module rectangular_channel

    use define_settings, only: setting
    use define_globals
    use define_indexes
    use define_keys

    implicit none

    !%-----------------------------------------------------------------------------
    !% Description:
    !% Rectangular channel geometry
    !%

    private

    public :: rectangular_depth_from_volume
    public :: rectangular_area_from_depth
    public :: rectangular_area_from_depth_singular
    public :: rectangular_topwidth_from_depth
    public :: rectangular_topwidth_from_depth_singular
    public :: rectangular_perimeter_from_depth
    public :: rectangular_perimeter_from_depth_singular
    public :: rectangular_hyddepth_from_depth
    public :: rectangular_hyddepth_from_depth_singular
    public :: rectangular_hydradius_from_depth_singular

    contains

!%==========================================================================
!% PUBLIC
!%==========================================================================
!%
    subroutine rectangular_depth_from_volume (elemPGx, Npack, thisCol)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Only applies on open channels (or non-surcharged rectangular conduits)
        !% Input elemPGx is pointer (already assigned) for elemPGalltm, elemPGetm or elemPGac
        !% Assumes that volume > 0 is enforced in volume computations.
        !% NOTE: this does NOT limit the depth by surcharge height at this point
        !% This will be done after the head is computed.
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:), Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: depth(:), volume(:), length(:), breadth(:)
        !%-----------------------------------------------------------------------------
        thisP   => elemPGx(1:Npack,thisCol)
        depth   => elemR(:,er_Depth)
        volume  => elemR(:,er_Volume)
        length  => elemR(:,er_Length)
        breadth => elemSGR(:,esgr_Rectangular_Breadth)
        !%-----------------------------------------------------------------------------

        depth(thisP) = volume(thisP) / (length(thisP) * breadth(thisP))

    end subroutine rectangular_depth_from_volume
    !%
!%==========================================================================
!%==========================================================================
!%
    elemental real(8) function rectangular_area_from_depth (indx) result (outvalue)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes area from known depth for rectangular cross section
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx  ! may be a packed array of indexes
        !%-----------------------------------------------------------------------------
        outvalue = elemR(indx,er_Depth) * elemSGR(indx,esgr_Rectangular_Breadth)

    end function rectangular_area_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function rectangular_area_from_depth_singular (indx) result (outvalue)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes area from known depth for rectangular cross section of a single element
        !% The input indx is the row index in full data 2D array.
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Rectangular_Breadth)
        !%-----------------------------------------------------------------------------
        outvalue = depth(indx) * breadth(indx)

    end function rectangular_area_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine rectangular_topwidth_from_depth (elemPGx, Npack, thisCol)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the topwidth from a known depth in a rectangular channel
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:)
        integer, intent(in) ::  Npack, thisCol
        integer, pointer :: thisP(:), GeomType(:)
        real(8), pointer :: breadth(:), topwidth(:), depth(:), fullDepth(:)
        !%-----------------------------------------------------------------------------
        thisP     => elemPGx(1:Npack,thisCol)
        GeomType  => elemI(:,ei_geometryType)
        topwidth  => elemR(:,er_Topwidth)
        depth     => elemR(:,er_Depth)
        fullDepth => elemR(:,er_FullDepth)
        breadth   => elemSGR(:,esgr_Rectangular_Breadth)
        !%-----------------------------------------------------------------------------

        topwidth(thisP) = breadth(thisP)

        !% HACK code: testing if rectangular open and closed can be
        !% incorporated in a single piece of code
        where ((GeomType(thisP) == rectangular_closed) .and. &
               (depth(thisP) >= fullDepth(thisP)))
               topwidth(thisP) = setting%ZeroValue%Topwidth
        end where

    end subroutine rectangular_topwidth_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function rectangular_topwidth_from_depth_singular (indx) result (outvalue)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the topwidth for a rectangular cross section of a single element
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        !%-----------------------------------------------------------------------------
        !%
        outvalue = elemSGR(indx,esgr_Rectangular_Breadth)

    end function rectangular_topwidth_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine rectangular_perimeter_from_depth (elemPGx, Npack, thisCol)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the perimeter from a known depth in a rectangular channel
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:)
        integer, intent(in) ::  Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: breadth(:), depth(:), perimeter(:)
        !%-----------------------------------------------------------------------------
        thisP     => elemPGx(1:Npack,thisCol)
        breadth   => elemSGR(:,esgr_Rectangular_Breadth)
        depth     => elemR(:,er_Depth)
        perimeter => elemR(:,er_Perimeter)
        !%-----------------------------------------------------------------------------

        perimeter(thisP) = twoR * depth(thisP) + breadth(thisP)

    end subroutine rectangular_perimeter_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function rectangular_perimeter_from_depth_singular (indx) result (outvalue)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes wetted perimeter from known depth for a rectangular cross section of
        !% a single element
        !%-----------------------------------------------------------------------------
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Rectangular_Breadth)
        !%-----------------------------------------------------------------------------

        outvalue = twoR * depth(indx) + breadth(indx)

    end function rectangular_perimeter_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine rectangular_hyddepth_from_depth (elemPGx, Npack, thisCol)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the hydraulic (average) depth from a known depth in a rectangular channel
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:)
        integer, intent(in) ::  Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: hyddepth(:), depth(:)
        !%-----------------------------------------------------------------------------
        thisP     => elemPGx(1:Npack,thisCol)
        depth     => elemR(:,er_Depth)
        hyddepth  => elemR(:,er_HydDepth)
        !%-----------------------------------------------------------------------------

        hyddepth(thisP) = depth(thisP)

    end subroutine rectangular_hyddepth_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function rectangular_hyddepth_from_depth_singular (indx) result (outvalue)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes hydraulic depth from known depth for rectangular cross section of
        !% a single element
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        !%-----------------------------------------------------------------------------

        outvalue = elemR(indx,er_Depth)

    end function rectangular_hyddepth_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function rectangular_hydradius_from_depth_singular (indx) result (outvalue)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes hydraulic radius from known depth for a rectangular cross section of
        !% a single element
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Rectangular_Breadth)
        !%-----------------------------------------------------------------------------

        outvalue = (depth(indx) * breadth(indx)) / ( twoR * depth(indx) + breadth(indx) )

    end function rectangular_hydradius_from_depth_singular
    !%
!%==========================================================================

!%
!%
!%==========================================================================
!%==========================================================================
!%
    !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !%
        !%-----------------------------------------------------------------------------

        !%-----------------------------------------------------------------------------
        !%
!%
!%
!%==========================================================================
!%==========================================================================
!%
    !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !%
        !%-----------------------------------------------------------------------------

        !%-----------------------------------------------------------------------------
        !%
!%
!%
!%==========================================================================
!%==========================================================================
!%
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !%
        !%-----------------------------------------------------------------------------

        !%-----------------------------------------------------------------------------
        !%
!%
!%
!%==========================================================================
!% PRIVATE
!%==========================================================================
!%
        !%-----------------------------------------------------------------------------
        !% Description:
        !%
        !%-----------------------------------------------------------------------------

        !%-----------------------------------------------------------------------------
        !%

       !%==========================================================================
    ! !%
    ! subroutine rectangular_open_head_from_volume (elemPGx, Npack, thisCol)
    !     !%-----------------------------------------------------------------------------
    !     !% Description:
    !     !% Only applies on open channels (or non-surcharged rectangular conduits)
    !     !% Input elemPGx is pointer (already assigned) for elemPGalltm, elemPGetm or elemPGac
    !     !% Assumes that volume > 0 is enforced in volume computations.
    !     !%-----------------------------------------------------------------------------
    !     integer, target, intent(in) :: elemPGx(:,:), Npack, thisCol
    !     integer, pointer :: thisP(:)
    !     real(8), pointer :: head(:), volume(:), length(:), breadth(:), zbottom(:)
    !     !%-----------------------------------------------------------------------------
    !     thisP   => elemPGx(1:Npack,thisCol)
    !     head    => elemR(:,er_Head)
    !     volume  => elemR(:,er_Volume)
    !     length  => elemR(:,er_Length)
    !     breadth => elemSGR(:,esgr_Rectangular_Breadth)
    !     zbottom => elemR(:,er_Zbottom)
    !     !%-----------------------------------------------------------------------------

    !     head(thisP) = zbottom(thisP) + volume(thisP) / (length(thisP) * breadth(thisP))

    ! end subroutine rectangular_open_head_from_volume
    !%
    !%==========================================================================
    !%    !%==========================================================================
    !%
    ! subroutine rectangular_area_from_depth (elemPGx, Npack, thisCol)
    !     !%-----------------------------------------------------------------------------
    !     !% Description:
    !     !% Computes area of a rectangular open channel given its depth
    !     !% Note, does NOT consider any closed top!
    !     !%-----------------------------------------------------------------------------
    !     integer, target, intent(in) :: elemPGx(:,:)
    !     integer, intent(in) ::  Npack, thisCol
    !     integer, pointer :: thisP(:)
    !     real(8), pointer :: area(:), depth(:), breadth(:)
    !     !%-----------------------------------------------------------------------------
    !     thisP   => elemPGx(1:Npack,thisCol)
    !     area    => elemR(:,er_Area)
    !     depth   => elemR(:,er_Depth)
    !     breadth => elemSGR(:,esgr_Rectangular_Breadth)
    !     !%-----------------------------------------------------------------------------

    !     area(thisP) = depth(thisP) * breadth(thisP)

    ! end subroutine rectangular_area_from_depth
    ! !%
    ! !%==========================================================================
    !%==========================================================================
    !% END OF MODULE
    !%+=========================================================================
end module rectangular_channel


C
C     ..................................................................
C
C        SUBROUTINE GAUSS
C
C        PURPOSE
C           COMPUTES A NORMALLY DISTRIBUTED RANDOM NUMBER WITH A GIVEN
C           MEAN AND STANDARD DEVIATION
C
C        USAGE
C           CALL GAUSS(IX,S,AM,V)
C
C        DESCRIPTION OF PARAMETERS
C           IX -IX MUST CONTAIN AN ODD INTEGER NUMBER WITH NINE OR
C               LESS DIGITS ON THE FIRST ENTRY TO GAUSS. THEREAFTER
C               IT WILL CONTAIN A UNIFORMLY DISTRIBUTED INTEGER RANDOM
C               NUMBER GENERATED BY THE SUBROUTINE FOR USE ON THE NEXT
C               ENTRY TO THE SUBROUTINE.
C           S  -THE DESIRED STANDARD DEVIATION OF THE NORMAL
C               DISTRIBUTION.
C           AM -THE DESIRED MEAN OF THE NORMAL DISTRIBUTION
C           V  -THE VALUE OF THE COMPUTED NORMAL RANDOM VARIABLE
C
C        REMARKS
C           THIS SUBROUTINE USES RANDU WHICH IS MACHINE SPECIFIC
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           RANDU
C
C        METHOD
C           USES 12 UNIFORM RANDOM NUMBERS TO COMPUTE NORMAL RANDOM
C           NUMBERS BY CENTRAL LIMIT THEOREM. THE RESULT IS THEN
C           ADJUSTED TO MATCH THE GIVEN MEAN AND STANDARD DEVIATION.
C           THE UNIFORM RANDOM NUMBERS COMPUTED WITHIN THE SUBROUTINE
C           ARE FOUND BY THE POWER RESIDUE METHOD.
C
C     ..................................................................
C
      SUBROUTINE GAUSS(IX,S,AM,V)
      A=0.0
      DO 50 I=1,12
      CALL RANDO(IX,IY,Y)
      IX=IY
   50 A=A+Y
      V=(A-6.0)*S+AM
      RETURN
      END


subroutine adrf1d( n, a, np, adu )
!***************************************************************
!***************************************************************
!** This routine was generated by the                         **
!** Tangent linear and Adjoint Model Compiler,  TAMC 5.3.2    **
!***************************************************************
!***************************************************************
!==============================================
! all entries are defined explicitly
!==============================================
implicit none

!==============================================
! define common blocks
!==============================================
!==============================================
! define arguments
!==============================================
real a
integer n
real adu(n)
integer np

!==============================================
! define local variables
!==============================================
real adr(n)
integer i
integer ip
integer ip1
real one_a

!----------------------------------------------
! RESET LOCAL ADJOINT VARIABLES
!----------------------------------------------
do ip1 = 1, n
  adr(ip1) = 0.
end do

!----------------------------------------------
! ROUTINE BODY
!----------------------------------------------
one_a = 1.-a
do ip = np, 1, -1
  do i = 1, n-1
    adr(i) = adr(i)+adu(i)*one_a
    adu(i+1) = adu(i+1)+adu(i)*a
    adu(i) = 0.
  end do
  if (ip .eq. 1) then
    adr(n) = adr(n)+adu(n)/(1.+a)
    adu(n) = 0.
  else
    adr(n-1) = adr(n-1)-adu(n)*(one_a*a**3/(1.-a**2)**2)
    adr(n) = adr(n)+adu(n)*(one_a/(1.-a**2)**2)
    adu(n) = 0.
  endif
  do i = n, 2, -1
    adu(i) = adu(i)+adr(i)*one_a
    adr(i-1) = adr(i-1)+adr(i)*a
    adr(i) = 0.
  end do
  if (ip .eq. 1) then
    adu(1) = adu(1)+adr(1)*one_a
    adr(1) = 0.
  else if (ip .eq. 2) then
    adu(1) = adu(1)+adr(1)/(1.+a)
    adr(1) = 0.
  else
    adu(2) = adu(2)-adr(1)*(one_a*a**3/(1.-a**2)**2)
    adu(1) = adu(1)+adr(1)*(one_a/(1.-a**2)**2)
    adr(1) = 0.
  endif
end do

end subroutine adrf1d


      SUBROUTINE MB01OH( UPLO, TRANS, N, ALPHA, BETA, R, LDR, H, LDH, A,
     $                   LDA )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute one of the symmetric rank 2k operations
C
C        R := alpha*R + beta*H*A' + beta*A*H',
C
C     or
C
C        R := alpha*R + beta*H'*A + beta*A'*H,
C
C     where alpha and beta are scalars, R, A, and H are N-by-N matrices,
C     with A and H upper Hessenberg.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the symmetric matrix R is
C             given as follows:
C             = 'U':  the upper triangular part is given;
C             = 'L':  the lower triangular part is given.
C
C     TRANS   CHARACTER*1
C             Specifies the form of H to be used in the matrix
C             multiplication as follows:
C             = 'N':  R := alpha*R + beta*H*A' + beta*A*H';
C             = 'T':  R := alpha*R + beta*H'*A + beta*A'*H;
C             = 'C':  R := alpha*R + beta*H'*A + beta*A'*H.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices R, A, and H.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then R need not be
C             set before entry.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then A and H are not
C             referenced.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
C             On entry with UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix R.
C             On entry with UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix R.
C             In both cases, the other strictly triangular part is not
C             referenced.
C             On exit, the leading N-by-N upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
C             this array contains the corresponding triangular part of
C             the computed matrix R.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,N)
C             On entry, the leading N-by-N upper Hessenberg part of this
C             array must contain the upper Hessenberg matrix H.
C             The remaining part of this array is not referenced.
C
C     LDH     INTEGER
C             The leading dimension of array H.  LDH >= MAX(1,N)
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N upper Hessenberg part of this
C             array must contain the upper Hessenberg matrix A.
C             The remaining part of this array is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N)
C
C     METHOD
C
C     A particularization of the algorithm used in the BLAS 3 routine
C     DSYR2K is used.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately N**3/3 operations.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2019.
C
C     REVISIONS
C
C     V. Sima, Apr. 2019.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION  ALPHA, BETA
      INTEGER           LDA, LDH, LDR, N
      CHARACTER         TRANS, UPLO
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), H(LDH,*), R(LDR,*)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION  BETA2, TEMP
      INTEGER           I, INFO, J, J1
      LOGICAL           LTRANS, UPPER
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION  TMP(1)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      LOGICAL           LSAME
      EXTERNAL          DDOT, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DLASCL, DLASET, DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      UPPER  = LSAME( UPLO, 'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      INFO = 0
      IF ( .NOT.UPPER .AND. .NOT. LSAME( UPLO, 'L' ) ) THEN
         INFO = 1
      ELSE IF ( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LTRANS ) THEN
         INFO = 2
      ELSE IF ( N.LT.0 ) THEN
         INFO = 3
      ELSE IF ( LDR.LT.MAX( 1,N ) ) THEN
         INFO = 7
      ELSE IF ( LDH.LT.MAX( 1,N ) ) THEN
         INFO = 9
      ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN
         INFO = 11
      END IF
      IF ( INFO.NE.0) THEN
         CALL XERBLA( 'MB01OH', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. ( BETA.EQ.ZERO .AND. ALPHA.EQ.ONE ) )
     $   RETURN
C
      IF ( BETA.EQ.ZERO ) THEN
         IF ( ALPHA.EQ.ZERO ) THEN
C
C           Special case alpha = 0.
C
            CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR )
         ELSE
C
C           Special case beta = 0.
C
            IF ( ALPHA.NE.ONE )
     $         CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO )
         END IF
         RETURN
      END IF
C
C     Start the operations.
C
      IF ( .NOT.LTRANS ) THEN
C
C        Form  R := alpha*R + beta*H*A' + beta*A*H'.
C
         IF ( UPPER ) THEN
C
            DO 20 J = 1, N
               IF ( ALPHA.EQ.ZERO ) THEN
                  TMP(1) = ZERO
                  CALL DCOPY( J, TMP, 0, R(1,J), 1 )
               ELSE IF ( ALPHA.NE.ONE ) THEN
                  CALL DSCAL( J, ALPHA, R(1,J), 1 )
               END IF
C
               DO 10 I = MAX( 1, J-1 ), N
                  CALL DAXPY( J, BETA*A(J,I), H(1,I), 1, R(1,J), 1 )
                  CALL DAXPY( J, BETA*H(J,I), A(1,I), 1, R(1,J), 1 )
   10          CONTINUE
C
   20       CONTINUE
C
         ELSE
C
            DO 40 J = 1, N
               IF ( ALPHA.EQ.ZERO ) THEN
                  TMP(1) = ZERO
                  CALL DCOPY( N-J+1, TMP, 0, R(J,J), 1 )
               ELSE IF ( ALPHA.NE.ONE ) THEN
                  CALL DSCAL( N-J+1, ALPHA, R(J,J), 1 )
               END IF
C
               DO 30 I = MAX( 1, J-1 ), N - 1
                  CALL DAXPY( I-J+2, BETA*A(J,I), H(J,I), 1, R(J,J), 1 )
                  CALL DAXPY( I-J+2, BETA*H(J,I), A(J,I), 1, R(J,J), 1 )
   30          CONTINUE
C
               CALL DAXPY( N-J+1, BETA*A(J,N), H(J,N), 1, R(J,J), 1 )
               CALL DAXPY( N-J+1, BETA*H(J,N), A(J,N), 1, R(J,J), 1 )
   40       CONTINUE
C
          END IF
C
      ELSE
C
C        Form  R := alpha*R + beta*H'*A + beta*A'*H.
C
         BETA2 = TWO*BETA
C
         IF ( UPPER ) THEN
C
            DO 60 J = 1, N - 1
C
               DO 50 I = 1, J
                  TEMP = BETA*( DDOT( I+1, H(1,I), 1, A(1,J), 1 ) +
     $                          DDOT( I+1, A(1,I), 1, H(1,J), 1 ) )
                  IF ( ALPHA.EQ.ZERO ) THEN
                     R(I,J) = TEMP
                  ELSE
                     R(I,J) = ALPHA*R(I,J) + TEMP
                  END IF
   50          CONTINUE
C
   60       CONTINUE
C
            DO 70 I = 1, N - 1
               TEMP = BETA*( DDOT( I+1, H(1,I), 1, A(1,N), 1 ) +
     $                       DDOT( I+1, A(1,I), 1, H(1,N), 1 ) )
               IF ( ALPHA.EQ.ZERO ) THEN
                  R(I,N) = TEMP
               ELSE
                  R(I,N) = ALPHA*R(I,N) + TEMP
               END IF
   70       CONTINUE
C
            TEMP = BETA2*DDOT( N, H(1,N), 1, A(1,N), 1 )
            IF ( ALPHA.EQ.ZERO ) THEN
               R(N,N) = TEMP
            ELSE
               R(N,N) = ALPHA*R(N,N) + TEMP
            END IF
C
         ELSE
C
            DO 90 J = 1, N - 1
               J1 = J + 1
C
               DO 80 I = J, N
                  TEMP = BETA*( DDOT( J1, H(1,I), 1, A(1,J), 1 ) +
     $                          DDOT( J1, A(1,I), 1, H(1,J), 1 ) )
                  IF ( ALPHA.EQ.ZERO ) THEN
                     R(I,J) = TEMP
                  ELSE
                     R(I,J) = ALPHA*R(I,J) + TEMP
                  END IF
   80          CONTINUE
C
   90       CONTINUE
C
            TEMP = BETA2*DDOT( N, H(1,N), 1, A(1,N), 1 )
            IF ( ALPHA.EQ.ZERO ) THEN
               R(N,N) = TEMP
            ELSE
               R(N,N) = ALPHA*R(N,N) + TEMP
            END IF
C
         END IF
C
      END IF
C
      RETURN
C *** Last line of MB01OH ***
      END


module real_transform_routines

    use auxiliary_routines

    use fftpack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use complex_transform_routines, only: &
        cfftmi, cfftmf, cfftmb

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: rfft1i, rfft1b, rfft1f, rfft2i, rfft2b, rfft2f, rfftmi, rfftmb, rfftmf

    interface
        !
        !==> 1D real initialization
        !
        module subroutine rfft1i(n, wsave, lensav, ierror)
            !
            !  rfft1i: initialization for rfft1b and rfft1f.
            !
            !  purpose:
            !
            !  rfft1i initializes array wsave for use in its companion routines
            !  rfft1b and rfft1f.  the prime factorization of n together with a
            !  tabulation of the trigonometric functions are computed and stored
            !  in array wsave.  separate wsave arrays are required for different
            !  values of n.
            !
            !  parameters:
            !
            !  integer n, the length of the sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  real wsave(lensav), containing the prime factors of
            !  n and also containing certain trigonometric values which will be used in
            !  routines rfft1b or rfft1f.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least n + int(log(real(n))) + 4.
            !
            !  integer ierror, error_flag.
            !  0, successful exit;
            !  2, input parameter lensav not big enough.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)  :: n
            real (wp),    intent (out) :: wsave(lensav)
            integer (ip), intent (in)  :: lensav
            integer (ip), intent (out) :: ierror
            !--------------------------------------------------------------
        end subroutine rfft1i
        !
        !==> 1D real backward
        !
        module subroutine rfft1b(n, inc, r, lenr, wsave, lensav, work, lenwrk, ierror)
            !
            ! purpose:
            !
            !  computes the one-dimensional fourier transform of a periodic
            !  sequence within a real array. this is referred to as the backward
            !  transform or fourier synthesis, transforming the sequence from
            !  spectral to physical space.  this transform is normalized since a
            !  call to rfft1b followed by a call to rfft1f (or vice-versa) reproduces
            !  the original array within roundoff error.
            !
            !  parameters:
            !
            !  integer n, the length of the sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  integer inc, the increment between the locations,
            !  in array r, of two consecutive elements within the sequence.
            !
            !  input/real r(lenr), on input, the data to be
            !  transformed, and on output, the transformed data.
            !
            !  integer lenr, the dimension of the r array.
            !  lenr must be at least inc*(n-1) + 1.
            !
            !  input, real (wp) wsave(lensav).  wsave's contents must be
            !  initialized with a call to rfft1i before the first call to routine
            !  rfft1f or rfft1b for a given transform length n.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least n + int(log(real(n))) + 4.
            !
            !  workspace, real (wp) work(lenwrk).
            !
            !  integer lenwrk, the dimension of the work array.
            !  lenwrk must be at least n.
            !
            !  integer ierror, error_flag.
            !  0, successful exit;
            !  1, input parameter lenr not big enough;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip) lenr
            integer (ip) lensav
            integer (ip) lenwrk
            integer (ip) ierror
            integer (ip) inc
            integer (ip) n
            real (wp) r(lenr)
            real (wp) work(lenwrk)
            real (wp) wsave(lensav)
            !--------------------------------------------------------------

        end subroutine rfft1b
        !
        !==> 1D real forward
        !
        module subroutine rfft1f(n, inc, r, lenr, wsave, lensav, work, lenwrk, ierror)
            !
            ! rfft1f: 1d forward fast fourier transform
            !
            !  Purpose:
            !
            !  rfft1f computes the one-dimensional fourier transform of a periodic
            !  sequence within a real array. This is referred to as the forward
            !  transform or fourier analysis, transforming the sequence from physical
            !  to spectral space. This transform is normalized since a call to
            !  rfft1f followed by a call to rfft1b (or vice-versa) reproduces the
            !  original array within roundoff error.
            !
            !  Parameters:
            !
            !  integer n, the length of the sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  integer inc, the increment between the locations, in
            !  array r, of two consecutive elements within the sequence.
            !
            !  input/real r(lenr), on input, contains the sequence
            !  to be transformed, and on output, the transformed data.
            !
            !  integer lenr, the dimension of the r array.
            !  lenr must be at least inc*(n-1) + 1.
            !
            !  input, real (wp) wsave(lensav).  wsave's contents must be
            !  initialized with a call to rfft1i before the first call to routine rfft1f
            !  or rfft1b for a given transform length n.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least n + int(log(real(n))) + 4.
            !
            !  workspace, real (wp) work(lenwrk).
            !
            !  integer lenwrk, the dimension of the work array.
            !  lenwrk must be at least n.
            !
            !  integer ierror, error_flag.
            !  0, successful exit;
            !  1, input parameter lenr not big enough:
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)     :: n
            integer (ip), intent (in)     :: inc
            real (wp),    intent (in out) :: r(lenr)
            integer (ip), intent (in)     :: lenr
            real (wp),    intent (out)    :: work(lenwrk)
            integer (ip), intent (in)     :: lenwrk
            real (wp),    intent (in)     :: wsave(lensav)
            integer (ip), intent (in)     :: lensav
            integer (ip), intent (out)    :: ierror
            !--------------------------------------------------------------
        end subroutine rfft1f
        !
        !==> 2D real initialization
        !
        module subroutine rfft2i(l, m, wsave, lensav, ierror)
            !
            ! rfft2i: initialization for rfft2b and rfft2f.
            !
            !  purpose:
            !  rfft2i initializes real array wsave for use in its companion routines
            !  rfft2f and rfft2b for computing the two-dimensional fast fourier
            !  transform of real data.  prime factorizations of l and m, together with
            !  tabulations of the trigonometric functions, are computed and stored in
            !  array wsave.  rfft2i must be called prior to the first call to rfft2f
            !  or rfft2b.  separate wsave arrays are required for different values of
            !  l or m.
            !
            !
            !  integer l, the number of elements to be transformed
            !  in the first dimension.  the transform is most efficient when l is a
            !  product of small primes.
            !
            !  integer m, the number of elements to be transformed
            !  in the second dimension.  the transform is most efficient when m is a
            !  product of small primes.
            !
            !  integer lensav, the number of elements in the wsave
            !  array.  lensav must be at least l + m + int(log(real(l)))
            !  + int(log(real(m))) + 8.
            !
            !  real wsave(lensav), containing the prime factors
            !  of l and m, and also containing certain trigonometric values which
            !  will be used in routines rfft2b or rfft2f.
            !
            !  integer ier, error_flag.
            !  0, successful exit;
            !  2, input parameter lensav not big enough;
            !  20, input error returned by lower level routine.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)  :: l
            integer (ip), intent (in)  :: m
            real (wp),    intent (out) :: wsave(lensav)
            integer (ip), intent (in)  :: lensav
            integer (ip), intent (out) :: ierror
            !--------------------------------------------------------------
        end subroutine rfft2i
        !
        !==>  2D real backward
        !
        module subroutine rfft2b(ldim, l, m, r, wsave, lensav, work, lenwrk, ierror)
            !
            ! rfft2b: real backward fast fourier transform, 2d.
            !
            ! purpose:
            !
            !  computes the two-dimensional discrete fourier transform of the
            !  complex fourier coefficients a real periodic array.  this transform is
            !  known as the backward transform or fourier synthesis, transforming from
            !  spectral to physical space.  routine rfft2b is normalized: a call to
            !  rfft2b followed by a call to rfft2f (or vice-versa) reproduces the
            !  original array within roundoff error.
            !
            !  parameters:
            !
            !  integer ldim, the first dimension of the 2d real
            !  array r, which must be at least 2*(l/2+1).
            !
            !  integer l, the number of elements to be transformed
            !  in the first dimension of the two-dimensional real array r.  the value of
            !  l must be less than or equal to that of ldim.  the transform is most
            !  efficient when l is a product of small primes.
            !
            !  integer m, the number of elements to be transformed
            !  in the second dimension of the two-dimensional real array r.  the transform
            !  is most efficient when m is a product of small primes.
            !
            !  input/real r(ldim,m), the real array of two
            !  dimensions.  on input, r contains the l/2+1-by-m complex subarray of
            !  spectral coefficients, on output, the physical coefficients.
            !
            !  input, real (wp) wsave(lensav).  wsave's contents must be
            !  initialized with a call to rfft2i before the first call to routine rfft2f
            !  or rfft2b with lengths l and m.  wsave's contents may be re-used for
            !  subsequent calls to rfft2f and rfft2b with the same transform lengths
            !  l and m.
            !
            !  integer lensav, the number of elements in the wsave
            !  array.  lensav must be at least l + m + int(log(real(l)))
            !  + int(log(real(m))) + 8.
            !
            !  workspace, real (wp) work(lenwrk).  work provides workspace, and
            !  its contents need not be saved between calls to routines rfft2b and rfft2f.
            !
            !  integer  lenwrk, the number of elements in the work
            !  array.  lenwrk must be at least ldim*m.
            !
            !  integer ierror, the error_flag.
            !  0, successful exit;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough;
            !  6, input parameter ldim < 2*(l/2+1);
            !  20, input error returned by lower level routine.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)     :: ldim
            integer (ip), intent (in)     :: l
            integer (ip), intent (in)     :: m
            real (wp),    intent (in out) :: r(ldim,m)
            real (wp),    intent (in)     :: wsave(lensav)
            integer (ip), intent (in)     :: lensav
            real (wp),    intent (out)    :: work(lenwrk)
            integer (ip), intent (in)     :: lenwrk
            integer (ip), intent (out)    :: ierror
            !--------------------------------------------------------------
        end subroutine rfft2b
        !
        !==> 2D real forward
        !
        module subroutine rfft2f(ldim, l, m, r, wsave, lensav, work, lenwrk, ierror)
            !
            ! rfft2f: real forward fast fourier transform, 2d.
            !
            ! purpose:
            !
            !  rfft2f computes the two-dimensional discrete fourier transform of a
            !  real periodic array.  this transform is known as the forward transform
            !  or fourier analysis, transforming from physical to spectral space.
            !  routine rfft2f is normalized: a call to rfft2f followed by a call to
            !  rfft2b (or vice-versa) reproduces the original array within roundoff
            !  error.
            !
            !  parameters:
            !
            !  integer ldim, the first dimension of the 2d real
            !  array r, which must be at least 2*(l/2+1).
            !
            !  integer l, the number of elements to be transformed
            !  in the first dimension of the two-dimensional real array r.  the value
            !  of l must be less than or equal to that of ldim.  the transform is most
            !  efficient when l is a product of small primes.
            !
            !  integer m, the number of elements to be transformed
            !  in the second dimension of the two-dimensional real array r.  the
            !  transform is most efficient when m is a product of small primes.
            !
            !  input/real r(ldim,m), the real array of two
            !  dimensions.  on input, containing the l-by-m physical data to be
            !  transformed.  on output, the spectral coefficients.
            !
            !  input, real (wp) wsave(lensav).  wsave's contents must be
            !  initialized with a call to rfft2i before the first call to routine rfft2f
            !  or rfft2b with lengths l and m.  wsave's contents may be re-used for
            !  subsequent calls to rfft2f and rfft2b with the same transform lengths.
            !
            !  integer lensav, the number of elements in the wsave
            !  array.  lensav must be at least l + m + int(log(real(l)))
            !  + int(log(real(m))) + 8.
            !
            !  workspace, real (wp) work(lenwrk), provides workspace, and its
            !  contents need not be saved between calls to routines rfft2f and rfft2b.
            !
            !  integer lenwrk, the number of elements in the work
            !  array.  lenwrk must be at least ldim*m.
            !
            !  integer ierror, the error_flag.
            !  0, successful exit;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough;
            !  6, input parameter ldim < 2*(l+1);
            !  20, input error returned by lower level routine.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)     :: ldim
            integer (ip), intent (in)     :: l
            integer (ip), intent (in)     :: m
            real (wp),    intent (in out) :: r(ldim,m)
            real (wp),    intent (in)     :: wsave(lensav)
            integer (ip), intent (in)     :: lensav
            real (wp),    intent (out)    :: work(lenwrk)
            integer (ip), intent (in)     :: lenwrk
            integer (ip), intent (out)    :: ierror
            !--------------------------------------------------------------
        end subroutine rfft2f
        !
        !==> multiple real initialization
        !
        module subroutine rfftmi(n, wsave, lensav, ierror)
            !
            ! rfftmi: initialization for rfftmb and rfftmf.
            !
            !  purpose:
            !
            !  rfftmi initializes array wsave for use in its companion routines
            !  rfftmb and rfftmf.  the prime factorization of n together with a
            !  tabulation of the trigonometric functions are computed and stored
            !  in array wsave.  separate wsave arrays are required for different
            !  values of n.
            !
            !  input
            !
            !  integer n, the length of each sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least n + int(log(real(n))) + 4.
            !
            !  output
            !  real wsave(lensav), work array containing the prime
            !  factors of n and also containing certain trigonometric
            !  values which will be used in routines rfftmb or rfftmf.
            !
            !  integer ierror, error_flag.
            !  0, successful exit;
            !  2, input parameter lensav not big enough.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)  :: n
            integer (ip), intent (in)  :: lensav
            real (wp),    intent (out) :: wsave(lensav)
            integer (ip), intent (out) :: ierror
            !--------------------------------------------------------------
        end subroutine rfftmi
        !
        !==> multiple real backward
        !
        module subroutine rfftmb(lot, jump, n, inc, r, lenr, wsave, lensav, work, lenwrk, ierror)
            !
            ! rfftmb: real backward fft, 1d, multiple vectors.
            !
            ! purpose:
            !
            !  computes the one-dimensional fourier transform of multiple
            !  periodic sequences within a real array.  this transform is referred
            !  to as the backward transform or fourier synthesis, transforming the
            !  sequences from spectral to physical space.
            !
            !  this transform is normalized since a call to rfftmb followed
            !  by a call to rfftmf (or vice-versa) reproduces the original
            !  array  within roundoff error.
            !
            !  parameters:
            !
            !  integer lot, the number of sequences to be transformed
            !  within array r.
            !
            !  integer jump, the increment between the locations, in
            !  array r, of the first elements of two consecutive sequences to be
            !  transformed.
            !
            !  integer n, the length of each sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  integer inc, the increment between the locations, in
            !  array r, of two consecutive elements within the same sequence.
            !
            !  input/real r(lenr), real array containing lot
            !  sequences, each having length n.  r can have any number of dimensions,
            !  but the total number of locations must be at least lenr.  on input, the
            !  spectral data to be transformed, on output the physical data.
            !
            !  integer lenr, the dimension of the r array.
            !  lenr must be at least (lot-1)*jump + inc*(n-1) + 1.
            !
            !  input, real (wp) wsave(lensav).  wsave's contents must be
            !  initialized with a call to rfftmi before the first call to routine rfftmf
            !  or rfftmb for a given transform length n.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must  be at least n + int(log(real(n))) + 4.
            !
            !  workspace, real (wp) work(lenwrk).
            !
            !  integer lenwrk, the dimension of the work array.
            !  lenwrk must be at least lot*n.
            !
            !  integer ierror, error_flag.
            !  0, successful exit;
            !  1, input parameter lenr not big enough;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough;
            !  4, input parameters inc, jump, n, lot are not consistent.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)     :: lot
            integer (ip), intent (in)     :: jump
            integer (ip), intent (in)     :: n
            integer (ip), intent (in)     :: inc
            real (wp),    intent (in out) :: r(lenr)
            integer (ip), intent (in)     :: lenr
            real (wp),    intent (in)     :: wsave(lensav)
            integer (ip), intent (in)     :: lensav
            real (wp),    intent (out)    :: work(lenwrk)
            integer (ip), intent (in)     :: lenwrk
            integer (ip), intent (out)    :: ierror
            !--------------------------------------------------------------
        end subroutine rfftmb
        !
        !==> multiple real forward
        !
        module subroutine rfftmf(lot, jump, n, inc, r, lenr, wsave, lensav, work, lenwrk, ierror)
            !
            ! rfftmf: real forward fft, 1d, multiple vectors.
            !
            !  purpose:
            !
            !  rfftmf computes the one-dimensional fourier transform of multiple
            !  periodic sequences within a real array.  this transform is referred
            !  to as the forward transform or fourier analysis, transforming the
            !  sequences from physical to spectral space.
            !
            !  this transform is normalized since a call to rfftmf followed
            !  by a call to rfftmb (or vice-versa) reproduces the original array
            !  within roundoff error.
            !
            !  parameters:
            !
            !  integer lot, the number of sequences to be transformed
            !  within array r.
            !
            !  integer jump, the increment between the locations, in
            !  array r, of the first elements of two consecutive sequences to be
            !  transformed.
            !
            !  integer n, the length of each sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  integer inc, the increment between the locations,
            !  in array r, of two consecutive elements within the same sequence.
            !
            !  input/real r(lenr), real array containing lot
            !  sequences, each having length n.  r can have any number of dimensions, but
            !  the total number of locations must be at least lenr.  on input, the
            !  physical data to be transformed, on output the spectral data.
            !
            !  integer lenr, the dimension of the r array.
            !  lenr must be at least (lot-1)*jump + inc*(n-1) + 1.
            !
            !  input, real (wp) wsave(lensav).  wsave's contents must be
            !  initialized with a call to rfftmi before the first call to routine rfftmf
            !  or rfftmb for a given transform length n.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least n + int(log(real(n))) + 4.
            !
            !  workspace, real (wp) work(lenwrk).
            !
            !  integer lenwrk, the dimension of the work array.
            !  lenwrk must be at least lot*n.
            !
            !  integer ierror, error_flag.
            !  0, successful exit;
            !  1, input parameter lenr not big enough;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough;
            !  4, input parameters inc, jump, n, lot are not consistent.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)     :: lot
            integer (ip), intent (in)     :: jump
            integer (ip), intent (in)     :: n
            integer (ip), intent (in)     :: inc
            real (wp),    intent (in out) :: r(lenr)
            integer (ip), intent (in)     :: lenr
            real (wp),    intent (in)     :: wsave(lensav)
            integer (ip), intent (in)     :: lensav
            real (wp),    intent (out)    :: work(lenwrk)
            integer (ip), intent (in)     :: lenwrk
            integer (ip), intent (out)    :: ierror
            !--------------------------------------------------------------
        end subroutine rfftmf
    end interface

    !---------------------------------------------------------------------------------
    ! Variables confined to the module
    !---------------------------------------------------------------------------------
    real (wp), parameter :: ZERO = 0.0_wp
    real (wp), parameter :: HALF = 0.5_wp
    real (wp), parameter :: ONE = 1.0_wp
    real (wp), parameter :: TWO = 2.0_wp
    real (wp), parameter :: THREE = 3.0_wp
    real (wp), parameter :: FOUR = 4.0_wp
    real (wp), parameter :: FIVE = 5.0_wp
    !---------------------------------------------------------------------------------

end module real_transform_routines


C***********************************************************************
C    Module:  xsolve.f
C
C    Copyright (C) 2000 Mark Drela
C
C    This program is free software; you can redistribute it and/or modify
C    it under the terms of the GNU General Public License as published by
C    the Free Software Foundation; either version 2 of the License, or
C    (at your option) any later version.
C
C    This program is distributed in the hope that it will be useful,
C    but WITHOUT ANY WARRANTY; without even the implied warranty of
C    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C    GNU General Public License for more details.
C
C    You should have received a copy of the GNU General Public License
C    along with this program; if not, write to the Free Software
C    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
C***********************************************************************

      SUBROUTINE GAUSS(NSIZ,NN,Z,R,NRHS)
C     *******************************************************
C     *                                                     *
C     *   Solves general NxN system in NN unknowns          *
C     *    with arbitrary number (NRHS) of righthand sides. *
C     *   Assumes system is invertible...                   *
C     *    ...if it isn't, a divide by zero will result.    *
C     *                                                     *
C     *   Z is the coefficient matrix...                    *
C     *     ...destroyed during solution process.           *
C     *   R is the righthand side(s)...                     *
C     *     ...replaced by the solution vector(s).          *
C     *                                                     *
C     *                              Mark Drela  1984       *
C     *******************************************************
C
      DIMENSION Z(NSIZ,NSIZ), R(NSIZ,NRHS)
C
      DO 1 NP=1, NN-1
        NP1 = NP+1
C
C------ find max pivot index NX
        NX = NP
        DO 11 N=NP1, NN
          IF(ABS(Z(N,NP))-ABS(Z(NX,NP))) 11,11,111
  111      NX = N
   11   CONTINUE
C
        PIVOT = 1.0/Z(NX,NP)
C
C------ switch pivots
        Z(NX,NP) = Z(NP,NP)
C
C------ switch rows & normalize pivot row
        DO 12 L=NP1, NN
          TEMP = Z(NX,L)*PIVOT
          Z(NX,L) = Z(NP,L)
          Z(NP,L) = TEMP
   12   CONTINUE
C
        DO 13 L=1, NRHS
          TEMP = R(NX,L)*PIVOT
          R(NX,L) = R(NP,L)
          R(NP,L) = TEMP
   13   CONTINUE
C
C------ forward eliminate everything
        DO 15 K=NP1, NN
          ZTMP = Z(K,NP)
C
C          IF(ZTMP.EQ.0.0) GO TO 15
C
          DO 151 L=NP1, NN
            Z(K,L) = Z(K,L) - ZTMP*Z(NP,L)
  151     CONTINUE
          DO 152 L=1, NRHS
            R(K,L) = R(K,L) - ZTMP*R(NP,L)
  152     CONTINUE
   15   CONTINUE
C
    1 CONTINUE
C
C---- solve for last row
      DO 2 L=1, NRHS
        R(NN,L) = R(NN,L)/Z(NN,NN)
    2 CONTINUE
C
C---- back substitute everything
      DO 3 NP=NN-1, 1, -1
        NP1 = NP+1
        DO 31 L=1, NRHS
          DO 310 K=NP1, NN
            R(NP,L) = R(NP,L) - Z(NP,K)*R(K,L)
  310     CONTINUE
   31   CONTINUE
    3 CONTINUE
C
      RETURN
      END ! GAUSS

      SUBROUTINE CGAUSS(NSIZ,NN,Z,R,NRHS)
C********************************************
C     Solves general complex linear systems.
C********************************************
      COMPLEX Z(NSIZ,NSIZ), R(NSIZ,NRHS)
      COMPLEX PIVOT, TEMP, ZTMP
C
      DO 1 NP=1, NN-1
        NP1 = NP+1
C
C------ find max pivot index NX
        NX = NP
        DO 11 N=NP1, NN
          IF(ABS(Z(N,NP))-ABS(Z(NX,NP))) 11,11,111
  111      NX = N
   11   CONTINUE
C
        PIVOT = (1.0,0.0)/Z(NX,NP)
C
C------ switch pivots
        Z(NX,NP) = Z(NP,NP)
C
C------ switch rows & normalize pivot row
        DO 12 L=NP1, NN
          TEMP = Z(NX,L)*PIVOT
          Z(NX,L) = Z(NP,L)
          Z(NP,L) = TEMP
   12   CONTINUE
C
        DO 13 L=1, NRHS
          TEMP = R(NX,L)*PIVOT
          R(NX,L) = R(NP,L)
          R(NP,L) = TEMP
   13   CONTINUE
C
C------ forward eliminate everything
        DO 15 K=NP1, NN
          ZTMP = Z(K,NP)
C
C          IF(ZTMP.EQ.0.0) GO TO 15
C
          DO 151 L=NP1, NN
            Z(K,L) = Z(K,L) - ZTMP*Z(NP,L)
  151     CONTINUE
          DO 152 L=1, NRHS
            R(K,L) = R(K,L) - ZTMP*R(NP,L)
  152     CONTINUE
   15   CONTINUE
C
    1 CONTINUE
C
C---- solve for last row
      DO 2 L=1, NRHS
        R(NN,L) = R(NN,L)/Z(NN,NN)
    2 CONTINUE
C
C---- back substitute everything
      DO 3 NP=NN-1, 1, -1
        NP1 = NP+1
        DO 31 L=1, NRHS
          DO 310 K=NP1, NN
            R(NP,L) = R(NP,L) - Z(NP,K)*R(K,L)
  310     CONTINUE
   31   CONTINUE
    3 CONTINUE
C
      RETURN
      END ! CGAUSS

      SUBROUTINE LUDCMP(NSIZ,N,A,INDX)
C     *******************************************************
C     *                                                     *
C     *   Factors a full NxN matrix into an LU form.        *
C     *   Subr. BAKSUB can back-substitute it with some RHS.*
C     *   Assumes matrix is non-singular...                 *
C     *    ...if it isn't, a divide by zero will result.    *
C     *                                                     *
C     *   A is the matrix...                                *
C     *     ...replaced with its LU factors.                *
C     *                                                     *
C     *                              Mark Drela  1988       *
C     *******************************************************
C
      DIMENSION A(NSIZ,NSIZ), INDX(NSIZ)
C
      PARAMETER (NVX=500)
      DIMENSION VV(NVX)
C
      IF(N.GT.NVX) STOP 'LUDCMP: Array overflow. Increase NVX.'
C
      DO 12 I=1, N
        AAMAX = 0.
        DO 11 J=1, N
          AAMAX = MAX( ABS(A(I,J)) , AAMAX )
   11   CONTINUE
        VV(I) = 1.0/AAMAX
   12 CONTINUE
C
      DO 19 J=1, N
        DO 14 I=1, J-1
          SUM = A(I,J)
          DO 13 K=1, I-1
            SUM = SUM - A(I,K)*A(K,J)
   13     CONTINUE
          A(I,J) = SUM
   14   CONTINUE
C
        AAMAX = 0.
        DO 16 I=J, N
          SUM = A(I,J)
          DO 15 K=1, J-1
            SUM = SUM - A(I,K)*A(K,J)
   15     CONTINUE
          A(I,J) = SUM
C
          DUM = VV(I)*ABS(SUM)
          IF(DUM.GE.AAMAX) THEN
           IMAX = I
           AAMAX = DUM
          ENDIF
   16   CONTINUE
C
        IF(J.NE.IMAX) THEN
         DO 17 K=1, N
           DUM = A(IMAX,K)
           A(IMAX,K) = A(J,K)
           A(J,K) = DUM
   17    CONTINUE
         VV(IMAX) = VV(J)
        ENDIF
C
        INDX(J) = IMAX
        IF(J.NE.N) THEN
         DUM = 1.0/A(J,J)
         DO 18 I=J+1, N
           A(I,J) = A(I,J)*DUM
   18    CONTINUE
        ENDIF
C
   19 CONTINUE
C
      RETURN
      END ! LUDCMP

      SUBROUTINE BAKSUB(NSIZ,N,A,INDX,B)
      DIMENSION A(NSIZ,NSIZ), B(NSIZ), INDX(NSIZ)
C
      II = 0
      DO 12 I=1, N
        LL = INDX(I)
        SUM = B(LL)
        B(LL) = B(I)
        IF(II.NE.0) THEN
         DO 11 J=II, I-1
           SUM = SUM - A(I,J)*B(J)
   11    CONTINUE
        ELSE IF(SUM.NE.0.0) THEN
         II = I
        ENDIF
        B(I) = SUM
   12 CONTINUE
C
      DO 14 I=N, 1, -1
        SUM = B(I)
        IF(I.LT.N) THEN
         DO 13 J=I+1, N
           SUM = SUM - A(I,J)*B(J)
   13    CONTINUE
        ENDIF
        B(I) = SUM/A(I,I)
   14 CONTINUE
C
      RETURN
      END ! BAKSUB

      SUBROUTINE BLSOLV
C-----------------------------------------------------------------
C      Custom solver for coupled viscous-inviscid Newton system:
C
C        A  |  |  .  |  |  .  |    d       R       S
C        B  A  |  .  |  |  .  |    d       R       S
C        |  B  A  .  |  |  .  |    d       R       S
C        .  .  .  .  |  |  .  |    d   =   R - dRe S
C        |  |  |  B  A  |  .  |    d       R       S
C        |  Z  |  |  B  A  .  |    d       R       S
C        .  .  .  .  .  .  .  |    d       R       S
C        |  |  |  |  |  |  B  A    d       R       S
C
C       A, B, Z  3x3  blocks containing linearized BL equation coefficients
C       |        3x1  vectors containing mass defect influence
C                     coefficients on Ue
C       d        3x1  unknown vectors (Newton deltas for Ctau, Theta, m)
C       R        3x1  residual vectors
C       S        3x1  Re influence vectors
C-----------------------------------------------------------------
      INCLUDE 'XFOIL.INC'
C
      IVTE1 = ISYS(IBLTE(1),1)
C
      VACC1 = VACCEL
      VACC2 = VACCEL * 2.0 / (S(N) - S(1))
      VACC3 = VACCEL * 2.0 / (S(N) - S(1))
C
      DO 1000 IV=1, NSYS
C
        IVP = IV + 1
C
C====== Invert VA(IV) block
C
C------ normalize first row
        PIVOT = 1.0 / VA(1,1,IV)
        VA(1,2,IV) = VA(1,2,IV) * PIVOT
        DO 10 L=IV, NSYS
          VM(1,L,IV) = VM(1,L,IV)*PIVOT
   10   CONTINUE
        VDEL(1,1,IV) = VDEL(1,1,IV)*PIVOT
        VDEL(1,2,IV) = VDEL(1,2,IV)*PIVOT
C
C------ eliminate lower first column in VA block
        DO 15 K=2, 3
          VTMP = VA(K,1,IV)
          VA(K,2,IV) = VA(K,2,IV) - VTMP*VA(1,2,IV)
          DO 150 L=IV, NSYS
            VM(K,L,IV) = VM(K,L,IV) - VTMP*VM(1,L,IV)
  150     CONTINUE
          VDEL(K,1,IV) = VDEL(K,1,IV) - VTMP*VDEL(1,1,IV)
          VDEL(K,2,IV) = VDEL(K,2,IV) - VTMP*VDEL(1,2,IV)
   15   CONTINUE
C
C
C------ normalize second row
        PIVOT = 1.0 / VA(2,2,IV)
        DO 20 L=IV, NSYS
          VM(2,L,IV) = VM(2,L,IV)*PIVOT
   20   CONTINUE
        VDEL(2,1,IV) = VDEL(2,1,IV)*PIVOT
        VDEL(2,2,IV) = VDEL(2,2,IV)*PIVOT
C
C------ eliminate lower second column in VA block
        K = 3
        VTMP = VA(K,2,IV)
        DO 250 L=IV, NSYS
          VM(K,L,IV) = VM(K,L,IV) - VTMP*VM(2,L,IV)
  250   CONTINUE
        VDEL(K,1,IV) = VDEL(K,1,IV) - VTMP*VDEL(2,1,IV)
        VDEL(K,2,IV) = VDEL(K,2,IV) - VTMP*VDEL(2,2,IV)
C
C
C------ normalize third row
        PIVOT = 1.0/VM(3,IV,IV)
        DO 350 L=IVP, NSYS
          VM(3,L,IV) = VM(3,L,IV)*PIVOT
  350   CONTINUE
        VDEL(3,1,IV) = VDEL(3,1,IV)*PIVOT
        VDEL(3,2,IV) = VDEL(3,2,IV)*PIVOT
C
C
C------ eliminate upper third column in VA block
        VTMP1 = VM(1,IV,IV)
        VTMP2 = VM(2,IV,IV)
        DO 450 L=IVP, NSYS
          VM(1,L,IV) = VM(1,L,IV) - VTMP1*VM(3,L,IV)
          VM(2,L,IV) = VM(2,L,IV) - VTMP2*VM(3,L,IV)
  450   CONTINUE
        VDEL(1,1,IV) = VDEL(1,1,IV) - VTMP1*VDEL(3,1,IV)
        VDEL(2,1,IV) = VDEL(2,1,IV) - VTMP2*VDEL(3,1,IV)
        VDEL(1,2,IV) = VDEL(1,2,IV) - VTMP1*VDEL(3,2,IV)
        VDEL(2,2,IV) = VDEL(2,2,IV) - VTMP2*VDEL(3,2,IV)
C
C------ eliminate upper second column in VA block
        VTMP = VA(1,2,IV)
        DO 460 L=IVP, NSYS
          VM(1,L,IV) = VM(1,L,IV) - VTMP*VM(2,L,IV)
  460   CONTINUE
        VDEL(1,1,IV) = VDEL(1,1,IV) - VTMP*VDEL(2,1,IV)
        VDEL(1,2,IV) = VDEL(1,2,IV) - VTMP*VDEL(2,2,IV)
C
C
        IF(IV.EQ.NSYS) GO TO 1000
C
C====== Eliminate VB(IV+1) block, rows  1 -> 3
        DO 50 K=1, 3
          VTMP1 = VB(K, 1,IVP)
          VTMP2 = VB(K, 2,IVP)
          VTMP3 = VM(K,IV,IVP)
          DO 510 L=IVP, NSYS
            VM(K,L,IVP) = VM(K,L,IVP)
     &        - (  VTMP1*VM(1,L,IV)
     &           + VTMP2*VM(2,L,IV)
     &           + VTMP3*VM(3,L,IV) )
  510     CONTINUE
          VDEL(K,1,IVP) = VDEL(K,1,IVP)
     &        - (  VTMP1*VDEL(1,1,IV)
     &           + VTMP2*VDEL(2,1,IV)
     &           + VTMP3*VDEL(3,1,IV) )
          VDEL(K,2,IVP) = VDEL(K,2,IVP)
     &        - (  VTMP1*VDEL(1,2,IV)
     &           + VTMP2*VDEL(2,2,IV)
     &           + VTMP3*VDEL(3,2,IV) )
   50   CONTINUE
C
        IF(IV.EQ.IVTE1) THEN
C------- eliminate VZ block
         IVZ = ISYS(IBLTE(2)+1,2)
C
         DO 55 K=1, 3
           VTMP1 = VZ(K,1)
           VTMP2 = VZ(K,2)
           DO 515 L=IVP, NSYS
             VM(K,L,IVZ) = VM(K,L,IVZ)
     &         - (  VTMP1*VM(1,L,IV)
     &            + VTMP2*VM(2,L,IV) )
  515      CONTINUE
           VDEL(K,1,IVZ) = VDEL(K,1,IVZ)
     &         - (  VTMP1*VDEL(1,1,IV)
     &            + VTMP2*VDEL(2,1,IV) )
           VDEL(K,2,IVZ) = VDEL(K,2,IVZ)
     &         - (  VTMP1*VDEL(1,2,IV)
     &            + VTMP2*VDEL(2,2,IV) )
   55    CONTINUE
        ENDIF
C
        IF(IVP.EQ.NSYS) GO TO 1000
C
C====== Eliminate lower VM column
        DO 60 KV=IV+2, NSYS
          VTMP1 = VM(1,IV,KV)
          VTMP2 = VM(2,IV,KV)
          VTMP3 = VM(3,IV,KV)
C
          IF(ABS(VTMP1).GT.VACC1) THEN
          DO 610 L=IVP, NSYS
            VM(1,L,KV) = VM(1,L,KV) - VTMP1*VM(3,L,IV)
  610     CONTINUE
          VDEL(1,1,KV) = VDEL(1,1,KV) - VTMP1*VDEL(3,1,IV)
          VDEL(1,2,KV) = VDEL(1,2,KV) - VTMP1*VDEL(3,2,IV)
          ENDIF
C
          IF(ABS(VTMP2).GT.VACC2) THEN
          DO 620 L=IVP, NSYS
            VM(2,L,KV) = VM(2,L,KV) - VTMP2*VM(3,L,IV)
  620     CONTINUE
          VDEL(2,1,KV) = VDEL(2,1,KV) - VTMP2*VDEL(3,1,IV)
          VDEL(2,2,KV) = VDEL(2,2,KV) - VTMP2*VDEL(3,2,IV)
          ENDIF
C
          IF(ABS(VTMP3).GT.VACC3) THEN
          DO 630 L=IVP, NSYS
            VM(3,L,KV) = VM(3,L,KV) - VTMP3*VM(3,L,IV)
  630     CONTINUE
          VDEL(3,1,KV) = VDEL(3,1,KV) - VTMP3*VDEL(3,1,IV)
          VDEL(3,2,KV) = VDEL(3,2,KV) - VTMP3*VDEL(3,2,IV)
          ENDIF
C
   60   CONTINUE
C
 1000 CONTINUE
C
C
C
      DO 2000 IV=NSYS, 2, -1
C
C------ eliminate upper VM columns
        VTMP = VDEL(3,1,IV)
        DO 81 KV=IV-1, 1, -1
          VDEL(1,1,KV) = VDEL(1,1,KV) - VM(1,IV,KV)*VTMP
          VDEL(2,1,KV) = VDEL(2,1,KV) - VM(2,IV,KV)*VTMP
          VDEL(3,1,KV) = VDEL(3,1,KV) - VM(3,IV,KV)*VTMP
   81   CONTINUE
C
        VTMP = VDEL(3,2,IV)
        DO 82 KV=IV-1, 1, -1
          VDEL(1,2,KV) = VDEL(1,2,KV) - VM(1,IV,KV)*VTMP
          VDEL(2,2,KV) = VDEL(2,2,KV) - VM(2,IV,KV)*VTMP
          VDEL(3,2,KV) = VDEL(3,2,KV) - VM(3,IV,KV)*VTMP
   82   CONTINUE
C
 2000 CONTINUE
C
      RETURN
      END