c
c     file blktri.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 2004 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      FISHPACK version 5.0                   .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A C K                        *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (Version 5.0 , JUNE 2004)                    *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     SUBROUTINE BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y,
C    +                   IERROR,W)
C
C
C
C DIMENSION OF           AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N),
C ARGUMENTS
C
C LATEST REVISION        JUNE 2004
C
C USAGE                  CALL BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,
C                                     CM,IDIMY,Y,IERROR,W)
C
C PURPOSE                BLKTRI SOLVES A SYSTEM OF LINEAR EQUATIONS
C                        OF THE FORM
C
C                        AN(J)*X(I,J-1) + AM(I)*X(I-1,J) +
C                        (BN(J)+BM(I))*X(I,J) + CN(J)*X(I,J+1) +
C                        CM(I)*X(I+1,J) = Y(I,J)
C
C                        FOR I = 1,2,...,M  AND  J = 1,2,...,N.
C
C                        I+1 AND I-1 ARE EVALUATED MODULO M AND
C                        J+1 AND J-1 MODULO N, I.E.,
C
C                        X(I,0) = X(I,N),  X(I,N+1) = X(I,1),
C                        X(0,J) = X(M,J),  X(M+1,J) = X(1,J).
C
C                        THESE EQUATIONS USUALLY RESULT FROM THE
C                        DISCRETIZATION OF SEPARABLE ELLIPTIC
C                        EQUATIONS.  BOUNDARY CONDITIONS MAY BE
C                        DIRICHLET, NEUMANN, OR PERIODIC.
C
C ARGUMENTS
C
C ON INPUT               IFLG
C
C                          = 0  INITIALIZATION ONLY.
C                               CERTAIN QUANTITIES THAT DEPEND ON NP,
C                               N, AN, BN, AND CN ARE COMPUTED AND
C                               STORED IN DERIVED data type w (see
c                               description of w below)
C
C                          = 1  THE QUANTITIES THAT WERE COMPUTED
C                               IN THE INITIALIZATION ARE USED
C                               TO OBTAIN THE SOLUTION X(I,J).
C
C                               NOTE:
C                               A CALL WITH IFLG=0 TAKES
C                               APPROXIMATELY ONE HALF THE TIME
C                               AS A CALL WITH IFLG = 1.
C                               HOWEVER, THE INITIALIZATION DOES
C                               NOT HAVE TO BE REPEATED UNLESS NP,
C                               N, AN, BN, OR CN CHANGE.
C
C                        NP
C                          = 0  IF AN(1) AND CN(N) ARE NOT ZERO,
C                               WHICH CORRESPONDS TO PERIODIC
C                               BOUNARY CONDITIONS.
C
C                          = 1  IF AN(1) AND CN(N) ARE ZERO.
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE J-DIRECTION.
C                          N MUST BE GREATER THAN 4.
C                          THE OPERATION COUNT IS PROPORTIONAL TO
C                          MNLOG2(N), HENCE N SHOULD BE SELECTED
C                          LESS THAN OR EQUAL TO M.
C
C                        AN,BN,CN
C                          ONE-DIMENSIONAL ARRAYS OF LENGTH N
C                          THAT SPECIFY THE COEFFICIENTS IN THE
C                          LINEAR EQUATIONS GIVEN ABOVE.
C
C                        MP
C                          = 0  IF AM(1) AND CM(M) ARE NOT ZERO,
C                               WHICH CORRESPONDS TO PERIODIC
C                               BOUNDARY CONDITIONS.
C
C                          = 1  IF AM(1) = CM(M) = 0  .
C
C                        M
C                          THE NUMBER OF UNKNOWNS IN THE I-DIRECTION.
C                           M MUST BE GREATER THAN 4.
C
C                        AM,BM,CM
C                          ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT
C                          SPECIFY THE COEFFICIENTS IN THE LINEAR
C                          EQUATIONS GIVEN ABOVE.
C
C                        IDIMY
C                          THE ROW (OR FIRST) DIMENSION OF THE
C                          TWO-DIMENSIONAL ARRAY Y AS IT APPEARS
C                          IN THE PROGRAM CALLING BLKTRI.
C                          THIS PARAMETER IS USED TO SPECIFY THE
C                          VARIABLE DIMENSION OF Y.
C                          IDIMY MUST BE AT LEAST M.
C
C                        Y
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES
C                          THE VALUES OF THE RIGHT SIDE OF THE LINEAR
C                          SYSTEM OF EQUATIONS GIVEN ABOVE.
C                          Y MUST BE DIMENSIONED AT LEAST M*N.
C
C                        W
c                          A fortran 90 derived TYPE (fishworkspace) variable
c                          that must be declared by the user.  The first
c                          two declarative statements in the user program
c                          calling BLKTRI must be:
c
c                               USE fish
c                               TYPE (fishworkspace) :: W
c
c                          The first statement makes the fishpack module
c                          defined in the file "fish.f" available to the
c                          user program calling BLKTRI.  The second statement
c                          declares a derived type variable (defined in
c                          the module "fish.f") which is used internally
c                          in BLKTRI to dynamically allocate real and complex
c                          work space used in solution.  An error flag
c                          (IERROR = 20) is set if the required work space
c                          allocation fails (for example if N,M are too large)
c                          Real and complex values are set in the components
c                          of W on a initial (IFLG=0) call to BLKTRI.  These
c                          must be preserved on non-initial calls (IFLG=1)
c                          to BLKTRI.  This eliminates redundant calculations
c                          and saves compute time.
c               ****       IMPORTANT!  The user program calling BLKTRI should
c                          include the statement:
c
c                               CALL FISHFIN(W)
C
C                          after the final approximation is generated by
C                          BLKTRI.  The will deallocate the real and complex
c                          work space of W.  Failure to include this statement
c                          could result in serious memory leakage.
C
C
C ARGUMENTS
C
C ON OUTPUT              Y
C                          CONTAINS THE SOLUTION X.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID
C                          INPUT PARAMETERS.  EXCEPT FOR NUMBER ZER0,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                        = 0  NO ERROR.
C                        = 1  M IS LESS THAN 5
C                        = 2  N IS LESS THAN 5
C                        = 3  IDIMY IS LESS THAN M.
C                        = 4  BLKTRI FAILED WHILE COMPUTING RESULTS
C                             THAT DEPEND ON THE COEFFICIENT ARRAYS
C                             AN, BN, CN.  CHECK THESE ARRAYS.
C                        = 5  AN(J)*CN(J-1) IS LESS THAN 0 FOR SOME J.
C
C                             POSSIBLE REASONS FOR THIS CONDITION ARE
C                             1. THE ARRAYS AN AND CN ARE NOT CORRECT
C                             2. TOO LARGE A GRID SPACING WAS USED
C                                IN THE DISCRETIZATION OF THE ELLIPTIC
C                                EQUATION.
C                             3. THE LINEAR EQUATIONS RESULTED FROM A
C                                PARTIAL DIFFERENTIAL EQUATION WHICH
C                                WAS NOT ELLIPTIC.
C
C                        = 20 If the dynamic allocation of real and
C                             complex work space in the derived type
C                             (fishworkspace) variable W fails (e.g.,
c                             if N,M are too large for the platform used)
C
C
C                        W
c                             The derived type (fishworkspace) variable W
c                             contains real and complex values that must not
C                             be destroyed if BLKTRI is called again with
C                             IFLG=1.
C
C
C SPECIAL CONDITIONS     THE ALGORITHM MAY FAIL IF ABS(BM(I)+BN(J))
C                        IS LESS THAN ABS(AM(I))+ABS(AN(J))+
C                        ABS(CM(I))+ABS(CN(J))
C                        FOR SOME I AND J. THE ALGORITHM WILL ALSO
C                        FAIL IF AN(J)*CN(J-1) IS LESS THAN ZERO FOR
C                        SOME J.
C                        SEE THE DESCRIPTION OF THE OUTPUT PARAMETER
C                        IERROR.
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED FILES         fish.f,comf.f
C
C LANGUAGE               FORTRAN 90
C
C HISTORY                WRITTEN BY PAUL SWARZTRAUBER AT NCAR IN THE
C                        EARLY 1970'S.  REWRITTEN AND RELEASED IN
C                        LIBRARIES IN JANUARY 1980. Revised in June
C                        2004 using Fortan 90 dynamically allocated work
c                        space and derived data types to eliminate mixed
c                        mode conflicts in the earlier versions.
C
C ALGORITHM              GENERALIZED CYCLIC REDUCTION
C
C PORTABILITY            FORTRAN 90.  APPROXIMATE MACHINE ACCURACY
C                        IS COMPUTED IN FUNCTION EPMACH.
C
C REFERENCES             SWARZTRAUBER,P. AND R. SWEET, 'EFFICIENT
C                        FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C                        ELLIPTIC EQUATIONS'
C                        NCAR TN/IA-109, JULY, 1975, 138 PP.
C
C                        SWARZTRAUBER P. N.,A DIRECT METHOD FOR
C                        THE DISCRETE SOLUTION OF SEPARABLE
C                        ELLIPTIC EQUATIONS, S.I.A.M.
C                        J. NUMER. ANAL.,11(1974) PP. 1136-1150.
C***********************************************************************
      SUBROUTINE BLKTRI(IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM,
     1   IDIMY, Y, IERROR, W)
      USE fish
      Implicit none
      TYPE (fishworkspace) :: w
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  :: IFLG
      INTEGER  :: NP
      INTEGER  :: N
      INTEGER  :: MP
      INTEGER  :: M
      INTEGER  :: IDIMY
      INTEGER  :: IERROR
      REAL  :: AN(*)
      REAL  :: BN(*)
      REAL  :: CN(*)
      REAL  :: AM(*)
      REAL  :: BM(*)
      REAL  :: CM(*)
      REAL  :: Y(IDIMY,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: IRWK, ICWK
C-----------------------------------------------
      IF (M < 5) THEN
         IERROR = 1
         write(*,*) 'IERROR',IERROR
         RETURN
      ENDIF
      IF (N < 3) THEN
         IERROR = 2
         RETURN
      ENDIF
      IF (IDIMY < M) THEN
         IERROR = 3
         RETURN
      ENDIF
      IF (IFLG == 0) THEN
!     compute and allocate real and complex required work space
         CALL BLK_SPACE (N, M, IRWK, ICWK)
         CALL ALLOCATFISH (IRWK, ICWK, W, IERROR)
         IF (IERROR == 20) RETURN
      ENDIF
      call blktrii (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y,
     +             IERROR,w%rew,w%cxw)
      RETURN
      END SUBROUTINE BLKTRI

      SUBROUTINE BLKTRII(IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM,
     1   IDIMY, Y, IERROR, W, WC)
      Implicit none
      external prod,prodp,cprod,cprodp
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: IFLG
      INTEGER , INTENT(IN) :: NP
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: MP
      INTEGER  :: M
      INTEGER  :: IDIMY
      INTEGER  :: IERROR
      REAL  :: AN(*)
      REAL  :: BN(*)
      REAL  :: CN(*)
      REAL  :: AM(*)
      REAL  :: BM(*)
      REAL  :: CM(*)
      REAL  :: Y(IDIMY,*)
      REAL  :: W(*)
      COMPLEX  :: WC(*)
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /CBLKT/
      COMMON /CBLKT/ NPP, K, EPS, CNV, NM, NCMPLX, IK
      INTEGER   NPP, K, NM, NCMPLX, IK
      REAL   EPS, CNV
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: IW1, IW2, IW3, IWW, IWU, IWD, NL, NH, IWAH, IWBH

      SAVE IW1, IW2, IW3, IWW, IWU, IWD, NL
C-----------------------------------------------

C
C TEST M AND N FOR THE PROPER FORM
C
      NM = N
!     check again for solvers which call blktrii directly
      IF (M < 5) THEN
         IERROR = 1
         write(*,*) 'IERROR',IERROR
         RETURN
      ENDIF
      IF (NM < 3) THEN
         IERROR = 2
         RETURN
      ENDIF
      IF (IDIMY < M) THEN
         IERROR = 3
         RETURN
      ENDIF

      IF (IFLG == 0) THEN
         NH = N
         NPP = NP
         IF (NPP /= 0) THEN
            NH = NH + 1
         ENDIF
         IK = 2
         K = 1
         IK = IK + IK
         K = K + 1
         DO WHILE(NH - IK > 0)
            IK = IK + IK
            K = K + 1
         END DO
         NL = IK
         IK = IK + IK
         NL = NL - 1
         IWAH = (K - 2)*IK + K + 5
         IF (NPP == 0) THEN
            IWBH = IWAH + NM + NM
            IW1 = IWBH
            NM = N - 1
         ELSE
            IW1 = IWAH
            IWBH = IW1 + NM
         ENDIF
!     set pointers in real,complex work space
         IW2 = IW1 + M
         IW3 = IW2 + M
         IWD = IW3 + M
         IWW = IWD + M
         IWU = IWW + M
         CALL COMPB (NL, IERROR, AN, BN, CN, W, WC, W(IWAH), W(IWBH))
         RETURN
      ENDIF
! *** important to reset nm for np = 0
      IF (NPP == 0) NM = N - 1

      IF (MP /= 0) THEN
         CALL BLKTR1 (NL, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, W, WC, W(
     1      IW1), W(IW2), W(IW3), W(IWD), W(IWW), W(IWU), WC(IW1), WC(
     2      IW2), WC(IW3), PROD, CPROD)
      ELSE
         CALL BLKTR1 (NL, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, W, WC, W(
     1      IW1), W(IW2), W(IW3), W(IWD), W(IWW), W(IWU), WC(IW1), WC(
     2      IW2), WC(IW3), PRODP, CPRODP)
      ENDIF
      RETURN
      END SUBROUTINE BLKTRII

      SUBROUTINE BLKTR1(N, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, B, BC,
     1   W1, W2, W3, WD, WW, WU, CW1, CW2, CW3, PRDCT, CPRDCT)
      Implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  :: N
      INTEGER  :: M
      INTEGER , INTENT(IN) :: IDIMY
      REAL  :: AN(*)
      REAL  :: BN(*)
      REAL  :: CN(*)
      REAL  :: AM(*)
      REAL  :: BM(*)
      REAL  :: CM(*)
      REAL  :: Y(IDIMY,1)
      REAL  :: B(*)
      REAL  :: W1(*)
      REAL  :: W2(*)
      REAL  :: W3(*)
      REAL  :: WD(*)
      REAL  :: WW(*)
      REAL  :: WU(*)
      COMPLEX  :: BC(*)
      COMPLEX  :: CW1(*)
      COMPLEX  :: CW2(*)
      COMPLEX  :: CW3(*)
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /CBLKT/
      COMMON /CBLKT/ NPP, K, EPS, CNV, NM, NCMPLX, IK
      INTEGER   NPP, K, NM, NCMPLX, IK
      REAL   EPS, CNV
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: KDO, L, IR, I2, I1, I3, I4, IRM1, IM2, NM2, IM3, NM3,
     1   IM1, NM1, I0, IF, I, IPI1, IPI2, IPI3, IDXC, NC, IDXA, NA, IP2
     2   , NP2, IP1, NP1, IP3, NP3, J, IZ, NZ, IZR, LL, IFD, IP, NP,
     3   IMI1, IMI2
      REAL :: DUM
C-----------------------------------------------
C
C BLKTR1 SOLVES THE LINEAR SYSTEM
C
C B  CONTAINS THE ROOTS OF ALL THE B POLYNOMIALS
C W1,W2,W3,WD,WW,WU  ARE ALL WORKING ARRAYS
C PRDCT  IS EITHER PRODP OR PROD DEPENDING ON WHETHER THE BOUNDARY
C CONDITIONS IN THE M DIRECTION ARE PERIODIC OR NOT
C CPRDCT IS EITHER CPRODP OR CPROD WHICH ARE THE COMPLEX VERSIONS
C OF PRODP AND PROD. THESE ARE CALLED IN THE EVENT THAT SOME
C OF THE ROOTS OF THE B SUB P POLYNOMIAL ARE COMPLEX
C
C
C
C BEGIN REDUCTION PHASE
C
      KDO = K - 1
      DO L = 1, KDO
         IR = L - 1
         I2 = 2**IR
         I1 = I2/2
         I3 = I2 + I1
         I4 = I2 + I2
         IRM1 = IR - 1
         CALL INDXB (I2, IR, IM2, NM2)
         CALL INDXB (I1, IRM1, IM3, NM3)
         CALL INDXB (I3, IRM1, IM1, NM1)
         I0 = 0
         CALL PRDCT (NM2, B(IM2), NM3, B(IM3), NM1, B(IM1), I0, DUM, Y(1
     1      ,I2), W3, M, AM, BM, CM, WD, WW, WU)
         IF = 2**K
         DO I = I4, IF, I4
            IF (I - NM > 0) CYCLE
            IPI1 = I + I1
            IPI2 = I + I2
            IPI3 = I + I3
            CALL INDXC (I, IR, IDXC, NC)
            IF (I - IF >= 0) CYCLE
            CALL INDXA (I, IR, IDXA, NA)
            CALL INDXB (I - I1, IRM1, IM1, NM1)
            CALL INDXB (IPI2, IR, IP2, NP2)
            CALL INDXB (IPI1, IRM1, IP1, NP1)
            CALL INDXB (IPI3, IRM1, IP3, NP3)
            CALL PRDCT (NM1, B(IM1), 0, DUM, 0, DUM, NA, AN(IDXA), W3,
     1         W1, M, AM, BM, CM, WD, WW, WU)
            IF (IPI2 - NM > 0) THEN
               W3(:M) = 0.
               W2(:M) = 0.
            ELSE
               CALL PRDCT (NP2, B(IP2), NP1, B(IP1), NP3, B(IP3), 0, DUM
     1            , Y(1,IPI2), W3, M, AM, BM, CM, WD, WW, WU)
               CALL PRDCT (NP1, B(IP1), 0, DUM, 0, DUM, NC, CN(IDXC), W3
     1            , W2, M, AM, BM, CM, WD, WW, WU)
            ENDIF
            Y(:M,I) = W1(:M) + W2(:M) + Y(:M,I)
         END DO
      END DO
      IF (NPP == 0) THEN
         IF = 2**K
         I = IF/2
         I1 = I/2
         CALL INDXB (I - I1, K - 2, IM1, NM1)
         CALL INDXB (I + I1, K - 2, IP1, NP1)
         CALL INDXB (I, K - 1, IZ, NZ)
         CALL PRDCT (NZ, B(IZ), NM1, B(IM1), NP1, B(IP1), 0, DUM, Y(1,I)
     1      , W1, M, AM, BM, CM, WD, WW, WU)
         IZR = I
         W2(:M) = W1(:M)
         DO LL = 2, K
            L = K - LL + 1
            IR = L - 1
            I2 = 2**IR
            I1 = I2/2
            I = I2
            CALL INDXC (I, IR, IDXC, NC)
            CALL INDXB (I, IR, IZ, NZ)
            CALL INDXB (I - I1, IR - 1, IM1, NM1)
            CALL INDXB (I + I1, IR - 1, IP1, NP1)
            CALL PRDCT (NP1, B(IP1), 0, DUM, 0, DUM, NC, CN(IDXC), W1,
     1         W1, M, AM, BM, CM, WD, WW, WU)
            W1(:M) = Y(:M,I) + W1(:M)
            CALL PRDCT (NZ, B(IZ), NM1, B(IM1), NP1, B(IP1), 0, DUM, W1
     1         , W1, M, AM, BM, CM, WD, WW, WU)
         END DO
         L118: DO LL = 2, K
            L = K - LL + 1
            IR = L - 1
            I2 = 2**IR
            I1 = I2/2
            I4 = I2 + I2
            IFD = IF - I2
            DO I = I2, IFD, I4
               IF (I - I2 - IZR /= 0) CYCLE
               IF (I - NM > 0) CYCLE  L118
               CALL INDXA (I, IR, IDXA, NA)
               CALL INDXB (I, IR, IZ, NZ)
               CALL INDXB (I - I1, IR - 1, IM1, NM1)
               CALL INDXB (I + I1, IR - 1, IP1, NP1)
               CALL PRDCT (NM1, B(IM1), 0, DUM, 0, DUM, NA, AN(IDXA), W2
     1            , W2, M, AM, BM, CM, WD, WW, WU)
               W2(:M) = Y(:M,I) + W2(:M)
               CALL PRDCT (NZ, B(IZ), NM1, B(IM1), NP1, B(IP1), 0, DUM,
     1            W2, W2, M, AM, BM, CM, WD, WW, WU)
               IZR = I
               IF (I - NM == 0) EXIT  L118
            END DO
         END DO L118
  119    CONTINUE
         Y(:M,NM+1) = Y(:M,NM+1) - CN(NM+1)*W1(:M) - AN(NM+1)*W2(:M)
         CALL INDXB (IF/2, K - 1, IM1, NM1)
         CALL INDXB (IF, K - 1, IP, NP)
         IF (NCMPLX /= 0) THEN
            CALL CPRDCT (NM + 1, BC(IP), NM1, B(IM1), 0, DUM, 0, DUM, Y(
     1         1,NM+1), Y(1,NM+1), M, AM, BM, CM, CW1, CW2, CW3)
         ELSE
            CALL PRDCT (NM + 1, B(IP), NM1, B(IM1), 0, DUM, 0, DUM, Y(1,
     1         NM+1), Y(1,NM+1), M, AM, BM, CM, WD, WW, WU)
         ENDIF
         W1(:M) = AN(1)*Y(:M,NM+1)
         W2(:M) = CN(NM)*Y(:M,NM+1)
         Y(:M,1) = Y(:M,1) - W1(:M)
         Y(:M,NM) = Y(:M,NM) - W2(:M)
         DO L = 1, KDO
            IR = L - 1
            I2 = 2**IR
            I4 = I2 + I2
            I1 = I2/2
            I = I4
            CALL INDXA (I, IR, IDXA, NA)
            CALL INDXB (I - I2, IR, IM2, NM2)
            CALL INDXB (I - I2 - I1, IR - 1, IM3, NM3)
            CALL INDXB (I - I1, IR - 1, IM1, NM1)
            CALL PRDCT (NM2, B(IM2), NM3, B(IM3), NM1, B(IM1), 0, DUM,
     1         W1, W1, M, AM, BM, CM, WD, WW, WU)
            CALL PRDCT (NM1, B(IM1), 0, DUM, 0, DUM, NA, AN(IDXA), W1,
     1         W1, M, AM, BM, CM, WD, WW, WU)
            Y(:M,I) = Y(:M,I) - W1(:M)
         END DO
C
         IZR = NM
         L131: DO L = 1, KDO
            IR = L - 1
            I2 = 2**IR
            I1 = I2/2
            I3 = I2 + I1
            I4 = I2 + I2
            IRM1 = IR - 1
            DO I = I4, IF, I4
               IPI1 = I + I1
               IPI2 = I + I2
               IPI3 = I + I3
               IF (IPI2 - IZR /= 0) THEN
                  IF (I - IZR /= 0) CYCLE
                  CYCLE  L131
               ENDIF
               CALL INDXC (I, IR, IDXC, NC)
               CALL INDXB (IPI2, IR, IP2, NP2)
               CALL INDXB (IPI1, IRM1, IP1, NP1)
               CALL INDXB (IPI3, IRM1, IP3, NP3)
               CALL PRDCT (NP2, B(IP2), NP1, B(IP1), NP3, B(IP3), 0, DUM
     1            , W2, W2, M, AM, BM, CM, WD, WW, WU)
               CALL PRDCT (NP1, B(IP1), 0, DUM, 0, DUM, NC, CN(IDXC), W2
     1            , W2, M, AM, BM, CM, WD, WW, WU)
               Y(:M,I) = Y(:M,I) - W2(:M)
               IZR = I
               CYCLE  L131
            END DO
         END DO L131
      ENDIF
C
C BEGIN BACK SUBSTITUTION PHASE
C
      DO LL = 1, K
         L = K - LL + 1
         IR = L - 1
         IRM1 = IR - 1
         I2 = 2**IR
         I1 = I2/2
         I4 = I2 + I2
         IFD = IF - I2
         DO I = I2, IFD, I4
            IF (I - NM > 0) CYCLE
            IMI1 = I - I1
            IMI2 = I - I2
            IPI1 = I + I1
            IPI2 = I + I2
            CALL INDXA (I, IR, IDXA, NA)
            CALL INDXC (I, IR, IDXC, NC)
            CALL INDXB (I, IR, IZ, NZ)
            CALL INDXB (IMI1, IRM1, IM1, NM1)
            CALL INDXB (IPI1, IRM1, IP1, NP1)
            IF (I - I2 <= 0) THEN
               W1(:M) = 0.
            ELSE
               CALL PRDCT (NM1, B(IM1), 0, DUM, 0, DUM, NA, AN(IDXA), Y(
     1            1,IMI2), W1, M, AM, BM, CM, WD, WW, WU)
            ENDIF
            IF (IPI2 - NM > 0) THEN
               W2(:M) = 0.
            ELSE
               CALL PRDCT (NP1, B(IP1), 0, DUM, 0, DUM, NC, CN(IDXC), Y(
     1            1,IPI2), W2, M, AM, BM, CM, WD, WW, WU)
            ENDIF
            W1(:M) = Y(:M,I) + W1(:M) + W2(:M)
            CALL PRDCT (NZ, B(IZ), NM1, B(IM1), NP1, B(IP1), 0, DUM, W1
     1         , Y(1,I), M, AM, BM, CM, WD, WW, WU)
         END DO
      END DO
      RETURN
      END SUBROUTINE BLKTR1

      REAL FUNCTION BSRH (XLL, XRR, IZ, C, A, BH, F, SGN)
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  :: IZ
      REAL , INTENT(IN) :: XLL
      REAL , INTENT(IN) :: XRR
      REAL  :: F
      REAL , INTENT(IN) :: SGN
      REAL  :: C(*)
      REAL  :: A(*)
      REAL  :: BH(*)
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /CBLKT/
      COMMON /CBLKT/ NPP, K, EPS, CNV, NM, NCMPLX, IK
      INTEGER   NPP, K, NM, NCMPLX, IK
      REAL   EPS, CNV
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      REAL :: R1, XL, XR, DX, X
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
C-----------------------------------------------
      XL = XLL
      XR = XRR
      DX = 0.5*ABS(XR - XL)
      X = 0.5*(XL + XR)
      R1 = SGN*F(X,IZ,C,A,BH)
      IF (R1 >= 0.) THEN
         IF (R1 == 0.) GO TO 105
         XR = X
      ELSE
         XL = X
      ENDIF
      DX = 0.5*DX
      DO WHILE(DX - CNV > 0.)
         X = 0.5*(XL + XR)
         R1 = SGN*F(X,IZ,C,A,BH)
         IF (R1 >= 0.) THEN
            IF (R1 == 0.) GO TO 105
            XR = X
         ELSE
            XL = X
         ENDIF
         DX = 0.5*DX
      END DO
  105 CONTINUE
      BSRH = 0.5*(XL + XR)
      RETURN
      END FUNCTION BSRH

      SUBROUTINE COMPB(N, IERROR, AN, BN, CN, B, BC, AH, BH)
      implicit none
      real :: epmach
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER  :: N
      INTEGER  :: IERROR
      REAL  :: AN(*)
      REAL , INTENT(IN) :: BN(*)
      REAL  :: CN(*)
      REAL  :: B(*)
      REAL  :: AH(*)
      REAL  :: BH(*)
      COMPLEX  :: BC(*)
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /CBLKT/
      COMMON /CBLKT/ NPP, K, EPS, CNV, NM, NCMPLX, IK
      INTEGER   NPP, K, NM, NCMPLX, IK
      REAL   EPS, CNV
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: J, IF, KDO, L, IR, I2, I4, IPL, IFD, I, IB, NB, JS, JF
     1   , LS, LH, NMP, L1, L2, J2, J1, N2M2
      REAL :: DUM, BNORM, ARG, D1, D2, D3
C-----------------------------------------------
C
C     COMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS USING SUBROUTINE
C     TEVLS WHICH IS A MODIFICATION THE EISPACK PROGRAM TQLRAT.
C     IERROR IS SET TO 4 IF EITHER TEVLS FAILS OR IF A(J+1)*C(J) IS
C     LESS THAN ZERO FOR SOME J.  AH,BH ARE TEMPORARY WORK ARRAYS.
C
      EPS = EPMACH(DUM)
      BNORM = ABS(BN(1))
      DO J = 2, NM
         BNORM = AMAX1(BNORM,ABS(BN(J)))
         ARG = AN(J)*CN(J-1)
         IF (ARG < 0.) GO TO 119
         B(J) = SIGN(SQRT(ARG),AN(J))
      END DO
      CNV = EPS*BNORM
      IF = 2**K
      KDO = K - 1
      L108: DO L = 1, KDO
         IR = L - 1
         I2 = 2**IR
         I4 = I2 + I2
         IPL = I4 - 1
         IFD = IF - I4
         DO I = I4, IFD, I4
            CALL INDXB (I, L, IB, NB)
            IF (NB <= 0) CYCLE  L108
            JS = I - IPL
            JF = JS + NB - 1
            LS = 0
            BH(:JF-JS+1) = BN(JS:JF)
            AH(:JF-JS+1) = B(JS:JF)
            CALL TEVLS (NB, BH, AH, IERROR)
            IF (IERROR /= 0) GO TO 118
            LH = IB - 1
            IF (NB > 0) THEN
               B(LH+1:NB+LH) = -BH(:NB)
               LH = NB + LH
            ENDIF
         END DO
      END DO L108
      B(:NM) = -BN(:NM)
      IF (NPP == 0) THEN
         NMP = NM + 1
         NB = NM + NMP
         DO J = 1, NB
            L1 = MOD(J - 1,NMP) + 1
            L2 = MOD(J + NM - 1,NMP) + 1
            ARG = AN(L1)*CN(L2)
            IF (ARG < 0.) GO TO 119
            BH(J) = SIGN(SQRT(ARG),(-AN(L1)))
            AH(J) = -BN(L1)
         END DO
         CALL TEVLS (NB, AH, BH, IERROR)
         IF (IERROR /= 0) GO TO 118
         CALL INDXB (IF, K - 1, J2, LH)
         CALL INDXB (IF/2, K - 1, J1, LH)
         J2 = J2 + 1
         LH = J2
         N2M2 = J2 + NM + NM - 2
  114    CONTINUE
         D1 = ABS(B(J1)-B(J2-1))
         D2 = ABS(B(J1)-B(J2))
         D3 = ABS(B(J1)-B(J2+1))
         IF (D2>=D1 .OR. D2>=D3) THEN
            B(LH) = B(J2)
            J2 = J2 + 1
            LH = LH + 1
            IF (J2 - N2M2 <= 0) GO TO 114
         ELSE
            J2 = J2 + 1
            J1 = J1 + 1
            IF (J2 - N2M2 <= 0) GO TO 114
         ENDIF
         B(LH) = B(N2M2+1)
         CALL INDXB (IF, K - 1, J1, J2)
         J2 = J1 + NMP + NMP
         CALL PPADD (NM + 1, IERROR, AN, CN, BC(J1), B(J1), B(J2))
      ENDIF
      RETURN
  118 CONTINUE
      IERROR = 4
      RETURN
  119 CONTINUE
      IERROR = 5
      RETURN
      END SUBROUTINE COMPB

      SUBROUTINE CPROD(ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,YY,M,A,B,C,D,W,Y)
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: ND
      INTEGER , INTENT(IN) :: NM1
      INTEGER , INTENT(IN) :: NM2
      INTEGER , INTENT(IN) :: NA
      INTEGER , INTENT(IN) :: M
      REAL , INTENT(IN) :: BM1(*)
      REAL , INTENT(IN) :: BM2(*)
      REAL , INTENT(IN) :: AA(*)
      REAL , INTENT(IN) :: X(*)
      REAL , INTENT(OUT) :: YY(*)
      REAL , INTENT(IN) :: A(*)
      REAL , INTENT(IN) :: B(*)
      REAL , INTENT(IN) :: C(*)
      COMPLEX , INTENT(IN) :: BD(*)
      COMPLEX , INTENT(INOUT) :: D(*)
      COMPLEX , INTENT(INOUT) :: W(*)
      COMPLEX , INTENT(INOUT) :: Y(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: J, MM, ID, M1, M2, IA, IFLG, K
      REAL :: RT
      COMPLEX :: CRT, DEN, Y1, Y2
C-----------------------------------------------
C
C PROD APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN YY           (COMPLEX CASE)
C AA   ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X
C ND,NM1,NM2 ARE THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY
C BD,BM1,BM2 ARE ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS
C NA IS THE LENGTH OF THE ARRAY AA
C X,YY THE MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS YY
C A,B,C  ARE ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX
C M  IS THE ORDER OF THE MATRIX
C D,W,Y ARE WORKING ARRAYS
C ISGN  DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE
C
      DO J = 1, M
         Y(J) = CMPLX(X(J),0.)
      END DO
      MM = M - 1
      ID = ND
      M1 = NM1
      M2 = NM2
      IA = NA
  102 CONTINUE
      IFLG = 0
      IF (ID > 0) THEN
         CRT = BD(ID)
         ID = ID - 1
C
C BEGIN SOLUTION TO SYSTEM
C
         D(M) = A(M)/(B(M)-CRT)
         W(M) = Y(M)/(B(M)-CRT)
         DO J = 2, MM
            K = M - J
            DEN = B(K+1) - CRT - C(K+1)*D(K+2)
            D(K+1) = A(K+1)/DEN
            W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN
         END DO
         DEN = B(1) - CRT - C(1)*D(2)
         IF (CABS(DEN) /= 0.) THEN
            Y(1) = (Y(1)-C(1)*W(2))/DEN
         ELSE
            Y(1) = (1.,0.)
         ENDIF
         DO J = 2, M
            Y(J) = W(J) - D(J)*Y(J-1)
         END DO
      ENDIF
      IF (M1 <= 0) THEN
         IF (M2 <= 0) GO TO 121
         RT = BM2(M2)
         M2 = M2 - 1
      ELSE
         IF (M2 <= 0) THEN
            RT = BM1(M1)
            M1 = M1 - 1
         ELSE
            IF (ABS(BM1(M1)) - ABS(BM2(M2)) > 0.) THEN
               RT = BM1(M1)
               M1 = M1 - 1
            ELSE
               RT = BM2(M2)
               M2 = M2 - 1
            ENDIF
         ENDIF
      ENDIF
      Y1 = (B(1)-RT)*Y(1) + C(1)*Y(2)
      IF (MM - 2 >= 0) THEN
         DO J = 2, MM
            Y2 = A(J)*Y(J-1) + (B(J)-RT)*Y(J) + C(J)*Y(J+1)
            Y(J-1) = Y1
            Y1 = Y2
         END DO
      ENDIF
      Y(M) = A(M)*Y(M-1) + (B(M)-RT)*Y(M)
      Y(M-1) = Y1
      IFLG = 1
      GO TO 102
  121 CONTINUE
      IF (IA > 0) THEN
         RT = AA(IA)
         IA = IA - 1
         IFLG = 1
C
C SCALAR MULTIPLICATION
C
         Y(:M) = RT*Y(:M)
      ENDIF
      IF (IFLG > 0) GO TO 102
      DO J = 1, M
         YY(J) = REAL(Y(J))
      END DO
      RETURN
      END SUBROUTINE CPROD

      SUBROUTINE CPRODP(ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, YY, M, A
     1   , B, C, D, U, Y)
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: ND
      INTEGER , INTENT(IN) :: NM1
      INTEGER , INTENT(IN) :: NM2
      INTEGER , INTENT(IN) :: NA
      INTEGER , INTENT(IN) :: M
      REAL , INTENT(IN) :: BM1(*)
      REAL , INTENT(IN) :: BM2(*)
      REAL , INTENT(IN) :: AA(*)
      REAL , INTENT(IN) :: X(*)
      REAL , INTENT(OUT) :: YY(*)
      REAL , INTENT(IN) :: A(*)
      REAL , INTENT(IN) :: B(*)
      REAL , INTENT(IN) :: C(*)
      COMPLEX , INTENT(IN) :: BD(*)
      COMPLEX , INTENT(INOUT) :: D(*)
      COMPLEX , INTENT(INOUT) :: U(*)
      COMPLEX , INTENT(INOUT) :: Y(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: J, MM, MM2, ID, M1, M2, IA, IFLG, K
      REAL :: RT
      COMPLEX :: V, DEN, BH, YM, AM, Y1, Y2, YH, CRT
C-----------------------------------------------
C
C PRODP APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN YY       PERIODIC BOUNDARY CONDITIONS
C AND  COMPLEX  CASE
C
C BD,BM1,BM2 ARE ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS
C ND,NM1,NM2 ARE THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY
C AA   ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X
C NA IS THE LENGTH OF THE ARRAY AA
C X,YY THE MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS YY
C A,B,C  ARE ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX
C M  IS THE ORDER OF THE MATRIX
C D,U,Y ARE WORKING ARRAYS
C ISGN  DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE
C
      DO J = 1, M
         Y(J) = CMPLX(X(J),0.)
      END DO
      MM = M - 1
      MM2 = M - 2
      ID = ND
      M1 = NM1
      M2 = NM2
      IA = NA
  102 CONTINUE
      IFLG = 0
      IF (ID > 0) THEN
         CRT = BD(ID)
         ID = ID - 1
         IFLG = 1
C
C BEGIN SOLUTION TO SYSTEM
C
         BH = B(M) - CRT
         YM = Y(M)
         DEN = B(1) - CRT
         D(1) = C(1)/DEN
         U(1) = A(1)/DEN
         Y(1) = Y(1)/DEN
         V = CMPLX(C(M),0.)
         IF (MM2 - 2 >= 0) THEN
            DO J = 2, MM2
               DEN = B(J) - CRT - A(J)*D(J-1)
               D(J) = C(J)/DEN
               U(J) = -A(J)*U(J-1)/DEN
               Y(J) = (Y(J)-A(J)*Y(J-1))/DEN
               BH = BH - V*U(J-1)
               YM = YM - V*Y(J-1)
               V = -V*D(J-1)
            END DO
         ENDIF
         DEN = B(M-1) - CRT - A(M-1)*D(M-2)
         D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN
         Y(M-1) = (Y(M-1)-A(M-1)*Y(M-2))/DEN
         AM = A(M) - V*D(M-2)
         BH = BH - V*U(M-2)
         YM = YM - V*Y(M-2)
         DEN = BH - AM*D(M-1)
         IF (CABS(DEN) /= 0.) THEN
            Y(M) = (YM - AM*Y(M-1))/DEN
         ELSE
            Y(M) = (1.,0.)
         ENDIF
         Y(M-1) = Y(M-1) - D(M-1)*Y(M)
         DO J = 2, MM
            K = M - J
            Y(K) = Y(K) - D(K)*Y(K+1) - U(K)*Y(M)
         END DO
      ENDIF
      IF (M1 <= 0) THEN
         IF (M2 <= 0) GO TO 123
         RT = BM2(M2)
         M2 = M2 - 1
      ELSE
         IF (M2 <= 0) THEN
            RT = BM1(M1)
            M1 = M1 - 1
         ELSE
            IF (ABS(BM1(M1)) - ABS(BM2(M2)) > 0.) THEN
               RT = BM1(M1)
               M1 = M1 - 1
            ELSE
               RT = BM2(M2)
               M2 = M2 - 1
C
C MATRIX MULTIPLICATION
C
            ENDIF
         ENDIF
      ENDIF
      YH = Y(1)
      Y1 = (B(1)-RT)*Y(1) + C(1)*Y(2) + A(1)*Y(M)
      IF (MM - 2 >= 0) THEN
         DO J = 2, MM
            Y2 = A(J)*Y(J-1) + (B(J)-RT)*Y(J) + C(J)*Y(J+1)
            Y(J-1) = Y1
            Y1 = Y2
         END DO
      ENDIF
      Y(M) = A(M)*Y(M-1) + (B(M)-RT)*Y(M) + C(M)*YH
      Y(M-1) = Y1
      IFLG = 1
      GO TO 102
  123 CONTINUE
      IF (IA > 0) THEN
         RT = AA(IA)
         IA = IA - 1
         IFLG = 1
C
C SCALAR MULTIPLICATION
C
         Y(:M) = RT*Y(:M)
      ENDIF
      IF (IFLG > 0) GO TO 102
      DO J = 1, M
         YY(J) = REAL(Y(J))
      END DO
      RETURN
      END SUBROUTINE CPRODP

      SUBROUTINE INDXA(I, IR, IDXA, NA)
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: I
      INTEGER , INTENT(IN) :: IR
      INTEGER , INTENT(OUT) :: IDXA
      INTEGER , INTENT(OUT) :: NA
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /CBLKT/
      COMMON /CBLKT/ NPP, K, EPS, CNV, NM, NCMPLX, IK
      INTEGER   NPP, K, NM, NCMPLX, IK
      REAL   EPS, CNV
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
      NA = 2**IR
      IDXA = I - NA + 1
      IF (I - NM > 0) THEN
         NA = 0
      ENDIF
      RETURN
      END SUBROUTINE INDXA

      SUBROUTINE INDXB(I, IR, IDX, IDP)
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: I
      INTEGER , INTENT(IN) :: IR
      INTEGER , INTENT(OUT) :: IDX
      INTEGER , INTENT(OUT) :: IDP
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /CBLKT/
      COMMON /CBLKT/ NPP, K, EPS, CNV, NM, NCMPLX, IK
      INTEGER   NPP, K, NM, NCMPLX, IK
      REAL   EPS, CNV
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: IZH, ID, IPL
C-----------------------------------------------
C
C B(IDX) IS THE LOCATION OF THE FIRST ROOT OF THE B(I,IR) POLYNOMIAL
C
      IDP = 0
      IF (IR >= 0) THEN
         IF (IR <= 0) THEN
            IF (I - NM > 0) GO TO 107
            IDX = I
            IDP = 1
            RETURN
         ENDIF
         IZH = 2**IR
         ID = I - IZH - IZH
         IDX = ID + ID + (IR - 1)*IK + IR + (IK - I)/IZH + 4
         IPL = IZH - 1
         IDP = IZH + IZH - 1
         IF (I - IPL - NM > 0) THEN
            IDP = 0
            RETURN
         ENDIF
         IF (I + IPL - NM > 0) THEN
            IDP = NM + IPL - I + 1
         ENDIF
      ENDIF
  107 CONTINUE
      RETURN
      END SUBROUTINE INDXB

      SUBROUTINE INDXC(I, IR, IDXC, NC)
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: I
      INTEGER , INTENT(IN) :: IR
      INTEGER , INTENT(OUT) :: IDXC
      INTEGER , INTENT(OUT) :: NC
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /CBLKT/
      COMMON /CBLKT/ NPP, K, EPS, CNV, NM, NCMPLX, IK
      INTEGER   NPP, K, NM, NCMPLX, IK
      REAL   EPS, CNV
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
      NC = 2**IR
      IDXC = I
      IF (IDXC + NC - 1 - NM > 0) THEN
         NC = 0
      ENDIF
      RETURN
      END SUBROUTINE INDXC

      SUBROUTINE PPADD(N, IERROR, A, C, CBP, BP, BH)
      implicit none
      external psgf,ppspf,ppsgf,bsrh
      real psgf,ppspf,ppsgf,bsrh
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(OUT) :: IERROR
      REAL  :: A(*)
      REAL  :: C(*)
      REAL , INTENT(INOUT) :: BP(*)
      REAL  :: BH(*)
      COMPLEX , INTENT(INOUT) :: CBP(*)
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /CBLKT/
      COMMON /CBLKT/ NPP, K, EPS, CNV, NM, NCMPLX, IK
      INTEGER   NPP, K, NM, NCMPLX, IK
      REAL   EPS, CNV
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER::IZ,IZM,IZM2,J,NT,MODIZ,IS,IF,IG,IT,ICV,I3,I2,NHALF
      REAL :: R4, R5, R6, SCNV, XL, DB, SGN, XR, XM, PSG
      COMPLEX :: CF, CX, FSG, HSG, DD, F, FP, FPP, CDIS, R1, R2, R3
C-----------------------------------------------
C
C     PPADD COMPUTES THE EIGENVALUES OF THE PERIODIC TRIDIAGONAL MATRIX
C     WITH COEFFICIENTS AN,BN,CN
C
C N IS THE ORDER OF THE BH AND BP POLYNOMIALS
C     ON OUTPUT BP CONTIANS THE EIGENVALUES
C CBP IS THE SAME AS BP EXCEPT TYPE COMPLEX
C BH IS USED TO TEMPORARILY STORE THE ROOTS OF THE B HAT POLYNOMIAL
C WHICH ENTERS THROUGH BP
C
      SCNV = SQRT(CNV)
      IZ = N
      IZM = IZ - 1
      IZM2 = IZ - 2
      IF (BP(N) - BP(1) <= 0.) THEN
         IF (BP(N) - BP(1) == 0.) GO TO 142
         BH(:N) = BP(N:1:(-1))
      ELSE
         BH(:N) = BP(:N)
      ENDIF
      NCMPLX = 0
      MODIZ = MOD(IZ,2)
      IS = 1
      IF (MODIZ /= 0) THEN
         IF (A(1) < 0.) GO TO 110
         IF (A(1) == 0.) GO TO 142
      ENDIF
      XL = BH(1)
      DB = BH(3) - BH(1)
      XL = XL - DB
      R4 = PSGF(XL,IZ,C,A,BH)
      DO WHILE(R4 <= 0.)
         XL = XL - DB
         R4 = PSGF(XL,IZ,C,A,BH)
      END DO
      SGN = -1.
      CBP(1) = CMPLX(BSRH(XL,BH(1),IZ,C,A,BH,PSGF,SGN),0.)
      BP(1) = REAL(CBP(1))
      IS = 2
  110 CONTINUE
      IF = IZ - 1
      IF (MODIZ /= 0) THEN
         IF (A(1) > 0.) GO TO 115
         IF (A(1) == 0.) GO TO 142
      ENDIF
      XR = BH(IZ)
      DB = BH(IZ) - BH(IZ-2)
      XR = XR + DB
      R5 = PSGF(XR,IZ,C,A,BH)
      DO WHILE(R5 < 0.)
         XR = XR + DB
         R5 = PSGF(XR,IZ,C,A,BH)
      END DO
      SGN = 1.
      CBP(IZ) = CMPLX(BSRH(BH(IZ),XR,IZ,C,A,BH,PSGF,SGN),0.)
      IF = IZ - 2
  115 CONTINUE
      DO IG = IS, IF, 2
         XL = BH(IG)
         XR = BH(IG+1)
         SGN = -1.
         XM = BSRH(XL,XR,IZ,C,A,BH,PPSPF,SGN)
         PSG = PSGF(XM,IZ,C,A,BH)
         IF (ABS(PSG) - EPS <= 0.) GO TO 118
         R6 = PSG*PPSGF(XM,IZ,C,A,BH)
         IF (R6 > 0.) GO TO 119
         IF (R6 == 0.) GO TO 118
         SGN = 1.
         CBP(IG) = CMPLX(BSRH(BH(IG),XM,IZ,C,A,BH,PSGF,SGN),0.)
c        bp(ig) = real(cbp(ig))
         SGN = -1.
         CBP(IG+1) = CMPLX(BSRH(XM,BH(IG+1),IZ,C,A,BH,PSGF,SGN),0.)
c        bp(ig) = real(cbp(ig))
c        bp(ig+1) = real(cbp(ig+1))
         CYCLE
C
C     CASE OF A MULTIPLE ZERO
C
  118    CONTINUE
         CBP(IG) = CMPLX(XM,0.)
         CBP(IG+1) = CMPLX(XM,0.)
c        bp(ig) = real(cbp(ig))
c        bp(ig+1) = real(cbp(ig+1))
         CYCLE
C
C     CASE OF A COMPLEX ZERO
C
  119    CONTINUE
         IT = 0
         ICV = 0
         CX = CMPLX(XM,0.)
  120    CONTINUE
         FSG = (1.,0.)
         HSG = (1.,0.)
         FP = (0.,0.)
         FPP = (0.,0.)
         DO J = 1, IZ
            DD = 1./(CX - BH(J))
            FSG = FSG*A(J)*DD
            HSG = HSG*C(J)*DD
            FP = FP + DD
            FPP = FPP - DD*DD
         END DO
         IF (MODIZ == 0) THEN
            F = (1.,0.) - FSG - HSG
         ELSE
            F = (1.,0.) + FSG + HSG
         ENDIF
         I3 = 0
         IF (CABS(FP) > 0.) THEN
            I3 = 1
            R3 = -F/FP
         ENDIF
         I2 = 0
         IF (CABS(FPP) > 0.) THEN
            I2 = 1
            CDIS = CSQRT(FP**2 - 2.*F*FPP)
            R1 = CDIS - FP
            R2 = (-FP) - CDIS
            IF (CABS(R1) - CABS(R2) > 0.) THEN
               R1 = R1/FPP
            ELSE
               R1 = R2/FPP
            ENDIF
            R2 = 2.*F/FPP/R1
            IF (CABS(R2) < CABS(R1)) R1 = R2
            IF (I3 <= 0) GO TO 133
            IF (CABS(R3) < CABS(R1)) R1 = R3
            GO TO 133
         ENDIF
         R1 = R3
  133    CONTINUE
         CX = CX + R1
         IT = IT + 1
         IF (IT > 50) GO TO 142
         IF (CABS(R1) > SCNV) GO TO 120
         IF (ICV > 0) GO TO 135
         ICV = 1
         GO TO 120
  135    CONTINUE
         CBP(IG) = CX
         CBP(IG+1) = CONJG(CX)
      END DO
      IF (CABS(CBP(N)) - CABS(CBP(1)) <= 0.) THEN
         IF (CABS(CBP(N)) - CABS(CBP(1)) == 0.) GO TO 142
         NHALF = N/2
         DO J = 1, NHALF
            NT = N - J
            CX = CBP(J)
            CBP(J) = CBP(NT+1)
            CBP(NT+1) = CX
         END DO
      ENDIF
      NCMPLX = 1
      DO J = 2, IZ
         IF (AIMAG(CBP(J)) /= 0.) GO TO 143
      END DO
      NCMPLX = 0
      BP(1) = REAL(CBP(1))
      DO J = 2, IZ
         BP(J) = REAL(CBP(J))
      END DO
      GO TO 143
  142 CONTINUE
      IERROR = 4
  143 CONTINUE
      RETURN
      END SUBROUTINE PPADD

      SUBROUTINE PROD(ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,Y,M,A,B,C,D,W,U)
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: ND
      INTEGER , INTENT(IN) :: NM1
      INTEGER , INTENT(IN) :: NM2
      INTEGER , INTENT(IN) :: NA
      INTEGER , INTENT(IN) :: M
      REAL , INTENT(IN) :: BD(*)
      REAL , INTENT(IN) :: BM1(*)
      REAL , INTENT(IN) :: BM2(*)
      REAL , INTENT(IN) :: AA(*)
      REAL , INTENT(IN) :: X(*)
      REAL , INTENT(INOUT) :: Y(*)
      REAL , INTENT(IN) :: A(*)
      REAL , INTENT(IN) :: B(*)
      REAL , INTENT(IN) :: C(*)
      REAL , INTENT(INOUT) :: D(*)
      REAL , INTENT(INOUT) :: W(*)
      REAL  :: U(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: J, MM, ID, IBR, M1, M2, IA, K
      REAL :: RT, DEN
C-----------------------------------------------
C
C PROD APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN Y
C BD,BM1,BM2 ARE ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS
C ND,NM1,NM2 ARE THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY
C AA   ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X
C NA IS THE LENGTH OF THE ARRAY AA
C X,Y  THE MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS Y
C A,B,C  ARE ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX
C M  IS THE ORDER OF THE MATRIX
C D,W,U ARE WORKING ARRAYS
C IS  DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE
C
      W(:M) = X(:M)
      Y(:M) = W(:M)
      MM = M - 1
      ID = ND
      IBR = 0
      M1 = NM1
      M2 = NM2
      IA = NA
  102 CONTINUE
      IF (IA > 0) THEN
         RT = AA(IA)
         IF (ND == 0) RT = -RT
         IA = IA - 1
C
C SCALAR MULTIPLICATION
C
         Y(:M) = RT*W(:M)
      ENDIF
      IF (ID <= 0) GO TO 125
      RT = BD(ID)
      ID = ID - 1
      IF (ID == 0) IBR = 1
C
C BEGIN SOLUTION TO SYSTEM
C
      D(M) = A(M)/(B(M)-RT)
      W(M) = Y(M)/(B(M)-RT)
      DO J = 2, MM
         K = M - J
         DEN = B(K+1) - RT - C(K+1)*D(K+2)
         D(K+1) = A(K+1)/DEN
         W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN
      END DO
      DEN = B(1) - RT - C(1)*D(2)
      W(1) = 1.
      IF (DEN /= 0.) THEN
         W(1) = (Y(1)-C(1)*W(2))/DEN
      ENDIF
      DO J = 2, M
         W(J) = W(J) - D(J)*W(J-1)
      END DO
      IF (NA > 0) GO TO 102
      GO TO 113
  111 CONTINUE
      Y(:M) = W(:M)
      IBR = 1
      GO TO 102
  113 CONTINUE
      IF (M1 <= 0) THEN
         IF (M2 <= 0) GO TO 111
      ELSE
         IF (M2 > 0) THEN
            IF (ABS(BM1(M1)) - ABS(BM2(M2)) <= 0.) GO TO 120
         ENDIF
         IF (IBR <= 0) THEN
            IF (ABS(BM1(M1)-BD(ID)) - ABS(BM1(M1)-RT) < 0.) GO TO 111
         ENDIF
         RT = RT - BM1(M1)
         M1 = M1 - 1
         GO TO 123
      ENDIF
  120 CONTINUE
      IF (IBR <= 0) THEN
         IF (ABS(BM2(M2)-BD(ID)) - ABS(BM2(M2)-RT) < 0.) GO TO 111
      ENDIF
      RT = RT - BM2(M2)
      M2 = M2 - 1
  123 CONTINUE
      Y(:M) = Y(:M) + RT*W(:M)
      GO TO 102
  125 CONTINUE
      RETURN
      END SUBROUTINE PROD

      SUBROUTINE PRODP(ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,Y,M,A,B,C,D,U,W)
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: ND
      INTEGER , INTENT(IN) :: NM1
      INTEGER , INTENT(IN) :: NM2
      INTEGER , INTENT(IN) :: NA
      INTEGER , INTENT(IN) :: M
      REAL , INTENT(IN) :: BD(*)
      REAL , INTENT(IN) :: BM1(*)
      REAL , INTENT(IN) :: BM2(*)
      REAL , INTENT(IN) :: AA(*)
      REAL , INTENT(IN) :: X(*)
      REAL , INTENT(INOUT) :: Y(*)
      REAL , INTENT(IN) :: A(*)
      REAL , INTENT(IN) :: B(*)
      REAL , INTENT(IN) :: C(*)
      REAL , INTENT(INOUT) :: D(*)
      REAL , INTENT(INOUT) :: U(*)
      REAL , INTENT(INOUT) :: W(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: J, MM, MM2, ID, IBR, M1, M2, IA, K
      REAL :: RT, BH, YM, DEN, V, AM
C-----------------------------------------------
C
C PRODP APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN Y        PERIODIC BOUNDARY CONDITIONS
C
C BD,BM1,BM2 ARE ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS
C ND,NM1,NM2 ARE THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY
C AA   ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X
C NA IS THE LENGTH OF THE ARRAY AA
C X,Y  THE MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS Y
C A,B,C  ARE ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX
C M  IS THE ORDER OF THE MATRIX
C D,U,W ARE WORKING ARRAYS
C IS  DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE
C

      Y(:M) = X(:M)
      W(:M) = Y(:M)
      MM = M - 1
      MM2 = M - 2
      ID = ND
      IBR = 0
      M1 = NM1
      M2 = NM2
      IA = NA
  102 CONTINUE
      IF (IA > 0) THEN
         RT = AA(IA)
         IF (ND == 0) RT = -RT
         IA = IA - 1
         Y(:M) = RT*W(:M)
      ENDIF
      IF (ID <= 0) GO TO 128
      RT = BD(ID)
      ID = ID - 1
      IF (ID == 0) IBR = 1
C
C BEGIN SOLUTION TO SYSTEM
C
      BH = B(M) - RT
      YM = Y(M)
      DEN = B(1) - RT
      D(1) = C(1)/DEN
      U(1) = A(1)/DEN
      W(1) = Y(1)/DEN
      V = C(M)
      IF (MM2 - 2 >= 0) THEN
         DO J = 2, MM2
            DEN = B(J) - RT - A(J)*D(J-1)
            D(J) = C(J)/DEN
            U(J) = -A(J)*U(J-1)/DEN
            W(J) = (Y(J)-A(J)*W(J-1))/DEN
            BH = BH - V*U(J-1)
            YM = YM - V*W(J-1)
            V = -V*D(J-1)
         END DO
      ENDIF
      DEN = B(M-1) - RT - A(M-1)*D(M-2)
      D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN
      W(M-1) = (Y(M-1)-A(M-1)*W(M-2))/DEN
      AM = A(M) - V*D(M-2)
      BH = BH - V*U(M-2)
      YM = YM - V*W(M-2)
      DEN = BH - AM*D(M-1)
      IF (DEN /= 0.) THEN
         W(M) = (YM - AM*W(M-1))/DEN
      ELSE
         W(M) = 1.
      ENDIF
      W(M-1) = W(M-1) - D(M-1)*W(M)
      DO J = 2, MM
         K = M - J
         W(K) = W(K) - D(K)*W(K+1) - U(K)*W(M)
      END DO
      IF (NA > 0) GO TO 102
      GO TO 116
  114 CONTINUE
      Y(:M) = W(:M)
      IBR = 1
      GO TO 102
  116 CONTINUE
      IF (M1 <= 0) THEN
         IF (M2 <= 0) GO TO 114
      ELSE
         IF (M2 > 0) THEN
            IF (ABS(BM1(M1)) - ABS(BM2(M2)) <= 0.) GO TO 123
         ENDIF
         IF (IBR <= 0) THEN
            IF (ABS(BM1(M1)-BD(ID)) - ABS(BM1(M1)-RT) < 0.) GO TO 114
         ENDIF
         RT = RT - BM1(M1)
         M1 = M1 - 1
         GO TO 126
      ENDIF
  123 CONTINUE
      IF (IBR <= 0) THEN
         IF (ABS(BM2(M2)-BD(ID)) - ABS(BM2(M2)-RT) < 0.) GO TO 114
      ENDIF
      RT = RT - BM2(M2)
      M2 = M2 - 1
  126 CONTINUE
      Y(:M) = Y(:M) + RT*W(:M)
      GO TO 102
  128 CONTINUE
      RETURN
      END SUBROUTINE PRODP

      SUBROUTINE TEVLS(N, D, E2, IERR)
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(OUT) :: IERR
      REAL , INTENT(INOUT) :: D(N)
      REAL , INTENT(INOUT) :: E2(N)
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /CBLKT/
      COMMON /CBLKT/ NPP, K, MACHEP, CNV, NM, NCMPLX, IK
      INTEGER   NPP, K, NM, NCMPLX, IK
      REAL   MACHEP, CNV
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I, J, L, M, II, L1, MML, NHALF, NTOP
      REAL :: B, C, F, G, H, P, R, S, DHOLD
C-----------------------------------------------
C
C
C     REAL SQRT,ABS,SIGN
C
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE EISPACK SUBROUTINE TQLRAT
C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E2 CONTAINS THE                SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        E2 HAS BEEN DESTROYED,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C                **********
C
      IERR = 0
      IF (N /= 1) THEN
C
         E2(:N-1) = E2(2:N)*E2(2:N)
C
         F = 0.0
         B = 0.0
         E2(N) = 0.0
C
         DO L = 1, N
            J = 0
            H = MACHEP*(ABS(D(L))+SQRT(E2(L)))
            IF (B <= H) THEN
               B = H
               C = B*B
            ENDIF
C
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
C
            DO M = L, N
               IF (E2(M) > C) CYCLE
               EXIT
C
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
C
            END DO
C
            IF (M /= L) THEN
  105          CONTINUE
               IF (J == 30) GO TO 114
               J = J + 1
C
C     ********** FORM SHIFT **********
C
               L1 = L + 1
               S = SQRT(E2(L))
               G = D(L)
               P = (D(L1)-G)/(2.0*S)
               R = SQRT(P*P + 1.0)
               D(L) = S/(P + SIGN(R,P))
               H = G - D(L)
C
               D(L1:N) = D(L1:N) - H
C
               F = F + H
C
C     ********** RATIONAL QL TRANSFORMATION **********
C
               G = D(M)
               IF (G == 0.0) G = B
               H = G
               S = 0.0
               MML = M - L
C
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
C
               DO II = 1, MML
                  I = M - II
                  P = G*H
                  R = P + E2(I)
                  E2(I+1) = S*R
                  S = E2(I)/R
                  D(I+1) = H + S*(H + D(I))
                  G = D(I) - E2(I)/G
                  IF (G == 0.0) G = B
                  H = G*P/R
               END DO
C
               E2(L) = S*G
               D(L) = H
C
C     ********** GUARD AGAINST UNDERFLOWED H **********
C
               IF (H == 0.0) GO TO 108
               IF (ABS(E2(L)) <= ABS(C/H)) GO TO 108
               E2(L) = H*E2(L)
               IF (E2(L) /= 0.0) GO TO 105
            ENDIF
  108       CONTINUE
            P = D(L) + F
C
C     ********** ORDER EIGENVALUES **********
C
            IF (L /= 1) THEN
C
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
C
               DO II = 2, L
                  I = L + 2 - II
                  IF (P >= D(I-1)) GO TO 111
                  D(I) = D(I-1)
               END DO
            ENDIF
C
            I = 1
  111       CONTINUE
            D(I) = P
         END DO
C
         IF (ABS(D(N)) >= ABS(D(1))) GO TO 115
         NHALF = N/2
         DO I = 1, NHALF
            NTOP = N - I
            DHOLD = D(I)
            D(I) = D(NTOP+1)
            D(NTOP+1) = DHOLD
         END DO
         GO TO 115
C
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
C
  114    CONTINUE
         IERR = L
      ENDIF
  115 CONTINUE
      RETURN
C
C     ********** LAST CARD OF TQLRAT **********
C
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
c June      2004    Version 5.0, Fortran 90 changes
C-----------------------------------------------------------------------
      END SUBROUTINE TEVLS


! public
! ACORN random number generation module.
! Author: John Manchuk, 2010
!
! function ACORNI originally from GSLIB (Deutsch, C.V., 1992)
!
! This was created so that multiple independent instatiations of the ACORN
! RNG could be implemented within the same program
!
module acorn_rng
    implicit none

    public :: acorninit, & !initialize an RNG with a seed (must be called first)
              acorni, &    !generate a random number
              acorniperm    !generate a random permutation

    type, public :: acorn_type
        integer :: KORDEI = 12
        integer :: MAXOP1 = 13 !KORDEI + 1
        real*8  :: MAXINT = 2**30
        integer :: ixv(13)
    end type acorn_type

    contains

    real*8 function acorni( acorn )
    !-----------------------------------------------------------------------
    ! Fortran implementation of ACORN random number generator of order less
    ! than or equal to 12 (higher orders can be obtained by increasing the
    ! parameter value MAXORD).
    ! NOTES: 1. The variable idum is a dummy variable. The common block
    !           IACO is used to transfer data into the function.
    !        2. Before the first call to ACORN the common block IACO must
    !           be initialised by the user, as follows. The values of
    !           variables in the common block must not subsequently be
    !           changed by the user.
    !
    !             KORDEI - order of generator required ( must be =< MAXORD)
    !             MAXINT - modulus for generator, must be chosen small
    !                      enough that 2*MAXINT does not overflow
    !             ixv(1) - seed for random number generator
    !                      require 0 < ixv(1) < MAXINT
    !             (ixv(I+1),I=1,KORDEI)
    !                    - KORDEI initial values for generator
    !                      require 0 =< ixv(I+1) < MAXINT
    !        3. After initialisation, each call to ACORN generates a single
    !           random number between 0 and 1.
    !        4. An example of suitable values for parameters is
    !             KORDEI   = 10
    !             MAXINT   = 2**30
    !             ixv(1)   = an odd integer in the (approximate) range
    !                        (0.001 * MAXINT) to (0.999 * MAXINT)
    !             ixv(I+1) = 0, I=1,KORDEI
    ! Author: R.S.Wikramaratna,                           Date: October 1990
    !-----------------------------------------------------------------------
        type(acorn_type), intent (inout) :: acorn
        integer :: i

        do i = 1, acorn%KORDEI
            acorn%ixv(i+1) = acorn%ixv(i+1) + acorn%ixv(i)
            if(acorn%ixv(i+1) >= acorn%MAXINT)then
                acorn%ixv(i+1) = acorn%ixv(i+1) - acorn%MAXINT
            endif
        end do

        acorni = real(acorn%ixv(acorn%MAXOP1), 8) / acorn%MAXINT
        return
    end function acorni

    !Initialize a random number generator
    subroutine acorninit(acorn,seed)
        type(acorn_type), intent (inout) :: acorn
        integer, intent (in) :: seed
        integer :: i
        real*8 :: p
        acorn%ixv = 0
        acorn%ixv(1) = seed
        do i = 1,seed
            p = acorni(acorn)
        enddo
        return
    end subroutine acorninit

    !Generate a random permutation
    subroutine acorniperm ( acorn, perm )
        type(acorn_type), intent (inout) :: acorn
        integer, intent (inout) :: perm(:)
        integer :: i, j, i0, i1, n

        n = ubound(perm,1)
        perm = 0
        do i = 1, n
            j = nint(acorni(acorn) * n)
            if(j < 1)then
                j = 1
            elseif(j > n)then
                j = n
            endif
            if(perm(j) /= 0)then
                i0 = j
                i1 = j
                do
                    if(i0 > 1)then
                        i0 = i0 - 1
                        if(perm(i0) < 1)then
                            perm(i0) = i
                            exit
                        endif
                    endif
                    if(i1 < n)then
                        i1 = i1 + 1
                        if(perm(i1) < 1)then
                            perm(i1) = i
                            exit
                        endif
                    endif
                enddo
            else
                perm(j) = i
            endif
        enddo

        return
    end subroutine acorniperm

end module acorn_rng


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program lonlat2xyz
!===============================================================================
!  Reads sets of lon,lat(,radius) from stdin and writes out x,y,z

   use spherical_geometry, only: geog2cart

   implicit none

   real(8) :: lon, lat, r, x, y, z, val
   character(len=250) :: arg
   integer :: iostat
   logical :: fixed_rad = .false., value = .false.

!  Check input arguments
   call get_args

   ! Get coordinates from stdin
   iostat = 0
   do while (iostat == 0)
      if (fixed_rad) then
         if (value) then
            read(*,*,iostat=iostat) lon, lat, val
         else
            read(*,*,iostat=iostat) lon, lat
         endif
      else
         if (value) then
            read(*,*,iostat=iostat) lon, lat, r, val
         else
            read(*,*,iostat=iostat) lon, lat, r
         endif
      endif
      if (iostat < 0) exit
      if (iostat > 0) then
         write(0,'(a)') 'lonlat2xyz: problem reading coordinates from stdin.'
         stop 1
      endif
      call geog2cart(lon, lat, r, x, y, z, degrees=.true.)
      if (value) then
         write(*,*) x, y, z, val
      else
         write(*,*) x, y, z
      endif
   enddo

contains
   !===============================================================================
   subroutine get_args()
   !===============================================================================
      integer :: iarg, narg
      narg = command_argument_count()
      iarg = 1
      do while (iarg <= narg)
         call get_command_argument(iarg, arg)
         select case(arg)
            case('-r')
               if (narg < iarg + 1) call usage
               call get_command_argument(iarg+1, arg)
               read(arg,*,iostat=iostat) r
               if (iostat /= 0) then
                  write(0,'(a)') 'lonlat2xyz: Error: Can''t read radius from ' &
                     // 'argument "' // trim(arg) // '"'
                  stop 1
               endif
               fixed_rad = .true.
               iarg = iarg + 2
            case('-v')
               value = .true.
               iarg = iarg + 1
            case('-h')
               call usage
            case default
               call usage
         end select
      enddo
   end subroutine get_args
   !-------------------------------------------------------------------------------

   !===============================================================================
   subroutine usage()
   !===============================================================================
      write(0,'(a)') &
         'Usage: lonlat2xyz (options) < [lon] [lat] [radius] (value)', &
         'Reads geographic coordinates from stdin and writes cartesian to stdout.', &
         'Options:', &
         '   -v          : Output the value in the third/fourth column', &
         '   -r [radius] : Fix radius.  If not present, r must be on stdin.'
      stop 1
   end subroutine usage
   !-------------------------------------------------------------------------------

end program lonlat2xyz
!-------------------------------------------------------------------------------


	FUNCTION PR_COMX  ( clhx, clcx )
C************************************************************************
C* PR_COMX								*
C*									*
C* This function computes COMX, the combined cloud height and coverage,	*
C* from CLHX and CLCX.  The following equation is used:			*
C*									*
C*               COMX = ( CLHX * 10 ) + CLCX				*
C*									*
C* REAL PR_COMX  ( CLHX, CLCX )						*
C*									*
C* Input parameters:							*
C*	CLHX		REAL		Cloud height			*
C*	CLCX 		REAL		Cloud coverage			*
C*									*
C* Output parameters:							*
C*	PR_COMX		REAL		Combined height & coverage	*
C**									*
C* Log:									*
C* I. Graffman/RDS	12/84						*
C* M. desJardins/GSFC	10/87						*
C* G. Huffman/GSC	7/88	Documentation; allow -X, no height	*
C* S. Schotz/GSC	10/88   Multiply height by 10 instead of 100	*
C*                              also check for clear case		*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for clear case
C
	IF ( clcx .eq. 1 ) THEN
            PR_COMX = clcx
C
C*	  Check for obscured clouds with missing height; return cloud
C*	  coverage only.
C
	  ELSE IF  ( ( ( clcx .eq. 5 ) .or. ( clcx .eq. 9 ) )
     *        .and. ( ERMISS ( clhx ) ) )  THEN
	    PR_COMX = clcx
C
C*	  Check for missing or invalid data.
C
	  ELSE IF  ( ( clhx .lt. 0. ) .or. ( ERMISS ( clhx ) ) )  THEN
	    PR_COMX = RMISSD
 	  ELSE
C
C*	    Combine data by multiplying height by 10 and adding clouds.
C*          Missing cloud amounts are given the value 0 (clear).
C
	    iclhx = clhx
	    iclcx = clcx
	    IF  ( ( iclcx .lt. 0 ) .or. ( iclcx .gt. 9 ) )  iclcx = 0
	    PR_COMX  = ( iclhx * 10 ) + iclcx
	END IF
C*
	RETURN
	END


c_________________________________________________________
c
      subroutine rbstrn(z,nbt,nch,ldf,rdf,lrr,nsmx,ibandlim,
     & leref,ntmx)
c      this routine calls tranls and then corrects error estimates
c       to account for the fraction of downweighted data; also corrects
c       errors to account for correlation between adjacent frequencies
c       caused by data window; currently assumes a pi-prolate window (could
c       be changed  by changing parameter vcorps1 (see egbert and booker,
c       1986 - appendix b for calculation of correction factor)

c       z is array of nbt spectral density matrices, nch is number of
c       channels of data at local site
c          , nch2=nch-2, nz = (nch+1)*nch/2 ( = # of  elements
c       of spectral density matrix stored in symmetric stoarage mode (lower
c       triangular half of matrix)), ldf = number of (complex) data points
c       used, rdf = actual degrees of freedom, ldfc = number of adjacent
c       pairs among frequencies stacked - all for each of nbt frequencies
c       (or stations)

      complex z(nsmx,*)
      real rdf(ntmx,nbt)
      integer ldf(nbt),ibandlim(2,*)
      logical lrr,leref
      parameter (vcorps1=.17)

      nch2 = nch-2
      nz = ((nch+1)*nch)/2

      write(*,*) 'nsmx,nbt,nch = ',nsmx,nbt,nch
      do k = 1,21
        write(*,*) z(k,1)
      enddo
      if(lrr) then
         do 10 i = 1,nbt
10       call trlsrr(z(1,i),nch,ldf(i))
      else if(leref) then
         call rtreref(z,nbt,nz,ldf,nch,nsmx)
      else
         do 20 i = 1,nbt
20       call tranls(z(1,i),nch,ldf(i))
      end if

c           for each frequency band ...
      do 140 j=1,nbt
      if(ldf(j).gt.2) then

c.........adjust for correlation of adjacent frequencies
         cor =  ibandlim(2,j)-ibandlim(1,j) + 1
         cor = 2.*vcorps1*(cor-1.)/cor
            do 139 k=1,3
            z(k,j)= z(k,j)*(1.+cor)
139         continue

c.......adjust errors, coherence to account for fraction of downweighted data
            do 130 i=1,nch2
            ie=(i+2)*(i+3)/2
            if(rdf(i,j).gt.(0.)) then
               cfac=(ldf(j)*2./rdf(i,j))
               err=real(z(ie,j))*cfac*cfac
               coh=aimag(z(ie,j))
               coh = coh/(cfac - (cfac-1.)*coh)
               z(ie,j)=cmplx(err,coh)
            end if
130         continue
         end if

140   continue
      return
      end


      SUBROUTINE DROTG(A,B,C,S)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 DROTG  Krogh  Changes to use M77CON
C>> 1994-04-19 DROTG  Krogh   Changed to use generic intrinsics.
C>> 1985-08-02 DROTG  Lawson  Initial code.
c--D replaces "?": ?ROTG, ?ROT
C
C     DESIGNED BY C.L.LAWSON, JPL, 1977 SEPT 08
C
C
C     CONSTRUCT THE GIVENS TRANSFORMATION
C
C         ( C  S )
C     G = (      ) ,    C**2 + S**2 = 1 ,
C         (-S  C )
C
C     WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR  (A,B)**T .
C
C     THE QUANTITY R = (+/-)SQRT(A**2 + B**2) OVERWRITES A IN
C     STORAGE.  THE VALUE OF B IS OVERWRITTEN BY A VALUE Z WHICH
C     ALLOWS C AND S TO BE RECOVERED BY THE FOLLOWING ALGORITHM:
C           IF Z=1  SET  C=0.D0  AND  S=1.D0
C           IF ABS(Z) .LT. 1  SET  C=SQRT(1-Z**2)  AND  S=Z
C           IF ABS(Z) .GT. 1  SET  C=1/Z  AND  S=SQRT(1-C**2)
C
C     NORMALLY, THE SUBPROGRAM DROT(N,X,INCX,Y,INCY,C,S) WILL
C     NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX.
C
C ------------------------------------------------------------------
C
      DOUBLE PRECISION  A, B, C, S, U, V, R
      IF (ABS(A) .LE. ABS(B)) GO TO 10
C
C *** HERE ABS(A) .GT. ABS(B) ***
C
      U = A + A
      V = B / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF A
C
      R = SQRT(.25D0 + V**2) * U
C
C     NOTE THAT C IS POSITIVE
C
      C = A / R
      S = V * (C + C)
      B = S
      A = R
      RETURN
C
C *** HERE ABS(A) .LE. ABS(B) ***
C
   10 IF (B .EQ. 0.D0) GO TO 20
      U = B + B
      V = A / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF B
C     (R IS IMMEDIATELY STORED IN A)
C
      A = SQRT(.25D0 + V**2) * U
C
C     NOTE THAT S IS POSITIVE
C
      S = B / A
      C = V * (S + S)
      IF (C .EQ. 0.D0) GO TO 15
      B = 1.D0 / C
      RETURN
   15 B = 1.D0
      RETURN
C
C *** HERE A = B = 0.D0 ***
C
   20 C = 1.D0
      S = 0.D0
      RETURN
C
      END


      MODULE m_kernel2
C.............................................................kernel2
c solution of 4 coupled equations (logariphmic mesh) for (l,\mu)
c 1->k1, 2->k2
c d/dxP1=[-k1]P1+exp(x)[e-v+2mc^2]/c^2Q1+exp(x)B/c^2\sigma_z[-1,-1]Q1
c d/dxQ1=[k1]Q1-exp(x)[e-v]P1+exp(x)B[\sigma_z[1,1]P1+\sigma_z[1,2]P2]
c d/dxP2=[-k2]P2+exp(x)[e-v+2mc^2]/c^2Q2+exp(x)B/c^2\sigma_z[-1,-1]Q2
c d/dxQ2=[k2]Q2-exp(x)[e-v]P2+exp(x)B[\sigma_z[2,1]P1+\sigma_z[2,2]P2]
c notations:
c Pi=exp(x)*gi
c Qi=exp(x)*cfi
c \gamma=sqrt(k^2-(Z/c)^2)
c v=0.5[V(1/2)+V(-1/2)]
c b=0.5[V(1/2)-V(-1/2)]
c Rydberg units: in charge
c Hartree units: com.
c NSOL= 2 -  4 equations
c ------------                                     a. shick KFA 1996
      CONTAINS
      SUBROUTINE kernel2(mrad,nsol,xmj,k1,k2,xx1,xx2,e,v,b,ri,dx,
     +                   nmatch,nstart,dp,dq,wp,wq)

      USE m_constants, ONLY : c_light
      USE m_diff
      IMPLICIT NONE
C     ..
C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: mrad
      REAL dx,e,xmj
      INTEGER k1,k2,nmatch,nsol,nstart
C     ..
C     .. Array Arguments ..
      REAL b(mrad),dp(2,2,mrad),dq(2,2,mrad),ri(mrad),v(mrad),
     +     wp(2,2,mrad),wq(2,2,mrad),xx1(4),xx2(4)
C     ..
C     .. Local Scalars ..
      REAL abz,bh,bmn,bmnp1,bn,bnp1,c1,c2,c3,cc,csq,dp11,dp12,
     +     dp13,dp14,dp21,dp22,dp23,dp24,dq11,dq12,dq13,dq14,dq21,dq22,
     +     dq23,dq24,dxd8,expdxh,gk,gk1,gk1k,gkk1,gmk,gmk1,p1c,p2c,
     +     q1c,q2c,r,vh,vmn,vmnp1,vn,vnp1,xk,xk1,xm
      INTEGER i,iny,ir,j,jri,n,nrk
C     ..
C     .. Local Arrays ..
      REAL bm(mrad),p1(mrad),p1s(mrad),p2(mrad),p2s(mrad),q1(mrad),
     +     q1s(mrad),q2(mrad),q2s(mrad),vm(mrad)
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC exp,real,sqrt
C     ..
C     .. Data statements ..
      DATA abz/0.5/
C     ..
      cc = c_light(2.0)
c
      DO ir = 1,mrad
         p1(ir) = 0.0
         q1(ir) = 0.0
         p1s(ir) = 0.0
         q1s(ir) = 0.0
c
         p2(ir) = 0.0
         q2(ir) = 0.0
         p2s(ir) = 0.0
         q2s(ir) = 0.0
c
         DO i = 1,2
            DO j = 1,2
c
               wp(i,j,ir) = 0.0
               wq(i,j,ir) = 0.0
c
               dp(i,j,ir) = 0.0
               dq(i,j,ir) = 0.0
            END DO
         END DO
      END DO
C
      csq = cc*cc
      expdxh = exp(dx/2.0)
      dxd8 = dx/8.0
      jri = nmatch
      nrk = jri
c-derivatives of potential
      CALL diff(
     >          mrad,v,dx,jri,
     <          vm)
      CALL diff(
     >          mrad,b,dx,jri,
     <          bm)
c- begin to solve coupled Dirac equation in "magnetic" field
      xk = real(k1)
      xk1 = real(k2)
      xm = xmj
      gk = -xm/ (xk+abz)
      gk1 = -xm/ (xk1+abz)
      gkk1 = -sqrt(1.0-gk*gk)
      gk1k = gkk1
      gmk = xm/ (xk-abz)
      gmk1 = xm/ (xk1-abz)
c
c     NB: V=R**2*POTENTIAL
c     NB: B=R**2*FIELD
c
      DO 30 iny = 1,nsol
C                                                                       WAB02140
         r = ri(nstart)
         vn = v(nstart)
         vmn = vm(nstart)
         bn = b(nstart)
         bmn = bm(nstart)
         IF (iny.EQ.1) THEN
            p1(nstart) = xx1(1)
            q1(nstart) = xx1(2)
            p2(nstart) = xx1(3)
            q2(nstart) = xx1(4)
         ELSE
            p1(nstart) = xx2(1)
            q1(nstart) = xx2(2)
            p2(nstart) = xx2(3)
            q2(nstart) = xx2(4)
         END IF
c---->f.po solution of Dirac eq.
         c1 = vn/r**2 - e
         c2 = 1.0 - c1/csq
c      C2=2.0-C1/CSQ !H
         c3 = bn/r/r
         p1s(nstart) = -xk*p1(nstart) + r* (c2+c3/csq*gmk)*q1(nstart)
         q1s(nstart) = xk*q1(nstart) + r*
     +                 ((c1+c3*gk)*p1(nstart)+c3*gkk1*p2(nstart))
C
         p2s(nstart) = -xk1*p2(nstart) + r* (c2+c3/csq*gmk1)*q2(nstart)
         q2s(nstart) = xk1*q2(nstart) +
     +                 r* ((c1+c3*gk1)*p2(nstart)+c3*gk1k*p1(nstart))
C   ******************************************************************
C   *                                                                *
C   *     THE RUNGE-KUTTA METHOD IS USED IN THE <NKR> FIRST STEPS    *
C   *                                                                *
C   ******************************************************************
C
         n = nstart
c-> y1
   10    p1c = p1(n)
         q1c = q1(n)
         p2c = p2(n)
         q2c = q2(n)
c-> k1=f(x1,y1)
         dp11 = dx* (-xk*p1c+r* (c2+c3/csq*gmk)*q1c)
         dq11 = dx* (xk*q1c+r* ((c1+c3*gk)*p1c+c3*gkk1*p2c))
         dp21 = dx* (-xk1*p2c+r* (c2+c3/csq*gmk1)*q2c)
         dq21 = dx* (xk1*q2c+r* ((c1+c3*gk1)*p2c+c3*gk1k*p1c))
c-> y11=y1+0.5*k1
         p1c = p1c + 0.5*dp11
         q1c = q1c + 0.5*dq11
         p2c = p2c + 0.5*dp21
         q2c = q2c + 0.5*dq21
c-> x1'=x1+0.5h
         r = r*expdxh
c-> interpolation of V and B for x1'
         vnp1 = v(n+1)
         vmnp1 = vm(n+1)
         bnp1 = b(n+1)
         bmnp1 = bm(n+1)
         vh = (vn+vnp1)*0.5 + (vmn-vmnp1)*dxd8
         bh = (bn+bnp1)*0.5 + (bmn-bmnp1)*dxd8
c-> k2=f(x1',y11)
         c1 = vh/r/r - e
         c2 = 1.0 - c1/csq
c      C2=2.0-C1/CSQ !H
         c3 = bh/r/r
C                                                                       WAB02850
         dp12 = dx* (-xk*p1c+r* (c2+c3/csq*gmk)*q1c)
         dq12 = dx* (xk*q1c+r* ((c1+c3*gk)*p1c+c3*gkk1*p2c))
         dp22 = dx* (-xk1*p2c+r* (c2+c3/csq*gmk1)*q2c)
         dq22 = dx* (xk1*q2c+r* ((c1+c3*gk1)*p2c+c3*gk1k*p1c))
c-> y12=y1+0.5*k2 (y12=y11-0.5*k1+0.5*k2)
         p1c = p1c + 0.5* (dp12-dp11)
         q1c = q1c + 0.5* (dq12-dq11)
         p2c = p2c + 0.5* (dp22-dp21)
         q2c = q2c + 0.5* (dq22-dq21)
c-> k3=f(x1',y12)
         dp13 = dx* (-xk*p1c+r* (c2+c3/csq*gmk)*q1c)
         dq13 = dx* (xk*q1c+r* ((c1+c3*gk)*p1c+c3*gkk1*p2c))
         dp23 = dx* (-xk1*p2c+r* (c2+c3/csq*gmk1)*q2c)
         dq23 = dx* (xk1*q2c+r* ((c1+c3*gk1)*p2c+c3*gk1k*p1c))
c-> y13=y1+k3 (y13=y12-0.5*k2+k3)
         p1c = p1c + dp13 - 0.5*dp12
         q1c = q1c - 0.5*dq12 + dq13
         p2c = p2c + dp23 - 0.5*dp22
         q2c = q2c - 0.5*dq22 + dq23
c-> x2=x1+h
         n = n + 1
         r = ri(n)
c-> k4=f(x2,y13)
         c1 = vnp1/r/r - e
         c2 = 1.0 - c1/csq
c      C2=2.0-C1/CSQ !H
         c3 = bnp1/r/r
c
         dp14 = dx* (-xk*p1c+r* (c2+c3/csq*gmk)*q1c)
         dq14 = dx* (xk*q1c+r* ((c1+c3*gk)*p1c+c3*gkk1*p2c))
         dp24 = dx* (-xk1*p2c+r* (c2+c3/csq*gmk1)*q2c)
         dq24 = dx* (xk1*q2c+r* ((c1+c3*gk1)*p2c+c3*gk1k*p1c))
c-> y2=y1+1/6*(k1+2*k2+2*k3+k4)
         p1(n) = p1(n-1) + (dp11+2.0* (dp12+dp13)+dp14)/6.0
         q1(n) = q1(n-1) + (dq11+2.0* (dq12+dq13)+dq14)/6.0
         p2(n) = p2(n-1) + (dp21+2.0* (dp22+dp23)+dp24)/6.0
         q2(n) = q2(n-1) + (dq21+2.0* (dq22+dq23)+dq24)/6.0
c-> f(x2,y2)
         p1s(n) = -xk*p1(n) + r* (c2+c3/csq*gmk)*q1(n)
         q1s(n) = xk*q1(n) + r* ((c1+c3*gk)*p1(n)+c3*gkk1*p2(n))
         p2s(n) = -xk1*p2(n) + r* (c2+c3/csq*gmk1)*q2(n)
         q2s(n) = xk1*q2(n) + r* ((c1+c3*gk1)*p2(n)+c3*gk1k*p1(n))
c-> redefinition of V ind B (2->1)
         vn = vnp1
         bn = bnp1
         vmn = vmnp1
         bmn = bmnp1
C                                                                       WAB03340
         IF (n-nrk.LT.0) GOTO 10
c---->Milne's method off now!
c
c storage of wave functions and their derivatives.
         DO ir = 1,jri
            wp(1,iny,ir) = p1(ir)
            wp(2,iny,ir) = p2(ir)
            wq(1,iny,ir) = q1(ir)
            wq(2,iny,ir) = q2(ir)
c derivatives
            dp(1,iny,ir) = p1s(ir)
            dp(2,iny,ir) = p2s(ir)
            dq(1,iny,ir) = q1s(ir)
            dq(2,iny,ir) = q2s(ir)
         END DO
C***********************************************************            WAB05210
   30 CONTINUE
c      write(oUnit,*) wp

      END SUBROUTINE kernel2
      END MODULE m_kernel2


! =============================================================================
!                       Test parcel initialisation
!
!         This unit test checks the parcel initialisation from fields.
! =============================================================================
program test_parcel_init
    use unit_test
    use constants, only : pi, zero, one, two, four, f12, f32
    use parcel_container
    use parcel_init, only : gen_parcel_scalar_attr, unit_test_parcel_init_alloc, init_timer
    use parcel_interpl, only : par2grid, par2grid_timer
    use parcel_ellipse, only : get_ab
    use fields, only : tbuoyg, field_default
    use parameters, only : update_parameters, dx, ncell, nx, nz, lower, vcell
    use timer
    implicit none

    double precision  :: xg, zg, facx, facz, argx, argz, v0
    integer:: i, ix, iz, mx, mz
    double precision :: rms, rmserr, error
    double precision, allocatable :: workg(:, :)
    double precision :: tol = 1.0d-9

     !Number of parcels per grid box = nbgx*nbgz
    integer, parameter :: nbgx = 2, nbgz = nbgx

    !Fractions of grid cell used for placing parcels:
    double precision, parameter :: dxf = one / dble(nbgx), &
                                   dzf = one / dble(nbgz)

    nx = 64
    nz = 32
    lower = (/-four, -two/)
    extent = (/8.0d0, four/)

    call register_timer('parcel init', init_timer)
    call register_timer('par2grid', par2grid_timer)

    call update_parameters

    call field_default

    !Maximum number of parcels:

    !Total number of parcels:
    n_parcels = nbgx * nbgz * ncell
    call parcel_alloc(n_parcels)

    !--------------------------------------------------------
    ! Define a gridded field "tbuoyg" (this can be arbitrary):
    facx = two * pi / extent(1)
    facz = one / extent(2)
    do ix = 0, nx-1
        xg = dx(1) * dble(ix)
        argx = facx * xg
        do iz = 0, nz
            zg = dx(2) * dble(iz)
            argz = facz * zg
            tbuoyg(iz,ix) = dexp(argz) * dsin(argx+one) / (one + f12 * dcos(argx))
        enddo
    enddo

    !---------------------------------------------------------
    !Initialise parcel volume positions and volume fractions:
    v0 = dxf * dzf * vcell
    i = 0
    do iz = 0, nz-1
        do ix = 0, nx-1
            do mz = 1,nbgz
                do mx = 1,nbgx
                    i = i + 1
                    parcels%position(1, i) = lower(1) + dx(1) * (dble(ix) + dxf * (dble(mx) - f12))
                    parcels%position(2, i) = lower(2) + dx(2) * (dble(iz) + dzf * (dble(mz) - f12))
                    parcels%volume(i) = v0
                    parcels%B(2, i) = zero
                    parcels%B(1, i) = get_ab(v0)
                enddo
            enddo
        enddo
    enddo

    ! Prepare for "gen_parcel_scalar_attr"
    call unit_test_parcel_init_alloc

    !---------------------------
    ! Generate parcel attribute:
    call gen_parcel_scalar_attr(tbuoyg, tol, parcels%buoyancy)

    !
    ! check result
    !
    error = zero

    ! Copy buoyg since it is overwritten in par2grid after:
    allocate(workg(-1:nz+1, 0:nx-1))
    workg = tbuoyg

    call par2grid

    ! Compute max and rms errors:

    ! Rms value of original field
    rms = dsqrt((f12 * sum(workg(0,:) ** 2 + workg(nz,:) ** 2) + &
                       sum(workg(1:nz-1,:) ** 2)) / dble(ncell))

    workg = tbuoyg - workg

    ! Rms error in reconstruction
    rmserr = dsqrt((f12 * sum(workg(0,:) ** 2 + workg(nz,:) ** 2) + &
                          sum(workg(1:nz-1,:) ** 2)) / dble(ncell))

    error = max(error, rmserr)

    ! Relative rms error
    error = max(error, rmserr / rms)

    ! Maximum error
    error = max(error, maxval(dabs(workg(0:nz,:))))

    call print_result_dp('Test parcel initialisation', error, atol=two * tol)

    call parcel_dealloc

    deallocate(workg)

end program test_parcel_init


      subroutine zsphbes(lmax,x,bj,hpm,dj,dh,job)
c_______________________________________________________________________
c calculate spherical bessel and hankel functions and their derivatives
c input: lmax integer scalar, max l
c        x    complex*16 scalar, argument of the bessel functions
c        job  integer scalar. job=+1: retarded hankel function is calculated
c             job=-1: advanced hankel function is calculated
c returns: bj complex*16 array of (0:lmax), j_l
c          hpm complex*16 array of (0:lmax), h(+-)_l (hankel function)
c          dj complex*16 array of (0:lmax), derivative of bj
c          dh complex*16 array of (0:lmax), derivative of hpm
c calls zsphbesjh
c  computes spherical bessel/hankel functions j and h+-
c    h+ = jl + i nl = sinx/x - i cosx/x
c    h- = jl - i nl = sinx/x + i cosx/x
c
c   xgz ornl 1994
      implicit real*8 (a-h,o-z)
      complex*16 ci
      parameter(ci=(0.0d0,1.0d0))
      complex*16 bj(0:lmax),hpm(0:lmax)
      complex*16 dj(0:lmax),dh(0:lmax)
      complex*16 x,eiz,fll
c
      if(x.eq.0.0d0) goto 200

c zsphbesjh returns bj, hpm and eiz
c eiz = job*exp(job*ci*x)
      call zsphbesjh(lmax,x,bj,hpm,eiz,job)
c put back factor of e^ix/x to hpm
      eiz=eiz/x
      do l=0,lmax
      hpm(l)=eiz*hpm(l)
      enddo

      fll=2.d0/x
      dj(0) = -bj(1)
      dj(1) = bj(0)-fll*bj(1)
      dh(0) = -hpm(1)
      dh(1) = hpm(0)-fll*hpm(1)
c
      do l=2,lmax
	 fll=l/x
         dj(l) = bj(l-1)-fll*bj(l)
         dh(l) = hpm(l-1)-fll*hpm(l)
      enddo
      return

200   write(6,*)'error bessel: zero argument.'
      stop
      end


module modFaceValues

    use modValues
    use modEOS
    implicit none

    contains

    subroutine getFaceValues(&
        FaceMethodU,FaceMethodP,&
        calfUx,calfCM1,calfCM2,calfRho,calfDrDp)
        implicit none
        character(len=*),optional,intent(in) :: &
            FaceMethodU,FaceMethodP,&
            calfUx,calfCM1,calfCM2,calfRho,calfDrDp
        integer :: lmCell,rpCell
        real(8) :: leftcRho,leftcC,leftcHt,rightcRho,rightcC,rightcHt,eosY(nspe)

        do i=nFaceStr,nFaceEnd
            lmCell = max(nFaceStr,i-1); lCell = i
            rCell = i+1; rpCell = min(nFaceEnd,i+2)

            CALL getRecon(chReconP,cP(lmCell),cP(lCell),cP(rCell),cP(rpCell),&
                        wL(i,1),wR(i,1))
            CALL getRecon(chReconU,cU(lmCell),cU(lCell),cU(rCell),cU(rpCell),&
                        wL(i,2),wR(i,2))
            CALL getRecon(chReconT,cT(lmCell),cT(lCell),cT(rCell),cT(rpCell),&
                        wL(i,3),wR(i,3))
            do nq=1,nspe-1
                CALL getRecon(chReconY,cY(lmCell,nq),cY(lCell,nq),&
                    cY(rCell,nq),cY(rpCell,nq),&
                    wL(i,3+nq),wR(i,3+nq))
            enddo

            forall(nq=1:nspe-1) wL(i,3+nq) = dmax1( 0.d0 , dmin1( 1.d0, wL(i,3+nq) ) )
            wL(i,3+nspe) = 1.d0 - sum( wL(i,4:2+nspe) )
            wL(i,3+nspe) = dmax1( 0.d0 , dmin1( 1.d0, wL(i,3+nspe) ) )
            forall(nq=1:nspe-1) wR(i,3+nq) = dmax1( 0.d0 , dmin1( 1.d0, wR(i,3+nq) ) )
            wR(i,3+nspe) = 1.d0 - sum( wR(i,4:2+nspe) )
            wR(i,3+nspe) = dmax1( 0.d0 , dmin1( 1.d0, wR(i,3+nspe) ) )

            !> get Rho, C, Ht
            CALL getRCH(wL(i,1),wL(i,2),wL(i,3),wL(i,4:3+nspe), leftcRho,leftcC,leftcHt)
            CALL getRCH(wR(i,1),wR(i,2),wR(i,3),wR(i,4:3+nspe), rightcRho,rightcC,rightcHt)
            !
            !> face U, Mdot
            if( trim(FaceMethodU) == 'AUSM' ) then
                CALL calfaceVelAUSM(&
                    wL(i,1),wL(i,2),wL(i,3),leftcRho,leftcC,&
                    wR(i,1),wR(i,2),wR(i,3),rightcRho,rightcC, fU(i))
            elseif( trim(FaceMethodU) == 'SLAU' ) then
                CALL calfaceVelSLAU(&
                    wL(i,1),wL(i,2),wL(i,3),leftcRho,leftcC,&
                    wR(i,1),wR(i,2),wR(i,3),rightcRho,rightcC, fU(i))
            else
                print*,'  ReconMethod not defined'
                stop
            endif
            !> upwind coefficient
            fgP(i) = 0.5d0*(1.d0+dsign(1.d0,fU(i)))
            fgN(i) = 0.5d0*(1.d0-dsign(1.d0,fU(i)))
            !> Mdot, upwind
            fMdot(i) = leftcRho*fU(i)*fgP(i)*area(i) &
                     + rightcRho*fU(i)*fgN(i)*area(i)

            !> face P
            if( present(FaceMethodP) ) then
                if( trim(FaceMethodP) == 'AUSM' ) then
                    CALL calFacePressAUSM(&
                        wL(i,1),wL(i,2),wL(i,3),leftcRho,leftcC,&
                        wR(i,1),wR(i,2),wR(i,3),rightcRho,rightcC, fP(i))
                elseif( trim(FaceMethodP) == 'SLAU2' ) then
                    CALL calFacePressSLAU(&
                        wL(i,1),wL(i,2),wL(i,3),leftcRho,leftcC,&
                        wR(i,1),wR(i,2),wR(i,3),rightcRho,rightcC, fP(i))
                elseif( trim(FaceMethodP) == 'SecOrder' ) then
                    CALL calFacePressSecOrder(&
                        wL(i,1),wL(i,2),wL(i,3),leftcRho,leftcC,&
                        wR(i,1),wR(i,2),wR(i,3),rightcRho,rightcC, fP(i))
                else
                    print*,'  ReconMethod not defined'
                    stop
                endif
            endif

            if(present(calfUx)) &
                fUx(i) = fgP(i)*cU(lCell) + fgN(i)*cU(rCell)
            if(present(calfCM1)) &
                fcoeffMom1(i) = fgP(i)*coeffMom1(lCell) + fgN(i)*coeffMom1(rCell)
            if(present(calfCM2)) &
                fcoeffMom2(i) = fgP(i)*coeffMom2(lCell) + fgN(i)*coeffMom2(rCell)
            if(present(calfRho)) &
                fRho(i) = fgP(i)*cRho(lCell) + fgN(i)*cRho(rCell)
            if(present(calfDrDp)) &
                fDrDp(i) = fgP(i)*cDrDp(lCell) + fgN(i)*cDrDp(rCell)

        enddo
    endsubroutine

    !================================
    subroutine getRecon(ReconMethod,cm2Phi,cm1Phi,cp1Phi,cp2Phi, leftPhi,rightPhi)
        implicit none
        character(len=*) :: ReconMethod
        real(8) :: cm2Phi,cm1Phi,cp1Phi,cp2Phi
        real(8) :: leftPhi,rightPhi

        if( trim(ReconMethod) == '1stOrder' ) then
            leftPhi = cm1Phi
            rightPhi = cp1Phi
        elseif( trim(ReconMethod) == '3thMUSCL' ) then
            CALL MUSCL_3th(cm2Phi,cm1Phi,cp1Phi,cp2Phi,leftPhi,rightPhi)
        else
            print*,'  ReconMethod not defined'
            stop
        endif

    endsubroutine

    !================================
    subroutine calFacePressSecOrder(fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR, pLR)

        implicit none

        real(8), intent(in) :: fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR
        real(8), intent(out):: pLR
        real(8) :: revAmatMom,cPrevAmatMom,revLAmatMom,revRAmatMom
        integer :: lmCell,rpCell

        lmCell = max(nFaceStr,i-1); lCell = i
        rCell = i+1; rpCell = min(nFaceEnd,i+2)

        revLAmatMom = 1.d0/( cDRDP(lCell)/timestep )
        revRAmatMom = 1.d0/( cDRDP(rCell)/timestep )
        revAmatMom = revLAmatMom + revRAmatMom
        cPrevAmatMom = fPL*revLAmatMom + fPR*revRAmatMom

        pLR = cPrevAmatMom/revAmatMom

    endsubroutine

    !================================
    subroutine calFaceVelAUSM(fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR, uLR)

        implicit none

        real(8) :: fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR
        real(8) :: uLR,M_L,M_R,MLP,MRM,chat

        ! AUSM+ scheme
        ! wL : left value of cell interface (face)
        ! wR : right
        !----------------------------------------------------

        chat = 0.5d0*(fCL+fCR)
        M_L = fUL/chat; M_R = fUR/chat

        !------ numerical mass flux & pressure flux in AUSM+ scheme ------
        if( abs(M_L) > 1.0 ) then
            MLP = 0.5*(M_L+abs(M_L))
        else
            MLP = 0.25*(M_L+1.0)**2.0
        endif
        if( abs(M_R) > 1.0 ) then
            MRM = 0.5*(M_R-abs(M_R))
        else
            MRM = -0.25*(M_R-1.0)**2.0
        endif

        uLR = (MLP + MRM)*chat

    endsubroutine

    !================================
    subroutine calFaceVelSLAU(fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR, uLR)

        implicit none

        real(8) :: fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR
        real(8) :: uLR
        real(8) :: rho_L,rho_R,u_L,u_R,p_L,p_R,c_L,c_R, &
         chat,M_L,M_R,MLP,preP,MRM,preM,RhouLR,Mcy,phi_c,g_c,Mbar,&
         D_L,D_R,D_rho,D_P,KLR

        ! AUSM+ scheme
        ! wL : left value of cell interface (face)
        ! wR : right
        !----------------------------------------------------

        chat = 0.5d0*(fCL+fCR)
        M_L = fUL/chat; M_R = fUR/chat

	    ! !> SLAU
        KLR = dsqrt(0.5d0*(fUL*fUL+fUR*fUR))
	    Mcy = dmin1(1.d0,KLR/chat)
	    phi_c = (1.d0-Mcy)**2.d0
	    g_c = 1.d0 + dmax1( dmin1(M_L,0.d0), -1.d0 )*dmin1( dmax1(M_R,0.d0), 1.d0 )
        Mbar = ( fRhoL*dabs(M_L)+fRhoR*dabs(M_R) ) / ( fRhoL + fRhoR )

        D_L = M_L+(1.d0-g_c)*dabs(M_L)
        D_R = M_R-(1.d0-g_c)*dabs(M_R)
        D_rho = Mbar*g_c
        D_P = 1.d0/chat**2.d0*phi_c

        RhouLR = 0.5d0*chat*(D_L*fRhoL+D_R*fRhoR-D_rho*(fRhoR-fRhoL)-D_P*(fPR-fPL))
	    if( RhouLR >= 0.d0 ) then
            uLR = RhouLR/fRhoL
        else
            uLR = RhouLR/fRhoR
        endif

    endsubroutine

    !================================
    subroutine calFacePressAUSM(fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR, pLR)

        implicit none

        real(8), intent(in) :: fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR
        real(8), intent(out):: pLR
        real(8) :: rho_L,rho_R,u_L,u_R,p_L,p_R,c_L,c_R, &
        H_L,H_R,chat,M_L,M_R,MLP,preP,MRM,preM,mdot

        ! AUSM+ scheme
        ! wL : left value of cell interface (face)
        ! wR : right
        !----------------------------------------------------

        chat = 0.5d0*(fCL+fCR)
        M_L = fUL/chat; M_R = fUR/chat

        !------ numerical mass flux & pressure flux in AUSM+ scheme ------
        if( abs(M_L) > 1.0 ) then
            preP = 0.5*(1.0+sign(1.0,M_L))
        else
            preP = 0.25*(M_L+1.0)**2.0*(2.0-M_L)
        endif
        if( abs(M_R) > 1.0 ) then
            preM = 0.5*(1.0-sign(1.0,M_R))
        else
            preM = 0.25*(M_R-1.0)**2.0*(2.0+M_R)
        endif
        pLR = preP*fPL+preM*fPR

    endsubroutine

    !================================
    subroutine calFacePressSLAU(fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR, pLR)

        implicit none

        real(8), intent(in) :: fPL,fUL,fTL,fRhoL,fCL,fPR,fUR,fTR,fRhoR,fCR
        real(8), intent(out):: pLR
        real(8) :: rho_L,rho_R,u_L,u_R,p_L,p_R,c_L,c_R, &
        H_L,H_R,chat,M_L,M_R,MLP,preP,MRM,preM,mdot,KLR,rhohat

        ! AUSM+ scheme
        ! wL : left value of cell interface (face)
        ! wR : right
        !----------------------------------------------------

        chat = 0.5d0*(fCL+fCR)
        M_L = fUL/chat; M_R = fUR/chat

        !------ numerical mass flux & pressure flux in AUSM+ scheme ------
        if( abs(M_L) > 1.0 ) then
            preP = 0.5*(1.0+sign(1.0,M_L))
        else
            preP = 0.25*(M_L+1.0)**2.0*(2.0-M_L)
        endif
        if( abs(M_R) > 1.0 ) then
            preM = 0.5*(1.0-sign(1.0,M_R))
        else
            preM = 0.25*(M_R-1.0)**2.0*(2.0+M_R)
        endif
        KLR = dsqrt(0.5d0*(fUL*fUL+fUR*fUR))
        rhohat = 0.5d0*(fRhoL+fRhoR)
	    PLR = 0.5d0*(fPL+fPR) &
              + 0.5d0*(fPL-fPR)*(preP-preM)   &
		      + KLR*rhohat*chat*(preP+preM-1.d0)

    endsubroutine

    endmodule

    !================================
        subroutine MUSCL_3th(qm,qi,qp,qp2,ql,qr)

            implicit none

            real(8)  qm,qi,qp,qp2,ql,qr
            real(8)  kpa,phi4,gbq,dbq,kam,kap,dq1,dq2,dq3,betat

            kpa = 1.0d0/3.0d0
            phi4  = 1.0d0*.250d0

            !betat=(3.0d0-kpa)/(1.0d0-kpa)
            betat=1.0d0

            kap   = 1.0d0+kpa
            kam   = 1.0d0-kpa

            dq1 = ( qi - qm)
            dq2 = ( qp - qi)
            dq3 = (qp2 - qp)

            gbq = minmod(betat*dq1,dq2)
            dbq = minmod(betat*dq2,dq1)
            ql  = qi+phi4*(kam*gbq+kap*dbq)

            gbq = minmod(dq2,dq3)
            dbq = minmod(dq3,dq2)
            qr  = qp-phi4*(kap*gbq+kam*dbq)

        contains
            function minmod(xx,yy,zz) result(mu)
                implicit none
                real(8), intent(in) :: xx,yy  !Input
                real(8),optional, intent(in) :: zz
                real(8)             :: mu        !output
                real(8) :: aa,bb,cc,dd,ee

                if(present(zz)) then
                    aa = dsign(1.0d0,xx)
                    bb = dabs(xx)
                    cc = aa*yy
                    dd = aa*zz
                    ee = dmin1(bb,cc,dd)
                    mu = aa*dmax1(0.d0,ee)
                else
                    aa = dsign(1.0d0,xx)
                    bb = dabs(xx)
                    cc = aa*yy
                    dd = dmin1(bb,cc)
                    mu = aa*dmax1(0.d0,dd)
                endif
            endfunction

        end subroutine