      SUBROUTINE TB03AD( LERI, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, NR, INDEX, PCOEFF, LDPCO1, LDPCO2,
     $                   QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To find a relatively prime left polynomial matrix representation
C     inv(P(s))*Q(s) or right polynomial matrix representation
C     Q(s)*inv(P(s)) with the same transfer matrix T(s) as that of a
C     given state-space representation, i.e.
C
C        inv(P(s))*Q(s) = Q(s)*inv(P(s)) = T(s) = C*inv(s*I-A)*B + D.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LERI    CHARACTER*1
C             Indicates whether the left polynomial matrix
C             representation or the right polynomial matrix
C             representation is required as follows:
C             = 'L':  A left matrix fraction is required;
C             = 'R':  A right matrix fraction is required.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to balance the triplet
C             (A,B,C), before computing a minimal state-space
C             representation, as follows:
C             = 'S':  Perform balancing (scaling);
C             = 'N':  Do not perform balancing.
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 original state dynamics 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/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading NR-by-NR part of this array contains
C             the upper block Hessenberg state dynamics matrix Amin of a
C             minimal realization for the original system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,MAX(M,P))
C             On entry, the leading N-by-M part of this array must
C             contain the original input/state matrix B; the remainder
C             of the leading N-by-MAX(M,P) part is used as internal
C             workspace.
C             On exit, the leading NR-by-M part of this array contains
C             the transformed input/state matrix Bmin.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the original state/output matrix C; the remainder
C             of the leading MAX(M,P)-by-N part is used as internal
C             workspace.
C             On exit, the leading P-by-NR part of this array contains
C             the transformed state/output matrix Cmin.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P))
C             The leading P-by-M part of this array must contain the
C             original direct transmission matrix D; the remainder of
C             the leading MAX(M,P)-by-MAX(M,P) part is used as internal
C             workspace.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,M,P).
C
C     NR      (output) INTEGER
C             The order of the minimal state-space representation
C             (Amin,Bmin,Cmin).
C
C     INDEX   (output) INTEGER array, dimension (P), if LERI = 'L', or
C                                     dimension (M), if LERI = 'R'.
C             If LERI = 'L', INDEX(I), I = 1,2,...,P, contains the
C             maximum degree of the polynomials in the I-th row of the
C             denominator matrix P(s) of the left polynomial matrix
C             representation.
C             These elements are ordered so that
C             INDEX(1) >= INDEX(2) >= ... >= INDEX(P).
C             If LERI = 'R', INDEX(I), I = 1,2,...,M, contains the
C             maximum degree of the polynomials in the I-th column of
C             the denominator matrix P(s) of the right polynomial
C             matrix representation.
C             These elements are ordered so that
C             INDEX(1) >= INDEX(2) >= ... >= INDEX(M).
C
C     PCOEFF  (output) DOUBLE PRECISION array, dimension
C             (LDPCO1,LDPCO2,N+1)
C             If LERI = 'L' then porm = P, otherwise porm = M.
C             The leading porm-by-porm-by-kpcoef part of this array
C             contains the coefficients of the denominator matrix P(s),
C             where kpcoef = MAX(INDEX(I)) + 1.
C             PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
C             of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if
C             LERI = 'L' then iorj = I, otherwise iorj = J.
C             Thus for LERI = 'L', P(s) =
C             diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).
C
C     LDPCO1  INTEGER
C             The leading dimension of array PCOEFF.
C             LDPCO1 >= MAX(1,P), if LERI = 'L';
C             LDPCO1 >= MAX(1,M), if LERI = 'R'.
C
C     LDPCO2  INTEGER
C             The second dimension of array PCOEFF.
C             LDPCO2 >= MAX(1,P), if LERI = 'L';
C             LDPCO2 >= MAX(1,M), if LERI = 'R'.
C
C     QCOEFF  (output) DOUBLE PRECISION array, dimension
C             (LDQCO1,LDQCO2,N+1)
C             If LERI = 'L' then porp = M, otherwise porp = P.
C             If LERI = 'L', the leading porm-by-porp-by-kpcoef part
C             of this array contains the coefficients of the numerator
C             matrix Q(s).
C             If LERI = 'R', the leading porp-by-porm-by-kpcoef part
C             of this array contains the coefficients of the numerator
C             matrix Q(s).
C             QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).
C
C     LDQCO1  INTEGER
C             The leading dimension of array QCOEFF.
C             LDQCO1 >= MAX(1,P),   if LERI = 'L';
C             LDQCO1 >= MAX(1,M,P), if LERI = 'R'.
C
C     LDQCO2  INTEGER
C             The second dimension of array QCOEFF.
C             LDQCO2 >= MAX(1,M),   if LERI = 'L';
C             LDQCO2 >= MAX(1,M,P), if LERI = 'R'.
C
C     VCOEFF  (output) DOUBLE PRECISION array, dimension
C             (LDVCO1,LDVCO2,N+1)
C             The leading porm-by-NR-by-kpcoef part of this array
C             contains the coefficients of the intermediate matrix V(s).
C             VCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).
C
C     LDVCO1  INTEGER
C             The leading dimension of array VCOEFF.
C             LDVCO1 >= MAX(1,P), if LERI = 'L';
C             LDVCO1 >= MAX(1,M), if LERI = 'R'.
C
C     LDVCO2  INTEGER
C             The second dimension of array VCOEFF.  LDVCO2 >= MAX(1,N).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determination when
C             transforming (A, B, C). If the user sets TOL > 0, then
C             the given value of TOL is used as a lower bound for the
C             reciprocal condition number (see the description of the
C             argument RCOND in the SLICOT routine MB03OD);  a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance
C             (determined by the SLICOT routine TB01UD) is used instead.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N+MAX(M,P))
C             On exit, if INFO = 0, the first nonzero elements of
C             IWORK(1:N) return the orders of the diagonal blocks of A.
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, 3*M, 3*P), PM*(PM + 2))
C             where  PM = P, if LERI = 'L';
C                    PM = M, if LERI = 'R'.
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:  if a singular matrix was encountered during the
C                   computation of V(s);
C             = 2:  if a singular matrix was encountered during the
C                   computation of P(s).
C
C     METHOD
C
C     The method for a left matrix fraction will be described here:
C     right matrix fractions are dealt with by constructing a left
C     fraction for the dual of the original system. The first step is to
C     obtain, by means of orthogonal similarity transformations, a
C     minimal state-space representation (Amin,Bmin,Cmin,D) for the
C     original system (A,B,C,D), where Amin is lower block Hessenberg
C     with all its superdiagonal blocks upper triangular and Cmin has
C     all but its first rank(C) columns zero.  The number and dimensions
C     of the blocks of Amin now immediately yield the row degrees of
C     P(s) with P(s) row proper: furthermore, the P-by-NR polynomial
C     matrix V(s) (playing a similar role to S(s) in Wolovich's
C     Structure Theorem) can be calculated a column block at a time, in
C     reverse order, from Amin. P(s) is then found as if it were the
C     O-th column block of V(s) (using Cmin as well as Amin), while
C     Q(s) = (V(s) * Bmin) + (P(s) * D). Finally, a special similarity
C     transformation is used to put Amin in an upper block Hessenberg
C     form.
C
C     REFERENCES
C
C     [1] Williams, T.W.C.
C         An Orthogonal Structure Theorem for Linear Systems.
C         Kingston Polytechnic Control Systems Research Group,
C         Internal Report 82/2, July 1982.
C
C     [2] Patel, R.V.
C         On Computing Matrix Fraction Descriptions and Canonical
C         Forms of Linear Time-Invariant Systems.
C         UMIST Control Systems Centre Report 489, 1980.
C         (Algorithms 1 and 2, extensively modified).
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, March 1998.
C     Supersedes Release 3.0 routine TB01SD.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000.
C
C     KEYWORDS
C
C     Canonical form, coprime matrix fraction, dual system, elementary
C     polynomial operations, Hessenberg form, minimal realization,
C     orthogonal transformation, polynomial matrix, state-space
C     representation, transfer matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         EQUIL, LERI
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2,
     $                  LDQCO1, LDQCO2, LDVCO1, LDVCO2, LDWORK, M, N,
     $                  NR, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           INDEX(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), PCOEFF(LDPCO1,LDPCO2,*),
     $                  QCOEFF(LDQCO1,LDQCO2,*), VCOEFF(LDVCO1,LDVCO2,*)
C     .. Local Scalars ..
      LOGICAL           LEQUIL, LLERIL, LLERIR
      INTEGER           I, IC, IFIRST, INDBLK, INPLUS, IOFF, IRANKC,
     $                  ISTART, ISTOP, ITAU, IZ, JOFF, JWORK, K, KMAX,
     $                  KPCOEF, KPLUS, KWORK, LDWRIC, MAXMP, MPLIM,
     $                  MWORK, NCOL, NCONT, NREFLC, NROW, PWORK, WRKOPT
      DOUBLE PRECISION  MAXRED
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          AB07MD, DGEMM, DGEQRF, DGETRF, DLACPY, DLASET,
     $                  DORMQR, DTRSM, MA02GD, TB01ID, TB01UD, TB01YD,
     $                  TB03AY, TC01OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO   = 0
      LLERIL = LSAME( LERI,  'L' )
      LLERIR = LSAME( LERI,  'R' )
      LEQUIL = LSAME( EQUIL, 'S' )
      MAXMP  = MAX( M, P )
      MPLIM  = MAX( 1, MAXMP )
      IF ( LLERIR ) THEN
C
C        Initialization for right matrix fraction.
C
         PWORK = M
         MWORK = P
      ELSE
C
C        Initialization for left matrix fraction.
C
         PWORK = P
         MWORK = M
      END IF
C
C     Test the input scalar arguments.
C
      IF( .NOT.LLERIL .AND. .NOT.LLERIR ) THEN
         INFO = -1
      ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MPLIM ) THEN
         INFO = -11
      ELSE IF( LDD.LT.MPLIM ) THEN
         INFO = -13
      ELSE IF( LDPCO1.LT.MAX( 1, PWORK ) ) THEN
         INFO = -17
      ELSE IF( LDPCO2.LT.MAX( 1, PWORK ) ) THEN
         INFO = -18
      ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. LLERIR .AND.
     $         LDQCO1.LT.MPLIM ) THEN
         INFO = -20
      ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. LLERIR .AND.
     $         LDQCO2.LT.MPLIM ) THEN
         INFO = -21
      ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN
         INFO = -23
      ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN
         INFO = -24
      ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ),
     $                           PWORK*( PWORK + 2 ) ) ) THEN
         INFO = -28
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB03AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, M, P ).EQ.0 ) THEN
         NR = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( LLERIR ) THEN
C
C        For right matrix fraction, obtain dual system.
C
         CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                INFO )
      END IF
C
C     Obtain minimal realization, in canonical form, for this system.
C     Part of the code in SLICOT routine TB01PD is included in-line
C     here. (TB01PD cannot be directly used.)
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
C     If required, balance the triplet (A,B,C) (default MAXRED).
C     Workspace: need N.
C
      IF ( LEQUIL ) THEN
         MAXRED = ZERO
         CALL TB01ID( 'A', N, MWORK, PWORK, MAXRED, A, LDA, B, LDB, C,
     $                LDC, DWORK, INFO )
      END IF
C
      IZ    = 1
      ITAU  = 1
      JWORK = ITAU + N
C
C     Separate out controllable subsystem (of order NCONT):
C     A <-- Z'*A*Z,  B <-- Z'*B,  C <-- C*Z.
C
C     Workspace: need   N + MAX(N, 3*MWORK, PWORK).
C                prefer larger.
C
      CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC,
     $             NCONT, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL,
     $             IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
      WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1
C
C     Separate out the observable subsystem (of order NR):
C     Form the dual of the subsystem of order NCONT (which is
C     controllable), leaving rest as it is.
C
      CALL AB07MD( 'Z', NCONT, MWORK, PWORK, A, LDA, B, LDB, C, LDC,
     $             DWORK, 1, INFO )
C
C     And separate out the controllable part of this dual subsystem.
C
C     Workspace: need   NCONT + MAX(NCONT, 3*PWORK, MWORK).
C                prefer larger.
C
      CALL TB01UD( 'No Z', NCONT, PWORK, MWORK, A, LDA, B, LDB, C, LDC,
     $             NR, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL,
     $             IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C     Retranspose, giving controllable and observable (i.e. minimal)
C     part of original system.
C
      CALL AB07MD( 'Z', NR, PWORK, MWORK, A, LDA, B, LDB, C, LDC, DWORK,
     $             1, INFO )
C
C     Annihilate the trailing components of IWORK(1:N).
C
      DO 10 I = INDBLK + 1, N
         IWORK(I) = 0
   10 CONTINUE
C
C     Initialize polynomial matrices P(s), Q(s) and V(s) to zero.
C
      DO 20 K = 1, N + 1
         CALL DLASET( 'Full', PWORK, PWORK, ZERO, ZERO, PCOEFF(1,1,K),
     $                LDPCO1 )
         CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, QCOEFF(1,1,K),
     $                LDQCO1 )
         CALL DLASET( 'Full', PWORK, NR, ZERO, ZERO, VCOEFF(1,1,K),
     $                LDVCO1 )
   20 CONTINUE
C
C     Finish initializing V(s), and set up row degrees of P(s).
C
      INPLUS = INDBLK + 1
      ISTART = 1
      JOFF = NR
C
      DO 40 K = 1, INDBLK
         KWORK = INPLUS - K
         KPLUS = KWORK + 1
         ISTOP = IWORK(KWORK)
         JOFF  = JOFF - ISTOP
C
         DO 30 I = ISTART, ISTOP
            INDEX(I) = KWORK
            VCOEFF(I,JOFF+I,KPLUS) = ONE
   30    CONTINUE
C
         ISTART = ISTOP + 1
   40 CONTINUE
C
C     ISTART = IWORK(1)+1 now: if .LE. PWORK, set up final rows of P(s).
C
      DO 50 I = ISTART, PWORK
         INDEX(I) = 0
         PCOEFF(I,I,1) = ONE
   50 CONTINUE
C
C     Triangularize the superdiagonal blocks of Amin.
C
      NROW = IWORK(INDBLK)
      IOFF = NR - NROW
      KMAX = INDBLK - 1
      ITAU = 1
      IFIRST = 0
      IF ( INDBLK.GT.2 ) IFIRST = IOFF - IWORK(KMAX)
C
C     QR decomposition of each superdiagonal block of A in turn
C     (done in reverse order to preserve upper triangular blocks in A).
C
      DO 60 K = 1, KMAX
C
C        Calculate dimensions of new block & its position in A.
C
         KWORK = INDBLK - K
         NCOL = NROW
         NROW = IWORK(KWORK)
         JOFF = IOFF
         IOFF = IOFF - NROW
         NREFLC = MIN( NROW, NCOL )
         JWORK  = ITAU + NREFLC
         IF ( KWORK.GE.2 ) IFIRST = IFIRST - IWORK(KWORK-1)
C
C        Find QR decomposition of this (full rank) block:
C        block = QR.  No pivoting is needed.
C
C        Workspace: need   MIN(NROW,NCOL) + NCOL;
C                   prefer MIN(NROW,NCOL) + NCOL*NB.
C
         CALL DGEQRF( NROW, NCOL, A(IOFF+1,JOFF+1), LDA, DWORK(ITAU),
     $                DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Premultiply appropriate row block of A by Q'.
C
C        Workspace: need   MIN(NROW,NCOL) + JOFF;
C                   prefer MIN(NROW,NCOL) + JOFF*NB.
C
         CALL DORMQR( 'Left', 'Transpose', NROW, JOFF, NREFLC,
     $                A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), A(IOFF+1,1),
     $                LDA, DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Premultiply appropriate row block of B by Q' also.
C
C        Workspace: need   MIN(NROW,NCOL) + MWORK;
C                   prefer MIN(NROW,NCOL) + MWORK*NB.
C
         CALL DORMQR( 'Left', 'Transpose', NROW, MWORK, NREFLC,
     $                A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), B(IOFF+1,1),
     $                LDB, DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        And postmultiply the non-zero part of appropriate column
C        block of A by Q.
C
C        Workspace: need   MIN(NROW,NCOL) + NR;
C                   prefer MIN(NROW,NCOL) + NR*NB.
C
         CALL DORMQR( 'Right', 'No Transpose', NR-IFIRST, NROW, NREFLC,
     $                A(IOFF+1,JOFF+1), LDA, DWORK(ITAU),
     $                A(IFIRST+1,IOFF+1), LDA, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Annihilate the lower triangular part of the block in A.
C
         IF ( K.NE.KMAX .AND. NROW.GT.1 )
     $      CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO,
     $                   A(IOFF+2,JOFF+1), LDA )
C
   60 CONTINUE
C
C     Finally: postmultiply non-zero columns of C by Q (K = KMAX).
C
C     Workspace: need   MIN(NROW,NCOL) + PWORK;
C                prefer MIN(NROW,NCOL) + PWORK*NB.
C
      CALL DORMQR( 'Right', 'No Transpose', PWORK, NROW, NREFLC,
     $             A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), C, LDC,
     $             DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C     Annihilate the lower triangular part of the block in A.
C
      IF ( NROW.GT.1 )
     $   CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO,
     $                A(IOFF+2,JOFF+1), LDA )
C
C     Calculate the (PWORK x NR) polynomial matrix V(s) ...
C
      CALL TB03AY( NR, A, LDA, INDBLK, IWORK, VCOEFF, LDVCO1, LDVCO2,
     $             PCOEFF, LDPCO1, LDPCO2, INFO)
C
      IF ( INFO.NE.0 ) THEN
         INFO = 1
         RETURN
      ELSE
C
C        And then use this matrix to calculate P(s): first store
C        C1 from C.
C
         IC = 1
         IRANKC = IWORK(1)
         LDWRIC = MAX( 1, PWORK )
         CALL DLACPY( 'Full', PWORK, IRANKC, C, LDC, DWORK(IC), LDWRIC )
C
         IF ( IRANKC.LT.PWORK ) THEN
C
C           rank(C) .LT. PWORK: obtain QR decomposition of C1,
C           giving R and Q.
C
C           Workspace: need   PWORK*IRANKC + 2*IRANKC;
C                      prefer PWORK*IRANKC +   IRANKC + IRANKC*NB.
C
            ITAU  = IC + LDWRIC*IRANKC
            JWORK = ITAU + IRANKC
C
            CALL DGEQRF( PWORK, IRANKC, DWORK(IC), LDWRIC, DWORK(ITAU),
     $                   DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C           First IRANKC rows of Pbar(s) are given by Wbar(s) * inv(R).
C           Check for zero diagonal elements of R.
C
            DO 70 I = 1, IRANKC
               IF ( DWORK(IC+(I-1)*LDWRIC+I-1).EQ.ZERO ) THEN
C
C                 Error return.
C
                  INFO = 2
                  RETURN
               END IF
   70       CONTINUE
C
            NROW = IRANKC
C
            DO 80 K = 1, INPLUS
               CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit',
     $                     NROW, IRANKC, ONE, DWORK(IC), LDWRIC,
     $                     PCOEFF(1,1,K), LDPCO1 )
               NROW = IWORK(K)
   80       CONTINUE
C
C           P(s) itself is now given by Pbar(s) * Q'.
C
            NROW = PWORK
C
            DO 90 K = 1, INPLUS
C
C              Workspace: need   PWORK*IRANKC + IRANKC + NROW;
C                         prefer PWORK*IRANKC + IRANKC + NROW*NB.
C
               CALL DORMQR( 'Right', 'Transpose', NROW, PWORK, IRANKC,
     $                      DWORK(IC), LDWRIC, DWORK(ITAU),
     $                      PCOEFF(1,1,K), LDPCO1, DWORK(JWORK),
     $                      LDWORK-JWORK+1, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
               NROW = IWORK(K)
   90       CONTINUE
C
         ELSE
C
C           Special case rank(C) = PWORK, full:
C           no QR decomposition (P(s)=Wbar(s)*inv(C1)).
C
            CALL DGETRF( PWORK, PWORK, DWORK(IC), LDWRIC, IWORK(N+1),
     $                   INFO )
C
            IF ( INFO.NE.0 ) THEN
C
C              Error return.
C
               INFO = 2
               RETURN
            ELSE
C
               NROW = IRANKC
C
C              Workspace: need   PWORK*IRANKC + N.
C
               DO 100 K = 1, INPLUS
                  CALL DTRSM( 'Right', 'Upper', 'No Transpose',
     $                        'Non-unit', NROW, PWORK, ONE, DWORK(IC),
     $                        LDWRIC, PCOEFF(1,1,K), LDPCO1 )
                  CALL DTRSM( 'Right', 'Lower', 'No Transpose', 'Unit',
     $                        NROW, PWORK, ONE, DWORK(IC), LDWRIC,
     $                        PCOEFF(1,1,K), LDPCO1 )
                  CALL MA02GD( NROW, PCOEFF(1,1,K), LDPCO1, 1, PWORK,
     $                         IWORK(N+1), -1 )
                  NROW = IWORK(K)
  100          CONTINUE
            END IF
         END IF
C
C        Finally, Q(s) = V(s) * B + P(s) * D can now be evaluated.
C
         NROW = PWORK
C
         DO 110 K = 1, INPLUS
            CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK,
     $                  NR, ONE, VCOEFF(1,1,K), LDVCO1, B, LDB, ZERO,
     $                  QCOEFF(1,1,K), LDQCO1 )
            CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK,
     $                  PWORK, ONE, PCOEFF(1,1,K), LDPCO1, D, LDD, ONE,
     $                  QCOEFF(1,1,K), LDQCO1 )
            NROW = IWORK(K)
  110    CONTINUE
C
      END IF
C
      IF ( LLERIR ) THEN
C
C        For right matrix fraction, return to original (dual of dual)
C        system.
C
         CALL AB07MD( 'Z', NR, MWORK, PWORK, A, LDA, B, LDB, C, LDC,
     $                DWORK, 1, INFO )
C
C        Also, obtain the dual of the polynomial matrix representation.
C
         KPCOEF = 0
C
         DO 120 I = 1, PWORK
            KPCOEF = MAX( KPCOEF, INDEX(I) )
  120    CONTINUE
C
         KPCOEF = KPCOEF + 1
         CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1,
     $                LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO )
      ELSE
C
C        Reorder the rows and columns of the system, to get an upper
C        block Hessenberg matrix A of the minimal system.
C
         CALL TB01YD( NR, M, P, A, LDA, B, LDB, C, LDC, INFO )
      END IF
C
C     Set optimal workspace dimension.
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of TB03AD ***
      END


      double precision function sub_fphalf(etaf)

c       This program calculates the definite integral F_(1/2)(etaf).
c
c       etaf = -energy relative to the Fermi level, in units of eV*q/kT

      implicit double precision (a-h,o-z)

      dimension a1(12), b1(12), a2(12), b2(12)
      parameter(expmax=69)
      expcap(x)=exp(max(min(x,expmax),-expmax))

      data m1,k1,m2,k2/7,7,10,11/
      data (a1(i),i=1,8) /5.75834152995465d+06,
     &                      1.30964880355883d+07,
     &                      1.07608632249013d+07,
     &                      3.93536421893014d+06,
     &                      6.42493233715640d+05,
     &                      4.16031909245777d+04,
     &                      7.77238678539648d+02,
     &                      1.00000000000000d+00/
      data (b1(i),i=1,8) /6.49759261942269d+06,
     &                      1.70750501625775d+07,
     &                      1.69288134856160d+07,
     &                      7.95192647756086d+06,
     &                      1.83167424554505d+06,
     &                      1.95155948326832d+05,
     &                      8.17922106644547d+03,
     &                      9.02129136642157d+01/
      data (a2(i),i=1,11)/4.85378381173415d-14,
     &                      1.64429113030738d-11,
     &                      3.76794942277806d-09,
     &                      4.69233883900644d-07,
     &                      3.40679845803144d-05,
     &                      1.32212995937796d-03,
     &                      2.60768398973913d-02,
     &                      2.48653216266227d-01,
     &                      1.08037861921488d+00,
     &                      1.91247528779676d+00,
     &                      1.00000000000000d+00/
      data (b2(i),i=1,12)/7.28067571760518d-14,
     &                      2.45745452167585d-11,
     &                      5.62152894375277d-09,
     &                      6.96888634549649d-07,
     &                      5.02360015186394d-05,
     &                      1.92040136756592d-03,
     &                      3.66887808002874d-02,
     &                      3.24095226486468d-01,
     &                      1.16434871200131d+00,
     &                      1.34981244060549d+00,
     &                      2.01311836975930d-01,
     &                     -2.14562434782759d-02/

      if (etaf .lt. 2) then
         x=expcap(etaf)
         rn=x+a1(m1)
         do i=m1-1,1,-1
            rn=rn*x+a1(i)
         end do
         den=b1(k1+1)
         do i=k1,1,-1
            den=den*x+b1(i)
         end do
         sub_fphalf=x*rn/den
      else
         x=1/(etaf*etaf)
         rn=x+a2(m2)
         do i=m2-1,1,-1
            rn=rn*x+a2(i)
         end do
         den=b2(k2+1)
         do i=k2,1,-1
            den=den*x+b2(i)
         end do
         sub_fphalf=etaf*sqrt(etaf)*rn/den
      endif
      return
      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc


      subroutine qlbox12(Y,musq,Ires)
      implicit none
C I^{\{D=4-2 \epsilon\}}_4(0,m_3^2,\pt^2,\pq^2;s_{12},s_{23};0,0,m_3^2,m_4^2)

c[                               m3sq - s12           m4sq - p4sq      ]
c[      0           0            ----------           -----------      ]
c[                                   2                     2           ]
c[                                                                     ]
c[                                                     m4sq - s23      ]
c[      0           0                0                 ----------      ]
c[                                                         2           ]
c[                                                                     ]
c[ m3sq - s12                                     - p3sq + m4sq + m3sq ]
c[ ----------       0               m3sq          -------------------- ]
c[     2                                                   2           ]
c[                                                                     ]
c[ m4sq - p4sq  m4sq - s23  - p3sq + m4sq + m3sq                       ]
c[ -----------  ----------  --------------------          m4sq         ]
c[      2           2                2                                 ]
      include 'qlconstants.f'
      integer iep
      logical qlzero
      double precision Y(4,4),p3sq,m3sq,m4sq,musq,
     . sibar,tabar,m4sqbar,fac,mean,
     . x43p,x43pm1,x43m,x43mm1,rat1,ieps1,ieps2
      double complex Ires(-2:0),qllnrat,dilog(3),zrat1,
     . ln43m,ln43p,cln,wlogtmu,wlogsmu,wlog4mu,wlog,qlLi2omrat,
     . qlLi2omx2,rat2p,rat2m,root,ga43p,ga43pm1,ga43m,ga43mm1

      m3sq=Y(3,3)
      m4sq=Y(4,4)
      sibar=2d0*Y(1,3)
      tabar=2d0*Y(2,4)
      m4sqbar=2d0*Y(1,4)
      p3sq=-(2d0*Y(3,4)-Y(3,3)-Y(4,4))

      mean=sqrt(musq*m3sq)
      fac=sibar*tabar
      wlogsmu=qllnrat(sibar,mean)
      wlogtmu=qllnrat(tabar,mean)
      wlog4mu=qllnrat(m4sqbar,mean)
      wlog=wlogsmu+wlogtmu-wlog4mu

C---- evaluate gamma's for the case p3sq=0
      if (qlzero(p3sq)) then
      root=cone
      x43p=-1d0
      x43pm1=-1d0
      x43m=m3sq
      x43mm1=m4sq
      else
      root=dcmplx((p3sq+m3sq-m4sq)**2-4d0*m3sq*p3sq)
      root=sqrt(root)
      ga43p=  dcmplx(+p3sq+m3sq-m4sq)+root
      ga43pm1=dcmplx(-p3sq+m3sq-m4sq)+root
      ga43m=  dcmplx(+p3sq+m3sq-m4sq)-root
      ga43mm1=dcmplx(-p3sq+m3sq-m4sq)-root

      x43p=-dreal(ga43p)
      x43pm1=-dreal(ga43pm1)
      x43m=dreal(ga43m)
      x43mm1=dreal(ga43mm1)
      endif

      dilog(1)=qlLi2omrat(m4sqbar,tabar)

C----deal with real roots
      if (qlzero(dimag(root))) then
      ln43p=qllnrat(x43p,x43pm1)
      ln43m=qllnrat(x43m,x43mm1)
      dilog(2)=qlLi2omx2(m4sqbar,x43p,sibar,x43pm1)
      dilog(3)=qlLi2omx2(m4sqbar,x43m,sibar,x43mm1)
      else
      call qlratreal(m4sqbar,sibar,rat1,ieps1)
      call qlratgam(rat2p,rat2m,ieps2,p3sq,m4sq,m3sq)
      zrat1=dcmplx(rat1)
      ln43p=cln(rat2p,ieps2)
      ln43m=cln(rat2m,ieps2)

      call qlspencer(zrat1,rat2p,ieps1,ieps2,dilog(2))
      call qlspencer(zrat1,rat2m,ieps1,ieps2,dilog(3))

      endif
      Ires(-2)=dcmplx(0.5d0)
      Ires(-1)=-wlog
      Ires( 0)=-dcmplx(pisq/12d0)
     . +2d0*wlogsmu*wlogtmu-wlog4mu**2
     . +(wlog4mu-wlogsmu)*log(m4sq/m3sq)-0.5d0*(ln43p**2+ln43m**2)
     . -2d0*dilog(1)-dilog(2)-dilog(3)

      do iep=-2,0
      Ires(iep)=Ires(iep)/dcmplx(fac)
      enddo
      return
      end


    subroutine calcjacob
    use setup2d
    implicit none
    include 'mpif.h'

    integer :: is,js,k, ic,ifp,jfp
    integer, dimension(4) :: IC2V
    double precision :: xpsi,ypsi,xeta,yeta

    do ic=1,NCELL
        do k =1,4
            IC2V(k)=IVCELL(ic,k)
        end do

        ! loop to find the |J| at the solution points
        ! also compute the volume of cell
        do js=1,N
            do is=1,N
                xpsi = 0.d0
                xeta = 0.d0
                ypsi = 0.d0
                yeta = 0.d0
                do k=1,4
                xpsi = xpsi + dmdxs(k,1,is,js) * XV(IC2V(k))
                ypsi = ypsi + dmdxs(k,1,is,js) * YV(IC2V(k))
                xeta = xeta + dmdxs(k,2,is,js) * XV(IC2V(k))
                yeta = yeta + dmdxs(k,2,is,js) * YV(IC2V(k))
                end do
                Jac(is,js,ic) = xpsi*yeta - xeta*ypsi
            end do
        end do

        ! loop to find the S vector at the flux points (family 1)

        do jfp=1,N
            do ifp=1,N+1
                xpsi = 0.d0
                xeta = 0.d0
                ypsi = 0.d0
                yeta = 0.d0
                do k=1,4
                xpsi = xpsi + dmdxf1(k,1,ifp,jfp) * XV(IC2V(k))
                ypsi = ypsi + dmdxf1(k,1,ifp,jfp) * YV(IC2V(k))
                xeta = xeta + dmdxf1(k,2,ifp,jfp) * XV(IC2V(k))
                yeta = yeta + dmdxf1(k,2,ifp,jfp) * YV(IC2V(k))
                end do
                ! S are the elements of the inverse jacobian
                S1(1,1,ifp,jfp,ic) = yeta
                S1(1,2,ifp,jfp,ic) = -xeta

                S1(2,1,ifp,jfp,ic) = -ypsi
                S1(2,2,ifp,jfp,ic) = xpsi
            end do
        end do

        ! loop to find the S vector at the flux points (family 2)

        do jfp=1,N+1
            do ifp=1,N

                xpsi = 0.d0
                xeta = 0.d0
                ypsi = 0.d0
                yeta = 0.d0

                do k=1,4
                xpsi = xpsi + dmdxf2(k,1,ifp,jfp) * XV(IC2V(k))
                ypsi = ypsi + dmdxf2(k,1,ifp,jfp) * YV(IC2V(k))
                xeta = xeta + dmdxf2(k,2,ifp,jfp) * XV(IC2V(k))
                yeta = yeta + dmdxf2(k,2,ifp,jfp) * YV(IC2V(k))
                end do

                ! S are the elements of the inverse jacobian

                S2(1,1,ifp,jfp,ic) = yeta
                S2(1,2,ifp,jfp,ic) = -xeta

                S2(2,1,ifp,jfp,ic) = -ypsi
                S2(2,2,ifp,jfp,ic) = xpsi

            end do
        end do
    end do

    end subroutine calcjacob


      subroutine fillpt(ptop,pl,p,ptrop,tg,tstrat,tl,plev,tlev,pmid,
     *                  tmid)
C     GCM 2.0  VERSION 1.1  JAN 2003
C  Put the T & P GCM arrays onto the NRC grid:  PLEV, PMID, TLEV, TMID
C  Sept 2002
C
C  PMID and TMID are the pressure and temperature at the GCM layer
C  mid-points.  PLEV and TLEV are the pressures and temperatures at
C  the GCM layer boundaries, i.e. at GCM levels.

      implicit none

      include "grid.h"

      integer K, L
      real*8 PTOP, PL(L_LEVELS), PLEV(L_LEVELS+1), PMID(L_LEVELS)
      real*8 TSTRAT, TL(L_LEVELS), TLEV(L_LEVELS+1), TMID(L_LEVELS)
      real*8 P, PTROP, TG

C======================================================================C

C  Fill the new radiation code variables.
C  PLEV and TLEV are the pressure and tempertures on a vertical grid
C  that the new radiation code uses.

      PLEV(1) = PTOP*1.0E-5
      PLEV(2) = PTOP
      DO K=3,L_LEVELS
        PLEV(K) = PL(K)
      END DO
      PLEV(L_LEVELS+1) = PLEV(L_LEVELS)

      DO K=1,3
        TLEV(K) = TSTRAT
      END DO

      DO K=4,L_LEVELS-1,2
        TLEV(K) = TL(K)
      END DO

      DO K=5,L_LEVELS-2,2
        TLEV(K) = TLEV(K+1) + (TLEV(K-1)-TLEV(K+1))*
     *            DLOG(PLEV(K)/PLEV(K+1))/
     *            DLOG(PLEV(K-1)/PLEV(K+1))
      END DO

C  Temperature of the bottom level is the ground temperature.

      IF(TG.GT.0.0) then
        TLEV(L_LEVELS) = TG
      ELSE
        TLEV(L_LEVELS) =  3182.48/(23.3494-LOG(P+PTROP))
      ENDIF

C  Fill the PMID & TMID arrays used by OPTCI and OPTCV subroutines.
C  TMID and PMID used to get the index for CO2 k-coefficient interpolation.

      TMID(1) = TLEV(2)
      TMID(2) = TLEV(2)
      PMID(1) = PLEV(1)
      PMID(2) = PLEV(2)

      DO L=1,L_LAYERS
        TMID(2*L+1) = TLEV(2*L+1)
        TMID(2*L+2) = TLEV(2*L+1)
        PMID(2*L+1) = PLEV(2*L+1)
        PMID(2*L+2) = PLEV(2*L+1)
      END DO

      TMID(L_LEVELS) = TLEV(L_LEVELS)
      PMID(L_LEVELS) = PLEV(L_LEVELS)

      RETURN
      END


!==========================================================================
elemental function gsw_sigma1 (sa, ct)
!==========================================================================
!
!  Calculates potential density anomaly with reference pressure of 1000 dbar,
!  this being this particular potential density minus 1000 kg/m^3.  This
!  function has inputs of Absolute Salinity and Conservative Temperature.
!
! sa     : Absolute Salinity                               [g/kg]
! ct     : Conservative Temperature                        [deg C]
!
! gsw_sigma1  : potential density anomaly with reference pressure of 1000
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_rho

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct

real (r8) :: gsw_sigma1

gsw_sigma1 = gsw_rho(sa,ct,1e3_r8) - 1e3_r8

return
end function

!--------------------------------------------------------------------------


*DECK CBETA
      COMPLEX FUNCTION CBETA (A, B)
C***BEGIN PROLOGUE  CBETA
C***PURPOSE  Compute the complete Beta function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7B
C***TYPE      COMPLEX (BETA-S, DBETA-D, CBETA-C)
C***KEYWORDS  COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CBETA computes the complete beta function of complex parameters A
C and B.
C Input Parameters:
C       A   complex and the real part of A positive
C       B   complex and the real part of B positive
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CGAMMA, CLBETA, GAMLIM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890206  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  CBETA
      COMPLEX A, B, CGAMMA, CLBETA
      EXTERNAL CGAMMA
      SAVE XMAX
      DATA XMAX / 0.0 /
C***FIRST EXECUTABLE STATEMENT  CBETA
      IF (XMAX.EQ.0.0) THEN
         CALL GAMLIM (XMIN, XMAXT)
         XMAX = XMAXT
      ENDIF
C
      IF (REAL(A) .LE. 0.0 .OR. REAL(B) .LE. 0.0) CALL XERMSG ('SLATEC',
     +   'CBETA', 'REAL PART OF BOTH ARGUMENTS MUST BE GT 0', 1, 2)
C
      IF (REAL(A)+REAL(B).LT.XMAX) CBETA = CGAMMA(A) * (CGAMMA(B)/
     1  CGAMMA(A+B) )
      IF (REAL(A)+REAL(B).LT.XMAX) RETURN
C
      CBETA = EXP (CLBETA(A, B))
C
      RETURN
      END


*DECK SSICS
      SUBROUTINE SSICS (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D,
     +   R, IWARN)
C***BEGIN PROLOGUE  SSICS
C***PURPOSE  Incompl. Cholesky Decomposition Preconditioner SLAP Set Up.
C            Routine to generate the Incomplete Cholesky decomposition,
C            L*D*L-trans, of a symmetric positive definite matrix, A,
C            which is stored in SLAP Column format.  The unit lower
C            triangular matrix L is stored by rows, and the inverse of
C            the diagonal matrix D is stored.
C***LIBRARY   SLATEC (SLAP)
C***CATEGORY  D2E
C***TYPE      SINGLE PRECISION (SSICS-S, DSICS-D)
C***KEYWORDS  INCOMPLETE CHOLESKY FACTORIZATION,
C             ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP SPARSE
C***AUTHOR  Greenbaum, Anne, (Courant Institute)
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-60
C             Livermore, CA 94550 (510) 423-3141
C             seager@llnl.gov
C***DESCRIPTION
C
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM
C     INTEGER NEL, IEL(NEL), JEL(NEL), IWARN
C     REAL    A(NELT), EL(NEL), D(N), R(N)
C
C     CALL SSICS( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, R,
C    $    IWARN )
C
C *Arguments:
C N      :IN       Integer.
C         Order of the Matrix.
C NELT   :IN       Integer.
C         Number of elements in arrays IA, JA, and A.
C IA     :INOUT    Integer IA(NELT).
C JA     :INOUT    Integer JA(NELT).
C A      :INOUT    Real A(NELT).
C         These arrays should hold the matrix A in the SLAP Column
C         format.  See "Description", below.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all non-zero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the lower
C         triangle of the matrix is stored.
C NEL    :OUT      Integer.
C         Number of non-zeros in the lower triangle of A.   Also
C         corresponds to the length of the IEL, JEL, EL arrays.
C IEL    :OUT      Integer IEL(NEL).
C JEL    :OUT      Integer JEL(NEL).
C EL     :OUT      Real     EL(NEL).
C         IEL, JEL, EL contain the unit lower triangular factor  of the
C         incomplete decomposition   of the A  matrix  stored  in  SLAP
C         Row format.   The Diagonal of   ones   *IS*   stored.     See
C         "Description", below for more details about the SLAP Row fmt.
C D      :OUT      Real D(N)
C         Upon return this array holds D(I) = 1./DIAG(A).
C R      :WORK     Real R(N).
C         Temporary real workspace needed for the factorization.
C IWARN  :OUT      Integer.
C         This is a warning variable and is zero if the IC factoriza-
C         tion goes well.  It is set to the row index corresponding to
C         the last zero pivot found.  See "Description", below.
C
C *Description
C       =================== S L A P Column format ==================
C       This routine  requires that  the matrix A  be stored in  the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except for  the diagonal entry, which
C       must appear first in each  "column")  and are stored  in the
C       real array A.  In other words, for each column in the matrix
C       put the diagonal entry in A.  Then put in the other non-zero
C       elements going down   the  column (except  the diagonal)  in
C       order.  The IA array holds the row  index for each non-zero.
C       The JA array holds the offsets into the IA, A arrays for the
C       beginning of   each    column.    That  is,    IA(JA(ICOL)),
C       A(JA(ICOL)) points to the beginning of the ICOL-th column in
C       IA and  A.  IA(JA(ICOL+1)-1),  A(JA(ICOL+1)-1) points to the
C       end  of   the ICOL-th  column.  Note   that  we  always have
C       JA(N+1) = NELT+1, where  N  is the number of columns in  the
C       matrix and  NELT   is the number of non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C           5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C                              1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       ==================== S L A P Row format ====================
C
C       This routine requires  that the matrix A  be  stored  in the
C       SLAP  Row format.   In this format  the non-zeros are stored
C       counting across  rows (except for the diagonal  entry, which
C       must appear first in each "row") and  are stored in the real
C       array A.  In other words, for each row in the matrix put the
C       diagonal entry in  A.   Then   put  in the   other  non-zero
C       elements   going  across the  row (except   the diagonal) in
C       order.   The  JA array  holds   the column   index for  each
C       non-zero.   The IA  array holds the  offsets into  the JA, A
C       arrays  for   the   beginning  of   each  row.   That    is,
C       JA(IA(IROW)),  A(IA(IROW)) points  to  the beginning  of the
C       IROW-th row in JA and A.   JA(IA(IROW+1)-1), A(IA(IROW+1)-1)
C       points to the  end of the  IROW-th row.  Note that we always
C       have IA(N+1) =  NELT+1, where  N  is  the number of rows  in
C       the matrix  and NELT  is the  number   of  non-zeros in  the
C       matrix.
C
C       Here is an example of the SLAP Row storage format for a  5x5
C       Matrix (in the A and JA arrays '|' denotes the end of a row):
C
C           5x5 Matrix         SLAP Row format for 5x5 matrix on left.
C                              1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 12 15 | 22 21 | 33 35 | 44 | 55 51 53
C       |21 22  0  0  0|  JA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  IA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       With the SLAP  format some  of  the   "inner  loops" of this
C       routine should vectorize  on  machines with hardware support
C       for vector   gather/scatter  operations.  Your compiler  may
C       require a compiler directive to  convince it that  there are
C       no  implicit  vector  dependencies.  Compiler directives for
C       the Alliant    FX/Fortran and CRI   CFT/CFT77 compilers  are
C       supplied with the standard SLAP distribution.
C
C       The IC factorization does not always exist for SPD matrices.
C       In the event that a zero pivot is found it is set  to be 1.0
C       and the factorization proceeds.   The integer variable IWARN
C       is set to the last row where the Diagonal was fudged.  This
C       eventuality hardly ever occurs in practice.
C
C***SEE ALSO  SCG, SSICCG
C***REFERENCES  1. Gene Golub and Charles Van Loan, Matrix Computations,
C                  Johns Hopkins University Press, Baltimore, Maryland,
C                  1983.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   871119  DATE WRITTEN
C   881213  Previous REVISION DATE
C   890915  Made changes requested at July 1989 CML Meeting.  (MKS)
C   890922  Numerous changes to prologue to make closer to SLATEC
C           standard.  (FNF)
C   890929  Numerous changes to reduce SP/DP differences.  (FNF)
C   900805  Changed XERRWV calls to calls to XERMSG.  (RWC)
C   910411  Prologue converted to Version 4.0 format.  (BAB)
C   920511  Added complete declaration section.  (WRB)
C   920929  Corrected format of reference.  (FNF)
C   930701  Updated CATEGORY section.  (FNF, WRB)
C***END PROLOGUE  SSICS
C     .. Scalar Arguments ..
      INTEGER ISYM, IWARN, N, NEL, NELT
C     .. Array Arguments ..
      REAL A(NELT), D(N), EL(NEL), R(N)
      INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL)
C     .. Local Scalars ..
      REAL ELTMP
      INTEGER I, IBGN, IC, ICBGN, ICEND, ICOL, IEND, IR, IRBGN, IREND,
     +        IROW, IRR, J, JBGN, JELTMP, JEND
      CHARACTER XERN1*8
C     .. External Subroutines ..
      EXTERNAL XERMSG
C***FIRST EXECUTABLE STATEMENT  SSICS
C
C         Set the lower triangle in IEL, JEL, EL
C
      IWARN = 0
C
C         All matrix elements stored in IA, JA, A.  Pick out the lower
C         triangle (making sure that the Diagonal of EL is one) and
C         store by rows.
C
      NEL = 1
      IEL(1) = 1
      JEL(1) = 1
      EL(1) = 1
      D(1) = A(1)
CVD$R NOCONCUR
      DO 30 IROW = 2, N
C         Put in the Diagonal.
         NEL = NEL + 1
         IEL(IROW) = NEL
         JEL(NEL) = IROW
         EL(NEL) = 1
         D(IROW) = A(JA(IROW))
C
C         Look in all the lower triangle columns for a matching row.
C         Since the matrix is symmetric, we can look across the
C         ITOW-th row by looking down the IROW-th column (if it is
C         stored ISYM=0)...
         IF( ISYM.EQ.0 ) THEN
            ICBGN = JA(IROW)
            ICEND = JA(IROW+1)-1
         ELSE
            ICBGN = 1
            ICEND = IROW-1
         ENDIF
         DO 20 IC = ICBGN, ICEND
            IF( ISYM.EQ.0 ) THEN
               ICOL = IA(IC)
               IF( ICOL.GE.IROW ) GOTO 20
            ELSE
               ICOL = IC
            ENDIF
            JBGN = JA(ICOL)+1
            JEND = JA(ICOL+1)-1
            IF( JBGN.LE.JEND .AND. IA(JEND).GE.IROW ) THEN
CVD$ NOVECTOR
               DO 10 J = JBGN, JEND
                  IF( IA(J).EQ.IROW ) THEN
                     NEL = NEL + 1
                     JEL(NEL) = ICOL
                     EL(NEL)  = A(J)
                     GOTO 20
                  ENDIF
 10            CONTINUE
            ENDIF
 20      CONTINUE
 30   CONTINUE
      IEL(N+1) = NEL+1
C
C         Sort ROWS of lower triangle into descending order (count out
C         along rows out from Diagonal).
C
      DO 60 IROW = 2, N
         IBGN = IEL(IROW)+1
         IEND = IEL(IROW+1)-1
         IF( IBGN.LT.IEND ) THEN
            DO 50 I = IBGN, IEND-1
CVD$ NOVECTOR
               DO 40 J = I+1, IEND
                  IF( JEL(I).GT.JEL(J) ) THEN
                     JELTMP = JEL(J)
                     JEL(J) = JEL(I)
                     JEL(I) = JELTMP
                     ELTMP = EL(J)
                     EL(J) = EL(I)
                     EL(I) = ELTMP
                  ENDIF
 40            CONTINUE
 50         CONTINUE
         ENDIF
 60   CONTINUE
C
C         Perform the Incomplete Cholesky decomposition by looping
C         over the rows.
C         Scale the first column.  Use the structure of A to pick out
C         the rows with something in column 1.
C
      IRBGN = JA(1)+1
      IREND = JA(2)-1
      DO 65 IRR = IRBGN, IREND
         IR = IA(IRR)
C         Find the index into EL for EL(1,IR).
C         Hint: it's the second entry.
         I = IEL(IR)+1
         EL(I) = EL(I)/D(1)
 65   CONTINUE
C
      DO 110 IROW = 2, N
C
C         Update the IROW-th diagonal.
C
         DO 66 I = 1, IROW-1
            R(I) = 0
 66      CONTINUE
         IBGN = IEL(IROW)+1
         IEND = IEL(IROW+1)-1
         IF( IBGN.LE.IEND ) THEN
CLLL. OPTION ASSERT (NOHAZARD)
CDIR$ IVDEP
CVD$ NODEPCHK
            DO 70 I = IBGN, IEND
               R(JEL(I)) = EL(I)*D(JEL(I))
               D(IROW) = D(IROW) - EL(I)*R(JEL(I))
 70         CONTINUE
C
C         Check to see if we have a problem with the diagonal.
C
            IF( D(IROW).LE.0.0E0 ) THEN
               IF( IWARN.EQ.0 ) IWARN = IROW
               D(IROW) = 1
            ENDIF
         ENDIF
C
C         Update each EL(IROW+1:N,IROW), if there are any.
C         Use the structure of A to determine the Non-zero elements
C         of the IROW-th column of EL.
C
         IRBGN = JA(IROW)
         IREND = JA(IROW+1)-1
         DO 100 IRR = IRBGN, IREND
            IR = IA(IRR)
            IF( IR.LE.IROW ) GOTO 100
C         Find the index into EL for EL(IR,IROW)
            IBGN = IEL(IR)+1
            IEND = IEL(IR+1)-1
            IF( JEL(IBGN).GT.IROW ) GOTO 100
            DO 90 I = IBGN, IEND
               IF( JEL(I).EQ.IROW ) THEN
                  ICEND = IEND
 91               IF( JEL(ICEND).GE.IROW ) THEN
                     ICEND = ICEND - 1
                     GOTO 91
                  ENDIF
C         Sum up the EL(IR,1:IROW-1)*R(1:IROW-1) contributions.
CLLL. OPTION ASSERT (NOHAZARD)
CDIR$ IVDEP
CVD$ NODEPCHK
                  DO 80 IC = IBGN, ICEND
                     EL(I) = EL(I) - EL(IC)*R(JEL(IC))
 80               CONTINUE
                  EL(I) = EL(I)/D(IROW)
                  GOTO 100
               ENDIF
 90         CONTINUE
C
C         If we get here, we have real problems...
            WRITE (XERN1, '(I8)') IROW
            CALL XERMSG ('SLATEC', 'SSICS',
     $         'A and EL data structure mismatch in row '// XERN1, 1, 2)
 100     CONTINUE
 110  CONTINUE
C
C         Replace diagonals by their inverses.
C
CVD$ CONCUR
      DO 120 I =1, N
         D(I) = 1.0E0/D(I)
 120  CONTINUE
      RETURN
C------------- LAST LINE OF SSICS FOLLOWS ----------------------------
      END


FUNCTION gasdev(idum)
  integer idum
  REAL gasdev
  integer iset
  REAL fac,gset,rsq,v1,v2,ran2
  SAVE iset,gset
  DATA iset/0/
  if (idum.lt.0) iset = 0
  if (iset.eq.0) then
1    v1 = 2.*ran2(idum)-1.
     v2 = 2.*ran2(idum)-1.
     rsq = v1**2 + v2**2
     if(rsq.ge.1..or.rsq.eq.0.)goto 1
     fac = sqrt(-2.*log(rsq)/rsq)
     gset = v1*fac
     gasdev = v2*fac
     iset = 1
  else
     gasdev = gset
     iset = 0
  endif
  return
END FUNCTION gasdev


*> \brief \b DCSDTS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
*                          LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
*                          RWORK, RESULT )
*
*       .. Scalar Arguments ..
*       INTEGER            LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q
*       ..
*       .. Array Arguments ..
*       INTEGER            IWORK( * )
*       DOUBLE PRECISION   RESULT( 15 ), RWORK( * ), THETA( * )
*       DOUBLE PRECISION   U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
*      $                   V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
*      $                   XF( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DCSDTS tests DORCSD, which, given an M-by-M partitioned orthogonal
*> matrix X,
*>              Q  M-Q
*>       X = [ X11 X12 ] P   ,
*>           [ X21 X22 ] M-P
*>
*> computes the CSD
*>
*>       [ U1    ]**T * [ X11 X12 ] * [ V1    ]
*>       [    U2 ]      [ X21 X22 ]   [    V2 ]
*>
*>                             [  I  0  0 |  0  0  0 ]
*>                             [  0  C  0 |  0 -S  0 ]
*>                             [  0  0  0 |  0  0 -I ]
*>                           = [---------------------] = [ D11 D12 ] ,
*>                             [  0  0  0 |  I  0  0 ]   [ D21 D22 ]
*>                             [  0  S  0 |  0  C  0 ]
*>                             [  0  0  I |  0  0  0 ]
*>
*> and also DORCSD2BY1, which, given
*>          Q
*>       [ X11 ] P   ,
*>       [ X21 ] M-P
*>
*> computes the 2-by-1 CSD
*>
*>                                     [  I  0  0 ]
*>                                     [  0  C  0 ]
*>                                     [  0  0  0 ]
*>       [ U1    ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
*>       [    U2 ]      [ X21 ]        [  0  0  0 ]   [ D21 ]
*>                                     [  0  S  0 ]
*>                                     [  0  0  I ]
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix X.  M >= 0.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*>          P is INTEGER
*>          The number of rows of the matrix X11.  P >= 0.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*>          Q is INTEGER
*>          The number of columns of the matrix X11.  Q >= 0.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is DOUBLE PRECISION array, dimension (LDX,M)
*>          The M-by-M matrix X.
*> \endverbatim
*>
*> \param[out] XF
*> \verbatim
*>          XF is DOUBLE PRECISION array, dimension (LDX,M)
*>          Details of the CSD of X, as returned by DORCSD;
*>          see DORCSD for further details.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the arrays X and XF.
*>          LDX >= max( 1,M ).
*> \endverbatim
*>
*> \param[out] U1
*> \verbatim
*>          U1 is DOUBLE PRECISION array, dimension(LDU1,P)
*>          The P-by-P orthogonal matrix U1.
*> \endverbatim
*>
*> \param[in] LDU1
*> \verbatim
*>          LDU1 is INTEGER
*>          The leading dimension of the array U1. LDU >= max(1,P).
*> \endverbatim
*>
*> \param[out] U2
*> \verbatim
*>          U2 is DOUBLE PRECISION array, dimension(LDU2,M-P)
*>          The (M-P)-by-(M-P) orthogonal matrix U2.
*> \endverbatim
*>
*> \param[in] LDU2
*> \verbatim
*>          LDU2 is INTEGER
*>          The leading dimension of the array U2. LDU >= max(1,M-P).
*> \endverbatim
*>
*> \param[out] V1T
*> \verbatim
*>          V1T is DOUBLE PRECISION array, dimension(LDV1T,Q)
*>          The Q-by-Q orthogonal matrix V1T.
*> \endverbatim
*>
*> \param[in] LDV1T
*> \verbatim
*>          LDV1T is INTEGER
*>          The leading dimension of the array V1T. LDV1T >=
*>          max(1,Q).
*> \endverbatim
*>
*> \param[out] V2T
*> \verbatim
*>          V2T is DOUBLE PRECISION array, dimension(LDV2T,M-Q)
*>          The (M-Q)-by-(M-Q) orthogonal matrix V2T.
*> \endverbatim
*>
*> \param[in] LDV2T
*> \verbatim
*>          LDV2T is INTEGER
*>          The leading dimension of the array V2T. LDV2T >=
*>          max(1,M-Q).
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*>          THETA is DOUBLE PRECISION array, dimension MIN(P,M-P,Q,M-Q)
*>          The CS values of X; the essentially diagonal matrices C and
*>          S are constructed from THETA; see subroutine DORCSD for
*>          details.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (M)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is DOUBLE PRECISION array, dimension (15)
*>          The test ratios:
*>          First, the 2-by-2 CSD:
*>          RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*>          RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
*>          RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
*>          RESULT(4) = norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 )
*>          RESULT(5) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
*>          RESULT(6) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
*>          RESULT(7) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
*>          RESULT(8) = norm( I - V2T'*V2T ) / ( MAX(1,M-Q)*ULP )
*>          RESULT(9) = 0        if THETA is in increasing order and
*>                               all angles are in [0,pi/2];
*>                    = ULPINV   otherwise.
*>          Then, the 2-by-1 CSD:
*>          RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*>          RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
*>          RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
*>          RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
*>          RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
*>          RESULT(15) = 0        if THETA is in increasing order and
*>                                all angles are in [0,pi/2];
*>                     = ULPINV   otherwise.
*>          ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
     $                   LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
     $                   RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   RESULT( 15 ), RWORK( * ), THETA( * )
      DOUBLE PRECISION   U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
     $                   V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
     $                   XF( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   PIOVER2, REALONE, REALZERO
      PARAMETER          ( PIOVER2 = 1.57079632679489662D0,
     $                     REALONE = 1.0D0, REALZERO = 0.0D0 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, R
      DOUBLE PRECISION   EPS2, RESID, ULP, ULPINV
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANSY
      EXTERNAL           DLAMCH, DLANGE, DLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DLACPY, DLASET, DORCSD, DORCSD2BY1,
     $                   DSYRK
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          COS, DBLE, MAX, MIN, SIN
*     ..
*     .. Executable Statements ..
*
      ULP = DLAMCH( 'Precision' )
      ULPINV = REALONE / ULP
*
*     The first half of the routine checks the 2-by-2 CSD
*
      CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, LDX )
      CALL DSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX,
     $            ONE, WORK, LDX )
      IF (M.GT.0) THEN
         EPS2 = MAX( ULP,
     $               DLANGE( '1', M, M, WORK, LDX, RWORK ) / DBLE( M ) )
      ELSE
         EPS2 = ULP
      END IF
      R = MIN( P, M-P, Q, M-Q )
*
*     Copy the matrix X to the array XF.
*
      CALL DLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
*     Compute the CSD
*
      CALL DORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'D', M, P, Q, XF(1,1), LDX,
     $             XF(1,Q+1), LDX, XF(P+1,1), LDX, XF(P+1,Q+1), LDX,
     $             THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T,
     $             WORK, LWORK, IWORK, INFO )
*
*     Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
*
      CALL DLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
      CALL DGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
     $            XF, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
      CALL DGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
     $            U1, LDU1, WORK, LDX, ZERO, XF, LDX )
*
      DO I = 1, MIN(P,Q)-R
         XF(I,I) = XF(I,I) - ONE
      END DO
      DO I = 1, R
         XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
     $           XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
      END DO
*
      CALL DGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q,
     $            ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
      CALL DGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P,
     $            ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX )
*
      DO I = 1, MIN(P,M-Q)-R
         XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE
      END DO
      DO I = 1, R
         XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
     $      XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
     $      SIN(THETA(R-I+1))
      END DO
*
      CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
     $            XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
      CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
     $            ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX )
*
      DO I = 1, MIN(M-P,Q)-R
         XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE
      END DO
      DO I = 1, R
         XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
     $             XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
     $             SIN(THETA(R-I+1))
      END DO
*
      CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q,
     $            ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
      CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P,
     $            ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX )
*
      DO I = 1, MIN(M-P,M-Q)-R
         XF(P+I,Q+I) = XF(P+I,Q+I) - ONE
      END DO
      DO I = 1, R
         XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
     $      XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
     $      COS(THETA(I))
      END DO
*
*     Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
      RESID = DLANGE( '1', P, Q, XF, LDX, RWORK )
      RESULT( 1 ) = ( RESID / DBLE(MAX(1,P,Q)) ) / EPS2
*
*     Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
*
      RESID = DLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK )
      RESULT( 2 ) = ( RESID / DBLE(MAX(1,P,M-Q)) ) / EPS2
*
*     Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
      RESID = DLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK )
      RESULT( 3 ) = ( RESID / DBLE(MAX(1,M-P,Q)) ) / EPS2
*
*     Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
*
      RESID = DLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK )
      RESULT( 4 ) = ( RESID / DBLE(MAX(1,M-P,M-Q)) ) / EPS2
*
*     Compute I - U1'*U1
*
      CALL DLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
      CALL DSYRK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1,
     $            ONE, WORK, LDU1 )
*
*     Compute norm( I - U'*U ) / ( MAX(1,P) * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', P, WORK, LDU1, RWORK )
      RESULT( 5 ) = ( RESID / DBLE(MAX(1,P)) ) / ULP
*
*     Compute I - U2'*U2
*
      CALL DLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
      CALL DSYRK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2,
     $            LDU2, ONE, WORK, LDU2 )
*
*     Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', M-P, WORK, LDU2, RWORK )
      RESULT( 6 ) = ( RESID / DBLE(MAX(1,M-P)) ) / ULP
*
*     Compute I - V1T*V1T'
*
      CALL DLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
      CALL DSYRK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE,
     $            WORK, LDV1T )
*
*     Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', Q, WORK, LDV1T, RWORK )
      RESULT( 7 ) = ( RESID / DBLE(MAX(1,Q)) ) / ULP
*
*     Compute I - V2T*V2T'
*
      CALL DLASET( 'Full', M-Q, M-Q, ZERO, ONE, WORK, LDV2T )
      CALL DSYRK( 'Upper', 'No transpose', M-Q, M-Q, -ONE, V2T, LDV2T,
     $            ONE, WORK, LDV2T )
*
*     Compute norm( I - V2T*V2T' ) / ( MAX(1,M-Q) * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', M-Q, WORK, LDV2T, RWORK )
      RESULT( 8 ) = ( RESID / DBLE(MAX(1,M-Q)) ) / ULP
*
*     Check sorting
*
      RESULT( 9 ) = REALZERO
      DO I = 1, R
         IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
            RESULT( 9 ) = ULPINV
         END IF
         IF( I.GT.1 ) THEN
            IF ( THETA(I).LT.THETA(I-1) ) THEN
               RESULT( 9 ) = ULPINV
            END IF
         END IF
      END DO
*
*     The second half of the routine checks the 2-by-1 CSD
*
      CALL DLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX )
      CALL DSYRK( 'Upper', 'Conjugate transpose', Q, M, -ONE, X, LDX,
     $            ONE, WORK, LDX )
      IF( M.GT.0 ) THEN
         EPS2 = MAX( ULP,
     $               DLANGE( '1', Q, Q, WORK, LDX, RWORK ) / DBLE( M ) )
      ELSE
         EPS2 = ULP
      END IF
      R = MIN( P, M-P, Q, M-Q )
*
*     Copy the matrix [ X11; X21 ] to the array XF.
*
      CALL DLACPY( 'Full', M, Q, X, LDX, XF, LDX )
*
*     Compute the CSD
*
      CALL DORCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1),
     $                 LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK,
     $                 LWORK, IWORK, INFO )
*
*     Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
*
      CALL DGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
     $            X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
      CALL DGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
     $            U1, LDU1, WORK, LDX, ZERO, X, LDX )
*
      DO I = 1, MIN(P,Q)-R
         X(I,I) = X(I,I) - ONE
      END DO
      DO I = 1, R
         X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
     $           X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
      END DO
*
      CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
     $            X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
      CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
     $            ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
*
      DO I = 1, MIN(M-P,Q)-R
         X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
      END DO
      DO I = 1, R
         X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
     $             X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
     $             SIN(THETA(R-I+1))
      END DO
*
*     Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
      RESID = DLANGE( '1', P, Q, X, LDX, RWORK )
      RESULT( 10 ) = ( RESID / DBLE(MAX(1,P,Q)) ) / EPS2
*
*     Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
      RESID = DLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
      RESULT( 11 ) = ( RESID / DBLE(MAX(1,M-P,Q)) ) / EPS2
*
*     Compute I - U1'*U1
*
      CALL DLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
      CALL DSYRK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1,
     $            ONE, WORK, LDU1 )
*
*     Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', P, WORK, LDU1, RWORK )
      RESULT( 12 ) = ( RESID / DBLE(MAX(1,P)) ) / ULP
*
*     Compute I - U2'*U2
*
      CALL DLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
      CALL DSYRK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2,
     $            LDU2, ONE, WORK, LDU2 )
*
*     Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', M-P, WORK, LDU2, RWORK )
      RESULT( 13 ) = ( RESID / DBLE(MAX(1,M-P)) ) / ULP
*
*     Compute I - V1T*V1T'
*
      CALL DLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
      CALL DSYRK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE,
     $            WORK, LDV1T )
*
*     Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
*
      RESID = DLANSY( '1', 'Upper', Q, WORK, LDV1T, RWORK )
      RESULT( 14 ) = ( RESID / DBLE(MAX(1,Q)) ) / ULP
*
*     Check sorting
*
      RESULT( 15 ) = REALZERO
      DO I = 1, R
         IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
            RESULT( 15 ) = ULPINV
         END IF
         IF( I.GT.1 ) THEN
            IF ( THETA(I).LT.THETA(I-1) ) THEN
               RESULT( 15 ) = ULPINV
            END IF
         END IF
      END DO
*
      RETURN
*
*     End of DCSDTS
*
      END


      subroutine table(flag,length,colmn1,colmn2,given,found)
c
c     + + + PURPOSE + + +
c
c     SR TABLE inserts an additional value into the first
c     column of an ordered, paired data set and uses linear
c     interpolation to compute the corresponding value of the
c     column
c
c     Called from: SRS CHNCON, HYDCHN, DCAP, AND OTHERS
c     Author(s): CREAMS file, C. Baffaut
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      integer length, flag
      real colmn1(length), colmn2(length), given, found, mxfound
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     colmn1(length) -
c     colmn2(length) -
c     given          -
c     found          -
c     length         -
c     flag           -
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      real intrpl, tval
      integer i, npos, j, k
c
c     + + + LOCAL DEFINITIONS + + +
c
c     intrpl -
c     tval     -
c     i      -
c     npos   -
c     j      -
c     k      -
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     intrpl
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      if (flag.ne.2) then
        if (flag.eq.3) go to 60
        if (flag.eq.4) go to 80
c
        do 10 i = 1, length
          npos = i
          if (colmn1(i).lt.given) go to 100
   10   continue
c
        go to 120
      end if
c
      do 20 i = 1, length
        npos = i
c
        if (colmn1(i).gt.given) then
          if (npos.eq.1) go to 120
          mxfound = intrpl(colmn1(npos-1),colmn2(npos-1),colmn1(npos),
     1        colmn2(npos),given)
c         exit
          go to 30
        end if
c
   20 continue
c
   30 do 50 k = 2, length
        tval = colmn1(k)
c
        do 40 j = npos, length
c
          if (colmn1(j)-tval.gt.given) then
            found = intrpl(colmn1(j-1),colmn2(j-1),colmn1(j),colmn2(j),
     1          given+tval) - colmn2(k)
            if (found.gt.mxfound) mxfound = found
            npos = j
c           exit
            go to 50
          end if
c
   40   continue
c
   50 continue
c
      found = mxfound
      return
c
   60 continue
c
      do 70 i = 1, length
        npos = i
        if (colmn2(i).lt.given) go to 110
   70 continue
c
      go to 120
c
   80 continue
c
      do 90 i = 1, length
        npos = i
        if (colmn2(i).gt.given) go to 110
   90 continue
c
      go to 120
c
  100 continue
c
      if (npos.eq.1) go to 120
      found = intrpl(colmn1(npos-1),colmn2(npos-1),colmn1(npos),
     1    colmn2(npos),given)
      return
c
  110 continue
c
      if (npos.ne.1) then
        found = intrpl(colmn2(npos-1),colmn1(npos-1),colmn2(npos),
     1      colmn1(npos),given)
        return
      end if
c
  120 continue
c
      write (38,1000) flag, given, colmn1(3), colmn2(3)
      write (6,1000) flag, given, colmn1(3), colmn2(3)
c
      stop
 1000 format (' ',/,12x,'**********ERROR**********',/,12x,
     1    'GIVEN is outside the range of the table',//,1x,
     1    'use this info to identify the function where',
     1    ' the problem occured',//,4x,
     1    'flag: 1 - given column 1 find column 2 ',
     1    '(column 1 decreases)',/,4x,
     1    '      2 - given column 1 find column 2 ',
     1    '(column 1 increases)',//,4x,
     1    '      3 - given column 2 find column 1 ',
     1    '(column 2 decreases)',/,4x,
     1    '      4 - given column 2 find column 1 ',
     1    '(column 2 increases)',//,12x,'the flag                  = ',
     1    i2,/,12x,'given value               = ',e10.3,/,12x,
     1    'third value from column 1 = ',e10.3,/,12x,
     1    'third value from column 2 = ',e10.3)
      end


      subroutine makertr(a,lda,n)
c----------------------------------------------------------------------
c      converts an upper triangular matrix, a, to the matrix
c  product a(transpose)*a with the product overwritting a.
c  normally, this is an absurd thing to do as the inverse of a
c  can be had directly from the upper triangular form.(cholesky
c  or qr decomposition give this form.)  this approach is useful
c  for space saving algorthms that accumulate a large ata type
c  matrix for least squares problem in a blockwise fashion
c  to save space.  the algorithm used is more efficient than a
c  pure brute force approach.  routine keeps the values of a in
c  the upper triangle and writes elements of ata inner products
c  in the lower triangle of a.  when finished the lower triangle
c  is copied onto the upper triangle destroying the information
c  that was there.
c
c  arguments-
c
c    a  - n by n upper triangle matrix that on output is replace
c         by the matrix product a(transpose)*a
c    lda- leading dimension of a in calling program.
c    n  - order of a.
c
c  required subprograms-
c      sumsq - real function calculates sum of squares of a vector
c              (blas type routine written by glp)
c      sdot  - blas routine to calculate inner products
c      cpltut- copies strict lower triangle of a to strict upper
c              triangle.
c  language - 1977 ansi standard fortran (algorithm assumes zero
c             trip do loops)
c  author   - gary l. pavlis
c  written  - may 1981
c
c----------------------------------------------------------------------
      integer lda,n
      real a(lda,n)
c--local variables used as loop counters
      integer i,j
c--used to hold a(1,1) diagonal element
      real aone
      if(n.le.1) return
c--the first row is treated specially
      aone = a(1,1)
      do 100 i=1,n
            a(i,1) = aone*a(1,i)
  100 continue
c--warning the zero trip do loop convention is assumed here.
      do 200 j=2,n
            do 150 i=j+1,n
                  a(i,j) = sdot(j,a(1,i),1,a(1,j),1)
  150       continue
            a(j,j) = sumsq(j,a(1,j),1)
  200 continue
      call cpltut(a,lda,n)
      return
      end

c $Id$


      subroutine anrs02 (a,ia,b,w,ipvt,n,io)
C     SUBROUTINE ANRS02 (A,IA,B,W,IPVT,N,IO)
C
C***********************************************************************
C                                                                      *
C                                                                      *
C     Copyright:        Eduardo Casas Renteria                         *
C                       Cecilia Pola Mendez                            *
C                                                                      *
C       Departamento de Matematicas,estadistica y Computacion          *
C       -----------------------------------------------------          *
C                       UNIVERSIDAD DE CANTABRIA                       *
C                       ------------------------                       *
C                               MAYO  1987                             *
C                                                                      *
C***********************************************************************
C
C     OBJETIVO:
C        Esta subrutina resuelve un sistema del tipo:
C                                P'LL'Px=b ,
C        donde  P  es una matriz de permutacion y  L  es una matriz
C        triangular inferior.
C
C     LISTA DE LLAMADA:
C     DE ENTRADA:
C
C        A      Matriz de dimension (IA,N).  En sus N primeras filas,
C               almacena a la matriz triangular superior L'. La parte
C               subdiagonal de A no es utilizada.
C
C        IA     Primera dimension de la matriz A. IA >= N.
C
C        B      Vector N-dimensional. Guarda los terminos independientes
C               del sistema.
C
C        W      Vector de trabajo N-dimensional.
C
C        IPVT   Vector entero de trabajo de dimension N. Se utiliza para
C               interpretar el cambio de filas producido al multiplicar
C               por la derecha por la matriz de permutacion P :
C                    IPVT(I)=J, indica que en el lugar I-esimo se coloca
C               la fila J-esima
C        N      Numero de filas y columnas de la matriz de coeficientes.
C
C        IO     Numero de canal de salida de resultados.
C
C     DE SALIDA:
C
C        B      Vector que recoge la solucion del sistema.
C
C
C        Esta subrutina trabaja en doble precision via una sentencia
C     "implicit":
C                implicit double precision (a-h,o-z)
C
C     SUPROGRAMAS AUXILIARES: anrs01,ddot,d1mach
C     FUNCIONES FORTRAN INTRINSECAS: abs,mod
C
C
      implicit double precision (a-h,o-z)
      dimension a(ia,*),b(*),w(*),ipvt(*)
C
C     Se resuelve el sistema Ly=Pb
C
      do 10 i=1,n
10    w(i)=b(ipvt(i))
      ind=1
      call anrs01(a,ia,n,w,w,ind,io)
C
C     Se resuelve el sistema L'z=y
C
      ind=2
      call anrs01(a,ia,n,w,w,ind,io)
C
C     Se calcula P'z
C
      do 20 i=1,n
20    b(ipvt(i))=w(i)
      end


      include 'VICMAIN_FOR'
      SUBROUTINE MAIN44
      COMMON/C1/HIST(-32768:32767),IBUF(32768)
      INTEGER*4 HIST
      INTEGER*2 IBUF

      COMMON/C2/OBUF(10),OHIST(0:255)	!Histogram record data structure
      INTEGER*4 OHIST
      INTEGER*4 BUF(10)
      EQUIVALENCE (BUF,OBUF)

      LOGICAL XVPTST
      INTEGER*4 SL,SS,EL
      REAL*4 MEAN,SIGMA
      CHARACTER*8 FORMAT
      CHARACTER*80 MSG

  803 FORMAT(' Mean=',F14.8,'   Sigma=',F14.8,
     &   '   Total number of pixels=',I10)

C     ....Get unit number and open input image
      CALL XVUNIT(iunit,'INP',1,IND,' ')
      CALL XVOPEN(IUNIT,IND,'OPEN_ACT','SA','IO_ACT','SA',' ')
      CALL XVSIZE(sl,ss,nl,ns,nli,nsi)
      IF (SL+NL-1 .GT. NLI) GOTO 902
      IF (SS+NS-1 .GT. NSI) GOTO 903
      IF (NS.GT.32768) GOTO 904
      NPTS = NL*NS
C     ....Compute histogram of input image.  If the image is byte
C     ....the histogram is stored directly in OHIST.  If halfword,
C     ....the histogram is first stored in HIST, and then
C     ....compressed into OHIST.

      EL = SL+NL-1
      CALL XVGET(IUNIT,IND,'FORMAT',FORMAT,' ')
      IF (FORMAT.EQ.'BYTE') THEN
         ITYPE = 1
C     ....Generate histogram
         DO LINE=SL,EL
            CALL XVREAD(IUNIT,ibuf,ind,'LINE',LINE,'SAMP',SS,
     &                 'NSAMPS',NS,' ')
            CALL HSUB(1,NS,IBUF,OHIST)
         ENDDO
      ELSE IF (FORMAT.EQ.'HALF'.OR.FORMAT.EQ.'WORD') THEN
         ITYPE = 2
         DO LINE=SL,EL
            CALL XVREAD(IUNIT,ibuf,ind,'LINE',LINE,'SAMP',SS,
     &                 'NSAMPS',NS,' ')
            DO J=1,NS
              IDN = IBUF(J)
              HIST(IDN) = HIST(IDN) + 1
            ENDDO
         ENDDO
      ELSE
         GOTO 990
      ENDIF

      IF (ITYPE.EQ.1) THEN
         CALL histat(OHIST,NPTS,mean,sigma,maxfreq)
C     ....Print mean, standard deviation, and total number of pixels
c         CALL QPRINT(' ***Test from Fortran')
          CALL XVMESSAGE(' ***Test from Fortran',' ')
         WRITE (MSG,803) MEAN,SIGMA,NPTS
c        CALL QPRINT(MSG,80)
         Call Xvmessage(msg, ' ')
         mean=0.0
         sigma=0.0
         maxfreq=0
         CALL tzhistat(OHIST,NPTS,mean,sigma,maxfreq)
c         CALL QPRINT(' ***Test from C')
         CALL Xvmessage(' ***Test from C', ' ')
         WRITE (MSG,803) MEAN,SIGMA,NPTS
c         CALL QPRINT(MSG,80)
         Call Xvmessage(msg, ' ')
      ELSE
	 IF (.NOT.XVPTST('INCLUDE')) THEN
	    NPTS = NPTS - HIST(-32768)
	    HIST(-32768) = 0
         ENDIF
         CALL histat2(HIST,NPTS,mean,sigma,mindn,maxdn,maxfreq)
C     ....Print mean, standard deviation, and total number of pixels
c         CALL QPRINT(' ***Test from Fortran')
         CALL Xvmessage(' ***Test from Fortran', ' ')
         WRITE (MSG,803) MEAN,SIGMA,NPTS
c         CALL QPRINT(MSG,80)
         Call Xvmessage(msg, ' ')
         mean=0.0
         sigma=0.0
         mindn=0
         maxdn=0
         maxfreq=0
         CALL tzhistat2(HIST,NPTS,mean,sigma,mindn,maxdn,maxfreq)
c         CALL QPRINT(' ***Test from C')
         CALL Xvmessage(' ***Test from C', ' ')
         WRITE (MSG,803) MEAN,SIGMA,NPTS
c         CALL QPRINT(MSG,80)
         Call Xvmessage(msg, ' ')
      ENDIF

      RETURN

c  902 CALL QPRINT(' ***Number of lines requested exceeds input size')
  902 CALL Xvmessage(' *** # lines requested exceeds input size',' ')
      GOTO 999
c  903 CALL QPRINT(' ***Number of samples requested exceeds input size')
  903 CALL Xvmessage(' *** # samples requested exceeds input size', ' ')
      GOTO 999
c  904 CALL QPRINT(' ***Input image number of samples exceeds limit')
  904 CALL Xvmessage(' ***Input image #samples exceeds limit', ' ')
      GOTO 999
c  990 CALL QPRINT(' ***Invalid input data format')
  990 CALL Xvmessage(' ***Invalid input data format',' ')
c      CALL QPRINT(' ***Inputs must be byte or halfword')
      CALL Xvmessage(' ***Inputs must be byte or halfword',' ')
      GOTO 999
c  999 CALL QPRINT(' thistat task cancelled')
  999 CALL Xvmessage(' thistat task cancelled', ' ')
      CALL ABEND
      END


! Copyright (c) 2012, Johannes Feist
! licensed under the MIT open source license, see LICENSE file

program main
  use laserfields
  implicit none
  real(dp) :: tt, dt

  call laserfields_read_parameters('laserfields.in')

  !             make_laserfield(form,intensity_Wcm2,lambda_nm,peak_time_as,duration_as,rampon_as,form_exponent,phase_pi,is_vecpot,group,linear_chirp_rate_w0as)
  call add_laserfield(make_laserfield('sin2',1.d15,20.d0,100.d0,200.d0))
  call add_laserfield(make_laserfield('weirdfield.dat'))

  dt = laserfields_smallest_TX() / 50.
  tt = laserfields_starttime() - dt
  do while (tt<=laserfields_endtime())
     tt = tt + dt
     write(6,*) tt, get_EL(tt)
  end do

end program main


      subroutine runY_000000l(k,l,Xtwiddle,Gtwiddle,Shat7zzzz,N0)
      implicit none
C---  Expression for extension of Eq. 5.60a
C---  Calculates D00llll
C---  Small terms of order Xtwiddle(0,k)*Diiiii,Xtwiddle(0,0)*Diiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7zzzz(np,z2max,-2:0)

      do ep=-2,0
      Dv(dzzzzzzi(l)+N0,ep)=
     . (Gtwiddle(k,1)*Shat7zzzz(1,z2(l,l),ep)
     . +Gtwiddle(k,2)*Shat7zzzz(2,z2(l,l),ep)
     . +Gtwiddle(k,3)*Shat7zzzz(3,z2(l,l),ep)
     . +Xtwiddle(k,0)*Dv(dzzzzii(z2(l,l))+N0,ep)
     . -Xtwiddle(0,0)*Dv(dzzzziii(z3(k,l,l))+N0,ep))
     . /(4d0*Gtwiddle(k,l))
      enddo

      return
      end


CCCCCCCCCCCCCCCCCC     MATHEMATICAL PACKAGE     CCCCCCCCCCCCCCCCCCCCCCC
CCCCCCC    MOST OF THESE ROUTINE ARE FULLY VECTORIZED ON CRAY-1  CCCCCC
CCCCCCC    THEY ARE ROUGHLY RESPONSIBLE OF 70% OF THE CPU TIME   CCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      DOUBLE PRECISION FUNCTION SDOT (N,X,IX,Y,IY)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION X(*),Y(*)
C     SDOT=DOT PRODUCT OF VECTOR X, STEP IX, BY VECTOR Y, STEP IY,
C     N ELEMENTS.
C     SIMULATE ROUTINE ON CRAY (SAME NAME AND CALLING SEQUENCE).
      J=1
      SDOT=0.D0
      DO 10 I=1,(N-1)*IX+1,IX
         SDOT=SDOT+X(I)*Y(J)
   10 J=J+IY
      RETURN
      END
      SUBROUTINE SCOPY (N,X,IX,Y,IY)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     COPY VECTOR X, STEP IX ONTO VECTOR Y, STEP IY, N ELEMENTS.
C     SIMULATE ROUTINE ON CRAY (SAME NAME AND CALLING SEQUENCE).
      DIMENSION X(*),Y(*)
      I=1
      DO 10 J=1,IY*(N-1)+1,IY
         Y(J)=X(I)
   10 I=I+IX
      RETURN
      END
      SUBROUTINE SAXPY(N,A,X,IX,Y,IY)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     VECTOR INCREMENT Y=Y+A*X WITH X & Y VECTORS OF LENGTH N, A SCALAR.
C     IX STEP OF X, IY STEP OF Y.
C     SIMULATE ROUTINE ON CRAY (SAME NAME AND CALLING SEQUENCE).
      DIMENSION X(*),Y(*)
      I=1
      DO 10 J=1,IY*(N-1)+1,IY
         Y(J)=Y(J)+A*X(I)
   10 I=I+IX
      RETURN
      END
      SUBROUTINE MXM(A,NAR,B,NBR,C,NCC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     RECTANGULAR MATRIX PRODUCT C=A*B.
C     EACH MATRIX IS ENTIRELY FULLFILLED AND PACKED.
C     SIMULATE ROUTINE ON CRAY (SAME NAME AND CALLING SEQUENCE).
      DIMENSION A(NAR,NBR),B(NBR,NCC),C(NAR,NCC)
      DO 20 J=1,NCC
         DO 10 I=1,NAR
   10    C(I,J)=0.D0
         DO 20 K=1,NBR
            DO 20 I=1,NAR
   20 C(I,J)=C(I,J)+A(I,K)*B(K,J)
      RETURN
      END
      SUBROUTINE MXMT (A,NAR,B,NBR,C,NCC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     MATRIX PRODUCT C(NAR,NCC) = A(NAR,NBR) * (B(NCC,NBR))'
C     ALL MATRICES RECTANGULAR , PACKED.
      DIMENSION A(NAR,NBR),B(NCC,NBR),C(NAR,NCC)
      DO 20 J=1,NCC
         DO 10 I=1,NAR
   10    C(I,J)=0.D0
         DO 20 K=1,NBR
            DO 20 I=1,NAR
   20 C(I,J)=C(I,J)+A(I,K)*B(J,K)
      RETURN
      END
      SUBROUTINE MTXM (A,NAR,B,NBR,C,NCC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     MATRIX PRODUCT C(NAR,NCC) = (A(NBR,NAR))' * B(NBR,NCC)
C     ALL MATRICES RECTANGULAR , PACKED.
      DIMENSION A(NBR,NAR),B(NBR,NCC),C(NAR,NCC)
      DO 20 J=1,NCC
         DO 10 I=1,NAR
   10    C(I,J)=0.D0
         DO 20 K=1,NBR
            DO 20 I=1,NAR
   20 C(I,J)=C(I,J)+A(K,I)*B(K,J)
      RETURN
      END
      SUBROUTINE MTXMC (A,NAR,B,NBR,C)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     MATRIX PRODUCT C(NAR,NAR) = (A(NBR,NAR))' * B(NBR,NAR)
C     A AND B RECTANGULAR , PACKED,
C     C LOWER LEFT TRIANGLE ONLY, PACKED IN CANONICAL ORDER.
      DIMENSION A(NBR,NAR),B(NBR,NAR),C(*)
C  NOTE ... THIS IS THE BEST VERSION ON CRAY 1.
      L=1
      DO 10 I=1,NAR
         CALL MXM (A(1,I),1,B,NBR,C(L),I)
   10 L=L+I
      RETURN
      END
      SUBROUTINE SUPDOT(S,H,G,N,IG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     (S)=(H)*(G) WITH  H  IN PACKED FORM (CANONICAL ORDER).
C     IG IS THE INCREMENT FOR THE VECTOR G.
      DIMENSION S(*),H(*),G(*)
C     CRAY-1 VERSION
CCC      K=1
CCC      L=1
CCC      DO 10 I=1,N
CCC      S(I)=SDOT(I,H(K),1,G,IG,I)
CCC      IF(I.GT.1) THEN
CCC         L=L+IG
CCC         CALL SAXPY(I-1,G(L),H(K),1,S,1)
CCC      ENDIF
CCC   10 K=K+I
CCC      RETURN
CCC      END
C     SCALAR VERSION OK WITH IG=1 ONLY.
      K=0
      DO 20 I=1,N
         SUM=0.D0
         DO 10 J=1,I
   10    SUM=SUM+G(J)*H(K+J)
         S(I)=SUM
   20 K=K+I
      IF (N.EQ.1) RETURN
      K=1
      DO 40 I=2,N
         GI=G(I)
         DO 30 J=1,I-1
   30    S(J)=S(J)+H(K+J)*GI
   40 K=K+I
      RETURN
      END


c-----------------------------------------------------------------------------
c     ADJOINT of Hicks-Henne based shape deformation parameterization
c     Deformation is interpolated to interior nodes using Thin-Plate Spline RBF
c     interpolation
c
c     Input files:
c       shape.in  : Defines fixed and moving surfaces
c       hicks.in  : Hicks-Henne parameters
c       grid.0    : Base grid
c       rb.dat    : Gradient wrt grid coordinates, given by flow adjoint solver
c
c     Output files:
c-----------------------------------------------------------------------------
      program deform_adj
      implicit none
      include 'dim.h'
      include 'param.h'
      include 'kulfan.h'
      integer total_pts
      real,allocatable:: r(:), dr(:), rw(:,:), drw(:,:), wt(:,:)
      real,allocatable:: rb(:), drwb(:,:), wtb(:,:)
      integer,allocatable:: idx(:,:)

      integer i, j, ioffrt, iblk, npts, nwp, ir, di, dj, mn
      integer fid

c     Read input file defining moving and fixed surfaces
      call readin()

c     Total number of grid points to allocate memory
      npts = total_pts(nblks, idim, jdim)
      if(nblks.gt.nblkmax)then
         print*,'main: increase maxblks'
         print*,'      nblks   =',nblks
         print*,'      maxblks =',nblkmax
         stop
      endif
      allocate ( r (npts*NDIM) )
      allocate (rb (npts*NDIM) )
      allocate (dr (npts*NDIM) )

c     Create offset array for coordinates storage
      ioffrt = 0
      do i=1,nblks
         ioffr(i) = ioffrt
         ioffrt   = ioffrt + idim(i) * jdim(i)
      enddo
      call readgrd(nblks, idim, jdim, ioffr, r)

c     Count number of boundary points to allocate memory
      nwp = 0
      mn  = 0
      do i=1,nsurf
         di  = abs(iend(i) - ibeg(i)) + 1
         dj  = abs(jend(i) - jbeg(i)) + 1
         nwp = nwp + di*dj
         mn  = max( mn, di*dj )
         nspt(i) = di*dj
      enddo
      allocate( rw  (NDIM, nwp) )
      allocate( drw (NDIM, nwp) )
      allocate( wt  (NDIM, nwp+NDIM+1) )
      allocate( wtb (NDIM, nwp+NDIM+1) )
      allocate( drwb(NDIM, nwp) )
      allocate( idx (mn, nsurf) )

c     For mirror surfaces like in symmetric airfoil
      do i=1,nsurf
         nhhpo(i) = nhhp(i)
         if(nhhp(i).lt.0)then
            ir      =-nhhp(i)
            nhhp(i) = nhhp(ir)
            do j=1,nhhp(i)
               xw(j,i) = -xw(j,ir)
            enddo
         endif
      enddo

c     Loop over surfaces
c     Put boundary points in rw and deformation into drw
c     Count number nwp of boundary points: there may be duplicate points
      nwp = 0
      do i=1,nsurf
         print*,'Applying deformation to surface =',i
         iblk = blk(i)
         ir   = ioffr(iblk)*NDIM + 1
         call shape_deform(ibeg(i), jbeg(i), iend(i), jend(i), nhhp(i),
     1                     idim(iblk), jdim(iblk), r(ir),
     2                     rw, drw, nwp, xw(1,i), idx(1,i), param_type)
      enddo
      print*,'Number of wall points (inc. duplicates) =',nwp

c     Remove duplicate boundary points
      call rem_dup(nwp, rw, drw, nsurf, nspt, mn, idx)

c-------------------
c     Reverse sweep
c-------------------

      wtb(:,:)  = 0.0
      drwb(:,:) = 0.0

c     Read gradient file, output by adjoint solver
      call readgrad(nblks, idim, jdim, ioffr, rb)

c     Test gradient
c     do iblk=1,nblks
c        ir   = ioffr(iblk)*NDIM + 1
c        call testgrad(idim(iblk), jdim(iblk), r(ir), rb(ir))
c     enddo

c     Compute deformation for interior points
      do iblk=1,nblks
         ir   = ioffr(iblk)*NDIM + 1
         call rbf_eval_b(idim(iblk), jdim(iblk), r(ir), rb(ir),
     1                   nwp, rw, wt, wtb)
      enddo

c     Construct RBF interpolant
      call rbf_train_b(nwp, rw, drw, drwb, wt, wtb)

      do i=1,nwp
      print*,i,drwb(1,i),drwb(2,i)
      enddo

      do i=1,nsurf
         print*,'Applying deformation to surface =',i
         iblk = blk(i)
         ir   = ioffr(iblk)*NDIM + 1
         call shape_deform_b(ibeg(i), jbeg(i), iend(i), jend(i),
     1                     nhhp(i), idim(iblk), jdim(iblk), r(ir),
     2                     rw, drw, drwb, nwp, xw(1,i), xwb(1,i),
     3                     idx(1,i), param_type)
         do j=1,nhhp(i)
            print*,j,xwb(j,i)
         enddo
      enddo

c     Differentiation for symmetric case
      do i=1,nsurf
         if(nhhpo(i).lt.0)then
            ir      =-nhhpo(i)
            do j=1,nhhp(i)
               xwb(j,ir) = xwb(j,ir) - xwb(j,i)
               xwb(j,i)  = 0.0
            enddo
         endif
      enddo

c     Save gradients
      fid = 15
      mn  = 0 ! Counter for parameter number
      open(fid, file='gradient.dat')
      do i=1,nsurf
         do j=1,nhhpo(i)
            mn = mn + 1
            write(fid,*) mn, xwb(j,i)
         enddo
      enddo
      close(fid)

      stop
      end