      SUBROUTINE SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N,
     $                   A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for X either the real continuous-time Sylvester equation
C
C        op(A)*X + ISGN*X*op(B) = scale*C,                           (1)
C
C     or the real discrete-time Sylvester equation
C
C        op(A)*X*op(B) + ISGN*X = scale*C,                           (2)
C
C     where op(M) = M or M**T, and ISGN = 1 or -1. A is M-by-M and
C     B is N-by-N; the right hand side C and the solution X are M-by-N;
C     and scale is an output scale factor, set less than or equal to 1
C     to avoid overflow in X. The solution matrix X is overwritten
C     onto C.
C
C     If A and/or B are not (upper) quasi-triangular, that is, block
C     upper triangular with 1-by-1 and 2-by-2 diagonal blocks, they are
C     reduced to Schur canonical form, that is, quasi-triangular with
C     each 2-by-2 diagonal block having its diagonal elements equal and
C     its off-diagonal elements of opposite sign.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the equation from which X is to be determined
C             as follows:
C             = 'C':  Equation (1), continuous-time case;
C             = 'D':  Equation (2), discrete-time case.
C
C     FACTA   CHARACTER*1
C             Specifies whether or not the real Schur factorization
C             of the matrix A is supplied on entry, as follows:
C             = 'F':  On entry, A and U contain the factors from the
C                     real Schur factorization of the matrix A;
C             = 'N':  The Schur factorization of A will be computed
C                     and the factors will be stored in A and U;
C             = 'S':  The matrix A is quasi-triangular (or Schur).
C
C     FACTB   CHARACTER*1
C             Specifies whether or not the real Schur factorization
C             of the matrix B is supplied on entry, as follows:
C             = 'F':  On entry, B and V contain the factors from the
C                     real Schur factorization of the matrix B;
C             = 'N':  The Schur factorization of B will be computed
C                     and the factors will be stored in B and V;
C             = 'S':  The matrix B is quasi-triangular (or Schur).
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     TRANB   CHARACTER*1
C             Specifies the form of op(B) to be used, as follows:
C             = 'N':  op(B) = B    (No transpose);
C             = 'T':  op(B) = B**T (Transpose);
C             = 'C':  op(B) = B**T (Conjugate transpose = Transpose).
C
C     ISGN    INTEGER
C             Specifies the sign of the equation as described before.
C             ISGN may only be 1 or -1.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of the matrix A, and the number of rows in the
C             matrices X and C.  M >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix B, and the number of columns in
C             the matrices X and C.  N >= 0.
C
C     A       (input or input/output) DOUBLE PRECISION array,
C             dimension (LDA,M)
C             On entry, the leading M-by-M part of this array must
C             contain the matrix A. If FACTA = 'S', then A contains
C             a quasi-triangular matrix, and if FACTA = 'F', then A
C             is in Schur canonical form; the elements below the upper
C             Hessenberg part of the array A are not referenced.
C             On exit, if FACTA = 'N', and INFO = 0 or INFO >= M+1, the
C             leading M-by-M upper Hessenberg part of this array
C             contains the upper quasi-triangular matrix in Schur
C             canonical form from the Schur factorization of A. The
C             contents of array A is not modified if FACTA = 'F' or 'S'.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     U       (input or output) DOUBLE PRECISION array, dimension
C             (LDU,M)
C             If FACTA = 'F', then U is an input argument and on entry
C             the leading M-by-M part of this array must contain the
C             orthogonal matrix U of the real Schur factorization of A.
C             If FACTA = 'N', then U is an output argument and on exit,
C             if INFO = 0 or INFO >= M+1, it contains the orthogonal
C             M-by-M matrix from the real Schur factorization of A.
C             If FACTA = 'S', the array U is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of array U.
C             LDU >= MAX(1,M), if FACTA = 'F' or 'N';
C             LDU >= 1,        if FACTA = 'S'.
C
C     B       (input or input/output) DOUBLE PRECISION array,
C             dimension (LDB,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix B. If FACTB = 'S', then B contains
C             a quasi-triangular matrix, and if FACTB = 'F', then B
C             is in Schur canonical form; the elements below the upper
C             Hessenberg part of the array B are not referenced.
C             On exit, if FACTB = 'N', and INFO = 0 or INFO = M+N+1,
C             the leading N-by-N upper Hessenberg part of this array
C             contains the upper quasi-triangular matrix in Schur
C             canonical form from the Schur factorization of B. The
C             contents of array B is not modified if FACTB = 'F' or 'S'.
C
C     LDB     (input) INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     V       (input or output) DOUBLE PRECISION array, dimension
C             (LDV,N)
C             If FACTB = 'F', then V is an input argument and on entry
C             the leading N-by-N part of this array must contain the
C             orthogonal matrix V of the real Schur factorization of B.
C             If FACTB = 'N', then V is an output argument and on exit,
C             if INFO = 0 or INFO = M+N+1, it contains the orthogonal
C             N-by-N matrix from the real Schur factorization of B.
C             If FACTB = 'S', the array V is not referenced.
C
C     LDV     INTEGER
C             The leading dimension of array V.
C             LDV >= MAX(1,N), if FACTB = 'F' or 'N';
C             LDV >= 1,        if FACTB = 'S'.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right hand side matrix C.
C             On exit, if INFO = 0 or INFO = M+N+1, the leading M-by-N
C             part of this array contains the solution matrix X.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor, scale, set less than or equal to 1 to
C             prevent the solution overflowing.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or M+N+1, then: DWORK(1) returns the
C             optimal value of LDWORK; if FACTA = 'N', DWORK(1+i) and
C             DWORK(1+M+i), i = 1,...,M, contain the real and imaginary
C             parts, respectively, of the eigenvalues of A; and, if
C             FACTB = 'N', DWORK(1+f+j) and DWORK(1+f+N+j), j = 1,...,N,
C             with f = 2*M if FACTA = 'N', and f = 0, otherwise, contain
C             the real and imaginary parts, respectively, of the
C             eigenvalues of B.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 1, a+MAX( c, b+d, b+e ) ),
C             where a = 1+2*M, if FACTA =  'N',
C                   a = 0,     if FACTA <> 'N',
C                   b = 2*N,   if FACTB =  'N', FACTA =  'N',
C                   b = 1+2*N, if FACTB =  'N', FACTA <> 'N',
C                   b = 0,     if FACTB <> 'N',
C                   c = 3*M,   if FACTA =  'N',
C                   c = M,     if FACTA =  'F',
C                   c = 0,     if FACTA =  'S',
C                   d = 3*N,   if FACTB =  'N',
C                   d = N,     if FACTB =  'F',
C                   d = 0,     if FACTB =  'S',
C                   e = M,     if DICO  =  'C', FACTA <> 'S',
C                   e = 0,     if DICO  =  'C', FACTA =  'S',
C                   e = 2*M,   if DICO  =  'D'.
C             An upper bound is
C             LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M ).
C             For good performance, LDWORK should be larger, e.g.,
C             LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M, 2*N+M*N ).
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             = i:  if INFO = i, i = 1,...,M, the QR algorithm failed
C                   to compute all the eigenvalues of the matrix A
C                   (see LAPACK Library routine DGEES); the elements
C                   2+i:1+M and 2+i+M:1+2*M of DWORK contain the real
C                   and imaginary parts, respectively, of the
C                   eigenvalues of A which have converged, and the
C                   array A contains the partially converged Schur form;
C             = M+j:  if INFO = M+j, j = 1,...,N, the QR algorithm
C                   failed to compute all the eigenvalues of the matrix
C                   B (see LAPACK Library routine DGEES); the elements
C                   2+f+j:1+f+N and 2+f+j+N:1+f+2*N of DWORK contain the
C                   real and imaginary parts, respectively, of the
C                   eigenvalues of B which have converged, and the
C                   array B contains the partially converged Schur form;
C                   as defined for the parameter DWORK,
C                   f = 2*M, if FACTA =  'N',
C                   f = 0,   if FACTA <> 'N';
C             = M+N+1:  if DICO = 'C', and the matrices A and -ISGN*B
C                   have common or very close eigenvalues, or
C                   if DICO = 'D', and the matrices A and -ISGN*B have
C                   almost reciprocal eigenvalues (that is, if lambda(i)
C                   and mu(j) are eigenvalues of A and -ISGN*B, then
C                   lambda(i) = 1/mu(j) for some i and j);
C                   perturbed values were used to solve the equation
C                   (but the matrices A and B are unchanged).
C
C     METHOD
C
C     An extension and refinement of the algorithms in [1,2] is used.
C     If the matrices A and/or B are not quasi-triangular (see PURPOSE),
C     they are reduced to Schur canonical form
C
C        A = U*S*U',  B = V*T*V',
C
C     where U, V are orthogonal, and S, T are block upper triangular
C     with 1-by-1 and 2-by-2 blocks on their diagonal. The right hand
C     side matrix C is updated accordingly,
C
C        C = U'*C*V;
C
C     then, the solution matrix X of the "reduced" Sylvester equation
C     (with A and B in (1) or (2) replaced by S and T, respectively),
C     is computed column-wise via a back substitution scheme. A set of
C     equivalent linear algebraic systems of equations of order at most
C     four are formed and solved using Gaussian elimination with
C     complete pivoting. Finally, the solution X of the original
C     equation is obtained from the updating formula
C
C        X = U*X*V'.
C
C     If A and/or B are already quasi-triangular (or in Schur form), the
C     initial factorizations and the corresponding updating steps are
C     omitted.
C
C     REFERENCES
C
C     [1] Bartels, R.H. and Stewart, G.W.  T
C         Solution of the matrix equation A X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is stable and reliable, since orthogonal
C     transformations and Gaussian elimination with complete pivoting
C     are used. If INFO = M+N+1, the Sylvester equation is numerically
C     singular.
C
C     CONTRIBUTORS
C
C     D. Sima, University of Bucharest, April 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Matrix algebra, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          DICO, FACTA, FACTB, TRANA, TRANB
      INTEGER            INFO, ISGN, LDA, LDB, LDC, LDU, LDV, LDWORK, M,
     $                   N
      DOUBLE PRECISION   SCALE
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ),  U( LDU, * ), V( LDV, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            BLAS3A, BLAS3B, BLOCKA, BLOCKB, CONT, NOFACA,
     $                   NOFACB, NOTRNA, NOTRNB, SCHURA, SCHURB
      INTEGER            AVAILW, BL, CHUNKA, CHUNKB, I, IA, IB, IERR, J,
     $                   JWORK, MAXWRK, MINWRK, SDIM
C     ..
C     .. Local Arrays ..
      LOGICAL            BWORK( 1 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME, SELECT
      EXTERNAL           LSAME, SELECT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DTRSYL,
     $                   SB04PY, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters
C
      CONT   = LSAME( DICO,  'C' )
      NOFACA = LSAME( FACTA, 'N' )
      NOFACB = LSAME( FACTB, 'N' )
      SCHURA = LSAME( FACTA, 'S' )
      SCHURB = LSAME( FACTB, 'S' )
      NOTRNA = LSAME( TRANA, 'N' )
      NOTRNB = LSAME( TRANB, 'N' )
C
      INFO = 0
      IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOFACA .AND. .NOT.LSAME( FACTA, 'F' ) .AND.
     $         .NOT.SCHURA ) THEN
         INFO = -2
      ELSE IF( .NOT.NOFACB .AND. .NOT.LSAME( FACTB, 'F' ) .AND.
     $         .NOT.SCHURB ) THEN
         INFO = -3
      ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND.
     $         .NOT.LSAME( TRANA, 'C' ) ) THEN
         INFO = -4
      ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND.
     $         .NOT.LSAME( TRANB, 'C' ) ) THEN
         INFO = -5
      ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
         INFO = -6
      ELSE IF( M.LT.0 ) THEN
         INFO = -7
      ELSE IF( N.LT.0 ) THEN
         INFO = -8
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDU.LT.1 .OR. ( .NOT.SCHURA .AND. LDU.LT.M ) ) THEN
         INFO = -12
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDV.LT.1 .OR. ( .NOT.SCHURB .AND. LDV.LT.N ) ) THEN
         INFO = -16
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -18
      ELSE
         IF ( NOFACA ) THEN
            IA = 1 + 2*M
            MINWRK = 3*M
         ELSE
            IA = 0
         END IF
         IF ( SCHURA ) THEN
            MINWRK = 0
         ELSE IF ( .NOT.NOFACA ) THEN
            MINWRK = M
         END IF
         IB = 0
         IF ( NOFACB ) THEN
            IB = 2*N
            IF ( .NOT.NOFACA )
     $         IB = IB + 1
            MINWRK = MAX( MINWRK, IB + 3*N )
         ELSE IF ( .NOT.SCHURB ) THEN
            MINWRK = MAX( MINWRK, N )
         END IF
         IF ( CONT ) THEN
            IF ( .NOT.SCHURA )
     $         MINWRK = MAX( MINWRK, IB + M )
         ELSE
            MINWRK = MAX( MINWRK, IB + 2*M )
         END IF
         MINWRK = MAX( 1, IA + MINWRK )
         IF( LDWORK.LT.MINWRK )
     $      INFO = -21
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB04PD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         SCALE = ONE
         DWORK( 1 ) = ONE
         RETURN
      END IF
      MAXWRK = MINWRK
C
      IF( NOFACA ) THEN
C
C        Compute the Schur factorization of A.
C        Workspace:  need   1+5*M;
C                    prefer larger.
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
         JWORK  = 2*M + 2
         IA     = JWORK
         AVAILW = LDWORK - JWORK + 1
         CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, A, LDA, SDIM,
     $               DWORK( 2 ), DWORK( M+2 ), U, LDU, DWORK( JWORK ),
     $               AVAILW, BWORK, IERR )
         IF( IERR.GT.0 ) THEN
            INFO = IERR
            RETURN
         END IF
         MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 )
      ELSE
         JWORK  = 1
         IA     = 2
         AVAILW = LDWORK
      END IF
C
      IF( .NOT.SCHURA ) THEN
C
C        Transform the right-hand side:  C <-- U'*C.
C        Workspace:  need   a+M,
C                    prefer a+M*N,
C                    where  a = 1+2*M, if FACTA =  'N',
C                           a = 0,     if FACTA <> 'N'.
C
         CHUNKA = AVAILW / M
         BLOCKA = MIN( CHUNKA, N ).GT.1
         BLAS3A = CHUNKA.GE.N .AND. BLOCKA
C
         IF ( BLAS3A ) THEN
C
C           Enough workspace for a fast BLAS 3 algorithm.
C
            CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M )
            CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, ONE,
     $                  U, LDU, DWORK( JWORK ), M, ZERO, C, LDC )
         ELSE IF ( BLOCKA ) THEN
C
C           Use as many columns of C as possible.
C
            DO 10 J = 1, N, CHUNKA
               BL = MIN( N-J+1, CHUNKA )
               CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC,
     $                      DWORK( JWORK ), M )
               CALL DGEMM( 'Transpose', 'NoTranspose', M, BL, M, ONE,
     $                     U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ),
     $                     LDC )
   10       CONTINUE
C
         ELSE
C
C           Use a BLAS 2 algorithm.
C
            DO 20 J = 1, N
               CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 )
               CALL DGEMV( 'Transpose', M, M, ONE, U, LDU,
     $                     DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 )
   20       CONTINUE
C
         END IF
         MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 )
      END IF
C
      IF( NOFACB ) THEN
C
C        Compute the Schur factorization of B.
C        Workspace:  need   1+MAX(a-1,0)+5*N,
C                    prefer larger.
C
         JWORK  = IA + 2*N
         AVAILW = LDWORK - JWORK + 1
         CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, B, LDB, SDIM,
     $               DWORK( IA ), DWORK( N+IA ), V, LDV, DWORK( JWORK ),
     $               AVAILW, BWORK, IERR )
         IF( IERR.GT.0 ) THEN
            INFO = IERR + M
            RETURN
         END IF
         MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 )
C
         IF( .NOT.SCHURA ) THEN
C
C           Recompute the blocking parameters.
C
            CHUNKA = AVAILW / M
            BLOCKA = MIN( CHUNKA, N ).GT.1
            BLAS3A = CHUNKA.GE.N .AND. BLOCKA
         END IF
      END IF
C
      IF( .NOT.SCHURB ) THEN
C
C        Transform the right-hand side:  C <-- C*V.
C        Workspace:  need   a+b+N,
C                    prefer a+b+M*N,
C                    where  b = 2*N,   if FACTB =  'N', FACTA =  'N',
C                           b = 1+2*N, if FACTB =  'N', FACTA <> 'N',
C                           b = 0,     if FACTB <> 'N'.
C
         CHUNKB = AVAILW / N
         BLOCKB = MIN( CHUNKB, M ).GT.1
         BLAS3B = CHUNKB.GE.M .AND. BLOCKB
C
         IF ( BLAS3B ) THEN
C
C           Enough workspace for a fast BLAS 3 algorithm.
C
            CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M )
            CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE,
     $                  DWORK( JWORK ), M, V, LDV, ZERO, C, LDC )
         ELSE IF ( BLOCKB ) THEN
C
C           Use as many rows of C as possible.
C
            DO 30 I = 1, M, CHUNKB
               BL = MIN( M-I+1, CHUNKB )
               CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC,
     $                      DWORK( JWORK ), BL )
               CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE,
     $                     DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ),
     $                     LDC )
   30       CONTINUE
C
         ELSE
C
C           Use a BLAS 2 algorithm.
C
            DO 40 I = 1, M
               CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 )
               CALL DGEMV( 'Transpose', N, N, ONE, V, LDV,
     $                     DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC )
   40       CONTINUE
C
         END IF
         MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 )
      END IF
C
C     Solve the (transformed) equation.
C     Workspace for DICO = 'D':  a+b+2*M.
C
      IF ( CONT ) THEN
         CALL DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC,
     $                SCALE, IERR )
      ELSE
         CALL SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC,
     $                SCALE, DWORK( JWORK ), IERR )
         MAXWRK = MAX( MAXWRK, JWORK + 2*M - 1 )
      END IF
      IF( IERR.GT.0 )
     $   INFO = M + N + 1
C
C     Transform back the solution, if needed.
C
      IF( .NOT.SCHURA ) THEN
C
C        Transform the right-hand side:  C <-- U*C.
C        Workspace:  need   a+b+M;
C                    prefer a+b+M*N.
C
         IF ( BLAS3A ) THEN
C
C           Enough workspace for a fast BLAS 3 algorithm.
C
            CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M )
            CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE,
     $                  U, LDU, DWORK( JWORK ), M, ZERO, C, LDC )
         ELSE IF ( BLOCKA ) THEN
C
C           Use as many columns of C as possible.
C
            DO 50 J = 1, N, CHUNKA
               BL = MIN( N-J+1, CHUNKA )
               CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC,
     $                      DWORK( JWORK ), M )
               CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE,
     $                     U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ),
     $                     LDC )
   50       CONTINUE
C
         ELSE
C
C           Use a BLAS 2 algorithm.
C
            DO 60 J = 1, N
               CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 )
               CALL DGEMV( 'NoTranspose', M, M, ONE, U, LDU,
     $                     DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 )
   60       CONTINUE
C
         END IF
      END IF
C
      IF( .NOT.SCHURB ) THEN
C
C        Transform the right-hand side:  C <-- C*V'.
C        Workspace:  need   a+b+N;
C                    prefer a+b+M*N.
C
         IF ( BLAS3B ) THEN
C
C           Enough workspace for a fast BLAS 3 algorithm.
C
            CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M )
            CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, ONE,
     $                  DWORK( JWORK ), M, V, LDV, ZERO, C, LDC )
         ELSE IF ( BLOCKB ) THEN
C
C           Use as many rows of C as possible.
C
            DO 70 I = 1, M, CHUNKB
               BL = MIN( M-I+1, CHUNKB )
               CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC,
     $                      DWORK( JWORK ), BL )
               CALL DGEMM( 'NoTranspose', 'Transpose', BL, N, N, ONE,
     $                     DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ),
     $                     LDC )
   70       CONTINUE
C
         ELSE
C
C           Use a BLAS 2 algorithm.
C
            DO 80 I = 1, M
               CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 )
               CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV,
     $                     DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC )
   80       CONTINUE
C
         END IF
      END IF
C
      DWORK( 1 ) = DBLE( MAXWRK )
C
      RETURN
C *** Last line of SB04PD ***
      END


! { dg-do compile }
! { dg-options "-O2 -fpeel-loops -finline-functions -fipa-cp-clone -fdump-ipa-inline-details" }

module TensorProducts
  use, intrinsic :: iso_fortran_env

  implicit none

  integer, parameter :: dp = real64 ! KIND for double precision

  type Vect3D
    real(dp) :: x, y, z
  end type

contains

  type(Vect3D) pure function MySum(array)
    type(Vect3D), intent(in) :: array(:,:)

    mysum = Vect3D(sum(array%x), sum(array%y), sum(array%z))
  end function

  pure subroutine GenerateGrid(N, M, width, height, centre, P)
    integer,      intent(in)  :: N, M
    real(dp),     intent(in)  :: width, height
    type(Vect3D), intent(in)  :: centre
    type(Vect3D), intent(out) :: P(N, M)
    real(dp)                  :: x(N), y(M)
    integer                   :: i, j

    x = ([( i, i = 0, N-1 )] * width/(N-1)) - (width / 2) + centre%x
    y = ([( j, j = 0, M-1 )] * height/(M-1)) - (height / 2) + centre%y
    do concurrent (i = 1:N)
      do concurrent (j = 1:M)
        P(i, j) = Vect3D(x(i), y(j), centre%z)
      end do
    end do
    P(2:3,2:3)%z = P(2:3,2:3)%z + 1.0_dp*reshape([2,1,1,-2], [2,2])
  end subroutine

  type(Vect3D) pure function TP_SUM(NU, D, NV) result(tensorproduct)
    ! (NU) D (NV)^T, row * matrix * column
    ! TODO (#6): TensorProduct: Investigate whether using DO loops triggers a temporary array.
    ! copied from Surfaces
    real(dp),     intent(in) :: NU(4), NV(4)
    type(Vect3D), intent(in) :: D(4,4)
    integer                  :: i, j
    type(Vect3D)             :: P(4,4)

    do concurrent (i = 1:4)
      do concurrent (j = 1:4)
        P(i,j)%x = NU(i) * D(i,j)%x * NV(j)
        P(i,j)%y = NU(i) * D(i,j)%y * NV(j)
        P(i,j)%z = NU(i) * D(i,j)%z * NV(j)
      end do
    end do
    tensorproduct = MySum(P)
  end function

  subroutine RandomSeed()
    integer                                 :: seed_size, clock, i
    integer,              allocatable, save :: seed(:)

    if (.not. allocated(seed)) then
      call random_seed(size=seed_size)
      allocate(seed(seed_size))
      call system_clock(count=clock)
      seed = clock + 37 * [( i -1, i = 1, seed_size )]
      call random_seed(put=seed)
    end if
  end subroutine

  subroutine RunTPTests()
    type(Vect3D)       :: tp, P(4,4)
    integer, parameter :: i_max = 10000000
    real(dp)           :: NU(4,i_max), NV(4,i_max)
    real(dp)           :: sum
    real               :: t(2)
    integer            :: i

!    print *, 'This code variant uses explicit %x, %y and %z to represent the contents of Type(Vect3D).'
    call GenerateGrid(4, 4, 20.0_dp, 20.0_dp, Vect3D(0.0_dp,0.0_dp,20.0_dp), P)
    call RandomSeed()
!    call cpu_time(t(1))
    do i = 1, 4
      call random_number(NU(i,:))
      call random_number(NV(i,:))
    end do
!    call cpu_time(t(2))
!    print *, 'Random Numbers, time:  ', t(2)-t(1)
    sum = 0.0
    call cpu_time(t(1))
    do i = 1, i_max
      tp = TP_SUM(NU(:,i), P(1:4,1:4), NV(:,i))
      sum = sum + tp%x
    end do
    call cpu_time(t(2))
    print *, 'Using SUM, time:       ', t(2)-t(1)
    print *, 'sum =', sum
  end subroutine

  end module

  program Main
  use TensorProducts

  implicit none

  call RunTPTests()
  end program

! { dg-final { scan-ipa-dump "Inlined tp_sum into runtptests" "inline" } }


!
! Example from ORNL OpenACC tutorial
!
!   https://www.olcf.ornl.gov/tutorials/openacc-vector-addition/#vecaddf90
!

program main

  ! Size of vectors
  integer :: n = 100000

  ! Input vectors
  real(8),dimension(:),allocatable :: a
  real(8),dimension(:),allocatable :: b
  ! Output vector
  real(8),dimension(:),allocatable :: c

  integer :: i
  real(8) :: sum

  ! Allocate memory for each vector
  allocate(a(n))
  allocate(b(n))
  allocate(c(n))

  ! Initialize content of input vectors, vector a[i] = sin(i)^2 vector b[i] = cos(i)^2
  do i=1,n
     a(i) = sin(i*1D0)*sin(i*1D0)
     b(i) = cos(i*1D0)*cos(i*1D0)
  enddo

  ! Sum component wise and save result into vector c

  !$acc kernels copyin(a(1:n),b(1:n)), copyout(c(1:n))
  do i=1,n
     c(i) = a(i) + b(i)
  enddo
  !$acc end kernels

  ! Sum up vector c and print result divided by n, this should equal 1 within error
  do i=1,n
     sum = sum +  c(i)
  enddo
  sum = sum/n
  print *, 'final result: ', sum

  ! Release memory
  deallocate(a)
  deallocate(b)
  deallocate(c)

end program main


!**********************************************************************
!   twod.f90 - a solution to the Poisson problem by using Jacobi
!   interation on a 2-d decomposition
!
!   .... the rest of this is from pi3.f to show the style ...
!
!   Each node:
!    1) receives the number of rectangles used in the approximation.
!    2) calculates the areas of it's rectangles.
!    3) Synchronizes for a global summation.
!   Node 0 prints the result.
!
!  Variables:
!
!    pi  the calculated result
!    n   number of points of integration.
!    x           midpoint of each rectangle's interval
!    f           function to integrate
!    sum,pi      area of rectangles
!    tmp         temporary scratch space for global summation
!    i           do loop index
!
!     This code is included (without the prints) because one version of
!     MPICH SEGV'ed (probably because of errors in handling send/recv of
!     MPI_PROC_NULL source/destination).
!
!****************************************************************************
      program main
      use mpi
      integer maxn
      parameter (maxn = 128)
      double precision  a(maxn,maxn), b(maxn,maxn), f(maxn,maxn)
      integer nx, ny
      integer myid, numprocs, it, rc, comm2d, ierr, stride
      integer nbrleft, nbrright, nbrtop, nbrbottom
      integer sx, ex, sy, ey
      integer dims(2)
      logical periods(2)
      double precision diff2d, diffnorm, dwork
      double precision t1, t2
      external diff2d
      data periods/2*.false./

      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
!      print *, "Process ", myid, " of ", numprocs, " is alive"
      if (myid .eq. 0) then
!
!         Get the size of the problem
!
!          print *, 'Enter nx'
!          read *, nx
           nx = 10
      endif
!      print *, 'About to do bcast on ', myid
      call MPI_BCAST(nx,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
      ny   = nx
!
! Get a new communicator for a decomposition of the domain.  Let MPI
! find a "good" decomposition
!
      dims(1) = 0
      dims(2) = 0
      call MPI_DIMS_CREATE( numprocs, 2, dims, ierr )
      call MPI_CART_CREATE( MPI_COMM_WORLD, 2, dims, periods, .true., &
                            comm2d, ierr )
!
! Get my position in this communicator
!
      call MPI_COMM_RANK( comm2d, myid, ierr )
!      print *, "Process ", myid, " of ", numprocs, " is alive"
!
! My neighbors are now +/- 1 with my rank.  Handle the case of the
! boundaries by using MPI_PROCNULL.
      call fnd2dnbrs( comm2d, nbrleft, nbrright, nbrtop, nbrbottom )
!      print *, "Process ", myid, ":",
!     *     nbrleft, nbrright, nbrtop, nbrbottom
!
! Compute the decomposition
!
      call fnd2ddecomp( comm2d, nx, sx, ex, sy, ey )
!      print *, "Process ", myid, ":", sx, ex, sy, ey
!
! Create a new, "strided" datatype for the exchange in the "non-contiguous"
! direction
!
      call mpi_Type_vector( ey-sy+1, 1, ex-sx+3, &
                            MPI_DOUBLE_PRECISION, stride, ierr )
      call mpi_Type_commit( stride, ierr )
!
!
! Initialize the right-hand-side (f) and the initial solution guess (a)
!
      call twodinit( a, b, f, nx, sx, ex, sy, ey )
!
! Actually do the computation.  Note the use of a collective operation to
! check for convergence, and a do-loop to bound the number of iterations.
!
      call MPI_BARRIER( MPI_COMM_WORLD, ierr )
      t1 = MPI_WTIME()
      do it=1, 100
	call exchng2( b, sx, ex, sy, ey, comm2d, stride, &
                      nbrleft, nbrright, nbrtop, nbrbottom )
	call sweep2d( b, f, nx, sx, ex, sy, ey, a )
	call exchng2( a, sx, ex, sy, ey, comm2d, stride, &
                      nbrleft, nbrright, nbrtop, nbrbottom )
	call sweep2d( a, f, nx, sx, ex, sy, ey, b )
	dwork = diff2d( a, b, nx, sx, ex, sy, ey )
	call MPI_Allreduce( dwork, diffnorm, 1, MPI_DOUBLE_PRECISION, &
                            MPI_SUM, comm2d, ierr )
        if (diffnorm .lt. 1.0e-5) exit
        if (myid .eq. 0) print *, 2*it, ' Difference is ', diffnorm
      enddo
      t2 = MPI_WTIME()
      if (myid .eq. 0 .and. it .gt. 100) print *, 'Failed to converge'
!      if (myid .eq. 0) then
!         print *, 'Converged after ', 2*it, ' Iterations in ', t2 - t1,
!     $        ' secs '
!      endif
!
      call MPI_Type_free( stride, ierr )
      call MPI_Comm_free( comm2d, ierr )
      call MPI_FINALIZE(rc)
      end


      subroutine advance(u, u_n, u_nm1, f, Cx2, Cy2, dt2, Nx, Ny)
      integer Nx, Ny
      real*8 u(0:Nx,0:Ny), u_n(0:Nx,0:Ny), u_nm1(0:Nx,0:Ny)
      real*8 f(0:Nx,0:Ny), Cx2, Cy2, dt2
      integer i, j
      real*8 u_xx, u_yy
Cf2py intent(in, out) u

C     Scheme at interior points
      do j = 1, Ny-1
         do i = 1, Nx-1
            u_xx = u_n(i-1,j) - 2*u_n(i,j) + u_n(i+1,j)
            u_yy = u_n(i,j-1) - 2*u_n(i,j) + u_n(i,j+1)
            u(i,j) = 2*u_n(i,j) - u_nm1(i,j) + Cx2*u_xx + Cy2*u_yy +
     &               dt2*f(i,j)
         end do
      end do

C     Boundary conditions
      j = 0
      do i = 0, Nx
         u(i,j) = 0
      end do
      j = Ny
      do i = 0, Nx
         u(i,j) = 0
      end do
      i = 0
      do j = 0, Ny
         u(i,j) = 0
      end do
      i = Nx
      do j = 0, Ny
         u(i,j) = 0
      end do
      return
      end


c
c     a subroutine for testing all scalar analysis and synthesis subroutines
c
      program tsha
c
c     set dimensions with parameter statements
c
      parameter(nnlat= 15,nnlon= 18, nnt = 3)
c     parameter(nnlat=14,nnlon=20,nnt=3)
      parameter (lleng= 5*nnlat*nnlat*nnlon,llsav= 5*nnlat*nnlat*nnlon)
      parameter (lldwork = nnlat*(nnlat+4))
      double precision dwork(lldwork)
      dimension work(lleng),wsave(llsav)
      dimension a(nnlat,nnlat,nnt),b(nnlat,nnlat,nnt),s(nnlat,nnlon,nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      lwork = lleng
      lsave = llsav
      nt = nnt
      call iout(nlat,4hnlat)
      call iout(nlon,4hnlon)
      call iout(nt,4h  nt)
      isym = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      ldwork = lldwork
      call gaqd(nlat,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name(4hgaqd)
      call iout(ier,4h ier)
      call vecout(thetag,4hthtg,nlat)
c
c     test all analysis and synthesis subroutines
c
      do icase=1,4
c
c     icase=1 test shaec,shsec
c     icase=2 test shaes,shses
c     icase=3 test shagc,shsgc
c     icase=4 test shags,shsgs
c
      call name(4h****)
      call name(4h****)
      call iout(icase,4hicas)
c
c
c     set scalar field as (x*y*z)**k) restricted to the sphere
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    xyzk = (sint*(sint*cost*sinp*cosp))**k
c           s(i,j,k) = exp(xyzk)
	    s(i,j,k) = xyzk
	  end do
	end do
c     call iout(k,4h   k)
c     call aout(s(1,1,k),4h   s,nlat,nlon)
      end do

      do l=1,lsave
	wsave(l) = 0.0
      end do
      if (icase.eq.1) then

      call name(4h**ec)
      call shaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)

      call name(4hshai)
      call iout(ierror,4hierr)

      call shaec(nlat,nlon,isym,nt,s,nlat,nlon,a,b,nlat,nlat,wsave,
     +lsave,work,lwork,ierror)

      call name(4hsha )
      call iout(ierror,4hierr)

      call shseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)

      call name(4hshsi)
      call iout(ierror,4hierr)

      call shsec(nlat,nlon,isym,nt,s,nlat,nlon,a,b,nlat,nlat,wsave,
     +lsave,work,lwork,ierror)

      call name(4hshs )
      call iout(ierror,4hierr)

      else if (icase.eq.2) then

      call name(4h**es)
      call shaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)

      call name(4hshai)
      call iout(ierror,4hierr)

      call shaes(nlat,nlon,isym,nt,s,nlat,nlon,a,b,nlat,nlat,wsave,
     +lsave,work,lwork,ierror)

      call name(4hsha )
      call iout(ierror,4hierr)

      call shsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)

      call name(4hshsi)
      call iout(ierror,4hierr)

      call shses(nlat,nlon,isym,nt,s,nlat,nlon,a,b,nlat,nlat,wsave,
     +lsave,work,lwork,ierror)

      call name(4hshs )
      call iout(ierror,4hierr)

      else if (icase.eq.3) then

      call name(4h**gc)

      call shagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)

      call name(4hshai)
      call iout(ierror,4hierr)

      call shagc(nlat,nlon,isym,nt,s,nlat,nlon,a,b,nlat,nlat,wsave,
     +lsave,work,lwork,ierror)

      call name(4hsha )
      call iout(ierror,4hierr)

      call shsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)

      call name(4hshsi)
      call iout(ierror,4hierr)

      call shsgc(nlat,nlon,isym,nt,s,nlat,nlon,a,b,nlat,nlat,wsave,
     +lsave,work,lwork,ierror)

      call name(4hshs )
      call iout(ierror,4hierr)

      else if (icase.eq.4) then

      call name(4h**gs)

      call shagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)

      call name(4hshai)
      call iout(ierror,4hierr)

      call shags(nlat,nlon,isym,nt,s,nlat,nlon,a,b,nlat,nlat,wsave,
     +lsave,work,lwork,ierror)

      call name(4hsha )
      call iout(ierror,4hierr)

      call shsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hshsi)
      call iout(ierror,4hierr)

      call shsgs(nlat,nlon,isym,nt,s,nlat,nlon,a,b,nlat,nlat,wsave,
     +lsave,work,lwork,ierror)

      call name(4hshs )
      call iout(ierror,4hierr)
      end if
c
c     compute "error" in s
c
      err2 = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta = thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    xyzk = (sint*(sint*cost*sinp*cosp))**k
c           err2 = err2+ (exp(xyzk)-s(i,j,k))**2
	    err2 = err2 + (xyzk-s(i,j,k))**2
	  end do
	end do
c     call iout(k,4h   k)
c     call aout(s(1,1,k),4h   s,nlat,nlon)
      end do
      err2 = sqrt(err2/(nt*nlat*nlon))
      call vout(err2,4herr2)
      end do
      end
      subroutine iout(ivar,nam)
      real nam
      write(6,10) nam , ivar
   10 format(1h a4, 3h = ,i8)
      return
      end
c
      subroutine vout(var,nam)
      real nam
      write(6,10) nam , var
   10 format(1h a4,3h = ,e12.5)
      return
      end
c
      subroutine name(nam)
      real nam
      write(6,100) nam
  100 format(1h a8)
      return
      end
c
      subroutine vecout(vec,nam,len)
      dimension vec(len)
      real nam
      write(6,109) nam, (vec(l),l=1,len)
  109 format(1h a4,/(1h 8e11.4))
      return
      end


      SUBROUTINE FRR1A1 (RZ,CZ,IB,REB,CEB)
C
      COMPLEX   Z,SUM,ZK,TERM
C
      Z  = CMPLX(RZ,CZ)
      IF (CABS(Z) .LT. .1) GO TO 100
      ZK  = CMPLX(1.,0.)
      N   = IB
      BF  = 1.
      BF1 = 0.
      SUM = CMPLX(0.,0.)
      DO 10 I = 1,N
      SUM = SUM + ZK/CMPLX(BF,0.)
      ZK  = ZK*Z
      BF1 = BF1 + 1.
      BF  = BF*BF1
   10 CONTINUE
      ZK  = CMPLX(BF,0.)/ZK*(CEXP(Z)-SUM)
      REB = REAL(ZK)
      CEB = AIMAG(ZK)
      RETURN
C
  100 CONTINUE
      ZK  = Z
      DEN = FLOAT(IB) + 1.
      SUM = CMPLX(1.,0.)
      DO 20 I = 1,30
      TERM= ZK/DEN
      SUM = SUM + TERM
      IF (CABS(TERM) .LT. 1.E-9) GO TO 200
      ZK  = ZK*Z
      DEN = DEN*(FLOAT(IB)+ FLOAT(I+1))
   20 CONTINUE
  200 REB = REAL(SUM)
      CEB = AIMAG(SUM)
      RETURN
      END


!Calculate the Gauss integral between a pair of line segments (half the contribution to the writhe)
!Based on methods by Klenin (2000)

subroutine gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
   use params, only: dp
   implicit none

   real(dp), PARAMETER :: PI = 3.141592654d0 ! Value of pi

   real(dp), intent(in) :: R1(3), R2(3)  ! PositionS
   real(dp), intent(in) :: e1(3), e2(3)  ! segment orientations
   real(dp), intent(in) :: s1, s2        ! segment lenghts
   !Geometric variables
   real(dp) r12(3)                 ! Relative position vector
   real(dp) beta                   ! Angle between tangents
   real(dp) cosB
   real(dp) sin2B
   real(dp) e3(3)
   real(dp) a0
   real(dp) a1
   real(dp) a2
   real(dp) a3
   real(dp) b
   !Variables for writhe integral
   real(dp) t1
   real(dp) t2
   real(dp) F1
   real(dp) F2
   real(dp) F3
   real(dp) F4

   !Counter variables
   integer I, J
   real(dp), intent(out) :: dWr      ! Writhe

   r12 = R2 - R1
   dWr = 0.

   cosB = doT_PRODUCT(e1, e2)
   B = ACOS(cosB)

   sin2B = sin(B)**2.
   e3(1) = e1(2)*e2(3) - e1(3)*e2(2)
   e3(2) = e1(3)*e2(1) - e1(1)*e2(3)
   e3(3) = e1(1)*e2(2) - e1(2)*e2(1)

   if (abs(sin2B) .lt. (10.**(-15.))) then
      sin2b = 0.
   endif

   a1 = doT_PRODUCT(r12, e2*cosB - e1)/(sin2B)
   a2 = doT_PRODUCT(r12, e2 - e1*cosB)/sin2B
   a0 = doT_PRODUCT(r12, e3)/sin2B

   t1 = a1 + s1
   t2 = a2 + s2
   F1 = -ATAN((t1*t2 + (a0**2.)*cosB)/(a0*SQRT((t1**2.+t2**2.-2.*t1*t2*cosB + (a0**2.)*sin2B))))/(4.*PI)
   t1 = a1 + s1
   t2 = a2
   F2 = -ATAN((t1*t2 + (a0**2.)*cosB)/(a0*SQRT((t1**2.+t2**2.-2.*t1*t2*cosB + (a0**2.)*sin2B))))/(4.*PI)
   t1 = a1
   t2 = a2 + s2
   F3 = -ATAN((t1*t2 + (a0**2.)*cosB)/(a0*SQRT((t1**2.+t2**2.-2.*t1*t2*cosB + (a0**2.)*sin2B))))/(4.*PI)
   t1 = a1
   t2 = a2
   F4 = -ATAN((t1*t2 + (a0**2.)*cosB)/(a0*SQRT((t1**2.+t2**2.-2.*t1*t2*cosB + (a0**2.)*sin2B))))/(4.*PI)
   dWr = F1 - F2 - F3 + F4

   !Gauss integral = 0 for segments in plane (dWr = NaN)
   if (dWr /= dWr) then
      dWr = 0.
   endif
   !Set dwr = 0 for segments nearly in-plane to avoid errors due to floating point
   if (abs(a0) < 10.**(-12.)) then
      dWr = 0.
   endif

   RETURN
END subroutine gauss_pair


*
* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
* See https://llvm.org/LICENSE.txt for license information.
* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
*

! RUN: %clang -c %S/check.c -o %t1
! RUN: %flang -c -I%S -lm %s -o %t2
! RUN: %flang -I%S -lm %t2 %t1 -o %t3
! RUN: %t3 | tee %t4 &&  grep '  6 tests completed. 6 tests PASSED. 0 tests failed.' %t4

*   Intrinsics and generics: trigonometric and hyperbolic functions.

	program p
	implicit complex (c), double precision (d), double complex(z)
	parameter(n=6)
	integer rslts(n), expect(n), ctoi, dtoi
	parameter (d_dr=0.174532925199432957692D-1)
	parameter (r_dr=0.174532925199432957692E-1)
	parameter (d_rd=0.572957795130823208769D+2)
	parameter r_rd=0.572957795130823208769E+2

	dtoi(d) = d * 1000 + .499
	ctoi(c) = 1000 * (real(c) + aimag(c))
	ztoi(z) = 1000 * (real(z) + dimag(z))
	d_dtor(d) = d_dr*d
	d_rtod(d) = d_rd*d
	r_dtor(r) = r_dr*r
	r_rtod(r) = r_rd*r

	data x3, xx3 / 2 * 3.0 /,  d1, cx / 1.0d0, (1.0,2.0) /
	data zx/(1.0d0,2.0d0)/

	rslts(1) = nint(acos(1.0) * 100)
	rslts(2) = 100 * dacos(.93969 * 1d0) + .2
	rslts(3) = acos(1.0d0) + x3 + .01
	rslts(4) = nint(r_dtor(acosd(1.0)) * 100)
	rslts(5) = 100 * d_dtor(dacosd(.93969 * 1d0)) + .2
	rslts(6) = d_dtor(acosd(1.0d0)) + x3 + .01

c --- check results:

	call check(rslts, expect, n)

	data expect / 0, 35, 3, 0, 35, 3 /
	end


!-------------------------------------------------------------------------------
!
!> \file    ArrowSolver.f90
!> \brief   Solve a system of simultaneous linear equations with a
!!           symmetric arrow matrix.
!> \author  M.H.A. Piro
!> \date    September 19, 2012
!
!
! Revisions:
! ==========
!
!   Date            Programmer          Description of change
!   ----            ----------          ---------------------
!   09/19/2012      M.H.A. Piro         Original code
!   03/20/2013      M.H.A. Piro         Allow for multiple rows of the arrow
!                                        head.
!
!
! Purpose:
! ========
!
!> \details The purpose of this subroutine is to solve a real system of linear
!! equations Ax = b where A is an n-by-n symmetric arrow matrix and x and b are
!! N vectors.  An arrow matrix is sparse everywhere except for the diagonal
!! (i.e., A(i,i) /= 0 except A(n,n) == 0), and the bottom row/extreme right column.
!! In other words, this matrix resembles the shape of an arrow head.  The arrow head
!! can be represented by a single row/column pair or by multiple rows/columns.  This
!! is defined by m.
!!
!! This subroutine effectively performs Gaussian elimination on only the bottom
!! m rows.  Computational expense is further reduced for this specific problem when
!! performing back subsituation by exploiting the sparsity of the A matrix.
!! This subroutine returns an error via the INFO variable if an error has been
!! detected.  The possible values for INFO are summarized below:
!!
!! INFO        Description
!! ----        -----------
!!   0         Successful exit.
!!  -1         m is equal to or less than zero.
!!  -2         n is equal to or less than zero.
!!  -3         m is greater than or equal to n.
!!  -10        The system of linear equations contains an inconsistent row.
!!   i         The row corresponding to i (where i > 0) in B contains a NAN.
!!
!
!
!
! Pertinent variables:
! ====================
!
!> \param[in]     m         An integer scalar representing the number of rows
!!                            corresponding to the arrow head.
!> \param[in]     n         An integer scalar representing the number of linear
!!                            equations.
!> \param[in]     A         A double real array represending the A matrix.
!> \param[in,out] B         A double real vector (dimension n)   representing
!!                            the functional vector on input and on output it
!!                            represents the solution vector.
!> \param[out]    INFO      An integer scalar indicating a successful exit or
!!                            an error.
!!
! Local variables:
! ----------------
! i, j, k                   Integer scalars used for indexing.
! dMultiplier               A double real scalar used for calculating the
!                            multiplier in Gaussian elimination.
!
!-------------------------------------------------------------------------------

subroutine ArrowSolver(m, n, A, B, INFO)

    implicit none

    integer                                :: i, j, k
    integer,                 intent(out)   :: INFO
    integer,                 intent(inout) :: m, n
    real(8)                                :: dMultiplier
    real(8), dimension(n,n), intent(inout) :: A
    real(8), dimension(n),   intent(inout) :: B

    ! Initialize variables:
    INFO = 0

    ! Ensure that input parameters are within bounds:
    if (m <= 0) then
        INFO = -1
        return
    elseif (n <= 0) then
        INFO = -2
        return
    elseif (m >= n) then
        INFO = -3
        return
    end if

    ! Loop through number of rows representing the arrow head:
    LOOP_ArrowHead: do k = n - m + 1, n

        ! Loop through columns along the diagonal:
        LOOP_Column: do j = 1, k - 1

            ! Cycle if the coefficient is zero:
            if (A(k,j) == 0D0) cycle LOOP_Column

            ! Compute the multiplier:
            dMultiplier = A(j,j) / A(k,j)

            ! Update all columns along row:
            A(k,j) = 0D0
            do i = j + 1, n
                A(k,i) = dMultiplier * A(k,i) - A(j,i)
            end do

            ! Update solution vector component:
            B(k) = dMultiplier * B(k) - B(j)

        end do LOOP_Column

    end do LOOP_ArrowHead

    ! Check if the system of equations contains an inconsistent row:
    IF_NULL: if (A(n,n) /= 0D0) then

        ! Perform back-step calculation:
        B(n) = B(n) / A(n,n)

        ! Loop backwards:
        LOOP_Back: do i = (n - 1), (1), (-1)

            ! Reinitialize temporary variable:
            dMultiplier = B(i)

            ! Loop along column:
            LOOP_Inner: do j = n, (n - m), (-1)
                ! Exit if the diagonal has been reached:
                if (j <= i) exit LOOP_Inner
                dMultiplier = dMultiplier - A(i,j) * B(j)
            end do LOOP_Inner

            ! Update the solution vector component:
            B(i) = dMultiplier / A(i,i)

        end do LOOP_Back
    else

        ! The system contains an inconsistent row.  Return an error:
        INFO = -10

    end if IF_NULL

    ! Check for a NAN:
    LOOP_NAN: do i = 1, n

        if (B(i) /= B(i)) then
            ! A NAN has been detected; report an error corresponding
            ! to the row of the first NAN and reset the solution vector.
            INFO = i
            B    = 0D0
            exit LOOP_NAN
        end if

    end do LOOP_NAN

    return

end subroutine ArrowSolver


! loosely translated from python.  We do not need to generate and store the entire vector at once.
! compilation: gfortran -Wall -std=f2008 -o thisfile thisfile.f08

program percolation_mean_run_density
  implicit none
  integer :: i, p10, n2, n, t
  real :: p, limit, sim, delta
  data n,p,t/100,0.5,500/
  write(6,'(a3,a5,4a7)')'t','p','n','p(1-p)','sim','delta%'
  do p10=1,10,2
     p = p10/10.0
     limit = p*(1-p)
     write(6,'()')
     do n2=10,15,2
        n = 2**n2
        sim = 0
        do i=1,t
           sim = sim + mean_run_density(n,p)
        end do
        sim = sim/t
        if (limit /= 0) then
           delta = abs(sim-limit)/limit
        else
           delta = sim
        end if
        delta = delta * 100
        write(6,'(i3,f5.2,i7,2f7.3,f5.1)')t,p,n,limit,sim,delta
     end do
  end do

contains

  integer function runs(n, p)
    integer, intent(in) :: n
    real, intent(in) :: p
    real :: harvest
    logical :: q
    integer :: count, i
    count = 0
    q = .false.
    do i=1,n
       call random_number(harvest)
       if (harvest < p) then
          q = .true.
       else
          if (q) count = count+1
          q = .false.
       end if
    end do
    runs = count
  end function runs

  real function mean_run_density(n, p)
    integer, intent(in) :: n
    real, intent(in) :: p
    mean_run_density = real(runs(n,p))/real(n)
  end function mean_run_density

end program percolation_mean_run_density


      subroutine surface(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
C
C
C#######################################################################
C
C     PURPOSE -
C
C        THIS ROUTINE DEFINES A BOUNDARY SURFACE OF THE SPECIFIED TYPE.
C        THE SURFACE TYPE IS SPECIFIED BY istype AND DESCRIBED
C        BY x1 to z4.
C
C
C     FORMAT: SURFACE/ISURNAME/IBTYPE/ISTYPE/X1/Y1/Z1/X2/Y2/Z2/
C                                          X3/Y3/Z3/X4/Y4/Z4
C      SPECIFICALLY:
C        SURFACE/ISURNAME/IBTYPE/plane/x1,y1,z1/x2,y2,z2/x3,y3,z3
C        SURFACE/isurname/IBTYPE/PLANEXYZ/x1,y1,z1/x2,y2,z2/x3,y3,z3
C        SURFACE/isurname/IBTYPE/PLANERTZ/radius1,theta1,z1,
C                                         radius2,theta2,z2,
C                                         radius3,theta3,z3,
C                                         xcen,ycen
C        SURFACE/isurname/IBTYPE/PLANERTP/radius1,theta1,phi1,
C                                         radius2,theta2,phi2,
C                                         radius3,theta3,phi3,
C                                         xcen,ycen,zcen
C        SURFACE/ISURNAME/IBTYPE/box/xmin,ymin,zmin/xmax,ymax,zmax
C        SURFACE/ISURNAME/IBTYPE/paralell/x1,y1,z1/x2,y2,z2/x3,y3,z3/
C                                         x4,y4,z4
C             WHERE POINTS 1, 2,  3 ARE THE FRONT LEFT, FRONT RIGHT
C                   AND BACK LEFT POINTS OF THE BASE AND POINT 4 IS
C                   THE UPPER LEFT POINT OF THE FRONT FACE.
C        SURFACE/ISURNAME/IBTYPE/sphere/xcen,ycen,zcen/radius
C        SURFACE/ISURNAME/IBTYPE/cylinder/x1,y1,z1/x2,y2,z2/radius
C             WHERE POINT 1 IS THE BOTTOM CENTER AND POINT 2 IS THE TOP
C                   CENTER OF THE CYLINDER.
C        SURFACE/ISURNAME/IBTYPE/cone/x1,y1,z1/x2,y2,z2/radius
C             WHERE POINT 1 IS THE VERTEX AND POINT 2 IS THE TOP
C                   CENTER OF THE CONE WITH RADIUS FROM THIS POINT.
C        SURFACE/ISURNAME/IBTYPE/ellipse/x1,y1,z1/x2,y2,z2/x3,y3,z3/
C                                        ar,br,cr
C             WHERE POINT 1 IS THE CENTER OF THE ELLIPSOID, POINT 2 IS
C                   ON THE a SEMI-AXIS, POINT 3 IS ON THE b SEMI-AXIS,
C                   AND ar, br, cr ARE RADII ALONG THEIR RESPECTIVE
C                   SEMI-AXES.
C        SURFACE/ISURNAME/IBTYPE/tabular/x1,y1,z1/x2,y2,z2/igeom
C                r1,z1, r2,z2, r3,z3,....
C                ...., rn,zn, end
C                       OR
C                r1,theta1, r2,theta2, r3,theta3,....
C                ...., rn,thetan, end
C             WHERE POINT 1 AND POINT 2 DEFINE THE AXIS OF ROTAION
C                   FOR THE TABULAR PROFILE WITH POINT 1 AS THE ORIGIN.
C                   THIS IS FOLLOWED BY PAIRS OF PROFILE DESCRIPTORS
C                   DEPENDING ON THE VALUE OF igeom.  IF igeom IS SET
C                   TO rz THEN THE R VALUE IS A RADIUS NORMAL TO THE
C                   AXIS OF ROTAION AND Z IS THE DISTANCE ALONG THE
C      REFLECTED BOUNDARY-POINT INFORMATION.
C                   NEW AXIS OF ROTATION.  IF igeom IS SET TO rt
C                   THEN THETA IS THE ANGLE FROM THE AXIS OF ROTATION
C                   AT POINT 1 AND R IS THE DISTANCE FROM POINT 1 ALONG
C                   THETA.  THE FIRST PAIR MUST START ON A NEW LINE AND
C                   ALL LINES MUST CONTAIN PAIRS OF DATA.  THE LAST PAIR
C                   OF DATA MUST BE FOLLOWED BY end.
C        SURFACE/ISURNAME/IBTYPE/sheet/nx/ny
C                 x1 y1 z1
C                 x2 y2 z2
C                 .
C                 xn yn zn
C                    This format is useful for reading a file that
C                    is a set of xyz triplets with the SURFACE command
C                    as the first line of the file. The file can be
C                    read in with the INPUT / filename command.
C
C        SURFACE/ISURNAME/IBTYPE/sheet/x1,y1,z1/x2,y2,z2/x3,y3,z3/igeom/
C                                      nx/ny
C                x1,y1,z1, x2,y2,z2, x3,y3,z3, ...
C                ...., xn,yn,zn, end
C                       OR
C                theta1,z1,r1, theta2,z2,r2, theta3,z3,r3, ...
C                ...., thetan,zn,rn, end
C                       OR
C                theta1,phi1,r1, theta2,phi2,r2, theta3,phi3,r3, ...
C                ...., thetan,phin,rn, end
C                       OR
C                points/ipt1,ipt2,ipt3
C             SHEET SURFACES ARE OPEN SURFACES THAT ARE DEFINED BY A
C             LOGICAL GRID WITH nx*ny GRID POINTS.  nx IS THE NUMBER OF
C             ROWS AND ny IS THE NUMBER OF COLUMNS IN THE GRID.  ALL
C             DATA IS ENTERED IN ROW-WISE ORDER AND THE TRIPLETS DEF-
C             INING EACH POINT IS OF THE TYPE AND ORDER SET IN igeom.
C             THE ALLOWABLE igeom VALUES ARE 'xyz', 'tzr' and 'tpr'.
C             THE 3 INPUT POINTS (x1 TO z3) DEFINE A NEW COORDINATE
C             SYSTEM.  POINT 1 (x1,y1,z1) IS THE NEW ORIGIN, THE LINE
C             BETWEEN POINTS 1 AND 2 IS THE NEW X-AXIS AND POINT 3
C             LIES ON THE NEW XY PLANE.  THE NEW Z-AXIS IS NORMAL TO
C             THE NEW XY PLANE.
C             WHEN igeom IS xyz THEN THE Z VALUES ARE MEASURDED FROM
C                   THE NEW XY PLANE.  THERE CAN ONLY BE ONE Z VALUE
C                   PER XY PAIR.  ANYTHING BELOW THE SHEET WITHIN
C                   THE GRID BOUNDS IS INSIDE THE SURFACE.
C             WHEN igeom IS tzr THEN THE r VALUE IS MEASURED FROM
C                   THE NEW Z AXIS, z IS MEASURED FROM THE ORIGIN
C                   AND theta IS MEASURED FROM THE NEW XZ PLANE.
C                   r VALUES MUST BE POSITIVE AND THERE CAN ONLY BE
C                   ONE PER tz PAIR.  ANYTHING BETWEEN THE REFERENCE
C                   LINE AND THE SHEET IS INSIDE THE SURFACE.
C             WHEN igeom IS tpr THEN THE r VALUE IS MEASURED FROM
C                   THE REFERNCE POINT, theta IS MEASURED FROM THE NEW
C                   X-AXIS AND phi IS MEASURED FROM THE NEW Z-AXIS.
C                   r VALUES MUST BE POSITIVE AND THERE CAN ONLY BE
C                   ONE PER tp PAIR.  ANYTHING BETWEEN THE REFERENCE
C                   POINT AND THE SHEET IS INSIDE THE SURFACE.
C
C     INPUT ARGUMENTS -
C
C         imsgin()  - Integer array of command input tokens
C         xmsgin()  - Real array of command input tokens
C         cmsgin()  - Character array of command input tokens
C         msgtype() - Integer array of command input token types
C         nwds      - Number of command input tokens
C
C        THESE ARE CONVERTED TO THE FOLLOWING:
C
C           isurnam - NAME FOR THIS SURFACE USED AS PATH TO STORAGE BLOCK
C           ibtype  - TYPE OF BOUNDARY: FREE, INTRFACE, REFLECT,
C                                    VIRTUAL OR INTRCONS
C           istype  - TYPE OF SURFACE: PLANE, SPHERE, CYLINDER, CONE,
C                                  BOX, PARALLELpiped
C           x1--z4  - PHYSICAL DESCRIPTION OF THE SURFACE, 4 POINTS
C                     FOR A PLANE, CENTER POINT AND RADIUS FOR A SPHERE,
C                     MIN. AND MAX. POINTS FOR A BOX, 4 POINTS FOR A
C                     PARALLELPIPED, 2 END CENTER POINTS AND RADIUS FOR
C                     A CYLINDER, 2 END CENTER POINTS AND 2 RADII FOR A
C                     CONE.
C
C     OUTPUT ARGUMENTS -
C
C         ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
C
C     CHANGE HISTORY -
C
C        $Log: surface.f,v $
C        Revision 2.00  2007/11/09 20:04:04  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.12   23 Mar 2001 15:02:02   dcg
CPVCS    fix error with cube type - save at correct offset
CPVCS
CPVCS       Rev 1.11   18 Apr 2000 13:24:34   dcg
CPVCS    implement release option for surfaces, regions and mregions
CPVCS
CPVCS       Rev 1.10   13 Apr 2000 16:50:16   dcg
CPVCS    add release surface option
CPVCS
CPVCS       Rev 1.9   Wed Apr 05 16:34:00 2000   dcg
CPVCS    allow 'interface' as well as 'intrface' for surface type
CPVCS
CPVCS       Rev 1.8   Wed Apr 05 13:35:08 2000   nnc
CPVCS    Minor source modifications required by the Absoft compiler.
CPVCS
CPVCS       Rev 1.7   20 Mar 2000 13:42:04   dcg
CPVCS    check for duplicate name - if so then print warning and skip command
CPVCS
CPVCS       Rev 1.6   24 Feb 2000 12:57:22   dcg
CPVCS    use geom_name when increasing mm surface definition block
CPVCS
CPVCS       Rev 1.5   24 Feb 2000 11:16:36   dcg
CPVCS    use type=3 for character arrays
CPVCS
CPVCS       Rev 1.4   Wed Feb 02 11:55:44 2000   dcg
CPVCS
CPVCS       Rev 1.3   13 Jan 2000 14:49:28   dcg
CPVCS
CPVCS       Rev 1.2   06 Jan 2000 12:55:16   dcg
CPVCS
CPVCS       Rev 1.35   Wed Nov 10 09:35:08 1999   dcg
CPVCS    remove test on miscellaneous storage block
CPVCS
CPVCS       Rev 1.34   Fri Sep 03 15:48:16 1999   dcg
CPVCS    tabular surface data read in as part of command
CPVCS
CPVCS       Rev 1.33   Fri Apr 17 10:09:48 1998   gable
CPVCS    Add some comments about the /sheet/nx/ny option.
CPVCS
CPVCS       Rev 1.32   Fri Oct 31 10:50:32 1997   dcg
CPVCS    declare ipcmoprm as a pointer
CPVCS
CPVCS       Rev 1.31   Mon Apr 14 17:02:10 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.30   Tue Feb 04 10:45:04 1997   dcg
CPVCS    normalize a,b,c,d representation of plane such that d=+/-1.0
CPVCS
CPVCS       Rev 1.29   Wed May 29 08:43:24 1996   het
CPVCS    Fix an error when checking input arguments for tabular.
CPVCS
CPVCS       Rev 1.28   Thu May 23 08:49:26 1996   dcg
CPVCS    use icscode to test for sb existence
CPVCS
CPVCS       Rev 1.27   Thu May 16 10:28:30 1996   dcg
CPVCS    changes for new interface type 3 and for new icontab, xcontab
CPVCS
CPVCS       Rev 1.26   11/07/95 17:26:52   dcg
CPVCS    change flag to 2 in mmgetblk calls
CPVCS
CPVCS       Rev 1.25   10/18/95 17:11:20   het
CPVCS    Fix an error with nstbout
CPVCS
CPVCS       Rev 1.24   10/18/95 12:17:08   het
CPVCS    Allow greater that 8 character names for sheets in the surface command.
CPVCS
CPVCS       Rev 1.23   09/19/95 13:09:58   dcg
CPVCS    add primative syntax checking
CPVCS
CPVCS       Rev 1.22   08/29/95 12:10:56   dcg
CPVCS    set length for names to 40 characters
CPVCS
CPVCS       Rev 1.21   08/28/95 11:32:04   ahmed
CPVCS    Adjust the location of mmrelprt in the routine
CPVCS
CPVCS       Rev 1.20   08/25/95 15:39:58   dcg
CPVCS    select 'active' mesh object when finished with sheet
CPVCS
CPVCS       Rev 1.19   08/23/95 16:05:16   dcg
CPVCS    changes for sheet routines as mesh objects
CPVCS
CPVCS       Rev 1.18   08/23/95 06:59:04   het
CPVCS    Remove the CMO prefix from SB-ids
CPVCS
CPVCS       Rev 1.17   08/22/95 06:51:04   het
CPVCS    Split the storage block for CMO variables.
CPVCS
CPVCS       Rev 1.16   06/13/95 12:34:20   ejl
CPVCS    Fixed error with input
CPVCS
CPVCS       Rev 1.15   06/13/95 09:02:52   ejl
CPVCS    Cleaned up msgtty, calling arguments.
CPVCS
CPVCS
CPVCS       Rev 1.14   06/07/95 15:31:54   het
CPVCS    Change character*32 idsb to character*132 idsb
CPVCS
CPVCS       Rev 1.13   05/12/95 11:40:22   ejl
CPVCS    Put error checking in SURFACE
CPVCS
CPVCS       Rev 1.12   05/01/95 08:34:16   het
CPVCS    Modifiy all the storage block calles for long names
CPVCS
CPVCS       Rev 1.11   03/31/95 09:10:30   het
CPVCS    Add the buildid calles before all storage block calls
CPVCS
CPVCS       Rev 1.10   03/30/95 05:00:52   het
CPVCS    Change the storage block id packing and preidsb to buildid for long names
CPVCS
CPVCS       Rev 1.9   03/23/95 15:08:38   dcg
CPVCS     Add mesh object name to storage block id for surface,region info.
CPVCS
CPVCS       Rev 1.8   02/20/95 15:54:40   ahmed
CPVCS    Double the memory length for 'sheet'  to handle NURBS
CPVCS
CPVCS       Rev 1.6   02/17/95 19:14:16   het
CPVCS    Adjust memory for tri and quad cmo
CPVCS
CPVCS       Rev 1.5   02/12/95 08:41:00   het
CPVCS    Add the quad_cmo and tri_cmo functions.
CPVCS
CPVCS       Rev 1.4   01/25/95 16:11:36   dcg
CPVCS     Activate sheet surface type
CPVCS
CPVCS       Rev 1.3   01/04/95 22:05:34   llt
CPVCS    unicos changes (made by het)
CPVCS
CPVCS       Rev 1.2   12/24/94 10:52:16   het
CPVCS    Add include files for chydro.h and comdict.h.
CPVCS
C
C
C#######################################################################
C
      implicit none
C
C#######################################################################
C
      include 'geom_lg.h'
      include 'chydro.h'
      include 'consts.h'
C
C#######################################################################
C
      integer nwds, imsgin(nwds), msgtype(nwds)
      REAL*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
C
      integer ierror,lenigeom,iout,i,istrt,lengthsparam,ntab,iend,
     *  ickrfl,lenibtype,lenistype,lenisurfnm,j
      integer icharlnf,length,ierrw,lout,itype,n
      pointer (ipout,out)
      real*8 out(*)
      real*8 ax,cz,bz,az,dist,xc,yc,zc,r,xdiff,ydiff,zdiff,dx,dy,dz,
     *  x4,y4,z4,x2,y2,z2,x3,y3,z3,x1,y1,z1,x4in,y4in,z4in,
     *  xmax1,ymax1,zmax1,xmx,ymx,zmx,xmin1,ymin1,zmin1,ai,bi,ci,
     *  a,b,c,d,distx,disty,aty,bty,denom,numer,angle,
     *  cty,theta,thetain,rr,zz,bx,cx,ay,by,cy,xmn,ymn,zmn,
     *  absofd,phi1,phi2,phi3,xcen,ycen,zcen,theta3,radius3,theta2,
     *  radius2,theta1,radius1,x1in,y1in,z1in,x2in,y2in,z2in,x3in,
     *  y3in,z3in
C
C#######################################################################
C
      REAL*8 x(3,6), y(3,6), z(3,6),rout

C
      character*32 isurfnm,geom_name
      character*32 ibtypein, istypein, igeom, cmosheet
      character*32 isubname, cmo
C
C
      character*132 logmess
      integer ierr
      real*8 eps
C
C#######################################################################
C
C
C
      isubname='surface'
C
      ierror = 0
C
C     Get length epsilon
C
      call get_epsilon('epsilonl',eps)
C
C     Get mesh object name
C
      call cmo_get_name(cmo,ierr)
      if(ierr.ne.0) call x3d_error(isubname,'cmo_get_name')
       call cmo_get_attinfo('geom_name',cmo,iout,rout,geom_name,
     *                        ipout,lout,itype,ierror)
C
C     ******************************************************************
C     GET NAME AND TYPE INFORMATION
C
      isurfnm = cmsgin(2)
      ibtypein  = cmsgin(3)
      if(ibtypein.eq.'interface') ibtypein='intrface'
      istypein  = cmsgin(4)
C
      lenisurfnm = icharlnf(isurfnm)
      lenibtype  = icharlnf(ibtypein)
      lenistype  = icharlnf(istypein)
c
c  make sure we have enough space
c
      call mmfindbk('csall',geom_name,ipcsall,length,ierror)
      if (ierror.ne.0 ) then
         length=100
         call mmgetblk('csall',geom_name,ipcsall,length,3,ierror)
         call mmgetblk('istype',geom_name,ipistype,length,3,ierror)
         call mmgetblk('ibtype',geom_name,ipibtype,length,3,ierror)
         call mmgetblk('sheetnm',geom_name,ipsheetnm,length,3,ierror)
         call mmgetblk('surfparam',geom_name,ipsurfparam,20*length,
     *          2,ierror)
         call mmgetblk('offsparam',geom_name,ipoffsparam,length,1,
     *          ierror)
      elseif(length.lt.nsurf+1) then
         call mmincblk('csall',geom_name,ipcsall,100,ierror)
         call mmincblk('istype',geom_name,ipistype,100,ierror)
         call mmincblk('ibtype',geom_name,ipibtype,100,ierror)
         call mmincblk('sheetnm',geom_name,ipsheetnm,100,ierror)
         call mmincblk('offsparam',geom_name,ipoffsparam,100,ierror)
      else
         call mmfindbk('istype',geom_name,ipistype,length,ierror)
         call mmfindbk('ibtype',geom_name,ipibtype,length,ierror)
         call mmfindbk('sheetnm',geom_name,ipsheetnm,length,ierror)
         call mmfindbk('surfparam',geom_name,ipsurfparam,length,ierror)
         call mmfindbk('offsparam',geom_name,ipoffsparam,length,ierror)
      endif
c
c  check for release or delete
c
      if(ibtypein.eq.'release'.or.ibtypein.eq.'delete'.or.
     *   ibtypein.eq.'remove') then
         do i=1,nsurf
            if(csall(i).eq.isurfnm) then
               if(ibtype(i).eq.'reflect'.or.ibtype(i).eq.'intrcons')
     *                 call condel(i)
               if(i.lt.nsurf) then
                  length=offsparam(i+1)-offsparam(i)
                  do j=offsparam(i),lastsparam-length
                     surfparam(j+1)=surfparam(j+length+1)
                  enddo
                  do j= i+1,nsurf
                     offsparam(j)=offsparam(j)-length
                  enddo
                  do j=i,nsurf-1
                     csall(j)=csall(j+1)
                     istype(j)=istype(j+1)
                     ibtype(j)=ibtype(j+1)
                     sheetnm(j)=sheetnm(j+1)
                     offsparam(j)=offsparam(j+1)
                  enddo
                  lastsparam=lastsparam-length
               else
                  lastsparam=0
                  if(nsurf.gt.1)lastsparam=offsparam(nsurf)
                  offsparam(nsurf)=0
                  csall(nsurf)=' '
               endif
               nsurf=nsurf-1
               go to 9999
            endif
         enddo
      endif
C
C     ******************************************************************
C     CHECK FOR VALID BOUNDARY TYPES.
C
      if ((ibtypein(1:lenibtype) .ne. 'free'    ) .and.
     &    (ibtypein(1:lenibtype) .ne. 'intrface') .and.
     &    (ibtypein(1:lenibtype) .ne. 'intrcons') .and.
     &    (ibtypein(1:lenibtype) .ne. 'virtual') .and.
     &    (ibtypein(1:lenibtype) .ne. 'reflect' )) then
C
C        ***************************************************************
C        ILLEGAL BOUNDARY TYPE.
C
         write(logmess,9000) ibtypein
 9000    format(' ERROR - Illegal Boundary Type: ', a)
         call writloga('default',0,logmess,0,ierrw)
         go to 9999
C
      endif
c
c  check for illegal surface type
c
      if ((istypein(1:lenistype) .ne. 'plane'   ) .and.
     &    (istypein(1:lenistype) .ne. 'planexyz') .and.
     &    (istypein(1:lenistype) .ne. 'planertz') .and.
     &    (istypein(1:lenistype) .ne. 'planertp') .and.
     &    (istypein(1:lenistype) .ne. 'box'     ) .and.
     &    (istypein(1:lenistype) .ne. 'cone'    ) .and.
     &    (istypein(1:lenistype) .ne. 'cylinder') .and.
     &    (istypein(1:lenistype) .ne. 'ellipse')  .and.
     &    (istypein(1:lenistype) .ne. 'parallel') .and.
     &    (istypein(1:lenistype) .ne. 'sphere'  ) .and.
     &    (istypein(1:lenistype) .ne. 'tabular' ) .and.
     &    (istypein(1:lenistype) .ne. 'sheet'   )) then
         write(logmess,9120) istypein
         call writloga('default',0,logmess,0,ierrw)
         go to 9999
      endif
c
c  increment number of surfaces
c
      nsurf=nsurf+1

c
c  check for duplicate names - if duplicate warn and ignore
c
      n=nsurf-1
      do i=1,n
         if(csall(i).eq.isurfnm) then
            nsurf=nsurf-1
            write(logmess,'(a,a)') 'duplicate surface - ignored: '
     *           ,isurfnm
            call writloga('default',0,logmess,0,ierror)
            go to 9999
         endif
      enddo
c
c  store names and types and offset
c
      istype(nsurf)=istypein(1:lenistype)
      ibtype(nsurf)=ibtypein(1:lenibtype)
      csall(nsurf)=isurfnm(1:lenisurfnm)
      if(nsurf.eq.1) lastsparam=0
      offsparam(nsurf)=lastsparam
c
c  get length of surfparam for later checks
c
      call mmfindbk('surfparam',geom_name,ipsurfparam,lengthsparam
     *      ,ierror)
C
      ickrfl=0
C
      if ((istypein(1:lenistype) .eq. 'plane'   ) .or.
     &    (istypein(1:lenistype) .eq. 'planexyz') .or.
     &    (istypein(1:lenistype) .eq. 'planertz') .or.
     &    (istypein(1:lenistype) .eq. 'planertp')) then
C
C        ***************************************************************
C        HANDLE PLANE TYPE SURFACE
C
         if ((istypein(1:lenistype) .eq. 'plane'   ) .or.
     *       (istypein(1:lenistype) .eq. 'planexyz')) then
C
            call test_argument_type(9,2,5,imsgin,xmsgin,cmsgin,
     *                              msgtype,nwds)
            x1in=xmsgin(5)
            y1in=xmsgin(6)
            z1in=xmsgin(7)
C
            x2in=xmsgin(8)
            y2in=xmsgin(9)
            z2in=xmsgin(10)
C
            x3in=xmsgin(11)
            y3in=xmsgin(12)
            z3in=xmsgin(13)
C
         elseif(istypein(1:lenistype) .eq. 'planertz' ) then
C
            call test_argument_type(12,2,5,imsgin,xmsgin,cmsgin,
     *                              msgtype,nwds)
            radius1=xmsgin(5)
            theta1 =xmsgin(6)*pie/180.0
            z1in   =xmsgin(7)
C
            radius2=xmsgin(8)
            theta2 =xmsgin(9)*pie/180.0
            z2in   =xmsgin(10)
C
            radius3=xmsgin(11)
            theta3 =xmsgin(12)*pie/180.0
            z3in   =xmsgin(13)
C
            xcen=xmsgin(14)
            ycen=xmsgin(15)
            zcen=xmsgin(16)
C
            x1in=radius1*cos(theta1)+xcen
            y1in=radius1*sin(theta1)+ycen
C
            x2in=radius2*cos(theta2)+xcen
            y2in=radius2*sin(theta2)+ycen
C
            x3in=radius3*cos(theta3)+xcen
            y3in=radius3*sin(theta3)+ycen
C
         elseif(istypein(1:lenistype) .eq. 'planertp' ) then
C
            call test_argument_type(12,2,5,imsgin,xmsgin,cmsgin,
     *                              msgtype,nwds)
            radius1=xmsgin(5)
            theta1 =xmsgin(6)*pie/180.0
            phi1   =xmsgin(7)*pie/180.0
C
            radius2=xmsgin(8)
            theta2 =xmsgin(9)*pie/180.0
            phi2   =xmsgin(10)*pie/180.0
C
            radius3=xmsgin(11)
            theta3 =xmsgin(12)*pie/180.0
            phi3   =xmsgin(13)*pie/180.0
C
            xcen=xmsgin(14)
            ycen=xmsgin(15)
            zcen=xmsgin(16)
C
            x1in=radius1*sin(theta1)*cos(phi1)+xcen
            y1in=radius1*sin(theta1)*sin(phi1)+ycen
            z1in=radius1*cos(theta1)+zcen
C
            x2in=radius2*sin(theta2)*cos(phi2)+xcen
            y2in=radius2*sin(theta2)*sin(phi2)+ycen
            z2in=radius2*cos(theta2)+zcen
C
            x3in=radius3*sin(theta3)*cos(phi3)+xcen
            y3in=radius3*sin(theta3)*sin(phi3)+ycen
            z3in=radius3*cos(theta3)+zcen
C
         endif
C
C        ---------------------------------------------------------------
C        CONVERT INPUT POINTS FROM CURRENT COORDINATE SYSTEM TO
C        NORMAL COORDINATE SYSTEM.
C
         call xyznorm(x1in,y1in,z1in,x(1,1),y(1,1),z(1,1))
         call xyznorm(x2in,y2in,z2in,x(2,1),y(2,1),z(2,1))
         call xyznorm(x3in,y3in,z3in,x(3,1),y(3,1),z(3,1))
C
C        ---------------------------------------------------------------
C        SAVE TRANSPOSED INPUT DATA IN surfparam
C
         if(lengthsparam.lt.offsparam(nsurf)+13) then
            call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
            lengthsparam=lengthsparam+500
         endif
         surfparam(offsparam(nsurf)+1)=x(1,1)
         surfparam(offsparam(nsurf)+2)=y(1,1)
         surfparam(offsparam(nsurf)+3)=z(1,1)
C
         surfparam(offsparam(nsurf)+4)=x(2,1)
         surfparam(offsparam(nsurf)+5)=y(2,1)
         surfparam(offsparam(nsurf)+6)=z(2,1)
C
         surfparam(offsparam(nsurf)+7)=x(3,1)
         surfparam(offsparam(nsurf)+8)=y(3,1)
         surfparam(offsparam(nsurf)+9)=z(3,1)
C
C        ---------------------------------------------------------------
C        SET UP THE EQUATION OF THE PLANE FROM THE 3 POINTS.
C
         a=  (y(2,1)-y(1,1))*(z(3,1)-z(1,1)) -
     &       (y(3,1)-y(1,1))*(z(2,1)-z(1,1))
         b=-((x(2,1)-x(1,1))*(z(3,1)-z(1,1)) -
     &       (x(3,1)-x(1,1))*(z(2,1)-z(1,1)))
         c=  (x(2,1)-x(1,1))*(y(3,1)-y(1,1)) -
     &       (x(3,1)-x(1,1))*(y(2,1)-y(1,1))
         d=a*x(1,1)+b*y(1,1)+c*z(1,1)
         if(abs(d).gt.eps ) then
            absofd=abs(d)
            a=a/absofd
            b=b/absofd
            c=c/absofd
            d=d/absofd
         endif
C
C        ---------------------------------------------------------------
C        SAVE COEFFICIENTS IN stbout
C        SAVE COEFFICIENTS IN stbout
C
         surfparam(offsparam(nsurf)+10)=a
         surfparam(offsparam(nsurf)+11)=b
         surfparam(offsparam(nsurf)+12)=c
         surfparam(offsparam(nsurf)+13)=d
         lastsparam=offsparam(nsurf)+13
C
C        ---------------------------------------------------------------
C        PRINT UNIT VECTOR FOR THE PLANE
C
         ai=a/sqrt(a*a + b*b + c*c)
         bi=b/sqrt(a*a + b*b + c*c)
         ci=c/sqrt(a*a + b*b + c*c)
C
         write(logmess,9060) isurfnm,ai,bi,ci
 9060    format('  The unit vector for ',a8,' is ',
     &          f10.7,'i  ',f10.7,'j  ',f10.7,'k')
         call writloga('default',0,logmess,0,ierrw)
C
C        ---------------------------------------------------------------
C        IF REFLECTIVE PLANE, SET UP BOUNDARY INFO
C
         if (ibtypein(1:lenibtype) .eq. 'reflect') then
C
            ickrfl=1
            nb=nb+1
            call flbound(1,nb,3,x(1,1),y(1,1),z(1,1),x(2,1),
     &                   y(2,1),z(2,1),x(3,1),y(3,1),z(3,1))
            call flbound(2,nb,3,zero,zero,zero,zero,zero,zero,zero,zero,
     &             zero)
C
         endif
C
      elseif ((istypein(1:lenistype) .eq. 'box'     ) .or.
     &        (istypein(1:lenistype) .eq. 'parallel')) then
C
C        ***************************************************************
C        HANDLE BOX OR PARALLELPIPED TYPE SURFACE
C
C        ---------------------------------------------------------------
C        IF BOX, CONVERT xmin, ymin TO x1 THROUGH z4 OF PARALLELPIPED
C
         if (istypein(1:lenistype) .eq. 'box') then
C
            if(lengthsparam.lt.offsparam(nsurf)+36) then
               call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
               lengthsparam=lengthsparam+500
            endif
C
            call test_argument_type(6,2,5,imsgin,xmsgin,cmsgin,
     *                              msgtype,nwds)
            xmn=xmsgin(5)
            ymn=xmsgin(6)
            zmn=xmsgin(7)
C
            xmx=xmsgin(8)
            ymx=xmsgin(9)
            zmx=xmsgin(10)
C
C           ............................................................
C           CONVERT INPUT DATA FROM LOCAL COORD. SYSTEM TO NORMAL
C           COORD. SYSTEM AND SAVE IN stbout
C           COORD. SYSTEM AND SAVE IN stbout
C
            call xyznorm(xmn,ymn,zmn,xmin1,ymin1,zmin1)
            call xyznorm(xmx,ymx,zmx,xmax1,ymax1,zmax1)
C
            surfparam(offsparam(nsurf)+1)=xmin1
            surfparam(offsparam(nsurf)+2)=ymin1
            surfparam(offsparam(nsurf)+3)=zmin1
C
            surfparam(offsparam(nsurf)+4)=xmax1
            surfparam(offsparam(nsurf)+5)=ymax1
            surfparam(offsparam(nsurf)+6)=zmax1
C
C           ............................................................
C           NOW CONVERT FROM BOX TO PARALLELPIPED IN CURRENT COORD. SYS.
C           THEN TRANSFORM THE CORNERS TO NORMAL COORD. SYSTEM.
C
            x1in=xmn
            y1in=ymn
            z1in=zmn
C
            x2in=xmx
            y2in=ymn
            z2in=zmn
C
            x3in=xmn
            y3in=ymx
            z3in=zmn
C
            x4in=xmn
            y4in=ymn
            z4in=zmx
C
            call xyznorm(x1in,y1in,z1in,x1,y1,z1)
            call xyznorm(x2in,y2in,z2in,x2,y2,z2)
            call xyznorm(x3in,y3in,z3in,x3,y3,z3)
            call xyznorm(x4in,y4in,z4in,x4,y4,z4)
C
         else
C
            call test_argument_type(14,2,5,imsgin,xmsgin,cmsgin,
     *                              msgtype,nwds)
            x1in=xmsgin(5)
            y1in=xmsgin(6)
            z1in=xmsgin(7)
C
            x2in=xmsgin(8)
            y2in=xmsgin(9)
            z2in=xmsgin(10)
C
            x3in=xmsgin(11)
            y3in=xmsgin(12)
            z3in=xmsgin(13)
C
            x4in=xmsgin(14)
            y4in=xmsgin(15)
            z4in=xmsgin(16)
C
C           ............................................................
C           CONVERT INPUT DATA FROM LOCAL COORD. SYSTEM TO NORMAL
C           COORD. SYSTEM AND SAVE IN stbout
C           COORD. SYSTEM AND SAVE IN stbout
C
            call xyznorm(x1in,y1in,z1in,x1,y1,z1)
            call xyznorm(x2in,y2in,z2in,x2,y2,z2)
            call xyznorm(x3in,y3in,z3in,x3,y3,z3)
            call xyznorm(x4in,y4in,z4in,x4,y4,z4)
C
            surfparam(offsparam(nsurf)+1)=x1
            surfparam(offsparam(nsurf)+2)=y1
            surfparam(offsparam(nsurf)+3)=z1
C
            surfparam(offsparam(nsurf)+4)=x2
            surfparam(offsparam(nsurf)+5)=y2
            surfparam(offsparam(nsurf)+6)=z2
C

            surfparam(offsparam(nsurf)+7)=x3
            surfparam(offsparam(nsurf)+8)=y3
            surfparam(offsparam(nsurf)+9)=z3
C
            surfparam(offsparam(nsurf)+10)=x4
            surfparam(offsparam(nsurf)+11)=y4
            surfparam(offsparam(nsurf)+12)=z4
C
         endif
C
C        ---------------------------------------------------------------
C        CALCULATE OFFSETS, XDIFF IS THE X DISTANCE BETWEEN POINTS
C        ALONG AN UPPER OR LOWER EDGE, DX IS THE X DISTANCE BETWEEN
C        POINTS ALONG A VERTICAL EDGE, ETC.
C
         dx=x4-x1
         dy=y4-y1
         dz=z2-z1
C
         xdiff=x2-x1
         ydiff=y3-y1
         zdiff=z4-z1
C
C        ---------------------------------------------------------------
C        SET UP 3 POINTS ON EACH OF THE 6 PLANES SO THAT THE RIGHT
C        HAND SYSTEM POINTS OUTWARD.
C
         x(1,1)=x1
         y(1,1)=y1
         z(1,1)=z1
C
         x(2,1)=x2
         y(2,1)=y2
         z(2,1)=z2
C
         x(3,1)=x4
         y(3,1)=y4
         z(3,1)=z4
C
         x(1,2)=x4+xdiff
         y(1,2)=y2+dy
         z(1,2)=z2+zdiff
C
         x(2,2)=x2
         y(2,2)=y2
         z(2,2)=z2
C
         x(3,2)=x3+xdiff
         y(3,2)=y2+ydiff
         z(3,2)=z3+dz
C
         x(1,3)=x(3,2)
         y(1,3)=y(3,2)
         z(1,3)=z(3,2)
C
         x(2,3)=x3
         y(2,3)=y3
         z(2,3)=z3
C
         x(3,3)=x3+dx
         y(3,3)=y3+dy
         z(3,3)=z3+zdiff
C
         x(1,4)=x1
         y(1,4)=y1
         z(1,4)=z1
C
         x(2,4)=x4
         y(2,4)=y4
         z(2,4)=z4
C
         x(3,4)=x3
         y(3,4)=y3
         z(3,4)=z3
C
         x(1,5)=x4
         y(1,5)=y4
         z(1,5)=z4
C
         x(2,5)=x(1,2)
         y(2,5)=y(1,2)
         z(2,5)=z(1,2)
C
         x(3,5)=x3+dx
         y(3,5)=y3+dy
         z(3,5)=z3+zdiff
C
         x(1,6)=x1
         y(1,6)=y1
         z(1,6)=z1
C
         x(2,6)=x3
         y(2,6)=y3
         z(2,6)=z3
C
         x(3,6)=x2
         y(3,6)=y2
         z(3,6)=z2
C
C        ---------------------------------------------------------------
C        LOOP THROUGH 6 PLANES TO GET EQUATIONS AND SAVE IN stbout
C        LOOP THROUGH 6 PLANES TO GET EQUATIONS AND SAVE IN stbout
C
         if (istypein(1:lenistype) .eq. 'box') then
            istrt=6
            lastsparam=lastsparam+6
         else
            istrt=12
            lastsparam=lastsparam+12
         endif
C
         do i=1,6
C
C           ............................................................
C           SET UP THE EQUATION OF THE PLANE FROM THE 3 POINTS.
C
            a=  (y(2,i)-y(1,i))*(z(3,i)-z(1,i)) -
     &          (y(3,i)-y(1,i))*(z(2,i)-z(1,i))
            b=-((x(2,i)-x(1,i))*(z(3,i)-z(1,i)) -
     &          (x(3,i)-x(1,i))*(z(2,i)-z(1,i)))
            c=  (x(2,i)-x(1,i))*(y(3,i)-y(1,i)) -
     &          (x(3,i)-x(1,i))*(y(2,i)-y(1,i))
            d=a*x(1,i)+b*y(1,i)+c*z(1,i)
            if(abs(d).gt.eps ) then
               absofd=abs(d)
               a=a/absofd
               b=b/absofd
               c=c/absofd
               d=d/absofd
            endif
C
C           ............................................................
C           SAVE COEFFICIENTS IN stbout
C           SAVE COEFFICIENTS IN stbout
C
            iout=istrt+(i-1)*4
            surfparam(offsparam(nsurf)+iout+1)=a
            surfparam(offsparam(nsurf)+iout+2)=b
            surfparam(offsparam(nsurf)+iout+3)=c
            surfparam(offsparam(nsurf)+iout+4)=d
C
C           ............................................................
C           IF REFLECTIVE PLANE, SET UP BOUNDARY INFO
C
            if (ibtypein(1:lenibtype) .eq. 'reflect') then
               ickrfl=1
               nb=nb+1
               call flbound(1,nb,3,x(1,i),y(1,i),z(1,i),x(2,i),
     &                      y(2,i),z(2,i),x(3,i),y(3,i),z(3,i))
               call flbound(2,nb,3,zero,zero,zero,zero,zero,zero,zero,
     &          zero,zero)
            endif
C
         enddo
C
         lastsparam=lastsparam+24
C
      elseif (istypein(1:lenistype) .eq. 'sphere') then
C
C        ***************************************************************
C        HANDLE SPHERE TYPE SURFACE
C
         call test_argument_type(4,2,5,imsgin,xmsgin,cmsgin,
     *                           msgtype,nwds)
         x1in=xmsgin(5)
         y1in=xmsgin(6)
         z1in=xmsgin(7)
         r=xmsgin(8)
         if(lengthsparam.lt.offsparam(nsurf)+4) then
               call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
               lengthsparam=lengthsparam+500
         endif
C
C        ---------------------------------------------------------------
C        CONVERT INPUT POINTS FROM CURRENT COORDINATE SYSTEM TO
C        NORMAL COORDINATE SYSTEM AND SAVE IN stbout
C        NORMAL COORDINATE SYSTEM AND SAVE IN stbout
C
         call xyznorm(x1in,y1in,z1in,xc,yc,zc)
C
         surfparam(offsparam(nsurf)+1)=xc
         surfparam(offsparam(nsurf)+2)=yc
         surfparam(offsparam(nsurf)+3)=zc
         surfparam(offsparam(nsurf)+4)=r
         lastsparam=lastsparam+4
C
      elseif ((istypein(1:lenistype) .eq. 'cylinder') .or.
     &        (istypein(1:lenistype) .eq. 'cone'    ) .or.
     &        (istypein(1:lenistype) .eq. 'tabular' )) then
C
C        ***************************************************************
C        HANDLE CYLINDER, CONE AND ROTATED TABULAR PROFILE TYPE SURFACE
C
         if ((istypein(1:lenistype) .eq. 'cylinder') .or.
     &       (istypein(1:lenistype) .eq. 'cone'    )) then
             call test_argument_type(7,2,5,imsgin,xmsgin,cmsgin,
     *                               msgtype,nwds)
         elseif (istypein(1:lenistype) .eq. 'tabular' ) then
             call test_argument_type(6,2,5,imsgin,xmsgin,cmsgin,
     *                               msgtype,nwds)
         endif
         if(lengthsparam.lt.offsparam(nsurf)+14) then
               call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
               lengthsparam=lengthsparam+500
         endif
         x1in=xmsgin(5)
         y1in=xmsgin(6)
         z1in=xmsgin(7)
C
         x2in=xmsgin(8)
         y2in=xmsgin(9)
         z2in=xmsgin(10)
C
         if (istypein(1:lenistype) .ne. 'tabular') then
            r=xmsgin(11)
         else
            igeom=cmsgin(11)
            lenigeom = icharlnf(igeom)
         endif
C
C        ---------------------------------------------------------------
C        CONVERT INPUT DATA FROM LOCAL COORD. SYSTEM TO NORMAL
C        COORD. SYSTEM AND SAVE IN stbout
C        COORD. SYSTEM AND SAVE IN stbout
C
         call xyznorm(x1in,y1in,z1in,x1,y1,z1)
         call xyznorm(x2in,y2in,z2in,x2,y2,z2)
C
         surfparam(offsparam(nsurf)+1)=x1
         surfparam(offsparam(nsurf)+2)=y1
         surfparam(offsparam(nsurf)+3)=z1
C
         surfparam(offsparam(nsurf)+4)=x2
         surfparam(offsparam(nsurf)+5)=y2
         surfparam(offsparam(nsurf)+6)=z2
C
         surfparam(offsparam(nsurf)+7)=xmsgin(11)
C
C        ---------------------------------------------------------------
C        ROTATE THE AXES SO THAT THE LINE BETWEEN POINT 1 AND POINT 2 IS
C        THE NEW Z AXIS
C
         dist=sqrt((x2-x1)**2 + (y2-y1)**2 + (z2-z1)**2)
C
C        ...............................................................
C        DETERMINE THE UNIT VECTOR ALONG THE INPUT POINTS (NEW Z AXIS)
C
         az=(x2-x1)/dist
         bz=(y2-y1)/dist
         cz=(z2-z1)/dist
C
C        ...............................................................
C        DETERMINE THE UNIT VECTOR ALONG THE NEW X AXIS WHICH LIES ON
C        THE OLD X-Y PLANE
C
         if ((az*az+bz*bz) .eq. 0) then
            ax=1
            bx=0
         else
            ax=sqrt(bz*bz/(az*az+bz*bz))
            bx=-sqrt(az*az/(az*az+bz*bz))
         endif
C
         cx=0
         if (az .lt. 0 .and. bz .gt. 0) bx=-bx
         if (az .lt. 0 .and. bz .lt. 0) then
            ax=-ax
            bx=-bx
         endif
C
         if (az .gt. 0 .and. bz .lt. 0) ax=-ax
C
C        ...............................................................
C        DETERMINE THE UNIT VECTOR ALONG THE NEW Y AXIS WHICH LIES
C        PERPENDICULAR TO THE NEW Z AND X AXIS (Z CROSS X)
C
         ay=bz*cx-bx*cz
         by=cz*ax-cx*az
         cy=az*bx-ax*bz
C
C        ---------------------------------------------------------------
C        STORE THE CENTER OR VERTEX POINT, THE END POINT, AND THE
C        RADIUS IN THE STORAGE BLOCK
C
         surfparam(offsparam(nsurf)+8)=x1
         surfparam(offsparam(nsurf)+9)=y1
         surfparam(offsparam(nsurf)+10)=z1
C
         surfparam(offsparam(nsurf)+11)=x2
         surfparam(offsparam(nsurf)+12)=y2
         surfparam(offsparam(nsurf)+13)=z2
C

C
C        ---------------------------------------------------------------
C        FOR A CONE, STORE dist FOR C IN THE EQUATION OF A CONE
C        FOR A CONE or cylinder store radius
c        For tabular store sheet name
C
         if (istypein(1:lenistype) .eq. 'cone') then
            surfparam(offsparam(nsurf)+14)=r
            surfparam(offsparam(nsurf)+15)=dist
            lastsparam=lastsparam+15
         elseif (istypein(1:lenistype) .eq. 'tabular') then
            sheetnm(nsurf)=igeom
            lastsparam=lastsparam+13
         else
            surfparam(offsparam(nsurf)+14)=r
            lastsparam=lastsparam+14
         endif
C
C        ---------------------------------------------------------------
C        FOR A ROTATED TABULAR SURFACE, GET AND STORE THE PROFILE PAIRS
C
         if (istypein(1:lenistype) .eq. 'tabular') then
C
            iend=0
            ntab=nwds-12
            if(lengthsparam.lt.offsparam(nsurf)+24+ntab) then
               call mmincblk('surfparam',geom_name,ipsurfparam,ntab+500,
     *                   ierr)
               lengthsparam=lengthsparam+500+ntab
            endif
C
C           ............................................................
C           LOOP THROUGH INPUT DATA UNTIL end FOUND
C
            do i=12,nwds-1
              surfparam(offsparam(nsurf)+i+4)=xmsgin(i)
            enddo
C
            surfparam(offsparam(nsurf)+15)=nwds-12
            lastsparam=lastsparam+2+ntab
C
C           ............................................................
C           CONVERT zr TO rz OR tr TO rt GEOMETRY
C
            if ((igeom(1:lenigeom).eq.'zr') .or.
     &          (igeom(1:lenigeom).eq.'tr')) then
C
               if (igeom(1:lenigeom) .eq. 'zr') igeom='rz'
               if (igeom(1:lenigeom) .eq. 'tr') igeom='rt'
C
               sheetnm(nsurf)=igeom
C
               do i=1,ntab,2
                  zz=surfparam(offsparam(nsurf)+15+i)
                  rr=surfparam(offsparam(nsurf)+15+i+1)
                  surfparam(offsparam(nsurf)+15+i)=rr
                  surfparam(offsparam(nsurf)+15+i+1)=zz
               enddo
C
            endif
C
C           ............................................................
C           CONVERT rt GEOMETRY TO rz GEOMETRY
C
            if (igeom(1:lenigeom) .eq. 'rt') then
C
               sheetnm(nsurf)='rz'
C
               do i=1,ntab,2
                  r=surfparam(offsparam(nsurf)+15+i)
                  thetain=surfparam(offsparam(nsurf)+15+i+1)
                  theta=thetain*pie/180.
C
                  if (thetain .eq. 0) then
                     surfparam(offsparam(nsurf)+15+i)=0
                     surfparam(offsparam(nsurf)+15+i+1)=r
                  elseif (thetain .eq. 90) then
                     surfparam(offsparam(nsurf)+15+i)=r
                     surfparam(offsparam(nsurf)+15+i+1)=0
                  elseif (thetain .eq. 180) then
                     surfparam(offsparam(nsurf)+15+i)=0
                     surfparam(offsparam(nsurf)+15+i+1)=-r
                  else
                     surfparam(offsparam(nsurf)+15+i)=r*sin(theta)
                     surfparam(offsparam(nsurf)+15+i+1)=r*cos(theta)
                  endif
               enddo
C
            endif
C
         endif
C
C        ---------------------------------------------------------------
C        STORE THE ROTATION VECTORS AS A MATRIX
C
         surfparam(lastsparam+1)=ax
         surfparam(lastsparam+2)=bx
         surfparam(lastsparam+3)=cx
C
         surfparam(lastsparam+4)=ay
         surfparam(lastsparam+5)=by
         surfparam(lastsparam+6)=cy
C
         surfparam(lastsparam+7)=az
         surfparam(lastsparam+8)=bz
         surfparam(lastsparam+9)=cz
C
         lastsparam=lastsparam+9
C
      elseif (istypein(1:lenistype) .eq. 'ellipse') then
C
C        ***************************************************************
C        HANDLE ELLIPSOID TYPE SURFACE
C
         call test_argument_type(12,2,5,imsgin,xmsgin,cmsgin,
     *                           msgtype,nwds)
         if(lengthsparam.lt.offsparam(nsurf)+27) then
               call mmincblk('surfparam',geom_name,ipsurfparam,500,ierr)
               lengthsparam=lengthsparam+500
         endif
         x1in=xmsgin(5)
         y1in=xmsgin(6)
         z1in=xmsgin(7)
C
         x2in=xmsgin(8)
         y2in=xmsgin(9)
         z2in=xmsgin(10)
C
         x3in=xmsgin(11)
         y3in=xmsgin(12)
         z3in=xmsgin(13)
C
         a=xmsgin(14)
         b=xmsgin(15)
         c=xmsgin(16)
C
C        ---------------------------------------------------------------
C        CONVERT INPUT DATA FROM LOCAL COORD. SYSTEM TO NORMAL
C        COORD. SYSTEM AND SAVE IN stbout
C        COORD. SYSTEM AND SAVE IN stbout
C
         call xyznorm(x1in,y1in,z1in,x1,y1,z1)
         call xyznorm(x2in,y2in,z2in,x2,y2,z2)
         call xyznorm(x3in,y3in,z3in,x3,y3,z3)
C
         surfparam(offsparam(nsurf)+1)=x1
         surfparam(offsparam(nsurf)+2)=y1
         surfparam(offsparam(nsurf)+3)=z1
C
         surfparam(offsparam(nsurf)+4)=x2
         surfparam(offsparam(nsurf)+5)=y2
         surfparam(offsparam(nsurf)+6)=z2
C
         surfparam(offsparam(nsurf)+7)=x3
         surfparam(offsparam(nsurf)+8)=y3
         surfparam(offsparam(nsurf)+9)=z3
C
         surfparam(offsparam(nsurf)+10)=a
         surfparam(offsparam(nsurf)+11)=b
         surfparam(offsparam(nsurf)+12)=c
C
C        ---------------------------------------------------------------
C        ROTATE THE AXES SO THAT THE LINE BETWEEN POINT 1 AND POINT 2 IS
C        THE NEW X AXIS AND THE LINE BETWEEN 1 AND 3 IS THE NEW Y AXIS
C
         distx=sqrt((x2-x1)**2 + (y2-y1)**2 + (z2-z1)**2)
         disty=sqrt((x3-x1)**2 + (y3-y1)**2 + (z3-z1)**2)
C
C        ...............................................................
C        DETERMINE THE UNIT VECTOR ALONG THE INPUT POINTS
C
         ax=(x2-x1)/distx
         bx=(y2-y1)/distx
         cx=(z2-z1)/distx
C
         aty=(x3-x1)/disty
         bty=(y3-y1)/disty
         cty=(z3-z1)/disty
C
C        ...............................................................
C        DETERMINE THE UNIT VECTOR ALONG THE NEW Z AXIS WHICH LIES
C        PERPENDICULAR TO THE NEW X AND Y AXIS (X CROSS Y)
C
         az=bx*cty-bty*cx
         bz=cx*aty-cty*ax
         cz=ax*bty-aty*bx
C
C        ...............................................................
C        DETERMINE THE UNIT VECTOR ALONG THE NEW Y AXIS WHICH LIES
C        PERPENDICULAR TO THE NEW Z AND X AXIS (Z CROSS X)
C
         ay=bz*cx-bx*cz
         by=cz*ax-cx*az
         cy=az*bx-ax*bz
C
C        ...............................................................
C        CHECK THAT THE ORIGINAL SEMI-AXIS WERE PERPENDICULAR.
C
         numer=ay*aty + by*bty + cy*cty
         denom=sqrt(ay**2+by**2+cy**2) * sqrt(aty**2+bty**2+cty**2)
         angle=acos(numer/denom)
C
         if (angle .gt. .08725) then
            write(logmess,9080)
 9080       format(' Warning - the semi-axis points are not ',
     &             'perpendicular.')
            call writloga('default',0,logmess,0,ierrw)
            write(logmess,9100)
 9100       format('           The y semi-axis will be recalculated.')
            call writloga('default',0,logmess,0,ierrw)
         endif
C
C        ---------------------------------------------------------------
C        STORE THE CENTER AND THE RADII IN THE STORAGE BLOCK.
C
         surfparam(offsparam(nsurf)+13)=x1
         surfparam(offsparam(nsurf)+14)=y1
         surfparam(offsparam(nsurf)+15)=z1
C
         surfparam(offsparam(nsurf)+16)=a
         surfparam(offsparam(nsurf)+17)=b
         surfparam(offsparam(nsurf)+18)=c
C
C        ---------------------------------------------------------------
C        STORE THE ROTATION MATRIX
C
         surfparam(offsparam(nsurf)+19)=ax
         surfparam(offsparam(nsurf)+20)=bx
         surfparam(offsparam(nsurf)+21)=cx
C
         surfparam(offsparam(nsurf)+22)=ay
         surfparam(offsparam(nsurf)+23)=by
         surfparam(offsparam(nsurf)+24)=cy
C
         surfparam(offsparam(nsurf)+25)=az
         surfparam(offsparam(nsurf)+26)=bz
         surfparam(offsparam(nsurf)+27)=cz
C
         lastsparam=lastsparam+27
C
      elseif (istypein(1:lenistype) .eq. 'sheet') then
C
C        ***************************************************************
C        HANDLE SHEET TYPE SURFACE
C
         call sheet(xmsgin,cmsgin,imsgin,msgtype,nwds,cmosheet)
         sheetnm(nsurf)=cmosheet
         call cmo_select(cmo,ierr)
C
      else
C
C        ***************************************************************
C        ILLEGAL SURFACE TYPE.
C
         write(logmess,9120) istypein
 9120    format(' ERROR - Illegal Surface Type: ', a)
         call writloga('default',0,logmess,0,ierrw)
         goto 9999
C
      endif
C
c  call conadd for constrained surface types
c
      if(ibtypein(1:7).eq.'reflect'.or.ibtypein(1:7).eq.'virtual'
     *  .or.ibtypein(1:8).eq.'intrcons') call conadd(nsurf)
 9999 continue
C
      return
      end