      SUBROUTINE NF01BR( COND, UPLO, TRANS, N, IPAR, LIPAR, R, LDR,
     $                   SDIAG, S, LDS, B, RANKS, TOL, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve one of the systems of linear equations
C
C           R*x = b ,  or  R'*x = b ,
C
C     in the least squares sense, where R is an n-by-n block upper
C     triangular matrix, with the structure
C
C         /   R_1    0    ..   0   |   L_1   \
C         |    0    R_2   ..   0   |   L_2   |
C         |    :     :    ..   :   |    :    | ,
C         |    0     0    ..  R_l  |   L_l   |
C         \    0     0    ..   0   |  R_l+1  /
C
C     with the upper triangular submatrices R_k, k = 1:l+1, square, and
C     the first l of the same order, BSN. The diagonal elements of each
C     block R_k have nonincreasing magnitude. The matrix R is stored in
C     the compressed form, as returned by SLICOT Library routine NF01BS,
C
C              /   R_1  |   L_1   \
C              |   R_2  |   L_2   |
C       Rc =   |    :   |    :    | ,
C              |   R_l  |   L_l   |
C              \    X   |  R_l+1  /
C
C     where the submatrix X is irrelevant. If the matrix R does not have
C     full rank, then a least squares solution is obtained. If l <= 1,
C     then R is an upper triangular matrix and its full upper triangle
C     is stored.
C
C     Optionally, the transpose of the matrix R can be stored in the
C     strict lower triangles of the submatrices R_k, k = 1:l+1, and in
C     the arrays SDIAG and S, as described at the parameter UPLO below.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COND    CHARACTER*1
C             Specifies whether the condition of submatrices R_k should
C             be estimated, as follows:
C             = 'E' :  use incremental condition estimation and store
C                      the numerical rank of R_k in the array entry
C                      RANKS(k), for k = 1:l+1;
C             = 'N' :  do not use condition estimation, but check the
C                      diagonal entries of R_k for zero values;
C             = 'U' :  use the ranks already stored in RANKS(1:l+1).
C
C     UPLO    CHARACTER*1
C             Specifies the storage scheme for the matrix R, as follows:
C             = 'U' :  the upper triangular part is stored as in Rc;
C             = 'L' :  the lower triangular part is stored, namely,
C                      - the transpose of the strict upper triangle of
C                        R_k is stored in the strict lower triangle of
C                        R_k, for k = 1:l+1;
C                      - the diagonal elements of R_k, k = 1:l+1, are
C                        stored in the array SDIAG;
C                      - the transpose of the last block column in R
C                        (without R_l+1) is stored in the array S.
C
C     TRANS   CHARACTER*1
C             Specifies the form of the system of equations, as follows:
C             = 'N':  R*x  = b  (No transpose);
C             = 'T':  R'*x = b  (Transpose);
C             = 'C':  R'*x = b  (Transpose).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix R.  N = BN*BSN + ST >= 0.
C             (See parameter description below.)
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             The integer parameters describing the structure of the
C             matrix R, as follows:
C             IPAR(1) must contain ST, the number of columns of the
C                     submatrices L_k and the order of R_l+1.  ST >= 0.
C             IPAR(2) must contain BN, the number of blocks, l, in the
C                     block diagonal part of R.  BN >= 0.
C             IPAR(3) must contain BSM, the number of rows of the blocks
C                     R_k, k = 1:l.  BSM >= 0.
C             IPAR(4) must contain BSN, the number of columns of the
C                     blocks R_k, k = 1:l.  BSN >= 0.
C             BSM is not used by this routine, but assumed equal to BSN.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 4.
C
C     R       (input) DOUBLE PRECISION array, dimension (LDR, NC)
C             where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
C             If UPLO = 'U', the leading N-by-NC part of this array must
C             contain the (compressed) representation (Rc) of the upper
C             triangular matrix R. The submatrix X in Rc and the strict
C             lower triangular parts of the diagonal blocks R_k,
C             k = 1:l+1, are not referenced. If BN <= 1 or BSN = 0, then
C             the full upper triangle of R must be stored.
C             If UPLO = 'L', BN > 1 and BSN > 0, the leading
C             (N-ST)-by-BSN part of this array must contain the
C             transposes of the strict upper triangles of R_k, k = 1:l,
C             stored in the strict lower triangles of R_k, and the
C             strict lower triangle of R_l+1 must contain the transpose
C             of the strict upper triangle of R_l+1. The submatrix X
C             in Rc is not referenced. The diagonal elements of R_k,
C             and, if COND = 'E', the upper triangular parts of R_k,
C             k = 1:l+1, are modified internally, but are restored
C             on exit.
C             If UPLO = 'L' and BN <= 1 or BSN = 0, the leading N-by-N
C             strict lower triangular part of this array must contain
C             the transpose of the strict upper triangular part of R.
C             The diagonal elements and, if COND = 'E', the upper
C             triangular elements are modified internally, but are
C             restored on exit.
C
C     LDR     INTEGER
C             The leading dimension of the array R.  LDR >= MAX(1,N).
C
C     SDIAG   (input) DOUBLE PRECISION array, dimension (N)
C             If UPLO = 'L', this array must contain the diagonal
C             entries of R_k, k = 1:l+1. This array is modified
C             internally, but is restored on exit.
C             This parameter is not referenced if UPLO = 'U'.
C
C     S       (input) DOUBLE PRECISION array, dimension (LDS,N-ST)
C             If UPLO = 'L', BN > 1, and BSN > 0, the leading
C             ST-by-(N-ST) part of this array must contain the transpose
C             of the rectangular part of the last block column in R,
C             that is [ L_1' L_2' ... L_l' ] . If COND = 'E', S is
C             modified internally, but is restored on exit.
C             This parameter is not referenced if UPLO = 'U', or
C             BN <= 1, or BSN = 0.
C
C     LDS     INTEGER
C             The leading dimension of the array S.
C             LDS >= 1,         if UPLO = 'U', or BN <= 1, or BSN = 0;
C             LDS >= MAX(1,ST), if UPLO = 'L', BN > 1, and BSN > 0.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the right hand side
C             vector b.
C             On exit, this array contains the (least squares) solution
C             of the system R*x = b or R'*x = b.
C
C     RANKS   (input or output) INTEGER array, dimension (r), where
C             r = BN + 1,  if ST > 0, BSN > 0, and BN > 1;
C             r = BN,      if ST = 0 and BSN > 0;
C             r = 1,       if ST > 0 and ( BSN = 0 or BN <= 1 );
C             r = 0,       if ST = 0 and BSN = 0.
C             On entry, if COND = 'U' and N > 0, this array must contain
C             the numerical ranks of the submatrices R_k, k = 1:l(+1).
C             On exit, if COND = 'E' or 'N' and N > 0, this array
C             contains the numerical ranks of the submatrices R_k,
C             k = 1:l(+1), estimated according to the value of COND.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If COND = 'E', the tolerance to be used for finding the
C             ranks of the submatrices R_k. If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             the reciprocal condition number;  a (sub)matrix whose
C             estimated condition number is less than 1/TOL is
C             considered to be of full rank. If the user sets TOL <= 0,
C             then an implicitly computed, default tolerance, defined by
C             TOLDEF = N*EPS,  is used instead, where EPS is the machine
C             precision (see LAPACK Library routine DLAMCH).
C             This parameter is not relevant if COND = 'U' or 'N'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             Denote Full = ( BN <= 1 or  BSN = 0 );
C                    Comp = ( BN >  1 and BSN > 0 ).
C             LDWORK >= 2*N,           if Full and COND = 'E';
C             LDWORK >= 2*MAX(BSN,ST), if Comp and COND = 'E';
C             LDWORK >= 0,   in the remaining cases.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Block back or forward substitution is used (depending on TRANS
C     and UPLO), exploiting the special structure and storage scheme of
C     the matrix R. If a submatrix R_k, k = 1:l+1, is singular, a local
C     basic least squares solution is computed. Therefore, the returned
C     result is not the basic least squares solution for the whole
C     problem, but a concatenation of (least squares) solutions of the
C     individual subproblems involving R_k, k = 1:l+1 (with adapted
C     right hand sides).
C
C     NUMERICAL ASPECTS
C                                    2    2
C     The algorithm requires 0(BN*BSN + ST + N*ST) operations and is
C     backward stable, if R is nonsingular.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005.
C
C     KEYWORDS
C
C     Linear system of equations, matrix operations, plane rotations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, SVLMAX
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, SVLMAX = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         COND, TRANS, UPLO
      INTEGER           INFO, LDR, LDS, LDWORK, LIPAR, N
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IPAR(*), RANKS(*)
      DOUBLE PRECISION  B(*), DWORK(*), R(LDR,*), S(LDS,*), SDIAG(*)
C     .. Local Scalars ..
      DOUBLE PRECISION  TOLDEF
      INTEGER           BN, BSM, BSN, I, I1, J, K, L, NC, NTHS, RANK, ST
      CHARACTER         TRANSL, UPLOL
      LOGICAL           ECOND, FULL, LOWER, NCOND, TRANR
C     .. Local Arrays ..
      DOUBLE PRECISION  DUM(3)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
      LOGICAL           LSAME
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMV, DSWAP, DTRSV, MB03OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      ECOND = LSAME( COND,  'E' )
      NCOND = LSAME( COND,  'N' )
      LOWER = LSAME( UPLO,  'L' )
      TRANR = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      INFO = 0
      IF( .NOT.( ECOND .OR. NCOND .OR. LSAME( COND,  'U' ) ) ) THEN
         INFO = -1
      ELSEIF( .NOT.( LOWER .OR. LSAME( UPLO,  'U' ) ) ) THEN
         INFO = -2
      ELSEIF( .NOT.( TRANR .OR. LSAME( TRANS, 'N' ) ) ) THEN
         INFO = -3
      ELSEIF( N.LT.0 ) THEN
         INFO = -4
      ELSEIF( LIPAR.LT.4 ) THEN
         INFO = -6
      ELSE
         ST   = IPAR(1)
         BN   = IPAR(2)
         BSM  = IPAR(3)
         BSN  = IPAR(4)
         NTHS = BN*BSN
         FULL = BN.LE.1 .OR. BSN.EQ.0
         IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN
            INFO = -5
         ELSEIF ( N.NE.NTHS + ST ) THEN
            INFO = -4
         ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN
            INFO = -8
         ELSEIF ( LDS.LT.1 .OR. ( LOWER .AND. .NOT.FULL .AND.
     $            LDS.LT.ST ) ) THEN
            INFO = -11
         ELSE
            IF ( ECOND ) THEN
               IF ( FULL ) THEN
                  L = 2*N
               ELSE
                  L = 2*MAX( BSN, ST )
               END IF
            ELSE
               L = 0
            END IF
            IF ( LDWORK.LT.L )
     $         INFO = -16
         END IF
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'NF01BR', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      IF ( ECOND ) THEN
         TOLDEF = TOL
         IF ( TOLDEF.LE.ZERO ) THEN
C
C           Use the default tolerance in rank determination.
C
            TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )
         END IF
      END IF
C
      NC = BSN + ST
      IF ( FULL ) THEN
C
C        Special case: l <= 1 or BSN = 0; R is just an upper triangular
C        matrix.
C
         IF ( LOWER ) THEN
C
C           Swap the diagonal elements of R and the elements of SDIAG
C           and, if COND = 'E', swap the upper and lower triangular
C           parts of R, in order to find the numerical rank.
C
            CALL DSWAP( N, R, LDR+1, SDIAG, 1 )
            IF ( ECOND ) THEN
               UPLOL  = 'U'
               TRANSL = TRANS
C
               DO 10 J = 1, N
                  CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 )
   10          CONTINUE
C
            ELSE
               UPLOL = UPLO
               IF ( TRANR ) THEN
                  TRANSL = 'N'
               ELSE
                  TRANSL = 'T'
               END IF
            END IF
         ELSE
            UPLOL  = UPLO
            TRANSL = TRANS
         END IF
C
         IF ( ECOND ) THEN
C
C           Estimate the reciprocal condition number and set the rank.
C           Workspace: 2*N.
C
            CALL MB03OD( 'No QR', N, N, R, LDR, IPAR, TOLDEF, SVLMAX,
     $                   DWORK, RANK, DUM, DWORK, LDWORK, INFO )
            RANKS(1) = RANK
C
         ELSEIF ( NCOND ) THEN
C
C           Determine rank(R) by checking zero diagonal entries.
C
            RANK = N
C
            DO 20 J = 1, N
               IF ( R(J,J).EQ.ZERO .AND. RANK.EQ.N )
     $            RANK = J - 1
   20       CONTINUE
C
            RANKS(1) = RANK
C
         ELSE
C
C           Use the stored rank.
C
            RANK = RANKS(1)
         END IF
C
C        Solve R*x = b, or R'*x = b using back or forward substitution.
C
         DUM(1) = ZERO
         IF ( RANK.LT.N )
     $      CALL DCOPY( N-RANK, DUM, 0, B(RANK+1), 1 )
         CALL DTRSV( UPLOL, TRANSL, 'NonUnit', RANK, R, LDR, B, 1 )
C
         IF ( LOWER ) THEN
C
C           Swap the diagonal elements of R and the elements of SDIAG
C           and, if COND = 'E', swap back the upper and lower triangular
C           parts of R.
C
            CALL DSWAP( N, R, LDR+1, SDIAG, 1 )
            IF ( ECOND ) THEN
C
               DO 30 J = 1, N
                  CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 )
   30          CONTINUE
C
            END IF
C
         END IF
         RETURN
      END IF
C
C     General case: l > 1 and BSN > 0.
C
      I = 1
      L = BN
      IF ( ECOND ) THEN
C
C        Estimate the reciprocal condition numbers and set the ranks.
C
         IF ( LOWER ) THEN
C
C           Swap the diagonal elements of R and the elements of SDIAG
C           and swap the upper and lower triangular parts of R, in order
C           to find the numerical rank. Swap S and the transpose of the
C           rectangular part of the last block column of R.
C
            DO 50 K = 1, BN
               CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 )
C
               DO 40 J = 1, BSN
                  CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 )
                  I = I + 1
   40          CONTINUE
C
   50       CONTINUE
C
            IF ( ST.GT.0 ) THEN
               CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 )
C
               DO 60 J = BSN + 1, NC
                  CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS )
                  CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 )
                  I = I + 1
   60          CONTINUE
C
            END IF
C
         END IF
C
         I1 = 1
C
C        Determine rank(R_k) using incremental condition estimation.
C        Workspace 2*MAX(BSN,ST).
C
         DO 70 K = 1, BN
            CALL MB03OD( 'No QR', BSN, BSN, R(I1,1), LDR, IPAR, TOLDEF,
     $                   SVLMAX, DWORK, RANKS(K), DUM, DWORK, LDWORK,
     $                   INFO )
            I1 = I1 + BSN
   70    CONTINUE
C
         IF ( ST.GT.0 ) THEN
            L = L + 1
            CALL MB03OD( 'No QR', ST, ST, R(I1,BSN+1), LDR, IPAR,
     $                   TOLDEF, SVLMAX, DWORK, RANKS(L), DUM, DWORK,
     $                   LDWORK, INFO )
         END IF
C
      ELSEIF ( NCOND ) THEN
C
C        Determine rank(R_k) by checking zero diagonal entries.
C
         IF ( LOWER ) THEN
C
            DO 90 K = 1, BN
               RANK = BSN
C
               DO 80 J = 1, BSN
                  IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.BSN )
     $               RANK = J - 1
                  I = I + 1
   80          CONTINUE
C
               RANKS(K) = RANK
   90       CONTINUE
C
            IF ( ST.GT.0 ) THEN
               L = L + 1
               RANK = ST
C
               DO 100 J = 1, ST
                  IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.ST )
     $               RANK = J - 1
                  I = I + 1
  100          CONTINUE
C
               RANKS(L) = RANK
            END IF
C
         ELSE
C
            DO 120 K = 1, BN
               RANK = BSN
C
               DO 110 J = 1, BSN
                  IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.BSN )
     $               RANK = J - 1
                  I = I + 1
  110          CONTINUE
C
               RANKS(K) = RANK
  120       CONTINUE
C
            IF ( ST.GT.0 ) THEN
               L = L + 1
               RANK = ST
C
               DO 130 J = BSN + 1, NC
                  IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.ST )
     $               RANK = J - BSN - 1
                  I = I + 1
  130          CONTINUE
C
               RANKS(L) = RANK
            END IF
         END IF
C
      ELSE
C
C        Set the number of elements of RANKS. Then use the stored ranks.
C
         IF ( ST.GT.0 )
     $      L = L + 1
      END IF
C
C     Solve the triangular system for x. If the system is singular,
C     then obtain a basic least squares solution.
C
      DUM(1) = ZERO
      IF ( LOWER .AND. .NOT.ECOND ) THEN
C
         IF ( .NOT.TRANR ) THEN
C
C           Solve R*x = b using back substitution, with R' stored in
C           the arrays R, SDIAG and S. Swap diag(R) and SDIAG.
C
            I1 = NTHS + 1
            IF ( ST.GT.0 ) THEN
               RANK = RANKS(L)
               IF ( RANK.LT.ST )
     $            CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 )
               CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 )
               CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK,
     $                     R(I1,BSN+1), LDR, B(I1), 1 )
               CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 )
               CALL DGEMV( 'Transpose', ST, NTHS, -ONE, S, LDS,
     $                     B(NTHS+1), 1, ONE, B, 1 )
            END IF
C
            DO 140 K = BN, 1, -1
               I1   = I1 - BSN
               RANK = RANKS(K)
               IF ( RANK.LT.BSN )
     $            CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 )
               CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 )
               CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK,
     $                     R(I1,1), LDR, B(I1), 1 )
               CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 )
  140       CONTINUE
C
         ELSE
C
C           Solve R'*x = b using forward substitution, with R' stored in
C           the arrays R, SDIAG and S. Swap diag(R) and SDIAG.
C
            I1 = 1
            IF ( TRANR ) THEN
               TRANSL = 'N'
            ELSE
               TRANSL = 'T'
            END IF
C
            DO 150 K = 1, BN
               RANK = RANKS(K)
               IF ( RANK.LT.BSN )
     $            CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 )
               CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 )
               CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, R(I1,1),
     $                     LDR, B(I1), 1 )
               CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 )
               I1 = I1 + BSN
  150       CONTINUE
C
            IF ( ST.GT.0 ) THEN
               RANK = RANKS(L)
               IF ( RANK.LT.ST )
     $            CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 )
               CALL DGEMV( 'NoTranspose', ST, NTHS, -ONE, S, LDS, B, 1,
     $                     ONE, B(I1), 1 )
               CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 )
               CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK,
     $                     R(I1,BSN+1), LDR, B(I1), 1 )
               CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 )
            END IF
C
         END IF
C
      ELSE
C
         IF ( .NOT.TRANR ) THEN
C
C           Solve R*x = b using back substitution.
C
            I1 = NTHS + 1
            IF ( ST.GT.0 ) THEN
               RANK = RANKS(L)
               IF ( RANK.LT.ST )
     $            CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 )
               CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1),
     $                     LDR, B(I1), 1 )
               CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR,
     $                     B(NTHS+1), 1, ONE, B, 1 )
            END IF
C
            DO 160 K = BN, 1, -1
               I1   = I1 - BSN
               RANK = RANKS(K)
               IF ( RANK.LT.BSN )
     $            CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 )
               CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1),
     $                     LDR, B(I1), 1 )
  160       CONTINUE
C
         ELSE
C
C           Solve R'*x = b using forward substitution.
C
            I1 = 1
C
            DO 170 K = 1, BN
               RANK = RANKS(K)
               IF ( RANK.LT.BSN )
     $            CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 )
               CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1),
     $                     LDR, B(I1), 1 )
               I1 = I1 + BSN
  170       CONTINUE
C
            IF ( ST.GT.0 ) THEN
               RANK = RANKS(L)
               IF ( RANK.LT.ST )
     $            CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 )
               CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, B, 1,
     $                     ONE, B(I1), 1 )
               CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1),
     $                     LDR, B(I1), 1 )
            END IF
C
         END IF
      END IF
C
      IF ( ECOND .AND. LOWER ) THEN
         I = 1
C
C        If COND = 'E' and UPLO = 'L', swap the diagonal elements of R
C        and the elements of SDIAG and swap back the upper and lower
C        triangular parts of R, including the part corresponding to S.
C
         DO 190 K = 1, BN
            CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 )
C
            DO 180 J = 1, BSN
               CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 )
               I = I + 1
  180       CONTINUE
C
  190    CONTINUE
C
         IF ( ST.GT.0 ) THEN
            CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 )
C
            DO 200 J = BSN + 1, NC
               CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS )
               CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 )
               I = I + 1
  200       CONTINUE
C
         END IF
C
      END IF
C
      RETURN
C
C *** Last line of NF01BR ***
      END


FUNCTION ncbeta (a, b, lambda, x, errmax) RESULT(fn_val)

!       ALGORITHM AS 310 APPL. STATIST. (1997), VOL. 46, NO. 1

!       Computes the cumulative distribution function of a
!       non-central beta random variable

! ELF90-compatible version by Alan Miller
! This version includes all of the other functions called.
! Latest revision - 29 November 1997

! N.B. Argument IFAULT has been removed

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)
REAL (dp), INTENT(IN) :: a, b, lambda, x, errmax
REAL (dp)             :: fn_val

! Local variables
INTEGER               :: xj, m, i, j, iter1, iter2, iterlo, iterhi

!       Local variable XJ gives the number of iterations taken

REAL (dp)             :: fx, gx, temp, ftemp, ebd, errbd, q, r, s, t, s0, &
                         s1, t0, t1, sum, psum, c, beta
REAL (dp), PARAMETER  :: zero = 0.0, half = 0.5, one = 1.0, five = 5.0

! EXTERNAL alngam, betain, betanc, gammad

fn_val = x

!       Check for admissibility of parameters

IF (lambda <= zero .OR. a <= zero .OR. b <= zero) THEN
  WRITE(*, *) 'Illegal value for A, B or LAMBDA in calling FUNCTION NCBETA'
  STOP
END IF
IF (x < zero .OR. x > one) THEN
  WRITE(*, *) 'Illegal value for X in calling FUNCTION NCBETA'
  STOP
END IF
IF (x == zero .OR. x == one) RETURN

c = lambda * half
xj = zero

IF (lambda < 54.0_dp) THEN

!       AS 226 as it stands is sufficient in this situation

  fn_val = betanc(x, a, b, lambda)
  RETURN
ELSE
  m = INT(c + half)
  iterlo = m - five * SQRT(REAL(m))
  iterhi = m + five * SQRT(REAL(m))
  t = - c + m * LOG(c) - alngam(m + one)
  q = EXP(t)
  r = q
  psum = q

  beta = alngam(a+ m) + alngam(b) - alngam(a + m + b)
  s1 = (a + m) * LOG(x) + b * LOG(one - x) - LOG(a + m) - beta
  gx = EXP(s1)
  fx = gx
  temp = betain(x, a + m, b, beta)
  ftemp= temp
  xj = xj + one
  sum = q - temp
  iter1= m

!      The first set of iterations starts from M and goes downwards

  20 IF (iter1 < iterlo) GO TO 30
  IF (q < errmax) GO TO 30
  q = q - iter1 / c
  xj = xj + one
  gx = (a + iter1) / (x * (a + b + iter1 - one)) * gx
  iter1= iter1- one
  temp =temp + gx
  psum = psum + q
  sum = sum + q * temp
  GO TO 20
  30 t0 = alngam(a + b) - alngam(a + one) - alngam(b)
  s0 = a * LOG(x) + b * LOG(one - x)

  DO i=1, iter1
    j = i - one
    s = s + EXP(t0 + s0 + j * LOG(x))
    t1 = LOG(a + b + j) - LOG(a + one + j) + t0
    t0 = t1
  END DO

!       Compute the first part of error bound

  errbd = (one - gammad(c, DBLE(iter1)))*(temp + s)
  q = r
  temp = ftemp
  gx = fx
  iter2 = m
  DO
    ebd = errbd + (one - psum) * temp
    IF (ebd < errmax .OR. iter2 >= iterhi) EXIT
    iter2 = iter2 + one
    xj = xj + one
    q = q * c / iter2
    psum = psum + q
    temp = temp - gx
    gx = x * (a + b + iter2 - one) / (a + iter2) * gx
  sum = sum + q * temp
  END DO
END IF
fn_val = sum

RETURN

CONTAINS

FUNCTION betanc(x, a, b, lambda) RESULT(fn_val)

!     ALGORITHM AS226 APPL. STATIST. (1987) VOL. 36, NO. 2
!     Incorporates modification AS R84 from AS vol. 39, pp 311-2, 1990

!     Returns the cumulative probability of X for the non-central beta
!     distribution with parameters A, B and non-centrality LAMBDA

!     Auxiliary routines required: ALNGAM - log-gamma function (ACM
!     291 or AS 245), BETAIN - incomplete-beta function (AS 63), and
!     the incomplete gamma function (gammad, AS 239).

! N.B. Argument IFAULT has been removed

REAL (dp), INTENT(IN) :: x, a, b, lambda
REAL (dp)             :: fn_val

! Local variables
REAL (dp)             :: ax, beta, c, errbd, gx, q, sumq, temp, xj, a0, x0

!     Change ERRMAX and ITRMAX if desired ...

REAL (dp), PARAMETER  :: errmax = 1.0E-6_dp, ualpha = 5.0_dp, zero = 0.0_dp, &
                         half = 0.5_dp, one = 1.0_dp
INTEGER, PARAMETER    :: itrmax = 100

fn_val = x

IF (lambda < zero .OR. a <= zero .OR. b <= zero) THEN
  WRITE(*, *) 'Illegal value for A, B or LAMBDA in calling FUNCTION BETANC'
  STOP
END IF
IF (x < zero .OR. x > one) THEN
  WRITE(*, *) 'Illegal value for X in calling FUNCTION BETANC'
  STOP
END IF
IF (x == zero .OR. x == one) RETURN

c = lambda * half

!     Initialize the series ...

x0 = INT( MAX(c - ualpha*SQRT(c), zero) )
a0 = a + x0
beta = alngam(a0) + alngam(b) - alngam(a0+b)
temp = betain(x, a0, b, beta)
gx = EXP(a0 * LOG(x) + b * LOG(one - x) - beta - LOG(a0))
IF (a0 > a) THEN
  q = EXP(-c + x0*LOG(c)) - alngam(x0 + one)
ELSE
  q = EXP(-c)
END IF
xj = zero
ax = q * temp
sumq = one - q
fn_val = ax

!     Recur over subsequent terms until convergence is achieved...

10 xj = xj + one
temp = temp - gx
gx = x * (a + b + xj - one) * gx / (a + xj)
q = q * c / xj
sumq = sumq - q
ax = temp * q
fn_val = fn_val + ax

!     Check for convergence and act accordingly...

errbd = (temp - gx) * sumq
IF ((INT(xj) < itrmax) .AND. (errbd > errmax)) GO TO 10
IF (errbd > errmax) WRITE(*, *) 'Error bound too large in BETANC'

RETURN
END FUNCTION betanc

FUNCTION betain(x, p, q, beta) RESULT(fn_val)

!     algorithm as 63  appl. statist. (1973), vol.22, no.3

!     computes incomplete beta function ratio for arguments
!     x between zero and one, p and q positive.
!     log of complete beta function, beta, is assumed to be known

! ELF90-compatible version by Alan Miller
! N.B. Argument IFAULT has been removed

! Latest revision - 29 November 1997

REAL (dp), INTENT(IN) :: x, p, q, beta
REAL (dp)             :: fn_val

! Local variables
LOGICAL               :: indx
INTEGER               :: ns
REAL (dp)             :: psq, cx, xx, pp, qq, term, ai, rx, temp

!     define accuracy and initialise

REAL (dp), PARAMETER  :: zero = 0.0_dp, one = 1.0_dp, acu = 1.0E-14_dp

fn_val = x

!     test for admissibility of arguments

IF(p <= zero .OR. q <= zero) THEN
  WRITE(*, *) 'AS63: Either p or q <= 0'
  RETURN
END IF
IF(x < zero .OR. x > one) THEN
  WRITE(*, *) 'AS63: Argument x outside range (0, 1)'
  RETURN
END IF
IF(x == zero .OR. x == one) RETURN

!     change tail if necessary and determine s

psq = p + q
cx = one - x
IF(p < psq*x) THEN
  xx = cx
  cx = x
  pp = q
  qq = p
  indx = .true.
ELSE
  xx = x
  pp = p
  qq = q
  indx = .false.
END IF
term = one
ai = one
fn_val = one
ns = qq + cx*psq

!     user soper's reduction formulae.

rx = xx/cx
3 temp = qq - ai
IF(ns == 0) rx = xx
4 term = term*temp*rx/(pp+ai)
fn_val = fn_val + term
temp = ABS(term)
IF(temp <= acu .AND. temp <= acu*fn_val) GO TO 5
ai = ai + one
ns = ns - 1
IF(ns >= 0) GO TO 3
temp = psq
psq = psq+one
GO TO 4

!     calculate result

5 fn_val = fn_val*EXP(pp*LOG(xx) + (qq-one)*LOG(cx) - beta)/pp
IF(indx) fn_val = one - fn_val

RETURN
END FUNCTION betain

FUNCTION gammad(x, p) RESULT(fn_val)

!      ALGORITHM AS239  APPL. STATIST. (1988) VOL. 37, NO. 3

!      Computation of the Incomplete Gamma Integral

!      Auxiliary functions required: ALOGAM = logarithm of the gamma
!      function, and ALNORM = algorithm AS66

! ELF90-compatible version by Alan Miller
! Latest revision - 29 November 1997

! N.B. Argument IFAULT has been removed

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)
REAL (dp), INTENT(IN) :: x, p
REAL (dp)             :: fn_val

! Local variables
REAL (dp)             :: pn1, pn2, pn3, pn4, pn5, pn6, arg, c, rn, a, b, an
REAL (dp), PARAMETER  :: zero = 0.d0, one = 1.d0, two = 2.d0, &
                         oflo = 1.d+37, three = 3.d0, nine = 9.d0, &
                         tol = 1.d-14, xbig = 1.d+8, plimit = 1000.d0, &
                         elimit = -88.d0
! EXTERNAL alogam, alnorm

fn_val = zero

!      Check that we have valid values for X and P

IF (p <= zero .OR. x < zero) THEN
  WRITE(*, *) 'AS239: Either p <= 0 or x < 0'
  RETURN
END IF
IF (x == zero) RETURN

!      Use a normal approximation if P > PLIMIT

IF (p > plimit) THEN
  pn1 = three * SQRT(p) * ((x / p) ** (one / three) + one /(nine * p) - one)
  fn_val = alnorm(pn1, .false.)
  RETURN
END IF

!      If X is extremely large compared to P then set fn_val = 1

IF (x > xbig) THEN
  fn_val = one
  RETURN
END IF

IF (x <= one .OR. x < p) THEN

!      Use Pearson's series expansion.
!      (Note that P is not large enough to force overflow in ALNGAM).

  arg = p * LOG(x) - x - alngam(p + one)
  c = one
  fn_val = one
  a = p
  40   a = a + one
  c = c * x / a
  fn_val = fn_val + c
  IF (c > tol) GO TO 40
  arg = arg + LOG(fn_val)
  fn_val = zero
  IF (arg >= elimit) fn_val = EXP(arg)

ELSE

!      Use a continued fraction expansion

  arg = p * LOG(x) - x - alngam(p)
  a = one - p
  b = a + x + one
  c = zero
  pn1 = one
  pn2 = x
  pn3 = x + one
  pn4 = x * b
  fn_val = pn3 / pn4
  60   a = a + one
  b = b + two
  c = c + one
  an = a * c
  pn5 = b * pn3 - an * pn1
  pn6 = b * pn4 - an * pn2
  IF (ABS(pn6) > zero) THEN
    rn = pn5 / pn6
    IF (ABS(fn_val - rn) <= MIN(tol, tol * rn)) GO TO 80
    fn_val = rn
  END IF

  pn1 = pn3
  pn2 = pn4
  pn3 = pn5
  pn4 = pn6
  IF (ABS(pn5) >= oflo) THEN

!      Re-scale terms in continued fraction if terms are large

    pn1 = pn1 / oflo
    pn2 = pn2 / oflo
    pn3 = pn3 / oflo
    pn4 = pn4 / oflo
  END IF
  GO TO 60
  80   arg = arg + LOG(fn_val)
  fn_val = one
  IF (arg >= elimit) fn_val = one - EXP(arg)
END IF

RETURN
END FUNCTION gammad

FUNCTION alngam(xvalue) RESULT(fn_val)

!     ALGORITHM AS245  APPL. STATIST. (1989) VOL. 38, NO. 2

!     Calculation of the logarithm of the gamma function

! ELF90-compatible version by Alan Miller
! Latest revision - 29 November 1997

! N.B. Argument IFAULT has been removed

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)
REAL (dp), INTENT(IN) :: xvalue
REAL (dp)             :: fn_val

! Local variables
REAL (dp) :: x, x1, x2, y

!     Coefficients of rational functions

REAL (dp), PARAMETER :: r1(9) = (/ -2.66685511495_dp, -24.4387534237_dp,  &
                                   -21.9698958928_dp,  11.1667541262_dp,  &
                                    3.13060547623_dp,  0.607771387771_dp, &
                                    11.9400905721_dp,  31.4690115749_dp,  &
                                    15.2346874070_dp /)
REAL (dp), PARAMETER :: r2(9) = (/ -78.3359299449_dp, -142.046296688_dp,  &
                                    137.519416416_dp,  78.6994924154_dp,  &
                                    4.16438922228_dp,  47.0668766060_dp,  &
                                    313.399215894_dp,  263.505074721_dp,  &
                                    43.3400022514_dp /)
REAL (dp), PARAMETER :: r3(9) = (/ -2.12159572323E5_dp,  2.30661510616E5_dp,  &
                                    2.74647644705E4_dp, -4.02621119975E4_dp,  &
                                   -2.29660729780E3_dp, -1.16328495004E5_dp,  &
                                   -1.46025937511E5_dp, -2.42357409629E4_dp,  &
                                   -5.70691009324E2_dp /)
REAL (dp), PARAMETER :: r4(5) = (/ 0.279195317918525_dp, 0.4917317610505968_dp, &
                                   0.0692910599291889_dp, 3.350343815022304_dp, &
                                   6.012459259764103_dp /)

!     Fixed constants

REAL (dp), PARAMETER :: alr2pi = 0.918938533204673_dp, four = 4._dp,  &
                        half = 0.5_dp, one = 1._dp, onep5 = 1.5_dp,   &
                        twelve = 12._dp, zero = 0._dp

!     Machine-dependant constants.
!     A table of values is given at the top of page 399 of the paper.
!     These values are for the IEEE double-precision format for which
!     B = 2, t = 53 and U = 1023 in the notation of the paper.

REAL (dp), PARAMETER :: xlge = 5.10E6_dp, xlgst = HUGE(1.0_dp)

x = xvalue
fn_val = zero

!     Test for valid function argument

IF (x >= xlgst) THEN
  WRITE(*, *) 'AS 245: Argument x too large'
  RETURN
END IF
IF (x <= zero) THEN
  WRITE(*, *) 'AS 245: Argument x <= 0'
  RETURN
END IF

!     Calculation for 0 < X < 0.5 and 0.5 <= X < 1.5 combined

IF (x < onep5) THEN
  IF (x < half) THEN
    fn_val = -LOG(x)
    y = x + one

!     Test whether X < machine epsilon

    IF (y == one) RETURN
  ELSE
    fn_val = zero
    y = x
    x = (x - half) - half
  END IF
  fn_val = fn_val + x * ((((r1(5)*y + r1(4))*y + r1(3))*y + r1(2))*y + r1(1)) / &
                    ((((y + r1(9))*y + r1(8))*y+ r1(7))*y + r1(6))
  RETURN
END IF

!     Calculation for 1.5 <= X < 4.0

IF (x < four) THEN
  y = (x - one) - one
  fn_val = y * ((((r2(5)*x + r2(4))*x + r2(3))*x + r2(2))*x + r2(1)) /  &
               ((((x + r2(9))*x + r2(8))*x + r2(7))*x+ r2(6))
  RETURN
END IF

!     Calculation for 4.0 <= X < 12.0

IF (x < twelve) THEN
  fn_val = ((((r3(5)*x + r3(4))*x + r3(3))*x + r3(2))*x + r3(1)) /  &
           ((((x + r3(9))*x + r3(8))*x + r3(7))*x + r3(6))
  RETURN
END IF

!     Calculation for X >= 12.0

y = LOG(x)
fn_val = x * (y - one) - half * y + alr2pi
IF (x > xlge) RETURN
x1 = one / x
x2 = x1 * x1
fn_val = fn_val + x1 * ((r4(3)*x2 + r4(2))*x2 + r4(1)) /  &
         ((x2 + r4(5))*x2 + r4(4))
RETURN
END FUNCTION alngam

FUNCTION alnorm(x, upper) RESULT(fn_val)

!  Algorithm AS66 Applied Statistics (1973) vol.22, no.3

!  Evaluates the tail area of the standardised normal curve
!  from x to infinity if upper is .true. or
!  from minus infinity to x if upper is .false.

REAL (dp), INTENT(IN) :: x
LOGICAL, INTENT(IN)   :: upper
REAL (dp)             :: fn_val

! Local variables
REAL (dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp, half = 0.5_dp, &
                        con = 1.28_dp
REAL (dp) :: z, y
LOGICAL   :: up

!*** machine dependent constants
REAL (dp), PARAMETER :: ltone = 7.0_dp, utzero = 18.66_dp

REAL (dp), PARAMETER :: p = 0.398942280444_dp, q = 0.39990348504_dp,   &
                        r = 0.398942280385_dp, a1 = 5.75885480458_dp,  &
                        a2 = 2.62433121679_dp, a3 = 5.92885724438_dp,  &
                        b1 = -29.8213557807_dp, b2 = 48.6959930692_dp, &
                        c1 = -3.8052E-8_dp, c2 = 3.98064794E-4_dp,     &
                        c3 = -0.151679116635_dp, c4 = 4.8385912808_dp, &
                        c5 = 0.742380924027_dp, c6 = 3.99019417011_dp, &
                        d1 = 1.00000615302_dp, d2 = 1.98615381364_dp,  &
                        d3 = 5.29330324926_dp, d4 = -15.1508972451_dp, &
                        d5 = 30.789933034_dp

up = upper
z = x
IF(z >=  zero) GO TO 10
up = .NOT. up
z = -z
10 IF(z <= ltone .OR. up .AND. z <= utzero) GO TO 20
fn_val = zero
GO TO 40
20 y = half*z*z
IF(z > con) GO TO 30

fn_val = half - z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
GO TO 40
30 fn_val = r*EXP(-y)/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/(z+c6))))))
40 IF(.NOT. up) fn_val = one - fn_val

RETURN
END FUNCTION alnorm

END FUNCTION ncbeta


        subroutine idd_frm(m,n,w,x,y)
c
c       transforms x into y via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c       In contrast to routine idd_sfrm, the present routine works best
c       when the length of the transformed vector is the integer n
c       output by routine idd_frmi, or when the length
c       is not specified, but instead determined a posteriori
c       using the output of the present routine. The transformed vector
c       output by the present routine is randomly permuted.
c
c       input:
c       m -- length of x
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m, as obtained
c            from the routine idd_frmi; n is the length of y
c       w -- initialization array constructed by routine idd_frmi
c       x -- vector to be transformed
c
c       output:
c       y -- transform of x
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,iw,n,k
        real*8 w(17*m+70),x(m),y(n)
c
c
c       Apply Rokhlin's random transformation to x, obtaining
c       w(16*m+71 : 17*m+70).
c
        iw = w(3+m+n)
        call idd_random_transf(x,w(16*m+70+1),w(iw))
c
c
c       Subselect from  w(16*m+71 : 17*m+70)  to obtain y.
c
        call idd_subselect(n,w(3),m,w(16*m+70+1),y)
c
c
c       Copy y into  w(16*m+71 : 16*m+n+70).
c
        do k = 1,n
          w(16*m+70+k) = y(k)
        enddo ! k
c
c
c       Fourier transform  w(16*m+71 : 16*m+n+70).
c
        call dfftf(n,w(16*m+70+1),w(4+m+n))
c
c
c       Permute  w(16*m+71 : 16*m+n+70)  to obtain y.
c
        call idd_permute(n,w(3+m),w(16*m+70+1),y)
c
c
        return
        end
c
c
c
c
        subroutine idd_sfrm(l,m,n,w,x,y)
c
c       transforms x into y via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c       In contrast to routine idd_frm, the present routine works best
c       when the length l of the transformed vector is known a priori.
c
c       input:
c       l -- length of y; l must be less than or equal to n
c       m -- length of x
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m, as obtained
c            from the routine idd_sfrmi
c       w -- initialization array constructed by routine idd_sfrmi
c       x -- vector to be transformed
c
c       output:
c       y -- transform of x
c
c       _N.B._: l must be less than or equal to n.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,iw,n,l,l2
        real*8 w(27*m+90),x(m),y(l)
c
c
c       Retrieve the number of pairs of outputs to be calculated
c       via sfft.
c
        l2 = w(3)
c
c
c       Apply Rokhlin's random transformation to x, obtaining
c       w(25*m+91 : 26*m+90).
c
        iw = w(4+m+l+l2)
        call idd_random_transf(x,w(25*m+90+1),w(iw))
c
c
c       Subselect from  w(25*m+91 : 26*m+90)  to obtain
c       w(26*m+91 : 26*m+n+90).
c
        call idd_subselect(n,w(4),m,w(25*m+90+1),w(26*m+90+1))
c
c
c       Fourier transform  w(26*m+91 : 26*m+n+90).
c
        call idd_sfft(l2,w(4+m+l),n,w(5+m+l+l2),w(26*m+90+1))
c
c
c       Copy the desired entries from  w(26*m+91 : 26*m+n+90)
c       to y.
c
        call idd_subselect(l,w(4+m),n,w(26*m+90+1),y)
c
c
        return
        end
c
c
c
c


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine ssor(niter)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   to perform pseudo-time stepping SSOR iterations
c   for five nonlinear pde's.
c---------------------------------------------------------------------

      implicit none
      integer niter

      include 'applu.incl'

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m, n, lst, lend
      integer istep
      double precision  tmp, tv(5*isiz1*isiz2)
      double precision  delunm(5)

      external timer_read
      double precision timer_read

c---------------------------------------------------------------------
c   begin pseudo-time stepping iterations
c---------------------------------------------------------------------
      tmp = 1.0d+00 / ( omega * ( 2.0d+00 - omega ) )

c---------------------------------------------------------------------
c   initialize a,b,c,d to zero (guarantees that page tables have been
c   formed, if applicable on given architecture, before timestepping).
c---------------------------------------------------------------------
      do j=1,isiz2
         do i=1,isiz1
            do n=1,5
               do m=1,5
                  a(m,n,i,j) = 0.d0
                  b(m,n,i,j) = 0.d0
                  c(m,n,i,j) = 0.d0
                  d(m,n,i,j) = 0.d0
               enddo
            enddo
         enddo
      enddo
      do i = 1, t_last
         call timer_clear(i)
      end do

c---------------------------------------------------------------------
c   compute the steady-state residuals
c---------------------------------------------------------------------
      call rhs

c---------------------------------------------------------------------
c   compute the L2 norms of newton iteration residuals
c---------------------------------------------------------------------
      call l2norm( isiz1, isiz2, isiz3, nx0, ny0, nz0,
     >             ist, iend, jst, jend,
     >             rsd, rsdnm )

c      if ( ipr .eq. 1 ) then
c         write (*,*) '          Initial residual norms'
c         write (*,*)
c         write (*,1007) ( rsdnm(m), m = 1, 5 )
c         write (*,'(/a)') 'Iteration RMS-residual of 5th PDE'
c      end if

      do i = 1, t_last
         call timer_clear(i)
      end do
      call timer_start(1)

c---------------------------------------------------------------------
c   the timestep loop
c---------------------------------------------------------------------
      do istep = 1, niter

c         if ( ( mod ( istep, inorm ) .eq. 0 ) .and.
c     >          ipr .eq. 1 ) then
c             write ( *, 1001 ) istep
c         end if
         if (mod ( istep, 20) .eq. 0 .or.
     >         istep .eq. itmax .or.
     >         istep .eq. 1) then
            if (niter .gt. 1) write( *, 200) istep
 200        format(' Time step ', i4)
         endif

c---------------------------------------------------------------------
c   perform SSOR iteration
c---------------------------------------------------------------------
         if (timeron) call timer_start(t_rhs)
         do k = 2, nz - 1
            do j = jst, jend
               do i = ist, iend
                  do m = 1, 5
                     rsd(m,i,j,k) = dt * rsd(m,i,j,k)
                  end do
               end do
            end do
         end do
         if (timeron) call timer_stop(t_rhs)

         lst = ist + jst
         lend = iend + jend

         do k = 2, nz -1
c---------------------------------------------------------------------
c   form the lower triangular part of the jacobian matrix
c---------------------------------------------------------------------
            if (timeron) call timer_start(t_jacld)
            call jacld(k)
            if (timeron) call timer_stop(t_jacld)

c---------------------------------------------------------------------
c   perform the lower triangular solution
c---------------------------------------------------------------------
            if (timeron) call timer_start(t_blts)
            call blts( isiz1, isiz2, isiz3,
     >                 nx, ny, nz, k,
     >                 omega,
     >                 rsd,
     >                 a, b, c, d,
     >                 ist, iend, jst, jend,
     >                 lst, lend )
            if (timeron) call timer_stop(t_blts)
         end do

         do k = nz - 1, 2, -1
c---------------------------------------------------------------------
c   form the strictly upper triangular part of the jacobian matrix
c---------------------------------------------------------------------
            if (timeron) call timer_start(t_jacu)
            call jacu(k)
            if (timeron) call timer_stop(t_jacu)

c---------------------------------------------------------------------
c   perform the upper triangular solution
c---------------------------------------------------------------------
            if (timeron) call timer_start(t_buts)
            call buts( isiz1, isiz2, isiz3,
     >                 nx, ny, nz, k,
     >                 omega,
     >                 rsd, tv,
     >                 d, a, b, c,
     >                 ist, iend, jst, jend,
     >                 lst, lend )
            if (timeron) call timer_stop(t_buts)
         end do

c---------------------------------------------------------------------
c   update the variables
c---------------------------------------------------------------------

         if (timeron) call timer_start(t_add)
         do k = 2, nz-1
            do j = jst, jend
               do i = ist, iend
                  do m = 1, 5
                     u( m, i, j, k ) = u( m, i, j, k )
     >                    + tmp * rsd( m, i, j, k )
                  end do
               end do
            end do
         end do
         if (timeron) call timer_stop(t_add)

c---------------------------------------------------------------------
c   compute the max-norms of newton iteration corrections
c---------------------------------------------------------------------
         if ( mod ( istep, inorm ) .eq. 0 ) then
            if (timeron) call timer_start(t_l2norm)
            call l2norm( isiz1, isiz2, isiz3, nx0, ny0, nz0,
     >                   ist, iend, jst, jend,
     >                   rsd, delunm )
            if (timeron) call timer_stop(t_l2norm)
c            if ( ipr .eq. 1 ) then
c                write (*,1006) ( delunm(m), m = 1, 5 )
c            else if ( ipr .eq. 2 ) then
c                write (*,'(i5,f15.6)') istep,delunm(5)
c            end if
         end if

c---------------------------------------------------------------------
c   compute the steady-state residuals
c---------------------------------------------------------------------
         if (timeron) call timer_start(t_rhs)
         call rhs
         if (timeron) call timer_stop(t_rhs)

c---------------------------------------------------------------------
c   compute the max-norms of newton iteration residuals
c---------------------------------------------------------------------
         if ( ( mod ( istep, inorm ) .eq. 0 ) .or.
     >        ( istep .eq. itmax ) ) then
            if (timeron) call timer_start(t_l2norm)
            call l2norm( isiz1, isiz2, isiz3, nx0, ny0, nz0,
     >                   ist, iend, jst, jend,
     >                   rsd, rsdnm )
            if (timeron) call timer_stop(t_l2norm)
c            if ( ipr .eq. 1 ) then
c                write (*,1007) ( rsdnm(m), m = 1, 5 )
c            end if
         end if

c---------------------------------------------------------------------
c   check the newton-iteration residuals against the tolerance levels
c---------------------------------------------------------------------
         if ( ( rsdnm(1) .lt. tolrsd(1) ) .and.
     >        ( rsdnm(2) .lt. tolrsd(2) ) .and.
     >        ( rsdnm(3) .lt. tolrsd(3) ) .and.
     >        ( rsdnm(4) .lt. tolrsd(4) ) .and.
     >        ( rsdnm(5) .lt. tolrsd(5) ) ) then
c            if (ipr .eq. 1 ) then
c               write (*,1004) istep
c            end if
            return
         end if

      end do

      call timer_stop(1)
      maxtime= timer_read(1)

      return

 1001 format (1x/5x,'pseudo-time SSOR iteration no.=',i4/)
 1004 format (1x/1x,'convergence was achieved after ',i4,
     >   ' pseudo-time steps' )
 1006 format (1x/1x,'RMS-norm of SSOR-iteration correction ',
     > 'for first pde  = ',1pe12.5/,
     > 1x,'RMS-norm of SSOR-iteration correction ',
     > 'for second pde = ',1pe12.5/,
     > 1x,'RMS-norm of SSOR-iteration correction ',
     > 'for third pde  = ',1pe12.5/,
     > 1x,'RMS-norm of SSOR-iteration correction ',
     > 'for fourth pde = ',1pe12.5/,
     > 1x,'RMS-norm of SSOR-iteration correction ',
     > 'for fifth pde  = ',1pe12.5)
 1007 format (1x/1x,'RMS-norm of steady-state residual for ',
     > 'first pde  = ',1pe12.5/,
     > 1x,'RMS-norm of steady-state residual for ',
     > 'second pde = ',1pe12.5/,
     > 1x,'RMS-norm of steady-state residual for ',
     > 'third pde  = ',1pe12.5/,
     > 1x,'RMS-norm of steady-state residual for ',
     > 'fourth pde = ',1pe12.5/,
     > 1x,'RMS-norm of steady-state residual for ',
     > 'fifth pde  = ',1pe12.5)

      end


!================================================================
!================================================================
!================================================================
!================================================================
subroutine hilbert1d(x,order,npoint)
  use amr_parameters, ONLY: qdp
  implicit none
  integer     ,INTENT(IN)                     ::npoint
  integer     ,INTENT(IN) ,dimension(1:npoint)::x
  real(qdp),INTENT(OUT),dimension(1:npoint)::order

  integer::ip

  do ip=1,npoint
#ifdef QUADHILBERT
     order(ip)=real(x(ip),kind=16)
#else
     order(ip)=real(x(ip),kind=8)
#endif
  end do

end subroutine hilbert1d
!================================================================
!================================================================
!================================================================
!================================================================
subroutine hilbert2d(x,y,order,bit_length,npoint)

  use amr_parameters, ONLY: qdp
  implicit none

  integer     ,INTENT(IN)                     ::bit_length,npoint
  integer     ,INTENT(IN) ,dimension(1:npoint)::x,y
  real(qdp),INTENT(OUT),dimension(1:npoint)::order

  logical,dimension(0:2*bit_length-1)::i_bit_mask
  logical,dimension(0:1*bit_length-1)::x_bit_mask,y_bit_mask
  integer,dimension(0:3,0:1,0:3)::state_diagram
  integer::i,ip,cstate,nstate,b0,b1,sdigit,hdigit

  if(bit_length>bit_size(bit_length))then
     write(*,*)'Maximum bit length=',bit_size(bit_length)
     write(*,*)'stop in hilbert2d'
     call clean_stop
  endif

  state_diagram = RESHAPE( (/ 1, 0, 2, 0, &
                            & 0, 1, 3, 2, &
                            & 0, 3, 1, 1, &
                            & 0, 3, 1, 2, &
                            & 2, 2, 0, 3, &
                            & 2, 1, 3, 0, &
                            & 3, 1, 3, 2, &
                            & 2, 3, 1, 0  /), &
                         & (/ 4, 2, 4 /) )

  do ip=1,npoint

     ! convert to binary
     do i=0,bit_length-1
        x_bit_mask(i)=btest(x(ip),i)
        y_bit_mask(i)=btest(y(ip),i)
     enddo

     ! interleave bits
     do i=0,bit_length-1
        i_bit_mask(2*i+1)=x_bit_mask(i)
        i_bit_mask(2*i  )=y_bit_mask(i)
     end do

     ! build Hilbert ordering using state diagram
     cstate=0
     do i=bit_length-1,0,-1
        b1=0 ; if(i_bit_mask(2*i+1))b1=1
        b0=0 ; if(i_bit_mask(2*i)  )b0=1
        sdigit=b1*2+b0
        nstate=state_diagram(sdigit,0,cstate)
        hdigit=state_diagram(sdigit,1,cstate)
        i_bit_mask(2*i+1)=btest(hdigit,1)
        i_bit_mask(2*i  )=btest(hdigit,0)
        cstate=nstate
     enddo

     ! save Hilbert key as double precision real
     order(ip)=0.
     do i=0,2*bit_length-1
        b0=0 ; if(i_bit_mask(i))b0=1
#ifdef QUADHILBERT
        order(ip)=order(ip)+real(b0,kind=16)*real(2,kind=16)**i
#else
        order(ip)=order(ip)+real(b0,kind=8)*real(2,kind=8)**i
#endif
     end do

  end do

end subroutine hilbert2d
!================================================================
!================================================================
!================================================================
!================================================================
subroutine hilbert3d(x,y,z,order,bit_length,npoint)
  use amr_parameters, ONLY: qdp
  implicit none

  integer     ,INTENT(IN)                     ::bit_length,npoint
  integer     ,INTENT(IN) ,dimension(1:npoint)::x,y,z
  real(qdp),INTENT(OUT),dimension(1:npoint)::order

  logical,dimension(0:3*bit_length-1)::i_bit_mask
  logical,dimension(0:1*bit_length-1)::x_bit_mask,y_bit_mask,z_bit_mask
  integer,dimension(0:7,0:1,0:11)::state_diagram
  integer::i,ip,cstate,nstate,b0,b1,b2,sdigit,hdigit

  if(bit_length>bit_size(bit_length))then
     write(*,*)'Maximum bit length=',bit_size(bit_length)
     write(*,*)'stop in hilbert3d'
     call clean_stop
  endif

  state_diagram = RESHAPE( (/   1, 2, 3, 2, 4, 5, 3, 5,&
                            &   0, 1, 3, 2, 7, 6, 4, 5,&
                            &   2, 6, 0, 7, 8, 8, 0, 7,&
                            &   0, 7, 1, 6, 3, 4, 2, 5,&
                            &   0, 9,10, 9, 1, 1,11,11,&
                            &   0, 3, 7, 4, 1, 2, 6, 5,&
                            &   6, 0, 6,11, 9, 0, 9, 8,&
                            &   2, 3, 1, 0, 5, 4, 6, 7,&
                            &  11,11, 0, 7, 5, 9, 0, 7,&
                            &   4, 3, 5, 2, 7, 0, 6, 1,&
                            &   4, 4, 8, 8, 0, 6,10, 6,&
                            &   6, 5, 1, 2, 7, 4, 0, 3,&
                            &   5, 7, 5, 3, 1, 1,11,11,&
                            &   4, 7, 3, 0, 5, 6, 2, 1,&
                            &   6, 1, 6,10, 9, 4, 9,10,&
                            &   6, 7, 5, 4, 1, 0, 2, 3,&
                            &  10, 3, 1, 1,10, 3, 5, 9,&
                            &   2, 5, 3, 4, 1, 6, 0, 7,&
                            &   4, 4, 8, 8, 2, 7, 2, 3,&
                            &   2, 1, 5, 6, 3, 0, 4, 7,&
                            &   7, 2,11, 2, 7, 5, 8, 5,&
                            &   4, 5, 7, 6, 3, 2, 0, 1,&
                            &  10, 3, 2, 6,10, 3, 4, 4,&
                            &   6, 1, 7, 0, 5, 2, 4, 3 /), &
                            & (/8 ,2, 12 /) )

  do ip=1,npoint

     ! convert to binary
     do i=0,bit_length-1
        x_bit_mask(i)=btest(x(ip),i)
        y_bit_mask(i)=btest(y(ip),i)
        z_bit_mask(i)=btest(z(ip),i)
     enddo

     ! interleave bits
     do i=0,bit_length-1
        i_bit_mask(3*i+2)=x_bit_mask(i)
        i_bit_mask(3*i+1)=y_bit_mask(i)
        i_bit_mask(3*i  )=z_bit_mask(i)
     end do

     ! build Hilbert ordering using state diagram
     cstate=0
     do i=bit_length-1,0,-1
        b2=0 ; if(i_bit_mask(3*i+2))b2=1
        b1=0 ; if(i_bit_mask(3*i+1))b1=1
        b0=0 ; if(i_bit_mask(3*i  ))b0=1
        sdigit=b2*4+b1*2+b0
        nstate=state_diagram(sdigit,0,cstate)
        hdigit=state_diagram(sdigit,1,cstate)
        i_bit_mask(3*i+2)=btest(hdigit,2)
        i_bit_mask(3*i+1)=btest(hdigit,1)
        i_bit_mask(3*i  )=btest(hdigit,0)
        cstate=nstate
     enddo

     ! save Hilbert key as double precision real
     order(ip)=0.
     do i=0,3*bit_length-1
        b0=0 ; if(i_bit_mask(i))b0=1
#ifdef QUADHILBERT
        order(ip)=order(ip)+real(b0,kind=16)*real(2,kind=16)**i
#else
        order(ip)=order(ip)+real(b0,kind=8)*real(2,kind=8)**i
#endif
     end do

  end do

end subroutine hilbert3d
!================================================================
!================================================================
!================================================================
!================================================================