************************************************************************
* Extended VANCA preconditioner, SCGS method
*
* Extended calling convention
*
* This routine performs one preconditioning step
*
*    (du,dp) = Vanca(F)
*
* with the full-block-Vanca preconditioner. (du,dp) must be =0
* initially. VANCP4 executes a local Block-Gauss-Seidel preconditioner
* onto the vector F to calculate a preconditioned vector (du,dp).
* In contrast to VANCP4, this routine uses a stronger approach which
* involves the solution of a local 4x4 system for every DOF.
*
* In:
*   U1,
*   U2     - array [1..NU] of double precision
*   P      - array [1..NP] of double precision
*            Velocity and Pressure components of the preconditioned
*            vector; must be =0 initially!
*   F1,
*   F2     - array [1..NU] of double precision
*   FP     - array [1..NP] of double precision
*            Velocity and pressure components of the vector that should
*            be preconditioned.
*   A,
*   KCOLA,
*   KLDA   - Current system matrix for velocity components
*
*   B1,
*   B2,
*   KCOLB,
*   KLDB   - The two pressure matrices
*
*   NU     - Length of velocity vectors and dimension of A
*   NP     - Length of pressure vectors and dimension of B1, B2
*
*   KMBD,
*   KVERT,
*   KMID,
*   KXNPR,
*   NVT,
*   NEL    - Usual geometry information;
*            KXNPR(.) decides on Dirichlet/Neumann nodes.
*
*   RLXSM  - Relaxation parameter; 0 <= RLXSM < 1
*
* Out:
*   U1,U2,P - Preconditioned vector, velocity and pressure
***********************************************************************

      SUBROUTINE  VANCP5 (U1,U2,P,F1,F2,FP,
     *                    A,KCOLA,KLDA,B1,B2,KCOLB,KLDB,NU,NP,
     *                    KMID,KXNPR,NEL,NVT)

      IMPLICIT NONE

C common blocks

      INCLUDE 'cout.inc'

      INCLUDE 'cbasictria.inc'

C parameters

      DOUBLE PRECISION U1(*),U2(*),P(*)
      DOUBLE PRECISION F1(*),F2(*),FP(*)
      DOUBLE PRECISION A(*),B1(*),B2(*)
      INTEGER KCOLA(*),KLDA(*),KCOLB(*),KLDB(*)
      INTEGER KMID(NNVE,*),KXNPR(2,*)
      INTEGER NU,NP
      INTEGER NEL,NVT
      DOUBLE PRECISION A1,A2

C     Local arrays for informations about one element

      DOUBLE PRECISION AA(4,4),BB1(4),BB2(4),FF1(4),FF2(4)
      INTEGER IU(4)
      LOGICAL BDBC(4)

C     local variables

      INTEGER IEL,ILD,IGD,IMID,IA,IB,IB1,IB2,JP1,JP2,ICOL,COL
      INTEGER IA1,IA2
      DOUBLE PRECISION FFP,PJP

C=======================================================================
C     Block Gauss-Seidel on Schur Complement
C=======================================================================

C     Basic algorithm:
C
C     What are we doing here? Well, we want to perform
C     *preconditioning*, i.e. we have to solve the problem
C
C       x_new  =  C^-1 (x_old)  =  C^-1 (F)  =  C^-1 (f,g)
C
C     for a "special" preconditioner C which we define in a moment.
C     This is equivalent to solving the system
C
C       C (x_new)  = x_old
C
C     C should be some approximation to A. Imagine our global system:
C
C         [ A   B ] (u) = (f)
C         [ B^t 0 ] (p)   (g)
C
C     In the Navier-Stokes equations with (u,p) being the preconditioned
C     vector, there should be g=0 - but this cannot be assumed
C     as it does not happen in general.
C     Now the algorithm for generating a new (u,p) vector from the old
C     one reads roughly as follows:
C
C     a) Restrict to a small part of the domain, in our case to one cell.
C     b) Fetch all the data (velocity, pressure) on that cell. On the
C        first cell, we have only "old" velocity entries. These values
C        are updated and then the calculation proceeds with the 2nd cell.
C
C               old                      new
C            |---X---|                |---X---|
C            |       |                |       |
C        old X   1   X old   -->  new X   1   X new
C            |       |                |       |
C            |---X---|                |---X---|
C               old                      new
C
C        From the second cell on, there might be "old" data and "new"
C        data on that cell - the old data that has not been updated and
C        perhaps some already updated velocity data from a neighbor cell.
C
C               new     old                   new     new
C            |---X---|---X---|             |---X---|---X---|
C            |       |       |             |       |       |
C        new X   1   X   2   X old --> new X   1   X   2   X new
C            |       |new    |             |       |newer  |
C            |---X---|---X---|             |---X---|---X---|
C               new     old                   new     new
C
C        These values are updated and then the calculation proceeds
C        with the next cell.
C        As can be seen in the above picture, the "new" node in the
C        middle is even going to be a "newer" node when handled again
C        for the 2nd cell. This is meant by "Gauss-Seldel" character:
C        Information is updated subsequently by using "old" data and
C        "new" data from a previous calculation.
C
C     So we start with a loop over all elements

      DO IEL=1,NEL

C       We now have the element
C                                            U3/V3
C       |---------|                       |----X----|
C       |         |                       |         |
C       |   IEL   |   with DOF's    U4/V4 X    P    X U2/V2
C       |         |                       |         |
C       |---------|                       |----X----|
C                                            U1/V1
C
C       Fetch the pressure P on the current element into FFP

        FFP=FP(IEL)

C       Loop over all 4 U-nodes of that element

        DO ILD=1,4

C         Calculate the DOF that belongs to our edge ILD:

          IMID = KMID(ILD,IEL)
          IGD  = IMID-NVT

C         Write the number of the edge/node to IU.

          IU(ILD) = IGD

        END DO

C       Sort IU in ascending order so that
C       it is sorted just like the global solution/rhs vector.
C
C       ONLY FOR DEBUGGING PURPOSES, not necessary in real
C       implementation; The vector IU defines the sorting.
C
C        DO ILD=1,4
C          DO COL=ILD+1,4
C            IF (IU(COL).LT.IU(ILD)) THEN
C              IGD = IU(ILD)
C              IU(ILD) = IU(COL)
C              IU(COL) = IGD
C            END IF
C          END DO
C        END DO

C       Now collect information about the nodes.

        DO ILD=1,4

          IGD = IU(ILD)
          IMID = IGD+NVT

C         Write into BDBC whether the edge is a Dirichlet-
C         Boundary edge:

          BDBC(ILD) = IAND(KXNPR(1,IMID),2**12).NE.0

C         Set FF1/FF2 initially to the value F1/F2 of the right hand
C         side vector that belongs to our current DOF corresponding
C         to II

          FF1(ILD) = F1(IGD)
          FF2(ILD) = F2(IGD)

        END DO

C       In a second loop build the local matrix and the RHS vectors.
C
C       Here a short description about the approach.
C       Again consider the problem:
C
C          [ A   B ] (u) = (f)
C          [ B^t 0 ] (p)   (g)
C
C       We assume, that all components in the vector (u,p) are
C       given - except for the four velocity unknowns and the
C       pressure unknown on the current element; these five unknowns
C       are located anywhere in the (u,p) vector. The idea is to
C       shift "everything known" to the right hand side to obtain
C       a system for only these unknowns!
C
C       Extracting all the lines of the system that correspond to
C       DOF's on our single element IEL results in a rectangular
C       system of the form
C
C          [ === A^ === B~ ] (|) = (f)
C          [ B~^t       0  ] (u)   (g)
C                            (|)
C                            (p)
C
C       <=>  [ MAT1 MAT2 B~ ] (u) = (fu)
C            [    ****   0  ] (p)   (fp)
C
C       with A^ being an 4 x (2*NVT) matrix for the two velocity
C       components and B being an (2*4) x 1 matrix that couples the
C       velocities to the pressure on our current element.
C       B~ is a 8 x 2 matrix: As every velocity couples with at most
C       two pressure elements on the neighbour cell, so we have
C       2 columns in the B-matrix.
C
C              IEL                              IEL
C           |--------|             |--------|--------|
C           |        |             |        |        |
C           |   P    |      or     |   Q    X   P    |
C           |        |             |        |        |
C         --|---X----|--           |--------|--------|
C
C       Now, throw all summands to the RHS vector that do
C       not correspond to the velocity/pressure DOF's on our single
C       element IEL!
C
C       That way, A^ is reduced to a square matrix with two square
C       submatrices A~ of size 4 x 4. The 8 x 2-matrix B~ reduces to
C       two 4 x 1 submatrices (originally, every velocity couples with
C       two pressure elements on the neighbour cell, so we have
C       2 columns in the B-matrix).
C
C       The system roughly looks like:
C
C       [ ....        B1 ] (u1)   (f1)           (| )           (| )           (| )
C       [ .A~.        |  ] (u2)   (| )           (| )           (| )           (| )
C       [ ....        |  ] (u3)   (| )           (| )           (| )           (| )
C       [ ....        |  ] (u4)   (| )           (| )           (| )           (| )
C       [       ....  B2 ] (v1) = (f2) - sum u_i (ci) - sum v_i (di) - sum   Q (qi)
C       [       .A~.  |  ] (v2)   (| )   i>4     (| )   i>4     (| )  Q in N   (| )
C       [       ....  |  ] (v3)   (| )           (| )           (| )           (| )
C       [       ....  |  ] (v4)   (| )           (| )           (| )           (| )
C       [ B1^T  B2^T  0  ] (p )   (fp)           (0 )           (0 )           (0 )
C
C       assuming in the example that element IEL contains u1,u2,u3,u4,
C       v1,v2,v3,v4 and p as DOF's, and using the notation that ci
C       and di are the i th column of matrix MAT1 and MAT2 above,
C       respectively. Q is the pressure on the neighbour elements in the
C       neighbourhood N of element IEL and qi the corresponding column
C       from the B~-matrix.
C       The above system obviously has the form
C
C           [ S         B1 ] (ul)   (du)
C           [      S    B2 ] (vl) = (dv)
C           [ B1^t B2^t  0 ] (p )   (dp)
C
C       The vector (du,dv,dp) is called "local residuum"; we'll build it
C       in FF1/FF2. The 4x4-matrix S (which is the same for both, X- and
C       Y-velocity here) we build in AA.
C
C       Note: This only holds for inner edges! For boundary edges, we
C       have to do a slight modification.
C
C       Clear the local matrix AA:

        CALL LCL1(AA,16)

C       Loop over the four DOF's of our element.

        DO ILD=1,4

C         Each local DOF ILD corresponds to the global DOF IGD=IU(ILD),
C         so we have to extract the line IGD into the row ILD of
C         the matrix AA.

          IGD = IU(ILD)

C         Loop through the line of the matrix. CCNT gives the next position
C         where to write in the local matrix. This is used as an index
C         in COLIDX to find the correct position where to write in the
C         local matrix.

          IA1 = KLDA(IGD)
          IA2 = KLDA(IGD+1)-1
          DO ICOL = IA1,IA2

C           Does this column belong to one of our four DOF's, or
C           do we have to throw it to the right hand side?

            IA = KCOLA(ICOL)
            DO COL=1,4

C             Use the following line to switch back to simple VANCA:
C              IF ((IA.EQ.IU(COL)).AND.(IA.EQ.IGD)) GOTO 50
C
C             The following line implements the extended VANCA:

              IF (IA.EQ.IU(COL)) GOTO 50

            END DO

C           Not found - this DOF has to be thrown to the RHS.
C           Mark that by setting ICOL > 4.
C           Otherwise, COL is the horizontal index where to write
C           into the local matrix.

            COL = 5

50          CONTINUE

            IF (COL.LE.4) THEN

C             This is a matrix entry belonging to one of our
C             DOF's. So note it into the local matrix AA.

              AA(ILD,COL) = A(ICOL)

C             Of course, don't modify the RHS or anything else.

            ELSE

C             This matrix entry must be moved to the right hand
C             side to create the "local residuum". But only for
C             inner edges - boundary edges are handled slightly
C             different!
C
C             Do we have a boundary edge?

              IF (.NOT.BDBC(ILD)) THEN

C               No, inner edge.
C               Subtract the A*u part from the RHS for the local
C               residuum. What we throw here to the RHS is therefore
C               on one hand a set of entries of the old velocities
C               as well as a set of entries which might have been
C               calculated by a previous update of another cell in
C               our neighbourhood.

                FF1(ILD) = FF1(ILD) - A(ICOL)*U1(IA)
                FF2(ILD) = FF2(ILD) - A(ICOL)*U2(IA)

              END IF ! not BDBC(ILD)

            END IF ! COL>4

          END DO ! ICOL

C         Ok, the velocity handling is finished. Not we come to handle
C         the pressure.
C         Do we have a boundary edge?

          IF (.NOT.BDBC(ILD)) THEN

C           Get BB1,BB2 and modify FF1,FF2.
C
C           In every line of each B-matrix, there is either one entry
C           (in case of boundary nodes) or there are at most two entries
C           (for inner nodes, which where each velocity component couples
C           with two elements:
C
C                IEL                              IEL
C             |--------|             |--------|--------|
C             |        |             |        |        |
C             |   P1   |      or     |   P2   X   P1   |
C             |        |             |        |        |
C           --|---X----|--           |--------|--------|
C
C           Our current edge is either an inner edge with two elements
C           attached, or a boundary edge with Neumann boundary
C           conditions.
C
C           In the case that two elements meet each other, we subtract
C           the B*(pressure of the neighbour cell) from the RHS.
C
C           In the case that we have only one element, there's
C           only one entry in the row of the B-matrix. We fetch the
C           first and last entry of the line, which will coincide
C           then (IB1=IB2). As there is no neighbour cell, we must
C           not subtract anything from the RHS! Nevertheless we have to
C           note the column numbers in the B-matrices to our BB1/BB2
C           vectors.
C
C           Get the first and last entry from row I of the B-matrices:

            IB1=KLDB(IGD)
            IB2=KLDB(IGD+1)-1
            JP1=KCOLB(IB1)
            JP2=KCOLB(IB2)

C           Check which of these two belong to the current element.
C           The corresponding other one is to be subtracted from the RHS
C           vector.

            IF (JP1.EQ.IEL)  THEN

              PJP = P(JP2)
              BB1(ILD) = B1(IB1)
              BB2(ILD) = B2(IB1)

C             Don't subtract anything from the RHS if there's
C             no neighbour element!

              IF (IB1.NE.IB2) THEN
                FF1(ILD) = FF1(ILD)-B1(IB2)*PJP
                FF2(ILD) = FF2(ILD)-B2(IB2)*PJP
              END IF

            ELSE IF (JP2.EQ.IEL)  THEN

              PJP = P(JP1)
              BB1(ILD) = B1(IB2)
              BB2(ILD) = B2(IB2)

C             Don't subtract anything from the RHS if there's
C             no neighbour element!

              IF (IB1.NE.IB2) THEN
                FF1(ILD) = FF1(ILD)-B1(IB1)*PJP
                FF2(ILD) = FF2(ILD)-B2(IB1)*PJP
              END IF

            ELSE
              WRITE(MTERM,'(A)')
     *          'ERROR in VANCP5: IEL entry in B not found'
              STOP
            ENDIF

          ELSE

C           Hmmm, the edge ILD is a Dirichlet boundary edge.
C           That means there is no adjacent element with a pressure
C           that we have to subtract from the RHS vector.
C           Simply write the one and only element in the current
C           line of the B-matrices to BB1/BB2.

            IB = KLDB(IGD)
            BB1(ILD) = B1(IB)
            BB2(ILD) = B2(IB)

          END IF ! not BDBC(ILD)

C         Go to the next DOF on our current element IEL...

        END DO ! ILD

C       Call the subroutine ELUPD3 for element update.
C
C       This routine will now "solve" the above system
C
C          [ S         B1 ] (ul)   (du)
C          [      S    B2 ] (vl) = (dv)
C          [ B1^t B2^t  0 ] (p )   (dp)
C
C       and write the new velocity/pressure values (ul,vl,p) to the
C       solution vector (U1,U2,P).
C       Note that although we called (du,dv,dp) "local defect", it's
C       not a real defect! (du,dv,dp) is the original RHS vector
C       where a lot of parts of the original system have been
C       subtracted in equivalent formulations! Therefore, the solution
C       of this local system really gives new values for velocity/
C       pressure and not "update" values like in a defect correction
C       approach!

        CALL  ELUPD3 (U1,U2,P,IEL,IU,BDBC,AA,BB1,BB2,FF1,FF2,FFP)

C       Go to the next element...

      END DO ! IEL

C=======================================================================
C
C     At this point we are finished calculating a the preconditioned
C     vector (du,dv,dp). The caller can use it e.g. in a defect
C     correction approach...

      END


!***********************************************************************************************************************************
!**                                          S U B R O U T I N E   G A S   T R A N S F E R                                        **
!***********************************************************************************************************************************

SUBROUTINE GAS_TRANSFER
  USE GLOBAL; USE GEOMC; USE KINETIC
  IMPLICIT NONE
  REAL, PARAMETER :: THETA_REAERATION = 1.024, M_TO_FT = 3.2808
  REAL :: AREA,ADEPTH,UAVG,HDEPTH,S,USTAR,A,BCOEF,DMO2
  INTEGER :: K

  IF (REAERC(JW) == '   RIVER') THEN

!** Average depth in ft

    AREA = 0.0
    DO K=KT,KBMIN(I)
      AREA = AREA+BHR1(K,I)
    END DO
    ADEPTH = AREA/BR(KTI(I),I)*M_TO_FT

!** Average velocity in feet/second

    UAVG = ABS(QC(I))/AREA*M_TO_FT

!** Reaeration factor

    IF (NEQN(JW) == 0) THEN
      IF (ADEPTH <= 2.0) THEN
        REAER(I) = 21.64*UAVG**0.67/ADEPTH**1.85
      ELSE IF (UAVG <= 1.8) THEN
        REAER(I) = 12.96*SQRT(UAVG)/ADEPTH**1.5
      ELSE
        HDEPTH = -11.875*UAVG+23.375
        IF (HDEPTH >= ADEPTH) THEN
          REAER(I) = 12.96*SQRT(UAVG)/ADEPTH**1.5
        ELSE
          REAER(I) = 11.57*UAVG**0.969/ADEPTH**1.673
        END IF
      END IF
    ELSE IF (NEQN(JW) == 1) THEN                                                                              !O'connor-Dobbins
      REAER(I) = 12.96*SQRT(UAVG)/ADEPTH**1.5                                                                 ! units: day-1
    ELSE IF (NEQN(JW) == 2) THEN                                                                              !Churchill
      REAER(I) = 11.57*UAVG**0.969/ADEPTH**1.673                                                              ! units: day-1
    ELSE IF (NEQN(JW) == 3) THEN                                                                              !Tsivoglou
      S = SLOPEC(JB)*5280.0
      IF (ABS(QC(I))*35.5 >= 10.0) THEN
        REAER(I) = 0.88*S*UAVG
      ELSE
        REAER(I) = 1.8*S*UAVG
      END IF
    ELSE IF (NEQN(JW) == 4) THEN                                                                              !Owens
      REAER(I) = 21.64*UAVG**0.67/ADEPTH**1.85
    ELSE IF (NEQN(JW) == 5) THEN                                                                              !Thackston and Krenkel
      USTAR    = SQRT(ADEPTH*SLOPEC(JB)*32.2)                                                                  ! SR 5/10/05
      REAER(I) = 24.88*(1.0+SQRT(0.176*UAVG/SQRT(ADEPTH)))*USTAR/ADEPTH                                       ! SR 5/10/05
    ELSE IF (NEQN(JW) == 6) THEN                                                                              !Langbien and Durum
      REAER(I) = 7.60*UAVG/ADEPTH**1.33
    ELSE IF (NEQN(JW) == 7) THEN                                                                              !Melching and Flores
      UAVG = UAVG/M_TO_FT
      IF (QC(I) == 0.0) THEN
        REAER(I) = 0.0
      ELSE IF (ABS(QC(I)) < 0.556) THEN
        REAER(I) = 517.0*((UAVG*SLOPEC(JB))**0.524)*ABS(QC(I))**(-0.242)
      ELSE
        REAER(I) = 596.0*((UAVG*SLOPEC(JB))**0.528)*ABS(QC(I))**(-0.136)
      END IF
    ELSE IF (NEQN(JW) == 8) THEN                                                                              !Melching and Flores
      UAVG   = UAVG/M_TO_FT
      ADEPTH = ADEPTH/M_TO_FT
      IF (ABS(QC(I)) < 0.556) THEN
        REAER(I) = 88.0*((UAVG*SLOPEC(JB))**0.313)*ADEPTH**(-0.353)
      ELSE
        REAER(I) = 142.0*((UAVG*SLOPEC(JB))**0.333)*ADEPTH**(-0.66)*BI(KT,I)**(-0.243)
      END IF
    ELSE IF (NEQN(JW) == 9) THEN                                                                              !User defined SI units
      UAVG     = UAVG/M_TO_FT
      ADEPTH   = ADEPTH/M_TO_FT
      REAER(I) = RCOEF1(JW)*(UAVG**RCOEF2(JW))*(ADEPTH**RCOEF3(JW))*(SLOPEC(JB)**RCOEF4(JW))
    ELSE IF (NEQN(JW) == 10) THEN                                                                             ! Thackston and Krenkel - updated
      USTAR    = SQRT(ADEPTH*SLOPEC(JB)*32.2)                                                                  ! SR 5/10/05
      REAER(I) = 4.99*(1.0+9.0*(0.176*UAVG/SQRT(ADEPTH))**0.25)*USTAR/ADEPTH                                  ! SR 5/10/05
    END IF
    !REAER(I) = REAER(I)*ADEPTH/M_TO_FT - now eliminated since changed computation in DO water quality section
    IF(MINKL(JW)>REAER(I))REAER(I)=MINKL(JW)    ! minimum value units day-1
  ELSE IF (REAERC(JW) == '    LAKE') THEN
    IF (NEQN(JW) == 1) THEN                                                                                !Broecker
      REAER(I) = 0.864*WIND10(I)
    ELSE IF (NEQN(JW) == 2) THEN
      IF (WIND10(I) <= 3.5) THEN                                                                              !Gelda
        A     = 0.2
        BCOEF = 1.0
      ELSE
        A     = 0.057
        BCOEF = 2.0
      END IF
      REAER(I) = A*WIND10(I)**BCOEF
    ELSE IF (NEQN(JW) == 3) THEN                                                                              !Banks & Herrera
      REAER(I) = (0.728*SQRT(WIND10(I))-0.317*WIND10(I)+0.0372*WIND10(I)**2)                                   !units of m/day
    ELSE IF (NEQN(JW) == 4) THEN                                                                              !Wanninkhof
      REAER(I) = 0.0986*WIND10(I)**1.64                                                                         !units of m/day
    ELSE IF (NEQN(JW) == 5) THEN                                                                              !Chen & Kanwisher
      DMO2     = 2.04E-9
      REAER(I) = DAY*DMO2/((200.0-60.0*SQRT(MIN(WIND10(I),11.0)))*1.E-6)
    ELSE IF (NEQN(JW) == 6) THEN                                                                              !Cole & Buchak
      REAER(I) = (0.5+0.05*WIND10(I)*WIND10(I))
    ELSE IF (NEQN(JW) == 7) THEN                                                                              !Banks
      IF (WIND10(I) <= 5.5) THEN
        REAER(I) = 0.362*SQRT(WIND10(I))
      ELSE
        REAER(I) = 0.0277*WIND10(I)**2
      END IF
    ELSE IF (NEQN(JW) == 8) THEN                                                                              !Smith
      REAER(I) = 0.64+0.128*WIND10(I)**2
    ELSE IF (NEQN(JW) == 9) THEN                                                                              !Liss
      IF (WIND10(I) <= 4.1) THEN
        REAER(I) = 0.156*WIND10(I)**0.63
      ELSE
        REAER(I) = 0.0269*WIND10(I)**1.9
      END IF
    ELSE IF (NEQN(JW) == 10) THEN                                                                             !Downing and Truesdale
      REAER(I) = 0.0276*WIND10(I)**2
    ELSE IF (NEQN(JW) == 11) THEN                                                                             !Kanwisher
      REAER(I) = 0.0432*WIND10(I)**2
    ELSE IF (NEQN(JW) == 12) THEN                                                                             !Yu, et al
      REAER(I) = 0.319*WIND10(I)
    ELSE IF (NEQN(JW) == 13) THEN                                                                             !Weiler
      IF (WIND10(I) <= 1.6) THEN
        REAER(I) = 0.398
      ELSE
        REAER(I) = 0.155*WIND10(I)**2
      END IF
    ELSE IF (NEQN(JW) == 14) THEN                                                                             !User defined
      REAER(I) = RCOEF1(JW)+RCOEF2(JW)*WIND10(I)**RCOEF3(JW)
    END IF
    IF(MINKL(JW)>REAER(I))REAER(I)=MINKL(JW)    ! minimum value units m day-1
    REAER(I) = REAER(I)*BI(KT,I)/BH2(KT,I)                                                         ! conversion from m/d to 1/d for all wind based equations
  ELSE IF (REAERC(JW) == ' ESTUARY') THEN
    AREA = 0.0
    DO K=KT,KBMIN(I)
      AREA = AREA+BHR1(K,I)
    END DO

    ADEPTH = AREA/BR(KTI(I),I)
    UAVG   = ABS(QC(I))/AREA

!** Reaeration factor

    IF (NEQN(JW) == 0) THEN
    ADEPTH = ADEPTH*M_TO_FT
    UAVG   = UAVG*M_TO_FT
      IF (ADEPTH <= 2.0) THEN
        REAER(I) = 21.64*UAVG**0.67/ADEPTH**1.85                                        ! units of day-1
      ELSE IF (UAVG <= 1.8) THEN
        REAER(I) = 12.96*SQRT(UAVG)/ADEPTH**1.5
      ELSE
        HDEPTH = -11.875*UAVG+23.375
        IF (HDEPTH >= ADEPTH) THEN
          REAER(I) = 12.96*SQRT(UAVG)/ADEPTH**1.5
        ELSE
          REAER(I) = 11.57*UAVG**0.969/ADEPTH**1.673
        END IF
      END IF
    ELSE IF (NEQN(JW) == 1) THEN                                                                           !Thomann and Fitzpatrick
      REAER(I) = (0.728*SQRT(WIND10(I))-0.317*WIND10(I)+0.0372*WIND10(I)**2)+3.93*SQRT(UAVG)/(ADEPTH)**0.5 ! units of m/day
      REAER(I) = REAER(I)/ADEPTH                                                                           ! units of 1/day
    ELSE IF (NEQN(JW) == 2) THEN                                                                           !User defined
      REAER(I) = RCOEF1(JW)*(UAVG**RCOEF2(JW))*(ADEPTH**RCOEF3(JW))+(0.5+RCOEF4(JW)*WIND10(I)*WIND10(I))   ! units of 1/day
    ENDIF
    IF(MINKL(JW)>REAER(I))REAER(I)=MINKL(JW)    ! minimum value units day-1

  END IF
  !IF(RCOEF1(JW)>REAER(I))REAER(I)=RCOEF1(JW)    ! minimum value units day-1
  REAER(I) = REAER(I)*THETA_REAERATION**(T1(KT,I)-20.0)      ! units of day-1
  REAER(I) = REAER(I)/DAY
END SUBROUTINE GAS_TRANSFER


      SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
     $                   WORK, LWORK, INFO )
*
*  -- LAPACK driver routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGELSY computes the minimum-norm solution to a real linear least
*  squares problem:
*      minimize || A * X - B ||
*  using a complete orthogonal factorization of A.  A is an M-by-N
*  matrix which may be rank-deficient.
*
*  Several right hand side vectors b and solution vectors x can be
*  handled in a single call; they are stored as the columns of the
*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
*  matrix X.
*
*  The routine first computes a QR factorization with column pivoting:
*      A * P = Q * [ R11 R12 ]
*                  [  0  R22 ]
*  with R11 defined as the largest leading submatrix whose estimated
*  condition number is less than 1/RCOND.  The order of R11, RANK,
*  is the effective rank of A.
*
*  Then, R22 is considered to be negligible, and R12 is annihilated
*  by orthogonal transformations from the right, arriving at the
*  complete orthogonal factorization:
*     A * P = Q * [ T11 0 ] * Z
*                 [  0  0 ]
*  The minimum-norm solution is then
*     X = P * Z' [ inv(T11)*Q1'*B ]
*                [        0       ]
*  where Q1 consists of the first RANK columns of Q.
*
*  This routine is basically identical to the original xGELSX except
*  three differences:
*    o The call to the subroutine xGEQPF has been substituted by the
*      the call to the subroutine xGEQP3. This subroutine is a Blas-3
*      version of the QR factorization with column pivoting.
*    o Matrix B (the right hand side) is updated with Blas-3.
*    o The permutation of matrix B (the right hand side) is faster and
*      more simple.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of
*          columns of matrices B and X. NRHS >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit, A has been overwritten by details of its
*          complete orthogonal factorization.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          On entry, the M-by-NRHS right hand side matrix B.
*          On exit, the N-by-NRHS solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B. LDB >= max(1,M,N).
*
*  JPVT    (input/output) INTEGER array, dimension (N)
*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
*          to the front of AP, otherwise column i is a free column.
*          On exit, if JPVT(i) = k, then the i-th column of AP
*          was the k-th column of A.
*
*  RCOND   (input) DOUBLE PRECISION
*          RCOND is used to determine the effective rank of A, which
*          is defined as the order of the largest leading triangular
*          submatrix R11 in the QR factorization with pivoting of A,
*          whose estimated condition number < 1/RCOND.
*
*  RANK    (output) INTEGER
*          The effective rank of A, i.e., the order of the submatrix
*          R11.  This is the same as the order of the submatrix T11
*          in the complete orthogonal factorization of A.
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.
*          The unblocked strategy requires that:
*             LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
*          where MN = min( M, N ).
*          The block algorithm requires that:
*             LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
*          where NB is an upper bound on the blocksize returned
*          by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,
*          and DORMRZ.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: If INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  Based on contributions by
*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKMIN,
     $                   LWKOPT, MN, NB, NB1, NB2, NB3, NB4
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
     $                   SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           ILAENV, DLAMCH, DLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEQP3, DLABAD, DLAIC1, DLASCL, DLASET,
     $                   DORMQR, DORMRZ, DTRSM, DTZRZF, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      MN = MIN( M, N )
      ISMIN = MN + 1
      ISMAX = 2*MN + 1
*
*     Test the input arguments.
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
         INFO = -7
      END IF
*
*     Figure out optimal block size
*
      IF( INFO.EQ.0 ) THEN
         IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
            LWKMIN = 1
            LWKOPT = 1
         ELSE
            NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
            NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
            NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, NRHS, -1 )
            NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, NRHS, -1 )
            NB = MAX( NB1, NB2, NB3, NB4 )
            LWKMIN = MN + MAX( 2*MN, N + 1, MN + NRHS )
            LWKOPT = MAX( LWKMIN,
     $                    MN + 2*N + NB*( N + 1 ), 2*MN + NB*NRHS )
         END IF
         WORK( 1 ) = LWKOPT
*
         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
            INFO = -12
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELSY', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
         RANK = 0
         RETURN
      END IF
*
*     Get machine parameters
*
      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
*
*     Scale A, B if max entries outside range [SMLNUM,BIGNUM]
*
      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
*        Scale matrix norm up to SMLNUM
*
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
*
*        Scale matrix norm down to BIGNUM
*
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
*
*        Matrix all zero. Return zero solution.
*
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         RANK = 0
         GO TO 70
      END IF
*
      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
      IBSCL = 0
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
*        Scale matrix norm up to SMLNUM
*
         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 1
      ELSE IF( BNRM.GT.BIGNUM ) THEN
*
*        Scale matrix norm down to BIGNUM
*
         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 2
      END IF
*
*     Compute QR factorization with column pivoting of A:
*        A * P = Q * R
*
      CALL DGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
     $             LWORK-MN, INFO )
      WSIZE = MN + WORK( MN+1 )
*
*     workspace: MN+2*N+NB*(N+1).
*     Details of Householder rotations stored in WORK(1:MN).
*
*     Determine RANK using incremental condition estimation
*
      WORK( ISMIN ) = ONE
      WORK( ISMAX ) = ONE
      SMAX = ABS( A( 1, 1 ) )
      SMIN = SMAX
      IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
         RANK = 0
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         GO TO 70
      ELSE
         RANK = 1
      END IF
*
   10 CONTINUE
      IF( RANK.LT.MN ) THEN
         I = RANK + 1
         CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
     $                A( I, I ), SMINPR, S1, C1 )
         CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
     $                A( I, I ), SMAXPR, S2, C2 )
*
         IF( SMAXPR*RCOND.LE.SMINPR ) THEN
            DO 20 I = 1, RANK
               WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
               WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
   20       CONTINUE
            WORK( ISMIN+RANK ) = C1
            WORK( ISMAX+RANK ) = C2
            SMIN = SMINPR
            SMAX = SMAXPR
            RANK = RANK + 1
            GO TO 10
         END IF
      END IF
*
*     workspace: 3*MN.
*
*     Logically partition R = [ R11 R12 ]
*                             [  0  R22 ]
*     where R11 = R(1:RANK,1:RANK)
*
*     [R11,R12] = [ T11, 0 ] * Y
*
      IF( RANK.LT.N )
     $   CALL DTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
     $                LWORK-2*MN, INFO )
*
*     workspace: 2*MN.
*     Details of Householder rotations stored in WORK(MN+1:2*MN)
*
*     B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
      CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
     $             B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
      WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) )
*
*     workspace: 2*MN+NB*NRHS.
*
*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
      CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
     $            NRHS, ONE, A, LDA, B, LDB )
*
      DO 40 J = 1, NRHS
         DO 30 I = RANK + 1, N
            B( I, J ) = ZERO
   30    CONTINUE
   40 CONTINUE
*
*     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
      IF( RANK.LT.N ) THEN
         CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
     $                LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ),
     $                LWORK-2*MN, INFO )
      END IF
*
*     workspace: 2*MN+NRHS.
*
*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
      DO 60 J = 1, NRHS
         DO 50 I = 1, N
            WORK( JPVT( I ) ) = B( I, J )
   50    CONTINUE
         CALL DCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
   60 CONTINUE
*
*     workspace: N.
*
*     Undo scaling
*
      IF( IASCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
     $                INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
     $                INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
      END IF
*
   70 CONTINUE
      WORK( 1 ) = LWKOPT
*
      RETURN
*
*     End of DGELSY
*
      END


c Compute travel time, etc., for direct (upward-departing) ray

	subroutine direct1(nl,v,vsq,thk,jl,tkj,delta,depth,tdir,u,x)

	implicit none

c	Parameters:
	integer	nl	! Number of layers		(input)
	real	v(nl)	! Layer wave speeds		(input)
	real	vsq(nl)	! Squares of wave speeds	(input)
	real	thk(nl)	! Layer thicknesses		(input)
	integer	jl	! Event layer			(input)
	real	tkj	! Event depth within layer jl	(input)
	real	delta	! Epicentral distance		(input)
	real	depth	! Event depth			(input)
	real	tdir	! Direct-ray travel time	(output)
	real	u	! Sine of take-off angle	(output)
	real	x	! Horizontal travel distance in event layer (output)

c       For the direct seismic ray from an event to a receiver in
c  a layered velocity structure, direct predicts the travel time, the
c  sine of the takeoff angle, and the horizontal distance of travel in
c  the event layer.  The receiver must be located at the top of layer
c  1 and the event must be located below layer 1.  Low velocity
c  layers are permitted.
c       To find the takeoff angle of the ray, a numerical approach
c  is required.  The basic scheme adopted here is the method of false
c  position.  (see acton, 1970, 'numerical methods that work,' for
c  example.)  First, the characteristics of the fastest layer
c  between the event and the surface are determined.  These permit
c  placing definite lower and upper bounds, ua and ub, on the
c  sine of the takeoff angle.  In turn, lower and upper bounds, xa
c  and xb, on the horizontal travel distance in the event layer are
c  determined.  The total horizontal travel distance for a ray with
c  with horizontal travel distance x in the event layer is denoted
c  by del, and the zero of del - delta is obtained by using xa and
c  xb as initial guesses for x in the method of false position
c  from x and tkj, the depth of the event below the top of the event
c  layer, the sine of the takeoff angle, u , is calculated.
c       From u and x, tdir is found by summing the travel time in
c  each layer.  finally, a slight correction to tdir is made, based
c  on the misfit between the final del and delta.

c	Local variables:
	real		del		! Computed distance
	real		dela, delb	! Distances corresponding to xa, xb
	doubleprecision	hypot		! Hypoteneuse function
	integer		j1
	integer		kount
	integer		l
	integer		lmax
	real		r
	real		tklmax
	real		usq
	real		ua, uasq
	real		ub, ubsq
	real		ubdiv
	real		vlmax
	real		xa, xb		! Bounds on x
	real		xtest

	if (jl .eq. 1) then
c	   Focus in surface layer
	   r = hypot(depth, delta)
	   tdir = r/v(1)
	   u = delta/r
	   x = delta
	   return
	endif

c     Find the fastest layer, lmax, above and including jl
      lmax = jl
      tklmax = tkj
      vlmax = v(jl)
      j1 = jl-1
      do 23184 l=1,j1
         if (.not.(v(l).gt.vlmax)) goto 23186
            lmax = l
            tklmax = thk(l)
            vlmax = v(l)
23186    continue
23184 continue

C CHANGE BY E.KISSLING MARCH 1984
      IF(tklmax.le.0.05) tklmax = 0.05

c     Find initial bounds on the sine of the takeoff angle
      ua = (v(jl)/vlmax)*delta/sqrt(delta**2+depth**2)
      ub = (v(jl)/vlmax)*delta/sqrt(delta**2+tklmax**2)

c     Calculate horizontal travel distances
      uasq = ua**2
      ubsq = ub**2
C CHANGE BY E.KISSLING MARCH 1984
      if (ubsq.ge.1.) ubsq = 0.99999
      if (uasq.ge.1.) uasq = 0.99999
      xa = tkj*ua/sqrt(1.0-uasq)
      if (.not.(lmax.eq.jl)) goto 23188
         xb = delta
         goto 23189
23188 continue
      xb = tkj*ub/sqrt(1.0-ubsq)
23189 continue
      dela = xa
      delb = xb
      do 23190 l=1,j1
         dela = dela+thk(l)*ua/sqrt(vsq(jl)/vsq(l)-uasq)
         ubdiv = sqrt(vsq(jl)/vsq(l)-ubsq)
         if (ubdiv.GT.1.e-20) GOTO 1002
c	    No write statements for Splus!
            ubdiv = 1.e-20
 1002    continue
         delb = delb+thk(l)*ub/sqrt(vsq(jl)/vsq(l)-ubsq)
23190 continue

c     Loop to find the zero of del-delta by the method of false position
      do 23192 kount=1,25
         if (.not.((delb-dela).lt.0.02)) goto 23194
            x = 0.5*(xa+xb)
            u = x/sqrt(x**2+tkj**2)
            usq = u**2
            goto 23193	! break
23194    continue
         x = xa+(delta-dela)*(xb-xa)/(delb-dela)
         u = x/sqrt(x**2+tkj**2)
         usq = u**2
         del = x
         do 23196 l=1,j1
            del = del+thk(l)*u/sqrt(vsq(jl)/vsq(l)-usq)
23196    continue
         xtest = del-delta
         if (abs(xtest).lt.0.02) goto 23193	! break
         if (.not.(xtest.lt.0.0)) goto 23200
            xa = x
            dela = del
            goto 23201
23200    continue
            xb = x
            delb = del
23201    continue
23192 continue
23193 continue

c     Calculate direct-ray travel time
      tdir = sqrt(x**2+tkj**2)/v(jl)
      do 23202 l=1,j1
         tdir = tdir+thk(l)*v(jl)/(vsq(l)*sqrt(vsq(jl)/vsq(l)-usq))
23202 continue
      tdir = tdir-(u/v(jl))*(del-delta)
      return
c  ***** end of subroutine direct1 *****
      end


      SUBROUTINE PHYSKS(XR,PR,Q,P)
*
*
*       Transformation from physical to KS variables.
*       ---------------------------------------------
*
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 XR(3),PR(3),Q(4),P(4)
*
*
*       Set the physical distance.
      R2=XR(1)**2+XR(2)**2+XR(3)**2
      R=SQRT(R2)
*
*       Obtain regularized coordinates.
      Q(4)=0.0D0
      A=R+ABS(XR(1))
      Q(1)=SQRT(0.5D0*A)
      B=1.0/(2.0D0*Q(1))
      Q(2)=XR(2)*B
      Q(3)=XR(3)*B
      IF(XR(1).LT.0.0D0)THEN
      U1=Q(1)
      Q(1)=Q(2)
      Q(2)=U1
      U3=Q(3)
      Q(3)=Q(4)
      Q(4)=U3
      END IF
*
*       Form regularized momenta.
      P(1)=2.D0*(+Q(1)*PR(1)+Q(2)*PR(2)+Q(3)*PR(3))
      P(2)=2.D0*(-Q(2)*PR(1)+Q(1)*PR(2)+Q(4)*PR(3))
      P(3)=2.D0*(-Q(3)*PR(1)-Q(4)*PR(2)+Q(1)*PR(3))
      P(4)=2.D0*(+Q(4)*PR(1)-Q(3)*PR(2)+Q(2)*PR(3))
*
      RETURN
      END