!*==dlagtm.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix, B and C are rectangular matrices, and α and β are scalars, which may be 0, 1, or -1.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLAGTM + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
!                          B, LDB )
!
!       .. Scalar Arguments ..
!       CHARACTER          TRANS
!       INTEGER            LDB, LDX, N, NRHS
!       DOUBLE PRECISION   ALPHA, BETA
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * ),
!      $                   X( LDX, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLAGTM performs a matrix-vector product of the form
!>
!>    B := alpha * A * X + beta * B
!>
!> where A is a tridiagonal matrix of order N, B and X are N by NRHS
!> matrices, and alpha and beta are real scalars, each of which may be
!> 0., 1., or -1.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  No transpose, B := alpha * A * X + beta * B
!>          = 'T':  Transpose,    B := alpha * A'* X + beta * B
!>          = 'C':  Conjugate transpose = Transpose
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.
!> \endverbatim
!>
!> \param[in] ALPHA
!> \verbatim
!>          ALPHA is DOUBLE PRECISION
!>          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 0.
!> \endverbatim
!>
!> \param[in] DL
!> \verbatim
!>          DL is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of T.
!> \endverbatim
!>
!> \param[in] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of T.
!> \endverbatim
!>
!> \param[in] DU
!> \verbatim
!>          DU is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) super-diagonal elements of T.
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The N by NRHS matrix X.
!> \endverbatim
!>
!> \param[in] LDX
!> \verbatim
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(N,1).
!> \endverbatim
!>
!> \param[in] BETA
!> \verbatim
!>          BETA is DOUBLE PRECISION
!>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 1.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the N by NRHS matrix B.
!>          On exit, B is overwritten by the matrix expression
!>          B := alpha * A * X + beta * B.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(N,1).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE DLAGTM(Trans,N,Nrhs,Alpha,Dl,D,Du,X,Ldx,Beta,B,Ldb)
      IMPLICIT NONE
!*--DLAGTM148
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Trans
      INTEGER Ldb , Ldx , N , Nrhs
      DOUBLE PRECISION Alpha , Beta
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION B(Ldb,*) , D(*) , Dl(*) , Du(*) , X(Ldx,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE , ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
!     ..
!     .. Local Scalars ..
      INTEGER i , j
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. Executable Statements ..
!
      IF ( N==0 ) RETURN
!
!     Multiply B by BETA if BETA.NE.1.
!
      IF ( Beta==ZERO ) THEN
         DO j = 1 , Nrhs
            DO i = 1 , N
               B(i,j) = ZERO
            ENDDO
         ENDDO
      ELSEIF ( Beta==-ONE ) THEN
         DO j = 1 , Nrhs
            DO i = 1 , N
               B(i,j) = -B(i,j)
            ENDDO
         ENDDO
      ENDIF
!
      IF ( Alpha==ONE ) THEN
         IF ( LSAME(Trans,'N') ) THEN
!
!           Compute B := B + A*X
!
            DO j = 1 , Nrhs
               IF ( N==1 ) THEN
                  B(1,j) = B(1,j) + D(1)*X(1,j)
               ELSE
                  B(1,j) = B(1,j) + D(1)*X(1,j) + Du(1)*X(2,j)
                  B(N,j) = B(N,j) + Dl(N-1)*X(N-1,j) + D(N)*X(N,j)
                  DO i = 2 , N - 1
                     B(i,j) = B(i,j) + Dl(i-1)*X(i-1,j) + D(i)*X(i,j)   &
     &                        + Du(i)*X(i+1,j)
                  ENDDO
               ENDIF
            ENDDO
         ELSE
!
!           Compute B := B + A**T*X
!
            DO j = 1 , Nrhs
               IF ( N==1 ) THEN
                  B(1,j) = B(1,j) + D(1)*X(1,j)
               ELSE
                  B(1,j) = B(1,j) + D(1)*X(1,j) + Dl(1)*X(2,j)
                  B(N,j) = B(N,j) + Du(N-1)*X(N-1,j) + D(N)*X(N,j)
                  DO i = 2 , N - 1
                     B(i,j) = B(i,j) + Du(i-1)*X(i-1,j) + D(i)*X(i,j)   &
     &                        + Dl(i)*X(i+1,j)
                  ENDDO
               ENDIF
            ENDDO
         ENDIF
      ELSEIF ( Alpha==-ONE ) THEN
         IF ( LSAME(Trans,'N') ) THEN
!
!           Compute B := B - A*X
!
            DO j = 1 , Nrhs
               IF ( N==1 ) THEN
                  B(1,j) = B(1,j) - D(1)*X(1,j)
               ELSE
                  B(1,j) = B(1,j) - D(1)*X(1,j) - Du(1)*X(2,j)
                  B(N,j) = B(N,j) - Dl(N-1)*X(N-1,j) - D(N)*X(N,j)
                  DO i = 2 , N - 1
                     B(i,j) = B(i,j) - Dl(i-1)*X(i-1,j) - D(i)*X(i,j)   &
     &                        - Du(i)*X(i+1,j)
                  ENDDO
               ENDIF
            ENDDO
         ELSE
!
!           Compute B := B - A**T*X
!
            DO j = 1 , Nrhs
               IF ( N==1 ) THEN
                  B(1,j) = B(1,j) - D(1)*X(1,j)
               ELSE
                  B(1,j) = B(1,j) - D(1)*X(1,j) - Dl(1)*X(2,j)
                  B(N,j) = B(N,j) - Du(N-1)*X(N-1,j) - D(N)*X(N,j)
                  DO i = 2 , N - 1
                     B(i,j) = B(i,j) - Du(i-1)*X(i-1,j) - D(i)*X(i,j)   &
     &                        - Dl(i)*X(i+1,j)
                  ENDDO
               ENDIF
            ENDDO
         ENDIF
      ENDIF
!
!     End of DLAGTM
!
      END SUBROUTINE DLAGTM


c
c*******************************************************************************
c
c      Subroutine SETBFL
c
c      Created by Danny Harvey on May 23, 1989
c
c*******************************************************************************c
      SUBROUTINE SETBFL (FL, OL, FU, OU, DT)
c
      REAL*4 FL
      INTEGER*4 OL
      REAL*4 FU
      INTEGER*4 OU
      REAL*4 DT
c
c    Subroutine SETBFL will compute the recursion coefficients for a bandpass
c    minimum phase butterworth filter using a pre-warped bilinear s to z
c    transform. These coefficients are then stored in a common block and are
c    used by subroutine FILREC which applies the recursive filter to a sampled
c    data array.
c
c    Inputs  -	FL	= The lower cutoff frequency in hz. If this is zero,
c			  then the filter will be pure low pass.
c		OL	= The order of the lower cutoff sideband. If this zero,
c			  then the filter will be pure low pass.
c    		FU	= The upper cutoff frequency in hz. If this is zero,
c			  then the filter will be pure high pass.
c		OU	= The order of the upper cutoff sideband. If this zero,
c			  then the filter will be pure high pass.
c		DT	= The sampling increment in seconds of the data.
c
c    Parameters are defined as follows:
c		NSMAX	= The maximum total number of filter stages.
c
      PARAMETER  (NSMAX  =  100)
c
      COMMON /BUTFLC/ NS, IS(NSMAX), B(NSMAX), C(NSMAX), GAIN,
     1                    F(NSMAX), FM1(NSMAX), FM2(NSMAX),
     2                              RM1(NSMAX), RM2(NSMAX),
     3                              XIM1(NSMAX), XIM2(NSMAX),
     4                              XOM1(NSMAX), XOM2(NSMAX)
c
c    Get the filter stages in the s-domain.
c
      ns = 0
      IF (OL+OU .GT. NSMAX) RETURN
      IF (FU .EQ. 0.0 .OR. OU .EQ. 0) THEN
	ns = 0
	gain = 1.0
      ELSE
        CALL BUTSTA (OU, NSOUT, IS, B, C)
        CALL L2L (FU, NSOUT, IS, B, C, GN)
        NS = NSOUT
	GAIN = GN
      END IF
      IF (FL .EQ. 0.0 .OR. OL .EQ. 0) THEN
      ELSE
        CALL BUTSTA (OL, NSOUT, IS(NS+1), B(NS+1), C(NS+1))
        CALL L2H (FL, NSOUT, IS(NS+1), B(NS+1), C(NS+1), GN)
        NS = NS + NSOUT
	GAIN = GAIN * GN
      END IF
c
c    Compute the recursion coefficients.
c
      CALL RECOEF (DT, 0, 1)
c
c    Normal Exit
c
      RETURN
      END
c
c*******************************************************************************
c
c    Subroutine BUTSTA
c
c    Created by Danny Harvey on July 12, 1986
c
c*******************************************************************************
c
      SUBROUTINE BUTSTA (NORDER, NSOUT, IS, B, C)
c
c    Subroutine BUTSTA will compute a set of simple filter stages
c    from an nth order Butterworth low pass filter. This is for
c    normalized frequency with the cutoff frequency at one rad/sec.
c
c    Inputs  - NORDER = Order of the filter.
c
c    Outputs - NSOUT  = The number of stages required to describe the filter.
c              IS(NSOUT) = A stage type flag for each stage.
c                          = 0 - Stage is 1./(S + C(I))
c                          = 1 - Stage is 1./(S**2 + B(I)*S + C(I))
c                          = 2 - Stage is S/(S + C(I))
c                          = 3 - Stage is S**2/(S**2 + B(I)*S + C(I))
c              B(NSOUT),C(NSOUT) = The coefficients for each stage.
c
      DIMENSION  IS(NORDER), B(NORDER), C(NORDER)
c
      DATA  PI / 3.141592653589793 /
c
      NSOUT = 0
      IF (NORDER .LT. 1) THEN
        RETURN
      END IF
      IF (NORDER .EQ. 2*(NORDER/2)) THEN
        NODD = 0
      ELSE
        NODD = 1
      END IF
      IF (NODD .EQ. 1) THEN
        NSOUT = 1
        IS(1) = 0
        C(1) = 1.
        IF (NORDER .EQ. 1) RETURN
        M = (NORDER-1)/2
        XK = 1.
      ELSE
        M = NORDER/2
        XK = 0.5
      END IF
      XN = PI/FLOAT(NORDER)
      DO 10  I = 1,M
        NSOUT = NSOUT + 1
        IS(NSOUT) = 1
        C(NSOUT) = 1.
        B(NSOUT) = 2.0*COS(XK*XN)
        XK = XK + 1.
   10 CONTINUE
C
      RETURN
C
      END
c
c*******************************************************************************
c
c    Subroutine L2L
c
c    Created by Danny Harvey on July 12, 1986
c
c*******************************************************************************
c
      SUBROUTINE L2L (FTRAN, NS, IS, B, C, GAIN)
c
c    Subroutine L2L will perform a lowpass to lowpass frequency band
c    transformation on a normalized cutoff low pass filter.
c
c    Inputs  - FTRAN  = The desired cutoff frequency in Hz.
c              NS     = The number of filter stages.
c              IS(NS) = A stage type flag for each stage.
c                       = 0 - Stage is 1./(S + C(I))
c                       = 1 - Stage is 1./(S**2 + B(I)*S + C(I))
c                       = 2 - Stage is S/(S + C(I))
c                       = 3 - Stage is S**2/(S**2 + B(I)*S + C(I))
c              B(NS),C(NS) = The coefficients for each stage.
c
c    Outputs - B(NS),C(NS) = The transformed stage coefficients
c              GAIN  = A total filter gain function which will normalize
c                      the filter response at zero frequency.
c
      DIMENSION  IS(NS), B(NS), C(NS)
c
      DATA  PI / 3.141592653589793 /
C
      GAIN = 1.
      W = FTRAN*2.*PI
      W2 = W*W
      DO 10  I = 1, NS
        IF (IS(I) .EQ. 0) THEN
          GAIN = GAIN*W
          C(I) = C(I)*W
        ELSE IF (IS(I) .EQ. 1) THEN
          GAIN = GAIN*W2
          B(I) = B(I)*W
          C(I) = C(I)*W2
        ELSE IF (IS(I) .EQ. 2) THEN
          C(I) = C(I)*W
        ELSE
          B(I) = B(I)*W
          C(I) = C(I)*W2
        END IF
   10 CONTINUE
C
      RETURN
C
      END
c
c*******************************************************************************
c
c    Subroutine L2H
c
c    Created by Danny Harvey on July 12, 1986
c
c*******************************************************************************
c
      SUBROUTINE L2H (FTRAN, NS, IS, B, C, GAIN)
c
c    Subroutine L2H will perform a lowpass to highpass frequency band
c    transformation on a normalized cutoff low pass filter.
c
c    Inputs  - FTRAN  = The desired cutoff frequency in Hz.
c              NS     = The number of filter stages.
c              IS(NS) = A stage type flag for each stage.
c                       = 0 - Stage is 1./(S + C(I))
c                       = 1 - Stage is 1./(S**2 + B(I)*S + C(I))
c                       = 2 - Stage is S/(S + C(I))
c                       = 3 - Stage is S**2/(S**2 + B(I)*S + C(I))
c              B(NS),C(NS) = The coefficients for each stage.
c
c    Outputs - IS(NS)= The transformed stage types.
c              B(NS),C(NS) = The transformed stage coefficients.
c              GAIN  = A total filter gain function which will normalize
c                      the filter response at infinite frequency.
c
      DIMENSION  IS(NS), B(NS), C(NS)
c
      DATA  PI / 3.141592653589793 /
C
      GAIN = 1.
      W = FTRAN*2.*PI
      W2 = W*W
      DO 10  I = 1, NS
        IF (IS(I) .EQ. 0) THEN
          GAIN = GAIN/C(I)
          IS(I) = 2
          C(I) = W/C(I)
        ELSE IF (IS(I) .EQ. 1) THEN
          IS(I) = 3
          GAIN = GAIN/C(I)
          B(I) = B(I)*W/C(I)
          C(I) = W2/C(I)
        ELSE IF (IS(I) .EQ. 2) THEN
          IS(I) = 0
          GAIN = GAIN*W/C(I)
          C(I) = W/C(I)
        ELSE
          IS(I) = 1
          GAIN = GAIN*W2/C(I)
          B(I) = B(I)*W/C(I)
          C(I) = W2/C(I)
        END IF
   10 CONTINUE
C
      RETURN
C
      END
c
c******************************************************************************
c
c    Subroutine RECOEF
c
c    Created by Danny Harvey on July 25, 1986
c
c******************************************************************************
c
      SUBROUTINE RECOEF (DT, ITRAN, IWARP)
c
c    Subroutine RECOEF will compute digital filter recursion coefficients.
c
c    Inputs  - DT     = Sampling increment in seconds.
c              ITRAN  = Transform type flag.
c                       = 0 - Bilinear s to z transform.
c              IWARP  = Pre-warping flag (used only for ITRAN = 0).
c                       = 0 - Do not pre-warp.
c                       = 1 - pre-warp.
c
c    Parameters are defined as follows:
c        NSMAX  = Maximum number of filter stages.
c
      PARAMETER  (NSMAX  =  100)
c
      COMMON /BUTFLC/ NS, IS(NSMAX), B(NSMAX), C(NSMAX), GAIN,
     1                    F(NSMAX), FM1(NSMAX), FM2(NSMAX),
     2                              RM1(NSMAX), RM2(NSMAX),
     3                              XIM1(NSMAX), XIM2(NSMAX),
     4                              XOM1(NSMAX), XOM2(NSMAX)
c
      DATA  PI  / 3.141592653589793 /
c
      do 100  i = 1, ns
        if (is(i) .eq. 0) then
          omega = c(i)
          if (iwarp .eq. 1) then
            x = omega*dt
            if (x .ge. pi) x = 0.999*pi
            omega = 2.*tan(0.5*x)/dt
          end if
          den = 2. + omega*dt
          f(i) = omega*dt/den
          fm1(i) = f(i)
          fm2(i) = 0.
          rm1(i) = (2. - omega*dt)/den
          rm2(i) = 0.
        else if (is(i) .eq. 1) then
          omega = sqrt(c(i))
          z = 0.5*b(i)/omega
          if (iwarp .eq. 1) then
            x = omega*dt
            if (x .ge. pi) x = 0.999*pi
            omega = 2.*tan(0.5*x)/dt
          end if
          cc = omega*omega
          bb = 2.*z*omega
          den = 4. + 2.*dt*bb + cc*dt*dt
          f(i) = cc*dt*dt/den
          fm1(i) = 2.*f(i)
          fm2(i) = f(i)
          rm1(i) = (8. - 2.*cc*dt*dt)/den
          rm2(i) = (2.*dt*bb - 4. - cc*dt*dt)/den
        else if (is(i) .eq. 2) then
          omega = c(i)
          if (iwarp .eq. 1) then
            x = omega*dt
            if (x .ge. pi) x = 0.999*pi
            omega = 2.*tan(0.5*x)/dt
          end if
          den = 2. + omega*dt
          f(i) = 2./den
          fm1(i) = -f(i)
          fm2(i) = 0.
          rm1(i) = (2. - omega*dt)/den
          rm2(i) = 0.
        else
          omega = sqrt(c(i))
          z = 0.5*b(i)/omega
          if (iwarp .eq. 1) then
            x = omega*dt
            if (x .ge. pi) x = 0.999*pi
            omega = 2.*tan(0.5*x)/dt
          end if
          cc = omega*omega
          bb = 2.*z*omega
          den = 4. + 2.*dt*bb + cc*dt*dt
          f(i) = 4./den
          fm1(i) = -2.*f(i)
          fm2(i) = f(i)
          rm1(i) = (8. - 2.*cc*dt*dt)/den
          rm2(i) = (2.*dt*bb - 4. - cc*dt*dt)/den
        end if
  100 continue
c
c    Normal exit
c
      return
c
c    End of Subroutine RECOEF
c
      end
c
c******************************************************************************
c
c    Subroutine INIFIL
c
c******************************************************************************
c
      SUBROUTINE INIFIL (XIN)
c
      REAL*4             XIN
c
c    Subroutine INIFIL will initialize the recursion previous values to
c    be consistent with a constant input value. This will minimize startup
c    transients.
c
c    Input -	XIN	= The constant input value.
c
c    Parameters are defined as follows:
c        NSMAX  = Maximum number of filter stages.
c
      parameter  (nsmax  =  100)
c
      COMMON /BUTFLC/ NS, IS(NSMAX), B(NSMAX), C(NSMAX), GAIN,
     1                    F(NSMAX), FM1(NSMAX), FM2(NSMAX),
     2                              RM1(NSMAX), RM2(NSMAX),
     3                              XIM1(NSMAX), XIM2(NSMAX),
     4                              XOM1(NSMAX), XOM2(NSMAX)
c
      yin = xin
      do 10  i = 1, ns
	yout = yin*(f(i) + fm1(i) + fm2(i))/(1.0 - rm1(i) - rm2(i))
	xim1(i) = yin
	xim2(i) = yin
	xom1(i) = yout
	xom2(i) = yout
	yin = yout
   10 continue
c
      RETURN
      END
c
c******************************************************************************
c
c    Subroutine FILREC
c
c    Created by Danny Harvey on May 24, 1989
c
c******************************************************************************
c
      SUBROUTINE FILREC (NPTS, XIN, ISAVE, XOUT)
c
      REAL*4 XIN(npts)
      REAL*4 XOUT(npts)
c
c    Subroutine FILREC will filter an input sample array using
c    a recursive digital filter.
c
c    Inputs - 	NPTS		= The number of points in the input array.
c		XIN(NPTS)	= Input sample array.
c		ISAVE		= Save output flag.
c				  If this is 0, then the output array, XOUT,
c				  is not used. This allows the recursion
c				  previous values to be stablized by running
c				  the filter with an input time pad without
c				  saving the results.
c				  If this is not 0, then the output filtered
c				  values are saved in XOUT.
c
c    Output -	XOUT(NPTS)	= Filtered output samples.
c
c    Parameters are defined as follows:
c        NSMAX  = Maximum number of filter stages.
c
      parameter  (nsmax  =  100)
c
      COMMON /BUTFLC/ NS, IS(NSMAX), B(NSMAX), C(NSMAX), GAIN,
     1                    F(NSMAX), FM1(NSMAX), FM2(NSMAX),
     2                              RM1(NSMAX), RM2(NSMAX),
     3                              XIM1(NSMAX), XIM2(NSMAX),
     4                              XOM1(NSMAX), XOM2(NSMAX)
c
c    Loop over the input samples and apply the filter.
c
      do 50  j = 1, npts
        yin = xin(j)
        do 100  i = 1, ns
          yout = yin*f(i) + xim1(i)*fm1(i) + xim2(i)*fm2(i)
     1                    + xom1(i)*rm1(i) + xom2(i)*rm2(i)
          xom2(i) = xom1(i)
          xom1(i) = yout
          xim2(i) = xim1(i)
          xim1(i) = yin
          yin = yout
  100   continue
        if (isave .ne. 0) xout(j) = yout
   50 continue
c
c    Normal exit
c
      return
c
c    End of Subroutine FILREC
c
      end

c $Id$


      SUBROUTINE TRAPAX
C
C     THIS SUBROUTINE CALCULATES THE STIFFNESS AND MASS MATRICES FOR THE
C     ASSYMETRIC RING ELEMENT WITH A TRAPEZOIDAL CROSS SECTION
C
C     SINGLE PRECISION VERSION
C
C     ECPT FOR THE TRAPAX ELEMENT
C
C     ECPT ( 1) = ELEMENT ID                                I
C     ECPT ( 2) = SIL A                                     I
C     ECPT ( 3) = SIL B                                     I
C     ECPT ( 4) = SIL C                                     I
C     ECPT ( 5) = SIL D
C     ECPT ( 6) = MATERIAL ORIENTATION ANGLE(DEGREES)       R
C     ECPT ( 8) = MATERIAL ID                               I
C     ECPT ( 9) TO ECPT (22) FOR PHI
C     ECPT (23) = COOR. SYS. FOR GRID POINT A               I
C     ECPT (24) = X-COOR. OF GRID POINT A (IN BASIC COOR)   R
C     ECPT (25) = Z-COOR. OF GRID POINT A (IN BASIC COOR)   R
C     ECPT (26) = 0.0
C     ECPT (27) = COOR. SYS. FOR GRID POINT B
C     ECPT (28) = X-COOR. OF GRID POINT B (IN BASIC COOR)   R
C     ECPT (29) = Z-COOR. OF GRID POINT B (IN BASIC COOR)   R
C     ECPT (30) = 0.0
C     ECPT (31) = COOR. SYS. FOR GRID POINT C               I
C     ECPT (32) = X-COOR. FOR GRID POINT C                  R
C     ECPT (33) = Z-COOR. FOR GRID POINT C                  R
C     ECPT (34) = 0.0
C     ECPT (35) = COOR. SYS. FOR GRID POINT D               I
C     ECPT (36) = X-COOR FOR GRID POINT D                   R
C     ECPT (37) = Z-COOR FOR GRID POINT D                   R
C     ECPT (38) = 0.0
C     ECPT (39) = EL. TEMPERATURE FOR MATERIAL PROP         R
C
C     ANY GROUP OF STATEMENTS PREFACED BY AN IF STATEMENT CONTAINING
C     ...KSYS78 OR LSYS78 ...  INDICATES CODING NECESSARY FOR THIS
C     ELEMENT*S PIEZOELECTRIC CAPABILITY
C
C     KSYS78 = 0   ELASTIC, NON-PIEZOELECTRIC MATERIAL
C     KSYS78 = 1   ELECTRICAL-ELASTIC COUPLED, PIEZOELETRIC MATERIAL
C     KSYS78 = 2   ELASTIC ONLY, PIEZOELECTRIC MATERIAL
C     LSYS78 = .TRUE. IF KSYS78 = 0, OR 2
C
      LOGICAL         PZMAT,LSYS78,IHEAT,NOGO
      INTEGER         ELID,ESTID,DICT(14),IPART(4)
      REAL            BMASS(12,12),BMBSS(144)
      REAL            ECPT(20),R(4),Z(4),DELINT(12),EE(63),TEO(45),
     1                SP(36),GB(12,12),GBP(4,4)
      DIMENSION       ACURL(208),D(144),AK(144),AKJ(256),ICS(4),
     1                IECPT(39),D1(48),D2(16),ACURP1(48),ACURP2(16),
     2                AKUPH(48),AKPH2(16)
C     DIMENSION       AKT(27)
      COMMON /SYSTEM/ KSYSTM(77),KSYS78,KDUM2(2),IHEAT
      COMMON /EMGPRM/ DUM(15),ISMB(3),IPREC,NOGO,HEAT,ICMBAR
      COMMON /EMGDIC/ IDM,LDICT,NGRIDS,ELID,ESTID
      COMMON /EMGEST/ IDEL,IGP(4),DGAMA,GAM,MATID,IPHI(13),CSDAT(16),
     1                TEMPE
      COMMON /CONDAS/ PI,TWOPI,XQ,DEGRAD
      COMMON /MATIN / MATIDC,MATFLG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/ E(3),ANU(3),RHO,G(3),ALF(3),TZERO,GSUBE,MOSKP(9),
     1                SETMAT
      COMMON /MATPZ / PZOUT(51)
C     COMMON /MATPZ / CE11,CE12,CE13,CE14,CE15,CE16,CE22,CE23,CE24,CE25,
C                     CE26,CE33,CE34,CE35,CE36,CE44,CE45,CE46,CE55,CE56,
C                     CE66,E11,E12,E13,E14,E15,E16,E21,E22,E23,E24,E25,
C                     E26,E31,E32,E33,E34,E35,E36,EPS11,EPS12,EPS13,
C                     EPS22,
      EQUIVALENCE     (KSYSTM(2),IOUT),(ECPT(1),IECPT(1),IDEL),
     1                (BMASS(1,1),ACURL(1),BMBSS(1)),(DICT5,DICT(5)),
     2                (ACURP1(1),ACURL(145)),(ACURP2(1),ACURL(193))
      DATA    IDEL2 , JAX /    0,   4HTRAP  /
C
      LSYS78 = .FALSE.
      IF (KSYS78.EQ.0 .OR. KSYS78.EQ.2) LSYS78 = .TRUE.
      IDEL1 = IDEL/1000
      ISORT = 0
      MASOR = 0
C
C     IF STIFFNESS MATRIX NOT NEEDED GO CALCULATE MASS MATRIX
C
      DO 50 I = 1,4
      ICS(I) = IECPT(4*I+19)
      R(I) = ECPT(4*I+20)
      Z(I) = ECPT(4*I+21)
   50 D(I) = ECPT(4*I+22)
C
C     TEST THE VALIDITY OF THE GRID POINT COORDINATES
C     NOTE THAT INTEGRATION ROUTINE FAILS FOR R = 0.0
C
      DO 200 I = 1,4
      IF (R(I) .LE. 0.) GO TO 7770
      IF (D(I) .NE. 0.) GO TO 7770
  200 CONTINUE
C
C     COMPUTE THE ELEMENT COORDINATES
C
      ZMIN = AMIN1(Z(1),Z(2),Z(3),Z(4))
      DO 120 I = 1,4
  120 Z(I) = Z(I) - ZMIN
C
C     FATAL IF RATIO OF RADII IS TO LARGE FOR GUASS QUADRATURE
C
      RMIN = AMIN1(R(1),R(2),R(3),R(4))
      RMAX = AMAX1(R(1),R(2),R(3),R(4))
      IF (RMIN .EQ. 0.0) GO TO 206
      IF (RMAX/RMIN .GT. 10.) GO TO 7760
C
  206 IF (R(1).GE.R(2) .OR. R(4).GE.R(3) .OR. Z(4).LE.Z(1)) GO TO 7770
      IF (ABS(Z(1)-Z(2)) .GT. .001) GO TO 7770
      IF (ABS(Z(3)-Z(4)) .GT. .001) GO TO 7770
      D(5) = (R(1)+R(4))/2.
      D(6) = (R(2)+R(3))/2.
      IF (D(5) .EQ. 0.0) GO TO 210
      IF (ABS((R(1)-R(4))/D(5)) .GT. .005) GO TO 210
      R(1) = D(5)
      R(4) = D(5)
  210 CONTINUE
      IF (D(6) .EQ. 0.0) GO TO 220
      IF (ABS((R(2)-R(3))/D(6)) .GT. .005) GO TO 220
      R(2) = D(6)
      R(3) = D(6)
  220 CONTINUE
C
C     FORM THE TRANSFORMMATION MATRIX(12X12) FROM FIELD COOR, TO GRID
C     POINT DEGREES OF FREEDOM
C
      DO 300 I = 1,144
  300 GB( I, 1) = 0.
      GB( 1, 1) = 1.
      GB( 2, 1) = R(1)
      GB( 3, 1) = Z(1)
      GB( 4, 1) = R(1)*Z(1)
      GB( 5, 2) = 1.
      GB( 6, 2) = R(1)
      GB( 7, 2) = Z(1)
      GB( 8, 2) = GB(4,1)
      GB( 9, 3) = 1.
      GB(10, 3) = R(1)
      GB(11, 3) = Z(1)
      GB(12, 3) = GB(4,1)
      GB( 1, 4) = 1.
      GB( 2, 4) = R(2)
      GB( 3, 4) = Z(2)
      GB( 4, 4) = R(2)*Z(2)
      GB( 5, 5) = 1.
      GB( 6, 5) = R(2)
      GB( 7, 5) = Z(2)
      GB( 8, 5) = GB(4,4)
      GB( 9, 6) = 1.
      GB(10, 6) = R(2)
      GB(11, 6) = Z(2)
      GB(12, 6) = GB(4,4)
      GB( 1, 7) = 1.
      GB( 2, 7) = R(3)
      GB( 3, 7) = Z(3)
      GB( 4, 7) = R(3)*Z(3)
      GB( 5, 8) = 1.
      GB( 6, 8) = R(3)
      GB( 7, 8) = Z(3)
      GB( 8, 8) = GB(4,7)
      GB( 9, 9) = 1.
      GB(10, 9) = R(3)
      GB(11, 9) = Z(3)
      GB(12, 9) = GB(4,7)
      GB( 1,10) = 1.
      GB( 2,10) = R(4)
      GB( 3,10) = Z(4)
      GB( 4,10) = R(4)*Z(4)
      GB( 5,11) = 1.
      GB( 6,11) = R(4)
      GB( 7,11) = Z(4)
      GB( 8,11) = GB(4,10)
      GB( 9,12) = 1.
      GB(10,12) = R(4)
      GB(11,12) = Z(4)
      GB(12,12) = GB(4,10)
C
      IF (LSYS78) GO TO 305
      GBP(1,1) = 1.0
      GBP(2,1) = R(1)
      GBP(3,1) = Z(1)
      GBP(4,1) = R(1)*Z(1)
      GBP(1,2) = 1.0
      GBP(2,2) = R(2)
      GBP(3,2) = Z(2)
      GBP(4,2) = R(2)*Z(2)
      GBP(1,3) = 1.0
      GBP(2,3) = R(3)
      GBP(3,3) = Z(3)
      GBP(4,3) = R(3)*Z(3)
      GBP(1,4) = 1.0
      GBP(2,4) = R(4)
      GBP(3,4) = Z(4)
      GBP(4,4) = R(4)*Z(4)
  305 CONTINUE
C
      IF (ISMB(1) .EQ. 0) GO TO 800
C
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY
C
      ISING = -1
      CALL INVERS (12,GB,12,D(10),0,D(11),ISING,SP)
      IF (ISING .EQ. 2) GO TO 7790
C
      IF (KSYS78 .EQ. 1) CALL INVERS (4,GBP,4,D(10),0,D(11),ISING,SP)
      IF (ISING  .EQ. 2) GOTO 7790
      IF (NOGO) RETURN
C
C     DELINT(01) = (-1,0)
C     DELINT(02) = (-1,1)
C     DELINT(03) = (-1,2)
C     DELINT(04) = ( 0,0)
C     DELINT(05) = ( 0,1)
C     DELINT(06) = ( 0,2)
C     DELINT(07) = ( 1,0)
C     DELINT(08) = ( 1,1)
C     DELINT(09) = ( 1,2)
C     DELINT(10) = ( 2,0)
C     DELINT(11) = ( 2,1)
C     DELINT(12) = ( 3,0)
C
      I1 = 0
      DO 400 I = 1,4
      IP = I - 2
      DO 350 J = 1,3
      IQ = J - 1
      I1 = I1 + 1
      IF (I1 .NE. 12)  GO TO 340
      IP = 3
      IQ = 0
  340 CONTINUE
      DELINT(I1) = RZINTS(IP,IQ,R,Z,4)
  350 CONTINUE
  400 CONTINUE
C
C     LOCATE THE MATERIAL PROPERTIES IN THE MAT1 OR MAT3
C
      MATIDC = MATID
      MATFLG = 7
      IF (KSYS78 .GT. 0) MATFLG = 9
      ELTEMP = TEMPE
C
      GAMR   = DGAMA*DEGRAD
      COSG   = COS(GAMR)
      SING   = SIN(GAMR)
      SINTH  = SING
      COSTH  = COSG
      CALL MAT (IDEL)
      PZMAT  = .FALSE.
      IF (SETMAT.EQ.4. .OR. SETMAT.EQ.5.) PZMAT = .TRUE.
      IF (PZMAT) GO TO 410
      KSAVE  = KSYS78
      KSYS78 = 0
      LSYS78 = .TRUE.
      GO TO 420
  410 RHO    = PZOUT(46)
      ALF(1) = PZOUT(47)
      ALF(2) = PZOUT(48)
      ALF(3) = PZOUT(49)
      TZERO  = PZOUT(50)
      GSUBE  = PZOUT(51)
  420 CONTINUE
C
      IF (SETMAT .EQ. 2.) GO TO 7780
CWKBI SPR94002 5/94
      DICT5 = GSUBE
      IF (KSYS78 .GT.  0) GO TO 500
      V   = ANU(1)*E(2)/E(1)
      VZ  = ANU(2)*E(3)/E(2)
      VR  = ANU(3)*E(1)/E(3)
      DEL = 1./(1. - V*ANU(1)  - VZ *ANU(2)- VR*ANU(3) - ANU(1)*ANU(2)*
     1      ANU(3) - V*VZ*VR )
C
C     COMPUTE ELASTIC CONSTANTS MATRIX FROM MATERIAL TO ELEMENT AXIS
C
  500 CONTINUE
      DO 510 I = 1,45
  510 TEO(I) = 0.
C
      IF (KSYS78 .GT. 0) GO TO 520
      TEO( 1) = E(1)*(1. - ANU(2)*VZ)*DEL
      TEO( 2) = E(1)*(ANU(3) + VZ*V)*DEL
      TEO( 3) = E(3)*(1. - ANU(1)*V)*DEL
      TEO( 4) = E(1)*(V  + ANU(3)*ANU(2))*DEL
      TEO( 5) = E(2)*(VZ + ANU(1)*ANU(3))*DEL
      TEO( 6) = E(2)*(1. - VR*ANU(3))*DEL
      TEO(10) = G(3)
      TEO(15) = G(1)
      TEO(21) = G(2)
      GO TO 530
  520 CONTINUE
C
C     PIEZOELECTRIC MATERIAL PROPERTIES STORED IN TEO(22-39)
C     DIELECTRIC MATERIAL PROPERTIES STORED IN TEO(40-45)
C     TEO(22-39) CONTAINS E-TRANSPOSE
C
      TEO( 1) = PZOUT( 1)
      TEO( 2) = PZOUT( 2)
      TEO( 3) = PZOUT( 7)
      TEO( 4) = PZOUT( 3)
      TEO( 5) = PZOUT( 8)
      TEO( 6) = PZOUT(12)
      TEO( 7) = PZOUT( 4)
      TEO( 8) = PZOUT( 9)
      TEO( 9) = PZOUT(13)
      TEO(10) = PZOUT(16)
      TEO(11) = PZOUT( 5)
      TEO(12) = PZOUT(10)
      TEO(13) = PZOUT(14)
      TEO(14) = PZOUT(17)
      TEO(15) = PZOUT(19)
      TEO(16) = PZOUT( 6)
      TEO(17) = PZOUT(11)
      TEO(18) = PZOUT(15)
      TEO(19) = PZOUT(18)
      TEO(20) = PZOUT(20)
      TEO(21) = PZOUT(21)
      IF (KSYS78 .EQ. 2) GO TO 530
      TEO(22) = PZOUT(22)
      TEO(23) = PZOUT(28)
      TEO(24) = PZOUT(34)
      TEO(25) = PZOUT(23)
      TEO(26) = PZOUT(29)
      TEO(27) = PZOUT(35)
      TEO(28) = PZOUT(24)
      TEO(29) = PZOUT(30)
      TEO(30) = PZOUT(36)
      TEO(31) = PZOUT(25)
      TEO(32) = PZOUT(31)
      TEO(33) = PZOUT(37)
      TEO(34) = PZOUT(26)
      TEO(35) = PZOUT(32)
      TEO(36) = PZOUT(38)
      TEO(37) = PZOUT(27)
      TEO(38) = PZOUT(33)
      TEO(39) = PZOUT(39)
      TEO(40) =-PZOUT(40)
      TEO(41) =-PZOUT(41)
      TEO(42) =-PZOUT(42)
      TEO(43) =-PZOUT(43)
      TEO(44) =-PZOUT(44)
      TEO(45) =-PZOUT(45)
  530 CONTINUE
C
C     MATRIX EG STORED AS FOLLOWS IN EE
C       1
C      2  3
C      4  5  6
C      7  8  9 10
C     11 12 13 14 15
C     16 17 18 19 20 21
C
      C2  = COSG*COSG
      S2  = SING*SING
      C4  = C2*C2
      S4  = S2*S2
      C2S2= C2*S2
      C3  = COSG*C2
      S3  = SING*S2
      CS2 = COSG*S2
      SC2 = SING*C2
      CS  = COSG*SING
C
      EE( 1) = TEO(1)*C4 + TEO(3)*S4 + 2.*C2S2*(TEO(2)+2.*TEO(10))
      EE( 2) = TEO(2)*(C4+S4) + C2S2*(TEO(1)+TEO(3)-4.0D0*TEO(10))
      EE( 3) = TEO(1)*S4 + 2.*C2S2*(TEO(2) + 2.*TEO(10))
     3       + TEO(3)*C4
      EE( 4) = TEO(4)*C2 + TEO(5)*S2
      EE( 5) = TEO(4)*S2 + TEO(5)*C2
      EE( 6) = TEO(6)
      EE( 7) = COSG*SING*S2*(TEO(2)-TEO(3)+2.*TEO(10))
     7       + SING*COSG*C2*(TEO(1)-TEO(2)-2.*TEO(10))
      EE( 8) = SING*COSG*C2*(TEO(2)-TEO(3)+2.*TEO(10))
     8       + COSG*SING*S2*(TEO(1)-TEO(2)-2.*TEO(10))
      EE( 9) = SING*COSG*(TEO(4) - TEO(5))
      EE(10) = C2S2*(TEO(1) - 2.*TEO(2) + TEO(3)) + TEO(10)*(C2-S2)**2
      EE(11) = 0.
      EE(12) = 0.
      EE(13) = 0.
      EE(14) = 0.
      EE(15) = TEO(15)*C2 + TEO(21)*S2
      EE(20) = COSG*SING*(TEO(15) - TEO(21))
      EE(21) = TEO(15)*S2 + TEO(21)*C2
C
      IF (LSYS78) GO TO 540
C
C     PIEZOELECTRIC MATERIAL PROPERTIES IN ELEMENT COORDINATES
C
      EE(37) = C3*TEO(22) - S3*TEO(26) + CS2*(TEO(25)+2.0*TEO(32)) -
     7         SC2*(TEO(23)+2.0*TEO(31))
      EE(38) = C3*TEO(23) + S3*TEO(25) + CS2*(TEO(26)-2.0*TEO(31)) +
     8         SC2*(TEO(22)-2.0*TEO(32))
      EE(39) = S2*TEO(27) + C2*TEO(24) - 2.0*CS*TEO(33)
      EE(40) = C3*TEO(25) - S3*TEO(23) + CS2*(TEO(22)-2.0*TEO(32)) -
     O         SC2*(TEO(26)-2.0*TEO(31))
      EE(41) = C3*TEO(26) + S3*TEO(22) + CS2*(TEO(23)+2.0*TEO(31)) +
     1         SC2*( TEO(25)+2.0*TEO(32))
      EE(42) = S2*TEO(24) + C2*TEO(27) + 2.0*CS*TEO(33)
      EE(43) = COSG*TEO(28) - SING*TEO(29)
      EE(44) = COSG*TEO(29) + SING*TEO(28)
      EE(45) = TEO(30)
      EE(46) = C3*TEO(31) + S3*TEO(32) - CS2*(TEO(23)-TEO(26)+TEO(31)) +
     6         SC2*(-TEO(32)-TEO(25)+TEO(22))
      EE(47) = C3*TEO(32) - S3*TEO(31) - CS2*(TEO(25)-TEO(22)+TEO(32)) +
     7         SC2*(TEO(23)+TEO(31)-TEO(26))
      EE(48) = (C2-S2)*TEO(33) + CS*(TEO(24)-TEO(27))
      EE(49) = C2*TEO(34) + S2*TEO(38) - CS*(TEO(35)+TEO(37))
      EE(50) = C2*TEO(35) - S2*TEO(37) + CS*(TEO(34)-TEO(38))
      EE(51) = COSG*TEO(36) - SING*TEO(39)
      EE(52) = C2*TEO(37) - S2*TEO(35) - CS*(TEO(38)-TEO(34))
      EE(53) = C2*TEO(38) + S2*TEO(34) + CS*(TEO(35)+TEO(37))
      EE(54) = COSG*TEO(39) + SING*TEO(36)
C
C     DIELECTRIC MATERIAL PROPERTIES IN ELEMENT COORDINTES
C
      EE(55) = S2*TEO(43) - 2.0*CS*TEO(41) + C2*TEO(40)
      EE(56) = (C2-S2)*TEO(41) - CS*(TEO(43)-TEO(40))
      EE(57) =-SING*TEO(44) + COSG*TEO(42)
      EE(59) = C2*TEO(43) + 2.0*CS*TEO(41) + S2*TEO(40)
      EE(60) = COSG*TEO(44) + SING*TEO(42)
      EE(63) = TEO(45)
  540 CONTINUE
C
C     COMPUTE HARMONIC COEFFICIENT
C
      MJHO  = MOD(IECPT(1),1000) - 1
      AJHO  = MJHO
      AJJHO = AJHO*AJHO
C
C     FORM THE ELEMENT STIFFNESS MATRIX IN FIELD SYSTEM
C
      ACURL( 1) = (EE(6) + AJJHO*EE(15))*DELINT(1)
      ACURL( 2) = (EE(4) + EE(6) + AJJHO*EE(15))*DELINT(4)
      ACURL( 3) = (EE(6) + AJJHO*EE(15))*DELINT(2) + EE(9)*DELINT(4)
      ACURL( 4) = (EE(4) + EE(6) + AJJHO*EE(15))*DELINT(5)
     4          + EE(9)* DELINT(7)
      ACURL( 5) = AJHO*(EE(6) + EE(15))*DELINT(1)
      ACURL( 6) = AJHO*EE(6)*DELINT(4)
      ACURL( 7) = AJHO*(EE(6) +EE(15))*DELINT(2) -AJHO*EE(20)*DELINT(4)
      ACURL( 8) = AJHO*EE(6)*DELINT(5) - AJHO*EE(20)*DELINT(7)
      ACURL( 9) = AJJHO*EE(20)*DELINT(1)
      ACURL(10) = DELINT(4)*(EE(9) + AJJHO*EE(20))
      ACURL(11) = DELINT(4)*EE(5) + AJJHO*DELINT(2)*EE(20)
      ACURL(12) = DELINT(7)*EE(5) + DELINT(5)*(EE(9)+AJJHO*EE(20))
      ACURL(14) = (EE(1) + 2.*EE(4) + EE(6) + AJJHO*EE(15))*DELINT(7)
      ACURL(15) = (EE(4) + EE(6) + AJJHO*EE(15))*DELINT(5) + (EE(7)
     5          + EE(9))*DELINT(7)
      ACURL(16) = (EE(1) + 2.*EE(4) + AJJHO*EE(15) + EE(6))*DELINT(8)
     6          + (EE(7) + EE(9))*DELINT(10)
      ACURL(17) = AJHO*(EE(4) + EE(6) + EE(15))*DELINT(4)
      ACURL(18) = AJHO*(EE(4) + EE(6))*DELINT(7)
      ACURL(19) = AJHO*(EE(4) + EE(6) + EE(15))*DELINT(5) - AJHO*EE(20)
     9          * DELINT(7)
      ACURL(20) = AJHO*(EE(4) + EE(6))*DELINT(8) -AJHO*EE(20)*DELINT(10)
      ACURL(21) = AJJHO*EE(20)*DELINT(4)
      ACURL(22) = DELINT(7)*(EE(7) + EE(9) + AJJHO*EE(20))
      ACURL(23) = DELINT(7)*(EE(2) + EE(5)) + AJJHO*DELINT(5)*EE(20)
      ACURL(24) = DELINT(10)*(EE(2) + EE(5)) + DELINT(8)*(EE(7)+EE(9))
     4          + DELINT(8)*AJJHO*EE(20)
      ACURL(27) = (EE(6) + AJJHO*EE(15))*DELINT(3) + 2.*EE(9)*DELINT(5)
     7          + EE(10)*DELINT(7)
      ACURL(28) = (EE(4) + EE(6) + AJJHO*EE(15))*DELINT(6)
     8          + EE(10)*DELINT(10) + (EE(7) + 2.*EE(9))*DELINT(8)
      ACURL(29) = AJHO*(EE(6) + EE(15))*DELINT(2) + AJHO*EE(9)*DELINT(4)
      ACURL(30) = AJHO*EE(6)*DELINT(5) + AJHO*EE(9)*DELINT(7)
      ACURL(31) = AJHO*(EE(6) + EE(15))*DELINT(3) + AJHO*(EE(9)
     1          - EE(20))*DELINT(5)
      ACURL(32) = AJHO*(EE(9) - EE(20))*DELINT(8) + AJHO*EE(6)*DELINT(6)
      ACURL(33) = AJJHO*EE(20)*DELINT(2)
      ACURL(34) = DELINT(7)*EE(10) + DELINT(5)*(EE(9) + AJJHO*EE(20))
      ACURL(35) = DELINT(7)*EE(8) + DELINT(5)*EE(5) + AJJHO*DELINT(3)
     5          * EE(20)
      ACURL(36) = DELINT(10)*EE(8) + DELINT(8)*(EE(5) + EE(10))
     6          + DELINT(6)*(EE(9) + AJJHO*EE(20))
      ACURL(40) = (EE(1) + 2.*EE(4) + EE(6)  + AJJHO*EE(15))*DELINT(9)
     O          + (2.*EE(7) + 2.*EE(9))*DELINT(11) + EE(10)*DELINT(12)
      ACURL(41) = AJHO*(EE(4) + EE(6) + EE(15))*DELINT(5)
     1          + AJHO*EE(9)*DELINT(7)
      ACURL(42) = AJHO*(EE(4) + EE(6))*DELINT(8) + AJHO*EE(9)*DELINT(10)
      ACURL(43) = AJHO*(EE(4) + EE(6) + EE(15))*DELINT(6)
     3          + AJHO*(EE(9) - EE(20))*DELINT(8)
      ACURL(44) = AJHO*(EE(4) + EE(6))*DELINT(9) + AJHO*(EE(9) - EE(20))
     4          * DELINT(11)
      ACURL(45) = AJJHO*EE(20)*DELINT(5)
      ACURL(46) = DELINT(8)*(EE(7) + EE(9) + AJJHO*EE(20)) + DELINT(10)
     6          * EE(10)
      ACURL(47) = DELINT(8)*(EE(2) + EE(5)) + DELINT(10)*EE(8)
     7          + AJJHO*DELINT(6)*EE(20)
      ACURL(48) = DELINT(11)*(EE(2) + EE(5) + EE(10)) + DELINT(12)*EE(8)
     8          + DELINT(9)*(EE(7) + EE(9) + AJJHO*EE(20))
      ACURL(53) = (EE(15) + AJJHO*EE(6))*DELINT(1)
      ACURL(54) = AJJHO*EE(6)*DELINT(4)
      ACURL(55) = (EE(15) + AJJHO*EE(6))*DELINT(2) - EE(20)*DELINT(4)
      ACURL(56) = AJJHO*EE(6)*DELINT(5) - EE(20)*DELINT(7)
      ACURL(57) = AJHO*EE(20)*DELINT(1)
      ACURL(58) = AJHO*DELINT(4)*(EE(9) + EE(20))
      ACURL(59) = AJHO*(DELINT(4)*EE(5) + DELINT(2)*EE(20))
      ACURL(60) = AJHO*(DELINT(7)*EE(5) + DELINT(5)*(EE(9) + EE(20)))
      ACURL(66) = AJJHO*EE(6)*DELINT(7)
      ACURL(67) = AJJHO*EE(6)*DELINT(5)
      ACURL(68) = AJJHO*EE(6)*DELINT(8)
      ACURL(69) = 0.
      ACURL(70) = AJHO*DELINT(7)*EE(9)
      ACURL(71) = AJHO*DELINT(7)*EE(5)
      ACURL(72) = AJHO*(DELINT(10)*EE(5) + DELINT(8)*EE(9))
      ACURL(79) = (EE(15) + AJJHO*EE(6))*DELINT(3) - 2.*EE(20)*DELINT(5)
     9          + EE(21)*DELINT(7)
      ACURL(80) = AJJHO*EE(6)*DELINT(6) - EE(20)*DELINT(8)
     O          + EE(21)*DELINT(10)
      ACURL(81) = AJHO*(EE(20)*DELINT(2) - EE(21)*DELINT(4))
      ACURL(82) = AJHO*(DELINT(5)*(EE(9) + EE(20)) - DELINT(7)*EE(21))
      ACURL(83) = AJHO*(DELINT(5)*(EE(5) - EE(21)) + DELINT(3)*EE(20))
      ACURL(84) = AJHO*(DELINT(8)*(EE(5) - EE(21)) + DELINT(6)*(EE(9)
     4          + EE(20)))
      ACURL(92) = EE(21)*DELINT(12) + AJJHO*EE(6)*DELINT(9)
      ACURL(93) =-AJHO*EE(21)*DELINT(7)
      ACURL(94) = AJHO*(DELINT(8)*EE(9) - DELINT(10)*EE(21))
      ACURL(95) = AJHO*DELINT(8)*(EE(5) - EE(21))
      ACURL(96) = AJHO*(DELINT(11)*(EE(5) - EE(21)) + DELINT(9)*EE(9))
      ACURL(105) = AJJHO*EE(21)*DELINT(1)
      ACURL(106) = AJJHO*DELINT(4)*EE(21)
      ACURL(107) = AJJHO*DELINT(2)*EE(21)
      ACURL(108) = AJJHO*DELINT(5)*EE(21)
      ACURL(118) = DELINT(7)*(EE(10) + AJJHO*EE(21))
      ACURL(119) = DELINT(7)*EE(8) + AJJHO*DELINT(5)*EE(21)
      ACURL(120) = DELINT(10)*EE(8) + DELINT(8)*(EE(10) + AJJHO*EE(21))
      ACURL(131) = DELINT(7)*EE(3) + AJJHO*DELINT(3)*EE(21)
      ACURL(132) = DELINT(10)*EE(3) + DELINT(8)*EE(8) + AJJHO*DELINT(6)
     2           * EE(21)
      ACURL(144) = DELINT(12)*EE(3) + 2.*DELINT(11)*EE(8) + DELINT(9)
     4           * (EE(10) + AJJHO*EE(21))
C
      IF (LSYS78) GO TO 550
      ACURL(145) = DELINT(1)*AJHO*(AJHO*EE(51) - EE(45))
      ACURL(146) = DELINT(4)*(EE(43) + AJHO*(AJHO*EE(51) - EE(49)
     6           - EE(45)))
      ACURL(147) = DELINT(2)*AJHO*(AJHO*EE(51) - EE(45)) + DELINT(4)
     7           * (EE(44) - AJHO*EE(50))
      ACURL(148) = DELINT(5)*(EE(43) + AJHO*(AJHO*EE(51) - EE(49)
     8           - EE(45))) + DELINT(7)*(EE(44) - AJHO*EE(50))
      ACURL(149) = DELINT(4)*AJHO*(AJHO*EE(51) - EE(45) - EE(39))
      ACURL(150) = DELINT(7)*(EE(43) + EE(37) + AJHO*(AJHO*EE(51)
     O           - EE(49) - EE(45) - EE(39)))
      ACURL(151) = DELINT(5)*AJHO*(AJHO*EE(51) - EE(45) - EE(39))
     1           + DELINT(7)*(EE(44) + EE(38) - AJHO*EE(50))
      ACURL(152) = DELINT(8)*(EE(43) + EE(37) + AJHO*(AJHO*EE(51)
     2           - EE(49) - EE(45) - EE(39))) + DELINT(10)*(EE(44)
     2           + EE(38) - AJHO*EE(50))
      ACURL(153) = DELINT(2)*AJHO*(AJHO*EE(51) - EE(45)) - DELINT(4)
     3           * AJHO*EE(48)
      ACURL(154) = DELINT(5)*(EE(43) + AJHO*(AJHO*EE(51) - EE(49)
     4           - EE(45))) + DELINT(7)*(EE(46) - AJHO*EE(48))
      ACURL(155) = DELINT(3)*AJHO*(AJHO*EE(51) - EE(45)) + DELINT(5)
     1           * (EE(44) - AJHO*(EE(50) + EE(48))) + DELINT(7)*EE(47)
      ACURL(156) = DELINT(6)*(EE(43) + AJHO*(AJHO*EE(51) - EE(49)
     6           - EE(45))) + DELINT(8)*(EE(46) + EE(44) - AJHO*(EE(50)
     6           + EE(48))) + DELINT(10)*EE(47)
      ACURL(157) = DELINT(5)*AJHO*(AJHO*EE(51) - EE(45) - EE(39))
     7           - DELINT(7)*AJHO*EE(48)
      ACURL(158) = DELINT(8)*(EE(43) + EE(47) + AJHO*(AJHO*EE(51)
     8           - EE(49) - EE(45) - EE(39))) - DELINT(10)*(EE(46)
     8           - AJHO*EE(48))
      ACURL(159) = DELINT(6)*AJHO*(AJHO*EE(51) - EE(45) - EE(39))
     9           + DELINT(8)*(EE(44) + EE(38) - AJHO*(EE(50) + EE(48)))
     9           + DELINT(10)*EE(47)
      ACURL(160) = DELINT(9)*(EE(43) + EE(37) + AJHO*(AJHO*EE(51)
     O           - EE(49) - EE(45) - EE(39))) + DELINT(11)*(EE(46)
     O           + EE(44) + EE(38) - AJHO*(EE(50) + EE(48)))
     O           + DELINT(12)*EE(47)
      ACURL(161) = DELINT(1)*AJHO*(EE(51) - AJHO*EE(45))
      ACURL(162) = DELINT(4)*(-EE(49) + AJHO*(EE(51) + EE(43)
     2           - AJHO*EE(45)))
      ACURL(163) = DELINT(2)*AJHO*(EE(51) - AJHO*EE(45)) + DELINT(4)
     3           * (AJHO*EE(44) - EE(50))
      ACURL(164) = DELINT(5)*(-EE(49) + AJHO*(EE(51) + EE(43) - AJHO
     4           * EE(51))) + DELINT(7)*(AJHO*EE(44) - EE(50))
      ACURL(165) =-DELINT(4)*AJJHO*EE(45)
      ACURL(166) = DELINT(7)*AJHO*(EE(43) - AJHO*EE(45))
      ACURL(167) = DELINT(7)*AJHO*EE(44) - DELINT(5)*AJJHO*EE(45)
      ACURL(168) = DELINT(8)*AJHO*(EE(43) - AJHO*EE(45)) + DELINT(10)
     8           * AJHO*EE(44)
      ACURL(169) = DELINT(2)*AJHO*(EE(51) - AJHO*EE(45)) - DELINT(4)
     9           * AJHO*EE(54)
      ACURL(170) = DELINT(5)*(-EE(49) + AJHO*(EE(51) + EE(43) - AJHO
     O           * EE(45))) + DELINT(7)*(EE(52) - AJHO*EE(54))
      ACURL(171) = DELINT(3)*AJHO*(EE(51) - AJHO*EE(45)) + DELINT(5)
     1           * (AJHO*(EE(44) - EE(54)) - EE(50)) + DELINT(7)*EE(53)
      ACURL(172) = DELINT(6)*(-EE(49) + AJHO*(EE(51) + EE(43) - AJHO
     2           * EE(45))) + DELINT(8)*(EE(52) - EE(50) + AJHO
     2           * (EE(44) - EE(54))) + DELINT(10)*EE(53)
      ACURL(173) =-DELINT(5)*AJJHO*EE(45) - DELINT(7)*AJHO*EE(54)
      ACURL(174) = DELINT(8)*AJHO*(EE(43) - AJHO*EE(45)) + DELINT(10)
     4           * (EE(54) - AJHO*EE(54))
      ACURL(175) =-DELINT(6)*AJJHO*EE(45) + DELINT(8)*AJHO*(EE(44)
     5           - EE(54)) + DELINT(10)*EE(53)
      ACURL(176) = DELINT(9)*AJHO*(EE(43) - AJHO*EE(45)) + DELINT(11)
     6           * (EE(52) + AJHO*(EE(44) - EE(54))) + DELINT(12)*EE(53)
      ACURL(177) = DELINT(1)*AJJHO*EE(54)
      ACURL(178) = DELINT(4)*AJHO*(AJHO*EE(54) - EE(52))
      ACURL(179) = DELINT(2)*AJJHO*EE(54) - DELINT(4)*AJHO*EE(53)
      ACURL(180) = DELINT(5)*AJHO*(AJHO*EE(54) - EE(52)) - DELINT(7)
     O           * AJHO*EE(53)
      ACURL(181) = DELINT(4)*AJHO*(AJHO*EE(54) - EE(48))
      ACURL(182) = DELINT(7)*(EE(46) + AJHO*(AJHO*EE(54) - EE(52)
     2           - EE(48)))
      ACURL(183) = DELINT(5)*AJHO*(AJHO*EE(54) - EE(48)) + DELINT(7)
     3           * (EE(47)-AJHO*EE(53))
      ACURL(184) = DELINT(8)*(EE(46) + AJHO*(AJHO*EE(54) - EE(52)
     4           - EE(48))) + DELINT(10)*(EE(47) - AJHO*EE(53))
      ACURL(185) = DELINT(2)*AJJHO*EE(54) - DELINT(4)*AJHO*EE(42)
      ACURL(186) = DELINT(5)*AJHO*(AJHO*EE(54) - EE(52)) + DELINT(7)
     6           * (EE(40) - AJHO*EE(42))
      ACURL(187) = DELINT(3)*AJJHO*EE(54) - DELINT(5)*AJHO*(EE(53)
     7           + EE(42)) + DELINT(7)*EE(41)
      ACURL(188) = DELINT(6)*AJHO*(AJHO*EE(54) - EE(52)) + DELINT(8)
     8           * (EE(40) - AJHO*(EE(53) + EE(42))) + DELINT(10)*EE(41)
      ACURL(189) =-DELINT(5)*AJHO*EE(48) + DELINT(4)*AJJHO*EE(54)
     9           - DELINT(7)*AJHO*EE(42)
      ACURL(190) = DELINT(8)*(EE(46) - AJHO*EE(48)) + DELINT(7)*AJHO
     O           * (AJHO*EE(54) - EE(52)) + DELINT(10)*(EE(40)
     O           - AJHO*EE(42))
      ACURL(191) =-DELINT(6)*AJHO*EE(48) + DELINT(5)*AJJHO*EE(54)
     1           + DELINT(8)*(EE(47) - AJHO*EE(42)) - DELINT(7)*AJHO
     1           * EE(53) + DELINT(10)*EE(41)
      ACURL(192) = DELINT(9)*(EE(46) - AJHO*EE(48)) + DELINT(8)*AJHO
     2           * (AJHO*EE(54) - EE(52)) + DELINT(11)*(EE(47) + EE(40)
     2           - AJHO*EE(42)) - DELINT(10)*AJHO*EE(53) + DELINT(12)
     2           * EE(41)
      ACURL(193) = DELINT(1)*AJJHO*EE(63)
      ACURL(194) = DELINT(4)*AJHO*(AJHO*EE(63) - EE(57))
      ACURL(195) = DELINT(2)*AJJHO*EE(63) - DELINT(4)*AJHO*EE(60)
      ACURL(196) = DELINT(5)*AJHO*(AJHO*EE(63) - EE(57)) - DELINT(7)
     6           * AJHO*EE(60)
      ACURL(197) = DELINT(4)*AJHO*(AJHO*EE(63) - EE(57))
      ACURL(198) = DELINT(7)*(AJJHO*EE(63) - 2.0*AJHO*EE(57) + EE(55))
      ACURL(199) = DELINT(5)*AJHO*(AJHO*EE(63) - EE(57)) + DELINT(7)
     9           * (EE(56) - AJHO*EE(60))
      ACURL(200) = DELINT(8)*(AJJHO*EE(63) - 2.0*AJHO*EE(57) + EE(55))
     O           + DELINT(10)*(EE(56) - AJHO*EE(60))
      ACURL(201) = DELINT(2)*AJJHO*EE(63) - DELINT(4)*AJHO*EE(60)
      ACURL(202) = DELINT(5)*AJHO*(AJHO*EE(63) - EE(57)) + DELINT(7)
     2           * (EE(56) - AJHO*EE(60))
      ACURL(203) = DELINT(3)*AJJHO*EE(63) - DELINT(5)*2.0*AJHO*EE(60)
     3           + DELINT(7)*EE(59)
      ACURL(204) = DELINT(6)*AJHO*(AJHO*EE(63) - EE(57)) + DELINT(8)
     4           * (EE(56) - 2.0*AJHO*EE(60)) + DELINT(10)*EE(59)
      ACURL(205) = DELINT(5)*AJHO*(AJHO*EE(63) - EE(57)) - DELINT(7)
     5           * AJHO*EE(60)
      ACURL(206) = DELINT(8)*(AJJHO*EE(63) - 2.0*EE(57) + EE(55))
     6           + DELINT(10)*(EE(56) - AJHO*EE(60))
      ACURL(207) = DELINT(6)*AJHO*(AJHO*EE(63) - EE(57)) + DELINT(8)
     7           * (EE(56) - 2.0*AJHO*EE(60)) + DELINT(10)*EE(59)
      ACURL(208) = DELINT(9)*(AJJHO*EE(63) - 2.0*AJHO*EE(57) + EE(55))
     8           + 2.0*DELINT(11)*(EE(56) - AJHO*EE(60)) + DELINT(12)
     8           * EE(59)
  550 CONTINUE
C
C     TRANSFORM THE ELEMENT STIFFNESS MATRIX FROM FIELD SYSTEM
C     TO GRID POINT DEGREES OF FREEDOM
C
C     EXPAND ACURL INTO (12X12)
C
      DO 610 IB = 2,12
      IC = 13*IB - 25
      I  = IC
      DO 605 J = IB,12
      IC = IC + 12
      I  = I  + 1
  605 ACURL(IC) = ACURL(I)
  610 CONTINUE
C
      DGAMA = PI
      IF (AJHO .EQ. 0.) DGAMA = TWOPI
      DO 630 I = 1,144
      ACURL(I) = ACURL(I)*DGAMA
  630 CONTINUE
C
      IF (LSYS78) GO TO 638
      DO 632 I = 145,208
  632 ACURL(I) = ACURL(I)*DGAMA
  638 CONTINUE
C
      CALL GMMATS (GB,12,12,1, ACURL,12,12,0, D )
      CALL GMMATS (D ,12,12,0, GB   ,12,12,0, AK)
C
      IF (LSYS78) GO TO 639
      CALL GMMATS (GB,12,12,1, ACURP1,12,4,0, D1)
      CALL GMMATS (D1,12,4,0, GBP,4,4,0, AKUPH)
      CALL GMMATS (GBP,4,4,1, ACURP2,4,4,0, D2)
      CALL GMMATS (D2,4,4,0, GBP,4,4,0, AKPH2)
  639 CONTINUE
C
      DO 640 I = 1,256
  640 AKJ(I) = 0.
      GO TO 655
C
C     COORDINATE SYSTEMS NOT POSSIBLE WITH RINGAX  CODE BELOW COULD
C     IMPLEMENT IT.
C
C     IF FOLLOWING CODE IS IMPLEMENTED MUST BE MODIFIED FOR
C     PIEZOELECTRIC
C
C     DO 650 I = 1,4
C     IF (ICS(I) .EQ. 0) GOTO 650
C     K = 9*(I-1) + 1
C     CALL TRANSS (ICS(I),D(K))
C 650 CONTINUE
C
C     SELECT THE APPROPRIATE SUB MATRIX FOR TRANSFORMATION
C
C     DO 690 IPP = 1,4
C     IR1 = 3*(IPP-1) + 1
C     IAPP= 9*(IPP-1) + 1
C     DO 680 I = 1,4
C     IC1 = 3*(I-1) + 1
C     IRC = (IR1-1)*12 + IC1
C     AKT(1) = AK(IRC   )
C     AKT(2) = AK(IRC+ 1)
C     AKT(3) = AK(IRC+ 2)
C     AKT(4) = AK(IRC+12)
C     AKT(5) = AK(IRC+13)
C     AKT(6) = AK(IRC+14)
C     AKT(7) = AK(IRC+24)
C     AKT(8) = AK(IRC+25)
C     AKT(9) = AK(IRC+26)
C
C     MORE COORDINATE SYSTEM CHANGE CODE
C
C     TRANSFORM THE STIFFNESS  SUB MATRICES  AS NECESSARY
C
C     IAKT = 1
C     IF (ICS(IPP) .EQ. 0) GO TO 660
C     CALL GMMATS (D(IAPP),3,3,1, AKT(1),3,3,0, AKT(10))
C     IAKT = 10
C     IF (ICS(I).EQ.0 .AND. ICS(IPP).EQ.0) GO TO 680
C 660 IF (ICS(I) .EQ.0) GO TO 670
C     IAI = 9*(I-1) + 1
C     CALL GMMATS (AKT(IAKT),3,3,0, D(IAI),3,3,0, AKT(IAKT+9))
C     IAKT = IAKT + 9
C
C     REPLACE THE TRANSFORMED MATRICES IN ORIGINAL MATRIX
C
C 670 AK(IRC   ) = AKT(IAKT  )
C     AK(IRC+ 1) = AKT(IAKT+1)
C     AK(IRC+ 2) = AKT(IAKT+2)
C     AK(IRC+12) = AKT(IAKT+3)
C     AK(IRC+13) = AKT(IAKT+4)
C     AK(IRC+14) = AKT(IAKT+5)
C     AK(IRC+24) = AKT(IAKT+6)
C     AK(IRC+25) = AKT(IAKT+7)
C     AK(IRC+26) = AKT(IAKT+8)
C
C 680 CONTINUE
C 690 CONTINUE
C
C     CREATE AN ARRAY POINTING TO THE GRIDS ACCORDING TO INCREASING
C     SIL VALUE
C
  655 CONTINUE
C
      ASSIGN 780 TO K OR M
  700 CONTINUE
      DO 705 I = 1,4
      IPART(I) = IECPT(I+1)
  705 CONTINUE
      I = -4
  710 J = 0
      DO 715 KK = 1,4
      IF (IPART(KK) .LT. J) GO TO 715
      J = IPART(KK)
      L = KK
  715 CONTINUE
      IPART(L) = I
      I = I + 1
      IF (I .LT. 0) GO TO 710
      DO 720 I = 1,4
      IPART(I) = -IPART(I)
  720 CONTINUE
      ISORT = 1
      GO TO K OR M, (780,880)
C
C     REARRANGE  AK  INTO AKJ BY INCREASING SIL VALUE
C     NOTE AKJ ALREADY INITALIZED TO ZERO
C
  780 DO 770 I = 1,4
      IT = IPART(I)
      DO 760 J = 1,4
      JT = IPART(J)
      DO 750 K = 1,3
      DO 740 L = 1,3
      IKJ = (IT-1)*64 + (JT-1)*4 + (K-1)*16 + L
      IF (MASOR .EQ. 1) IKJ = (IT-1)*36 + (JT-1)*3 + (K-1)*12 + L
      IK  = (I-1)*36 + (J-1) *3 +(K-1)*12 + L
      AKJ(IKJ) = AK(IK)
C
      IF (MASOR .EQ. 1) GO TO 740
      IF (LSYS78) GO TO 740
      IKJA = IKJ - L + 4
      IKA  = (IK-L)/3 + 1
      IKJB = (JT-1)*64 + 48 + (IT-1)*4 + K
      IKJC = (IT-1)*64 + 52 + (JT-1)*4
      IKC  = (I-1)*4 + J
      AKJ(IKJA) = AKUPH(IKA)
      AKJ(IKJB) = AKUPH(IKA)
      AKJ(IKJC) = AKPH2(IKC)
  740 CONTINUE
  750 CONTINUE
  760 CONTINUE
  770 CONTINUE
      IF (MASOR .EQ. 1) GO TO 895
C
C     SET UP CONSTANTS AND OUTPUT AKJ
C
      DICT(1) = ESTID
      DICT(2) = 1
      DICT(3) = 16
      DICT(4) = 15
CWKBD SPR94002 5/94      DICT5   =  GSUBE
      IP      = IPREC
      CALL EMGOUT (AKJ,AKJ,256,1,DICT,1,IP)
C
C    COME HERE TO CALCULATE THE MASS  MATRIX. THIS ROUTINE WILL
C    CALCULATE EITHER THE CONSISTENT OR LUMPED MASS MATRICES
C    DEPENDING ON THE PARAMETER ICM BAR
C
C
C     IF STIFFNESS MATRIX NOT NEEDED WE HAVE ALL WE NEED FOR THE
C     MASS MATRIX CALCULATIONS
  800 IF (ISMB(2).EQ.0 .AND. .NOT.PZMAT) KSYS78 = KSAVE
      IF (ISMB(2) .EQ. 0) RETURN
      IF (ICMBAR  .LT. 0) GO TO 820
      I1 = 0
      DO 810 I = 1,3
      IP = I
      DO 810 J = 1,3
      IQ = J - 1
      I1 = I1 + 1
      DELINT(I1) = RZINTS(IP,IQ,R,Z,4)
  810 CONTINUE
C
  820 IF (ISMB(1) .NE. 0) GO TO 830
      MATIDC = MATID
      MATFLG = 7
      IF (KSYS78 .GT. 0) MATFLG = 9
      ELTEMP = TEMPE
      GAMR   = DGAMA*DEGRAD
      COSTH  = COS(GAMR)
      SINTH  = SIN(GAMR)
      CALL MAT (IDEL)
      IF (KSYS78 .GT.  0) RHO = PZOUT(46)
      IF (SETMAT .EQ. 2.) GO TO 7780
C
C     COMPUTE THE HARMONIC COEFFICIENT
C
  830 MJHO = MOD(IECPT(1),1000) - 1
      AJHO = MJHO
      RHOD = RHO*PI
      IF (AJHO  .EQ. 0.) RHOD = 2.*RHOD
      IF (ICMBAR .LT. 0) GO TO 900
C
C     COMPUTE THE CONSISTENT MASS MATRIX IN FIELD COORDINATES
C
      DO 840 I = 1,144
  840 BMASS( I, 1) = 0.
      BMASS( 1, 1) = DELINT(1)
      BMASS( 1, 2) = DELINT(4)
      BMASS( 1, 3) = DELINT(2)
      BMASS( 1, 4) = DELINT(5)
      BMASS( 2, 2) = DELINT(7)
      BMASS( 2, 3) = DELINT(5)
      BMASS( 2, 4) = DELINT(8)
      BMASS( 3, 3) = DELINT(3)
      BMASS( 3, 4) = DELINT(6)
      BMASS( 4, 4) = DELINT(9)
      BMASS( 5, 5) = DELINT(1)
      BMASS( 5, 6) = DELINT(4)
      BMASS( 5, 7) = DELINT(2)
      BMASS( 5, 8) = DELINT(5)
      BMASS( 6, 6) = DELINT(7)
      BMASS( 6, 7) = DELINT(5)
      BMASS( 6, 8) = DELINT(8)
      BMASS( 7, 7) = DELINT(3)
      BMASS( 7, 8) = DELINT(6)
      BMASS( 8, 8) = DELINT(9)
      BMASS( 9, 9) = DELINT(1)
      BMASS( 9,10) = DELINT(4)
      BMASS( 9,11) = DELINT(2)
      BMASS( 9,12) = DELINT(5)
      BMASS(10,10) = DELINT(7)
      BMASS(10,11) = DELINT(5)
      BMASS(10,12) = DELINT(8)
      BMASS(11,11) = DELINT(3)
      BMASS(11,12) = DELINT(6)
      BMASS(12,12) = DELINT(9)
      DO 860 IB = 2,12
      IC = 13*IB - 25
      I  = IC
      DO 850 J = IB,12
      IC = IC + 12
      I  = I + 1
  850 BMBSS(I) = BMBSS(IC)
  860 CONTINUE
      DO 870 I = 1,144
  870 BMBSS(I) = BMBSS(I)*RHOD
C
C     TRANSFORM THE ELEMENT MASS MATRIX FROM FIELD COORDINATES TO
C     GRID  POINT DEGREES  OF FREEDOM
C
      CALL GMMATS (GB,12,12,1, BMASS,12,12,0, D)
      CALL GMMATS (D ,12,12,0, GB,12,12,0, AK)
      DO 875 I = 1,256
  875 AKJ(I) = 0.
      IF (ISORT .EQ. 1) GO TO 880
      ASSIGN 880 TO K OR M
      GO TO  700
C
C     REARRANGE AK INTO AKJ BY INCREASING SIL VALUE
C
  880 MASOR = 1
      GO TO 780
C
  895 DICT(1) = ESTID
      DICT(2) = 1
      DICT(3) = 12
      DICT(4) =  7
CWKBD SPR94002 5/94      DICT5   =  0.
      IP      = IPREC
C
      CALL EMGOUT (AKJ,AKJ,144,1,DICT,2,IP)
      GO TO 940
C
C
C     LUMPED MASS CALCULATIONS HANDLED HERE
C
  900 AR = (R(1)*(Z(2)-Z(4)) + R(2)*(Z(3)-Z(1)) + R(3)*(Z(4)-Z(2)) +
     1      R(4)*(Z(1)-Z(3)))/2.
      AKJ(1) = RHOD*(R(1) + R(2) + R(3) + R(4))/4.*AR
      AKJ(1) = AKJ(1)/4.0
      DO 920 I = 2,12
  920 AKJ(I) = AKJ(1)
C
      DICT(1) = ESTID
      DICT(2) = 2
      DICT(3) = 12
      DICT(4) = 7
CWKBD SPR94002 5/94      DICT5   = 0.
      IP      = IPREC
C
      CALL EMGOUT (AKJ,AKJ,12,1,DICT,2,IP)
  940 IF (.NOT.PZMAT) KSYS78 = KSAVE
      RETURN
C
C     SET FATAL ERROR FLAG AND ALLOWING ERROR MESSAGES TO ACCUMULATE
C
 7760 I = 218
      GO TO 7800
 7770 I = 37
      GO TO 7800
C
C     MAT2 NOT LEGAL
C
 7780 I = 126
      GO TO 7800
 7790 I =  26
 7800 IF (IDEL1 .EQ. IDEL2) GO TO 7810
      IDEL2  = IDEL1
      ICS(1) = IDEL1
      ICS(2) = JAX
      CALL MESAGE (30,I,ICS)
 7810 NOGO = .TRUE.
      GO TO 940
      END


C
C $Id: istr32.f,v 1.6 2008-07-27 00:17:16 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE ISTR32 (UT,VT,WT,XT,YT,ZT,IENT)
C
C This routine implements the 3-space to 2-space transformation by
C Kuber, Szabo and Giulieri, as described in "The Perspective
C Representation of Functions of Two Variables", Journal of the ACM
C 15, 2, 193-204, 1968.
C
C If IENT = 1, the transformation is being defined:
C
C   UT, VT, and WT are the 3-space coordinates of the intersection of
C   the line of sight and the image plane.  This point can be thought
C   of as the point looked at.
C
C   XT, YT, and ZT are the 3-space coordinates of the eye position.
C
C If IENT is 2, a point is being transformed:
C
C   UT, VT, WT are the 3-space coordinates of a point to be transformed.
C
C   XT and YT are the coordinates resulting from the 3-space to 2-space
C   transformation.  When ISCALE is zero, XT and YT are in the same
C   units as U, V, and W.  When ISCALE is non-zero, XT and YT are in
C   the fractional coordinate system.
C
C   ZT is not used.
C
C Due to the nature of this routine, all variables used in it are saved
C from call to call.
C
      SAVE
C
      COMMON /ISCOMN/ BIG,BIGD,DBPI,IDONE,IFILL,IFLIP,IONES,IHSS(1000),
     +                IREF,ISCA(16,256),ISCALE,ISCR(16,256),ISLBT,ISDR,
     +                LHSS,LX,NFPW,NINU,NINV,NINW,NX,NY,R0,RNX,RNY,
     +                SMALL,SVAL,TENSN,U,V,W,XMAX,XMIN,YMAX,YMIN,XVPL,
     +                XVPR,YVPB,YVPT
C
      COMMON /PWRZ1I/ UUMIN,UUMAX,VVMIN,VVMAX,WWMIN,WWMAX,DELCRT,EYEU,
     +                EYEV,EYEW
C
C Define the range of fractional coordinates to be used.
C
      DATA FXL,FXR,FYB,FYT / .0005,.9995,.0005,.9995 /
C
C Define the value of "pi".
C
      DATA PI / 3.14159265358979 /
C
C Decide what kind of call was done.
C
      IF (IENT .NE. 1) GO TO  50
C
C The transformation is to be defined:
C
      AU = UT
      AV = VT
      AW = WT
      EU = XT
      EV = YT
      EW = ZT
C
      DU = AU-EU
      DV = AV-EV
      DW = AW-EW
      D = SQRT(DU*DU+DV*DV+DW*DW)
      COSAL = DU/D
      COSBE = DV/D
      COSGA = DW/D
C
      AL = ATAN(ABS(SQRT(1.-COSAL*COSAL)/COSAL))
      IF (COSAL .LE. 0.) AL = PI-AL
      BE = ATAN(ABS(SQRT(1.-COSBE*COSBE)/COSBE))
      IF (COSBE .LE. 0.) BE = PI-BE
      GA = ATAN(ABS(SQRT(1.-COSGA*COSGA)/COSGA))
      IF (COSGA .LE. 0.) GA = PI-GA
      SINGA = SIN(GA)
C
C The 3-space point looked at is transformed into (0,0) of the 2-space
C plane.  The 3-space W axis is transformed into the 2-space Y axis.
C If the line of sight is almost parallel to the 3-space W axis, the
C 3-space V axis is chosen (instead of the 3-space W axis) to be
C transformed into the 2-space Y axis.
C
      JDONE = 2
      IF (ISCALE)  10, 30, 10
   10 X0 = XMIN
      Y0 = YMIN
      X1 = FXL
      Y1 = FYB
      X2 = FXR-FXL
      Y2 = FYT-FYB
      X3 = X2/(XMAX-XMIN)
      Y3 = Y2/(YMAX-YMIN)
      X4 = FXR
      Y4 = FYT
      FACT = 1.
      IF (BIGD .LE. 0.) GO TO  20
      X0 = -BIGD
      Y0 = -BIGD
      X3 = X2/(2.*BIGD)
      Y3 = Y2/(2.*BIGD)
      FACT = R0/D
   20 DELCRT = X2*32767.
      JDONE = 1
   30 IF (SINGA .LT. 0.0001) GO TO  40
      R = 1./SINGA
      JUMP = 2
      RETURN
   40 SINBE = SIN(BE)
      R = 1./SINBE
      JUMP = 1
      RETURN
C
C A point is to be transformed:
C
   50 UU = UT
      VV = VT
      WW = WT
      Q = D/((UU-EU)*COSAL+(VV-EV)*COSBE+(WW-EW)*COSGA)
      GO TO (60, 70), JUMP
   60 UU = ((EW+Q*(WW-EW)-AW)*COSAL-(EU+Q*(UU-EU)-AU)*COSGA)*R
      VV = (EV+Q*(VV-EV)-AV)*R
      GO TO (80, 90), JDONE
   70 UU = ((EU+Q*(UU-EU)-AU)*COSBE-(EV+Q*(VV-EV)-AV)*COSAL)*R
      VV = (EW+Q*(WW-EW)-AW)*R
      GO TO (80, 90), JDONE
   80 XT = MIN(X4,MAX(X1,X1+X3*(FACT*UU-X0)))
      YT = MIN(Y4,MAX(Y1,Y1+Y3*(FACT*VV-Y0)))
      RETURN
   90 XT = UU
      YT = VV
      RETURN
C
      END


	FUNCTION SND_SHD  ( datain, nparm, k, deltaz, ivcord )
C************************************************************************
C* SND_SHD								*
C*									*
C* This function computes the wind shear direction for a layer.		*
C*									*
C* SND_SHD  ( DATAIN, NPARM, K, DELTAZ, IVCORD )			*
C*									*
C* Input parameters:							*
C*	DATAIN (LLMXLV)	REAL		Interpolated sounding data	*
C*	NPARM		INTEGER		Number of parameters		*
C*	K		INTEGER		Current sounding level		*
C*	DELTAZ		REAL		Height interval			*
C*	IVCORD		INTEGER		Vertical coordinate		*
C*									*
C* Output parameters:							*
C*	SND_SHD		REAL		Wind shear direction		*
C**									*
C* Log:									*
C* S. Jacobs/EAI	 5/92						*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'sndiag.prm'
C*
	REAL            datain (*)
C*
	REAL    	stndb (10), stndt (10), stndl (10)
	CHARACTER       cvalue*20
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	SND_SHD = RMISSD
C
C*	Get information over a depth.
C
c	dfdpth = 0.
c	idfcrd = 3
c	CALL PC_DPTH  ( datain, nparm, clev, ivcord, dfdpth, idfcrd, 1,
c     +			depth, idcord, stndl, stndb, stndt, ier )
C
C*	Check for missing data.
C
c	IF  ( ier .ne. 0 )  RETURN
c	DO  i = 4, 6
c	    IF ( ERMISS ( stndb (i) ) ) RETURN
c	    IF ( ERMISS ( stndt (i) ) ) RETURN
c	END DO
c	depth = stndt (6) - stndb (6)
c	IF  ( depth .eq. 0.0 )  RETURN
C
C*	Do shear calculation.
C
c	CALL PC_GCND ( '$', 1, dir, cvalue, ier )
c	utop = stndt (4)
c	vtop = stndt (5)
c	ubot = stndb (4)
c	vbot = stndb (5)
	depth = deltaz
	utop = datain((k-1+1)*nparm+IUABS)
	vtop = datain((k-1+1)*nparm+IVABS)
	ubot = datain((k-1-1)*nparm+IUABS)
	vbot = datain((k-1-1)*nparm+IVABS)
c	IF ( ier .ne. 0 ) THEN
	    dudz = ( utop - ubot ) / ( 2. * depth )
	    dvdz = ( vtop - vbot ) / ( 2. * depth )
	    SND_SHD = PR_DRCT ( dudz, dvdz )
c	  ELSE
c	    SND_SHD = dir
c	END IF
C*
	RETURN
	END


  !
  !diagonal bath hamiltonian: +energy of the bath=\sum_a=1,Norb\sum_{l=1,Nbath}\e^a_l n^a_l
  htmp=zero
  do iorb=1,size(dmft_bath%e,2)
     do kp=1,Nbath
        alfa=getBathStride(iorb,kp)
        htmp =htmp + dmft_bath%e(1,iorb,kp)*ib(alfa)        !UP
        htmp =htmp + dmft_bath%e(Nspin,iorb,kp)*ib(alfa+Ns) !DW
     enddo
  enddo
  !
  Hmat(i,i) = Hmat(i,i) + htmp
  !


	INTEGER I,J,ADM,ATIVIDA(4)
	REAL MATERIA(4,7),CUSTOUN(1,7),CUSTOAT(4),CUSTOL(4),ENCARGS(4)
	REAL CUSTOTT,MATERTT(7)
	OPEN(UNIT=1,FILE="materiais.dat",STATUS="OLD")
	OPEN(UNIT=2,FILE="custoun.dat",STATUS="OLD")
	CUSTOAT = 0.0
	CUSTOL = 0.0
	ENCARGS = 0.0
	CUSTOTT = 0.0
	MATERTT = 0.0
	DO I = 1,4
		IF(I.EQ.1)READ(2,10)(CUSTOUN(I,J),J=1,7)
		READ(1,10)(MATERIA(I,J),J=1,7)
	END DO
	DO I = 1,4
		IF(I.EQ.1) THEN
			WRITE(*,10)(CUSTOUN(I,J),J=1,7)
			WRITE(*,*)
		END IF
		WRITE(*,10)(MATERIA(I,J),J=1,7)
	END DO
10	FORMAT(7(F5.1,2X))
C	LEITURA DA TAXA DE ADMINISTRACAO
	READ(*,20)ADM
	READ(*,20)(ATIVIDA(I),I=1,4)
20	FORMAT(4(I3,1X))
C	======================ETAPA D.1 E D.2==========================
	DO I = 1,4
		DO J = 1,7
			CUSTOAT(I)=CUSTOAT(I)+ATIVIDA(I)*MATERIA(I,J)*CUSTOUN(1,J)
		END DO
		CUSTOAT(I)=CUSTOAT(I)*(1.+ADM/100.)
		CUSTOL(I)=CUSTOAT(I)*1.36
	END DO
C	=========================ETAPA D.3=============================
	DO I = 1,4
		DO J = 4,5
			ENCARGS(I)=ENCARGS(I)+ATIVIDA(I)*MATERIA(I,J)*CUSTOUN(1,J)
		END DO
		ENCARGS(I) = ENCARGS(I)*0.16
	END DO
C	=========================ETAPA D.4=============================
	DO I = 1,4
		CUSTOTT = CUSTOTT + CUSTOL(I)+ENCARGS(I)
	END DO
	WRITE(*,*)CUSTOTT
	PAUSE
C	=========================ETAPA D.5=============================
	DO J = 1,7
		DO I = 1,4
			MATERTT(J) = MATERTT(J) + MATERIA(I,J)*ATIVIDA(I)
		END DO
	END DO
	WRITE(*,*)(MATERTT(J),I=1,7)
	STOP
	END


c gmm01f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
C  subroutine gau0.f generates tabulated values for
C  Gaunt coefficients up to n=v=n_max
      subroutine gau0(nmax)
      include 'gmm01f.par'
      parameter (ni0=np*(np+1)*(2*np+1)/3+np*np)
      parameter (ng0=np*(2*np**3+10*np**2+19*np+5)/6)
      integer v,qmax,uvmax,iga0(ni0)
      double precision ga0(ng0)
      common/g0/ga0
      common/ig0/iga0
          na=0
          uvmax=nmax*(nmax+2)
          i=0
      do m=-nmax,nmax
         ns=max(1,iabs(m))
         do n=ns,nmax
            do v=ns,nmax
               call gxurcd0(-m,n,v,qmax,na)
               i=i+1
                   iga0(i)=na
               na=na+qmax+1
                enddo
         enddo
          enddo
      return
      end


!-----------------------------------------------------------------------------------
! Name: rpn3(ixyz,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)
!
! Description: Roe f-wave solver for the 3D Euler equations in general geometries
!
! Waves: 3
! Equations: 5
!
! Conserved Quantities:
!       1 density
!       2 x_momentum
!       3 y_momentum
!       4 z_momentum
!       5 energy
!
! Auxilliary Quantities:
!       1  nx xface (i-1/2,j,k)
!       2  ny xface (i-1/2,j,k)
!       3  nz xface (i-1/2,j,k)
!       4  gamma_x (area/(dyc*dzc))
!       5  nx yface (i,j-1/2,k)
!       6  ny yface (i,j-1/2,k)
!       7  nz yface (i,j-1/2,k)
!       8  gamma_x (area/(dxc*dzc))
!       9  nx zface (i,j,k-1/2)
!       10 ny zface (i,j,k-1/2)
!       11 nz zface (i,j,k-1/2)
!       12 gamma_z (area/(dxc*dyc))
!       13 kappa(i,j,k) volumeOfHex/(dxc*dyc*dzc)
!       14 dz (Cartesian), dr (Spherical)
!       15 z (Cartesian), r (Spherical)
!
! Inputs:
!         ixyz <INTEGER>   : direction to take slice x-direction if ixyz=1
!                                                    y-direction if ixyz=2.
!                                                    z-direction if ixyz=3.
!         maxm <INTEGER>   : max number of grid cells (less the ghost cells)
!         meqn <INTEGER>   : number of equations in the system (=5)
!         mwaves <INTEGER> : nuber of waves in the system (=3)
!         maux <INTEGER>   : number of auxilary variables (=15)
!         mbc <INTEGER>    : number of ghost cells on either end
!         mx <INTEGER>     : number of elements
!         ql <REAL>        : state vector at left edge of each cell
!                            Note the i'th Riemann problem has left state qr(:,i-1)
!         qr <REAL>        : state vector at right edge of each cell
!                            Note the i'th Riemann problem has right state ql(:,i)
!         auxl <REAL>      : state of auxilary variable on left egde of cell
!         auxr <REAL>      : state of auxilary variable on right egde of cell
!
! Outputs:
!          fwave <REAL>    : f-wave vectors (eigenvectors of Roe matrix)
!          s <REAL>        : eigenvalues (eigenvalues of Roe matrix)
!          amdq <REAL>     : left-going fluctuations
!          apdq <REAL>     : right-going fluctuations
!
! Adapted from rpn3_euler.f90 in $CLAWHOME/riemann/src
!-----------------------------------------------------------------------------------
SUBROUTINE rpn3(ixyz,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)

  IMPLICIT NONE

  ! Input
  INTEGER, INTENT(IN) :: ixyz,maxm,meqn,mwaves,maux,mbc,mx
  REAL(kind=8), DIMENSION(meqn,1-mbc:maxm+mbc), INTENT(IN) :: ql,qr
  REAL(kind=8), DIMENSION(maux,1-mbc:maxm+mbc), INTENT(IN) :: auxl,auxr

  ! Output
  REAL(kind=8), DIMENSION(meqn,mwaves,1-mbc:maxm+mbc), INTENT(INOUT) :: fwave
  REAL(kind=8), DIMENSION(mwaves,1-mbc:maxm+mbc), INTENT(INOUT) :: s
  REAL(kind=8), DIMENSION(meqn,1-mbc:maxm+mbc), INTENT(INOUT) :: amdq,apdq

  ! Local Storage
  REAL(kind=8), DIMENSION(meqn) :: delta,beta
  REAL(kind=8), DIMENSION(-1:maxm+mbc) :: u,v,w,enth,ek,a,a2g1,psi
  REAL(kind=8) :: gamma1,asqrd,pl,pr,vnl,vnr,rhsq2,rhsqrtl,rhsqrtr,nx,ny,nz,vn,&
       areaRatio,dr,finterp,qinterp,quinterp,qvinterp,qwinterp
  INTEGER :: i,j,mu=2,mv=3,mw=4,mws,nu,nv,nw,iratio=4,gFlux=0
  CHARACTER(20) :: nonsingularNormal

  ! Common block storage for ideal gas constant and gravity term
  REAL(kind=8) :: gamma ! Ideal gas constant
  REAL(kind=8) :: g_r  ! Gravitational Constant Magnitude
  LOGICAL :: gravity,gravityflux ! Turn Gravity Source Term On/Off
  COMMON /cparam/ gamma,g_r,gravity,gravityflux

  ! Set (gamma-1)
  gamma1 = gamma - 1.d0

  ! Gravity in Energy Flux On/Off
  gFlux = 0
  IF(gravityflux)gFlux=1

  ! Make sure the number of waves is 3 for this solver
  IF (mwaves /= 3) THEN
     WRITE(6,*) '*** Must set mwaves=3 for this Riemann solver'
     STOP
  ENDIF

  ! Set mu to point to  the component of the system that corresponds to momentum in
  !  the direction of this slice, mv and mw to the orthogonal momentums.  Set the
  !  nu,nv,and nw indices for the normal vectors in a similar way.  The iratio is
  !  the aux array index for the gamma area scaling for mapped grids.
  IF(ixyz == 1)THEN
     mu = 2
     mv = 3
     mw = 4
     iratio = 4
  ELSE IF(ixyz == 2)THEN
     mu = 3
     mv = 4
     mw = 2
     iratio = 8
  ELSE IF (ixyz == 3)THEN
     mu = 4
     mv = 2
     mw = 3
     iratio = 12
  ELSE
     WRITE(*,*)"Something is wrong with ixyz..."
     STOP
  ENDIF
  nu = (ixyz-1)*4 + mu - 1
  nv = (ixyz-1)*4 + mv - 1
  nw = (ixyz-1)*4 + mw - 1

  ! Note that notation for u,v, and w reflects assumption that the
  !   Riemann problems are in the x-direction with u in the normal
  !   direction and v and w in the orthogonal directions, but with the
  !   above definitions of mu, mv, and mw the routine also works with
  !   ixyz=2 and ixyz = 3
  !   and returns, for example, f0 as the Godunov flux g0 for the
  !   Riemann problems u_t + g(u)_y = 0 in the y-direction.

  ! Initialize fwaves and speeds
  fwave = 0.d0
  s = 0.d0

  ! Loop over grid cell interfaces
  DO i = 2-mbc, mx+mbc
     IF (qr(1,i-1) <= 0.d0 .OR. ql(1,i) <= 0.d0) THEN
        WRITE(*,*) i, mu, mv, mw
        WRITE(*,'(5e12.4)') (qr(j,i-1),j=1,5)
        WRITE(*,'(5e12.4)') (ql(j,i),j=1,5)
        IF (ixyz == 1) WRITE(6,*) '*** (rpn3) rho <= 0 in x-sweep at ',i
        IF (ixyz == 2) WRITE(6,*) '*** (rpn3) rho <= 0 in y-sweep at ',i
        IF (ixyz == 3) WRITE(6,*) '*** (rpn3) rho <= 0 in z-sweep at ',i
        WRITE(6,*) 'stopped with rho <= 0...'
        STOP
     ENDIF
     rhsqrtl = SQRT(qr(1,i-1))
     rhsqrtr = SQRT(ql(1,i))
     pl = gamma1*(qr(5,i-1) - 0.5d0*(qr(mu,i-1)**2 + &
          qr(mv,i-1)**2 + qr(mw,i-1)**2)/qr(1,i-1) &
          - qr(1,i-1)*(g_r)*auxr(15,i-1)*gFlux )
     pr = gamma1*(ql(5,i) - 0.5d0*(ql(mu,i)**2 + &
          ql(mv,i)**2 + ql(mw,i)**2)/ql(1,i) &
          - ql(1,i)*(g_r)*auxl(15,i)*gFlux )
     rhsq2 = rhsqrtl + rhsqrtr
     u(i) = (qr(mu,i-1)/rhsqrtl + ql(mu,i)/rhsqrtr) / rhsq2
     v(i) = (qr(mv,i-1)/rhsqrtl + ql(mv,i)/rhsqrtr) / rhsq2
     w(i) = (qr(mw,i-1)/rhsqrtl + ql(mw,i)/rhsqrtr) / rhsq2
     enth(i) = ((qr(5,i-1)+pl)/rhsqrtl + (ql(5,i)+pr)/rhsqrtr) / rhsq2
     psi(i) = (qr(1,i-1)*(g_r)*auxr(15,i-1)/rhsqrtl &
          + ql(1,i)*(g_r)*auxl(15,i)/rhsqrtr)/rhsq2*gFlux
     ek(i) = 0.5d0*(u(i)**2 + v(i)**2 + w(i)**2)
     asqrd = gamma1*(enth(i) - ek(i))
     IF (i>=0 .AND. i<=mx .AND. asqrd <= 0.d0) THEN
        IF (ixyz == 1) WRITE(6,*) '*** (rpn3) a**2 <= 0 in x-sweep at ',i
        IF (ixyz == 2) WRITE(6,*) '*** (rpn3) a**2 <= 0 in y-sweep at ',i
        IF (ixyz == 3) WRITE(6,*) '*** (rpn3) a**2 <= 0 in z-sweep at ',i
        WRITE(6,*) 'stopped with a**2 < 0...'
        STOP
     ENDIF
     a(i) = SQRT(asqrd)
     a2g1(i)  = asqrd/gamma1
  END DO

  ! Now split the jump in q1d at each interface into f-waves
  !   find alpha(1) thru alpha(5), the coefficients of the 5 eigenvectors:
  DO i = 2-mbc, mx+mbc

     ! Normal Vectors, Normal Velocity, and Area Ratio
     nx = auxl(nu,i)
     ny = auxl(nv,i)
     nz = auxl(nw,i)
     vn = u(i)*nx + v(i)*ny + w(i)*nz
     areaRatio = auxl(iratio,i)

     ! Compute the jumps (delta F) in the flux functions
     pl = gamma1*(ql(5,i) &
          - 0.5d0*(ql(mu,i)**2+ql(mv,i)**2+ql(mw,i)**2)/ql(1,i) &
          - ql(1,i)*(g_r)*auxl(15,i)*gFlux)
     pr = gamma1*(qr(5,i-1) &
          - 0.5d0*(qr(mu,i-1)**2+qr(mv,i-1)**2+qr(mw,i-1)**2)/qr(1,i-1) &
          - qr(1,i-1)*(g_r)*auxr(15,i-1)*gFlux)
     vnl = (ql(mu,i)*nx + ql(mv,i)*ny + ql(mw,i)*nz)/ql(1,i)
     vnr = (qr(mu,i-1)*nx + qr(mv,i-1)*ny + qr(mw,i-1)*nz)/qr(1,i-1)
     delta(1) = ql(1,i)*vnl - qr(1,i-1)*vnr
     delta(2) = (vnl*ql(mu,i) + pl*nx) - (vnr*qr(mu,i-1) + pr*nx)
     delta(3) = (vnl*ql(mv,i) + pl*ny) - (vnr*qr(mv,i-1) + pr*ny)
     delta(4) = (vnl*ql(mw,i) + pl*nz) - (vnr*qr(mw,i-1) + pr*nz)
     delta(5) = ((ql(5,i) + pl)*vnl) - ((qr(5,i-1) + pr)*vnr)

     ! Modify delta(2/3/4/5) to account for gravitational term
     IF(gravity .AND. ixyz==3)THEN
        dr = (auxl(14,i) + auxl(14,i-1))*0.5d0
        finterp = auxl(14,i-1)/(auxl(14,i)+auxl(14,i-1))
        qinterp = ql(1,i)*finterp + qr(1,i-1)*(1.d0-finterp)
        quinterp = ql(mu,i)*finterp + qr(mu,i-1)*(1.d0-finterp)
        qvinterp = ql(mv,i)*finterp + qr(mv,i-1)*(1.d0-finterp)
        qwinterp = ql(mw,i)*finterp + qr(mw,i-1)*(1.d0-finterp)
        delta(2) = delta(2) + dr*g_r*nx*qinterp
        delta(3) = delta(3) + dr*g_r*ny*qinterp
        delta(4) = delta(4) + dr*g_r*nz*qinterp
        IF(.NOT.gravityflux)&
             delta(5) = delta(5) + dr*g_r*(quinterp*nx + qvinterp*ny + qwinterp*nz)
     END IF

     ! Pick the largest normal to avoid using a singular direction
     IF(ABS(nx) >= ABS(ny) .AND. ABS(nx) >= ABS(nz))THEN
        nonsingularNormal = "x"
     ELSEIF(ABS(ny) >= ABS(nx) .AND. ABS(ny) >= ABS(nz))THEN
        nonsingularNormal = "y"
     ELSEIF(ABS(nz) >= ABS(nx) .AND. ABS(nz) >= ABS(ny))THEN
        nonsingularNormal = "z"
     ELSE
        WRITE(*,*)"Invalid Normal Vector..."
        WRITE(*,*)"nx: ",nx,"ny: ",ny,"nz: ",nz
        STOP
     END IF

     beta(4) = ((enth(i) + psi(i) - 2.d0*ek(i))*delta(1) &
          + u(i)*delta(2) + v(i)*delta(3) + w(i)*delta(4) - delta(5))/a2g1(i)
     beta(5) = ( (a(i)-vn)*delta(1) - a(i)*beta(4) &
          + nx*delta(2) + ny*delta(3) + nz*delta(4) )/(2.d0*a(i))
     beta(1) = delta(1) - beta(4) - beta(5)

     SELECT CASE(TRIM(nonsingularNormal))
     CASE("x")
        beta(2) = ( (v(i)-vn*ny)*delta(1) + nx*ny*delta(2) &
             + (ny**2-1.d0)*delta(3) + ny*nz*delta(4) )/nx
        beta(3) = (-(w(i)-vn*nz)*delta(1) - nx*nz*delta(2) &
             - ny*nz*delta(3) - (nz**2-1.d0)*delta(4) )/nx
     CASE("y")
        beta(2) = (-(u(i)-vn*nx)*delta(1) - (nx**2-1.d0)*delta(2) &
             - ny*nx*delta(3) - nx*nz*delta(4) )/ny
        beta(3) = ( (w(i)-vn*nz)*delta(1) + nx*nz*delta(2) &
             + ny*nz*delta(3) + (nz**2-1.d0)*delta(4) )/ny
     CASE("z")
        beta(2) = ( (u(i)-vn*nx)*delta(1) + (nx**2-1.d0)*delta(2) &
             + nx*ny*delta(3) + nz*nx*delta(4) )/nz
        beta(3) = (-(v(i)-vn*ny)*delta(1) - nx*ny*delta(2) &
             - (ny**2-1.d0)*delta(3) - nz*ny*delta(4) )/nz
     END SELECT

     ! Compute the f-waves.
     !   Note that the 2-wave, 3-wave and 4-wave travel at the same speed
     !   and are lumped together in fwave(.,2,.).  The 5-wave is then stored
     !   in fwave(.,3,.).
     fwave(1,1,i)  = beta(1)
     fwave(mu,1,i) = beta(1)*(u(i)-a(i)*nx)
     fwave(mv,1,i) = beta(1)*(v(i)-a(i)*ny)
     fwave(mw,1,i) = beta(1)*(w(i)-a(i)*nz)
     fwave(5,1,i)  = beta(1)*(enth(i) + psi(i) - a(i)*vn)
     s(1,i) = (vn-a(i))*areaRatio

     fwave(1,2,i)  = beta(4)
     SELECT CASE(TRIM(nonsingularNormal))
     CASE("x")
        fwave(mu,2,i) = beta(4)*u(i) + beta(2)*ny - beta(3)*nz
        fwave(mv,2,i) = beta(4)*v(i) - beta(2)*nx
        fwave(mw,2,i) = beta(4)*w(i) + beta(3)*nx
        fwave(5,2,i)  = beta(4)*(ek(i) + psi(i))  &
             + beta(2)*(u(i)*ny-v(i)*nx) + beta(3)*(w(i)*nx-u(i)*nz)
     CASE("y")
        fwave(mu,2,i) = beta(4)*u(i) + beta(2)*ny
        fwave(mv,2,i) = beta(4)*v(i) - beta(2)*nx + beta(3)*nz
        fwave(mw,2,i) = beta(4)*w(i) - beta(3)*ny
        fwave(5,2,i)  = beta(4)*(ek(i) + psi(i))  &
             + beta(2)*(u(i)*ny-v(i)*nx) + beta(3)*(v(i)*nz-w(i)*ny)
     CASE("z")
        fwave(mu,2,i) = beta(4)*u(i) - beta(2)*nz
        fwave(mv,2,i) = beta(4)*v(i) + beta(3)*nz
        fwave(mw,2,i) = beta(4)*w(i) + beta(2)*nx - beta(3)*ny
        fwave(5,2,i)  = beta(4)*(ek(i) + psi(i))  &
             + beta(2)*(w(i)*nx-u(i)*nz) + beta(3)*(v(i)*nz-w(i)*ny)
     END SELECT
     s(2,i) = vn*areaRatio

     fwave(1,3,i)  = beta(5)
     fwave(mu,3,i) = beta(5)*(u(i)+a(i)*nx)
     fwave(mv,3,i) = beta(5)*(v(i)+a(i)*ny)
     fwave(mw,3,i) = beta(5)*(w(i)+a(i)*nz)
     fwave(5,3,i)  = beta(5)*(enth(i) + psi(i) + a(i)*vn)
     s(3,i) = (vn+a(i))*areaRatio

     ! Compute fluctuations amdq and apdq
     !  amdq = SUM s*fwave   over left-going waves
     !  apdq = SUM s*fwave   over right-going waves
     amdq(:,i) = 0.d0
     apdq(:,i) = 0.d0
     DO mws=1,mwaves
        fwave(:,mws,i) = fwave(:,mws,i)*areaRatio
        IF (s(mws,i) < 0.d0) THEN
           amdq(:,i) = amdq(:,i) + fwave(:,mws,i)
        ELSE
           apdq(:,i) = apdq(:,i) + fwave(:,mws,i)
        ENDIF
     END DO

  END DO
END SUBROUTINE rpn3


*DECK SPOFA
      SUBROUTINE spofa(a,lda,n,info)
      INTEGER lda,n,info
      DOUBLE PRECISION a(lda,1)
C
C     SPOFA FACTORS A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX.
C
C     SPOFA IS USUALLY CALLED BY SPOCO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR SPOCO) = (1 + 18/N)*(TIME FOR SPOFA) .
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE SYMMETRIC MATRIX TO BE FACTORED.  ONLY THE
C                DIAGONAL AND UPPER TRIANGLE ARE USED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX  R  SO THAT  A = TRANS(R)*R
C                WHERE  TRANS(R)  IS THE TRANSPOSE.
C                THE STRICT LOWER TRIANGLE IS UNALTERED.
C                IF  INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
C
C        INFO    INTEGER
C                = 0  FOR NORMAL RETURN.
C                = K  SIGNALS AN ERROR CONDITION.  THE LEADING MINOR
C                     OF ORDER  K  IS NOT POSITIVE DEFINITE.
C
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SDOT
C     FORTRAN SQRT
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION sdot,t
      DOUBLE PRECISION s
      INTEGER j,jm1,k
C     BEGIN BLOCK WITH ...EXITS TO 40
C
C
      DO 30 j = 1,n
          info = j
          s = 0.0E0
          jm1 = j - 1
          IF (jm1.LT.1) GO TO 20
          DO 10 k = 1,jm1
              t = a(k,j) - sdot(k-1,a(1,k),1,a(1,j),1)
              t = t/a(k,k)
              a(k,j) = t
              s = s + t*t
   10     CONTINUE
   20     CONTINUE
          s = a(j,j) - s
C     ......EXIT
          IF (s.LE.0.0E0) GO TO 40
          a(j,j) = sqrt(s)
   30 CONTINUE
      info = 0
   40 CONTINUE
      RETURN

      END


!
! This file is released under terms of BSD license
! See LICENSE file for more information
!
! Simple program to test the kcache directive
!

PROGRAM claw_test
  INTEGER :: istart = 0
  INTEGER :: iend = 10
  INTEGER :: jstart = 0
  INTEGER :: jend = 20
  CALL call_test(istart,iend,jstart,jend)
END PROGRAM claw_test

PURE FUNCTION f(i,j)
  INTEGER, INTENT(IN) :: i,j
  REAL :: f
  f = 1.0 * i * j
END FUNCTION

SUBROUTINE call_test(istart,iend,jstart,jend)
  INTEGER, INTENT(IN) :: istart, iend, jstart, jend
  INTEGER :: i,j
  REAL, DIMENSION(istart:iend,istart:iend) :: array6, array7

  DO i = istart, iend
    DO j = jstart, jend
      array6(i,j) = 1.0 * i * j
    END DO
  END DO

  DO i = istart, iend
    DO j = jstart, jend
      array7(i,j) = array6(i,j) * 2.0
    END DO
  END DO
END SUBROUTINE call_test


submodule(euler_interface_m) euler_prob_0005_m
    implicit none

contains

    module character(len=20) function euler0005()
        write (euler0005, "(i20)") ans(20_int64)
    end function euler0005

    integer(int64) function ans(n)
        integer(int64), intent(in) :: n
        integer(int64) :: i, tmp

        tmp = 1_int64
        do i = 1_int64, n
            tmp = lcm(tmp, i)
        end do
        ans = tmp
    end function ans

end submodule euler_prob_0005_m


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.
    ! This default version simply sets eta = max(h + b,0)

    ! For more specific initial conditions
    !  copy this to an application directory and
    !  loop over all grid cells to set values of q(1:meqn, 1:mx).

    !use geoclaw_module, only: dry_tolerance !uncomment if needed
    use geoclaw_module, only: grav  !uncomment if needed
    use grid_module, only: xgrid,zgrid,mx_grid

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    !locals
    integer :: i
    real(kind=8) :: xcell,r,x0

    real(kind=8) :: eta
    real(kind=8) :: dz(mx)

    ! assume displaced surface agrees with sea floor deformation
    open(unit=33,file='dtopo_okada.data',status='old',form='formatted')

    do i=1,mx
        read(33,*) dz(i)
        enddo

    do i=1,mx
        eta = dz(i)
        q(1,i) = max(0.d0, eta - aux(1,i))
        q(2,i) = 0.d0

   enddo

end subroutine qinit