      SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            I, INFO, N
      DOUBLE PRECISION   DLAM, RHO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DELTA( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  This subroutine computes the I-th updated eigenvalue of a symmetric
*  rank-one modification to a diagonal matrix whose elements are
*  given in the array d, and that
*
*             D(i) < D(j)  for  i < j
*
*  and that RHO > 0.  This is arranged by the calling routine, and is
*  no loss in generality.  The rank-one modified system is thus
*
*             diag( D )  +  RHO *  Z * Z_transpose.
*
*  where we assume the Euclidean norm of Z is 1.
*
*  The method consists of approximating the rational functions in the
*  secular equation by simpler interpolating rational functions.
*
*  Arguments
*  =========
*
*  N      (input) INTEGER
*         The length of all arrays.
*
*  I      (input) INTEGER
*         The index of the eigenvalue to be computed.  1 <= I <= N.
*
*  D      (input) DOUBLE PRECISION array, dimension (N)
*         The original eigenvalues.  It is assumed that they are in
*         order, D(I) < D(J)  for I < J.
*
*  Z      (input) DOUBLE PRECISION array, dimension (N)
*         The components of the updating vector.
*
*  DELTA  (output) DOUBLE PRECISION array, dimension (N)
*         If N .GT. 2, DELTA contains (D(j) - lambda_I) in its  j-th
*         component.  If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5
*         for detail. The vector DELTA contains the information necessary
*         to construct the eigenvectors by DLAED3 and DLAED9.
*
*  RHO    (input) DOUBLE PRECISION
*         The scalar in the symmetric updating formula.
*
*  DLAM   (output) DOUBLE PRECISION
*         The computed lambda_I, the I-th updated eigenvalue.
*
*  INFO   (output) INTEGER
*         = 0:  successful exit
*         > 0:  if INFO = 1, the updating process failed.
*
*  Internal Parameters
*  ===================
*
*  Logical variable ORGATI (origin-at-i?) is used for distinguishing
*  whether D(i) or D(i+1) is treated as the origin.
*
*            ORGATI = .true.    origin at i
*            ORGATI = .false.   origin at i+1
*
*   Logical variable SWTCH3 (switch-for-3-poles?) is for noting
*   if we are working with THREE poles!
*
*   MAXIT is the maximum number of iterations allowed for each
*   eigenvalue.
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Ren-Cang Li, Computer Science Division, University of California
*     at Berkeley, USA
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                   THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,
     $                   TEN = 10.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ORGATI, SWTCH, SWTCH3
      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER
      DOUBLE PRECISION   A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
     $                   EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
     $                   RHOINV, TAU, TEMP, TEMP1, W
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   ZZ( 3 )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAED5, DLAED6
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Since this routine is called in an inner loop, we do no argument
*     checking.
*
*     Quick return for N=1 and 2.
*
      INFO = 0
      IF( N.EQ.1 ) THEN
*
*         Presumably, I=1 upon entry
*
         DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
         DELTA( 1 ) = ONE
         RETURN
      END IF
      IF( N.EQ.2 ) THEN
         CALL DLAED5( I, D, Z, DELTA, RHO, DLAM )
         RETURN
      END IF
*
*     Compute machine epsilon
*
      EPS = DLAMCH( 'Epsilon' )
      RHOINV = ONE / RHO
*
*     The case I = N
*
      IF( I.EQ.N ) THEN
*
*        Initialize some basic variables
*
         II = N - 1
         NITER = 1
*
*        Calculate initial guess
*
         MIDPT = RHO / TWO
*
*        If ||Z||_2 is not one, then TEMP should be set to
*        RHO * ||Z||_2^2 / TWO
*
         DO 10 J = 1, N
            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
   10    CONTINUE
*
         PSI = ZERO
         DO 20 J = 1, N - 2
            PSI = PSI + Z( J )*Z( J ) / DELTA( J )
   20    CONTINUE
*
         C = RHOINV + PSI
         W = C + Z( II )*Z( II ) / DELTA( II ) +
     $       Z( N )*Z( N ) / DELTA( N )
*
         IF( W.LE.ZERO ) THEN
            TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
     $             Z( N )*Z( N ) / RHO
            IF( C.LE.TEMP ) THEN
               TAU = RHO
            ELSE
               DEL = D( N ) - D( N-1 )
               A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
               B = Z( N )*Z( N )*DEL
               IF( A.LT.ZERO ) THEN
                  TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
               ELSE
                  TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
               END IF
            END IF
*
*           It can be proved that
*               D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
*
            DLTLB = MIDPT
            DLTUB = RHO
         ELSE
            DEL = D( N ) - D( N-1 )
            A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
            B = Z( N )*Z( N )*DEL
            IF( A.LT.ZERO ) THEN
               TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
            ELSE
               TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
            END IF
*
*           It can be proved that
*               D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
*
            DLTLB = ZERO
            DLTUB = MIDPT
         END IF
*
         DO 30 J = 1, N
            DELTA( J ) = ( D( J )-D( I ) ) - TAU
   30    CONTINUE
*
*        Evaluate PSI and the derivative DPSI
*
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 40 J = 1, II
            TEMP = Z( J ) / DELTA( J )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
   40    CONTINUE
         ERRETM = ABS( ERRETM )
*
*        Evaluate PHI and the derivative DPHI
*
         TEMP = Z( N ) / DELTA( N )
         PHI = Z( N )*TEMP
         DPHI = TEMP*TEMP
         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
     $            ABS( TAU )*( DPSI+DPHI )
*
         W = RHOINV + PHI + PSI
*
*        Test for convergence
*
         IF( ABS( W ).LE.EPS*ERRETM ) THEN
            DLAM = D( I ) + TAU
            GO TO 250
         END IF
*
         IF( W.LE.ZERO ) THEN
            DLTLB = MAX( DLTLB, TAU )
         ELSE
            DLTUB = MIN( DLTUB, TAU )
         END IF
*
*        Calculate the new step
*
         NITER = NITER + 1
         C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
         A = ( DELTA( N-1 )+DELTA( N ) )*W -
     $       DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
         B = DELTA( N-1 )*DELTA( N )*W
         IF( C.LT.ZERO )
     $      C = ABS( C )
         IF( C.EQ.ZERO ) THEN
*          ETA = B/A
*           ETA = RHO - TAU
            ETA = DLTUB - TAU
         ELSE IF( A.GE.ZERO ) THEN
            ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
         ELSE
            ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
         END IF
*
*        Note, eta should be positive if w is negative, and
*        eta should be negative otherwise. However,
*        if for some reason caused by roundoff, eta*w > 0,
*        we simply use one Newton step instead. This way
*        will guarantee eta*w < 0.
*
         IF( W*ETA.GT.ZERO )
     $      ETA = -W / ( DPSI+DPHI )
         TEMP = TAU + ETA
         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
            IF( W.LT.ZERO ) THEN
               ETA = ( DLTUB-TAU ) / TWO
            ELSE
               ETA = ( DLTLB-TAU ) / TWO
            END IF
         END IF
         DO 50 J = 1, N
            DELTA( J ) = DELTA( J ) - ETA
   50    CONTINUE
*
         TAU = TAU + ETA
*
*        Evaluate PSI and the derivative DPSI
*
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 60 J = 1, II
            TEMP = Z( J ) / DELTA( J )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
   60    CONTINUE
         ERRETM = ABS( ERRETM )
*
*        Evaluate PHI and the derivative DPHI
*
         TEMP = Z( N ) / DELTA( N )
         PHI = Z( N )*TEMP
         DPHI = TEMP*TEMP
         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
     $            ABS( TAU )*( DPSI+DPHI )
*
         W = RHOINV + PHI + PSI
*
*        Main loop to update the values of the array   DELTA
*
         ITER = NITER + 1
*
         DO 90 NITER = ITER, MAXIT
*
*           Test for convergence
*
            IF( ABS( W ).LE.EPS*ERRETM ) THEN
               DLAM = D( I ) + TAU
               GO TO 250
            END IF
*
            IF( W.LE.ZERO ) THEN
               DLTLB = MAX( DLTLB, TAU )
            ELSE
               DLTUB = MIN( DLTUB, TAU )
            END IF
*
*           Calculate the new step
*
            C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
            A = ( DELTA( N-1 )+DELTA( N ) )*W -
     $          DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
            B = DELTA( N-1 )*DELTA( N )*W
            IF( A.GE.ZERO ) THEN
               ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
            ELSE
               ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
            END IF
*
*           Note, eta should be positive if w is negative, and
*           eta should be negative otherwise. However,
*           if for some reason caused by roundoff, eta*w > 0,
*           we simply use one Newton step instead. This way
*           will guarantee eta*w < 0.
*
            IF( W*ETA.GT.ZERO )
     $         ETA = -W / ( DPSI+DPHI )
            TEMP = TAU + ETA
            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
               IF( W.LT.ZERO ) THEN
                  ETA = ( DLTUB-TAU ) / TWO
               ELSE
                  ETA = ( DLTLB-TAU ) / TWO
               END IF
            END IF
            DO 70 J = 1, N
               DELTA( J ) = DELTA( J ) - ETA
   70       CONTINUE
*
            TAU = TAU + ETA
*
*           Evaluate PSI and the derivative DPSI
*
            DPSI = ZERO
            PSI = ZERO
            ERRETM = ZERO
            DO 80 J = 1, II
               TEMP = Z( J ) / DELTA( J )
               PSI = PSI + Z( J )*TEMP
               DPSI = DPSI + TEMP*TEMP
               ERRETM = ERRETM + PSI
   80       CONTINUE
            ERRETM = ABS( ERRETM )
*
*           Evaluate PHI and the derivative DPHI
*
            TEMP = Z( N ) / DELTA( N )
            PHI = Z( N )*TEMP
            DPHI = TEMP*TEMP
            ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
     $               ABS( TAU )*( DPSI+DPHI )
*
            W = RHOINV + PHI + PSI
   90    CONTINUE
*
*        Return with INFO = 1, NITER = MAXIT and not converged
*
         INFO = 1
         DLAM = D( I ) + TAU
         GO TO 250
*
*        End for the case I = N
*
      ELSE
*
*        The case for I < N
*
         NITER = 1
         IP1 = I + 1
*
*        Calculate initial guess
*
         DEL = D( IP1 ) - D( I )
         MIDPT = DEL / TWO
         DO 100 J = 1, N
            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
  100    CONTINUE
*
         PSI = ZERO
         DO 110 J = 1, I - 1
            PSI = PSI + Z( J )*Z( J ) / DELTA( J )
  110    CONTINUE
*
         PHI = ZERO
         DO 120 J = N, I + 2, -1
            PHI = PHI + Z( J )*Z( J ) / DELTA( J )
  120    CONTINUE
         C = RHOINV + PSI + PHI
         W = C + Z( I )*Z( I ) / DELTA( I ) +
     $       Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
*
         IF( W.GT.ZERO ) THEN
*
*           d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
*
*           We choose d(i) as origin.
*
            ORGATI = .TRUE.
            A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
            B = Z( I )*Z( I )*DEL
            IF( A.GT.ZERO ) THEN
               TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
            ELSE
               TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
            END IF
            DLTLB = ZERO
            DLTUB = MIDPT
         ELSE
*
*           (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
*
*           We choose d(i+1) as origin.
*
            ORGATI = .FALSE.
            A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
            B = Z( IP1 )*Z( IP1 )*DEL
            IF( A.LT.ZERO ) THEN
               TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
            ELSE
               TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
            END IF
            DLTLB = -MIDPT
            DLTUB = ZERO
         END IF
*
         IF( ORGATI ) THEN
            DO 130 J = 1, N
               DELTA( J ) = ( D( J )-D( I ) ) - TAU
  130       CONTINUE
         ELSE
            DO 140 J = 1, N
               DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
  140       CONTINUE
         END IF
         IF( ORGATI ) THEN
            II = I
         ELSE
            II = I + 1
         END IF
         IIM1 = II - 1
         IIP1 = II + 1
*
*        Evaluate PSI and the derivative DPSI
*
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 150 J = 1, IIM1
            TEMP = Z( J ) / DELTA( J )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
  150    CONTINUE
         ERRETM = ABS( ERRETM )
*
*        Evaluate PHI and the derivative DPHI
*
         DPHI = ZERO
         PHI = ZERO
         DO 160 J = N, IIP1, -1
            TEMP = Z( J ) / DELTA( J )
            PHI = PHI + Z( J )*TEMP
            DPHI = DPHI + TEMP*TEMP
            ERRETM = ERRETM + PHI
  160    CONTINUE
*
         W = RHOINV + PHI + PSI
*
*        W is the value of the secular function with
*        its ii-th element removed.
*
         SWTCH3 = .FALSE.
         IF( ORGATI ) THEN
            IF( W.LT.ZERO )
     $         SWTCH3 = .TRUE.
         ELSE
            IF( W.GT.ZERO )
     $         SWTCH3 = .TRUE.
         END IF
         IF( II.EQ.1 .OR. II.EQ.N )
     $      SWTCH3 = .FALSE.
*
         TEMP = Z( II ) / DELTA( II )
         DW = DPSI + DPHI + TEMP*TEMP
         TEMP = Z( II )*TEMP
         W = W + TEMP
         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
     $            THREE*ABS( TEMP ) + ABS( TAU )*DW
*
*        Test for convergence
*
         IF( ABS( W ).LE.EPS*ERRETM ) THEN
            IF( ORGATI ) THEN
               DLAM = D( I ) + TAU
            ELSE
               DLAM = D( IP1 ) + TAU
            END IF
            GO TO 250
         END IF
*
         IF( W.LE.ZERO ) THEN
            DLTLB = MAX( DLTLB, TAU )
         ELSE
            DLTUB = MIN( DLTUB, TAU )
         END IF
*
*        Calculate the new step
*
         NITER = NITER + 1
         IF( .NOT.SWTCH3 ) THEN
            IF( ORGATI ) THEN
               C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
     $             ( Z( I ) / DELTA( I ) )**2
            ELSE
               C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
     $             ( Z( IP1 ) / DELTA( IP1 ) )**2
            END IF
            A = ( DELTA( I )+DELTA( IP1 ) )*W -
     $          DELTA( I )*DELTA( IP1 )*DW
            B = DELTA( I )*DELTA( IP1 )*W
            IF( C.EQ.ZERO ) THEN
               IF( A.EQ.ZERO ) THEN
                  IF( ORGATI ) THEN
                     A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
     $                   ( DPSI+DPHI )
                  ELSE
                     A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
     $                   ( DPSI+DPHI )
                  END IF
               END IF
               ETA = B / A
            ELSE IF( A.LE.ZERO ) THEN
               ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
            ELSE
               ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
            END IF
         ELSE
*
*           Interpolation using THREE most relevant poles
*
            TEMP = RHOINV + PSI + PHI
            IF( ORGATI ) THEN
               TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
               TEMP1 = TEMP1*TEMP1
               C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
     $             ( D( IIM1 )-D( IIP1 ) )*TEMP1
               ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
               ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
     $                   ( ( DPSI-TEMP1 )+DPHI )
            ELSE
               TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
               TEMP1 = TEMP1*TEMP1
               C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
     $             ( D( IIP1 )-D( IIM1 ) )*TEMP1
               ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
     $                   ( DPSI+( DPHI-TEMP1 ) )
               ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
            END IF
            ZZ( 2 ) = Z( II )*Z( II )
            CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
     $                   INFO )
            IF( INFO.NE.0 )
     $         GO TO 250
         END IF
*
*        Note, eta should be positive if w is negative, and
*        eta should be negative otherwise. However,
*        if for some reason caused by roundoff, eta*w > 0,
*        we simply use one Newton step instead. This way
*        will guarantee eta*w < 0.
*
         IF( W*ETA.GE.ZERO )
     $      ETA = -W / DW
         TEMP = TAU + ETA
         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
            IF( W.LT.ZERO ) THEN
               ETA = ( DLTUB-TAU ) / TWO
            ELSE
               ETA = ( DLTLB-TAU ) / TWO
            END IF
         END IF
*
         PREW = W
*
         DO 180 J = 1, N
            DELTA( J ) = DELTA( J ) - ETA
  180    CONTINUE
*
*        Evaluate PSI and the derivative DPSI
*
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 190 J = 1, IIM1
            TEMP = Z( J ) / DELTA( J )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
  190    CONTINUE
         ERRETM = ABS( ERRETM )
*
*        Evaluate PHI and the derivative DPHI
*
         DPHI = ZERO
         PHI = ZERO
         DO 200 J = N, IIP1, -1
            TEMP = Z( J ) / DELTA( J )
            PHI = PHI + Z( J )*TEMP
            DPHI = DPHI + TEMP*TEMP
            ERRETM = ERRETM + PHI
  200    CONTINUE
*
         TEMP = Z( II ) / DELTA( II )
         DW = DPSI + DPHI + TEMP*TEMP
         TEMP = Z( II )*TEMP
         W = RHOINV + PHI + PSI + TEMP
         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
     $            THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
*
         SWTCH = .FALSE.
         IF( ORGATI ) THEN
            IF( -W.GT.ABS( PREW ) / TEN )
     $         SWTCH = .TRUE.
         ELSE
            IF( W.GT.ABS( PREW ) / TEN )
     $         SWTCH = .TRUE.
         END IF
*
         TAU = TAU + ETA
*
*        Main loop to update the values of the array   DELTA
*
         ITER = NITER + 1
*
         DO 240 NITER = ITER, MAXIT
*
*           Test for convergence
*
            IF( ABS( W ).LE.EPS*ERRETM ) THEN
               IF( ORGATI ) THEN
                  DLAM = D( I ) + TAU
               ELSE
                  DLAM = D( IP1 ) + TAU
               END IF
               GO TO 250
            END IF
*
            IF( W.LE.ZERO ) THEN
               DLTLB = MAX( DLTLB, TAU )
            ELSE
               DLTUB = MIN( DLTUB, TAU )
            END IF
*
*           Calculate the new step
*
            IF( .NOT.SWTCH3 ) THEN
               IF( .NOT.SWTCH ) THEN
                  IF( ORGATI ) THEN
                     C = W - DELTA( IP1 )*DW -
     $                   ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
                  ELSE
                     C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
     $                   ( Z( IP1 ) / DELTA( IP1 ) )**2
                  END IF
               ELSE
                  TEMP = Z( II ) / DELTA( II )
                  IF( ORGATI ) THEN
                     DPSI = DPSI + TEMP*TEMP
                  ELSE
                     DPHI = DPHI + TEMP*TEMP
                  END IF
                  C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
               END IF
               A = ( DELTA( I )+DELTA( IP1 ) )*W -
     $             DELTA( I )*DELTA( IP1 )*DW
               B = DELTA( I )*DELTA( IP1 )*W
               IF( C.EQ.ZERO ) THEN
                  IF( A.EQ.ZERO ) THEN
                     IF( .NOT.SWTCH ) THEN
                        IF( ORGATI ) THEN
                           A = Z( I )*Z( I ) + DELTA( IP1 )*
     $                         DELTA( IP1 )*( DPSI+DPHI )
                        ELSE
                           A = Z( IP1 )*Z( IP1 ) +
     $                         DELTA( I )*DELTA( I )*( DPSI+DPHI )
                        END IF
                     ELSE
                        A = DELTA( I )*DELTA( I )*DPSI +
     $                      DELTA( IP1 )*DELTA( IP1 )*DPHI
                     END IF
                  END IF
                  ETA = B / A
               ELSE IF( A.LE.ZERO ) THEN
                  ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
               ELSE
                  ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
               END IF
            ELSE
*
*              Interpolation using THREE most relevant poles
*
               TEMP = RHOINV + PSI + PHI
               IF( SWTCH ) THEN
                  C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
                  ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
                  ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
               ELSE
                  IF( ORGATI ) THEN
                     TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
                     TEMP1 = TEMP1*TEMP1
                     C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
     $                   ( D( IIM1 )-D( IIP1 ) )*TEMP1
                     ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
                     ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
     $                         ( ( DPSI-TEMP1 )+DPHI )
                  ELSE
                     TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
                     TEMP1 = TEMP1*TEMP1
                     C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
     $                   ( D( IIP1 )-D( IIM1 ) )*TEMP1
                     ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
     $                         ( DPSI+( DPHI-TEMP1 ) )
                     ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
                  END IF
               END IF
               CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
     $                      INFO )
               IF( INFO.NE.0 )
     $            GO TO 250
            END IF
*
*           Note, eta should be positive if w is negative, and
*           eta should be negative otherwise. However,
*           if for some reason caused by roundoff, eta*w > 0,
*           we simply use one Newton step instead. This way
*           will guarantee eta*w < 0.
*
            IF( W*ETA.GE.ZERO )
     $         ETA = -W / DW
            TEMP = TAU + ETA
            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
               IF( W.LT.ZERO ) THEN
                  ETA = ( DLTUB-TAU ) / TWO
               ELSE
                  ETA = ( DLTLB-TAU ) / TWO
               END IF
            END IF
*
            DO 210 J = 1, N
               DELTA( J ) = DELTA( J ) - ETA
  210       CONTINUE
*
            TAU = TAU + ETA
            PREW = W
*
*           Evaluate PSI and the derivative DPSI
*
            DPSI = ZERO
            PSI = ZERO
            ERRETM = ZERO
            DO 220 J = 1, IIM1
               TEMP = Z( J ) / DELTA( J )
               PSI = PSI + Z( J )*TEMP
               DPSI = DPSI + TEMP*TEMP
               ERRETM = ERRETM + PSI
  220       CONTINUE
            ERRETM = ABS( ERRETM )
*
*           Evaluate PHI and the derivative DPHI
*
            DPHI = ZERO
            PHI = ZERO
            DO 230 J = N, IIP1, -1
               TEMP = Z( J ) / DELTA( J )
               PHI = PHI + Z( J )*TEMP
               DPHI = DPHI + TEMP*TEMP
               ERRETM = ERRETM + PHI
  230       CONTINUE
*
            TEMP = Z( II ) / DELTA( II )
            DW = DPSI + DPHI + TEMP*TEMP
            TEMP = Z( II )*TEMP
            W = RHOINV + PHI + PSI + TEMP
            ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
     $               THREE*ABS( TEMP ) + ABS( TAU )*DW
            IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
     $         SWTCH = .NOT.SWTCH
*
  240    CONTINUE
*
*        Return with INFO = 1, NITER = MAXIT and not converged
*
         INFO = 1
         IF( ORGATI ) THEN
            DLAM = D( I ) + TAU
         ELSE
            DLAM = D( IP1 ) + TAU
         END IF
*
      END IF
*
  250 CONTINUE
*
      RETURN
*
*     End of DLAED4
*
      END


      SUBROUTINE stifbs(y,dydx,nv,x,htry,eps,yscal,hdid,hnext,derivs)
      INTEGER nv,NMAX,KMAXX,IMAX
      REAL eps,hdid,hnext,htry,x,dydx(nv),y(nv),yscal(nv),SAFE1,SAFE2,
     *REDMAX,REDMIN,TINY,SCALMX
      EXTERNAL derivs
      PARAMETER (NMAX=50,KMAXX=7,IMAX=KMAXX+1,SAFE1=.25,SAFE2=.7,
     *REDMAX=1.e-5,REDMIN=.7,TINY=1.e-30,SCALMX=.1)
CU    USES derivs,jacobn,simpr,pzextr
      INTEGER i,iq,k,kk,km,kmax,kopt,nvold,nseq(IMAX)
      REAL eps1,epsold,errmax,fact,h,red,scale,work,wrkmin,xest,xnew,
     *a(IMAX),alf(KMAXX,KMAXX),dfdx(NMAX),dfdy(NMAX,NMAX),err(KMAXX),
     *yerr(NMAX),ysav(NMAX),yseq(NMAX)
      LOGICAL first,reduct
      SAVE a,alf,epsold,first,kmax,kopt,nseq,nvold,xnew
      DATA first/.true./,epsold/-1./,nvold/-1/
      DATA nseq /2,6,10,14,22,34,50,70/
      if(eps.ne.epsold.or.nv.ne.nvold)then
        hnext=-1.e29
        xnew=-1.e29
        eps1=SAFE1*eps
        a(1)=nseq(1)+1
        do 11 k=1,KMAXX
          a(k+1)=a(k)+nseq(k+1)
11      continue
        do 13 iq=2,KMAXX
          do 12 k=1,iq-1
            alf(k,iq)=eps1**((a(k+1)-a(iq+1))/((a(iq+1)-a(1)+1.)*(2*k+
     *1)))
12        continue
13      continue
        epsold=eps
        nvold=nv
        a(1)=nv+a(1)
        do 14 k=1,KMAXX
          a(k+1)=a(k)+nseq(k+1)
14      continue
        do 15 kopt=2,KMAXX-1
          if(a(kopt+1).gt.a(kopt)*alf(kopt-1,kopt))goto 1
15      continue
1       kmax=kopt
      endif
      h=htry
      do 16 i=1,nv
        ysav(i)=y(i)
16    continue
      call jacobn(x,y,dfdx,dfdy,nv,nmax)
      if(h.ne.hnext.or.x.ne.xnew)then
        first=.true.
        kopt=kmax
      endif
      reduct=.false.
2     do 18 k=1,kmax
        xnew=x+h
        if(xnew.eq.x)pause 'stepsize underflow in stifbs'
        call simpr(ysav,dydx,dfdx,dfdy,nmax,nv,x,h,nseq(k),yseq,derivs)
        xest=(h/nseq(k))**2
        call pzextr(k,xest,yseq,y,yerr,nv)
        if(k.ne.1)then
          errmax=TINY
          do 17 i=1,nv
            errmax=max(errmax,abs(yerr(i)/yscal(i)))
17        continue
          errmax=errmax/eps
          km=k-1
          err(km)=(errmax/SAFE1)**(1./(2*km+1))
        endif
        if(k.ne.1.and.(k.ge.kopt-1.or.first))then
          if(errmax.lt.1.)goto 4
          if(k.eq.kmax.or.k.eq.kopt+1)then
            red=SAFE2/err(km)
            goto 3
          else if(k.eq.kopt)then
            if(alf(kopt-1,kopt).lt.err(km))then
              red=1./err(km)
              goto 3
            endif
          else if(kopt.eq.kmax)then
            if(alf(km,kmax-1).lt.err(km))then
              red=alf(km,kmax-1)*SAFE2/err(km)
              goto 3
            endif
          else if(alf(km,kopt).lt.err(km))then
            red=alf(km,kopt-1)/err(km)
            goto 3
          endif
        endif
18    continue
3     red=min(red,REDMIN)
      red=max(red,REDMAX)
      h=h*red
      reduct=.true.
      goto 2
4     x=xnew
      hdid=h
      first=.false.
      wrkmin=1.e35
      do 19 kk=1,km
        fact=max(err(kk),SCALMX)
        work=fact*a(kk+1)
        if(work.lt.wrkmin)then
          scale=fact
          wrkmin=work
          kopt=kk+1
        endif
19    continue
      hnext=h/scale
      if(kopt.ge.k.and.kopt.ne.kmax.and..not.reduct)then
        fact=max(scale/alf(kopt-1,kopt),SCALMX)
        if(a(kopt+1)*fact.le.wrkmin)then
          hnext=h/fact
          kopt=kopt+1
        endif
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/stifbs.for


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

      subroutine make_set

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

c---------------------------------------------------------------------
c     This function allocates space for a set of cells and fills the set
c     such that communication between cells on different nodes is only
c     nearest neighbor
c---------------------------------------------------------------------

      include 'header.h'
      include 'mpinpb.h'

      integer p, i, j, c, dir, size, excess, ierr,ierrcode

c---------------------------------------------------------------------
c     compute square root; add small number to allow for roundoff
c     (note: this is computed in setup_mpi.f also, but prefer to do
c     it twice because of some include file problems).
c---------------------------------------------------------------------
      ncells = dint(dsqrt(dble(no_nodes) + 0.00001d0))

c---------------------------------------------------------------------
c     this makes coding easier
c---------------------------------------------------------------------
      p = ncells

c---------------------------------------------------------------------
c     determine the location of the cell at the bottom of the 3D
c     array of cells
c---------------------------------------------------------------------
      cell_coord(1,1) = mod(node,p)
      cell_coord(2,1) = node/p
      cell_coord(3,1) = 0

c---------------------------------------------------------------------
c     set the cell_coords for cells in the rest of the z-layers;
c     this comes down to a simple linear numbering in the z-direct-
c     ion, and to the doubly-cyclic numbering in the other dirs
c---------------------------------------------------------------------
      do c=2, p
         cell_coord(1,c) = mod(cell_coord(1,c-1)+1,p)
         cell_coord(2,c) = mod(cell_coord(2,c-1)-1+p,p)
         cell_coord(3,c) = c-1
      end do

c---------------------------------------------------------------------
c     offset all the coordinates by 1 to adjust for Fortran arrays
c---------------------------------------------------------------------
      do dir = 1, 3
         do c = 1, p
            cell_coord(dir,c) = cell_coord(dir,c) + 1
         end do
      end do

c---------------------------------------------------------------------
c     slice(dir,n) contains the sequence number of the cell that is in
c     coordinate plane n in the dir direction
c---------------------------------------------------------------------
      do dir = 1, 3
         do c = 1, p
            slice(dir,cell_coord(dir,c)) = c
         end do
      end do

c---------------------------------------------------------------------
c     fill the predecessor and successor entries, using the indices
c     of the bottom cells (they are the same at each level of k
c     anyway) acting as if full periodicity pertains; note that p is
c     added to those arguments to the mod functions that might
c     otherwise return wrong values when using the modulo function
c---------------------------------------------------------------------
      i = cell_coord(1,1)-1
      j = cell_coord(2,1)-1

      predecessor(1) = mod(i-1+p,p) + p*j
      predecessor(2) = i + p*mod(j-1+p,p)
      predecessor(3) = mod(i+1,p) + p*mod(j-1+p,p)
      successor(1)   = mod(i+1,p) + p*j
      successor(2)   = i + p*mod(j+1,p)
      successor(3)   = mod(i-1+p,p) + p*mod(j+1,p)

c---------------------------------------------------------------------
c     now compute the sizes of the cells
c---------------------------------------------------------------------
      do dir= 1, 3
c---------------------------------------------------------------------
c     set cell_coord range for each direction
c---------------------------------------------------------------------
         size   = grid_points(dir)/p
         excess = mod(grid_points(dir),p)
         do c=1, ncells
            if (cell_coord(dir,c) .le. excess) then
               cell_size(dir,c) = size+1
               cell_low(dir,c) = (cell_coord(dir,c)-1)*(size+1)
               cell_high(dir,c) = cell_low(dir,c)+size
            else
               cell_size(dir,c) = size
               cell_low(dir,c)  = excess*(size+1)+
     >              (cell_coord(dir,c)-excess-1)*size
               cell_high(dir,c) = cell_low(dir,c)+size-1
            endif
            if (cell_size(dir, c) .le. 2) then
               write(*,50)
 50            format(' Error: Cell size too small. Min size is 3')
               ierrcode = 1
               call MPI_Abort(mpi_comm_world,ierrcode,ierr)
               stop
            endif
         end do
      end do

      return
      end

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


module airfoil_m
#ifdef dnad
    use dnadmod
#define real type(dual)
#endif

    use dataset_m
    implicit none

    type airfoil_t
        character(100) :: name
        character(20) :: properties_type
        integer :: has_data_file
        integer :: has_geom_file

        real :: aL0
        real :: CLa
        real :: CmL0
        real :: Cma
        real :: CD0,CD0L,CD0L2
        real :: CLmax

        type(dataset_t) :: data2D
        type(dataset_t) :: geom
    end type airfoil_t

    type airfoil_p
        type(airfoil_t),pointer :: p
    end type airfoil_p

contains

!-----------------------------------------------------------------------------------------------------------
subroutine af_create_from_data_file(t,filename)
    type(airfoil_t) :: t
    character(100) :: filename
    t%has_data_file = 1
    call ds_create_from_file(t%data2D,filename,4)
    t%CLmax = math_max(t%data2D%datasize, t%data2D%RawData(:,2))
end subroutine af_create_from_data_file

!-----------------------------------------------------------------------------------------------------------
subroutine af_create_geom_from_file(t,DB_Airfoil)
    type(airfoil_t) :: t
    character(200) :: DB_Airfoil
    character(100) :: filename

    filename = trim(adjustl(DB_Airfoil))//'/'//trim(adjustl(t%name))//'_profile.txt'
    call ds_create_from_file(t%geom,filename,2)

end subroutine af_create_geom_from_file

!-----------------------------------------------------------------------------------------------------------
real function af_CLa(t,alpha)
    type(airfoil_t),pointer :: t
    real :: alpha,CL1,CL2
    if(t%has_data_file==1) then
        CL1 = ds_linear_interpolate_col(t%data2D,180.0/pi*(alpha-0.005),1,2)
        CL2 = ds_linear_interpolate_col(t%data2D,180.0/pi*(alpha+0.005),1,2)
        af_CLa = (CL2-CL1)/0.01
    else
        af_CLa = t%CLa
    end if
!    af_CLa = 6.9034609677143 !4412 linear
!    af_CLa = 6.9152325411828 - 2.0*0.3793150634847*alpha !4412 nonlinear
!    write(*,*) alpha*180.0/pi,af_CLa
end function af_CLa

!-----------------------------------------------------------------------------------------------------------
real function af_CL(t,alpha)
    type(airfoil_t),pointer :: t
    real :: alpha
    if(t%has_data_file==1) then
        af_CL = ds_linear_interpolate_col(t%data2D,180.0/pi*alpha,1,2)
    else
        af_CL = t%CLa*(alpha-t%aL0)
    end if
!    af_CL = 0.5173557093757 + 6.9034609677143*alpha !4412 linear
!    af_CL = 0.5183846299204 +  6.9152325411828*alpha - 0.3793150634847*(alpha**2) !4412 nonlinear
!    write(*,*) alpha*180.0/pi,af_CL
end function af_CL

!-----------------------------------------------------------------------------------------------------------
real function af_CD(t,alpha)
    type(airfoil_t),pointer :: t
    real :: alpha,CL
    if(t%has_data_file==1) then
        af_CD = ds_linear_interpolate_col(t%data2D,180.0/pi*alpha,1,3)
    else
        CL = af_CL(t,alpha)
        af_CD = t%CD0 + t%CD0L*CL + t%CD0L2*CL**2
    end if
end function af_CD

!-----------------------------------------------------------------------------------------------------------
real function af_Cm(t,alpha)
    type(airfoil_t),pointer :: t
    real :: alpha
    if(t%has_data_file==1) then
        af_Cm = ds_linear_interpolate_col(t%data2D,180.0/pi*alpha,1,4)
    else
        af_Cm = (t%CmL0 + t%Cma*(alpha-t%aL0))
    end if
end function af_Cm

!-----------------------------------------------------------------------------------------------------------
end module airfoil_m


SUBROUTINE DGELSD1_F95( A, B, RANK, S, RCOND, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP => DP
      USE LA_AUXMOD, ONLY: ERINFO
      USE F77_LAPACK, ONLY: GELSD_F77 => LA_GELSD,  ILAENV_F77 => ILAENV
!   .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
      INTEGER, INTENT(OUT), OPTIONAL :: RANK
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
      REAL(WP), INTENT(IN), OPTIONAL :: RCOND
!   .. ARRAY ARGUMENTS ..
      REAL(WP), INTENT(INOUT) :: A(:,:), B(:)
      REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: S(:)
!   .. PARAMETERS ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GELSD'
!   .. LOCAL SCALARS ..
      INTEGER :: LINFO, ISTAT,  LWORK, N, M, MN, LRANK, SS, &
     &  LIWORK, SMLSIZ, NLVL
      REAL(WP) :: LRCOND
!   .. LOCAL POINTERS ..
      REAL(WP), POINTER :: WORK(:)
      REAL(WP), POINTER :: LS(:)
      INTEGER, POINTER :: IWORK(:)
      REAL(WP) :: WORKMIN(1)
      INTEGER :: IWORKMIN(1)
      DOUBLE PRECISION  TWO
      PARAMETER       ( TWO = 2.0D0 )
!   .. INTRINSIC FUNCTIONS ..
      INTRINSIC SIZE, PRESENT, MAX, MIN, EPSILON
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0; M = SIZE(A,1); N = SIZE(A,2)
    MN = MIN(M,N)
    SMLSIZ = ILAENV_F77( 9, 'DGELSD', ' ', 0, 0, 0, 0 )
    NLVL = INT( LOG( DBLE( MAX(1,MN) ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) )
      LIWORK = 3*MAX(M,N)*(3 * NLVL + 11 )
    IF( PRESENT(RCOND) )THEN; LRCOND = RCOND; ELSE
      LRCOND = 100*EPSILON(1.0_WP) ; ENDIF
    IF( PRESENT(S) )THEN; SS = SIZE(S); ELSE; SS =MN; ENDIF
!   .. TEST THE ARGUMENTS
    IF( M < 0 .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B, 1 ) /= MAX(1,M,N)) THEN; LINFO = -2
    ELSE IF( SS /= MN ) THEN; LINFO = -4
    ELSE IF( LRCOND <= 0.0_WP ) THEN; LINFO = -5
    ELSE
      IF( PRESENT(S) )THEN; LS => S
      ELSE; ALLOCATE( LS(MN), STAT = ISTAT );
        IF (ISTAT /= 0) THEN
          LINFO = -100
          GOTO 100
        ENDIF
      END IF
! .. DETERMINE THE WORKSPACE ..
! .. QUERING THE SIZE OF WORKSPACE ..
      LWORK = -1
      CALL GELSD_F77( M, N, 1, A, MAX(1,M), B, MAX(1,M,N), &
&       LS, LRCOND, LRANK, WORKMIN, LWORK, IWORKMIN,  LINFO )
      LWORK = WORKMIN(1)

      ALLOCATE( WORK(LWORK), STAT = ISTAT )
      IF (ISTAT /= 0) THEN
        LINFO = -100
        GOTO 200
      ENDIF
      ALLOCATE( IWORK(LIWORK), STAT = ISTAT )
      IF (ISTAT /= 0) THEN
        LINFO = -100
        GOTO 250
      ENDIF
      CALL GELSD_F77( M, N, 1, A, MAX(1,M), B, SIZE(B,1), &
&       LS, LRCOND, LRANK, WORK, LWORK, IWORK, LINFO )
      IF( PRESENT(RANK) ) RANK = LRANK

300     DEALLOCATE(IWORK)
250	DEALLOCATE(WORK)
200     IF (.NOT. PRESENT(S)) DEALLOCATE(LS)
ENDIF
100     CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE DGELSD1_F95


      subroutine qqb_wbb_z(p,z)
      implicit none
      include 'constants.f'
      include 'qcdcouple.f'
      include 'scale.f'
      include 'PR_new.f'
      include 'agq.f'
      integer is
      double precision z,p(mxpart,4),dot
      double precision xl12,xl15,xl16,xl25,xl26,xl56
      double precision ii_qq,ii_qg,if_qq,fi_qq,ff_qq,tempqg

      xl12=dlog(+two*dot(p,1,2)/musq)
      xl15=dlog(-two*dot(p,1,5)/musq)
      xl16=dlog(-two*dot(p,1,6)/musq)
      xl25=dlog(-two*dot(p,2,5)/musq)
      xl26=dlog(-two*dot(p,2,6)/musq)
      xl56=dlog(+two*dot(p,5,6)/musq)

      do is=1,3
      Q1(q,q,a,is)=ason4pi
     .             *((xn-two/xn)*(if_qq(z,xl15,is)+fi_qq(z,xl15,is))
     .                  +two/xn *(if_qq(z,xl16,is)+fi_qq(z,xl16,is))
     .                  -one/xn *(ii_qq(z,xl12,is)+ff_qq(z,xl56,is)))
      Q1(a,a,q,is)=ason4pi
     .             *((xn-two/xn)*(if_qq(z,xl25,is)+fi_qq(z,xl25,is))
     .                  +two/xn *(if_qq(z,xl26,is)+fi_qq(z,xl26,is))
     .                  -one/xn *(ii_qq(z,xl12,is)+ff_qq(z,xl56,is)))
      Q2(a,a,q,is)=ason4pi
     .             *((xn-two/xn)*(if_qq(z,xl26,is)+fi_qq(z,xl26,is))
     .                  +two/xn *(if_qq(z,xl25,is)+fi_qq(z,xl25,is))
     .                  -one/xn *(ii_qq(z,xl12,is)+ff_qq(z,xl56,is)))
      Q2(q,q,a,is)=ason4pi
     .             *((xn-two/xn)*(if_qq(z,xl16,is)+fi_qq(z,xl16,is))
     .                  +two/xn *(if_qq(z,xl15,is)+fi_qq(z,xl15,is))
     .                  -one/xn *(ii_qq(z,xl12,is)+ff_qq(z,xl56,is)))

      tempqg=ason2pi*tr*ii_qg(z,xl12,is)
      Q1(a,g,q,is)=tempqg
      Q1(q,g,a,is)=tempqg
      Q2(a,g,q,is)=tempqg
      Q2(q,g,a,is)=tempqg
      enddo

      return
      end


c******************************************************************************
c
c      Simlexspecies redistribution
c
c******************************************************************************
c
       SUBROUTINE SJISRD(NAMAX,NIW,NRW,IW,RW)
c
c      Simplex species redistribution.
c------------------------------------------------------------------------------
c      Species group notation:
c
c          smf denotes the species for which a target mol fraction
c          is specified.  These are balancing species.  The only other
c          allowed species are the basis species identified in SJISMP.
c
c          bo denotes basis species from SJISMP.
c
c          bx denotes detargeted balancing species.
c
c      SJISRD loads up the smf species as close to their target
c      mol fractions as possible by maximizing
c
c              sum{SMOL(J)}    sum over smf species
c
c          subject to the constraints
c
c              sum{N(I,J)*SMOL(J)} = PA(I)     for all independent atoms
c
c              SMOL(J)  ge  0    all bo&bx species
c
c              [X(J)*PMOL(phase of J) -  SMOL(J)]  ge  0   for smf species
c
c              X(J) is the target mol fraction for the smf species J.
c
c          Works only with the linearly independent atoms,  1,...,K,...,NB.
c
c          Only allocates atoms to the smf and bo&bx species.
c------------------------------------------------------------------------------
c          The simplex process is carried out using variables Y(J)
c          defined by
c
c           for bo and bx species:
c
c              Y(J) = SMOL(J)
c
c              Y(J) = - SMOL(J) + X(J)*PMOL(phase of J) smf species
c
c           for smf species:
c
c              Y(Jsmf)= - SMOL(Jsmf)
c                        + X(Jsmf)*[sum{SMOL(smf species in the phase)}
c                                + sum{Y(bo&bx species in the phase)}]
c
c          This is a system of simultaneous linear algebraic equations
c          relating the NSMF  values of SMOL(smf species) to NSMF
c          values of Y(smf species) and to the Y(bo&bx species):
c
c           - SMOL(Jsmf) + X(Jsmf)*sum{SMOL(smf species in the phase)}
c                  =  Y(Jsmf) - X(Jsmf)*sum{Y(bo&bx species in the phase)}
c
c           or, using the summation convention,
c
c           A(I,K)*SMOL(JSMF(K)) = Y(JSMF(I))
c                     + B(I,L)*Y(JBO(L))
c
c          where JSMF(K) denotes the J of the Kth smf species, and JBO(L)
c          denotes the J of the Lth bo&bx species.
c
c          The inversion of this gives
c
c          SMOL(JSMF(I)) = Q(I,K)*[Y(JSMF(K)) + B(K,L)*Y(JBO(L))]
c
c          Hence, the function to be minimized in the Simplex process is
c
c          - sum{Q(I,K)*[B(K,L)*Y(JBO(L)) + Y(JSMF(K))]} all smf species.
c
c          which we recast as
c
c            sum{F(M))*Y(M)} = min       M = 1,...,NS2
c
c          The atomic constraints become
c
c            N(I,JSMF(K))*Q(K,L)*[Y(JSMF(L)) + B(L,M)*Y(JBO(M))]
c
c               + N(I,JBO(K))*Y(JBO(K)) = PA(I)   I=IB(K), K=1,...,NB
c
c          which we recast as
c
c            sum{R(I,L)*Y(L)} = PA(I)     I = IB(K), K=1,NB
c
c          plus the constraints
c
c             Y(M) ge 0  smf and bo species.
c
c          For numerical precision we multiply by the conditioning
c          matrix CM(K,L) and instead work with the conditioned R and
c          the conditioned populations:
c
c            sum{RC(K,L)*Y(L)} = PC(K)      K=1,NB
c
c          The smf species denoted by JSMF above are carried as the first
c          species in JS2, followed by the bo, then the bx, species, then the
c          false species used during initialization.
c
c          At call there are no bx species (all balancers are given targets).
c          At the conclusion of the maximization described above, any smf
c          species in a phase with no mols is made a bx species, and a
c          second run is then made.  This allows the phase to become populated
c          while maintaining the smf constraints in populated phases.
c
c          At the conclusion, the system base control KB reset to SJISRD bases.
c------------------------------------------------------------------------------
c      Nomenclature:
c
c      Variables in the argument list:
c @        NAMAX       maximum number of atoms
c @        NIW         dimension of work array IW
c @        NRW         dimension of work array IR
c          IW(I)       integer work array
c          RW(I)       REAL*8 work array
c
c      Variables in the integer work array IW:
c @        IB(K) = I   if the Ith atom is the Kth independent system atom
c @        JB(K) = J   if the Jth species is the Kth basis
c -        JS2(K) = J  if the Jth species is the Kth SJISRD species
c @        KB(J)       run-start basis control for species J:
c                   -3 for bx species not a SJISRD base at run start
c                   -2 for smf species not a SJISRD base at run start
c                   -1 for bo species not a SJISRD base at run start
c                    1 for bo species a SJISRD base at run sratr
c                    2 for smf species a SJISRD base at run start
c                    3 for bx species a SJISRD base at run start
c                    4 for excluded species
c                    0 for all other species
c @-       KB2(K)      basis control for the Kth SJISRD species
c                   -3 SJISRD y(K) is a bx species not in use as a y-base
c                   -2 SJISRD y(K) is a smf species not in use as a y-base
c                   -1 SJISRD y(K) is a bo species not in use as a y-base
c                    1 SJISRD y(K) is a bo species in use as a y-base
c                    2 SJISRD y(K) is a smf species in use as a y-base
c                    3 SJISRD y(k) is a bx species in use as a y-base
c @        KMON        monitor control
c @        KUMO        output unit for monitor
c -        LB2(K) = L  if the Lth SJISRD y is the Kth SJISRD basis
c @        MPJ(J) = M  if species J is in phase M
c @        N(I,J)      number of Ith atoms in Jth-species molecule
c @        NB          number of independent bases
c @        NP          number of phases
c @        NS          number of species
c
c      Variables in the real work array RW:
c -        A(I,J)      work array
c -        B(K,L)      bo species influence array (see above)
c @        CM(K,M)     conditioning matrix
c -        EEQN(K)     relative error in the Kth change equation
c -        F(K)        minimizing coefficient; see above
c @        FRND        roundoff number
c @        HUGE        largest machine number
c @#       PC(K)       conditioned population of Kth basis atoms
c @#       PMOL(M)     mols in phase M
c -        Q(I,J)      matrix inverse (y influence on mols)
c -        RC(I,L)     effective N(I,L) of y pseudospecies (conditioned R)
c @#       SMOL(J)     mols of the Jth species
c -        SMUL(I)     simplex lagrange multiplier for the Ith variable
c -        W(I)        work vector
c @        X(J)        target mol fractions (J for smf species)
c -        Y(L)        Lth element of the solution vector
c
c      Variables used only internally:
c -        NBOBX        total number of bo + bx species
c -        KPASS        pass counter
c -        KPMAX        maximum allowed KPASS
c -        KRUN         run-through counter
c -        NS2          number of SJISRD species
c -        NSMF         number of smf species
c------------------------------------------------------------------------------
       IMPLICIT    REAL*8  (A-H,O-Z)
c------------------------------------------------------------------------------
       DIMENSION   IW(NIW),RW(NRW)
c------------------------------------------------------------------------------
       COMMON /SJEPTR/
     ;   IoKERR,IoKMON,IoKTRE,IoKUMO,IoNA,IoNB,IoNP,IoNS,IoIB,IoIBO,
     ;   IoJB,IoJBAL,IoJBA,IoJBB,IoJBO,IoJBX,IoJS2,IoKB,IoKB2,IoKBA,
     ;   IoKBB,IoKBO,IoKPC,IoKPCX,IoLB2,IoMPA,IoMPJ,IoN,LoN,IoNSP,
     ;   IoFRND,IoHUGE,IoR1,IoR2,IoR3,IoA,LoA,IoB,LoB,IoBBAL,
     ;   IoCM,LoCM,IoD,LoD,IoDC,LoDC,IoDPML,IoDLAM,IoDLAY,IoE,
     ;   LoE,IoEEQN,IoELAM,IoELMA,IoELMB,IoF,IoG,IoHA,IoHC,IoPA,
     ;   IoPC,IoPMOL,IoQ,LoQ,IoQC,LoQC,IoRC,LoRC,IoRL,IoRP,
     ;   IoSMOA,IoSMOB,IoSMOO,IoSMOL,IoSMUL,IoW,IoX,IoXO,IoY,IoZ
c------------------------------------------------------------------------------
c    integers for compares
       DATA   M1,M2,M3/-1,-2,-3/
c------------------------------------------------------------------------------
c    constants
       FERRF = 10*RW(IoFRND)
       ZERO = 0
c
c    get parameters
       NB = IW(IoNB)
       NP = IW(IoNP)
       NS = IW(IoNS)
       KMON = IW(IoKMON)
       KUMO = IW(IoKUMO)
c
c    set control
       KRUN = 1
c
c    set up JSMF and JS2 for smf species
1      NSMF = 0
       DO 2 J=1,NS
           L = IW(IoKB+J)
           IF ((L.EQ.2).OR.(L.EQ.M2))  THEN
               NSMF = NSMF + 1
               IW(IoJS2+NSMF) = J
               IW(IoKB2+NSMF) = L
               ENDIF
2          CONTINUE
c
c    set NS2, JS2, and KB2 for bo species
       NS2 = NSMF
       DO 3 K=1,NB
           J = IW(IoJB+K)
           NS2 = NS2 + 1
           IW(IoJS2+NS2) = J
           IW(IoKB2+NS2) = IW(IoKB+J)
3          CONTINUE
c    set NS2, JS2, and KB2 for bx species
       DO 4 J=1,NS
           L = IW(IoKB+J)
           IF ((L.EQ.3).OR.(L.EQ.M3))  THEN
               NS2 = NS2 + 1
               IW(IoJS2+NS2) = J
               IW(IoKB2+NS2) = L
               ENDIF
4          CONTINUE
       NBOBX = NS2 - NSMF
c
c    check for too many specified species
       IF (NSMF.GT.2*NAMAX) THEN
           IW(IoKERR) = 1
           RETURN
           ENDIF
c
c  set up the A array in B
       DO 9 K=1,NSMF
           JK = IW(IoJS2+K)
           MJK = IW(IoMPJ+JK)
           DO 8 L=1,NSMF
               JL = IW(IoJS2+L)
               MJL = IW(IoMPJ+JL)
               IoBKL = IoB + K + LoB*L
               IF (MJK.EQ.MJL)  THEN
                       RW(IoBKL) = RW(IoX+JK)
                   ELSE
                       RW(IoBKL) = 0
                   ENDIF
8              CONTINUE
           IoBKK = IoB + K + LoB*K
           RW(IoBKK) = RW(IoBKK) - 1
9          CONTINUE
c
c        compute the matrix Q
       DO 19 K=1,NSMF
c        load the matrix and rhs
           DO 15 L=1,NSMF
               RW(IoW+L) = 0
               DO 13 M=1,NSMF
                   RW(IoA+L+LoA*M) = RW(IoB+L+LoB*M)
13                 CONTINUE
15             CONTINUE
           RW(IoW+K) = 1
c        solve
           CALL SJULES(LoA,RW(IoA+1+LoA),RW(IoW+1),NSMF,IW(IoKERR))
           IF (IW(IoKERR).NE.0)  RETURN
c        transfer the column
           DO 17 L =1,NSMF
               RW(IoQ+L+LoQ*K) = RW(IoW+L)
17             CONTINUE
19         CONTINUE
c
c    compute the B array
       IF (NBOBX.GT.0)  THEN
           DO 25 K=1,NSMF
               JK = IW(IoJS2+K)
               MJK = IW(IoMPJ+JK)
               DO 23 L=1,NBOBX
                   LX = NSMF + L
                   JL = IW(IoJS2+LX)
                   MJL = IW(IoMPJ+JL)
                   IF (MJK.EQ.MJL)  THEN
                           RW(IoB+K+LoB*L) = - RW(IoX+JK)
                       ELSE
                           RW(IoB+K+LoB*L) = 0
                       ENDIF
23                 CONTINUE
25             CONTINUE
           ENDIF
c
c    compute the F vector
       DO 39 K=1,NS2
           IoFK = IoF+K
           RW(IoFK) = 0
           IF (K.LE.NSMF)  THEN
c                smf species
                   DO 31 I=1,NSMF
                       RW(IoFK) = RW(IoFK) - RW(IoQ+I+LoQ*K)
31                     CONTINUE
               ELSE
c                bo&bx species
                   L = K - NSMF
                   DO 35 I=1,NSMF
                       DO 33 M=1,NSMF
                          RW(IoFK) = RW(IoFK) -
     ;                      RW(IoQ+I+LoQ*M)*RW(IoB+M+LoB*L)
33                        CONTINUE
35                     CONTINUE
               ENDIF
39         CONTINUE
c
c    compute the conditioned R array
       DO 59 K=1,NB
           DO 57 L=1,NS2
               JL = IW(IoJS2+L)
               IoRCKL = IoRC + K + LoRC*L
               RW(IoRCKL) = 0
c            branch on species L type
               IF (L.LE.NSMF)  THEN
c                    smf species
                       DO 45 K1=1,NSMF
                           J1 = IW(IoJS2+K1)
c                        check for a contribution
                           IF ((IW(IoKB+J1).NE.1)
     ;                      .OR.(IW(IoJB+K).EQ.J1)) THEN
                               IF (IW(IoKB+J1).EQ.1)  THEN
c                                    species J1 is the Kth base
                                       SUM1 = 1
                                   ELSE
c                                    species J1 is not a base
                                       SUM1 = 0
                                       DO 43 K2=1,NB
                                         I2 = IW(IoIB+K2)
                                         SUM1 = SUM1 +
     ;                                    RW(IoCM+K+LoCM*K2)*
     ;                                      IW(IoN+I2+LoN*J1)
43                                       CONTINUE
                                   ENDIF
                               RW(IoRCKL) = RW(IoRCKL)
     ;                           + SUM1*RW(IoQ+K1+LoQ*L)
                               ENDIF
45                         CONTINUE
                   ELSE
c                    bo&bx species
                       LX = L - NSMF
                       DO 55 K1=1,NSMF
                           SUM1 = 0
                           DO 53 K2=1,NSMF
                               J2 = IW(IoJS2+K2)
                               IF ((IW(IoKB+J2).NE.1)
     ;                          .OR.(IW(IoJB+K).EQ.J2))  THEN
c                               check for a contribution
                                 IF (IW(IoKB+J2).EQ.1)  THEN
c                                     species J2 is the Kth base
                                       SUM2 = 1
                                    ELSE
c                                     species J2 is not a base
                                       SUM2 = 0
                                       DO 51 K3=1,NB
                                         I3 = IW(IoIB+K3)
                                         SUM2 = SUM2 +
     ;                                    RW(IoCM+K+LoCM*K3)*
     ;                                      IW(IoN+I3+LoN*J2)
51                                       CONTINUE
                                    ENDIF
                                 SUM1 = SUM1 + SUM2*RW(IoQ+K2+LoQ*K1)
                                 ENDIF
53                             CONTINUE
                           RW(IoRCKL) = RW(IoRCKL) +
     ;                       SUM1*RW(IoB+K1+LoB*LX)
55                         CONTINUE
c
c                    check type of L species
                       IF (IW(IoKB+JL).EQ.1)  THEN
c                            L is a base; add 1 if its the Kth base
                               IF (L-NSMF.EQ.K)  RW(IoRCKL) =
     ;                          RW(IoRCKL) + 1
                           ELSE
c                            L is a bx species
                               DO 56 K1=1,NB
                                   I1 = IW(IoIB+K1)
                                   RW(IoRCKL) = RW(IoRCKL)
     ;                            + RW(IoCM+K+LoCM*K1)*
     ;                                IW(IoN+I1+LoN*JL)
56                                 CONTINUE
                           ENDIF
                   ENDIF
57             CONTINUE
59         CONTINUE
c
c -- set initial basis
c
c    clear all mols
       DO 61 J=1,NS
           RW(IoSMOL+J) = 0
61         CONTINUE
c    set basis mols = conditioned populations
       DO 63 K=1,NB
           J = IW(IoJB+K)
           RW(IoSMOL+J) = RW(IoPC+K)
63         CONTINUE
c
c    set Y
70     DO 71 K=1,NSMF
           J = IW(IoJS2+K)
           M = IW(IoMPJ+J)
           RW(IoY+K) = - RW(IoSMOL+J) + RW(IoX+J)*RW(IoPMOL+M)
71         CONTINUE
       DO 73 L=1,NBOBX
           K = NSMF + L
           J = IW(IoJS2+K)
           RW(IoY+K) = RW(IoSMOL+J)
73         CONTINUE
c
c    set basis pointer
       K = 0
       DO 75 L=1,NS2
           IF (IW(IoKB2+L).GT.0) THEN
               K = K + 1
               IW(IoLB2+K) = L
               ENDIF
75         CONTINUE
c
c    initializations
       KPASS = 0
       KPMAX = 2*NS2
c
c -- Simplex loop point; Determine the simplex multipliers.
c
100    KPASS = KPASS + 1
c
c    check pass count
       IF (KPASS.GT.KPMAX)  THEN
           IF (KMON.GT.0)  WRITE (KUMO,106)
106        FORMAT (/' Too many passes in SJISRD')
           IW(IoKERR) = 1
           RETURN
           ENDIF
c
c    set up the matrix and rhs
       DO 129 K=1,NB
           LK = IW(IoLB2+K)
           RW(IoSMUL+K) = RW(IoF+LK)
           DO 119 L=1,NB
               RW(IoA+K+LoA*L) = RW(IoRC+L+LoRC*LK)
119            CONTINUE
129        CONTINUE
c
c      solve to put the multipliers in SMUL
       CALL SJULES(LoA,RW(IoA+1+LoA),RW(IoSMUL+1),NB,IW(IoKERR))
       IF (IW(IoKERR).NE.0)  RETURN
c
c ---- select the new basis member LN
c
       SMAX = 0
       LN = 0
       DO 169 L=1,NS2
           IF (IW(IoKB2+L).LT.0)  THEN
c            SJISRD species L is a trial base base
               KBN = - IW(IoKB2+L)
               SL = - RW(IoF+L)
               TERMX = DABS(SL)
c
c            add in the Simplex multiplier terms
156            DO 167 K=1,NB
                   AKL = RW(IoRC+K+LoRC*L)
                   TERM = RW(IoSMUL+K)*AKL
                   SL = SL + TERM
                   CALL SJUMAX(TERM,TERMX)
167                CONTINUE
               CALL SJURND(SL,TERMX)
               IF (SL.GT.SMAX)  THEN
c                a better candidate found
                   SMAX = SL
                   LN = L
                   ENDIF
               ENDIF
c
169        CONTINUE
c
c -- Check for completion (LN=0)
c
       IF (LN.EQ.0)  GOTO 400
c
c -- Determine the directions of change as LN becomes a basis member.
c
c          W(K) = dY(Kth old basis)/dY(new basis)
c
       KBN = - IW(IoKB2+LN)
c
c    load matrix in A and rhs in W
       DO  179  K=1,NB
           RW(IoW+K) = - RW(IoRC+K+LoRC*LN)
176        DO 177 L=1,NB
               LL = IW(IoLB2+L)
               RW(IoA+K+LoA*L) = RW(IoRC+K+LoRC*LL)
177            CONTINUE
179        CONTINUE
c
c      solve to put the directions in W
       CALL SJULES(LoA,RW(IoA+1+LoA),RW(IoW+1),NB,IW(IoKERR))
       IF (IW(IoKERR).NE.0)  RETURN
c
c -- Determine which of the old bases KE will be eliminated
c
       LE = 0
       DS = RW(IoHUGE)
       DO 183 K=1,NB
           LK = IW(IoLB2+K)
           IoWK = IoW + K
           IoYLK = IoY + LK
           IF (((RW(IoWK).LT.ZERO).AND.(RW(IoYLK).GE.ZERO)).OR.
     ;         ((RW(IoWK).GT.ZERO).AND.(RW(IoYLK).LT.ZERO)))  THEN
c            the y of LK move towards zero on the path
               DSL = - RW(IoYLK)/RW(IoWK)
               IF (DABS(DSL-DS).LE.RW(IoFRND)*DS)  DSL = DS
               IF ((DSL.LT.DS).OR.((DSL.EQ.DS).AND.(LK.GT.NS2)))  THEN
c                base LK is a better replacement candidate
                   DS = DSL
                   LE = LK
                   KE = K
                   ENDIF
               ENDIF
183        CONTINUE
c
c -- check for elimination
c
       IF (LE.EQ.0)  GOTO 400
c
c -- solve for the new bases (rather than for changes, for better accuracy)
c
c    remove the old base
       RW(IoY+LE) = 0
       IW(IoKB2+LE) = - IW(IoKB2+LE)
c
c    set the new base
       RW(IoY+LN) = DS
       IW(IoKB2+LN) = - IW(IoKB2+LN)
       IW(IoLB2+KE) = LN
c
c    set up the equation system
       DO 209 K=1,NB
c        load rhs
           RW(IoW+K) = RW(IoPC+K)
c        load matrix
           DO 205 M=1,NB
               LM = IW(IoLB2+M)
               RW(IoA+K+LoA*M) = RW(IoRC+K+LoRC*LM)
205            CONTINUE
209        CONTINUE
c    solve
       CALL SJULES(LoA,RW(IoA+1+LoA),RW(IoW+1),NB,IW(IoKERR))
c    check for failure
       IF (IW(IoKERR).NE.0)  RETURN
c    trim and load the solution
       DO 229 K=1,NB
           LK = IW(IoLB2+K)
           IoWK = IoW + K
           IoYLK = IoY + LK
c        zero drop fixup
           IF (((RW(IoWK).LT.ZERO).AND.(RW(IoYLK).GE.ZERO)).OR.
     ;     ((RW(IoWK).GT.ZERO).AND.(RW(IoYLK).LT.ZERO))) RW(IoWK) = 0
           RW(IoYLK) = RW(IoWK)
229        CONTINUE
c
c    check for accuracy of constraint satisfaction
       KFIX = 0
       DO 249 K=1,NB
c        compute equation error in SUM
           SUM = RW(IoPC+K)
           TERMX = DABS(SUM)
           DO 245 L=1,NB
               LL = IW(IoLB2+L)
               AX = RW(IoRC+K+LoRC*LL)
               TERM = AX*RW(IoY+LL)
               CALL SJUMAX(TERM,TERMX)
               SUM = SUM - TERM
245            CONTINUE
c        check relative errors
           IF (TERMX.NE.ZERO)  SUM = DABS(SUM/TERMX)
c        save error
           RW(IoEEQN+K) = SUM
c        check error vs limits
           IF (SUM.GT.FERRF)  KFIX = 1
249        CONTINUE
c
c    skip refinement if not necessary
       IF (KFIX.EQ.0)  GOTO 300
c
c -- Solution refinement
c
c    Solve for the populations of the other bases using the new base value
c    in a shortened set of conditional equations. The most accurately
c    solved equation (KE) is dropped.
c
c    find the most accurately solved equation
250    SUM = RW(IoHUGE)
       KE = 0
       DO 251 K=1,NB
           IF (RW(IoEEQN+K).LT.SUM)  THEN
               SUM = RW(IoEEQN+K)
               KE = K
               ENDIF
251        CONTINUE
c
c    check for inability to fix
       IF (KE.EQ.0)  THEN
           GOTO 300
           ENDIF
c
c    set up the reduced equation system
       K1 = 0
       DO 269 K=1,NB
           IF (K.NE.KE)  THEN
c            load rhs
               K1 = K1 + 1
               RW(IoW+K1) = RW(IoPC+K) -
     ;                  RW(IoRC+K+LoRC*LN)*RW(IoY+LN)
c            load matrix
               M1 = 0
               DO 267 M=1,NB
                   LM = IW(IoLB2+M)
                   IF (LM.NE.LN)  THEN
                       M1 = M1 + 1
                       RW(IoA+K1+LoA*M1) = RW(IoRC+K+LoRC*LM)
                       ENDIF
267                CONTINUE
               ENDIF
269        CONTINUE
c    solve
       CALL SJULES(LoA,RW(IoA+1+LoA),RW(IoW+1),K1,IW(IoKERR))
c    check for failure
        IF (IW(IoKERR).NE.0)  THEN
c        try another equation
           RW(IoEEQN+KE) = RW(IoHUGE)
           GOTO 250
           ENDIF
c
c    transfer the solution
       K1 = 0
       DO 279 K=1,NB
           LK = IW(IoLB2+K)
           IF (LK.NE.LN)  THEN
               K1 = K1 + 1
               RW(IoY+LK) = RW(IoW+K1)
               ENDIF
279        CONTINUE
c
c -- end of pass
c
300   GOTO 100
c
c *** end of run
c
c   compute the mols of smf species
400    DO 409 K=1,NSMF
           J = IW(IoJS2+K)
           RW(IoSMOL+J) = 0
           TERMX = 0
           DO 407 L=1,NSMF
               TERM = RW(IoQ+K+LoQ*L)*RW(IoY+L)
               CALL SJUMAX(TERM,TERMX)
               RW(IoSMOL+J) = RW(IoSMOL+J) + TERM
               SUM = 0
               DO 405 M=1,NB
                   MX = NSMF + M
                   SUM = SUM + RW(IoB+L+LoB*M)*RW(IoY+MX)
405                CONTINUE
               TERM = RW(IoQ+K+LoQ*L)*SUM
               RW(IoSMOL+J) = RW(IoSMOL+J) + TERM
               CALL SJUMAX(TERM,TERMX)
407            CONTINUE
           CALL SJURND(RW(IoSMOL+J),TERMX)
409        CONTINUE
c
c    set mols of bo&bx species
       DO 411 K=1,NBOBX
           KX = NSMF + K
           J = IW(IoJS2+KX)
           L = NSMF + K
           RW(IoSMOL+J) = RW(IoY+L)
411        CONTINUE
c
c    compute phase mols
       DO 413 M=1,NP
           RW(IoPMOL+M) = 0
413        CONTINUE
       DO 415 K=1,NS2
           J = IW(IoJS2+K)
           M = IW(IoMPJ+J)
           RW(IoPMOL+M) = RW(IoPMOL+M) + RW(IoSMOL+J)
415        CONTINUE
c
c    check run
       IF (KRUN.EQ.1)  THEN
c       check for balancing species in an absent phase
           KSMF = 0
           DO 429 K=1,NSMF
               JK = IW(IoJS2+K)
               IF (RW(IoSMOL+JK).EQ.ZERO)  THEN
c                    balancer has zero mols; check phase
                       DO 427 L=1,NS2
                           JL = IW(IoJS2+L)
                           IF (IW(IoMPJ+JL).EQ.IW(IoMPJ+JK))  THEN
                               IF (RW(IoSMOL+JL).NE.ZERO)  THEN
c                                phase populated ; keep as smf
                                   KSMF = 1
                                   GOTO 429
                                   ENDIF
                               ENDIF
427                        CONTINUE
c                    balancer is in an empty phase; set as bx
                       IF (IW(IoKB2+K).LT.0)  THEN
c                            species is not a current SJISRD base
                               IW(IoKB2+K) = -3
                           ELSE
c                            species is a current SJISRD base
                               IW(IoKB2+K) = 3
                           ENDIF
                       KRUN = 2
                   ELSE
c                    balancer is smf species in a populated phase
                       KSMF = 1
                   ENDIF
429            CONTINUE
c
c        go do a second run if needed and feasible
           IF ((KRUN.EQ.2).AND.(KSMF.EQ.1))  THEN
c            set run-start basis controls
               DO 439 K=1,NS2
                   J = IW(IoJS2+K)
                   IW(IoKB+J) = IW(IoKB2+K)
439                CONTINUE
               GOTO 1
               ENDIF
           ENDIF
c
c ** exit
c
c    reset system basis as SJISRD basis
       NB = 0
       DO 459 L=1,NS2
           J = IW(IoJS2+L)
           IF (IW(IoKB2+L).GT.0)  THEN
c                the species is a system base
                   NB = NB + 1
                   IW(IoJB+NB) = J
                   IW(IoKB+J) = 1
               ELSE
c                the species is not a systems base
                   IW(IoKB+J) = 0
               ENDIF
459        CONTINUE
c
c    exit
       IW(IoKERR) = 0
       RETURN
c
       END
c******************************************************************************


subroutine quad2d4n(igau,ngau,gau,wei,maxnsd,maxnquad)

      real*8 gau(maxnsd,maxnquad), wei(maxnquad)

	  DO I = 1,maxnquad
		WEI(I) = 0.0
		DO J = 1,maxnsd
		  GAU(J,I) = 0.0
		ENDDO
	  ENDDO

      IF(IGAU.EQ.1) THEN
		NGAU = 1
		GAU(1,1) = 0.0
		GAU(2,1) = 0.0

		WEI(1) = 4.0
		RETURN
	  ENDIF

      IF(IGAU.EQ.2) THEN
		NGAU = 4
		GC      =+.577350269189626

        GAU(1,1)=-GC
        GAU(2,1)=-GC
        GAU(1,2)=+GC
        GAU(2,2)=-GC
        GAU(1,3)=-GC
        GAU(2,3)=+GC
        GAU(1,4)=+GC
        GAU(2,4)=+GC
		WEI(1)= 1.0
		WEI(2)= 1.0
		WEI(3)= 1.0
		WEI(4)= 1.0

		RETURN
      ENDIF

END


!==============================================================================!
  subroutine Surf_Mod_Handle_4_Points(surf, surf_v)
!------------------------------------------------------------------------------!
!   Surface intersects cell at four points                                     !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Surf_Type), target :: surf
  real                    :: surf_v(3)
!-----------------------------------[Locals]-----------------------------------!
  type(Vert_Type), pointer :: vert(:)
  type(Elem_Type), pointer :: elem(:)
  integer,         pointer :: nv, ne
  integer                  :: ver(4), loop
  real                     :: v_21(3), v_31(3), v_41(3)
  real                     :: tri_p_123(3), tri_p_134(3)
  integer                  :: permutations(4, 6)
!=============================================================================!

  ! Take aliases
  nv   => surf % n_verts
  ne   => surf % n_elems
  vert => surf % vert
  elem => surf % elem

  permutations = reshape((/ &
    0, 1, 2, 3,  &
    0, 2, 1, 3,  &
    0, 3, 1, 2,  &
    0, 1, 3, 2,  &
    0, 2, 3, 1,  &
    0, 3, 2, 1   &
  /), shape(permutations))

  !-------------------------------------------!
  !   Try to find a permutation which works   !
  !-------------------------------------------!
  do loop = 1, 6

    ver(1) = nv - permutations(1, loop)
    ver(2) = nv - permutations(2, loop)
    ver(3) = nv - permutations(3, loop)
    ver(4) = nv - permutations(4, loop)

    v_21(1) = vert(ver(2)) % x_n - vert(ver(1)) % x_n
    v_21(2) = vert(ver(2)) % y_n - vert(ver(1)) % y_n
    v_21(3) = vert(ver(2)) % z_n - vert(ver(1)) % z_n

    v_31(1) = vert(ver(3)) % x_n - vert(ver(1)) % x_n
    v_31(2) = vert(ver(3)) % y_n - vert(ver(1)) % y_n
    v_31(3) = vert(ver(3)) % z_n - vert(ver(1)) % z_n

    v_41(1) = vert(ver(4)) % x_n - vert(ver(1)) % x_n
    v_41(2) = vert(ver(4)) % y_n - vert(ver(1)) % y_n
    v_41(3) = vert(ver(4)) % z_n - vert(ver(1)) % z_n

    tri_p_123 = Math_Mod_Cross_Product(v_21, v_31)
    tri_p_134 = Math_Mod_Cross_Product(v_31, v_41)

    if(dot_product(surf_v, tri_p_123) > 0.0 .and.  &
       dot_product(surf_v, tri_p_134) > 0.0) then
      exit
    end if

  end do

  !--------------------------------------------------------------------!
  !   You've found a permutation which works, store new elements now   !
  !--------------------------------------------------------------------!

  ! One new element with three vertices
  ne = ne + 1
  elem(ne) % i = ver(1)
  elem(ne) % j = ver(2)
  elem(ne) % k = ver(3)

  ! Second new element with three vertices
  ne = ne + 1
  elem(ne) % i = ver(1)
  elem(ne) % j = ver(3)
  elem(ne) % k = ver(4)

  end subroutine


C     LAST UPDATE 17/07/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      REAL FUNCTION DBRENT2(AX,BX,CX,F,DF,TOL,XMIN)
      IMPLICIT NONE
C
C Purpose: Given a function F and its derivative function DF, and
C          given a bracketing triplet of abscissas AX,BX,CX [such
C          that BX is between AX and CX, and F(BX) is less than
C          both F(AX) and F(CX)], this routine isolates the minimum
C          to a fractional precision of about TOL using a modification
C          of Brent's method that uses derivatives. The abscissa of the
C          minimum is returned as XMIN and the minimum function value
C          is returned as DBRENT2, the returned function value.
C
C Calls   2: F, DF
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      INTEGER ITMAX
      REAL ZEPS
      PARAMETER(ITMAX=100, ZEPS=1.0E-10)
C
C Scalar arguments:
C
      REAL AX,BX,CX,TOL,XMIN
C
C Function arguments:
C
      REAL F
      EXTERNAL F,DF
C
C External functions:
C
      REAL F1DIM,DF1DIM
      EXTERNAL F1DIM,DF1DIM
C
C Local variables:
C
      INTEGER ITER
      LOGICAL OK1,OK2
      REAL A,B,D,DU,DV,DW,DX,E,FU,FV,FW,FX,U,V,W,X,XM,TOL1,TOL2,D1,D2,
     &     U1,U2,OLDE
C
C-----------------------------------------------------------------------
      A = MIN(AX,CX)
      B = MAX(AX,CX)
      V = BX
      W = V
      X = V
      E = 0.0
      FX = F1DIM(X,F)
      FV = FX
      FW = FX
      DX = DF1DIM(X,DF)
      DV = DX
      DW = DX
      DO 10 ITER=1,ITMAX
         XM = 0.5*(A+B)
         TOL1 = TOL*ABS(X) + ZEPS
         TOL2 = 2.0*TOL1
         IF(ABS(X-XM).LE.(TOL2-0.5*(B-A)))GOTO 3
         IF(ABS(E).GT.TOL1)THEN
            D1 = 2.0*(B-A)
            D2 = D1
            IF(DW.NE.DX)D1 = (W-X)*DX/(DX-DW)
            IF(DV.NE.DX)D2 = (V-X)*DX/(DX-DV)
            U1 = X + D1
            U2 = X + D2
            OK1 = ((A-U1)*(U1-B).GT.0.0).AND.(DX*D1.LE.0.0)
            OK2 = ((A-U2)*(U2-B).GT.0.0).AND.(DX*D2.LE.0.0)
            OLDE = E
            E = D
            IF(.NOT.(OK1.OR.OK2))THEN
               GOTO 1
            ELSEIF(OK1.AND.OK2)THEN
               IF(ABS(D1).LT.ABS(D2))THEN
                  D = D1
               ELSE
                  D = D2
               ENDIF
            ELSEIF(OK1)THEN
               D = D1
            ELSE
               D = D2
            ENDIF
            IF(ABS(D).GT.ABS(0.5*OLDE))GOTO 1
            U = X + D
            IF(U.LT.TOL2.OR.B-U.LT.TOL2)D=SIGN(TOL1,XM-X)
            GOTO 2
         ENDIF
 1       IF(DX.GE.0.0)THEN
            E = A - X
         ELSE
            E = B - X
         ENDIF
         D = 0.5*E
 2       IF(ABS(D).GE.TOL1)THEN
            U = X + D
            FU = F1DIM(U,F)
         ELSE
            U = X + SIGN(TOL1,D)
            FU = F1DIM(U,F)
            IF(FU.GT.FX)GOTO 3
         ENDIF
         DU = DF1DIM(U,DF)
         IF(FU.LE.FX)THEN
            IF(U.GE.X)THEN
               A = X
            ELSE
               B = X
            ENDIF
            V = W
            FV = FW
            DV = DW
            W = X
            FW = FX
            DW = DX
            X = U
            FX = FU
            DX = DU
         ELSE
            IF(U.LT.X)THEN
               A = U
            ELSE
               B = U
            ENDIF
            IF(FU.LE.FW.OR.W.EQ.X)THEN
               V = W
               FV = FW
               DV = DW
               W = U
               FW = FU
               DW = DU
            ELSEIF(FU.LE.FV.OR.V.EQ.X.OR.V.EQ.W)THEN
               V = U
               FV = FU
               DV = DU
            ENDIF
         ENDIF
 10   CONTINUE
      WRITE(6,1000)
 3    XMIN = X
      DBRENT2 = FX
      RETURN
C
 1000 FORMAT(1X,'DBRENT:Warning - maximum number of iterations reached')
C-----------------------------------------------------------------------
      END


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   DIM constant folding in the expander.

	parameter(n = 35)
	integer rslts(n), expect(n)
	real  rrslts(n), rexpect(n)
	equivalence (rslts, rrslts), (expect, rexpect)

        integer  i, j, k, l
        real     r, s, t, u
        double precision  d, e, f, g

	data (expect(i), i = 1, 11) /0,21,0,11,57,0,0,23,0,0,0/
        i = DIM( 2, 23)
        rslts(1) = i
        i = DIM( 23, 2)
        rslts(2) = i
        j = DIM( -34, -23)
        rslts(3) = j
        j = DIM( -23, -34)
        rslts(4) = j
        j = DIM( 23, -34)
        rslts(5) = j
        j = DIM( -23, 34)
        rslts(6) = j
        k = DIM(0, 23)
        rslts(7) = k
        k = DIM(23, 0)
        rslts(8) = k
        k = DIM(0,0)
        rslts(9) = k
        l = DIM(j,k)
        rslts(10) = l
        l = DIM(k,l)
        rslts(11) = l

	data (rexpect(i), i = 12, 23) /0.0,21.2,0.0,11.6,0.0,58.0,
     -  34.5,0.0,0.0,58.0,0.0,0.0/
        r = DIM(2.45,23.2)
        rrslts(12) = r
        r = DIM(23.45,2.25)
        rrslts(13) = r
        s = DIM(-34.6,-23.4)
        rrslts(14) = s
        s = DIM(-23.4,-35.0)
        rrslts(15) = s
        s = DIM(-23.4,34.6)
        rrslts(16) = s
        s = DIM(23.4,-34.6)
        rrslts(17) = s
        t = DIM(0.0, -34.5)
        rrslts(18) = t
        t = DIM(0.0, 34.5)
        rrslts(19) = t
        t = DIM(0.0, 0.0)
        rrslts(20) = t
        u = DIM(s,t)
        rrslts(21) = u
        u = DIM(t,s)
        rrslts(22) = u
        u = DIM(s,s)
        rrslts(23) = u

	data (rexpect(i), i = 24, 35) /0.0,32.0,0.0,23.3,92.5,0.0,
     -  0.0,34.8,0.0,0.0,0.0,0.0/
        d = DIM(2.45D0,34.3D0)
        rrslts(24) = d
        d = DIM(34.45D0, 2.45D0)
        rrslts(25) = d
        e = DIM(-34.6D0,-23.6D0)
        rrslts(26) = e
        e = DIM(-34.6D0, -57.9D0)
        rrslts(27) = e
        e = DIM(34.6D0, -57.9D0)
        rrslts(28) = e
        e = DIM(-34.6D0, 57.9D0)
        rrslts(29) = e
        f = DIM(0.0D0,34.8D0)
        rrslts(30) = f
        f = DIM(34.8D0,0.0D0)
        rrslts(31) = f
        f = DIM(0.0D0,0.0D0)
        rrslts(32) = f
        g = DIM(e,f)
        rrslts(33) = g
        g = DIM(g,e)
        rrslts(34) = g
        g = DIM(g,g)
        rrslts(35) = g

        call check(rslts,expect,n)
        end


!==========================================================================================
! SUBRUTINA DE CALCULO DE PROPIEDADES DE AUTO DIFUSION. DESPLAZAMIENTO CUADRATICO MEDIO Y
! COEFICIENTE DE DIFUSION DEPENDIENTE DEL TIEMPO
!
! AUTOR: MARTIN ALEJANDRO PAREDES SOSA
!==========================================================================================

Subroutine WDT(k)

  Use cte
  Implicit None

  Integer :: k, i, j, p, nmax                              !CONTADORES
  Real :: Ti, Time                                         !CONTROL DE TIEMPO
  Real :: Wtx, Wty, Wtz, Wt                                !DESPLAZAMIENTO CUADRATICO MEDIO
  Real :: Dif                                              !DIFUSION

  Open(96, File="wdt.dat")

  !TIEMPO ENTRE CONFIGURACIONES
  Ti = Real(iSave2) * dt

  !BARRIDO TEMPORAL
  TEMPO: Do i = 1 , k-1

     nmax = k - i

     Wtx = 0.0
     Wty = 0.0
     Wtz = 0.0
     Wt = 0.0

     !BARRIMIENTO DE PARTICULAS
     BPart: Do p = 1, N

        !BARRIDO EN TIEMPO
        Tiempo: Do j = 1, nmax

           Wtx = Wtx + ( CXD(p,i+j) - CXD(p,j)  ) * ( CXD(p,i+j) - CXD(p,j)  )
           wty = Wty + ( CYD(p,i+j) - CYD(p,j)  ) * ( CYD(p,i+j) - CYD(p,j)  )
           Wtz = Wtz + ( CZD(p,i+j) - CZD(p,j)  ) * ( CZD(p,i+j) - CZD(p,j)  )

        End Do Tiempo

     End Do BPart

     Time = Ti * Real(i)
     Wt = (Wtx + Wty + Wtz ) / ( Real(nmax) * Real(N) * 6.0 )
     Dif = Wt / Time

     Write(96,*) Time, Wt, Dif

  End Do TEMPO
  Close(96)

End Subroutine WDT


       SUBROUTINE RKQC(Y,DYDX,N,X,HTRY,EPS,YSCAL,HDID,HNEXT,HMIN)

       PARAMETER (NMAX   = 24,
     >            PGROW  = -.20,
     >            PSHRNK = -0.25,
     >            FCOR   = 1./15.,
     >            ONE    = 1.,
     >            SAFETY = 0.9,
     >            ERRCON = 6.0E-04,
     >            BOUND  = 1.000E+08 )

       DIMENSION DYDX(NMAX),YSCAL(NMAX),YTEMP(NMAX),
     >           DYSAV(NMAX),YSAV(NMAX)

       real Y(NMAX)

C SAVE INITIAL VALUES
           XSAV=X
           DO 11 I=1,N
            YSAV(I)=Y(I)
            DYSAV(I)=DYDX(I)
11        CONTINUE
          H = HTRY

C   TWO HALF STEPS
1         HH=0.5*H
	      !write(*,*) 'in rkqc before rk4'
		  !write(*,*) N
          CALL RK4(YSAV,DYSAV,N,XSAV,HH,YTEMP)
		  !write(*,*) 'in rkqc after rk4'
		  !write(*,*) N
          X=XSAV+HH
          CALL DERIVS(X,YTEMP,DYDX,N)
		  !write(*,*) 'in rkqc after derivs'
		  !write(*,*) N
          CALL RK4(YTEMP,DYDX,N,X,HH,Y)
          X=XSAV+H

C   TAKE THE LARGE STEP
          CALL RK4(YSAV,DYSAV,N,XSAV,H,YTEMP)
          ERRMAX = 0.0

C   EVALUATE ACCURACY
          DO 12 I=1,N

C  YTEMP NOW CONTAINS THE ERROR ESTIMATE
           YTEMP(I)=Y(I)-YTEMP(I)
c      WRITE(6,*)YTEMP(I)
           ERRMAX=max(ERRMAX,abs(YTEMP(I)/YSCAL(I)))
12         CONTINUE

C SCALE RELATIVE TO THE REQUIRE EPS(ACCURACY)
           ERRMAX=ERRMAX/EPS
ck           write(27,121) errmax
121        format(5x,'errmax =',e17.9/)
           IF(ERRMAX .GT. ONE)THEN
C
C  TRUNCUATION ERROR TOO LARGE REDUCE STEPSIZE
            WRITE(*,*)'reducing stepsize', H
             H=SAFETY*H*(ERRMAX**PSHRNK)
c  CHECK  FORsSTIFFNESS AND POSSIBLE STABILITY PROBLEMS
ck           write(27,122) h,hmin
122          format(5x,'H =',e17.9,2x,'HMIN =',e17.9/)

             IF (H .LE. HMIN)THEN
			   write(*,*) 'calling implicit',N
                CALL IMPLICIT(YSAV(1:N),XSAV,HTRY,N)
c                WRITE(27,31)
c31              FORMAT('STIFFNESS DETECTED')
                X = XSAV+HTRY
                DO 100 I=1,N
                   Y(I)=YSAV(I)
100             CONTINUE
                HDID = HTRY
                HNEXT= HTRY
                RETURN
             ENDIF
             GO TO 1
C  GO FOR ANOTHER TRY
           ELSE

C   STEP SUCCEEDED
             HDID=H
             IF(ERRMAX .GT. ERRCON)THEN
               HNEXT=SAFETY*H*(ERRMAX**PGROW)
             ELSE
               HNEXT=4.00*H
C  INCREASE STEPSIZE
             ENDIF

           ENDIF
           DO 13 I=1,N
C  MOP UP FIFTH ORDER TRUNCUATION ERROR
              Y(I)=Y(I)+YTEMP(I)*FCOR
13         CONTINUE

99         CONTINUE

       RETURN
       END


      DOUBLE PRECISION FUNCTION AB13AX( DICO, N, M, P, A, LDA, B, LDB,
     $                                  C, LDC, HSV, DWORK, LDWORK,
     $                                  INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Hankel-norm of the transfer-function matrix G of
C     a stable state-space system (A,B,C). The state dynamics matrix A
C     of the given system is an upper quasi-triangular matrix in
C     real Schur form.
C
C     FUNCTION VALUE
C
C     AB13AX  DOUBLE PRECISION
C             The Hankel-norm of G (if INFO = 0).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation, i.e. the
C             order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             state dynamics matrix A in a real Schur canonical form.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             input/state matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             state/output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     HSV     (output) DOUBLE PRECISION array, dimension (N)
C             If INFO = 0, this array contains the Hankel singular
C             values of the given system ordered decreasingly.
C             HSV(1) is the Hankel norm of the given system.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the state matrix A is not stable (if DICO = 'C')
C                   or not convergent (if DICO = 'D');
C             = 2:  the computation of Hankel singular values failed.
C
C     METHOD
C
C     Let be the stable linear system
C
C          d[x(t)] = Ax(t) + Bu(t)
C          y(t)    = Cx(t)                               (1)
C
C     where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
C     for a discrete-time system, and let G be the corresponding
C     transfer-function matrix. The Hankel-norm of G is computed as the
C     the maximum Hankel singular value of the system (A,B,C).
C     The computation of the Hankel singular values is performed
C     by using the square-root method of [1].
C
C     REFERENCES
C
C     [1] Tombs M.S. and Postlethwaite I.
C         Truncated balanced realization of stable, non-minimal
C         state-space systems.
C         Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
C
C     NUMERICAL ASPECTS
C
C     The implemented method relies on a square-root technique.
C                                     3
C     The algorithms require about 17N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 1998.
C     Based on the RASP routine SHANRM.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Feb. 2000, V. Sima, Research Institute for Informatics, Bucharest.
C     Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Multivariable system, state-space model, system norms.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO
      INTEGER           INFO, LDA, LDB, LDC, LDWORK, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*)
C     .. Local Scalars ..
      LOGICAL           DISCR
      INTEGER           I, IERR, J, KR, KS, KTAU, KU, KW, MNMP
      DOUBLE PRECISION  SCALEC, SCALEO, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLACPY, DSCAL, DTPMV, MA02DD, MB03UD, SB03OU,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C     .. Executable Statements ..
C
      INFO  = 0
      DISCR = LSAME( DICO, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) +
     $                         ( N*( N + 1 ) )/2 ) ) THEN
         INFO = -13
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB13AX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 ) THEN
         AB13AX = ZERO
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Allocate N*MAX(N,M,P), N, and N*(N+1)/2 working storage for the
C     matrices S, TAU, and R, respectively. S shares the storage with U.
C
      KU   = 1
      KS   = 1
      MNMP = MAX( N, M, P )
      KTAU = KS + N*MNMP
      KR   = KTAU + N
      KW   = KR
C
C     Copy C in U.
C
      CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), MNMP )
C
C     If DISCR = .FALSE., solve for R the Lyapunov equation
C                                  2
C     A'*(R'*R) + (R'*R)*A + scaleo  * C'*C = 0 .
C
C     If DISCR = .TRUE., solve for R the Lyapunov equation
C                         2
C     A'*(R'*R)*A + scaleo  * C'*C = R'*R .
C
C     Workspace needed:      N*(MAX(N,M,P)+1);
C     Additional workspace:  need   4*N;
C                            prefer larger.
C
      CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), MNMP,
     $             DWORK(KTAU), DWORK(KU), N, SCALEO, DWORK(KW),
     $             LDWORK-KW+1, IERR )
      IF( IERR.NE.0 ) THEN
         INFO = 1
         RETURN
      ENDIF
C
      WRKOPT = DWORK(KW) + DBLE( KW-1 )
C
C     Pack the upper triangle of R in DWORK(KR).
C     Workspace needed:      N*(MAX(N,M,P) + 1) + N*(N+1)/2.
C
      CALL MA02DD( 'Pack', 'Upper', N, DWORK(KU), N, DWORK(KR) )
C
      KW = KR + ( N*( N + 1 ) )/2
C
C     Copy B in S (over U).
C
      CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KS), N )
C
C     If DISCR = .FALSE., solve for S the Lyapunov equation
C                                  2
C     A*(S*S') + (S*S')*A' + scalec *B*B' = 0 .
C
C     If DISCR = .TRUE., solve for S the Lyapunov equation
C                         2
C     A*(S*S')*A' + scalec *B*B' = S*S' .
C
C     Workspace needed:      N*(MAX(N,M,P) + 1) + N*(N+1)/2;
C     Additional workspace:  need   4*N;
C                            prefer larger.
C
      CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KS), N,
     $             DWORK(KTAU), DWORK(KS), N, SCALEC, DWORK(KW),
     $             LDWORK-KW+1, IERR )
C
      WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) )
C
C                             | x x |
C     Compute R*S in the form | 0 x | in S. Note that R is packed.
C
      J = KS
      DO 10 I = 1, N
         CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', I, DWORK(KR),
     $               DWORK(J), 1 )
         J = J + N
   10 CONTINUE
C
C     Compute the singular values of the upper triangular matrix R*S.
C
C     Workspace needed:      N*MAX(N,M,P);
C     Additional workspace:  need   MAX(1,5*N);
C                            prefer larger.
C
      KW = KTAU
      CALL MB03UD( 'NoVectors', 'NoVectors', N, DWORK(KS), N, DWORK, 1,
     $             HSV, DWORK(KW), LDWORK-KW+1, IERR )
      IF( IERR.NE.0 ) THEN
         INFO = 2
         RETURN
      ENDIF
C
C     Scale singular values.
C
      CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 )
      AB13AX = HSV(1)
C
      DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) )
C
      RETURN
C *** Last line of AB13AX ***
      END


!-----subroutine---------------------------------------------g.guidati--
!
     subroutine FLAT
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!
!     scope             determine sigma distribution
!
!.......................................................................
!               declarations
!.......................................................................
      USE TINoiseGeneric
      USE TINoiseDDD
      USE TINoiseInput
      USE TINoiseFLAT
      USE TINoiseRHSin
      USE TIPrecision
      USE TI_Guidati

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4),PARAMETER         :: ncircle=200
INTEGER(4)                   :: nvar,icircle,nok,nbad,ik2
REAL(DbKi)                   :: eps,h1,hmin,kk2, Isumwell, Isum, Itot
REAL(DbKi)                   :: poverall,phi,psumtot,spectrum,yshift
REAL(DbKi)                   :: deta1,rho,phi_pg,dirfac
REAL(DbKi)                   :: btot,ptot,splsumm
REAL(DbKi)                   :: phif(2)

COMPLEX(DbKi)                :: value,dval1,dval2,dval11,dval12,dval22
COMPLEX(DbKi)                :: btrans,btrans1,btrans2, res1,res2
COMPLEX(DbKi)                :: ampli, arg1, arg2, F2, HANK0, HANK1
COMPLEX(DbKi)                :: bbb    (ncircle)
COMPLEX(DbKi)                :: bbb1   (ncircle)
COMPLEX(DbKi)                :: bbb2   (ncircle)
COMPLEX(DbKi)                :: bbbsum (ncircle,-100:100)
COMPLEX(DbKi)                :: bbb1sum(ncircle,-100:100)
COMPLEX(DbKi)                :: bbb2sum(ncircle,-100:100)
COMPLEX(DbKi)                :: pppsum (ncircle,-100:100)
COMPLEX(DbKi)                :: Ivec1,Ivec2,Iflux,dpppp,psumwell

EXTERNAL         :: FPLAT,rkqs

      nvar    =  2
      eps     =  1.0D-07
      h1      =  0.1d0
      hmin    =  0.0d0
      lderiv = .true.
      eta2 = dpath/2

      deta1 = 5000.0 * eta2
      s1      = -deta1
      s2      = +deta1
      phif(1) = 0.0
      phif(2) = 0.0
      call odeint(phif,nvar,s1,s2,eps,h1,hmin,nok,nbad,FPLAT,rkqs)

      ampli = 2. * sqrt(2.*mach_ti/(1.-mach_ti))

!.......................................................................
!
!.......................................................................

!      write(128,*) 'variables = p1,p2,b1,b2,I1,I2'
!      write(128,*) 'ZONE'

      poverall = 0.0
      do icircle=1,ncircle
	phi = pi2 * dble(icircle)/dble(ncircle)
        x1 =  rad * cos(phi)
        x2 =  rad * sin(phi)

	rho = sqrt(x1**2+x2**2)
!	if(phi.ge.-pi.and.phi.le.-pi/2.) phi_pg = -pi-atan(x2/x1)
!	if(phi.gt.-pi/2..and.phi.le.0.0) phi_pg = -atan(x2/x1)
	if(phi.gt.0.0.and.phi.lt.pi/2.) phi_pg =  atan(x2/x1)
	if(phi.ge.pi/2..and.phi.le.pi) phi_pg = pi+atan(x2/x1)
	if(phi.gt.pi.and.phi.le.3.*pi/2.) phi_pg = pi+atan(x2/x1)
	if(phi.gt.3.*pi/2..and.phi.le.2.*pi) phi_pg=pi2+atan(x2/x1)

 	res1 = imag/4.*HANK0((kwave*rho)**2)
 	res2 = -imag/4.*kwave2*HANK1((kwave*rho)**2)

	dirfac = cos(0.5*phi_pg) - mach_ti*sin(phi_pg)*sin(0.5*phi_pg)/(1.-mach_ti*cos(phi_pg))

	btrans  = ampli  * res1 * dirfac
!     >              /sqrt(1.+mach_ti*cos(phi_pg))
        btrans1 = ampli  * (res2 * x1 * dirfac)
!	sin(0.5*phi_pg) -
!     >            res1 * cos(0.5*phi_pg) * 0.5 /(1.+(x2/x1)**2) *
!     >            (-x2/x1**2) )
!     >              /sqrt(1.+mach_ti*cos(phi_pg))
        btrans2 = ampli  * (res2 * x2 * dirfac)
!	sin(0.5*phi_pg) -
!     >            res1 * cos(0.5*phi_pg) * 0.5 /(1.+(x2/x1)**2) *
!     >            (1./x1) )
!     >              /sqrt(1.+mach_ti*cos(phi_pg))
        bbb (icircle) = btrans * exp(-imag*kwave*mach_ti*x1)
        bbb1(icircle) = (btrans1-btrans*imag*kwave*mach_ti)* exp(-imag*kwave*mach_ti*x1)
        bbb2(icircle) = btrans2 * exp(-imag*kwave*mach_ti*x1)

      end do

      do icircle=1,ncircle
        do ik2=nklow,nkhig
          bbbsum  (icircle,ik2) = 0.0
          bbb1sum (icircle,ik2) = 0.0
          bbb2sum (icircle,ik2) = 0.0
          pppsum  (icircle,ik2) = 0.0
        end do
      end do

      psumtot = 0.0
      do ik2 = nklow,nkhig,ndk
        kk2 = strou * dble(ik2) / 10.
        Isumwell = 0.0
        psumwell = 0.0

        if(lspectrum) then
          spectrum = strou**2/(1.+(LLL/chord)**2*(strou**2+kk2**2))**3
        else
          spectrum = 1.0
        endif

        do icircle=1,ncircle
          bbbsum(icircle,ik2)  = bbb(icircle)  * sqrt(spectrum)
          bbb1sum(icircle,ik2) = bbb1(icircle) * sqrt(spectrum)
          bbb2sum(icircle,ik2) = bbb2(icircle) * sqrt(spectrum)
          dpppp = (bbb(icircle)+imag/strou*bbb1(icircle)) * sqrt(spectrum)
          pppsum(icircle,ik2) = pppsum(icircle,ik2) + dpppp

        end do
      end do

      Isum = 0.0
      do icircle=1,ncircle
        Itot = 0.0
        phi = pi2*dble(icircle)/dble(ncircle)
        do ik2 = nklow,nkhig,ndk
          Ivec1 = conjg(bbbsum(icircle,ik2))*(mach_ti**2*bbbsum(icircle,ik2)-imag/strou*bbb1sum(icircle,ik2))
          Ivec2 = conjg(bbbsum(icircle,ik2))*(-imag/strou*bbb2sum(icircle,ik2))
          Iflux = Ivec1*cos(phi)+Ivec2*sin(phi)
          Isum  = Isum + abs(Iflux*pi2/dble(ncircle)*rad)
          btot  = abs(bbbsum(icircle,ik2))
          ptot  = abs(pppsum(icircle,ik2))
          Itot  = Itot + abs(Iflux)*rad
        end do
!        write(128,*) cos(phi)*ptot*sqrt(rad),sin(phi)*ptot*sqrt(rad),cos(phi)*btot*sqrt(rad),sin(phi)*btot*sqrt(rad), &
 !           	     cos(phi)*Itot,sin(phi)*Itot
!        write(128,*) -cos(phi)*abs(bbbsum(icircle,0)),
!     >                sin(phi)*abs(bbbsum(icircle,0)),
!     >               -cos(phi)*abs(bbb1sum(icircle,0)),
!     >                sin(phi)*abs(bbb1sum(icircle,0)),
!     >               -cos(phi)*abs(bbb2sum(icircle,0)),
!     >                sin(phi)*abs(bbb2sum(icircle,0))
      end do

      splsumm = 10.0d0 * log10(Isum)

      SPL_FlatPlate(icount_freq) = splsumm
!      write(28,*) real(freq),real(strou),real(splsumm)
      write(*,*) 'SOUND LEVEL  FP     --->  ',real(freq),real(strou),real(splsumm)
!      call flush(128)
!      call flush(28)

!.......................................................................
!               end of subroutine
!.......................................................................
      return
!***********************************************************************
      end

      subroutine FPLAT(eta1,y,dydx)
      USE TINoiseGeneric
      USE TINoiseFLAT
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

REAL(DbKi)                   :: integ2, theta0, r0, eta1
REAL(DbKi)                   :: y(2), dydx(2)

COMPLEX(DbKi)                   :: fou

      r0 = sqrt(eta1**2+eta2**2)
      if(eta1.le.0.0d0) theta0 = asin(eta2/r0)
      if(eta1.gt.0.0d0) theta0 = pi-asin(eta2/r0)
      fou = exp(imag*eta1*strou) / (imag*strou)
      integ2 = -0.5*r0**(-1.5)*cos(1.5*theta0)
      dydx(1) = dble(integ2*fou)
      dydx(2) = dble(-imag*integ2*fou)
      return
      end