      PROGRAM TORSIN4Q
C=======================================================================
C           2-DIM FEM PROGRAM FOR SOLVING TORSION EQUATION
C                  USING UPPER HALF BANDED MATRIX
C              EQUATION: DP/DX + DP/DY + ALPHA * P = 0.
C                ELEMENT : 4-NODED ISO-PARAMETERIC
C         NUMBERING ORDER: (-1,-1),(+1,-1),(+1,+1),(-1,+1)
C  ORIGINAL:1984 EIJI FUKUMORI BUFFALO NY & REVISED: DEC, 2006 TAKAHAMA
C=======================================================================
      IMPLICIT REAL*8 ( A-H , O-Z )
      PARAMETER ( ND=4,MXE=30000,MXN=30000,MXB=3000,INTEPT=2,MXW=500 )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN), IBND(MXB),
     * ITYPE(MXB), BVALUE(MXB),RK(MXN,MXW), RHS(MXN),SK(ND,ND), 
     * X(ND), Y(ND),BX(2,ND),SAI(INTEPT), W(INTEPT),SS(ND,ND),
     * BPP(2,ND,INTEPT,INTEPT), SF(ND,INTEPT,INTEPT),
     * DUMMY0(ND), DUMMY1(ND), XS(ND), YS(ND), BPPX(2,ND,ND)
      DIMENSION  SOURCE(MXN),TAUZX(MXN),TAUZY(MXN),NDREPEAT(MXN)
      CHARACTER INPFILE*12
      WRITE (*,*)' TORSIN4Q.FOR SOLVER'
C=======================================================================
      CALL GRULE ( INTEPT, SAI, W   )
      CALL DERIV ( ND, INTEPT, X, Y, SAI, BPP )
      CALL SHAPEF( ND, INTEPT, X, SAI, SF )
C=======================================================================
      INPFILE = 'TRS4DATA.QQQ'
      WRITE(*,*)' INPUT FILE NAME =', INPFILE
      CALL INPUT ( ND,MXE,MXN,MXB,NE,NNODE,NB,GM,THETA, NODEX,
     * XCOORD,YCOORD,IBND,ITYPE,BVALUE, INPFILE )
C=======================================================================
      CALL BANDWID ( MXE, ND, NE,NODEX, NBW )
      IF ( NBW .GT. MXW ) STOP 'Error ... NBW > MXW'
C=======================================================================
      CALL DAREA ( MXE,MXN,INTEPT,ND,BPP,W,NE,XCOORD,YCOORD,
     * NODEX, AREA )
C=======================================================================
      CALL GSM ( INTEPT,ND,NBW ,MXE,MXN,MXW,NE,NNODE,BPP,W,BX,SS,
     * NODEX,XCOORD,YCOORD,RK )
C=======================================================================
      CALL SRCTRM ( MXE,MXN,INTEPT,ND,NNODE,BPP,W,NE,GM,THETA,
     * SF,XCOORD,YCOORD,NODEX,SS, SOURCE )
C=======================================================================
      CALL FORMQ (MXN,MXB,MXW,NNODE,NB,NBW,RK,RHS,ITYPE,BVALUE,IBND,
     *                  SOURCE)
C=======================================================================
      CALL SYSTEM ( MXN, MXW, NNODE, NBW, RK, RHS )
C=======================================================================
      CALL MOMENT ( MXE,MXN,INTEPT,ND,BPP,W,NE,SF,
     * XCOORD,YCOORD,NODEX, RHS,TORQUE  )
C=======================================================================
      CALL STRESS ( ND,MXE,MXN,NE,NNODE,BPPX,NODEX,XCOORD,YCOORD,
     * XS, YS, DUMMY0, DUMMY1, RHS, NDREPEAT,TAUZX,TAUZY )
C=======================================================================
      CALL PRINT ( MXN, NNODE , RHS )
      CALL PRINTG ( ND,MXE,MXN, NNODE,NE,  XCOORD, YCOORD,
     *                      GM,THETA, NODEX,MXB, NB, IBND,ITYPE,BVALUE,
     *                      RHS,TORQUE,TAUZX,TAUZY, AREA )
C=======================================================================
      STOP
      END
C
C
      SUBROUTINE GSM ( INTEPT,ND,NBW ,MXE,MXN,MXW,NE,NNODE,BPP,W,BX,SS,
     * NODEX,XCOORD,YCOORD,RK )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),RK(MXN,MXW),
     * SS(ND,ND), BX(2,ND),W(INTEPT), BPP(2,ND,INTEPT,INTEPT)
C====== RESET GLOBAL MATRIX RK ======
      DO I = 1, NNODE
      DO J = 1, NBW
      RK(I,J) = 0.
      END DO
      END DO
C===== INTEGRATION =======
      DO IEL = 1 ,NE
      DO I = 1 , ND
      DO J = I , ND
      SS(I,J) = 0.
      END DO
      END DO
      DO K = 1 , INTEPT
      DO L = 1 , INTEPT
      WEIGHT = W(K) * W(L)
      YAC11 = 0.
      YAC12 = 0.
      YAC21 = 0.
      YAC22 = 0.
      DO I = 1 , ND
      YAC11 = YAC11 + BPP(1,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC12 = YAC12 + BPP(1,I,K,L) * YCOORD(NODEX(IEL,I))
      YAC21 = YAC21 + BPP(2,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC22 = YAC22 + BPP(2,I,K,L) * YCOORD(NODEX(IEL,I))
      END DO
      DETJ = YAC11 * YAC22 - YAC12 * YAC21
      Y11 =   YAC22 / DETJ
      Y12 = - YAC12 / DETJ
      Y21 = - YAC21 / DETJ
      Y22 =   YAC11 / DETJ
      DO J = 1 , ND
      BX(1,J) = Y11 * BPP(1,J,K,L) + Y12 * BPP(2,J,K,L)
      BX(2,J) = Y21 * BPP(1,J,K,L) + Y22 * BPP(2,J,K,L)
      END DO
      BETA = WEIGHT * DETJ
      DO I = 1 , ND
      DO J = I , ND
      SS(I,J) = SS(I,J) + ( BX(1,I)*BX(1,J)+BX(2,I)*BX(2,J) )*BETA
      END DO
      END DO
      END DO
      END DO
      DO I = 1 , ND
      DO J = I , ND
      SS(J,I) = SS(I,J)
      END DO
      END DO
C----ASSEMBLY
      DO K = 1 , ND
      I = NODEX(IEL,K)
      DO L = 1 , ND
      J = NODEX(IEL,L) - I + 1
      IF ( J .GT. 0 ) RK(I,J) = RK(I,J) - SS(K,L)
      END DO
      END DO
      END DO
      RETURN
      END
C
C
      SUBROUTINE INPUT ( ND,MXE,MXN,MXB,NE,NNODE,NB,GM,THETA,NODEX,
     * XCOORD,YCOORD,IBND,ITYPE,BVALUE, INPFILE )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),IBND(MXB),
     * ITYPE(MXB), BVALUE(MXB)
      LOGICAL YES
      CHARACTER INPFILE*12
      IR = 1
      INQUIRE ( FILE=INPFILE, EXIST=YES )
      IF ( YES ) OPEN ( IR, FILE=INPFILE, STATUS='OLD' )
      IF ( .NOT. YES ) STOP' NO INPUT FILE'
      READ (IR,*) GM, THETA
      READ (IR,*) NE
      DO I = 1 , NE
      READ (IR,*) IEL,( NODEX(IEL,J),J=1,ND )
      END DO
      READ (IR,*) NNODE
      READ (IR,*) ( NODE,XCOORD(NODE),YCOORD(NODE),J=1,NNODE )
      READ (IR,*) NB
      READ (IR,*) (IBND(I), ITYPE(I), BVALUE(I),I=1,NB)
      CLOSE (IR)
      RETURN
      END
C
C
      SUBROUTINE PRINT ( MXN, NNODE, RHS )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION RHS(MXN)
      CHARACTER OUTFILE*12, EXFILE*3
      LOGICAL YES
      OUTFILE ='SOLUTION.BIN'
      EXFILE ='NEW'
      IW = 1
      INQUIRE ( FILE=OUTFILE, EXIST=YES )
      IF ( YES ) EXFILE='OLD'
      OPEN ( IW, FILE=OUTFILE, STATUS=EXFILE,FORM='UNFORMATTED' )
      WRITE (IW) (RHS(I),I=1,NNODE)
      CLOSE (IW)
      RETURN
      END
C
C
      SUBROUTINE PRINTG ( ND,MXE,MXN, NNODE,NE,  XCOORD, YCOORD,
     *                      GM,THETA, NODEX,MXB, NB, IBND,ITYPE,BVALUE,
     *                      RHS,TORQUE,TAUZX,TAUZY, AREA )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION RHS(MXN), XCOORD(MXN), YCOORD(MXN),NODEX(MXE,ND),
     *  IBND(MXB),ITYPE(MXB), BVALUE(MXB), TAUZX(MXN),TAUZY(MXN)
      CHARACTER OUTFILE*12, EXFILE*3
      LOGICAL YES
      OUTFILE ='SOLUTION.FEM'
      EXFILE ='NEW'
      IW = 1
      INQUIRE ( FILE=OUTFILE, EXIST=YES )
      IF ( YES ) EXFILE='OLD'
      OPEN ( IW, FILE=OUTFILE, STATUS=EXFILE,FORM='FORMATTED' )
C
      WRITE (IW,*) 'SHEAR MODULUS,THETA=', GM,THETA
C
      WRITE (IW,*)
      WRITE (IW,*) 'NUMBER-OF-ELEMENTS  ', NE
      WRITE (IW,*) 'ELEMENT-NUMBER I-NODE J-NODE K-NODE L-NODE'
      DO I = 1, NE
      WRITE (IW,*) I, (NODEX(I,J),J=1,ND)
      END DO
C
      WRITE (IW,*)
      WRITE (IW,*) 'NUMBER OF NODAL POINTS  ',NNODE
      WRITE (IW,*) 'NODE X-COORDINATE Y-COORDINATE'
      DO I = 1, NNODE
      WRITE (IW,*) I,  XCOORD(I), YCOORD(I)
      END DO
C
      WRITE (IW,*)
      WRITE (IW,*) 'RESULTS:  AREA-OF-DOMAIN =', AREA
      WRITE (IW,*)
      WRITE (IW,*) 'NUMBER OF BOUNDARY NODES  ',NB
      WRITE (IW,*) 'NODE TYPE VALUE'
      DO I = 1, NB
      WRITE (IW,*) IBND(I),ITYPE(I), BVALUE(I)
      END DO
C
      WRITE (IW,*)
      WRITE (IW,*) 'RESULTS: STRESS FUNCTION'
      WRITE (IW,*) 'NODE STRESS-FUNCTION'
      DO I = 1, NNODE
      WRITE (IW,*) I,  RHS(I)
      END DO
C
      WRITE (IW,*)
      WRITE (IW,*) 'RESULTS:  TORQUE =', TORQUE
C
      WRITE (IW,*)
      WRITE (IW,*) 'RESULTS: NODE, TAUZX,  TAUZY'
      DO I = 1, NNODE
      WRITE (IW,*) I,  TAUZX(I),  TAUZY(I)
      END DO
      CLOSE (IW)
      RETURN
      END
C
C
      SUBROUTINE BANDWID ( MXE, ND, NE, NODEX , NBW  )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND)
      NBW = 0
      DO I = 1 , NE
      DO J = 1 , ND-1
      DO K = J+1 , ND
      NBW = MAX0(NBW,IABS(NODEX(I,J)-NODEX(I,K)))
      END DO
      END DO
      END DO
      NBW = NBW + 1
      write(*,*) ' bandwidth =', nbw
      RETURN
      END
C
C
      SUBROUTINE SYSTEM ( MXN, MXW, NUMNP, MBAND, A, B )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION A(MXN,MXW) , B(MXN)
C---------- ELIMINATION ------------------
      DO N = 1 , NUMNP 
      DO L = 2 , MBAND 
      C = A(N,L) / A(N,1) 
      I = N + L - 1 
      IF ( I .LE. NUMNP ) THEN
      J = 0 
      DO K = L , MBAND 
      J = J + 1 
      A(I,J) = A(I,J) - C * A(N,K)
      END DO
      A(N,L) = C
      B(I) = B(I) - A(N,L) * B(N)
      ENDIF
      END DO
      B(N) = B(N) / A(N,1)
      END DO
C---------- BACKSUBSTITUTION -------------
      N = NUMNP
      DO WHILE ( N .GT. 0 )
      DO K = 2 , MBAND
      L = N + K - 1 
      IF ( L .LE. NUMNP ) B(N) = B(N)-A(N,K)*B(L) 
      END DO
      N = N - 1 
      END DO
      RETURN
      END 
C
C
      SUBROUTINE FORMQ (MXN,MXB,MXW,NNODE,NB,NBW,A,RHS,IBC,BV,IBND,
     * SOURCE)
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION RHS(MXN),A(MXN,MXW),IBC(MXB),BV(MXB),IBND(MXB),
     * SOURCE(MXN)
C  BOUNDARY CONDITIONS ARE COUPLED HERE.
C  ITYPE(I) = 1 ---> DIRICHLET, ITYPE(I) = 2 ---> NEUMANN
C----- REFORMATION OF VECTOR RHS DUE TO FIRST KIND B.C. 
C------ CLEAR RIGHT HAND SIDE.
      DO I = 1 , NNODE
      RHS (I) = -SOURCE(I)
      END DO
C------ DIRICHLET B.C.'S DO TO RHS.
      DO K = 1 , NB
        IF ( IBC(K) .EQ. 1 ) THEN
          I = IBND(K) 
          DO J = 2 , NBW 
              I = I - 1 
              IF ( I.GT. 0 ) THEN
              RHS(I) = RHS(I) - BV(K) * A(I,J)
              END IF
          END DO
            I = IBND(K) 
          DO J = 2 , NBW 
              I = I + 1 
              IF ( I .LE. NNODE ) THEN
              RHS(I) = RHS(I) - BV(K) * A(IBND(K),J)
              END IF
          END DO
        END IF
      END DO
C-----REFORMATION OF MATRIX A.
      DO K = 1 , NB
      I = IBND (K)
      IF ( IBC(K) .EQ. 1 ) THEN
      RHS(I) = BV(K) 
      A(I,1) = 1. 
      DO J = 2 , NBW 
      L = I - J + 1 
      A(I,J) = 0. 
      IF ( L  .GT. 0 ) THEN
      A( L ,J) = 0. 
      END IF
      END DO
      ELSE
      RHS (I) = RHS(I) - BV(K)
      END IF
      END DO
      RETURN
      END
C
C
      SUBROUTINE GRULE ( N , SAI , W )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION SAI(N) , W(N)
      IF ( N .LT. 2 ) STOP'N<2'
      IF ( N .GT. 6 ) STOP'N>6'
      IF ( N .EQ. 1 ) THEN
      SAI(1) = 0.
      W(1) = 2.
      RETURN
      END IF
C
      IF ( N .EQ. 2 ) THEN
      SAI(1) = 0.5773502692
      W(1) = 1.
      END IF
C
      IF ( N .EQ. 3 ) THEN
      SAI(1) = 0.7745966692
      SAI(2) = 0.
      W(1) = 5./ 9.
      W(2) = 8./ 9.
      END IF
C
      IF ( N .EQ. 4 ) THEN
      SAI(1) = 0.3399810436
      SAI(2) = 0.8611363116
        W(1) = 0.6521451549
        W(2) = 0.3478548451
      END IF
C
      IF ( N .EQ. 5 ) THEN
      SAI(1) = 0.9061798459
      SAI(2) = 0.5384693101
      SAI(3) = 0.
        W(1) = 0.2369268850
        W(2) = 0.4786286705
        W(3) = 5.12 / 9.
      END IF
C
      IF ( N .EQ. 6 ) THEN
      SAI(1) = 0.2386191861
      SAI(2) = 0.6612093865
      SAI(3) = 0.9324695142
        W(1) = 0.4679139346
        W(2) = 0.3607615730
        W(3) = 0.1713244924
      END IF
C
      NN = N / 2
      DO  I = 1 , NN
      J = N - I + 1
      SAI(J) = - SAI(I)
      W(J) = W(I)
      END DO
      RETURN
      END
C
C
      SUBROUTINE DERIV ( ND, INTEPT, F0, F1, SAI, BPP )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION SAI(INTEPT),BPP(2,ND,INTEPT,INTEPT),F0(ND),F1(ND)
      DO K = 1 , INTEPT
      E1 = SAI (K)
      DO L = 1 , INTEPT
      E2 = SAI (L)
COMPUTATION OF BP(J) = DN(J) / DETA1
      CALL ISOPARA ( ND, E1+0.5 , E2 , F1 )
      CALL ISOPARA ( ND, E1-0.5 , E2 , F0 )
      DO I = 1 , ND
      BPP(1,I,K,L) = F1(I) - F0(I)
      END DO
COMPUTATION OF BP(J)= DN(J)/DETA2
      CALL ISOPARA ( ND, E1 , E2+0.5 , F1 )
      CALL ISOPARA ( ND, E1 , E2-0.5 , F0 )
      DO I = 1 , ND
      BPP(2,I,K,L) = F1(I) - F0(I)
      END DO
      END DO
      END DO
      RETURN
      END
C
C
      SUBROUTINE ISOPARA ( ND, E1 , E2 , F )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION F(ND)
      F(1) = 0.25*(1.- E1)*(1.- E2)
      F(2) = 0.25*(1.+ E1)*(1.- E2)
      F(3) = 0.25*(1.+ E1)*(1.+ E2)
      F(4) = 0.25*(1.- E1)*(1.+ E2)
      RETURN
      END
C
C
      SUBROUTINE SHAPEF ( ND, INTEPT, F, SAI, SF )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION F(ND) , SAI(INTEPT) , SF(ND,INTEPT,INTEPT)
      DO K = 1 , INTEPT
      E1 = SAI (K)
      DO L = 1 , INTEPT
      E2 = SAI( L )
      CALL ISOPARA ( ND, E1 , E2 , F )
      DO I = 1 , ND
      SF(I,K,L) = F(I)
      END DO
      END DO
      END DO
      RETURN
      END
C
C
      SUBROUTINE SRCTRM ( MXE,MXN,INTEPT,ND,NNODE,BPP,W,NE,GM,THETA,
     * SF,XCOORD,YCOORD,NODEX,SS, SOURCE )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),
     * SOURCE(MXN),
     * SS(ND,ND),BPP(2,ND,INTEPT,INTEPT),W(INTEPT),SF(ND,INTEPT,INTEPT)
C
      TRSCONST = 2.*GM*THETA
      DO I = 1, NNODE
      SOURCE(I) = 0.
      END DO
      DO IEL = 1 ,NE
      DO I = 1 , ND
      DO J = 1 , ND
      SS(I,J) = 0.
      END DO
      END DO
      DO K = 1 , INTEPT
      DO L = 1 , INTEPT
      WEIGHT = W(K) * W(L) * TRSCONST
      YAC11 = 0.
      YAC12 = 0.
      YAC21 = 0.
      YAC22 = 0.
      DO I = 1 , ND
      YAC11 = YAC11 + BPP(1,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC12 = YAC12 + BPP(1,I,K,L) * YCOORD(NODEX(IEL,I))
      YAC21 = YAC21 + BPP(2,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC22 = YAC22 + BPP(2,I,K,L) * YCOORD(NODEX(IEL,I))
      END DO
      DETJ = YAC11 * YAC22 - YAC12 * YAC21
      BETA = WEIGHT * DETJ
      DO I = 1 , ND
      DO J = 1 , ND
      SS(I,J) = SS(I,J) + SF(I,K,L) * SF(J,K,L) * BETA
      END DO
      END DO
      END DO
      END DO
C
      DO K = 1 , ND
      SUM = 0
      DO L = 1 , ND
      SUM = SUM + SS(K,L)
      END DO
      SOURCE(NODEX(IEL,K)) = SOURCE(NODEX(IEL,K)) + SUM
      END DO
      END DO
      RETURN
      END
C
C
      SUBROUTINE MOMENT ( MXE,MXN,INTEPT,ND,BPP,W,NE,SF,
     * XCOORD,YCOORD,NODEX, RHS,TORQUE  )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),RHS(MXN),
     * SS(ND,ND),BPP(2,ND,INTEPT,INTEPT),W(INTEPT),SF(ND,INTEPT,INTEPT)
      TORQUE = 0.
      DO IEL = 1 ,NE
      DO K = 1 , INTEPT
      DO L = 1 , INTEPT
      WEIGHT = W(K) * W(L)
      YAC11 = 0.
      YAC12 = 0.
      YAC21 = 0.
      YAC22 = 0.
      DO I = 1 , ND
      YAC11 = YAC11 + BPP(1,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC12 = YAC12 + BPP(1,I,K,L) * YCOORD(NODEX(IEL,I))
      YAC21 = YAC21 + BPP(2,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC22 = YAC22 + BPP(2,I,K,L) * YCOORD(NODEX(IEL,I))
      END DO
      DETJ = YAC11 * YAC22 - YAC12 * YAC21
      BETA = WEIGHT * DETJ
      DO I = 1 , ND
      TORQUE  = TORQUE  + SF(I,K,L) * BETA*RHS(NODEX(IEL,I))
      END DO
      END DO
      END DO
      END DO
      TORQUE  = 2.*TORQUE
      RETURN
      END
C
C
      SUBROUTINE ELNDPT ( ND, XS, YS )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION XS(ND), YS(ND)
      IF ( ND .LT. 4 ) STOP'ND<4'
      IF ( ND .GT. 9 ) STOP'ND>9'
      IF ( ND .EQ. 4) THEN
      XS(1) = -1.
      XS(2) = 1.
      XS(3) = 1.
      XS(4) = -1.
      YS(1) = -1.
      YS(2) = -1.
      YS(3) = 1.
      YS(4) = 1.
      END IF
      RETURN
      END
C
C
      SUBROUTINE STRESS ( ND ,MXE,MXN,NE,NNODE, BPPX,NODEX,
     * XCOORD,YCOORD,
     * XS, YS, DUMMY0, DUMMY1, RHS, NDREPEAT,TAUZX,TAUZY )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),RHS(MXN),
     *  BPPX(2,ND,ND),XS(ND),YS(ND),DUMMY0(ND),DUMMY1(ND),
     *  TAUZX(MXN),TAUZY(MXN), NDREPEAT(MXN)
C====================================
      CALL ELNDPT  ( ND, XS, YS )
      CALL DERIVX ( ND, DUMMY0, DUMMY1, XS, YS, BPPX )
C===== INTEGRATION =======
      DO I = 1, NNODE
      NDREPEAT(I) = 0
      TAUZX(I) = 0.
      TAUZY(I) = 0.
      END DO
      DO IEL = 1 ,NE
      DO K = 1 , ND
      YAC11 = 0.
      YAC12 = 0.
      YAC21 = 0.
      YAC22 = 0.
      DO I = 1 , ND
      YAC11 = YAC11 + BPPX(1,I,K) * XCOORD(NODEX(IEL,I))
      YAC12 = YAC12 + BPPX(1,I,K) * YCOORD(NODEX(IEL,I))
      YAC21 = YAC21 + BPPX(2,I,K) * XCOORD(NODEX(IEL,I))
      YAC22 = YAC22 + BPPX(2,I,K) * YCOORD(NODEX(IEL,I))
      END DO
      DETJ = YAC11 * YAC22 - YAC12 * YAC21
      Y11 =   YAC22 / DETJ
      Y12 = - YAC12 / DETJ
      Y21 = - YAC21 / DETJ
      Y22 =   YAC11 / DETJ
      DTDX = 0.
      DTDY = 0.
      DO J = 1 , ND
      DNDX = Y11*BPPX(1,J,K)+Y12*BPPX(2,J,K)
      DNDY = Y21*BPPX(1,J,K)+Y22*BPPX(2,J,K)
      DTDX = DTDX + DNDX*RHS(NODEX(IEL,J))
      DTDY = DTDY + DNDY*RHS(NODEX(IEL,J))
      END DO
      NODE = NODEX(IEL,K)
      TAUZX(NODE) = TAUZX(NODE) + DTDY
      TAUZY(NODE) = TAUZY(NODE) - DTDX
      NDREPEAT(NODE) = NDREPEAT(NODE) + 1
      END DO
      END DO
      DO I = 1 , NNODE
      TAUZX(I) = TAUZX(I)/NDREPEAT(I)
      TAUZY(I) = TAUZY(I)/NDREPEAT(I)
      END DO
      RETURN
      END
C
C
      SUBROUTINE DERIVX ( ND, DUMMY0, DUMMY1, XS, YS, BPPX )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION XS(ND),YS(ND),BPPX(2,ND,ND),DUMMY0(ND),DUMMY1(ND)
      DO K = 1 , ND
      E1 = XS (K)
      E2 = YS (K)
COMPUTATION OF BP(J) = DN(J) / DETA1
      CALL ISOPARA ( ND, E1+0.5 , E2 , DUMMY1 )
      CALL ISOPARA ( ND, E1-0.5 , E2 , DUMMY0 )
      DO I = 1 , ND
      BPPX(1,I,K) = DUMMY1(I) - DUMMY0(I)
      END DO
COMPUTATION OF BP(J)= DN(J) / DETA2
      CALL ISOPARA ( ND, E1 , E2+0.5 , DUMMY1 )
      CALL ISOPARA ( ND, E1 , E2-0.5 , DUMMY0 )
      DO I = 1 , ND
      BPPX(2,I,K) = DUMMY1(I) - DUMMY0(I)
      END DO
      END DO
      RETURN
      END
C
C
      SUBROUTINE DAREA ( MXE,MXN,INTEPT,ND,BPP,W,NE,XCOORD,YCOORD,
     * NODEX, AREA )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),
     * BPP(2,ND,INTEPT,INTEPT),W(INTEPT)
      AREA = 0.
      DO IEL = 1 ,NE
      DO K = 1 , INTEPT
      DO L = 1 , INTEPT
      WEIGHT = W(K) * W(L)
      YAC11 = 0.
      YAC12 = 0.
      YAC21 = 0.
      YAC22 = 0.
      DO I = 1 , ND
      YAC11 = YAC11 + BPP(1,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC12 = YAC12 + BPP(1,I,K,L) * YCOORD(NODEX(IEL,I))
      YAC21 = YAC21 + BPP(2,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC22 = YAC22 + BPP(2,I,K,L) * YCOORD(NODEX(IEL,I))
      END DO
      DETJ = YAC11 * YAC22 - YAC12 * YAC21
      AREA = AREA + WEIGHT * DETJ
      END DO
      END DO
      END DO
      RETURN
      END
