      INCLUDE 'FLIB.FI'     ! FOR USE WITH MICROSOFT FORTRAN ONLY
      PROGRAM DNA
C      
C =====================================================================
C I                                                                   I
C I                                                                   I
C I                           =============                           I
C I                           --- D N A ---                           I
C I                           =============                           I
C I                                                                   I
C I                     DAMAGE NONLINEAR ANALYSIS                     I
C I                               FOR                                 I
C I                  ELASTO-PLASTC MATERIAL BEHAVIOR                  I
C I                                                                   I
C I   SCOPE OF PROGRAM:                                               I
C I                                                                   I
C I   ANALYISIS OF STRESSES, STRAINS AND DEFORMATIONS INDUCED ON      I
C I   AN ELASTO-PLASTIC SOLID CONTINUUM AS THE RESULT OF VARIOUS      I
C I   FORCE OR DISPLACEMENT LOADINGS INCLUDING THE EFFECT OF DAMAGE.  I
C I                                                                   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INCLUDE 'FLIB.FD'     ! FOR USE WITH MICROSOFT FORTRAN ONLY
      INTEGER MAX_NODES,MAX_STORAGE,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MAX_STORAGE=300000,MNNDF=3,
     .           MAX_NODES_DOF=MAX_NODES*MNNDF)
      INTEGER IDIM,I_IN,LFGLEN,NELEM,NTDF,IEXT,IRES,I_OUT,I_GRAPH
      INTEGER LDEV,LDEV1,LDEV2,LDEV3,LDEV4,LDEVST,IFILEN,INCREMENTS
      INTEGER ITERATIONS,LFOLEN,MBAND,NINODE,NNDF,NNODES,NTSK
      INTEGER STR$COLLAPSE,OPENERR,STR$FIND_FIRST_IN_SET_R
      INTEGER GRAPHICS_INTR,OUTPUT_INTR,IDOF(MAX_NODES_DOF),
     .        JDIAG(MAX_NODES)
      CHARACTER*60 IN_FN,OUT_FN,GRAPH_FN,RESPONSE*6,FILESTAT*6
      LOGICAL DELETE,LINEAR,RESTART,SYMMETRIC,GRAPHICS_OUT
C      THE FOLLOWING TWO LINES ARE FOR USE WITH MIRCRSOFT FORTRAN ONLY    
      INTEGER*2 IYR,IMON,IIDAY,IFDAY,IHOUR,IMIN,ISEC,IHSEC
      REAL*4 INITIAL_TIME,FINAL_TIME,SOLUTION_TIME
      REAL*8 R(MAX_NODES),SKG,SKGL
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
      COMMON/INPUT8/NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,
     .              SYMMETRIC,IDIM,NINODE
      COMMON/INPUTG/RESTART,OUTPUT_INTR,GRAPHICS_INTR,GRAPHICS_OUT
      COMMON/MEMO1/SKG(MAX_STORAGE)
      COMMON/MEMO2/SKGL(MAX_STORAGE)
      COMMON/IN_IO/I_OUT,I_IN,I_GRAPH
C
C       I_OUT   = OUTPUT DEVICE NUMBER
C       I_IN    = INPUT DEVICE NUMBER
C       I_GRAPH = GRAPHICAL OUTPUT DEVICE NUMBER
C
      I_GRAPH = 4      
      I_IN  = 11
      I_OUT = 13
      DELETE=.TRUE.
      WRITE(*,'(1X,A,$)')'(D)elete or (K)eep intermediate files '//
     .         'after successful run [D]> '
      READ(*,'(A)',ERR=10)RESPONSE
      IRES=STR$COLLAPSE(RESPONSE,RESPONSE)
      DELETE=RESPONSE(1:1) .NE. 'K' .AND. RESPONSE(1:1) .NE. 'k'
10    IF(DELETE)FILESTAT='DELETE'
      IF(.NOT.DELETE)FILESTAT='KEEP'
C
C     OPEN ALL I/O DEVICES
C
      IN_FN=' '
      OUT_FN=' '
      GRAPH_FN=' '
      OPEN(LDEV1,FILE='ldev1.dat',FORM='UNFORMATTED',STATUS='UNKNOWN')
      OPEN(LDEV2,FILE='ldev2.dat',FORM='UNFORMATTED',STATUS='UNKNOWN')
      OPEN(LDEVST,FILE='ldevst.dat',FORM='FORMATTED',STATUS='UNKNOWN')
      OPEN(I_IN,FILE=IN_FN,FORM='FORMATTED',STATUS='OLD',ERR=20)
      GOTO 25
20    WRITE(*,'(1X,A,$)')'Error opening input file. Enter new name> '
      READ(*,'(A)')IN_FN
      OPEN(I_IN,FILE=IN_FN,FORM='FORMATTED',STATUS='OLD',ERR=20)
      IFILEN=STR$COLLAPSE(IN_FN,IN_FN)
      IEXT=STR$FIND_FIRST_IN_SET_R(IN_FN(:IFILEN),'.')-1
      IF(IEXT.LE.0)IEXT=IFILEN
      OUT_FN=IN_FN(:IEXT)//'.out'
      GRAPH_FN=IN_FN(:IEXT)//'.ps'
      LFOLEN=STR$COLLAPSE(OUT_FN,OUT_FN)
      LFGLEN=STR$COLLAPSE(GRAPH_FN,GRAPH_FN)
      PRINT*,'DATA OUTPUT FILE SET TO: '//OUT_FN(:LFOLEN)
      PRINT*,'GRAPHICS OUTPUT FILE SET TO: '//GRAPH_FN(:LFGLEN)
25    OPEN(I_OUT,FILE=OUT_FN,FORM='FORMATTED',STATUS='UNKNOWN',
     .     IOSTAT=OPENERR)
30    IF(OPENERR.NE.0)THEN
        WRITE(*,'(1X,A,$)')'Error opening output file. Enter new name> '
        READ(*,'(A)')OUT_FN
        OPEN(I_OUT,FILE=OUT_FN,FORM='FORMATTED',STATUS='UNKNOWN',
     .       IOSTAT=OPENERR)
        GOTO 30
      ENDIF      
C
C       READ THE INPUT FILE
C
      CALL INPUT(IDOF)
      CLOSE(I_IN,STATUS='KEEP')
      IF (NINODE.GT.0) THEN
        CALL HERMIT
        CALL COEFIC
      END IF
C
C       INITIATE THE PLOTTING ROUTINES
C
      IF (GRAPHICS_INTR.GT.0) THEN
        OPEN(I_GRAPH,FILE=GRAPH_FN,FORM='FORMATTED',STATUS='UNKNOWN',
     .       IOSTAT=OPENERR)
40      IF(OPENERR.NE.0)THEN
          WRITE(*,'(1X,A,$)')'Error opening graphics output file.'//
     .                       ' Enter new name> '
          READ(*,'(A)')GRAPH_FN
          OPEN(I_GRAPH,FILE=GRAPH_FN,FORM='FORMATTED',STATUS='UNKNOWN',
     .         IOSTAT=OPENERR)
          GOTO 40
        ENDIF      
        CALL INPLOT( NELEM )                                           
      END IF
C     INITIATE TIMING OF SOLUTION
      CALL GETDAT(IIDAY,IMON,IYR)
      CALL GETTIM(IHOUR,IMIN,ISEC,IHSEC)
      INITIAL_TIME=IHOUR*3600.0+IMIN*60+ISEC+IHSEC/100.0
C
C       DEFINE THE GLOBAL DEGREES OF FREEDOM
C
      CALL GLOB1(NNODES,NNDF,NTDF,IDOF)
C
C       FIND THE BANDWIDTH AND THE LOCATION OF THE DIAGONAL TERMS
C       IN THE GLOBAL STIFFNESS MATRIX
C
      CALL DIAGNL(NELEM,NNDF,NTDF,IDOF,JDIAG,NTSK,MBAND,SYMMETRIC,I_OUT)
C
C       ASSEMBLE THE LOAD VECTOR
C
      CALL LOAD(R)
C
C       CALL THE SOLUTION CONTROL UNIT
C
      CALL CONTRL(SKG,SKGL,R,IDOF,JDIAG,NTSK,NTDF,I_OUT,MBAND)
C     TERMINATE TIMING OF SOLUTION
      CALL GETDAT(IFDAY,IMON,IYR)
      CALL GETTIM(IHOUR,IMIN,ISEC,IHSEC)
      IF(IFDAY.NE.IIDAY) THEN
        IHOUR=IHOUR+24
        IMIN=IMIN+60
      ENDIF
      FINAL_TIME=IHOUR*3600+IMIN*60+ISEC+IHSEC/100.0
      SOLUTION_TIME=FINAL_TIME-INITIAL_TIME
      IHOUR=INT(SOLUTION_TIME)/3600
      IMIN=(INT(SOLUTION_TIME)-IHOUR*3600)/60
      ISEC=INT(SOLUTION_TIME)-IHOUR*3600-IMIN*60
      IHSEC=(SOLUTION_TIME-INT(SOLUTION_TIME))*100
      WRITE(I_OUT,'(1X,''CPU USAGE: '',I2,'':'',I2.2,'':'',I2.2,
     .      ''.'',I2.2,'' hrs'')')IHOUR,IMIN,ISEC,IHSEC
      WRITE(*,'(1X,''CPU USAGE: '',I2,'':'',I2.2,'':'',I2.2,
     .      ''.'',I2.2,'' hrs'')')IHOUR,IMIN,ISEC,IHSEC
C
C       CLOSE THE PLOT FILES
C                      
      IF(GRAPHICS_INTR.GT.0) CALL EOJOB
C
100   CLOSE(I_OUT,STATUS='KEEP')
      CLOSE(I_GRAPH,STATUS='KEEP')
      CLOSE(LDEV1,STATUS=FILESTAT)
      CLOSE(LDEV2,STATUS=FILESTAT)
      CLOSE(LDEVST,STATUS=FILESTAT)
C
      END
C               
C =====================================================================
C ========================== C O N T R L ==============================
C =====================================================================
C
      SUBROUTINE CONTRL(SKG,SKGL,R,IDOF,JDIAG,NTSK,NTDF,I_OUT,MBAND)
C
C =====================================================================
C I                                                                   I
C I    P R O G R A M:                                                 I
C I                                                                   I
C I    SUBROUTINE 'CONTRL' CONTROLS THE INCREMENTAL LOADING AND THE   I
C I    NEWTON RAPHSON ITERATIVE PROCESS FOR THE TOTAL LAGRANGIAN      I
C I    GEOMETRIC AND MATERIAL NONLINEARITIES.                         I
C I                                                                   I
C I    A R G U M E N T   L I S T:                                     I
C I                                                                   I
C I    SKG(I)      =  GLOBAL STIFFNESS MATRIX STORED AS A ONE         I
C I                   DIMENSIONAL ARRAY                               I
C I    R(I)        =  LOAD VECTOR                                     I
C I    IDOF(I)     =  VECTOR CONTAINING THE D.O.F. NUMBERS OF JOINTS  I
C I    JDIAG(I)    =  LOCATION OF THE DIAGONAL TERMS OF EACH COLUMN   I
C I                   IN THE GLOBAL STIFFNESS MATRIX 'SKG'            I
C I    NTSK        =  TOTAL NUMBER OF TERMS IN THE 'SKG' MATRIX       I
C I    NTDF        =  NUMBER OF TOTAL D.O.F. IN THE PROBLEM           I
C I                   NOT INCLUDING THE CONSTRAINED BOUNDARIES        I
C I    I_OUT       =  OUTPUT DEVICE                                   I
C I    MBAND       =  HALF BAND WIDTH OF THE STIFFNESS MATRIX         I
C I                                                                   I
C I                                                                   I
C I    C O M M O N   B L O C K S                                      I
C I                                                                   I
C I    REFFER TO THE COMMON BLOCK DESCRIPTIONS.                       I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_NODES,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      INTEGER GRAPHICS_INTR,OUTPUT_INTR,I,ICODE,ICOUNT,ID,IDIM,IDIR
      INTEGER IFINAL,INCREM,INCREMENTS,IOCNT,IPLCNT,ISTART,ITERATIONS
      INTEGER ITEST,I_OUT,K1,K2,K3,LAST,LDEV,LDEV1,LDEV2,LDEV3,LDEV4
      INTEGER LDEVST,MBAND,MDF,NELEM,NINODE,NIT,NNDF,NNODES,NTDF,NTSK
      INTEGER IDOF(*),JDIAG(*),ISPB,STR$COLLAPSE,LSTR1,LSTR2
      LOGICAL ISAVE,LINEAR,RESTART,SYMMETRIC,YES,GRAPHICS_OUT
      REAL*8 R(*),SKG(*),SKGL(*),DUMMY(3),RE1(MAX_NODES_DOF)
      REAL*8 CST,DLINC,DC,RE,RINC,RIT,U,UINC,UTOTAL
      CHARACTER*40 STR1,STR2
      COMMON/TRANS/DC(3,3)
      COMMON/INPUTE/ISPB(MAX_NODES)
      COMMON/MAIN1/U(MAX_NODES_DOF)
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/MAIN4/RE(MAX_NODES_DOF)
      COMMON/INPUT7/RIT(MAX_NODES_DOF),RINC(MAX_NODES_DOF),
     .              UINC(MAX_NODES_DOF)
      COMMON/INPUT8/NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,
     .              SYMMETRIC,IDIM,NINODE
      COMMON/INPUTG/RESTART,OUTPUT_INTR,GRAPHICS_INTR,GRAPHICS_OUT
      COMMON/CONTR1/INCREM,NIT
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
C
      DATA YES/.TRUE./
C
C       MDF       = MAXIMUM DEGREES OF FREEDOM INCLUDING THE SUPPORTS
C
      MDF = NNODES*NNDF
      IF (OUTPUT_INTR.EQ.0) OUTPUT_INTR = INCREMENTS
C
C       IF THIS RUN IS A RESTART THEN RESTORE THE LAST CONVERGED VALUES
C       OF THE EQUILIBRIUM LOAD VECTOR AND THE TOTAL DISPLACEMENT VECTOR
C
      IF (RESTART) THEN
        CALL RESTOR(MDF,ISTART)
        IFINAL=ISTART+INCREMENTS
        ISAVE=LINEAR
        ISTART=ISTART+1
      ELSE
        ISTART = 1
        IFINAL = INCREMENTS
C
C       FOR THE FIRST ITERATION OF THE FIRST INCREMENT USE THE
C       GEOMETRIC LINEARITY ROUTINES.
C
C       LINEAR = TRUE; GEOMETRIC LINARITY
C              = FALSE; GEOMETRIC NON-LINEARITY
C       ISAVE  = DUMMY VARIABLE USED TO STORE THE VALUE OF 'LINEAR'
C
        ISAVE = LINEAR
        LINEAR = .TRUE.
      END IF
      IF (GRAPHICS_INTR.GT.0.AND.GRAPHICS_OUT) THEN
        IF (NINODE.GT.0) CALL CURVE
        CALL PLOTER(NNODES,NELEM,NNDF,IDIM,NINODE,LINEAR)
      END IF
C
C       CALCULATE THE PROPER LOAD OR DISPLACEMENT INCREMENT
C
C       UINC( K ) = APPLIED INCREMENT OF DISPLACEMENT
C       U( K )    = TOTAL APPLIED DISPLACEMENTS
C       R( K )    = TOTAL APPLIED LOADS
C       RINC( K ) = INCREMENT OF APPLIED LOADS
C       RE( K )   = EQUILIBRIUM LOAD VECTOR
C       INCREMENTS = NUMBER OF LOAD INCREMENTS
C
      DLINC = DFLOAT( INCREMENTS )
      DO K1 = 1 , MDF
        UINC( K1 ) = U( K1 )/DLINC
        RINC( K1 ) = (R( K1 ) - RE( K1 ))/DLINC
      END DO
C
C       ICOUNT = ITERATION COUNT FOR THE RUN
C       IOCNT  = INCREMENT COUNT FROM THE START OR SINCE THE LAST
C                OUTPUT. WHEN 'IOCNT' IS EQUAL TO 'OUTPUT_INTR' A COMPLETE
C                OUTPUT WILL BE GENERATED.
C
      ICOUNT = 0
      IOCNT = 0
      IPLCNT = 0
C
C                      S T A R T      O F
C              I N C R E M E N T      L O O P
C
C
      DO INCREM = ISTART , IFINAL
        IOCNT = IOCNT + 1
        IPLCNT = IPLCNT + 1
        WRITE(STR1,'(I39)')INCREM
        WRITE(STR2,'(I39)')IFINAL
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(*,*)'LOAD INCREMENT # '//STR1(:LSTR1)//' OF '//
     .             STR2(:LSTR2)
C
C       ADJUST THE BOUNDARY CONDITIONS FOR THE INTERFACE NODES
C
        IF (NINODE.GT.0) THEN
          CALL BOUND(IDOF,NNDF,NINODE,ICODE,I_OUT)
          IF (ICODE.EQ.1) THEN
            CALL GLOB2(NNODES,NNDF,NTDF,IDOF)
            CALL DIAGNL(NELEM,NNDF,NTDF,IDOF,JDIAG,NTSK,MBAND,
     .                  SYMMETRIC,I_OUT)
          END IF
        END IF
C
C       U( K )   = INCREMENT OF THE APPLIED DISPLACEMENTS USED
C                   FOR THE FIRST ITERATION
C       RIT( K ) = TOTAL APPLIED LOAD AT THE END OF THE INCREMENT
C
        DO K1 = 1 , MDF
          U( K1 ) = UINC( K1 )
          RIT( K1 ) = RINC( K1 ) + RE( K1 )
        END DO
C
C                      S T A R T      O F
C              I T E R A T I O N      L O O P
C
        DO NIT = 1 , ITERATIONS
C
C       NIT =  ITERATION NUMBER
C       ITERATIONS = MAXIMUM NUMBER OF ITERATIONS ALLOWED
C
          DO K1 = 1 , NNODES
            I = NNDF*(K1 - 1)
            ICODE = ISPB( K1 )
            DO K2 = 1 , NNDF
              IDIR = I + K2
              DUMMY( K2 ) = RIT( IDIR ) - RE( IDIR )
            END DO
            IF (ICODE.GT.0) THEN
              CALL DIRCOS(ICODE,IDIM)
              DO K2 = 1 , IDIM
                CST = 0.D0
                DO K3 = 1 , IDIM
                  IDIR = I + K3
                  CST = CST + (RIT( IDIR ) - RE( IDIR ))*DC(K3 , K2)
                END DO
                DUMMY( K2 ) = CST
              END DO
            END IF
            DO K2 = 1 , NNDF
              IDIR = I + K2
              ID = IDOF( IDIR )
              IF(ID.GT.0) R( ID ) = DUMMY( K2 )
            END DO
          END DO
          IF (NIT.EQ.1) THEN
            LDEV = LDEV1
          ELSE
            LDEV = LDEV2
          END IF
          CALL ASSEMB(SKG,SKGL,R,U,IDOF,JDIAG,NTSK,MBAND,I_OUT)
          CALL REWIN
          IF (SYMMETRIC) THEN
            CALL SOLVE2(SKG,R,JDIAG,NTDF,1,I_OUT)
            CALL SOLVE2(SKG,R,JDIAG,NTDF,2,I_OUT)
          ELSE IF(.NOT.SYMMETRIC) THEN
            CALL SOLVE1(SKG,SKGL,R,JDIAG,NTDF,YES,YES)
          END IF
          DO K1 = 1 , MDF                               
            ID = IDOF( K1 )
            IF(ID.GT.0) U( K1 ) = U( K1 ) + R( ID )
          END DO
          DO K1 = 1 , NNODES
            I = NNDF*(K1 - 1)
            ICODE = ISPB( K1 )
            DO K2 = 1 , NNDF
              IDIR = I + K2
              DUMMY( K2 ) = U( IDIR )
            END DO
            IF (ICODE.GT.0) THEN
              CALL DIRCOS(ICODE,IDIM)
              DO K2 = 1 , IDIM
                CST = 0.D0
                DO K3 = 1 , IDIM
                  IDIR = I + K3
                  CST = CST + DC(K2 , K3)*U( IDIR )
                END DO
                DUMMY( K2 ) = CST
              END DO
            END IF
            DO K2 = 1 , NNDF
              IDIR = I + K2
              UTOTAL( IDIR ) = UTOTAL( IDIR ) + DUMMY( K2 )
              U( IDIR ) = DUMMY( K2 )
            END DO
          END DO
          LINEAR = ISAVE
          DO K1 = 1 , MDF
            RE1( K1 ) = RE( K1 )
            RE( K1 ) = 0.D0
          END DO
          CALL GETSTR(I_OUT)
          CALL CHECK(RE1,MDF,ITEST,I_OUT)
          DO K1 = 1 , MDF
            U( K1 ) = 0.D0
          END DO
          CALL REWIN
          IF(ITEST.EQ.1) THEN
            GOTO 600
          ELSE IF (ITEST.EQ.2) THEN
            GO TO 590
          END IF
        END DO
C
C                        E N D        O F
C              I T E R A T I O N      L O O P
C
        IF (ITERATIONS.EQ.1) GO TO 600
        WRITE(I_OUT , 1003) INCREM , INCREM-1
        PRINT*,'MAXIMUM NUMBER OF ITERATIONS EXCEEDED. '//
     .         'PROGRAM TERMINATED'
 590    CALL RESTOR(MDF,LAST)
        WRITE(*,*)'WRITING OUTPUT FOR LOAD INCREMENT # '//STR1(:LSTR1)
        CALL OUTPUT(I_OUT)
        CALL REWIN
        IF (GRAPHICS_INTR.GT.0.AND.GRAPHICS_OUT) THEN
          WRITE(*,*)'WRITING GRAPHICS OUTPUT FOR '//
     .                        'LOAD INCREMENT # '//STR1(:LSTR1)
          IF (NINODE.GT.0) CALL CURVE
          CALL PLOTER(NNODES,NELEM,NNDF,IDIM,NINODE,LINEAR)
        END IF    
        GO TO 800
 600    CALL SWAP
        CALL STORE(MDF,INCREM)
        ICOUNT = ICOUNT + NIT
        IF(OUTPUT_INTR.GT.0) THEN
          IF (MOD(IOCNT,OUTPUT_INTR).EQ.0) THEN
            WRITE(*,*)'WRITING OUTPUT FOR LOAD INCREMENT # '//
     .                          STR1(:LSTR1)
            WRITE(I_OUT , 1004) INCREM
            CALL OUTPUT(I_OUT)
            CALL REWIN
          ENDIF
        END IF
        IF(GRAPHICS_INTR.GT.0.AND.GRAPHICS_OUT) THEN
          IF (MOD(IPLCNT,GRAPHICS_INTR).EQ.0) THEN
            WRITE(*,*)'WRITING GRAPHICS OUTPUT FOR '//
     .                          'LOAD INCREMENT # '//STR1(:LSTR1)
            IF (NINODE.GT.0) CALL CURVE
            CALL PLOTER(NNODES,NELEM,NNDF,IDIM,NINODE,LINEAR)
          END IF
        ENDIF
      END DO
 800  WRITE(I_OUT , 1002) ICOUNT
 1002 FORMAT(//1X,'>>>>>>> TOTAL NUMBER OF ITERATIONS FOR THIS RUN IS'
     . ,' = ',I5)
 1003 FORMAT(/1X,'>>>>>>> PROGRAM TERMINATED DUE TO EXEEDING THE '/
     . 9X,'ALLOWABLE NUMBER OF ITERATIONS AT LOAD INCREMENT ',I4//
     . 1X,'>>>>>>> OUTPUTS ARE FOR THE LAST CONVERGED INCREMENT ',I4)
 1004 FORMAT(///1X,'>>>>>>> OUTPUTS AT INCREMENT ',I4)
C 
      END
C
C =====================================================================
C =========================== C H E C K ===============================
C =====================================================================
C
      SUBROUTINE CHECK(RE1,MDF,ITEST,I_OUT)
      IMPLICIT NONE
      INTEGER DIVER_STOP,MAX_NODES,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      INTEGER INCREM,ITEST,I_OUT,K,MDF,NDIVER,NIT
      REAL*8 RE1(*),CONV_FAC,DZERO,ENRG,ENRG1,RE,RINC,RIT,U,UINC
      COMMON/CONTR1/INCREM,NIT
      COMMON/MAIN1/U(MAX_NODES_DOF)
      COMMON/MAIN4/RE(MAX_NODES_DOF)
      COMMON/INPUT7/RIT(MAX_NODES_DOF),RINC(MAX_NODES_DOF),
     .              UINC(MAX_NODES_DOF)
      COMMON/INPUTB/CONV_FAC,ENRG1,NDIVER,DIVER_STOP
C
      DATA DZERO /0.D0/
C
C      ITEST = 0; NO CONVERGANCE
C            = 1; CONVERGANCE
C            = 2; TERMINATE PROGRAM DUE TO EXCEEDING THE ALLOWED
C                 NUMBER OF DIVERGING ITERATIONS
C
      ITEST = 0
      ENRG = DZERO
C
C        CALCULATE THE INCREMENT OF THE INTERNAL ENEGRY DUE TO THE
C        OUT OF BALANCE FORCES. AND REINITIALIZE THE INCREMENTAL
C        DISPLACEMENT VECTOR 'U'.
C
      DO K = 1 , MDF
        ENRG = ENRG + U( K )*(RE( K ) - RE1( K ))
      END DO
      IF (NIT.EQ.1.OR.ENRG1.EQ.DZERO) THEN
        ENRG1 = ENRG
      ELSE
        IF (ENRG.GT.ENRG1) THEN
          NDIVER = NDIVER + 1
          WRITE(I_OUT , 100)INCREM,NIT
          IF (NDIVER.GE.DIVER_STOP) THEN
            WRITE(I_OUT , 200)
            ITEST = 2
            PRINT*,'>>>>>>> PROGRAM TERMINATED DO TO EXEEDING '
     .             //'THE ALLOWABLE NUMBER OF DIVERGING '//
     .             'ITERATIONS'
          END IF
        ELSE IF(ENRG.LE.CONV_FAC*ENRG1) THEN
          ITEST = 1
          NDIVER = 0
        END IF
      END IF
 100  FORMAT(/1X,'>>>>>>> DIVERGANCE DETECTED',
     . ' AT LOAD INCREMENT ',I4,' ITERATION NO. ',I4)
 200  FORMAT(/1X,'>>>>>>> PROGRAM TERMINATED DO TO EXEEDING THE '/
     . 9X,'ALLOWABLE NUMBER OF DIVERGING ITERATIONS')
C
      END 
C
C =====================================================================
C ====================== U T I L I T ==================================
C =====================================================================
C
      SUBROUTINE UTILIT
      IMPLICIT NONE
      INTEGER MAX_NODES,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      INTEGER IERROR,INCREM,ISTART,ISWAP,I_GRAPH,I_IN,I_OUT,K1,LDEV
      INTEGER LDEV1,LDEV2,LDEV10,LDEV3,LDEV4,LDEV5,LDEV6,LDEV7
      INTEGER LDEV8,LDEV9,LDEVST,MDF
      REAL*8 RE,UTOTAL
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
      COMMON/DEV1/LDEV5,LDEV6,LDEV7,LDEV8,LDEV9,LDEV10
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/MAIN4/RE(MAX_NODES_DOF)
      COMMON/IN_IO/I_OUT,I_IN,I_GRAPH
C
C ============== E N T R Y     S W A P ================================
C
      ENTRY SWAP
      ISWAP = LDEV1
      LDEV1 = LDEV2
      LDEV2 = ISWAP
      RETURN
C
C ============== E N T R Y     R E W I N ==============================
C
      ENTRY REWIN
      REWIND(UNIT=LDEV1,ERR=1000,IOSTAT=IERROR)
      REWIND(UNIT=LDEV2,ERR=1000,IOSTAT=IERROR)
      RETURN
C
C ============== E N T R Y     R E S T O R ============================
C
      ENTRY RESTOR(MDF,ISTART)
      READ(LDEVST , *,ERR=1002)ISTART,LDEV1,LDEV2,LDEV3,LDEV4,
     .                LDEV5,LDEV6,LDEV7,LDEV8,LDEV9,LDEV10
      DO K1 = 1 , MDF
        READ(LDEVST, *,ERR=1002)RE( K1 ),UTOTAL( K1 )
      END DO
      REWIND(UNIT=LDEVST,ERR=1000,IOSTAT=IERROR)
      RETURN
C
C ============== E N T R Y     S T O R E ==============================
C
      ENTRY STORE(MDF,INCREM)
      WRITE(LDEVST , *,ERR=1003)INCREM,LDEV1,LDEV2,LDEV3,LDEV4,
     .               LDEV5,LDEV6,LDEV7,LDEV8,LDEV9,LDEV10
      DO K1 = 1 , MDF
        WRITE(LDEVST , *,ERR=1003)RE( K1 ),UTOTAL( K1 )
      END DO
      REWIND(UNIT=LDEVST,ERR=1000,IOSTAT=IERROR)
      RETURN
 1000 WRITE(I_OUT , 1001)
 1001 FORMAT(1H0,1X,'ERROR IN REWINDING UTILITY FILES IS DETECTED',
     .  ' BY ROUTINE CONTRL')
      STOP
 1002 PRINT*, 'ERROR READING FROM UTILITY FILE ON UNIT LDEVST'
      RETURN
 1003 PRINT*, 'ERROR WRITING TO UTILITY FILE ON UNIT LDEVST'
C
      END
C           
C =====================================================================
C ========================= L O A D ===================================
C =====================================================================
C
      SUBROUTINE LOAD (R)
C
C =====================================================================
C I                                                                   I
C I    P R O G R A M                                                  I
C I                                                                   I
C I    LOAD ASSEMBLES THE LOAD VECTOR BY CONSIDERING THE              I
C I    EXTERNALY APPLIED LOADS AND THE GRAVITY LOADS WHICH ARE        I
C I    SUPERIMPOSED ON THE STRUCTURE.                                 I
C I                                                                   I
C I                                                                   I
C I    A R G U M E N T   L I S T                                      I
C I                                                                   I
C I      R(I)      =  LOAD VECTOR TO BE ASSEMBLED                     I
C I                                                                   I
C I                                                                   I
C I    C O M M O N   B L O C K S                                      I
C I                                                                   I
C I    REFFER TO THE COMMON BLOCK DESCRIPTIONS.                       I
C I      N(I,J)    =  SHAPE FUNCTION FOR NODE I AT INTEGR. POINT J    I
C I      W(I)      =  GAUSSIAN WEIGHTING FUNCTIONS                    I
C I      XGAUSS    =  X COORDINATE OF THE GAUSSIAN POINTS IN THE ELEM.I
C I      WGTX(I)   =  SPECIFIC WEIGHT OF MATERIAL I IN THE X DIR.     I
C I      WGTY(I)   =  SPECIFIC WEIGHT OF MATERIAL I IN THE Y DIR.     I
C I      WGTZ(I)   =  SPECIFIC WEIGHT OF MATERIAL I IN THE Z DIR.     I
C I      THICK     =  THICKNESS OF THE ELEMENTS FOR PLANE STR & STN   I
C I                =  2*PI*XGAUSS FOR AXISYMETRIC PROBLEMS            I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MAX_GAUSS_PTS,
     .        MAX_MAT_TYPE,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20,
     ,           MAX_GAUSS_PTS=27,MAX_MAT_TYPE=10,MNNDF=3,
     .           MAX_NODES_DOF=MAX_NODES*MNNDF)
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      INTEGER IDIM,INCREMENTS,INTGPN,ISTART,ITERATIONS,K,K1,K2,K3
      INTEGER LINES,M1,MATNUM,NELEM,NINODE,NNDF,INTCOD,NIP
      INTEGER NNEL,NNODES,NOP,ELNUM,ELEM_TYPE,SAVED_ETYPE
      INTEGER NIPXI,NIPETA,NIPSI
      REAL*8 N,NXI,NETA,NSI,CST,DETJAC,RAD,THICK,R(*),RX,RY,RZ,W
      REAL*8 WGTX,WGTY,WGTZ
      LOGICAL LINEAR,SYMMETRIC
      COMMON/INPUT1/NIPXI,NIPETA,NIPSI,NIP,INTCOD
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/INPUT6/WGTX(MAX_MAT_TYPE),WGTY(MAX_MAT_TYPE),
     .              WGTZ(MAX_MAT_TYPE)
      COMMON/INPUT7/RX(MAX_NODES_DOF),RY(MAX_NODES_DOF),
     .              RZ(MAX_NODES_DOF)
      COMMON/INPUT8/NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,
     .              SYMMETRIC,IDIM,NINODE
      COMMON/INPUT9/THICK,STRS_STRN_REL
      COMMON/ISHAP1/N(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NXI(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NETA(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NSI(MAX_ELEM_NODES,MAX_GAUSS_PTS)
      COMMON/ISHAP2/W(MAX_GAUSS_PTS)
C
C ----- FIND THE CONTRIBUTION OF THE GRAVITY WEIGHTS FOR 2D ELEMENTS
C
      SAVED_ETYPE = 0
      DO ELNUM = 1 , NELEM
        CALL ELINFO(ELNUM,ELEM_TYPE,NNEL,MATNUM,STRS_STRN_REL,
     .              ISTART,LINES)
        IF (ELEM_TYPE.GT.300) THEN
          IF (ELEM_TYPE.NE.SAVED_ETYPE) THEN
            IF (INTCOD.GE.140) THEN
              CALL ISH3DI(ELEM_TYPE,NNEL)
            ELSE
              CALL ISH3DG(ELEM_TYPE,NNEL)
            END IF
          END IF
          SAVED_ETYPE = ELEM_TYPE
          DO INTGPN = 1 , NIP
            CALL JACB3D(INTGPN,ELNUM,NNEL,DETJAC)
            CST = DETJAC*W( INTGPN )
            DO K1 = 1 , NNEL
              M1 = NOP(K1 , ELNUM)
              RX( M1 ) = RX( M1 ) + N(K1 , INTGPN)*WGTX( MATNUM )*CST
              RY( M1 ) = RY( M1 ) + N(K1 , INTGPN)*WGTY( MATNUM )*CST
              RZ( M1 ) = RZ( M1 ) + N(K1 , INTGPN)*WGTZ( MATNUM )*CST
            END DO
          END DO
        ELSE
          IF (ELEM_TYPE.NE.SAVED_ETYPE) CALL ISH2DG(ELEM_TYPE,NNEL)
          SAVED_ETYPE = ELEM_TYPE
          DO INTGPN = 1 , NIP
            CALL JACB2D(INTGPN,ELNUM,NNEL,DETJAC)
            IF (STRS_STRN_REL.EQ.AXISYMMETRIC) 
     .                CALL AXISYM(INTGPN,ELNUM,NNEL,RAD,THICK)
            CST = DETJAC*THICK*W( INTGPN )
            DO K1 = 1 , NNEL
              M1 = NOP(K1 , ELNUM)
              RX( M1 ) = RX( M1 ) + N(K1 , INTGPN)*WGTX( MATNUM )*CST
              RY( M1 ) = RY( M1 ) + N(K1 , INTGPN)*WGTY( MATNUM )*CST
            END DO
          END DO
        END IF
      END DO
C
C --- PLACE RX' S AND RY' S IN THE RIGHT POSITIONS IN THE
C --- LOAD ARRAY.
C
      IF (IDIM.EQ.2) THEN
        DO K = 1 , NNODES
          K2 = 2*K
          K1 = K2 - 1
          R( K1 )=RX( K )
          R( K2 )=RY( K )
        END DO
      ELSE IF(IDIM.EQ.3) THEN
        DO K = 1 , NNODES
          K3 = 3*K
          K2 = K3 - 1
          K1 = K3 - 2
          R( K1 )=RX( K )
          R( K2 )=RY( K )
          R( K3 )=RZ( K )
        END DO
      END IF
C
      END
C
C =====================================================================
C ======================== A S S E M B ================================
C =====================================================================
C
      SUBROUTINE ASSEMB(SKG,SKGL,R,U,IDOF,JDIAG,NTSK,MBAND,I_OUT)
C
C =====================================================================
C I                                                                   I
C I   P R O G R A M                                                   I
C I                                                                   I
C I   SUBROUTINE ASSEMB ASSEMBLES THE GLOBAL STIFFNESS MATRIX AND/OR  I
C I   STORES THE NODE NUMBERS OF THE CURRENT ELEMENT AND THE POSITION I
C I   OF THE ELEMENT MATRICES IN THE GLOBAL MATRICES.                 I
C I                                                                   I
C I                                                                   I
C I   A R G U M E N T     L I S T                                     I
C I                                                                   I
C I   SKG(I)   =  GLOBAL STIFFNESS MATRIX STORED IN A ONE DIMENSIONAL I
C I               ARRAY USING THE SKYLINE METHOD                      I
C I   R(I)     =  LOAD VECTOR                                         I
C I   U(I)     =  VECTOR OF THE IMPOSED NODAL DISPLACEMENTS           I
C I   IDOF(I)  =  VECTOR CONTAINING THE D.O.F. NUMBERS THE JOINTS     I
C I   JDIAG(I) =  LOCATION OF THE DIAGONAL TERMS OF EACH COLUMN IN    I
C I               THE GLOBAL STIFFNESS MATRIX 'SKG'                   I
C I   NTSK     =  NUMBER OF TERMS IN THE SKG MATRIX                   I
C I   SYMMETRIC   =  TRUE; SYMMETRIC STIFFNESS MATRIX                 I
C I                  FALSE; NONSYMMETRIC STIFFNESS MATRIX             I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEMENTS,MAX_ELEM_NODES,MAX_ELEM_STIFF,MNNDF
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_ELEMENTS=400,MAX_ELEM_NODES=20)
      PARAMETER (MAX_ELEM_STIFF=60,MNNDF=3)
      INTEGER ELNUM,ELEM_TYPE,SAVED_ETYPE,I1,I2,IDIM,INCREMENTS
      INTEGER ISTART,ITERATIONS,I_OUT,JDOF,K,K1,K2,LINES,LOCA,LOCD
      INTEGER MATNUM,MBAN,MBAND,NCB,NDOF,NELEM,NINODE,NOP,NIP,INTCOD
      INTEGER NNDF,NNEL,NNODES,NRB,NTSK,IDOF(*),II,JDIAG(*)
      INTEGER NIPXI,NIPETA,NIPSI
      REAL*8 THICK,R(*),SK,SKG(*),SKGL(*),U(*)
      LOGICAL LINEAR,SYMMETRIC
      COMMON/INPUT1/NIPXI,NIPETA,NIPSI,NIP,INTCOD
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/INPUT8/NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,
     .              SYMMETRIC,IDIM,NINODE
      COMMON/INPUT9/THICK,STRS_STRN_REL
      COMMON/ELST1/SK(MAX_ELEM_STIFF,MAX_ELEM_STIFF)
      COMMON/ASSEM2/II(MAX_ELEM_STIFF)
C
C        INITIALIZE THE GLOBAL STIFFNESS MATRIX TO ZERO       
C             
      IF (SYMMETRIC) THEN
        DO K1 = 1 , NTSK
          SKG( K1 )=0.D0
        END DO
      ELSE
        DO K1 = 1 , NTSK/2
          SKG( K1 ) = 0.D0
          SKGL( K1 ) = 0.D0
        END DO
      END IF
C
C           NCB = NUMBER OF COLUMNS IN THE <B> MATRIX.
C           NRB = NUMBER OF ROWS IN THE <B> MATRIX.
C           NNEL = NUMBER OF NODES IN THE ELEMENT.
C           MBAN = FULL BANDWIDTH OF THE STIFFNESS MATRIX
C
      MBAN = MBAND*2 - 1
      SAVED_ETYPE = 0
      DO ELNUM = 1 , NELEM
        CALL ELINFO(ELNUM,ELEM_TYPE,NNEL,MATNUM,STRS_STRN_REL,
     .              ISTART,LINES)
        IF (ELEM_TYPE.NE.SAVED_ETYPE) THEN
          IF (ELEM_TYPE.GT.300) THEN
            NCB = 3*NNEL
            NRB = 6
            IF (INTCOD.GE.140) THEN
              CALL ISH3DI(ELEM_TYPE,NNEL)
            ELSE
              CALL ISH3DG(ELEM_TYPE,NNEL)
            END IF
          ELSE
            NCB = 2*NNEL
            CALL ISH2DG(ELEM_TYPE,NNEL)
            IF (STRS_STRN_REL.EQ.AXISYMMETRIC) THEN
              NRB = 4
            ELSE
              NRB = 3
            END IF
          END IF
        END IF
        SAVED_ETYPE = ELEM_TYPE
        DO K1 = 1 , NNEL
          I1 = NNDF*(K1 - 1)
          I2 = NNDF*(NOP(K1 , ELNUM) - 1)
          DO K2 = 1 , NNDF
            K = I1 + K2
            II( K ) = I2 + K2
          END DO
        END DO
C
C              GEOMETRICALLY NONLINEAR PROBLEMS
C
        IF (.NOT.LINEAR) THEN
          IF (ELEM_TYPE.GT.300) THEN
            CALL ES3DNS(ELNUM,ELEM_TYPE,NNEL,NNDF,NRB,NCB,NIP,MATNUM,
     .                  SYMMETRIC,I_OUT)
          ELSE
            CALL ES2DNS(ELNUM,ELEM_TYPE,NNEL,NNDF,NRB,NCB,NIP,MATNUM,
     .                  SYMMETRIC,I_OUT)
          END IF
C
C              GEOMETRICALLY LINEAR PROBLEMS
C
        ELSE IF(LINEAR) THEN
          IF (ELEM_TYPE.GT.300) THEN
            CALL ES3DLS(ELNUM,ELEM_TYPE,NNEL,NNDF,NRB,NCB,NIP,MATNUM,
     .                  SYMMETRIC,I_OUT)
          ELSE
            CALL ES2DLS(ELNUM,ELEM_TYPE,NNEL,NNDF,NRB,NCB,NIP,MATNUM,
     .                  SYMMETRIC,I_OUT)
          END IF
        END IF
        DO K1 = 1 , NCB
          NDOF = IDOF(II( K1 ))
          IF (NDOF.GT.0) THEN
            LOCD = JDIAG( NDOF )
            DO K2 = 1 , NCB
              JDOF = IDOF(II( K2 ))
              IF (SYMMETRIC) THEN
                IF (NDOF.GE.JDOF.AND.JDOF.GT.0) THEN
                  LOCA = LOCD + NDOF - JDOF
                  SKG( LOCA ) = SKG( LOCA ) + SK(K1 , K2)
                END IF
              ELSE
                IF (NDOF.GE.JDOF.AND.JDOF.GT.0) THEN
                  LOCA = LOCD - NDOF + JDOF
                  SKG( LOCA ) = SKG( LOCA ) + SK(K2 , K1)
                  SKGL( LOCA ) = SKGL( LOCA ) + SK(K1 , K2)
                END IF
              END IF
            END DO
          ELSE IF(NDOF.LT.0) THEN
            DO K2 = 1 , NCB
              JDOF = IDOF(II( K2 ))
              IF (JDOF.GT.0) THEN
                R( JDOF ) = R( JDOF ) - SK(K1 , K2)*U(II( K1 ))
              END IF
            END DO
          END IF
        END DO
      END DO
C
      END
C
C =====================================================================
C ========================== E L S T I F ==============================
C =====================================================================
C
      SUBROUTINE ELSTIF
C
C =====================================================================
C I                                                                   I
C I   P R O G R A M                                                   I
C I                                                                   I
C I   ELSTIF EVALUATES THE STIFFNESS MATIRIX OF EACH ELEM.            I
C I                                                                   I
C I   E N T R Y    P O I N T S                                        I
C I                                                                   I
C I   ES2DLS: FOR 2D PLANE STRESS, PLANE STRAIN AND AXISYMMETRIC      I
C I           PROBLEMS WITHOUT GEOMETRIC NONLIARITY.                  I
C I                                                                   I
C I   ES2DNS: FOR 2D PLANE STRESS, PLANE STRAIN AND AXISYMMETRIC      I
C I           PROBLEMS WITH GEOMETRIC NONLIEARITY.                    I
C I                                                                   I
C I   ES3DLS: FOR 3D STRAIN FIELDS WITHOUT GEOM. NONLINEARITY         I
C I                                                                   I
C I   ES3DNS: FOR 3D STRAIN FIELDS WITH GEOMETRIC NONLINEARITY        I
C I                                                                   I
C I                                                                   I
C I   A R G U M E N T     L I S T                                     I
C I                                                                   I
C I   ELNUM     = ELEMENT NUMBER                                      I
C I                                                                   I
C I   NNEL      = NUMBER OF NODES IN THE ELEMENT                      I
C I                                                                   I
C I   NRB       = NUMBER OF ROWS OF THE <B> MATRIX                    I
C I                                                                   I
C I   NCB       = NUMBER OF COLUMNS OF THE <B> MATRIX                 I
C I                                                                   I
C I   NIP       = TOTAL NUMBER OF INTEGRATION POINTS IN THE ELEM.     I
C I                                                                   I
C I   MATNUM    = MATERIAL NUMBER FOR THE ELEMENT                     I
C I                                                                   I
C I   STRS_STRN_REL = 1(PLANE_STRESS): PLANE STRESS PROBLEM (ES2DLS , I
C I                                    ES2DNS ONLY)                   I
C I                   2(PLANE_STRAIN): PLANE STRAIN PROBLEM (ES2DLS , I
C I                                    ES2DNS ONLY)                   I
C I                   3(AXISYMMETRIC): AXISYMMETRIC PROBLEM (ES2DLS , I
C I                                    ES2DNS ONLY)                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEM_NODES,MAX_GAUSS_PTS,MAX_ELEM_STIFF
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_ELEM_NODES=20,MAX_GAUSS_PTS=27,MAX_ELEM_STIFF=60)
      REAL*8 N,NXI,NETA,NSI,NX,NY,NZ,B1,B2,B3,B4,CST,DETJAC,RAD,SX,SXY
      REAL*8 SXZ,SY,SYZ,SZ,THICK,STRESS(6),W,SK
      INTEGER ELNUM,ELEM_TYPE,INTGPN,I_OUT,K1,K11,K12,K13,K2,K21,K22
      INTEGER K23,LDEV,LDEV1,LDEV2,LDEV3,LDEV4,LDEVST,MATNUM,NCB,NIP
      INTEGER NNDF,NNEL,NRB
      LOGICAL SYMMETRIC
      COMMON/INPUT9/THICK,STRS_STRN_REL
      COMMON/ISHAP2/W(MAX_GAUSS_PTS)
      COMMON/ELST1/SK(MAX_ELEM_STIFF,MAX_ELEM_STIFF)
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
      COMMON/ISHAP1/N(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NXI(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NETA(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NSI(MAX_ELEM_NODES,MAX_GAUSS_PTS)
      COMMON/JACOB1/NX(MAX_ELEM_NODES),NY(MAX_ELEM_NODES),
     .              NZ(MAX_ELEM_NODES)
C
C ======================== E N T R Y    E S 2 D L S ===================
C
      ENTRY ES2DLS(ELNUM,ELEM_TYPE,NNEL,NNDF,NRB,NCB,NIP,MATNUM,
     .             SYMMETRIC,I_OUT)
      CALL ZEROSK(NCB)
      DO INTGPN = 1 , NIP
        CALL JACB2D(INTGPN,ELNUM,NNEL,DETJAC)
        IF(STRS_STRN_REL.EQ.AXISYMMETRIC) 
     .              CALL AXISYM(INTGPN,ELNUM,NNEL,RAD,THICK)
        CALL B2DLS(INTGPN,NNEL,RAD)
        CST = DETJAC*THICK*W( INTGPN )
        CALL MATMOD(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,
     .              I_OUT,0)
        CALL BTDB(SYMMETRIC,NRB,NCB,CST)
      END DO
      CALL SKTRAN(ELNUM,NNEL,NNDF,NCB,2)
      RETURN
C
C ======================== E N T R Y    E S 2 D N S ===================
C
      ENTRY ES2DNS(ELNUM,ELEM_TYPE,NNEL,NNDF,NRB,NCB,NIP,MATNUM,
     .             SYMMETRIC,I_OUT)
      CALL ZEROSK(NCB)
      RAD = 1.D0
      DO INTGPN = 1 , NIP
        CALL JACB2D(INTGPN,ELNUM,NNEL,DETJAC)
        IF(STRS_STRN_REL.EQ.AXISYMMETRIC) 
     .               CALL AXISYM(INTGPN,ELNUM,NNEL,RAD,THICK)
        CALL B2DNS(INTGPN,NNEL,RAD)
        CALL MATMOD(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,
     .              I_OUT,0)
        CST = DETJAC*THICK*W( INTGPN )
        CALL BTDB(SYMMETRIC,NRB,NCB,CST)
        READ(LDEV) STRESS
        SX = STRESS( 1 )
        SY = STRESS( 2 )
        SZ = STRESS( 4 )
        SXY = STRESS( 3 )
        IF(STRS_STRN_REL.NE.AXISYMMETRIC) SZ = 0.D0
C
C --- CALCULATION OF <G>TR <M><G>.
C
        DO K1 = 1 , NNEL
          K12 = 2*K1
          K11 = K12 - 1
          B1 = (NX(K1)*SX+NY(K1)*SXY)*CST
          B2 = (NX(K1)*SXY+NY(K1)*SY)*CST
          B3 = N(K1,INTGPN)*SZ*CST/RAD**2
          DO K2 = 1 , NNEL
            K22 = 2*K2
            K21 = K22 - 1
            B4 = NX(K2)*B1+NY(K2)*B2
            SK(K11,K21) = SK(K11,K21)+B4+N(K2,INTGPN)*B3
            SK(K12,K22) = SK(K12,K22)+B4
          END DO
        END DO
      END DO  
      CALL SKTRAN(ELNUM,NNEL,NNDF,NCB,2)
      RETURN
C
C ======================== E N T R Y    E S 3 D L S ===================
C
      ENTRY ES3DLS(ELNUM,ELEM_TYPE,NNEL,NNDF,NRB,NCB,NIP,MATNUM,
     .             SYMMETRIC,I_OUT)            
      CALL ZEROSK(NCB)
      DO INTGPN = 1 , NIP
        CALL JACB3D(INTGPN,ELNUM,NNEL,DETJAC)
        CALL B3DLS(NNEL)
        CALL MATMOD(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,
     .              I_OUT,0)
        CST = DETJAC*W( INTGPN )
        CALL BTDB(SYMMETRIC,NRB,NCB,CST)
      END DO
      CALL SKTRAN(ELNUM,NNEL,NNDF,NCB,3)
      RETURN
C
C ======================== E N T R Y    E S 3 D N S ===================
C
      ENTRY ES3DNS(ELNUM,ELEM_TYPE,NNEL,NNDF,NRB,NCB,NIP,MATNUM,
     .             SYMMETRIC,I_OUT)
      CALL ZEROSK(NCB)                      
      DO INTGPN = 1 , NIP
        CALL JACB3D(INTGPN,ELNUM,NNEL,DETJAC)
        CALL B3DNS(NNEL)
        CALL MATMOD(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,
     .              I_OUT,0)
        CST = DETJAC*W( INTGPN )
        CALL BTDB(SYMMETRIC,NRB,NCB,CST)
        READ(LDEV)STRESS
        SX = STRESS( 1 )
        SY = STRESS( 2 )
        SZ = STRESS( 3 )
        SXY = STRESS( 4 )
        SYZ = STRESS( 5 )
        SXZ = STRESS( 6 )
C
C --- CALCULATION OF <G>TR <M><G>.
C
        DO K1 = 1 , NNEL
          K13 = 3*K1
          K12 = K13 - 1
          K11 = K13 - 2
          B1 = (NX(K1)*SX + NY(K1)*SXY + NZ(K1)*SXZ)*CST
          B2 = (NX(K1)*SXY + NY(K1)*SY + NZ(K1)*SYZ)*CST
          B3 = (NX(K1)*SXZ + NY(K1)*SYZ + NZ(K1)*SZ)*CST
          DO K2 = 1 , NNEL
            K23 = 3*K2
            K22 = K23 - 1
            K21 = K23 - 2
            B4 = NX(K2)*B1 + NY(K2)*B2 + NZ(K2)*B3
            SK(K11,K21) = SK(K11,K21) + B4
            SK(K12,K22) = SK(K12,K22) + B4
            SK(K13,K23) = SK(K13,K23) + B4
          END DO
        END DO
      END DO
      CALL SKTRAN(ELNUM,NNEL,NNDF,NCB,3)
C      
      END
C
C =====================================================================
C ======================= Z E R O S K =================================
C =====================================================================
C
      SUBROUTINE ZEROSK(N)
      IMPLICIT NONE
      INTEGER MAX_ELEM_STIFF
      PARAMETER (MAX_ELEM_STIFF=60)
      INTEGER K1,K2,N
      REAL*8 SK
      COMMON/ELST1/SK(MAX_ELEM_STIFF,MAX_ELEM_STIFF)
C
      DO K2 = 1 , N
        DO K1 = 1 , N
          SK(K1 , K2) = 0.D0
        END DO
      END DO
C
      END
C
C =====================================================================
C ========================== S K T R A N ==============================
C =====================================================================
C
      SUBROUTINE SKTRAN(ELNUM,NNEL,NNDF,NCB,IDIM)
C
C =====================================================================
C I                                                                   I
C I   P R O G R A M                                                   I
C I                                                                   I
C I   SKTRAN MODIFIES THE ELEMENT STIFFNESS MATRIX FOR THE SKEW       I
C I   BOUNDARY CONDITIONS USING <T>T<SK><T> TRANSFORMATION.           I
C I                                                                   I
C I   A R G U M E N T     L I S T                                     I
C I                                                                   I
C I   ELNUM     = ELEMENT NUMBER                                      I
C I                                                                   I
C I   NNEL      = NUMBER OF NODES IN THE ELEMENT                      I
C I                                                                   I
C I   NNDF      = NUMBER OF NODAL DEGREES OF FREEDOM                  I
C I                                                                   I
C I   NCB       = NUMBER OF COLUMNS OF THE <B> MATRIX                 I
C I                                                                   I
C I   IDIM      = PHYSICAL DIMENSION OF THE PROBLEM (I.E.,2D OR 3D)   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MAX_ELEM_STIFF
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20,
     .           MAX_ELEM_STIFF=60)
      INTEGER ELNUM,I,ICODE,ID,IDIM,IDIR,K1,K2,K3,NCB,NNDF,NNEL,NODE
      INTEGER ISPB,NOP
      REAL*8 CST(3),DC,SK
      COMMON/ELST1/SK(MAX_ELEM_STIFF,MAX_ELEM_STIFF)
      COMMON/TRANS/DC(3,3)
      COMMON/INPUTE/ISPB(MAX_NODES)
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
C
      DO K1 = 1 , NNEL
        NODE = NOP(K1 , ELNUM)
        ICODE = ISPB(NODE)
        IF (ICODE.GT.0) THEN
          I = NNDF*(K1 - 1)
          CALL DIRCOS(ICODE,IDIM)
          DO K2 = 1 , NCB
            DO K3 = 1 , IDIM
              CST( K3 ) = 0.D0
              DO IDIR = 1 , IDIM
                ID = I + IDIR
                CST( K3 ) = CST( K3 ) + SK(K2 , ID)*DC(IDIR , K3)
              END DO
            END DO
            DO K3 = 1 , IDIM
              ID = I + K3
              SK(K2 , ID) = CST( K3 )
            END DO
          END DO
          DO K2 = 1 , NCB
            DO K3 = 1 , IDIM
              CST( K3 ) = 0.D0
              DO IDIR = 1 , IDIM
                ID = I + IDIR
                CST( K3 ) = CST( K3 ) + SK(ID , K2)*DC(IDIR , K3)
              END DO
            END DO
            DO K3 = 1 , IDIM
              ID = I + K3
              SK(ID , K2) = CST( K3 )
            END DO
          END DO
        END IF
      END DO
C
      END
C
C =====================================================================
C ========================== D I R C O S ==============================
C =====================================================================
C
      SUBROUTINE DIRCOS(ICODE,IDIM)
C
C =====================================================================
C I                                                                   I
C I   P R O G R A M                                                   I
C I                                                                   I
C I   DIRCOS EVALUATES THE DIRECTION COSINES OF THE Y_PRIM AND        I
C I   THE Z_PRIM AXES FOR SKEW BOUNDARY CONDITIONS USING THE          I
C I   DIRECTION COSINES OF THE X_PRIM (WHICH IS THE AXIS NORMAL TO    I
C I   THE PLANE OF THE ROLLER).                                       I
C I                                                                   I
C I                                                                   I
C I   A R G U M E N T     L I S T                                     I
C I                                                                   I
C I   ICODE     = ADDRESS OF THE DIRECTION COSINES OF THE X_PRIM      I
C I                                                                   I
C I   IDIM      = PHYSICAL DIMENSION OF THE PROBLEM (I.E.,2D OR 3D)   I
C I                                                                   I
C I                                                                   I
C I   C O M M O N    B L O C K S                                      I
C I                                                                   I
C I   COSTX(ICODE)  =  COSINE OF THETA_X                              I
C I                                                                   I
C I   COSTY(ICODE)  =  COSINE OF THETA_Y                              I
C I                                                                   I
C I   COSTZ(ICODE)  =  COSINE OF THETA_Z                              I
C I                                                                   I
C I   DC(I,J)       =  TRANSFORMATION MATRIX WHICH HAS ITS COLUMNS    I
C I                    EQUAL TO THE DIRECTION COSINES OF THE          I
C I                    X_PRIM, Y_PRIM, AND Z_PRIM AXES.               I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_SKEW_BC,ICODE,IDIM
      REAL*8 CNORM,TX,TY,TZ,COSTX,COSTY,COSTZ,DC
      PARAMETER (MAX_SKEW_BC=300)
      COMMON/INPUTD/COSTX(MAX_SKEW_BC),COSTY(MAX_SKEW_BC),
     .              COSTZ(MAX_SKEW_BC)
      COMMON/TRANS/DC(3,3)
C
      IF(IDIM.EQ.2) THEN
        DC(1 , 1) = COSTX( ICODE )
        DC(2 , 1) = COSTY( ICODE )
        DC(1 , 2) = -COSTY( ICODE )
        DC(2 , 2) = COSTX( ICODE )
      ELSE IF(IDIM.EQ.3) THEN
        TX = COSTX( ICODE )
        TY = COSTY( ICODE )
        TZ = COSTZ( ICODE )
        DC(1 , 1) = TX
        DC(2 , 1) = TY
        DC(3 , 1) = TZ
        CNORM = DSQRT(TY**2 + TX**2)
        DC(1 , 2) = -TY/CNORM
        DC(2 , 2) = TX/CNORM
        DC(3 , 2) = 0.D0
        CNORM=DSQRT((TX/TY)**2+1.D0+(TX**2/(TY*TZ)+TY/TZ)**2)
        DC(1,3)=TX/(TY*CNORM)
        DC(2,3)=1.D0/CNORM
        DC(3,3)=-(TX**2/(TY*TZ)+TY/TZ)/CNORM
      END IF
C
      END
C
C =====================================================================
C ============================ B T D B ================================
C =====================================================================
C
      SUBROUTINE BTDB(SYMMETRIC,NRB,NCB,CST)
C
C =====================================================================
C I                                                                   I
C I   SUBPROGRAM BTDB EVALUATES <BT><DEP><B>CST, WHERE                I
C I                                                                   I
C I      <BT> = TRANSPOSE OF THE <B> MATRIX                           I
C I      <DEP> = MATERIAL STIFFNESS MATRIX                            I
C I      CST   = CONSTANT VALUE TO BE MULT. WITH EACH TERM OF THE     I
C I              RESULTING MATRIX.                                    I
C I                                                                   I
C I   A R G U M E N T      L I S T                                    I
C I                                                                   I
C I      SYMMETRIC = TRUE; FOR SYMMETRIC STIFFNESS MATRIX             I
C I                  FALSE; FOR NONSYMMETRIC STIFFNESS MATRIX         I
C I                                                                   I
C I      NRB  = NUMBER OF ROWS IN THE <B> BATRIX                      I
C I                                                                   I
C I      NCB  = NUMBER OF COLUMNS IN THE <B> MATRIX                   I
C I                                                                   I
C I      CST  = INTEGRATION CONSTANT                                  I
C I                                                                   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEM_STIFF
      PARAMETER (MAX_ELEM_STIFF=60)
      REAL*8 SK,B,DEP,CST,DUMMY(6)
      INTEGER K1,K2,K3,K4,K5,NCB,NRB
      LOGICAL SYMMETRIC
      COMMON/ELST1/SK(MAX_ELEM_STIFF,MAX_ELEM_STIFF)
      COMMON/B1/B(6,MAX_ELEM_STIFF)
      COMMON/MATER1/DEP(6,6)
C
C --- B(K3,K1) IS THE TRANSPOSE OF THE B(K1,K3)
C
      DO K1 = 1 , NRB
        DO K2 = 1 , NRB
          DEP(K1 , K2) = DEP(K1 , K2)*CST
        END DO
      END DO
      IF (SYMMETRIC) THEN
        DO K1 = 1,NCB
          DO K2 = 1,NRB
            DUMMY(K2) = 0.D0
            DO K3 = 1,NRB
              DUMMY(K2) = DUMMY(K2)+B(K3,K1)*DEP(K3,K2)
            END DO
          END DO
          DO K4 = 1,K1
            DO K5 = 1,NRB
              SK(K1,K4) = SK(K1,K4) + DUMMY( K5 )*B(K5 , K4)
            END DO
            SK(K4,K1) = SK(K1,K4)
          END DO
        END DO
      ELSE IF(.NOT.SYMMETRIC) THEN
        DO K1 = 1,NCB
          DO K2 = 1,NRB
            DUMMY(K2) = 0.D0
            DO K3 = 1,NRB
              DUMMY(K2) = DUMMY(K2)+B(K3,K1)*DEP(K3,K2)
            END DO
          END DO
          DO K4 = 1,NCB
            DO K5 = 1,NRB
              SK(K1,K4) = SK(K1,K4) + DUMMY( K5 )*B(K5 , K4)
            END DO
          END DO
        END DO
      END IF
C
      END
C
C =====================================================================
C ========================= B 2 D 3 D =================================
C =====================================================================
C
      SUBROUTINE B2D3D
C
C =====================================================================
C I                                                                   I
C I   SUBPROGRAM B2D3D EVALUATES THE 'B' MATRIX FOR THE 2D AND 3D     I
C I   FINITE STRAIN PROBLEMS.                                         I
C I                                                                   I
C I      ENTRY POINTS:                                                I
C I      B2DLS : FOR 2D PLANE STRESS, PLANE STRAIN AND AXISYMMETRIC   I
C I               PROBLEMS WITHOUT GEOMETRIC NONLINEARITY.            I
C I                                                                   I
C I      B2DNS: FOR 2D PLANE STRESS, PLANE STRAIN AND AXISYMMETRIC    I
C I               PROBLEMS WITH GEOMETRIC NONLINEARITY.               I
C I                                                                   I
C I      B3DLS : FOR 3D STRAIN FIELDS WITHOUT GEOMETRIC NONLINEARITY  I
C I                                                                   I
C I      B3DNS: FOR 3D STRAIN FIELDS WITH GEOMETRIC NONLINEARITY      I
C I                                                                   I
C I     B(I,J)      =  VARIATIONAL STRAIN-DISPLACEMENT STIFFNESS      I
C I                    MATRIX.                                        I
C I                                                                   I
C I                                                                   I
C I   NX(K) = PARTIAL DERIVATIVE OF N(K) WITH RESPECT TO X;           I
C I   NY(K) = PARTIAL DERIVATIVE OF N(K) WITH RESPECT TO Y;           I
C I   NZ(K) = PARTIAL DERIVATIVE OF N(K) WITH RESPECT TO Z;           I
C I                                                                   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      INTEGER MAX_NODES,MAX_ELEM_NODES,MAX_GAUSS_PTS,MAX_ELEM_STIFF,
     .        MNNDF,MAX_NODES_DOF
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_NODES=3000,MAX_ELEM_NODES=20,MAX_GAUSS_PTS=27,
     .           MAX_ELEM_STIFF=60,MNNDF=3,
     .           MAX_NODES_DOF=MAX_NODES*MNNDF)
      INTEGER NNEL,INTGPN,K1,K11,K12,K13,II
      REAL*8 A5,DUDX,DVDX,DWDX,DUDY,DVDY,DWDY,DUDZ,DVDZ,DWDZ,RAD,THICK
      REAL*8 B,N,NETA,NSI,NX,NXI,NY,NZ,UTOTAL
      COMMON/INPUT9/THICK,STRS_STRN_REL
      COMMON/ISHAP1/N(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NXI(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NETA(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NSI(MAX_ELEM_NODES,MAX_GAUSS_PTS)
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/ASSEM2/II(MAX_ELEM_STIFF)
      COMMON/JACOB1/NX(MAX_ELEM_NODES),NY(MAX_ELEM_NODES),
     .              NZ(MAX_ELEM_NODES)
      COMMON/B1/B(6,MAX_ELEM_STIFF)
      COMMON/B2/DUDX,DVDX,DWDX,DUDY,DVDY,DWDY,DUDZ,DVDZ,DWDZ,A5
C
C ======================== E N T R Y    B 2 D L S =====================
C
      ENTRY B2DLS(INTGPN,NNEL,RAD)
C                                        
C --- CALCULATION OF THE <B> MATRIX
C
      DO K1 = 1,NNEL
        K12 = 2*K1
        K11 = K12 - 1
        B(1,K11) = NX(K1)
        B(1,K12) = 0.D0
        B(2,K11) = 0.D0
        B(2,K12) = NY(K1)
        B(3,K11) = NY(K1)
        B(3,K12) = NX(K1)
      END DO
C
C --- CALCULATION OF THE ADDITIONAL ROW OF <B> FOR THE AXISYM. CASE.
C
      IF (STRS_STRN_REL.EQ.AXISYMMETRIC) THEN
        DO K1 = 1 , NNEL
          K12 = 2*K1
          K11 = K12 - 1
          B(4,K11) = N(K1,INTGPN)/RAD
          B(4,K12) = 0.D0
        END DO
      END IF
      RETURN
C
C ======================== E N T R Y    B 2 D N S =====================
C
      ENTRY B2DNS(INTGPN,NNEL,RAD)
C
C --- CALCULATION OF THE <B> MATRIX  
C
      DUDX = 0.D0
      DVDX = 0.D0
      DUDY = 0.D0
      DVDY = 0.D0
      A5 = 0.D0
      DO K1 = 1,NNEL
        K12 = 2*K1
        K11 = K12 - 1
        DUDX = DUDX + NX(K1)*UTOTAL(II(K11))
        DVDX = DVDX + NX(K1)*UTOTAL(II(K12))
        DUDY = DUDY + NY(K1)*UTOTAL(II(K11))
        DVDY = DVDY + NY(K1)*UTOTAL(II(K12))
        A5 = A5 + N(K1,INTGPN)*UTOTAL(II(K11))
      END DO
      DO K1 = 1,NNEL
        K12 = 2*K1
        K11 = K12 - 1
        B(1,K11)=(1.D0 + DUDX)*NX(K1)
        B(1,K12)=DVDX*NX(K1)
        B(2,K11)=DUDY*NY(K1)
        B(2,K12)=(1.D0 + DVDY)*NY(K1)
        B(3,K11)=DUDY*NX(K1) + (1.D0 + DUDX)*NY(K1)
        B(3,K12)=DVDX*NY(K1) + (1.D0 + DVDY)*NX(K1)
      END DO
C
C --- CALCULATION OF THE ADDITIONAL ROW OF <B> FOR THE AXISYM CASE.
C
      IF (STRS_STRN_REL.EQ.AXISYMMETRIC) THEN
        A5 = A5/RAD
        DO K1 = 1 , NNEL
          K12 = 2*K1
          K11 = K12 - 1
          B(4,K11) = (A5 + 1.D0)*N(K1,INTGPN)/RAD
          B(4,K12) = 0.D0
        END DO
      END IF
      RETURN
C
C ======================== E N T R Y    B 3 D L S =====================
C
      ENTRY B3DLS(NNEL)
C
C --- CALCULATION OF THE <B> MATRIX                
C
      DO K1 = 1,NNEL
        K13 = 3*K1
        K12 = K13 - 1
        K11 = K13 - 2
        B(1,K11) = NX(K1)
        B(1,K12) = 0.D0
        B(1,K13) = 0.D0
        B(2,K11) = 0.D0
        B(2,K12) = NY(K1)
        B(2,K13) = 0.D0
        B(3,K11) = 0.D0
        B(3,K12) = 0.D0
        B(3,K13) = NZ(K1)
        B(4,K11) = NY(K1)
        B(4,K12) = NX(K1)
        B(4,K13) = 0.D0
        B(5,K11) = 0.D0
        B(5,K12) = NZ(K1)
        B(5,K13) = NY(K1)
        B(6,K11) = NZ(K1)
        B(6,K12) = 0.D0
        B(6,K13) = NX(K1)
      END DO
      RETURN
C
C ======================== E N T R Y    B 3 D N S =====================
C
      ENTRY B3DNS(NNEL)
C                                    
C --- CALCULATION OF THE <B> MATRIX
C
      DUDX = 0.D0
      DVDX = 0.D0
      DWDX = 0.D0
      DUDY = 0.D0
      DVDY = 0.D0
      DWDY = 0.D0
      DUDZ = 0.D0
      DVDZ = 0.D0
      DWDZ = 0.D0
      DO K1 = 1,NNEL
        K13 = 3*K1
        K12 = K13 - 1
        K11 = K13 - 2
        DUDX = DUDX + NX(K1)*UTOTAL(II(K11))
        DVDX = DVDX + NX(K1)*UTOTAL(II(K12))
        DWDX = DWDX + NX(K1)*UTOTAL(II(K13))
        DUDY = DUDY + NY(K1)*UTOTAL(II(K11))
        DVDY = DVDY + NY(K1)*UTOTAL(II(K12))
        DWDY = DWDY + NY(K1)*UTOTAL(II(K13))
        DUDZ = DUDZ + NZ(K1)*UTOTAL(II(K11))
        DVDZ = DVDZ + NZ(K1)*UTOTAL(II(K12))
        DWDZ = DWDZ + NZ(K1)*UTOTAL(II(K13))
      END DO
      DO K1 = 1,NNEL
        K13 = 3*K1
        K12 = K13 - 1
        K11 = K13 - 2
        B(1,K11) = (1.D0 + DUDX)*NX(K1)
        B(1,K12) = DVDX*NX(K1)
        B(1,K13) = DWDX*NX(K1)
        B(2,K11) = DUDY*NY(K1)
        B(2,K12) = (1.D0 + DVDY)*NY(K1)
        B(2,K13) = DWDY*NY(K1)
        B(3,K11) = DUDZ*NZ(K1)
        B(3,K12) = DVDZ*NZ(K1)
        B(3,K13) = (1.D0 + DWDZ)*NZ(K1)
        B(4,K11) = DUDY*NX(K1) + (1.D0 + DUDX)*NY(K1)
        B(4,K12) = DVDX*NY(K1) + (1.D0 + DVDY)*NX(K1)
        B(4,K13) = DWDY*NX(K1) + DWDX*NY(K1)
        B(5,K11) = DUDZ*NY(K1) + DUDY*NZ(K1)
        B(5,K12) = DVDZ*NY(K1) + (1.D0 + DVDY)*NZ(K1)
        B(5,K13) = DWDY*NZ(K1) + (1.D0 + DWDZ)*NY(K1)
        B(6,K11) = DUDZ*NX(K1) + (1.D0 + DUDX)*NZ(K1)
        B(6,K12) = DVDX*NZ(K1) + DVDZ*NX(K1)
        B(6,K13) = DWDX*NZ(K1) + (1.D0 + DWDZ)*NX(K1)
      END DO
C
      END
C
C =====================================================================
C ========================= A X I S Y M ===============================
C =====================================================================
C
      SUBROUTINE AXISYM(INTGPN,ELNUM,NNEL,RAD,THICK)
C
C =====================================================================
C I                                                                   I
C I      SUBPROGRAM AXISYM EVALUATES THE RADIUS OF THE INTEGRATION    I
C I      POINT FROM THE AXIS OF SYMMETRY FOR AXISYMMETRIC PROBLEMS.   I
C I      THE AXIS OF SYMMETRY IS ASSUMED TO BE THE Y AXIS.            I
C I                                                                   I
C I         INTGPN  = INTEGRATION POINT NUMBER                        I
C I         ELNUM   = ELEMENT NUMBER                                  I
C I         NNEL    = NUMBER OF NODES IN THE ELEMENT                  I
C I         RAD     = RADIUS OF THE INTEGRATION POINT                 I
C I         THICK   = CIRCUMFERENCE OF THE AXISYMMETRIC SOLID         I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MAX_GAUSS_PTS
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20,
     .           MAX_GAUSS_PTS=27)
      INTEGER INTGPN,K1,NNEL,NOP,ELNUM
      REAL*8 RAD,THICK,N,NXI,NETA,NSI
      REAL*4 X,Y,Z
      COMMON/ISHAP1/N(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NXI(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NETA(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NSI(MAX_ELEM_NODES,MAX_GAUSS_PTS)
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/INPUT3/X(MAX_NODES),Y(MAX_NODES),Z(MAX_NODES)
C
      RAD = 0.D0
      DO K1 = 1 , NNEL
        RAD = RAD + N(K1 , INTGPN)*X(NOP(K1 , ELNUM))
      END DO
      THICK = 6.283185307179586D0*RAD
C
      END
C
C =====================================================================
C ========================== G E T S T R ==============================
C =====================================================================
C
      SUBROUTINE GETSTR(I_OUT)
C
C =====================================================================
C I                                                                   I
C I   SUBROUTINE GETSTR ASSEMBELS THE GLOBAL STIFFNESS MATRIX AND/OR  I
C I   STORES THE NODE NUMBERS OF THE CURRENT ELEMENT AND THE POSITION I
C I   OF THE ELEMENT MATRICES IN THE GLOBAL MATRICES.                 I
C I                                                                   I
C I                                                                   I
C I   II(J)    POSITION OF LOCAL STIFFNESS TERMS IN THE GLOBAL        I
C I            STIFFNESS MATRIX.                                      I
C I                                                                   I
C I   SKG(I) =    GLOBAL STIFFNESS MATRIX IN THE CONDENSED FORM       I
C I   SK(I,J)  =    ELEMENT STIFFNESS MATRIX                          I
C I                 (SK IS COMPUTED BY SUBPROGRAM STIFEL)             I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEMENTS,MAX_ELEM_NODES,MAX_ELEM_STIFF,MNNDF
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_ELEMENTS=400,MAX_ELEM_NODES=20,MAX_ELEM_STIFF=60)
      PARAMETER (MNNDF=3)
      INTEGER ELNUM,ELEM_TYPE,SAVED_ETYPE,I1,I2,IDIM,INCREMENTS
      INTEGER ISTART,ITERATIONS,I_OUT,K,K1,K2,LINES,MATNUM,NCB,NELEM
      INTEGER NINODE,NNDF,II,NOP,NNODES,NNEL,NRB,NIP,INTCOD
      INTEGER NIPXI,NIPETA,NIPSI
      REAL*8 THICK
      LOGICAL LINEAR,SYMMETRIC
      COMMON/INPUT8/NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,
     .              SYMMETRIC,IDIM,NINODE
      COMMON/INPUT9/THICK,STRS_STRN_REL
      COMMON/INPUT1/NIPXI,NIPETA,NIPSI,NIP,INTCOD
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/ASSEM2/II(MAX_ELEM_STIFF)
C                                                      
C           NCB = NUMBER OF COLUMNS IN THE <B> MATRIX.
C           NRB = NUMBER OF ROWS IN THE <B> MATRIX.
C           NNEL = NUMBER OF NODES IN THE ELEMENT.
C
      SAVED_ETYPE = 0
      DO ELNUM = 1 , NELEM
        CALL ELINFO(ELNUM,ELEM_TYPE,NNEL,MATNUM,STRS_STRN_REL,
     .              ISTART,LINES)
        IF (ELEM_TYPE.NE.SAVED_ETYPE) THEN
          IF (ELEM_TYPE.GT.300) THEN
            NCB = 3*NNEL
            NRB = 6
            IF (INTCOD.GE.140) THEN
              CALL ISH3DI(ELEM_TYPE,NNEL)
            ELSE
              CALL ISH3DG(ELEM_TYPE,NNEL)
            END IF
          ELSE
            NCB = 2*NNEL
            CALL ISH2DG(ELEM_TYPE,NNEL)
            IF (STRS_STRN_REL.EQ.AXISYMMETRIC) THEN
              NRB = 4
            ELSE
              NRB = 3
            END IF
          END IF
        END IF
        SAVED_ETYPE = ELEM_TYPE
        DO K1 = 1 , NNEL
          I1 = NNDF*(K1 - 1)
          I2 = NNDF*(NOP(K1 , ELNUM) - 1)
          DO K2 = 1 , NNDF
            K = I1 + K2
            II( K ) = I2 + K2
          END DO
        END DO
C
C              GEOMETRICALLY NONLINEAR PROBLEMS
C
        IF(.NOT.LINEAR) THEN
          IF(ELEM_TYPE.GT.300) THEN
            CALL S3DNS(ELNUM,ELEM_TYPE,NNEL,NRB,NCB,NIP,MATNUM,I_OUT)
          ELSE
            CALL S2DNS(ELNUM,ELEM_TYPE,NNEL,NRB,NCB,NIP,MATNUM,I_OUT)
          ENDIF
C
C              GEOMETRICALLY LINEAR PROBLEMS
C
        ELSE IF(LINEAR) THEN
          IF(ELEM_TYPE.GT.300) THEN
            CALL S3DLS(ELNUM,ELEM_TYPE,NNEL,NRB,NCB,NIP,MATNUM,I_OUT)
          ELSE
            CALL S2DLS(ELNUM,ELEM_TYPE,NNEL,NRB,NCB,NIP,MATNUM,I_OUT)
          ENDIF
        ENDIF
      END DO
C
      END
C
C =====================================================================
C =========================== E L S T R ===============================
C =====================================================================
C
      SUBROUTINE ELSTR
C
C =====================================================================
C I                                                                   I
C I      SUBPROGRAM ELSTR EVALUATES THE STIFFNESS MATRIX OF EACH ELEM I
C I                                                                   I 
C I      ENTRY POINTS:                                                I
C I      S2DLS   : FOR 2D PLANE STRESS, PLANE STRAIN AND AXISYMMETRIC I
C I               PROBLEMS WITHOUT GEOMETRIC NONLINEARITY.            I
C I                                                                   I
C I      S2DNS : FOR 2D PLANE STRESS, PLANE STRAIN AND AXISYMMETRIC   I
C I               PROBLEMS WITH GEOMETRIC NONLINEARITY.               I
C I                                                                   I
C I      S3DLS   : FOR 3D STRAIN FIELDS WITHOUT GEOM. NONLINEARITY    I
C I                                                                   I
C I      S3DNS : FOR 3D STRAIN FIELDS WITH GEOMETRIC NONLINEARITY     I
C I                                                                   I
C I                                                                   I
C I  PARAMETER LIST:                                                  I
C I                                                                   I
C I   STRS_STRN_REL = 1(PLANE_STRESS): PLANE STRESS PROBLEM (ES2DLS , I
C I                                    ES2DNS ONLY)                   I
C I                   2(PLANE_STRAIN): PLANE STRAIN PROBLEM (ES2DLS , I
C I                                    ES2DNS ONLY)                   I
C I                   3(AXISYMMETRIC): AXISYMMETRIC PROBLEM (ES2DLS , I
C I                                    ES2DNS ONLY)                   I
C I                                                                   I
C I      ELNUM     = ELEMENT NUMBER                                   I
C I      NNEL      = NUMBER OF NODES IN THE ELEMENT                   I
C I      NRB       = NUMBER OF ROWS OF THE <B> MATRIX                 I
C I      NCB       = NUMBER OF COLUMNS OF THE <B> MATRIX              I
C I      NIP       = TOTAL NUMBER OF INTEGRATION POINTS IN THE ELEM.  I
C I                                                                   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEM_NODES,MAX_GAUSS_PTS,MAX_ELEM_STIFF,
     .        MNNDF,MAX_NODES_DOF
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_NODES=3000,MAX_ELEM_NODES=20,MAX_GAUSS_PTS=27,
     .           MAX_ELEM_STIFF=60,MNNDF=3,
     .           MAX_NODES_DOF=MAX_NODES*MNNDF)
      REAL*8 N,NXI,NETA,NSI,NX,NY,NZ,A5,CST,DETJAC,RAD,THICK
      REAL*8 DUDX,DVDX,DWDX,DUDY,DVDY,DWDY,DUDZ,DVDZ,DWDZ
      REAL*8 STRN,UTOTAL,W
      INTEGER ELNUM,ELEM_TYPE,INTGPN,I_OUT,K1,K11,K12,K13,MATNUM,NCB
      INTEGER NIP,NNEL,NRB,II
      COMMON/ISHAP2/W(MAX_GAUSS_PTS)
      COMMON/ISHAP1/N(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NXI(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NETA(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NSI(MAX_ELEM_NODES,MAX_GAUSS_PTS)
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/ASSEM2/II(MAX_ELEM_STIFF)
      COMMON/JACOB1/NX(MAX_ELEM_NODES),NY(MAX_ELEM_NODES),
     .              NZ(MAX_ELEM_NODES)
      COMMON/B2/DUDX,DVDX,DWDX,DUDY,DVDY,DWDY,DUDZ,DVDZ,DWDZ,A5
      COMMON/INPUT9/THICK,STRS_STRN_REL
      COMMON/ELSTR1/STRN(6)
C
C ======================== E N T R Y    S 2 D L S =====================
C
      ENTRY S2DLS (ELNUM,ELEM_TYPE,NNEL,NRB,NCB,NIP,MATNUM,I_OUT)
      DO INTGPN = 1 , NIP
        CALL JACB2D(INTGPN,ELNUM,NNEL,DETJAC)
        IF(STRS_STRN_REL.EQ.AXISYMMETRIC) 
     .                 CALL AXISYM(INTGPN,ELNUM,NNEL,RAD,THICK)
        CALL B2DLS(INTGPN,NNEL,RAD)
        CST = DETJAC*THICK*W( INTGPN )
        DUDX = 0.D0
        DVDX = 0.D0
        DUDY = 0.D0
        DVDY = 0.D0
        A5 = 0.D0
        DO K1 = 1,NNEL
          K12 = 2*K1
          K11 = K12 - 1
          DUDX = DUDX + NX(K1)*UTOTAL(II(K11))
          DVDX = DVDX + NX(K1)*UTOTAL(II(K12))
          DUDY = DUDY + NY(K1)*UTOTAL(II(K11))
          DVDY = DVDY + NY(K1)*UTOTAL(II(K12))
          A5 = A5 + N(K1,INTGPN)*UTOTAL(II(K11))
        END DO
        STRN( 1 ) = DUDX
        STRN( 2 ) = DVDY
        STRN( 3 ) = DUDY + DVDX
        STRN( 4 ) = 0.D0
        IF (STRS_STRN_REL.EQ.AXISYMMETRIC) STRN( 4 ) = A5/RAD
        CALL MATMOD(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,
     .              I_OUT,1)
        CALL EQUILB(CST,NCB,NRB)
      END DO
      RETURN
C
C ======================== E N T R Y    S 2 D N S =====================
C
      ENTRY S2DNS (ELNUM,ELEM_TYPE,NNEL,NRB,NCB,NIP,MATNUM,I_OUT)
      DO INTGPN = 1 , NIP                 
        CALL JACB2D(INTGPN,ELNUM,NNEL,DETJAC)
        IF(STRS_STRN_REL.EQ.AXISYMMETRIC)
     .                  CALL AXISYM(INTGPN,ELNUM,NNEL,RAD,THICK)
        CALL B2DNS(INTGPN,NNEL,RAD)
        CST = DETJAC*THICK*W( INTGPN )
        STRN(1)=DUDX+0.5D0*(DUDX**2 + DVDX**2 )
        STRN(2)=DVDY+0.5D0*(DUDY**2 + DVDY**2 )
        STRN(3)=DUDY+DVDX + DUDX*DUDY + DVDX*DVDY
        STRN(4)=0.D0
        IF (STRS_STRN_REL.EQ.AXISYMMETRIC) STRN(4)=A5+0.5D0*(A5**2)
        CALL MATMOD(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,I_OUT,
     .              1)
        CALL EQUILB(CST,NCB,NRB)
      END DO
      RETURN
C
C ======================== E N T R Y    S 3 D L S =====================
C
      ENTRY S3DLS (ELNUM,ELEM_TYPE,NNEL,NRB,NCB,NIP,MATNUM,I_OUT)
      DO INTGPN = 1 , NIP
        CALL JACB3D(INTGPN,ELNUM,NNEL,DETJAC)
        CALL B3DLS(NNEL)
        CST = DETJAC*W( INTGPN )
        DUDX = 0.D0
        DVDX = 0.D0
        DWDX = 0.D0
        DUDY = 0.D0
        DVDY = 0.D0
        DWDY = 0.D0
        DUDZ = 0.D0
        DVDZ = 0.D0
        DWDZ = 0.D0
        DO K1 = 1,NNEL
          K13 = 3*K1
          K12 = K13 - 1
          K11 = K13 - 2
          DUDX = DUDX + NX(K1)*UTOTAL(II(K11))
          DVDX = DVDX + NX(K1)*UTOTAL(II(K12))
          DWDX = DWDX + NX(K1)*UTOTAL(II(K13))
          DUDY = DUDY + NY(K1)*UTOTAL(II(K11))
          DVDY = DVDY + NY(K1)*UTOTAL(II(K12))
          DWDY = DWDY + NY(K1)*UTOTAL(II(K13))
          DUDZ = DUDZ + NZ(K1)*UTOTAL(II(K11))
          DVDZ = DVDZ + NZ(K1)*UTOTAL(II(K12))
          DWDZ = DWDZ + NZ(K1)*UTOTAL(II(K13))
        END DO
        STRN( 1 ) = DUDX
        STRN( 2 ) = DVDY
        STRN( 3 ) = DWDZ
        STRN( 4 ) = DUDY + DVDX
        STRN( 5 ) = DWDY + DVDZ
        STRN( 6 ) = DWDX + DUDZ
        CALL MATMOD(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,
     .              I_OUT,1)
        CALL EQUILB(CST,NCB,NRB)
      END DO
      RETURN
C
C ======================== E N T R Y    S 3 D N S =====================
C
      ENTRY S3DNS (ELNUM,ELEM_TYPE,NNEL,NRB,NCB,NIP,MATNUM,I_OUT)
      DO INTGPN = 1 , NIP
        CALL JACB3D(INTGPN,ELNUM,NNEL,DETJAC)
        CALL B3DNS(NNEL)
        CST = DETJAC*W( INTGPN )
        STRN(1)=DUDX+0.5D0*(DUDX**2+DVDX**2+DWDX**2)
        STRN(2)=DVDY+0.5D0*(DUDY**2+DVDY**2+DWDY**2)
        STRN(3)=DWDZ+0.5D0*(DUDZ**2+DVDZ**2+DWDZ**2)
        STRN( 4 ) = DUDY + DVDX + DUDX*DUDY + DVDX*DVDY + DWDX*DWDY
        STRN( 5 ) = DWDY + DVDZ + DUDZ*DUDY + DVDZ*DVDY + DWDZ*DWDY
        STRN( 6 ) = DWDX + DUDZ + DUDZ*DUDX + DVDZ*DVDX + DWDZ*DWDX
        CALL MATMOD(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,
     .              I_OUT,1)
        CALL EQUILB(CST,NCB,NRB)
      END DO
C
      END
C
C =====================================================================
C ========================= E Q U L I B ===============================
C =====================================================================
C
      SUBROUTINE EQUILB(CST,NCB,NRB)
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEM_STIFF,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MAX_ELEM_STIFF=60,MNNDF=3,
     .           MAX_NODES_DOF=MAX_NODES*MNNDF)
      REAL*8 B,RE,STRS,CST,TEMP
      INTEGER K1,K2,NCB,NRB,II
      COMMON/ASSEM2/II(MAX_ELEM_STIFF)
      COMMON/ELSTR2/STRS(6)
      COMMON/MAIN4/RE(MAX_NODES_DOF)
      COMMON/B1/B(6,MAX_ELEM_STIFF)
C
      DO K1 = 1 , NCB
        TEMP = 0.D0
        DO K2 = 1 , NRB
          TEMP = TEMP + B(K2 , K1)*STRS( K2 )
        END DO
        RE(II(K1)) = RE(II(K1)) + TEMP*CST
      END DO
C
      END
C
C =====================================================================
C ======================== C A U C H Y ================================
C =====================================================================
C
      SUBROUTINE CAUCHY(ELNUM,ELEM_TYPE,NNEL,NNDF,INTGPN,STRESS,CSTR)
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20,
     .           MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      REAL*8 NX,NY,NZ,JACMAT(3,3),DETJAC,DJAC,SUM,CAUCH(3,3),CSTR(6)
      REAL*8 PIOLA(3,3),STRESS(6)
      REAL*8 DUDX,DVDX,DWDX,DUDY,DVDY,DWDY,DUDZ,DVDZ,DWDZ,UTOTAL
      INTEGER ELNUM,ELEM_TYPE,INTGPN,K1,K11,K12,K13,K2,K3,K4,NNDF,NNEL
      INTEGER NOP
      COMMON/JACOB1/NX(MAX_ELEM_NODES),NY(MAX_ELEM_NODES),
     .              NZ(MAX_ELEM_NODES)
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
C
      DUDX = 0.D0
      DUDY = 0.D0
      DUDZ = 0.D0
      DVDX = 0.D0
      DVDY = 0.D0
      DVDZ = 0.D0
      DWDX = 0.D0
      DWDY = 0.D0
      DWDZ = 0.D0
      IF (ELEM_TYPE.GT.300) THEN
        CALL JACB3D(INTGPN,ELNUM,NNEL,DETJAC)
        DO K1 = 1 , NNEL
          K11 = NNDF*(NOP(K1 , ELNUM) - 1) + 1
          K12 = K11 + 1
          K13 = K11 + 2
          DUDX = DUDX + NX( K1 )*UTOTAL( K11 )
          DUDY = DUDY + NY( K1 )*UTOTAL( K11 )
          DUDZ = DUDZ + NZ( K1 )*UTOTAL( K11 )
          DVDX = DVDX + NX( K1 )*UTOTAL( K12 )
          DVDY = DVDY + NY( K1 )*UTOTAL( K12 )
          DVDZ = DVDZ + NZ( K1 )*UTOTAL( K12 )
          DWDX = DWDX + NX( K1 )*UTOTAL( K13 )
          DWDY = DWDY + NY( K1 )*UTOTAL( K13 )
          DWDZ = DWDZ + NZ( K1 )*UTOTAL( K13 )
        END DO
        PIOLA(1 , 1) = STRESS( 1 )
        PIOLA(2 , 2) = STRESS( 2 )
        PIOLA(3 , 3) = STRESS( 3 )
        PIOLA(1 , 2) = STRESS( 4 )
        PIOLA(2 , 1) = STRESS( 4 )
        PIOLA(1 , 3) = STRESS( 6 )
        PIOLA(3 , 1) = STRESS( 6 )
        PIOLA(2 , 3) = STRESS( 5 )
        PIOLA(3 , 2) = STRESS( 5 )
      ELSE
        CALL JACB2D(INTGPN,ELNUM,NNEL,DETJAC)
        DO K1 = 1 , NNEL
          K11 = NNDF*(NOP(K1 , ELNUM) - 1) + 1
          K12 = K11 + 1
          DUDX = DUDX + NX( K1 )*UTOTAL( K11 )
          DUDY = DUDY + NY( K1 )*UTOTAL( K11 )
          DVDX = DVDX + NX( K1 )*UTOTAL( K12 )
          DVDY = DVDY + NY( K1 )*UTOTAL( K12 )
        END DO
        PIOLA(1 , 1) = STRESS( 1 )
        PIOLA(2 , 2) = STRESS( 2 )
        PIOLA(1 , 2) = STRESS( 3 )
        PIOLA(2 , 1) = STRESS( 3 )
        PIOLA(3 , 3) = STRESS( 4 )
        PIOLA(1 , 3) = 0.D0
        PIOLA(2 , 3) = 0.D0
        PIOLA(3 , 1) = 0.D0
        PIOLA(3 , 2) = 0.D0
      END IF
      JACMAT(1 , 1) = 1.D0 + DUDX
      JACMAT(1 , 2) = DUDY
      JACMAT(1 , 3) = DUDZ
      JACMAT(2 , 1) = DVDX
      JACMAT(2 , 2) = 1.D0 + DVDY
      JACMAT(2 , 3) = DVDZ
      JACMAT(3 , 1) = DWDX
      JACMAT(3 , 2) = DWDY
      JACMAT(3 , 3) = 1.D0 + DWDZ
      DJAC=(1.D0+DUDX)*((1.D0+DVDY)*(1.D0+DWDZ)-DVDZ*DWDY)-
     .       DUDY*(DVDX*(1.D0+DWDZ)-DVDZ*DWDX)+
     .       DUDZ*(DVDX*DWDY-(1.D0+DVDY)*DWDX)
      DO K1 = 1 , 3
        DO K2 = 1 , K1
          SUM = 0.D0
          DO K3 = 1 , 3
            DO K4 = 1 , 3
              SUM = SUM + PIOLA(K3 , K4)*JACMAT(K1 , K3)*JACMAT(K2,K4)
            END DO
          END DO
          CAUCH(K1 , K2) = SUM/DJAC
        END DO
      END DO
      IF (ELEM_TYPE.GT.300) THEN
        CSTR( 1 ) = CAUCH(1 , 1)
        CSTR( 2 ) = CAUCH(2 , 2)
        CSTR( 3 ) = CAUCH(3 , 3)
        CSTR( 4 ) = CAUCH(2 , 1)
        CSTR( 5 ) = CAUCH(3 , 2)
        CSTR( 6 ) = CAUCH(3 , 1)
      ELSE
        CSTR( 1 ) = CAUCH(1 , 1)
        CSTR( 2 ) = CAUCH(2 , 2)
        CSTR( 3 ) = CAUCH(2 , 1)
        CSTR( 4 ) = CAUCH(3 , 3)
      END IF
C
      END
C
C =====================================================================
C ========================= G A U S S =================================
C =====================================================================
C
      SUBROUTINE GAUSS(NIP,W,GCOORD)
C
C =====================================================================
C I                                                                   I
C I      SUBPROGRAM GAUSS STORES THE COORDINATES XI AND ETA OF THE    I
C I      NUMERICAL INTEGRATION POINTS AND THEIR WEIGHTING FUNCTIONS   I
C I      FOR THE FOUR POINT AND THE NINE POINT INTEGRATION.           I
C I                                                                   I
C I          NIP       = NUMBER OF THE INTEGRATION POINTS             I
C I          W(I)      = WEIGTH FUNCTION                              I
C I          GCOORD(I) = COORDINATES OF THE GAUSSIAN POINTS           I
C I                      FROM THE NEGATIVE TO POSITIVE                I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      REAL*8 W(3),GCOORD(3)
      INTEGER NIP
C
      IF (NIP.EQ.1) THEN
        W( 1 ) = 2.D0
        GCOORD( 1 ) = 0.D0
      ELSE IF (NIP.EQ.2) THEN
        W( 1 ) = 1.D0
        W( 2 ) = 1.D0
        GCOORD( 1 ) = -0.577350269189626D0
        GCOORD( 2 ) = 0.577350269189626D0
      ELSE IF (NIP.EQ.3) THEN
        W( 1 ) = 5.D0/9.D0
        W( 2 ) = 8.D0/9.D0
        W( 3 ) = W( 1 )
        GCOORD( 1 ) = -0.774596669241483D0
        GCOORD( 2 ) = 0.D0
        GCOORD( 3 ) = 0.774596669241483D0
      END IF
C
      END
C
C =====================================================================
C ========================== I R O N S ================================
C =====================================================================
C
      SUBROUTINE IRONS(A1,B6,C8,B,C,NIP,INTCOD)
C
C =====================================================================
C I                                                                   I
C I      SUBPROGRAM IRONS STORES THE COORDINATES RETURNS THE COORD.   I
C I      AND THE WEIGHT FUNCTIONS FOR THE OPTIMUM INTEGRATION         I
C I      POINTS INTRODUCED BY BRUCE M. IRONS.                         I
C I                                                                   I
C I      FOR THE DESCRIPTION OF VARIABLES REFER TO THE REFERENCE      I
C I      PUBLICATION.                                                 I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER INTCOD,NIP
      REAL*8 A1,B,B6,C,C8
C
      IF (INTCOD.EQ.150) THEN
        NIP = 15
        A1 = 1.564444444444D0
        B6 = 0.3555555555556D0
        C8 = 0.5377777777778D0
        B = 1.D0
        C = 0.674199862D0
      ELSE IF(INTCOD.EQ.151) THEN
        NIP = 15
        A1 = 0.712137436D0
        B6 = 0.686227234D0
        C8 = 0.396312395D0
        B = 0.848418011D0
        C = 0.727662441D0
      ELSE IF(INTCOD.EQ.140) THEN
        NIP = 14
        A1 = 0.D0
        B6 = .886426593D0
        C8 = .335180055D0
        B = 0.795822426D0
        C = 0.758786911D0
      END IF
C
      END
C
C =====================================================================
C ======================= I S H A P E =================================
C =====================================================================
C
      SUBROUTINE ISHAPE
C
C =====================================================================
C I                                                                   I
C I   THIS PROGRAM EVALUATES THE SHAPE FUNCTIONS, THEIR DERIVATIVES   I
C I   WITH RESPECT TO THE NATURAL COORDINATES, AND THE WEIGHT         I
C I   FUNCTIONS AT EACH INTEGRATION POINT.                            I
C I                                                                   I
C I   ENTRY POINTS:                                                   I
C I       ISH2DG     (FOR 2D ELEMENTS)                                I
C I       ISH3DG     (FOR 3D ELEMENTS)                                I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEM_NODES,MAX_GAUSS_PTS
      PARAMETER (MAX_ELEM_NODES=20,MAX_GAUSS_PTS=27)
      INTEGER ELEM_TYPE,I,IETA,INTCOD,ISI,IXI,J,NIP,NIPETA,NIPSI,NIPXI
      INTEGER NNEL
      REAL*8 A,A1,AETA,ASI,AXI,B,B6,C,C8,ETA(3),F(MAX_ELEM_NODES)
      REAL*8 FETA(MAX_ELEM_NODES),FSI(MAX_ELEM_NODES),XI(3)
      REAL*8 FXI(MAX_ELEM_NODES),SI(3),W,WETA(3),WSI(3),WXI(3)
      COMMON/ISHAP2/W(MAX_GAUSS_PTS)
      COMMON/INPUT1/NIPXI,NIPETA,NIPSI,NIP,INTCOD
C
C         EVALUATE THE SHAPE FUNCTIONS OF THE 2D ISOPARAMETRIC ELEMENTS
C
C ======================== E N T R Y    I S H 2 D G ===================
C
      ENTRY ISH2DG(ELEM_TYPE,NNEL)
C
C       GET THE NATURAL COORDINATES OF THE INTEGRATION POINTS
C
      CALL GAUSS(NIPXI,WXI,XI)
      CALL GAUSS(NIPETA,WETA,ETA)
      NIP = NIPXI*NIPETA
C
C       NIP = TOTAL NUMBER OF THE INTEGRATION POINTS FOR THE ELEMENT
C       IETA = ROW NUMBER OF THE GAUSSIAN POINT FROM THE BOTTOM
C       IXI = COLUMN NUMBER OF THE GAUSSIAN POINT FROM LEFT
C
      DO IETA = 1 , NIPETA
        DO IXI = 1 , NIPXI
          J = (IETA - 1)*NIPXI + IXI
          W( J ) = WXI( IXI )*WETA( IETA )
          AXI = XI( IXI )
          AETA = ETA( IETA )
          CALL ISOP2D(AXI,AETA,F,FXI,FETA,ELEM_TYPE)
          CALL ISHEXT(NNEL,J,F,FXI,FETA,FSI)
        END DO
      END DO
      RETURN
C
C         EVALUATE THE SHAPE FUNCTIONS OF THE 3D ISOPARAMETRIC ELEMENTS
C
C ======================== E N T R Y    I S H 3 D G ===================
C
      ENTRY ISH3DG(ELEM_TYPE,NNEL)                     
      CALL GAUSS(NIPXI,WXI,XI)
      CALL GAUSS(NIPETA,WETA,ETA)
      CALL GAUSS(NIPSI,WSI,SI)
      NIP = NIPXI*NIPETA*NIPSI
      I = NIPXI*NIPETA
      DO ISI = 1 , NIPSI
        DO IETA = 1 , NIPETA
          DO IXI = 1 , NIPXI
            J = (ISI - 1)*I + (IETA - 1)*NIPXI + IXI
            W( J ) = WXI( IXI )*WETA( IETA )*WSI( ISI )
            AXI = XI( IXI )
            AETA = ETA( IETA )
            ASI = SI( ISI )
            CALL ISOP3D(AXI,AETA,ASI,F,FXI,FETA,FSI,ELEM_TYPE)
            CALL ISHEXT(NNEL,J,F,FXI,FETA,FSI)
          END DO
        END DO
      END DO
      RETURN
C
C ======================== E N T R Y    I S H 3 D I ===================
C
      ENTRY ISH3DI(ELEM_TYPE,NNEL)
      CALL IRONS(A1,B6,C8,B,C,NIP,INTCOD)
      AXI = B
      AETA = 0.D0
      ASI = 0.D0
      DO J = 1 , 6
        W( J ) = B6
        CALL ISOP3D(AXI,AETA,ASI,F,FXI,FETA,FSI,ELEM_TYPE)
        CALL ISHEXT(NNEL,J,F,FXI,FETA,FSI)
        A = AETA
        AETA = -AXI
        AXI  = -ASI
        ASI  = -A
      END DO
      AXI = C
      AETA = C
      ASI = C
      DO J = 7 , 14
        W( J ) = C8
        CALL ISOP3D(AXI,AETA,ASI,F,FXI,FETA,FSI,ELEM_TYPE)
        CALL ISHEXT(NNEL,J,F,FXI,FETA,FSI)
        AXI  = -AXI
        A = AETA
        AETA = -ASI
        IF (J.EQ.10) AETA = ASI
        ASI  =  A
      END DO
      IF (INTCOD.GE.150) THEN
        W( 15 ) = A1
        AXI = 0.D0
        AETA = 0.D0
        ASI = 0.D0
        CALL ISOP3D(AXI,AETA,ASI,F,FXI,FETA,FSI,ELEM_TYPE)
        CALL ISHEXT(NNEL,15,F,FXI,FETA,FSI)
      END IF
C
      END
C
C =====================================================================
C =========================== I S H E X T =============================
C =====================================================================
C
      SUBROUTINE ISHEXT(NNEL,J,F,FXI,FETA,FSI)
      IMPLICIT NONE
      INTEGER MAX_ELEM_NODES,MAX_GAUSS_PTS
      PARAMETER (MAX_ELEM_NODES=20,MAX_GAUSS_PTS=27)
      REAL*8 N,NXI,NETA,NSI,FETA(MAX_ELEM_NODES),FSI(MAX_ELEM_NODES)
      REAL*8 F(MAX_ELEM_NODES),FXI(MAX_ELEM_NODES)
      INTEGER J,NN,NNEL
      COMMON/ISHAP1/N(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NXI(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NETA(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NSI(MAX_ELEM_NODES,MAX_GAUSS_PTS)
C
      DO NN = 1 , NNEL
        N(NN , J) = F( NN )
        NXI(NN , J) = FXI( NN )
        NETA(NN , J) = FETA( NN )
        NSI(NN , J) = FSI( NN )
      END DO
C
      END
C
C =====================================================================
C =========================== E L M L I B =============================
C =====================================================================
C
      SUBROUTINE ELMLIB
C
C =====================================================================
C I                                                                   I
C I      SUBPROGRAM ELMLIB CALCULATES THE SHAPE FUNCTIONS AND THE     I
C I      PARTIAL DRIVATIVES OF THE SHAPE FUNCTIONS WRT THE LOCAL      I
C I      COORDINATES 'XI', 'ETA' AND 'SI'.                            I
C I                                                                   I
C I              N(I)     = SHAPE FUNCTIONS OF THE ELEMENT            I
C I              NXI(I) = PARTIAL DRIVATIVE OF 'N' WRT 'XI'           I
C I              NETA(I) =    PARTIAL DRIVATIVE OF 'N' WRT 'ETA'      I
C I              NSI(I) = PARTIAL DERIVATIVE OF 'N' WRT 'SI'          I
C I                                                                   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEM_NODES
      INTEGER ELEM_TYPE,PLN_STRN_4N,PLN_STRN_8N,BRICK_8N,BRICK_20N
      PARAMETER (PLN_STRN_4N=204,PLN_STRN_8N=208,BRICK_8N=308,
     .           BRICK_20N=320)    
      PARAMETER (MAX_ELEM_NODES=20)
      REAL*8 XI,ETA,SI,N(MAX_ELEM_NODES),NXI(MAX_ELEM_NODES),XI0,ETA0
      REAL*8 NETA(MAX_ELEM_NODES),NSI(MAX_ELEM_NODES),SI0
      REAL*4 ETAI,SII,XII
      INTEGER K,K1,K2
      COMMON/ELLIB1/XII(MAX_ELEM_NODES),ETAI(MAX_ELEM_NODES),
     .              SII(MAX_ELEM_NODES)
C
C ======================== E N T R Y    I S O P 2 D ===================
C
      ENTRY ISOP2D(XI,ETA,N,NXI,NETA,ELEM_TYPE)
C
C       DRIVATIVE OF SHAPE FUNCTIONS FOR 2D ISOPARAMETRIC ELEMENTS.
C
      NXI(1) = -0.25D0*(1.D0- ETA)
      NXI(2) =  0.25D0*(1.D0- ETA)
      NXI(3) =  0.25D0*(1.D0+ ETA)
      NXI(4) = -0.25D0*(1.D0+ ETA)
      NETA(1) = -0.25D0*(1.D0- XI)
      NETA(2) = -0.25D0*(1.D0+ XI)
      NETA(3) =  0.25D0*(1.D0+ XI)
      NETA(4) =  0.25D0*(1.D0- XI)
      IF(ELEM_TYPE.EQ.PLN_STRN_4N) GO TO 10
C
C        ADDITIONAL TERMS FOR THE EIGHT NODE ISOPARAMETRIC EL.
C
      NXI(5) = - XI*(1.D0- ETA)
      NXI(6) = 0.5D0*(1.D0- ETA**2)
      NXI(7) = - XI*(1.D0+ ETA)
      NXI(8) = -0.50D0*(1.D0- ETA**2)
      NETA(5) = -0.5D0*(1.D0- XI**2)
      NETA(6) = -(1.D0+ XI)* ETA
      NETA(7) = 0.5D0*(1.D0- XI**2)
      NETA(8) = -(1.D0- XI)* ETA
      NXI(1) = NXI(1)-0.5D0*(NXI(5)+NXI(8))
      NXI(2) = NXI(2)-0.5D0*(NXI(5)+NXI(6))
      NXI(3) = NXI(3)-0.5D0*(NXI(7)+NXI(6))
      NXI(4) = NXI(4)-0.5D0*(NXI(7)+NXI(8))
      NETA(1) = NETA(1)-0.5D0*(NETA(5)+NETA(8))
      NETA(2) = NETA(2)-0.5D0*(NETA(5)+NETA(6))
      NETA(3) = NETA(3)-0.5D0*(NETA(7)+NETA(6))
      NETA(4) = NETA(4)-0.5D0*(NETA(7)+NETA(8))
      IF(ELEM_TYPE.EQ.PLN_STRN_8N) GO TO 10
C
C       ADDITIONAL TERMS FOR THE NINE NODE LAGRANGIAN ELEMENT
C
      NXI(9) = -2.D0*XI*(1.D0- ETA**2)
      NXI(1) = NXI(1)+NXI(9)/4.D0
      NXI(2) = NXI(2)+NXI(9)/4.D0
      NXI(3) = NXI(3)+NXI(9)/4.D0
      NXI(4) = NXI(4)+NXI(9)/4.D0
      NXI(5) = NXI(5)-NXI(9)/2.D0
      NXI(6) = NXI(6)-NXI(9)/2.D0
      NXI(7) = NXI(7)-NXI(9)/2.D0
      NXI(8) = NXI(8)-NXI(9)/2.D0
      NETA(9) = -2.D0* ETA*(1.D0- XI**2)
      NETA(1) = NETA(1)+NETA(9)/4.D0
      NETA(2) = NETA(2)+NETA(9)/4.D0
      NETA(3) = NETA(3)+NETA(9)/4.D0
      NETA(4) = NETA(4)+NETA(9)/4.D0
      NETA(5) = NETA(5)-NETA(9)/2.D0
      NETA(6) = NETA(6)-NETA(9)/2.D0
      NETA(7) = NETA(7)-NETA(9)/2.D0
      NETA(8) = NETA(8)-NETA(9)/2.D0
C
C ======================== E N T R Y    N 2 D =========================
C
      ENTRY N2D(XI,ETA,N,ELEM_TYPE)
C
C       SHAPE FUNCTIONS  FOR 2D ISOPARAMETRIC ELEMENTS.
C
  10  N(1) = 0.25D0*(1.D0- XI)*(1.D0- ETA)
      N(2) = 0.25D0*(1.D0+ XI)*(1.D0- ETA)
      N(3) = 0.25D0*(1.D0+ XI)*(1.D0+ ETA)
      N(4) = 0.25D0*(1.D0- XI)*(1.D0+ ETA)
      IF(ELEM_TYPE.EQ.PLN_STRN_4N) RETURN
C
C        ADDITIONAL TERMS FOR THE EIGHT NODE ISOPARAMETRIC EL.
C
      N(5) = 0.5D0*(1.D0- XI**2)*(1.D0- ETA)
      N(6) = 0.5D0*(1.D0+ XI)*(1.D0- ETA**2)
      N(7) = 0.5D0*(1.D0- XI**2)*(1.D0+ ETA)
      N(8) = 0.5D0*(1.D0- XI)*(1.D0- ETA**2)
      N(1) = N(1)-0.5D0*(N(5)+N(8))
      N(2) = N(2)-0.5D0*(N(5)+N(6))
      N(3) = N(3)-0.5D0*(N(7)+N(6))
      N(4) = N(4)-0.5D0*(N(7)+N(8))
      IF(ELEM_TYPE.EQ.PLN_STRN_8N) RETURN
C
C       ADDITIONAL TERMS FOR THE NINE NODE LAGRANGIAN ELEMENT
C
      N(9) = (1.D0- ETA**2)*(1.D0- XI**2)
      N(1) = N(1)+N(9)/4.D0
      N(2) = N(2)+N(9)/4.D0
      N(3) = N(3)+N(9)/4.D0
      N(4) = N(4)+N(9)/4.D0
      N(5) = N(5)-N(9)/2.D0
      N(6) = N(6)-N(9)/2.D0
      N(7) = N(7)-N(9)/2.D0
      N(8) = N(8)-N(9)/2.D0
      RETURN
C
C     SHAPE FUNCTIONS AND THEIR DERIVATIVES FOR THE 3D ISOP. EL.
C
C ======================== E N T R Y    I S O P 3 D ===================
C
      ENTRY ISOP3D(XI,ETA,SI,N,NXI,NETA,NSI,ELEM_TYPE)
      IF(ELEM_TYPE.EQ.BRICK_8N) THEN                
        DO K = 1 , 8
          CALL ELMEXT(XI,ETA,SI,K,XI0,ETA0,SI0)
          N(K)   = .125D0*(1.D0 + XI0)*(1.D0+ETA0)*(1.D0+SI0)
          NXI(K) = .125D0*(1.D0 + ETA0)*(1.D0 + SI0)*XII( K )
          NETA(K)= .125D0*(1.D0 + XI0)*(1.D0 + SI0)*ETAI( K )
          NSI(K) = .125D0*(1.D0 + XI0)*(1.D0 + ETA0)*SII( K )
        END DO
      ELSE IF (ELEM_TYPE.EQ.BRICK_20N) THEN
C
C        HEXAHYDRON SOLID ELEMENT
C        SHAPE FUNCTIONS AND THIE DERIVATIVES FOR NODES 1-8.
C
        DO  K= 1 , 8
          CALL ELMEXT(XI,ETA,SI,K,XI0,ETA0,SI0)
          N(K)=.125D0*(1.D0+XI0)*(1.D0+ETA0)*(1.D0+SI0)*(XI0+ETA0+
     .         SI0-2.D0)
          NXI(K)=.125D0*(1.D0+ETA0)*(1.D0+SI0)*(2.D0*XI0+ETA0+SI0-1.D0)
     .           *XII(K)
          NETA(K)=.125D0*(1.D0+XI0)*(1.D0+SI0)*(XI0+2.D0*ETA0+SI0-1.D0)
     .            *ETAI(K)
          NSI(K)=.125D0*(1.D0+ETA0)*(1.D0+XI0)*(XI0+ETA0+2.D0*SI0-1.D0)
     .           *SII(K)
        END DO
        K1 = 9
        K2 = 10
C
C        SHAPE FUNCTIONS AND THEIR DERIVATIVES FOR NODES 13-16.
C
        DO K = 13 , 16
          CALL ELMEXT(XI,ETA,SI,K,XI0,ETA0,SI0)
          N(K)=.25D0*(1.D0+XI0)*(1.D0+ETA0)*(1.D0-SI**2)
          NXI(K)=.25D0*(1.D0+ETA0)*(1.D0-SI**2)*XII(K)
          NETA(K)=.25D0*(1.D0+XI0)*(1.D0-SI**2)*ETAI(K)
          NSI(K)=-0.5D0*(1.D0+ETA0)*(1.D0+XI0)*SI
C
C        SHAPE FUNCTIONS AND THEIR DERIVATIVES FOR NODES 9,11,17,19.
C
          CALL ELMEXT(XI,ETA,SI,K1,XI0,ETA0,SI0)
          N(K1)=.25D0*(1.D0-XI**2)*(1.D0+ETA0)*(1.D0+SI0)
          NXI(K1)=-0.5D0*(1.D0+ETA0)*(1.D0+SI0)*XI
          NETA(K1)=.25D0*(1.D0-XI**2)*(1.D0+SI0)*ETAI(K1)
          NSI(K1)=.25D0*(1.D0+ETA0)*(1.D0-XI**2)*SII(K1)
C
C        SHAPE FUNCTIONS AND THEIR DERIVATIVES FOR NODES 10,12,18,20.
C
          CALL ELMEXT(XI,ETA,SI,K2,XI0,ETA0,SI0)
          N(K2)=.25D0*(1.D0+XI0)*(1.D0-ETA**2)*(1.D0+SI0)
          NXI(K2)=.25D0*(1.D0-ETA**2)*(1.D0+SI0)*XII(K2)
          NETA(K2)=-0.5D0*(1.D0+XI0)*(1.D0+SI0)*ETA
          NSI(K2)=.25D0*(1.D0-ETA**2)*(1.D0+XI0)*SII(K2)
          IF (K1.EQ.11) THEN
            K1 = 17
            K2 = 18
          ELSE
            K1 = K1 + 2
            K2 = K2 + 2
          END IF
        END DO
      END IF
C
      END
C
C =====================================================================
C ======================== E L M E X T ================================
C =====================================================================
C
      SUBROUTINE ELMEXT(XI,ETA,SI,K,XI0,ETA0,SI0)
C
C =====================================================================
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEM_NODES,K
      PARAMETER (MAX_ELEM_NODES=20)
      REAL*8 XI,ETA,SI,XI0,ETA0,SI0
      REAL*4 ETAI,SII,XII
      COMMON/ELLIB1/XII(MAX_ELEM_NODES),ETAI(MAX_ELEM_NODES),
     .              SII(MAX_ELEM_NODES)
C
      XI0 = XI*XII( K )
      ETA0 =  ETA*ETAI( K )
      SI0 = SI*SII( K )
C
      END
C
C =====================================================================
C ========================== J A C O B I ==============================
C =====================================================================
C
      SUBROUTINE JACOBI
C
C =====================================================================
C I                                                                   I
C I        THIS PROGRAM CALCULATES THE JACOBIAN OF THE                I
C I        TRANSFORMATION BETWEEN THE LOCAL COORDINATES               I
C I        XI AND ETA AND THE GLOBAL COORDINATES X AND Y              I
C I        FOR INTEGRATION POINT 'INTGPN' OF ELEMENT NUMBER 'NREL'.   I
C I                                                                   I
C I   INTGPN  =    INTEGRATION POINT NUMBER                           I
C I   NREL    =    ELEMENT NUMBER                                     I
C I   DETJAC  =    DETERMINANT OF THE JACOBIAN                        I
C I   NX(I)   =    PARTIAL DERIVATIVE OF N(I) WITH RESPECT TO X       I
C I   NY(I)   =    PARTIAL DERIVATIVE OF N(I) WITH RESPECT TO Y       I
C I   NZ(I)   =    PARTIAL DERIVATIVE OF N(I) WITH RESPECT TO Z       I
C I   NNEL    =    NUMBER OF NODES(SHAPE FUNCTIONS) PER ELEMENT       I
C I                                                                   I
C I   NXI(I)  =    PARTIAL DERIVATIVE OF N(I) WITH RESPECT TO XI      I
C I   NETA(I) =    PARTIAL DERIVATIVE OF N(I) WITH RESPECT TO ETA     I
C I   NSI(I)  =    PARTIAL DERIVATIVE OF N(I) WITH RESPECT TO SI      I
C I   X(IK)   =    NODE COORDINATE  X,  IK=GLOBAL NODE NUMBER,        I
C I   Y(IK)   =    NODE COORDINATE  Y,  IK=GLOBAL NODE NUMBER,        I
C I   Z(IK)   =    NODE COORDINATE  Z,  IK=GLOBAL NODE NUMBER,        I
C I   XXI     =    PARTIAL DERIVATIVE OF X WITH RESPECT TO XI         I
C I   XETA    =    PARTIAL DERIVATIVE OF X WITH RESPECT TO ETA        I
C I   XSI     =    PARTIAL DERIVATIVE OF X WITH RESPECT TO SI         I
C I   YXI     =    PARTIAL DERIVATIVE OF Y WITH RESPECT TO XI         I
C I   YETA    =    PARTIAL DERIVATIVE OF Y WITH RESPECT TO ETA        I
C I   YSI     =    PARTIAL DERIVATIVE OF Y WITH RESPECT TO SI         I
C I   ZXI     =    PARTIAL DERIVATIVE OF Z WITH RESPECT TO XI         I
C I   ZETA    =    PARTIAL DERIVATIVE OF Z WITH RESPECT TO ETA        I
C I   ZSI     =    PARTIAL DERIVATIVE OF Z WITH RESPECT TO SI         I
C I                                                                   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MAX_GAUSS_PTS
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20,
     .           MAX_GAUSS_PTS=27)
      REAL*8 N,NXI,NETA,NSI,NX,NY,NZ,DETJAC,XETA,XSI,XXI,YETA,YSI
      REAL*8 YXI,ZETA,ZSI,ZXI
      REAL*4 X,Y,Z
      INTEGER INTGPN,K,K1,NNEL,NODE,NREL,NOP
      COMMON/ISHAP1/N(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NXI(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NETA(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NSI(MAX_ELEM_NODES,MAX_GAUSS_PTS)
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/INPUT3/X(MAX_NODES),Y(MAX_NODES),Z(MAX_NODES)
      COMMON/JACOB1/NX(MAX_ELEM_NODES),NY(MAX_ELEM_NODES),
     .              NZ(MAX_ELEM_NODES)
C
C ======================== E N T R Y    J A C B 2 D ===================
C
      ENTRY JACB2D(INTGPN,NREL,NNEL,DETJAC)
      XXI = 0.D0
      XETA = 0.D0
      YXI = 0.D0
      YETA = 0.D0
      DO K1 = 1 , NNEL
        NODE = NOP(K1 , NREL)
        XXI  = XXI + NXI(K1,INTGPN)*X( NODE )
        XETA = XETA + NETA(K1,INTGPN)*X( NODE )
        YXI  = YXI + NXI(K1,INTGPN)*Y( NODE )
        YETA = YETA + NETA(K1,INTGPN)*Y( NODE )
      END DO
      DETJAC = XXI*YETA - YXI*XETA
      DO K = 1 , NNEL
        NX(K) = (YETA*NXI(K,INTGPN) - YXI*NETA(K,INTGPN))/DETJAC
        NY(K) = (-XETA*NXI(K,INTGPN) + XXI*NETA(K,INTGPN))/DETJAC
      END DO
      RETURN
C
C ======================== E N T R Y    J A C B 3 D ===================
C
      ENTRY JACB3D(INTGPN,NREL,NNEL,DETJAC)
      XXI = 0.D0
      XETA = 0.D0
      XSI = 0.D0
      YXI = 0.D0
      YETA = 0.D0
      YSI = 0.D0
      ZXI = 0.D0
      ZETA = 0.D0
      ZSI = 0.D0
      DO K1=1,NNEL
        NODE = NOP(K1 , NREL)
        XXI  = XXI + NXI(K1,INTGPN)*X( NODE )
        XETA = XETA + NETA(K1,INTGPN)*X( NODE )
        XSI  = XSI + NSI(K1,INTGPN)*X( NODE )
        YXI  = YXI + NXI(K1,INTGPN)*Y( NODE )
        YETA = YETA + NETA(K1,INTGPN)*Y( NODE )
        YSI  = YSI + NSI(K1,INTGPN)*Y( NODE )
        ZXI  = ZXI + NXI(K1,INTGPN)*Z( NODE )
        ZETA = ZETA + NETA(K1,INTGPN)*Z( NODE )
        ZSI  = ZSI + NSI(K1,INTGPN)*Z( NODE )
      END DO
      DETJAC= XXI*(YETA*ZSI - ZETA*YSI) - YXI*(XETA*ZSI - ZETA*XSI) +
     .        ZXI*(XETA*YSI - YETA*XSI)
      DO K = 1 , NNEL
        NX(K) = ((YETA*ZSI - ZETA*YSI)*NXI(K,INTGPN)
     .          -(YXI*ZSI - ZXI*YSI)*NETA(K,INTGPN)
     .          +(YXI*ZETA - ZXI*YETA)*NSI(K,INTGPN))/DETJAC
        NY(K) = (-(XETA*ZSI - ZETA*XSI)*NXI(K,INTGPN)
     .          +(XXI*ZSI - ZXI*XSI)*NETA(K,INTGPN)
     .         -(XXI*ZETA - ZXI*XETA)*NSI(K,INTGPN))/DETJAC
        NZ(K) = ((XETA*YSI - YETA*XSI)*NXI(K,INTGPN)
     .         -(XXI*YSI - YXI*XSI)*NETA(K,INTGPN)
     .         +(XXI*YETA - YXI*XETA)*NSI(K,INTGPN))/DETJAC
      END DO
C
      END
C
C  ===================================================================
C  ======================== I N P L O T===============================
C  ===================================================================
C
      SUBROUTINE INPLOT(NELEM)
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MAX_ELEM_BOUND
      INTEGER MAX_LINES
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20,
     .           MAX_ELEM_BOUND=48,MAX_LINES=3000)
      INTEGER ELNUM,ELEM_TYPE,STRS_STRN_REL,ICODE,ISTART,ISTOP
      INTEGER ITHICK,J1,J2,K1,K2,LINES,MATNUM,NELEM,NLINES,NN,NODE
      INTEGER IE,IREP,IS,IVE,IVS,NOP,OUTPUT_INTR,GRAPHICS_INTR
      INTEGER I_OUT,I_IN,I_GRAPH,STR$COLLAPSE,LSTR1,LSTR2
      REAL*4 D,DMAG,FMAG,PSXMAX,PSXMIN,PSYMAX,PSYMIN,SX,SY,XL,XR,XRM
      REAL*4 XVL,XVR,YB,YRM,YT,YVB,YVT,ZF
      LOGICAL CONTOURS,RESTART,GRAPHICS_OUT
      CHARACTER*40 STR1,STR2
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/GRAPH1/IS(MAX_ELEM_BOUND),IE(MAX_ELEM_BOUND)
      COMMON/GRAPH2/IVS(MAX_LINES),IVE(MAX_LINES)
      COMMON/GRAPH3/XL,XR,YB,YT,ZF,D
      COMMON/GRAPH4/XVL,XVR,YVB,YVT,SX,SY
      COMMON/GRAPH5/FMAG,DMAG,CONTOURS,ITHICK,NLINES
      COMMON/IREP1/IREP(MAX_LINES)
      COMMON/POSTS/PSXMIN,PSXMAX,PSYMIN,PSYMAX
      COMMON/INPUTG/RESTART,OUTPUT_INTR,GRAPHICS_INTR,GRAPHICS_OUT
      COMMON/IN_IO/I_OUT,I_IN,I_GRAPH
C
C     CHECK COORDINATES OF WORLD VIEWPORT FOR VALIDITY AND INCREASE
C     TO ALLOW FOR COORDINATES OF DEFORMED GEOMETRY
C
      XRM=XR-XL
      YRM=YT-YB
      IF(XRM .LE. 1.0E-20) THEN
        XL=PSXMIN
        XR=PSXMAX
        XRM=XR-XL
      ENDIF
      IF(YRM .LE. 1.0E-20) THEN
        YB=PSYMIN
        YT=PSYMAX
        YRM=YT-YB
      ENDIF
      XL=XL-0.05*FMAG*ABS(XRM)
      XR=XR+0.05*FMAG*ABS(XRM)
      YB=YB-0.05*FMAG*ABS(YRM)
      YT=YT+0.05*FMAG*ABS(YRM)
C                      
C       DETERMINE THE FACTORS FOR THE WINDOW TO VIEWPORT MAPPING
C
      SX = (XVR - XVL)/(XR - XL)
      SY = (YVT - YVB)/(YT - YB)
C                            
C       TO PRESERVE PROPORTIONALITY USE THE SMALLEST OF THE SX AND SY
C       IN BOTH X AND Y DIRECTIONS
C
      IF (SX.GT.SY) THEN
        SX = SY
      ELSE
        SY = SX
      END IF
C
C       INITIALIZE THE PLOTTING DEVICE
C
      CALL IDENT
      CALL JOBPLT
C      CALL PLOT(1.,1.,-3)
      CALL VTHICK( ITHICK )
C
C       DETERMINE THE LINE AND THE NODE CONNECTIVITY OF THE MESH
C
      DO ELNUM = 1 , NELEM
        CALL ELINFO(ELNUM,ELEM_TYPE,NN,MATNUM,STRS_STRN_REL,
     .              ISTART,LINES)
        ISTOP = ISTART + LINES - 1
        DO K2 = ISTART , ISTOP
          J1 = NOP(IS( K2 ), ELNUM)
          J2 = NOP(IE( K2 ), ELNUM)
          ICODE = 0
          DO K1 = 1 , NLINES
            IF (J2.EQ.IVS(K1).OR.J2.EQ.IVE(K1)) THEN
              IF (J1.EQ.IVE(K1).OR.J1.EQ.IVS(K1)) THEN
                IREP( K1 ) = IREP( K1 ) + 1
                ICODE = 1
              END IF
            END IF
          END DO
          IF (ICODE.EQ.0) THEN
            NLINES = NLINES + 1
            IF(NLINES.GT.MAX_LINES) THEN
              WRITE(STR1,'(I39)')NLINES
              WRITE(STR2,'(I39)')MAX_LINES
              LSTR1=STR$COLLAPSE(STR1,STR1)
              LSTR2=STR$COLLAPSE(STR2,STR2)
              WRITE(I_OUT,*)'NUMBER OF LINES IN MESH ('//STR1(:LSTR1)//
     .            ') EXCEEDES ALLOWABLE (MAX_LINES='//STR2(:LSTR2)//').'
     .            //' REMAINING GRAPHICAL OUTPUT SKIPPED.'
              WRITE(*,*)'NUMBER OF LINES IN MESH ('//STR1(:LSTR1)//
     .            ') EXCEEDES ALLOWABLE (MAX_LINES='//STR2(:LSTR2)//').'
     .            //' REMAINING GRAPHICAL OUTPUT SKIPPED.'
              GRAPHICS_OUT=.FALSE.
              RETURN
            ENDIF
            IREP( NLINES ) = IREP( NLINES ) + 1
            IVS( NLINES ) = J1
            IVE( NLINES ) = J2
          END IF
        END DO
        DO K1 = 1 , NN
          NODE = NOP(K1 , ELNUM)
          IREP( NODE ) = IREP( NODE ) + 32
        END DO
      END DO
C
      END                              
C
C  ===================================================================
C  ======================== P L O T E R ==============================
C  ===================================================================
C
      SUBROUTINE PLOTER(NNODES,NELEM,NNDF,IDIM,NINODE,LINEAR)
C
C  ===================================================================
C  I                                                                 I
C  I    SUBROUTINE PLOTER IS DESIGNED TO PLOT THE MESH BEFORE AND    I
C  I    AFTER THE ANALYSIS HAS BEEN PERFORMED, FOR BOTH THE EIGHT    I
C  I    AND THE FOUR NODE ELEMENTS                                   I
C  I                                                                 I
C  I    DMAG  =  MAGNIFICATION FACTOR TO BE USED FOR DISPLACEMENTS   I
C  I    FMAG  =  MAGNIFICATION FACTOR TO BE USED FOR GEOMETRY        I
C  I    NE    =  NUMBER OF ELEMENTS IN THE MESH                      I
C  I    NN    =  NUMBER OF NODES FOR EACH ELEMENT                    I
C  I    X(I)  =  X-COORDINATE OF THE NODE                            I
C  I    Y(I)  =  Y-COORDINATE OF THE NODE                            I
C  I    Z(I)  =  Z-COORDINATE OF THE NODE                            I
C  I                                                                 I
C  ===================================================================
C
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MAX_ELEM_BOUND
      INTEGER MAX_LINES,NFRAME,MNNDF,MAX_NODES_DOF,MAX_CONT_SEGS
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20,
     .           MAX_ELEM_BOUND=48,MAX_LINES=3000,MAX_CONT_SEGS=100)
      PARAMETER (NFRAME=14,MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      REAL*4 X,Y,Z,DMAG,FMAG,R,RISE,RUN,SLOPE,V1,V2,VCONT,VCONT1
      REAL*4 VH,VINTR,VL,VMAX,VMAX1,VMIN,VMIN1,X1,X2,XE,XS,Y1,Y2,YE
      REAL*4 XC(MAX_CONT_SEGS),XXE(MAX_CONT_SEGS),XXS(MAX_CONT_SEGS)
      REAL*4 YC(MAX_CONT_SEGS),YYE(MAX_CONT_SEGS),YYS(MAX_CONT_SEGS)
      REAL*4 YS,ZE,ZS,VLEGND(10)
      INTEGER ELNUM,STR$LENGTH,ELEM_TYPE,ICODE,ICOOR
      INTEGER ID1,ID2,IDENT1,IDENT2,IDIM,IFRAME,IFTL,INCREM,INFRAME
      INTEGER INTGPN,IPTYPE,IR,IR1,IRLINE,ISTART,ISTOP
      INTEGER ITHICK,IVEND,IVSTR,K1,K2,K3,LDEV,LDEV1,LDEV2,LDEV3,LDEV4
      INTEGER LDEVST,LE,LE1,LE2,LINES,LNUM,LNUM1,LS,LS2,LSN,MATNUM
      INTEGER NCLS,NCONT,NELEM,NINODE,NIT,NLINES,NIP
      INTEGER NN,NNDF,NNODES,NODE,NODE1,NODE2,IE,IREP,IS,IVE,IVS,IYIEL
      INTEGER LEGEND(10),LNEND(MAX_LINES),LNSTR(MAX_LINES),NOP
      INTEGER NIPXI,NIPETA,NIPSI,INTCOD,OUTPUT_INTR,GRAPHICS_INTR      
      INTEGER I_OUT,I_IN,I_GRAPH,STR$COLLAPSE,LSTR1,LSTR2
      REAL*8 UTOTAL,XIP,YIP,ZIP,UXIP,UYIP,UZIP,THICK
C
C     NOTE:  ARRAY "VALUE" HAS TO BE DIMENSIONED 'NFRAME' TIMES THE
C            MAXIMUM NUMBER OF NODES.
C
      REAL*4 VALUE(NFRAME*MAX_NODES)
      LOGICAL LOGIC,LINEAR,CONTOURS,RESTART,GRAPHICS_OUT
      CHARACTER*80 AXFRAME_TITLE(NFRAME)*40,LEGSTR(5)
      CHARACTER*40 FRAME_TITLE(NFRAME),STR1,STR2
      COMMON/INPUT1/NIPXI,NIPETA,NIPSI,NIP,INTCOD
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/GRAPH1/IS(MAX_ELEM_BOUND),IE(MAX_ELEM_BOUND)
      COMMON/GRAPH2/IVS(MAX_LINES),IVE(MAX_LINES)
      COMMON/IREP1/IREP(MAX_LINES)
      COMMON/INPUT3/X(MAX_NODES),Y(MAX_NODES),Z(MAX_NODES)
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/GRAPH5/FMAG,DMAG,CONTOURS,ITHICK,NLINES
      COMMON/PLAST1/IYIEL(MAX_ELEMENTS)
      COMMON/CONTR1/INCREM,NIT
      COMMON/INPUT9/THICK,STRS_STRN_REL
      COMMON/INPUTG/RESTART,OUTPUT_INTR,GRAPHICS_INTR,GRAPHICS_OUT
      COMMON/IN_IO/I_OUT,I_IN,I_GRAPH
C
      DATA FRAME_TITLE /'(STRESS: X)','(STRESS: Y)','(STRESS: Z)',
     .                  '(STRESS: XY)','(STRAIN: X)','(STRAIN: Y)',
     .                  '(STRAIN: Z)','(STRAIN: XY)',
     .                  '(CAUCHY STRESS: X)','(CAUCHY STRESS: Y)',
     .                  '(CAUCHY STRESS: Z)','(CAUCHY STRESS: XY)',
     .                  '(VOLUMETRIC STRAINS)','(WORK)' /
      DATA AXFRAME_TITLE /'(STRESS: R)','(STRESS: Z)','(STRESS: THETA)',
     .                  '(STRESS: RZ)','(STRAIN: R)','(STRAIN: Z)',
     .                  '(STRAIN: THETA)','(STRAIN: RZ)',
     .                  '(CAUCHY STRESS: R)','(CAUCHY STRESS: Z)',
     .                  '(CAUCHY STRESS: THETA)','(CAUCHY STRESS: RZ)',
     .                  '(VOLUMETRIC STRAINS)','(WORK)' /
C                             
C       IR = MAXIMUM NUMBER OF REPETITIONS FOR SURFACE LINES
C
      IR = IDIM - 1  
C
C ----- IDENTIFY EACH NODE BY A DIAMOND
C
      DO NODE = 1 , NNODES
        ID1 = NNDF*(NODE - 1)
        XS = X( NODE )*FMAG + UTOTAL( ID1 + 1 )*DMAG
        YS = Y( NODE )*FMAG + UTOTAL( ID1 + 2 )*DMAG
        CALL VIEW2(XS,YS,0.10,5)
      END DO
      DO ELNUM = 1 , NELEM
        CALL ELINFO(ELNUM,ELEM_TYPE,NN,MATNUM,STRS_STRN_REL,
     .              ISTART,LINES)
        DO INTGPN = 1 , NIP
          LOGIC = BTEST(IYIEL( ELNUM ) , INTGPN)
          IF (LOGIC) THEN
            CALL COORD1(ELNUM,NN,INTGPN,XIP,YIP,ZIP)
            CALL COORD2(ELNUM,NN,INTGPN,NNDF,UXIP,UYIP,UZIP)
            XS = XIP*FMAG + UXIP*DMAG
            YS = YIP*FMAG + UYIP*DMAG
            CALL VIEW2(XS,YS,0.10,11)
          END IF
        END DO
      END DO
      DO K1 = 1 , NLINES
        NODE1 = IVS( K1 )
        NODE2 = IVE( K1 )
        ID1 = NNDF*(NODE1 - 1)
        ID2 = NNDF*(NODE2 - 1)
        XS = X( NODE1 )*FMAG + UTOTAL( ID1 + 1 )*DMAG
        YS = Y( NODE1 )*FMAG + UTOTAL( ID1 + 2 )*DMAG
        XE = X( NODE2 )*FMAG + UTOTAL( ID2 + 1 )*DMAG
        YE = Y( NODE2 )*FMAG + UTOTAL( ID2 + 2 )*DMAG
        IF (IDIM.EQ.3) THEN
          ZS = Z( NODE1 )*FMAG + UTOTAL( ID1 + 3 )*DMAG
          ZE = Z( NODE2 )*FMAG + UTOTAL( ID2 + 3 )*DMAG
        ELSE
          ZS = 0.
          ZE = 0.
        END IF         
        CALL CLIP(XS,YS,ZS,1.,XE,YE,ZE,1.)
      END DO
      CALL EOPLOT(0)
      IF (.NOT.CONTOURS.OR.INCREM.EQ.0) RETURN
      CALL EXTRAP(NELEM,NNODES,NNDF,LINEAR,VALUE,IPTYPE)
      IF(IPTYPE.EQ.1)INFRAME=13
      IF(IPTYPE.EQ.2)INFRAME=14
      DO IFRAME=1,INFRAME
        CALL NNUM0
C
C        DRAW THE BOUNDARY OF THE MESH
C
        DO 50 K1 = 1 , NLINES                   
          IRLINE = IAND(IREP(K1),31)
          IF (IRLINE.GT.IR) GO TO 50
          NODE1 = IVS( K1 )
          NODE2 = IVE( K1 )
          ID1 = NNDF*(NODE1 - 1)
          ID2 = NNDF*(NODE2 - 1)
          XS = X( NODE1 )*FMAG + UTOTAL( ID1 + 1 )*DMAG
          YS = Y( NODE1 )*FMAG + UTOTAL( ID1 + 2 )*DMAG
          XE = X( NODE2 )*FMAG + UTOTAL( ID2 + 1 )*DMAG
          YE = Y( NODE2 )*FMAG + UTOTAL( ID2 + 2 )*DMAG
          IF (IDIM.EQ.3) THEN
            ZS=Z(NODE1)*FMAG+UTOTAL(ID1+3)*DMAG
            ZE=Z(NODE2)*FMAG+UTOTAL(ID2+3)*DMAG
          ELSE
            ZS=0.
            ZE=0.
          END IF
          CALL CLIP(XS,YS,ZS,1.,XE,YE,ZE,1.)
 50     CONTINUE
C
C        DRAW THE CURVED BOUNDARY OF THE DIE IF THERE IS ONE.
C
        IF (NINODE.GT.0) CALL CURVE
C
C        DRAW THE CONTOUR LINES
C
        IVSTR=(IFRAME-1)*NNODES+1
        IVEND=IFRAME*NNODES
        VMIN= VALUE(IVSTR)
        VMAX= VALUE(IVSTR)
        DO K1=IVSTR,IVEND
          VMIN=AMIN1(VMIN,VALUE(K1))
          VMAX=AMAX1(VMAX,VALUE(K1))
        END DO
C
C       ADJUST THE VMAX AND VMIN SO THAT CONTOURS CLOSE TO THESE VALUES
C       ARE ALSO GENERATED.
C
        VMIN1=VMIN
        VMAX1=VMAX
        VMAX=VMAX-ABS(VMAX)/50.
        VMIN=VMIN+ABS(VMIN)/50.
        VINTR=(VMAX-VMIN)/9.
        VCONT=VMIN
        K3=0
        DO NCONT=0,9
          K3=K3+1
          VLEGND(K3)=VCONT
          LEGEND(K3)=NCONT
          NCLS=0
          DO ELNUM=1,NELEM
            CALL ELINFO(ELNUM,ELEM_TYPE,NN,MATNUM,STRS_STRN_REL,ISTART,
     .                  LINES)
            ISTOP=ISTART+LINES-1
            ICODE=0
            DO K1=ISTART,ISTOP
              NODE1=NOP(IS(K1),ELNUM)
              NODE2=NOP(IE(K1),ELNUM)
              ID1=NODE1+IVSTR-1
              ID2=NODE2+IVSTR-1
              V1=VALUE(ID1)
              V2=VALUE(ID2)
              VH=AMAX1(V1,V2)
              VL=AMIN1(V1,V2)
              IF (VCONT.EQ.VL.OR.VCONT.EQ.VH) THEN
                VCONT1=VCONT+VCONT/10000.
              ELSE
                VCONT1=VCONT
              END IF
              IF (VCONT.GT.VL.AND.VCONT.LT.VH) THEN
                R=(VCONT1-V1)/(V2-V1)
                IDENT1=NNDF*(NODE1-1)
                IDENT2=NNDF*(NODE2-1)
                X1=X(NODE1)*FMAG+UTOTAL(IDENT1+1)*DMAG
                X2=X(NODE2)*FMAG+UTOTAL(IDENT2+1)*DMAG
                Y1=Y(NODE1)*FMAG+UTOTAL(IDENT1+2)*DMAG
                Y2=Y(NODE2)*FMAG+UTOTAL(IDENT2+2)*DMAG
                IF (ICODE.EQ.0) THEN
                  XS=X1+R*(X2-X1)
                  YS=Y1+R*(Y2-Y1)
                  CALL GETLIN(NODE1,NODE2,NLINES,LNUM1)
                  ICODE=1
                ELSE
                  NCLS=NCLS+1
                  IF(NCLS.GT.MAX_CONT_SEGS) THEN
                    WRITE(STR1,'(I39)')NCLS
                    WRITE(STR2,'(I39)')MAX_CONT_SEGS
                    LSTR1=STR$COLLAPSE(STR1,STR1)
                    LSTR2=STR$COLLAPSE(STR2,STR2)
                    WRITE(I_OUT,*)'NUMBER OF CONTOUR SEGMENTS ('//
     .               STR1(:LSTR1)//') EXCEEDS ALLOWABLE (MAX_CONT_SEGS='
     .               //STR2(:LSTR2)//'). REMAINGING SEGMENTS IGNORED'
                    WRITE(*,*)'NUMBER OF CONTOUR SEGMENTS ('//
     .               STR1(:LSTR1)//') EXCEEDS ALLOWABLE (MAX_CONT_SEGS='
     .               //STR2(:LSTR2)//'). REMAINGING SEGMENTS IGNORED'
                    NCLS=MAX_CONT_SEGS
                    GOTO 60
                  ENDIF
                  XXS(NCLS)=XS
                  YYS(NCLS)=YS
                  XXE(NCLS)=X1+R*(X2-X1)
                  YYE(NCLS)=Y1+R*(Y2-Y1)
                  CALL GETLIN(NODE1,NODE2,NLINES,LNUM)
                  LNEND(NCLS)=LNUM
                  LNSTR(NCLS)=LNUM1
                  ICODE=0
                END IF
              END IF
60            CONTINUE              
            END DO
          END DO
C
C        SEARCH FOR THE CONTOUR LINES WHICH CROSS THE BOUNDARIES
C
          DO 120 K1 = 1 , NCLS
            IR1 = 0
            IF (LNSTR( K1 ).EQ.0) GO TO 120
            IF (IAND(IREP(LNSTR( K1 )),31).EQ.1) THEN
              XC( 1 ) = XXS( K1 )
              YC( 1 ) = YYS( K1 )
              XC( 2 ) = XXE( K1 )
              YC( 2 ) = YYE( K1 )
              IR1 = 1
              LE = LNEND( K1 )
              LSN = LNSTR( K1 )
              LNSTR( K1 ) = 0
            ELSE IF(IAND(IREP(LNEND( K1 )),31).EQ.1) THEN
              XC( 2 ) = XXS( K1 )
              YC( 2 ) = YYS( K1 )
              XC( 1 ) = XXE( K1 )
              YC( 1 ) = YYE( K1 )
              LE = LNSTR( K1 )
              LSN = LNEND( K1 )
              LNSTR( K1 ) = 0
              IR1 = 1
            END IF
            IF (IR1.EQ.1) THEN
              ICOOR = 2
 100          CONTINUE
              DO 110 K2 = 1 , NCLS
                LS2 = LNSTR( K2 )
                IF (K2.EQ.K1.OR.LS2.EQ.0) GO TO 110
                LE2 = LNEND( K2 )
                IF (LS2.EQ.LE) THEN
                  ICOOR = ICOOR + 1
                  XC( ICOOR ) = XXE( K2 )
                  YC( ICOOR ) = YYE( K2 )
                  LE = LNEND( K2 )
                  LNSTR( K2 ) = 0
                  IF (IAND(IREP( LE ),31).EQ.1) THEN
                    CALL DLINE(XC,YC,ICOOR-1)
                    RISE=YC(ICOOR)-YC(1)
                    RUN=XC(ICOOR)-XC(1)
                    IF(ABS(RUN).LE.1.0E-20.AND.ABS(RISE).LE.1.0E-20)THEN
                      SLOPE=0.0
                    ELSE
                      SLOPE=ATAN2(RISE,RUN)
                    ENDIF
                    CALL NUMLIN(XC(1),YC(1),NCONT,SLOPE)
                    CALL NUMLIN(XC(ICOOR),YC(ICOOR),NCONT,SLOPE)
                    GO TO 120
                  END IF
                  GO TO 100
                ELSE IF(LE2.EQ.LE) THEN
                  ICOOR = ICOOR + 1
                  XC( ICOOR ) = XXS( K2 )
                  YC( ICOOR ) = YYS( K2 )
                  LE = LNSTR( K2 )
                  LNSTR( K2 ) = 0
                  IF (IAND(IREP( LE ),31).EQ.1) THEN
                    CALL DLINE(XC,YC,ICOOR-1)
                    RISE=YC(ICOOR)-YC(1)
                    RUN=XC(ICOOR)-XC(1)
                    IF(ABS(RUN).LE.1.0E-20.AND.ABS(RISE).LE.1.0E-20)THEN
                      SLOPE=0.0
                    ELSE
                      SLOPE=ATAN2(RISE,RUN)
                    ENDIF
                    CALL NUMLIN(XC(1),YC(1),NCONT,SLOPE)
                    CALL NUMLIN(XC(ICOOR),YC(ICOOR),NCONT,SLOPE)
                    GO TO 120
                  END IF
                  GO TO 100
                END IF
 110          CONTINUE
            END IF
 120      CONTINUE
C
C        SEARCH FOR THE CONTOUR LINES WHICH FORM A CLOSED LOOP INSIDE
C        THE MESH REGION.
C
          DO 150 K1 = 1 , NCLS
            LS = LNSTR( K1 )
            LE = LS
            IF (LS.NE.0) THEN
              XC( 1 ) = XXS( K1 )
              YC( 1 ) = YYS( K1 )
              XC( 2 ) = XXE( K1 )
              YC( 2 ) = YYE( K1 )
              LE1 = LNEND( K1 )
              LNSTR( K1 ) = 0
              ICOOR = 2
 130          CONTINUE
              DO 140 K2 = 1 , NCLS
                LS2 = LNSTR( K2 )
                IF (K2.EQ.K1.OR.LS2.EQ.0) GO TO 140
                LE2 = LNEND( K2 )
                IF (LS2.EQ.LE1) THEN
                  ICOOR = ICOOR + 1
                  XC( ICOOR ) = XXE( K2 )
                  YC( ICOOR ) = YYE( K2 )
                  LE1 = LNEND( K2 )
                  LNSTR( K2 ) = 0
                  IF (LE1.EQ.LE.AND.ICOOR.GT.3) THEN
                    CALL DLINE(XC,YC,ICOOR-1)
                    CALL NUMLIN(XC(ICOOR),YC(ICOOR),NCONT,0.0)
                    GO TO 150
                  END IF
                  GO TO 130
                ELSE IF(LE2.EQ.LE1) THEN
                  ICOOR = ICOOR + 1
                  XC( ICOOR ) = XXS( K2 )
                  YC( ICOOR ) = YYS( K2 )
                  LE1 = LNSTR( K2 )
                  LNSTR( K2 ) = 0
                  IF (LE1.EQ.LE.AND.ICOOR.GT.3) THEN
                    CALL DLINE(XC,YC,ICOOR-1)
                    CALL NUMLIN(XC(ICOOR),YC(ICOOR),NCONT,0.0)
                    GO TO 150
                  END IF
                  GO TO 130
                END IF
 140          CONTINUE
            END IF
 150      CONTINUE
          VCONT = VCONT + VINTR
        END DO
        CALL PLTNUM
        IF(STRS_STRN_REL.EQ.AXISYMMETRIC) THEN
          IFTL=STR$LENGTH(AXFRAME_TITLE(IFRAME))
          WRITE(LEGSTR(1) , 1002)IFRAME,AXFRAME_TITLE(IFRAME)(:IFTL),
     .                         INCREM
        ELSE
          IFTL=STR$LENGTH(FRAME_TITLE(IFRAME))
          WRITE(LEGSTR(1) , 1002)IFRAME,FRAME_TITLE(IFRAME)(:IFTL),
     .                         INCREM
        ENDIF
        WRITE(LEGSTR(2) , 1003)VMIN1,VMAX1
        WRITE(LEGSTR(3) , 1001)(LEGEND(K1),VLEGND(K1),K1 = 1 , 4)
        WRITE(LEGSTR(4) , 1001)(LEGEND(K1),VLEGND(K1),K1 = 5 , 8)
        WRITE(LEGSTR(5) , 1001)(LEGEND(K1),VLEGND(K1),K1 = 9 , 10)
        CALL LEGEND_OUT(LEGSTR)
        CALL EOPLOT(0)
      END DO
 1001 FORMAT(1X,I1,' = ',E11.4,6X,I1,' = ',E11.4,6X,I1,' = ',E11.4,
     .       6X,I1,' = ',E11.4)
 1002 FORMAT(1X,'LEGEND FOR FRAME NUMBER ',I3,' ',A,' AT LOAD STEP ',I3)
 1003 FORMAT(1X,'MINIMUM = ',E11.4,6X,'MAXIMUM = ',E11.4)
C 
      END
C
C ======================================================================
C ========================== G E T L I N ===============================
C ======================================================================
C
      SUBROUTINE GETLIN(NODE1,NODE2,NLINES,LNUM)
      IMPLICIT NONE
      INTEGER MAX_LINES,K1,LNUM,NLINES,NODE1,NODE2,IVE,IVS
      PARAMETER (MAX_LINES=3000)
      COMMON/GRAPH2/IVS(MAX_LINES),IVE(MAX_LINES)
C
      DO K1 = 1 , NLINES
        IF (NODE1.EQ.IVS( K1 ).OR.NODE1.EQ.IVE( K1 )) THEN
          IF (NODE2.EQ.IVE( K1 ).OR.NODE2.EQ.IVS( K1 )) THEN
            LNUM = K1
            RETURN
          END IF
        END IF
      END DO
C
      END
C
C ======================================================================
C ========================== D L I N E =================================
C ======================================================================
C
      SUBROUTINE DLINE(XC,YC,NLIN)
      IMPLICIT NONE
      INTEGER K1,NLIN
      REAL*4 XC(*),YC(*),XE,XS,YE,YS
C
      XS = XC( 1 )
      YS = YC( 1 )
      DO K1 = 2 , NLIN+1
        XE = XC( K1 )
        YE = YC( K1 )
        CALL CLIP(XS,YS,0.,1.,XE,YE,0.,1.)
        XS = XE
        YS = YE
      END DO
C
      END
C
C ======================================================================
C ========================= N U M L I N ================================
C ======================================================================
C
      SUBROUTINE NUMLIN(XE,YE,NCONT,THETA)
      IMPLICIT NONE
      INTEGER MAX_CONT_LINES
      PARAMETER (MAX_CONT_LINES=100)
      REAL*4 ANGLE,FPN,HEIGHT,TDIF,THETA,TOL,X1,X2,XDIF
      REAL*4 XE,Y1,Y2,YDIF,YE,XVL,XVR,YVB,YVT,SX,SY
      REAL*4 XNUM(MAX_CONT_LINES),YNUM(MAX_CONT_LINES),
     .       SLOPE(MAX_CONT_LINES)
      INTEGER NUMVAL(MAX_CONT_LINES),ICODE,NNUM,K1,K2,NCONT
      INTEGER I_OUT,I_IN,I_GRAPH,STR$COLLAPSE,LSTR1,LSTR2
      CHARACTER*40 STR1,STR2
      COMMON/GRAPH4/XVL,XVR,YVB,YVT,SX,SY
      COMMON/IN_IO/I_OUT,I_IN,I_GRAPH
C
      SAVE HEIGHT,NNUM,XNUM,YNUM,NUMVAL,SLOPE
C
      HEIGHT = 0.1
      NNUM = NNUM + 1
      IF(NNUM.GT.MAX_CONT_LINES) THEN
        WRITE(STR1,'(I39)')NNUM
        WRITE(STR2,'(I39)')MAX_CONT_LINES
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'NUMBER OF CONTOUR LINES ('//STR1(:LSTR1)//') '//
     .       'EXCEEDS ALLOWABLE (MAX_CONT_LINES='//STR2(:LSTR2)//'). '//
     .       'REMAINING CONTOUR LINES NOT DRAWN'
        WRITE(*,*)'NUMBER OF CONTOUR LINES ('//STR1(:LSTR1)//') '//
     .       'EXCEEDS ALLOWABLE (MAX_CONT_LINES='//STR2(:LSTR2)//'). '//
     .       'REMAINING CONTOUR LINES NOT DRAWN'
        NNUM=MAX_CONT_LINES
        RETURN
      ENDIF
      SLOPE(NNUM) = THETA
      XNUM( NNUM ) = XE - HEIGHT * COS(THETA)
      YNUM( NNUM ) = YE + HEIGHT * SIN(THETA)
      NUMVAL( NNUM ) = NCONT
      RETURN        
C
C ======================== E N T R Y    P L T N U M ===================
C
      ENTRY PLTNUM                                 
      ANGLE = 90.
      TOL = 1.6*HEIGHT/SX
      FPN = FLOAT(NUMVAL( 1 ))
      CALL VIEW3(XNUM( 1 ),YNUM( 1 ),HEIGHT,FPN,SLOPE(1),-1)
      DO K1 = 2 , NNUM
        ICODE = 0
        X1 = XNUM( K1 )
        Y1 = YNUM( K1 )
        DO K2 = 1 , K1 - 1
          IF (NUMVAL(K2).GE.0) THEN
            X2 = XNUM( K2 )
            Y2 = YNUM( K2 )
            XDIF = X1 - X2
            YDIF = Y1 - Y2
            TDIF = SQRT(XDIF**2 + YDIF**2)
            IF (TDIF.LT.TOL) ICODE = 1
          END IF
        END DO
        IF (ICODE.EQ.0) THEN
          FPN = FLOAT(NUMVAL( K1 ))
          CALL VIEW3(X1,Y1,HEIGHT,FPN,SLOPE(K1),-1)        
        ELSE
          NUMVAL( K1 ) = -1
        END IF
      END DO
      RETURN
C
C ======================== E N T R Y    N N U M 0 =====================
C
      ENTRY NNUM0   
      NNUM = 0
C      
      END
C
C ======================================================================
C =========================== C L I P ==================================
C ======================================================================
C
      SUBROUTINE CLIP(X1,Y1,Z1,W1,X2,Y2,Z2,W2)
      IMPLICIT NONE
      INTEGER ZOR,ZAND,ICK,IZ,IZ1,IZ2,IZAND,IZOR,IZONE
      REAL*4 CNST,D,W1,W2,WW,X1,X2,XL,XR,XX,Y1,Y2,YB,YT,YY,Z1,Z2,ZF
      COMMON/GRAPH3/XL,XR,YB,YT,ZF,D
      EQUIVALENCE (IZOR,ZOR),(IZAND,ZAND)
C
      IF (W1.EQ.1..AND.W2.EQ.1.) GO TO 90
      IF (Z1.GT.ZF.AND.Z2.GT.ZF) RETURN
      IF(Z1.LE.ZF.AND.Z2.LE.ZF) GO TO 90
      CNST = (ZF - Z1)/(Z1 - Z2)
      XX = X1 + CNST*(X1 - X2)
      YY = Y1 + CNST*(Y1 - Y2)
      WW = (1. - ZF/D)
      IF (Z1.GT.ZF) THEN
        X1 = XX
        Y1 = YY
        W1 = WW
      ELSE IF(Z2.GT.ZF) THEN
        X2 = XX
        Y2 = YY
        W2 = WW
      END IF
  90  X1 = X1/W1
      Y1 = Y1/W1
      X2 = X2/W2
      Y2 = Y2/W2
      IZ1 = IZONE(X1 , Y1)
      IZ2 = IZONE(X2 , Y2)
 100  ZOR = IOR(IZ1 , IZ2)
      IF (IZOR.NE.0) GO TO 400
 200  CALL VIEW1(X1,Y1,3)
      CALL VIEW1(X2,Y2,2)
      RETURN
 400  ZAND = IAND(IZ1 , IZ2)
      IF (IZAND.NE.0) RETURN
      ZAND = IAND(ZOR ,  1)
      IF (IZAND.EQ.0) GO TO 900
      XX = XL
      ICK = 1
 500  YY = Y1 + (Y2 - Y1)/(X2 - X1)*(XX - X1)
 600  IZ = IZONE(XX , YY)
      ZAND = IAND(IZ1 , ICK)
      IF (IZAND.NE.0) GO TO 800
 700  X2 = XX
      Y2 = YY
      IZ2 = IZ
      GO TO 100
 800  X1 = XX
      Y1 = YY
      IZ1 = IZ
      GO TO 100
 900  ZAND = IAND(ZOR , 2)
      IF (IZAND.EQ.0) GO TO 1000
      XX = XR
      ICK = 2
      GO TO 500
 1000 ZAND = IAND(ZOR , 4)
      IF (IZAND.EQ.0) GO TO 1200
      YY = YB
      ICK = 4
 1100 XX = X1 + (X2 - X1)/(Y2 - Y1)*(YY - Y1)
      GO TO 600
 1200 YY = YT
      ICK = 8
      GO TO 1100
C
      END
C
C ======================================================================
C =========================== I Z O N E ================================
C ======================================================================
C
      INTEGER FUNCTION IZONE(X,Y)
      IMPLICIT NONE
      REAL*4 D,X,XL,XR,Y,YB,YT,ZF
      COMMON/GRAPH3/XL,XR,YB,YT,ZF,D
C
      IZONE = 0
      IF (X.LT.XL) IZONE = 1
      IF (X.GT.XR) IZONE = 2
      IF (Y.LT.YB) IZONE = IZONE + 4
      IF (Y.GT.YT) IZONE = IZONE + 8
C
      END
C
C ======================================================================
C =========================== V I E W ==================================
C ======================================================================
C
      SUBROUTINE VIEW(X,Y,IPEN)
      IMPLICIT NONE
      INTEGER ICODE,IPEN,ISYM
      REAL*4 ANGLE,D,FPN,HEIGHT,SX,SY,X,XL,XR,XV,XVL,XVR,Y,YB,YT,YV
      REAL*4 YVB,YVT,ZF
      COMMON/GRAPH3/XL,XR,YB,YT,ZF,D
      COMMON/GRAPH4/XVL,XVR,YVB,YVT,SX,SY
C
C ======================== E N T R Y    V I E W 1 =====================
C
      ENTRY VIEW1(X,Y,IPEN)
      XV = SX*(X - XL) + XVL
      YV = SY*(Y - YB) + YVB
      CALL PLOT(XV,YV,IPEN)
      RETURN
C
C ======================== E N T R Y    V I E W 2 =====================
C
      ENTRY VIEW2(X,Y,HEIGHT,ISYM)
      IF (X.LT.XL.OR.X.GT.XR.OR.Y.LT.YB.OR.Y.GT.YT) RETURN
      XV = SX*(X - XL) + XVL
      YV = SY*(Y - YB) + YVB
      CALL SYMBOL(XV,YV,HEIGHT,ISYM,0.,-1)
      RETURN
C
C ======================== E N T R Y    V I E W 3 =====================
C
      ENTRY VIEW3(X,Y,HEIGHT,FPN,ANGLE,ICODE)
      IF (X.LT.XL.OR.X.GT.XR.OR.Y.LT.YB.OR.Y.GT.YT) RETURN
      XV = SX*(X - XL) + XVL
      YV = SY*(Y - YB) + YVB
      CALL NUMBER(XV,YV,HEIGHT,FPN,ANGLE,ICODE)
C
      END                                           
C
C ======================================================================
C =========================== E X T R A P ==============================
C ======================================================================
C                 
      SUBROUTINE EXTRAP(NELEM,NNODES,NNDF,LINEAR,VALUE,IPTYPE)
      IMPLICIT NONE
      INTEGER NFRAME,MAT_ELAS,MAT_PLAS,MAT_ELAS_DAM,MAT_PLAS_DAM
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MAX_MAT_TYPE
      INTEGER MAX_LINES
      PARAMETER (NFRAME=14)
      PARAMETER (MAT_ELAS=1,MAT_PLAS=2,MAT_ELAS_DAM=3,MAT_PLAS_DAM=4)
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20)
      PARAMETER (MAX_MAT_TYPE=10,MAX_LINES=3000)
      REAL*8 A,ETA,WORK,XI,AWORK(9),CAUC(6,9),CAUCH(6),CENTER(6)
      REAL*8 SIGXI(9),STRAIN(6),STRELA(6),STRESS(6),STRN(6,9),STRS(6,9)
      REAL*8 VOLUMS(9),N(MAX_ELEM_NODES),SIGETA(9),SHAPE(9,9)
      REAL*4 VALUE(*)
      CHARACTER*1 IYIELD
      INTEGER ELNUM,ELEM_TYPE,SAVED_ETYPE,STRS_STRN_REL
      INTEGER ID,ID1,IEND,INTGPN,IPTYPE,IRNODE,ISTART,IT,K1,K2,NIP
      INTEGER K3,LDEV,LDEV1,LDEV2,LDEV3,LDEV4,LDEVST,LINES,MATNUM,NELEM
      INTEGER NN,NNDF,NNODES,NODE,INT22,INT33,IREP,IVE,IVS,MATYPE,NOP
      INTEGER NIPXI,NIPETA,NIPSI,INTCOD      
      LOGICAL LINEAR
      COMMON/INPUT1/NIPXI,NIPETA,NIPSI,NIP,INTCOD
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/INPUTF/MATYPE(MAX_MAT_TYPE)
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
      COMMON/GRAPH2/IVS(MAX_LINES),IVE(MAX_LINES)
      COMMON/IREP1/IREP(MAX_LINES)
      COMMON/EXTRP1/INT33(9),INT22(4)
C
      DATA SIGXI/-1.,1.,1.,-1.,0.,1.,0.,-1.,0./
      DATA SIGETA/-1.,-1.,1.,1.,-1.,0.,1.,0.,0./
C
      DO K1=1,NFRAME*NNODES
        VALUE(K1) = 0.
      END DO
      SAVED_ETYPE=0
      DO ELNUM=1,NELEM
        CALL ELINFO(ELNUM,ELEM_TYPE,NN,MATNUM,STRS_STRN_REL,
     .              ISTART,LINES)
        IF (ELEM_TYPE.NE.SAVED_ETYPE) THEN
          IF (ELEM_TYPE.LT.300) THEN
            IF (NIP.EQ.4) THEN
              A=1.73205080756887653D0
              IT=2104
            ELSE
              A=1.29099444873580604D0
              IT=2109
            END IF
            DO K1=1,NN
              XI=SIGXI(K1)*A
              ETA=SIGETA(K1)*A
              CALL N2D(XI,ETA,N,IT)
              IF (NIP.EQ.4) THEN
                DO K2=1,NIP
                  SHAPE(INT22(K2),K1)=N(K2)
                END DO
              ELSE
                DO K2=1,NIP
                  SHAPE(INT33(K2),K1)=N(K2)
                END DO
              END IF
            END DO
            IEND=4
          ELSE
            RETURN
          END IF
        END IF
        SAVED_ETYPE=ELEM_TYPE
        DO INTGPN=1,NIP
          IF (MATYPE(MATNUM).EQ.MAT_ELAS) THEN
            READ(LDEV1) STRESS,STRAIN
            IPTYPE=1
          ELSE IF((MATYPE(MATNUM).EQ.MAT_PLAS)) THEN
            READ(LDEV1)STRESS,STRAIN,STRELA,CENTER,WORK,
     .                 IYIELD
            AWORK(INTGPN)=WORK
            IPTYPE=2
          END IF
          IF (LINEAR) THEN
            VOLUMS(INTGPN)=(STRESS(1)+STRESS(2)+STRESS(4))/3.0D0
          ELSE
            CALL CAUCHY(ELNUM,ELEM_TYPE,NN,NNDF,INTGPN,STRESS,CAUCH)
            VOLUMS(INTGPN)=(CAUCH(1)+CAUCH(2)+CAUCH(4))/3.0D0
            DO K1=1,IEND
              CAUC(K1,INTGPN)=CAUCH( K1 )
            END DO
          END IF
          DO K1=1,IEND
            STRS(K1,INTGPN)=STRESS(K1)
            STRN(K1,INTGPN)=STRAIN(K1)
          END DO
        END DO
C
C     OBTAIN INFORMATION FOR FRAMES #1-#4 (STRESS: X,Y,Z,XY)
C
        DO K1=1,NN
          NODE=NOP(K1,ELNUM)
          DO K2=1,IEND
            ID=(K2-1)*NNODES+NODE
            DO K3=1,NIP
              VALUE(ID)=VALUE(ID)+STRS(K2,K3)*SHAPE(K3,K1)
            END DO
          END DO
        END DO
C
C     OBTAIN INFORMATION FOR FRAMES #5-#8 (STRAIN: X,Y,Z,XY)
C
        DO K1=1,NN
          NODE=NOP(K1,ELNUM)
          DO K2=1,IEND
            ID=(IEND+K2-1)*NNODES+NODE
            DO K3=1,NIP
              VALUE(ID)=VALUE(ID)+STRN(K2,K3)*SHAPE(K3,K1)
            END DO
          END DO
        END DO
C
C     OBTAIN INFORMATION FOR FRAMES #9-#12 (CAUCHY STRESS: X,Y,Z,XY)
C
        DO K1=1,NN
          NODE=NOP(K1,ELNUM)
          DO K2=1,IEND
            ID=(2*IEND+K2-1)*NNODES+NODE
            DO K3=1,NIP
              VALUE(ID)=VALUE(ID)+CAUC(K2,K3)*SHAPE(K3,K1)
            END DO
          END DO
        END DO
C
C     OBTAIN INFORMATION FOR FRAME #13 (VOLUMETRIC STRAIN)
C
        ID1=3*IEND*NNODES
        DO K1=1,NN
          ID=ID1+NOP(K1,ELNUM)
          DO K3=1,NIP
            VALUE(ID)=VALUE(ID)+VOLUMS(K3)*SHAPE(K3,K1)
          END DO
        END DO
C
C     OBTAIN INFORMATION FOR FRAME #14 (WORK)
C
        IF(IPTYPE.EQ.2) THEN
          ID1=(3*IEND+1)*NNODES
          DO K1=1,NN
            ID=ID1+NOP(K1,ELNUM)
            DO K3=1,NIP
              VALUE(ID)=VALUE(ID)+AWORK(K3)*SHAPE(K3,K1)
            END DO
          END DO
        ENDIF                            
      END DO
C
C     NORMALIZE VALUES
C      
      DO K2=1,NFRAME
        ID1=(K2-1)*NNODES
        DO NODE=1,NNODES
          IRNODE=IREP(NODE)/32
          ID=ID1+NODE
          VALUE(ID)=VALUE(ID)/IRNODE
        END DO
      END DO
      CALL REWIN
C
      END              
C
C =====================================================================
C =========================== E L I N F O =============================
C =====================================================================
C
      SUBROUTINE ELINFO(ELNUM,ELEM_TYPE,NNEL,MATNUM,STRS_STRN_REL,
     .                  ISTART,LINES)
C
C =====================================================================
C I                                                                   I
C I    P R O G R A M                                                  I
C I                                                                   I
C I    PROGRAM 'ELINFO' EXTRACTS ELEMENT INFORMATION FROM THE ARRAY   I
C I    'INFOEL'.                                                      I
C I                                                                   I
C I    A R G U M E N T      L I S T                                   I
C I                                                                   I
C I    ELNUM     = ELEMENT NUMBER PASSED BY THE CALLING ROUTINE       I
C I                                                                   I
C I    ELEM_TYPE = ELEMENT TYPE PASSED TO THE CALLING ROUTINE         I
C I                                                                   I
C I    NNEL      = NUMBER OF NODES IN THE ELEMNT PASSED TO THE        I
C I                CALLING ROUTINE                                    I
C I                                                                   I
C I    MATNUM    = MATERIAL I.D. NUMBER FOR THE ELEMENT PASSED TO THE I
C I                CALLING ROUTINE                                    I
C I                                                                   I
C I    ISTART    = STARTING POSITION OF THE LINE CONNECTIVITY DATA    I
C I                IN ARRAYS 'IS' AND 'IE'.                           I
C I                                                                   I
C I    LINES     = NUMBER OF LINES CONNECTING THE NODES WITHIN THE    I
C I                ELEMENT                                            I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      INTEGER MAX_ELEMENTS
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_ELEMENTS=400)
      INTEGER ELNUM,ELEM_TYPE,I,ISTART,LINES,MATNUM,NNEL,INFOEL
      COMMON/INPUTA/INFOEL(MAX_ELEMENTS)
C
      I = INFOEL( ELNUM )
      LINES = I/67108864
      ISTART = IAND(I , 66060288)/1048576
      STRS_STRN_REL  = IAND(I , 917504)/131072
      ELEM_TYPE  = IAND(I , 130816)/256
      NNEL   = IAND(I , 248)/8
      MATNUM = IAND(I , 7)
C
      END
C
C =====================================================================
C =========================== G L O B A L =============================
C =====================================================================
C
      SUBROUTINE GLOBAL
C
C =====================================================================
C I                                                                   I
C I     SUBROUTINE GLOBAL IS USED TO MODIFY THE FINAL GLOBAL          I
C I     STIFFNESS MATRIX. THIS IS DONE IN ORDER TO SOLVE THE          I
C I     SET OF SIMULTANEOUS EQUATIONS BY THE METHOD OF MODIFICATION.  I
C I     THIS SUBROUTINE IS DESIGNED FOR MODIFICATION OF BANDED        I
C I     NONSYMMETRIC MATRICES IN THEIR CONDENSED FORM.                I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER ICOUNT,ID,MDOF,NNDF,NNODES,NTDF,IDOF(*)
C
C ======================== E N T R Y    G L O B 1 =====================
C
      ENTRY GLOB1(NNODES,NNDF,NTDF,IDOF)            
      MDOF = NNDF*NNODES
      ICOUNT = 0
      DO ID = 1 , MDOF
        IF (IDOF( ID ).EQ.0) THEN
          ICOUNT = ICOUNT + 1
          IDOF( ID ) = ICOUNT
        ELSE IF (IDOF( ID ).GT.0) THEN
          IDOF( ID ) = 0
        END IF
      END DO
      NTDF = ICOUNT
      RETURN
C
C ======================== E N T R Y    G L O B 2 =====================
C
      ENTRY GLOB2(NNODES,NNDF,NTDF,IDOF)          
      MDOF = NNDF*NNODES
      ICOUNT = 0
      DO ID = 1 , MDOF
        IF (IDOF( ID ).GT.0) THEN
          ICOUNT  = ICOUNT + 1
          IDOF( ID ) = ICOUNT
        END IF
      END DO
      NTDF = ICOUNT
C      
      END
C
C =====================================================================
C ======================== D I A G N L ================================
C =====================================================================
C
      SUBROUTINE DIAGNL(NELEM,NNDF,NTDF,IDOF,JDIAG,NTSK,MBAND,SYMMETRIC,
     .                  I_OUT)
C     
C =====================================================================
C I                                                                   I
C I    THIS PROGRAM COMPUTES THE VECTOR CONTAINING THE ADDRESSES      I
C I    OF THE DIAGONAL ELEMENTS OF THE STIFFNESS MATRIX. IT ALSO      I
C I    CALCULATES THE BANDWIDTH AND THE AVERAGE BANDWIDTH OF THE      I
C I    STIFFNESS MATRIX AND PRINTS THESE STATISTICS.                  I
C I                                                                   I
C I    A R G U M E N T      L I S T                                   I
C I                                                                   I
C I    NELEM     = TOTAL NUMBER OF ELEMENTS                           I
C I                                                                   I
C I    NNDF      = NUMBER OF NODAL DEGREES OF FREEDOM                 I
C I                                                                   I
C I    NTDF      = NUMBER OF TOTAL DEGREES OF FREEDOM                 I
C I                                                                   I
C I    IDOF(I)   = VECTOR CONTAINING THE D.O.F. NUMBERS OF THE NODES  I
C I                                                                   I
C I    JDIAG(I)  = VECTOR CONTAINING THE ADDRESS OF THE DIAGONAL      I
C I                TERMS IN THE GLOBAL STIFFNESS MATRIX 'SKG'         I
C I                                                                   I
C I    NTSK      = NUMBER OF TERMS IN THE GLOBAL STIFFNESS MATRIX     I
C I                                                                   I
C I    MBAND     = HALF BANDWIDTH OF THE STIFFNESS MATRIX             I
C I                                                                   I
C I    I_OUT     = OUTPUT DEVICE NUMBER                               I
C I                                                                   I
C I                                                                   I
C I    C O M M O N     B L O C K S                                    I
C I                                                                   I
C I    NOP(I,J)  = MEMBER INCIDENCES                                  I
C I                                                                   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEMENTS,MAX_ELEM_NODES
      INTEGER ELNUM,ELEM_TYPE,STRS_STRN_REL
      PARAMETER (MAX_ELEMENTS=400,MAX_ELEM_NODES=20)
      LOGICAL SYMMETRIC
      INTEGER IDOF(*), JDIAG(*),NOP,ID,IDIR,ISTART,I_OUT,K,LINES
      INTEGER MATNUM,MAXDOF,MBAND,MBAV,MBN,MHT,MINDOF,NELEM,NNDF,NNEL
      INTEGER NODE,NTDF,NTSK
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
C
      MBAV = 0
      MBAND = 0
      DO K = 1 , NTDF
        JDIAG( K ) = 0
      END DO
      DO ELNUM = 1 , NELEM
        CALL ELINFO(ELNUM,ELEM_TYPE,NNEL,MATNUM,STRS_STRN_REL,
     .              ISTART,LINES)
        MAXDOF = 0
        MINDOF = 1000000
        DO 20 NODE = 1 , NNEL
         DO 20 IDIR = 1 , NNDF
           K = NNDF*(NOP(NODE , ELNUM) - 1) + IDIR
           IF(IDOF( K ))20,20,10
 10        MAXDOF = MAX0(MAXDOF , IDOF( K ))
           MINDOF = MIN0(MINDOF , IDOF( K ))
 20     CONTINUE
C
C        AT THIS POINT THE HEIGHT OF EACH COLUMN IS STORED IN JDIAG
C
        DO 26 NODE = 1 , NNEL
          DO 26 IDIR = 1 , NNDF
            ID = NNDF*(NOP(NODE , ELNUM) - 1) + IDIR
            ID = IDOF( ID )
            IF ( ID )26 , 26 , 25
 25         MHT = ID - MINDOF + 1
            IF(MHT.GT.JDIAG( ID )) JDIAG( ID ) = MHT
 26     CONTINUE
C
C        FIND THE BANDWIDTH AND THE AVERAGE BANDWIDTH
C
        MBN = MAXDOF - MINDOF
        MBAND = MAX0(MBAND , MBN)
        MBAV = MBAV + MBAND
      END DO
      MBAV = MBAV/NELEM + 1
      MBAND = MBAND + 1
C
C        LOCATION OF EACH DIAGONAL TERM WILL NOW BE STORED IN JDIAG
C
      IF (SYMMETRIC) THEN
        MHT = 1
        ID  = 0
        DO K = 1 , NTDF+1
          ID = ID + MHT
          MHT = JDIAG( K )
          JDIAG( K ) = ID
        END DO
        NTSK = JDIAG(NTDF+1) - JDIAG( 1 )
      ELSE
        ID = 0
        DO K = 1 , NTDF
          ID = ID + JDIAG( K )
          JDIAG( K ) = ID
        END DO
        NTSK = 2*JDIAG( NTDF )
      END IF
C
C        NTSK = NUMBER OF TERMS IN THE GLOBAL STIFFNESS MATRIX "SKG"
C
      WRITE(I_OUT , 100)NTDF,MBAND,MBAV,NTSK
 100  FORMAT(/1X,'NUMBER OF EQUATIONS = ',I8/1X,'HALF BANDWIDTH = ',
     . I8/1X,'AVERAGE BANDWIDTH = ',I8/1X,'SIZE OF THE STIFFNESS MATRIX'
     . ,' = ',I8)
C
      END
C
C =====================================================================
C ========================== S O L V E 1 ==============================
C =====================================================================
C
      SUBROUTINE SOLVE1(A,C,B,JDIAG,NEQ,AFAC,BACK)
C
C ====================================================================
C I                                                                  I
C I   P R O G R A M:                                                 I
C I                                                                  I
C I   PROGRAM 'SOLVE1' IS USED TO SOLVE A SERIES OF BANDED           I
C I   NONSYMMETRIC LINEAR EQUATIONS USING THE GAUSS ELIMINATION/BACK I
C I   SUBSTITUTION WITH NO COLUMN PIVOTING.                          I
C I                                                                  I
C I   STORAGE:    COEFFICIENT MATRIX SHOULD BE STORED IN TWO ONE     I
C I               DIMENSIONAL ARRAYS USING THE SKYLINE OR THE        I
C I               PROFILE METHOD                                     I
C I               A( K ) = UPPER TRIANGULAR MATRIX                   I
C I               C( K ) = LOWER TRIANGULAR MATRIC                   I
C I               B( K ) = RIGHT HAND SIDE VECTOR ON CALL            I
C I                      = VECTOR OF UNKNOWNS ON RETURN              I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      LOGICAL AFAC,BACK
      INTEGER I,ID,IE,IH,IR,IS,J,JD,JH,JR,K,NEQ,JDIAG(*)
      REAL*8 A(*),C(*),B(*),D,DOTPRO
C
C        FACTOR A TO UT*D*U, REDUCE B TO Y
C
      JR = 0
      DO 300 J = 1 , NEQ
        JD = JDIAG( J )
        JH = JD - JR
        IF (JH.LE.1) GO TO 300
        IS = J + 1 - JH
        IE = J - 1
        IF (.NOT.AFAC) GO TO 250
        K = JR + 1
        ID = 0
C
C        REDUCE ALL EQUATIONS EXCEPT DIAGONAL
C
        DO I = IS , IE
          IR = ID
          ID = JDIAG( I )
          IH = MIN0(ID-IR-1 , I - IS)
          IF (IH.EQ.0) GO TO 150
          A( K ) = A( K ) - DOTPRO(A( K-IH ),C( ID-IH ),IH)
          C( K ) = C( K ) - DOTPRO(C( K-IH ),A( ID-IH ),IH)
 150      IF (A(ID).NE.0.0) C( K ) = C( K )/A( ID )
          K = K + 1
        END DO
C
C         REDUCE THE DIAGONAL TERM
C
        A( JD ) = A( JD ) - DOTPRO(A( JR+1 ),C( JR+1 ),JH-1)
C
C         FORWARD REDUCE THE RIGHT HAND SIDE
C
 250    IF ( BACK ) B( J ) = B( J ) - DOTPRO(C( JR+1 ),B( IS ),JH-1)
 300  JR = JD
      IF(.NOT.BACK) RETURN
C
C         BACK SUBSTITUTION
C
      J = NEQ
      JD = JDIAG( J )
 500  IF (A( JD ).NE.0.0) B( J ) = B( J )/A( JD )
      D = B( J )
      J = J - 1
      IF (J.LE.0) RETURN
      JR = JDIAG( J )
      IF (JD-JR.LE.1) GO TO 700
      IS = J - JD + JR + 2
      K = JR - IS + 1
      DO I = IS , J
        B( I ) = B( I ) - A( I+K )*D
      END DO
 700  JD = JR
      GO TO 500
C      
      END
C
C =====================================================================
C ============================= D O T P R O ===========================
C =====================================================================
C
      REAL*8 FUNCTION DOTPRO(A,B,N)
      IMPLICIT NONE
      REAL*8 A(*),B(*),TEMP
      INTEGER I,N
C
      TEMP = 0.D0
      DO I = 1 , N
        TEMP = TEMP + A( I )*B( I )
      END DO
      DOTPRO = TEMP
C
      END
C
C =====================================================================
C ========================== S O L V E 2 ==============================
C =====================================================================
C
      SUBROUTINE SOLVE2(A,R,JDIAG,NEQU,KKK,I_OUT)
C
C ====================================================================
C I                                                                  I
C I   THIS PROGRAM IS USED TO SOLVE FINITE ELEMENT STATIC EQUILIB.   I
C I   EQUATIONS IN CORE, USING COMPACTED STORAGE AND COLUMN REDUCTON I
C I   SCHEME                                                         I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      INTEGER IC,I_OUT,J,K,KH,KI,KK,KKK,KL,KLT,KN,KU,L,N,ND,NEQU
      INTEGER JDIAG(*)
      REAL*8 A(*),R(*),B,C
C
C        PERFORM L*D*L FACTORIZATION OF THE STIFFNESS MATRIX
C
      IF (KKK - 2) 40 , 150 , 150
 40   DO 140 N = 1 , NEQU
        KN = JDIAG( N )
        KL = KN + 1
        KU = JDIAG(N+1) - 1
        KH = KU - KL
        IF (KH) 110,90,50
 50     K = N - KH
        IC = 0
        KLT = KU
        DO 80 J = 1 , KH
          IC = IC + 1
          KLT = KLT - 1
          KI = JDIAG( K )
          ND = JDIAG( K + 1 ) - KI - 1
          IF (ND) 80 , 80 , 60
 60       KK = MIN0(IC,ND)
          C = 0.D0
          DO L = 1 , KK
            C = C + A(KI + L)*A(KLT + L)
          END DO
          A( KLT ) = A( KLT ) - C
 80     K = K + 1
 90     K = N
        B = 0.D0
        DO KK = KL , KU
          K = K - 1
          KI = JDIAG( K )
          C = A( KK )/ A( KI )
          B = B + C*A( KK )
          A( KK ) = C
        END DO
        A( KN ) = A( KN ) - B
 110    IF (A( KN )) 120 ,120 , 140
 120    WRITE(I_OUT , 2000) N , A( KN )
        STOP 'STIFFNESS MATRIX NOT POSITIVE DEFINITE '
 140  CONTINUE                                      
      RETURN
C
C       REDUCE THE RIGHT-HAND-SIDE LOAD VECTOR
C
 150  DO 180 N = 1 , NEQU
        KL = JDIAG( N ) + 1
        KU = JDIAG( N + 1) - 1
        IF(KU-KL) 180 , 160 , 160
 160    K = N
        C = 0.D0
        DO KK = KL , KU
          K = K - 1
          C = C + A( KK )*R( K )
        END DO
        R( N ) = R( N ) - C
 180  CONTINUE
C
C       BACK-SUBSTITUTE
C
      DO N = 1 , NEQU
        K = JDIAG( N )
        R( N ) = R( N )/ A( K )
      END DO
      IF (NEQU.EQ.1) RETURN
      N = NEQU
      DO 230 L = 2 , NEQU
        KL = JDIAG( N ) + 1
        KU = JDIAG( N + 1 ) - 1
        IF ( KU - KL ) 230 , 210 , 210
 210    K = N
        DO KK = KL , KU
          K = K - 1
          R( K )  = R( K ) - A( KK )*R( N )
        END DO
 230  N = N - 1
      RETURN
 2000 FORMAT(//1X,'STIFFNESS MATRIX NOT POSITIVE DEFINITE '//
     . 1X,' NONPOSITIVE PIVOT FOR EQUATION ',I4//1X,'PIVOT = ',E20.12)
C     
      END
C
C =====================================================================
C ======================== C O O R D ==================================
C =====================================================================
C
      SUBROUTINE COORD
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MAX_GAUSS_PTS,MNNDF
      INTEGER MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20,
     .           MAX_GAUSS_PTS=27,MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      REAL*4 X,Y,Z
      REAL*8 N,NXI,NETA,NSI,U(MNNDF),UXIP,UYIP,UZIP,X1,Y1,Z1,UTOTAL
      INTEGER ELNUM,ID,INTGPN,K,K1,NNDF,NNEL,NOP
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/INPUT3/X(MAX_NODES),Y(MAX_NODES),Z(MAX_NODES)
      COMMON/ISHAP1/N(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NXI(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NETA(MAX_ELEM_NODES,MAX_GAUSS_PTS),
     .              NSI(MAX_ELEM_NODES,MAX_GAUSS_PTS)
C
C ======================== E N T R Y    C O O R D 1 ===================
C
      ENTRY COORD1(ELNUM,NNEL,INTGPN,X1,Y1,Z1)     
      X1 = 0.D0
      Y1 = 0.D0
      Z1 = 0.D0
      DO K = 1 , NNEL
        X1 = X1 + N(K , INTGPN)*X(NOP(K , ELNUM))
        Y1 = Y1 + N(K , INTGPN)*Y(NOP(K , ELNUM))
        Z1 = Z1 + N(K , INTGPN)*Z(NOP(K , ELNUM))
      END DO
      RETURN
C
C ======================== E N T R Y    C O O R D 2 ===================
C
      ENTRY COORD2(ELNUM,NNEL,INTGPN,NNDF,UXIP,UYIP,UZIP)
      U( 1 ) = 0.D0
      U( 2 ) = 0.D0                  
      U( 3 ) = 0.D0
      DO K = 1 , NNEL
        DO ID = 1 , NNDF
          K1 = NNDF*(NOP(K , ELNUM) - 1) + ID
          U( ID ) = U( ID ) + N(K , INTGPN)*UTOTAL( K1 )
        END DO
      END DO
      UXIP = U( 1 )
      UYIP = U( 2 )
      UZIP = U( 3 )
C
      END
C
C =====================================================================
C ======================== M A T M O D ================================
C =====================================================================
C
      SUBROUTINE MATMOD(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,
     .                  I_OUT,ICODE)
      IMPLICIT NONE
      INTEGER MAT_ELAS,MAT_PLAS,MAT_ELAS_DAM,MAT_PLAS_DAM
      INTEGER MAX_MAT_TYPE
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAT_ELAS=1,MAT_PLAS=2,MAT_ELAS_DAM=3,MAT_PLAS_DAM=4)
      PARAMETER (MAX_MAT_TYPE=10)
      INTEGER ELNUM,ELEM_TYPE,I,ICODE,INTGPN,I_OUT,MATNUM,MATYPE
      COMMON/INPUTF/MATYPE(MAX_MAT_TYPE)
C
      I = MATYPE( MATNUM )
      IF (I.EQ.MAT_ELAS) THEN
        CALL ELAST(ELEM_TYPE,MATNUM,STRS_STRN_REL,ICODE)
      ELSE IF(I.EQ.MAT_PLAS) THEN
        CALL PLAST(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,ICODE)
C      ELSE IF(I.EQ.MAT_ELAS_DAM) THEN
C        CALL ELDAM(ELEM_TYPE,MATNUM,STRS_STRN_REL,ICODE)
C     ELSE IF(I.EQ.MAT_PLAS_DAM) THEN
C        CALL PLDAM(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,ICODE)
      ELSE
        WRITE (I_OUT , 100) I
        STOP 'INVALID MATERIAL TYPE SPECIFIED'
      END IF
 100  FORMAT (/1X,'INVALID MATERIAL TYPE(',I3,') SPECIFIED')
C 
      END
C
C =====================================================================
C ======================= E L A S T ===================================
C =====================================================================
C
      SUBROUTINE ELAST(ELEM_TYPE,MATNUM,STRS_STRN_REL,ICODE)
      IMPLICIT NONE
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      INTEGER ELEM_TYPE,ICODE,MATNUM
C                                        
      IF (ICODE.EQ.0) THEN
        CALL DELAST(ELEM_TYPE,MATNUM,STRS_STRN_REL)
      ELSE
        CALL STRSTN(ELEM_TYPE,MATNUM,STRS_STRN_REL)
      END IF
C
      END
C
C =====================================================================
C ======================= S T R S T N =================================
C =====================================================================
C
      SUBROUTINE STRSTN(ELEM_TYPE,MATNUM,STRS_STRN_REL)
      IMPLICIT NONE
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      INTEGER ELEM_TYPE,IEND,INCREM,K1,K2,LDEV,LDEV1,LDEV2,LDEV3,LDEV4
      INTEGER LDEVST,MATNUM,NIT
      REAL*8 S,DEP,STRN,STRS,STRESS(6),STRAIN(6),DE(6),DS(6)
      COMMON/MATER1/DEP(6,6)              
      COMMON/ELSTR1/STRN(6)
      COMMON/ELSTR2/STRS(6)
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
      COMMON/CONTR1/INCREM,NIT
C
      IF (ELEM_TYPE.GT.300) THEN
        IEND=6
      ELSE
        IEND=4
      ENDIF
      IF (INCREM.GT.1) THEN
        READ(LDEV1) STRESS,STRAIN
      ELSE
        DO K1 = 1 , IEND
          STRESS( K1 ) = 0.D0
          STRAIN( K1 ) = 0.D0
        END DO
      END IF
      DO K1 = 1 , IEND
        DE( K1 ) = STRN( K1 ) - STRAIN( K1 )
      END DO
      CALL DELAST(ELEM_TYPE,MATNUM,STRS_STRN_REL)
      DO K1= 1 , IEND
        S = 0.D0
        DO K2 = 1 , IEND
          S = S + DEP(K1 , K2)*DE( K2 )
        END DO
        DS( K1 ) = S
      END DO
      DO K1=1,IEND
        STRAIN(K1)=STRN(K1)
        STRESS(K1)=STRESS(K1)+DS(K1)
        STRS(K1)=STRESS(K1)
      END DO
      WRITE(LDEV2) STRESS,STRAIN
C
      END
C
C =====================================================================
C ====================== D E L A S T ==================================
C =====================================================================
C
      SUBROUTINE DELAST(ELEM_TYPE,MATNUM,STRS_STRN_REL)
C
C =====================================================================
C I                                                                   I
C I   PROGRAM 'ELAST'EVALUATES THE STRESS-STRAIN STIFFNESS MATRIX     I
C I   FOR ISOTROPIC OR ORTHOTROPIC ELASTIC MATERIALS                  I
C I                                                                   I
C I   C O M M O N      B L O C K S                                    I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_MAT_TYPE
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_MAT_TYPE=10)
      INTEGER ELEM_TYPE,K1,K2,MATNUM
      REAL*8 NUX,NUY,NUZ,CST1,CST2,G,DEP,EX,EY,EZ,P1X,P1Y,P1Z
      REAL*8 P2X,P2Y,P2Z
      COMMON/MATER1/DEP(6,6)
      COMMON/INPUT5/NUX(MAX_MAT_TYPE),NUY(MAX_MAT_TYPE),
     .              NUZ(MAX_MAT_TYPE),EX(MAX_MAT_TYPE),
     .              EY(MAX_MAT_TYPE),EZ(MAX_MAT_TYPE),
     .              P1X(MAX_MAT_TYPE),P1Y(MAX_MAT_TYPE),
     .              P1Z(MAX_MAT_TYPE),P2X(MAX_MAT_TYPE),
     .              P2Y(MAX_MAT_TYPE),P2Z(MAX_MAT_TYPE)
C
      IF (ELEM_TYPE.GT.300) THEN
        DO K2 = 1 , 6
          DO K1 = 1 , 6
            DEP(K1 , K2) = 0.D0
          END DO
        END DO
        G=0.5D0*EX(MATNUM)/(1.D0+NUX(MATNUM))
        CST1=2.D0*G*(1.D0-NUX(MATNUM))/(1.D0-2.D0*NUX(MATNUM))
        CST2=2.D0*G*NUX(MATNUM)/(1.D0-2.D0*NUX(MATNUM))
        DEP(1 , 1) = CST1
        DEP(2 , 2) = CST1
        DEP(3 , 3) = CST1
        DEP(4 , 4) = G
        DEP(5 , 5) = G
        DEP(6 , 6) = G
        DEP(1 , 2) = CST2
        DEP(1 , 3) = CST2
        DEP(2 , 1) = CST2
        DEP(2 , 3) = CST2
        DEP(3 , 1) = CST2
        DEP(3 , 2) = CST2
      ELSE
        DO K2 = 1 , 4
          DO K1 = 1 , 4
            DEP(K1 , K2) = 0.D0
          END DO
        END DO
C
C       PLANE STRESS
C
        IF (STRS_STRN_REL.EQ.PLANE_STRESS) THEN
          DEP(1,1)=EX(MATNUM)/(1.D0-NUX(MATNUM)**2)
          DEP(2,2)=DEP(1,1)
          DEP(3,3)=EX(MATNUM)*0.5D0/(1.D0+NUX(MATNUM))
          DEP(1,2)=NUX( MATNUM )*DEP(1 , 1)
          DEP(2,1)=DEP(1 , 2)
C
C       AXISYMMETRIC AND PLANE STRAIN
C
        ELSE
          CST1=EX(MATNUM)/(1.D0+NUX(MATNUM))/(1.D0-2.D0*NUX(MATNUM))
          DEP(1 , 1) = (1.D0-NUX(MATNUM))*CST1
          DEP(2 , 2) = DEP(1 , 1)
          DEP(3 , 3) = EX(MATNUM)*0.5D0/(1.D0+NUX(MATNUM))
          DEP(4 , 4) = DEP(1 , 1)
          DEP(1 , 2) =  NUX( MATNUM )*CST1
          DEP(2 , 1) =  NUX( MATNUM )*CST1
          DEP(1 , 4) =  NUX( MATNUM )*CST1
          DEP(4 , 1) =  NUX( MATNUM )*CST1
          DEP(2 , 4) =  NUX( MATNUM )*CST1
          DEP(4 , 2) =  NUX( MATNUM )*CST1
        END IF
      END IF
C
      END
C
C =====================================================================
C ======================== P L A S T ==================================
C =====================================================================
C
      SUBROUTINE PLAST(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,
     .                 ICODE)
      IMPLICIT NONE
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      INTEGER ELNUM,ELEM_TYPE,ICODE,IEND,INTGPN,MATNUM
C
      IF (ELEM_TYPE.GT.300) THEN
        IEND=6
      ELSE
        IEND=4
      ENDIF
      IF (ICODE.EQ.0) THEN
        CALL MISES1(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,IEND)
      ELSE
        CALL MISES2(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,IEND)
      END IF
C
      END
C
C =====================================================================
C ======================== M I S E S ==================================
C =====================================================================
C
      SUBROUTINE MISES
C
C =====================================================================
C I                                                                   I
C I   P R O G R A M:                                                  I
C I                                                                   I
C I      PROGRAM 'MISES' IS THE CONTROL UNIT FOR CALCULATION OF THE   I
C I      ELASTOPLASTIC STRESS-STRAIN STIFFNESS MATRIX.                I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_ELEMENTS,MAX_MAT_TYPE,MNNDF
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_ELEMENTS=400,MAX_MAT_TYPE=10,MNNDF=3)
      INTEGER ELNUM,ELEM_TYPE,IDIM,IEND,INCREM,INCREMENTS,INTGPN,ITEMP
      INTEGER ITERATIONS,K1,K2,K3,K4,LDEV,LDEV1,LDEV2,LDEV3,LDEV4
      INTEGER LDEVST,MATNUM,NELEM,NINODE,NIT,NNDF,NNODES,IYIEL
      INTEGER LDEV10,LDEV5,LDEV6,LDEV7,LDEV8,LDEV9
      CHARACTER*1 IYIELD
      LOGICAL LINEAR,SYMMETRIC
      REAL*8 NUX,NUY,NUZ,ALAMDA,AMUDOT,BETA,C2,C3,CST,DEN,DJAC,F,F0
      REAL*8 F1,F2,FACSUM,FACTOR,FJ,FK,POISS,SY,WORK,YOUNG,AD,ALAM
      REAL*8 AMU,DEP,DEPM,EX,EY,EZ,FE,FS,FZ,P1X,P1Y,P1Z,P2X,P2Y
      REAL*8 P2Z,STRN,STRS
      REAL*8 S0(3,3),C(3,3),Z(3,3),RR(3,3),E(3,3),DEL(3,3),ED(3,3)
      REAL*8 EDOT(3,3),SF(3,3),EDOTEL(3,3),EDOTPL(3,3),DELAS(6)
      REAL*8 STRESS(6),STRAIN(6),CENTER(6),STRELA(6),DE(6),SDOT(3,3)
      COMMON/DEV1/LDEV5,LDEV6,LDEV7,LDEV8,LDEV9,LDEV10
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
      COMMON/CONTR1/INCREM,NIT
      COMMON/ELSTR1/STRN(6)
      COMMON/ELSTR2/STRS(6)
      COMMON/ADMAT1/AD(3,3,3,3)
      COMMON/PLAST1/IYIEL(MAX_ELEMENTS)
      COMMON/FDER1/FJ,FK,FS(3,3),FE(3,3),FZ(3,3)
      COMMON/MATER1/DEP(6,6)
      COMMON/ELPLD1/DEPM(3,3,3,3),ALAM(3,3),AMU(3,3)
      COMMON/INPUT8/NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,
     .              SYMMETRIC,IDIM,NINODE
      COMMON/INPUT5/NUX(MAX_MAT_TYPE),NUY(MAX_MAT_TYPE),
     .              NUZ(MAX_MAT_TYPE),EX(MAX_MAT_TYPE),
     .              EY(MAX_MAT_TYPE),EZ(MAX_MAT_TYPE),
     .              P1X(MAX_MAT_TYPE),P1Y(MAX_MAT_TYPE),
     .              P1Z(MAX_MAT_TYPE),P2X(MAX_MAT_TYPE),
     .              P2Y(MAX_MAT_TYPE),P2Z(MAX_MAT_TYPE)
C
      DATA ((DEL(K1,K2),K1=1,3),K2=1,3)/1.D0,0.D0,0.D0,0.D0,1.D0,
     .        0.D0,0.D0,0.D0,1.D0/
C
C ==================== E N T R Y    M I S E S 2 =======================
C
      ENTRY MISES2(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,IEND)
      FACTOR = 1.D0
      FACSUM = 0.D0
      IF (INCREM.GT.1) THEN
        READ(LDEV1) STRESS,STRAIN,STRELA,CENTER,WORK,IYIELD
      ELSE
        DO K1 = 1 , IEND
          STRAIN( K1 ) = 0.D0
          STRESS( K1 ) = 0.D0
          CENTER( K1 ) = 0.D0
          STRELA( K1 ) = 0.D0
        END DO
        WORK = 0.D0
      END IF
C
C --- GET THE MATERIAL PARAMETERS
C
      C2=P2X(MATNUM)
      C3=P1Y(MATNUM)
      SY=P1Z(MATNUM)
      BETA=P1X(MATNUM)
      YOUNG = EX( MATNUM )
      POISS = NUX( MATNUM )
C
C --- CALCULATION OF THE STRAIN INCREMENT
C
      DO K1 = 1 , IEND
        DE( K1 ) = STRN( K1 ) - STRAIN( K1 )
      END DO
C
C --- CALCULATION OF THE USEFUL TENSORS
C
      CALL TENSOR(ELEM_TYPE,STRESS,S0,1.D0)
      CALL TENSOR(ELEM_TYPE,STRAIN,E,0.5D0)
      CALL TENSOR(ELEM_TYPE,DE,ED,0.5D0)
      CALL TENSOR(ELEM_TYPE,CENTER,Z,1.D0)
C
C --- CALCULATION OF THE FOURTH ORDER ELASTIC STIFFNESS MATRIX
C
      CALL ADMAT(YOUNG,POISS)
      DO K1=1,3
        DO K2=1,3
          C(K1,K2)=2.D0*E(K1,K2)+DEL(K1,K2)
          CST=0.D0
          DO K3=1,3
            DO K4=1,3
              CST=CST+AD(K1,K2,K3,K4)*ED(K3,K4)
            END DO
          END DO
          SDOT(K1,K2)=CST
        END DO
      END DO
C
C --- CALCULATION OF THE JACOBIAN OF DEFORMATION
C
  34  CALL DEFJAC(E,DEL,RR,DJAC)
C
C --- START OF THE INCREMENTATION LOOP
C --- CALCULATION OF THE TRIAL ELASTIC STRESS
C
      DO K2=1,3
        DO K1=1,3
          SF(K1,K2)=S0(K1,K2)+SDOT(K1,K2)
        END DO
      END DO
C
C --- CALCULATION OF THE YIELD FUNCTION FOR THE TRIAL ELASTIC STRESS
C
      CALL YIELD(SF,C,Z,WORK,DJAC,C2,C3,SY,F,F1,F2)
      IF (F.LE.0.D0) THEN
        FACSUM=FACSUM+FACTOR
        DO K1=1,IEND
          STRELA(K1)=STRELA(K1)+DE(K1)*FACTOR
        END DO
        DO K2=1,3
          DO K1=1,3
            E(K1,K2)=E(K1,K2)+EDOT(K1,K2)
            C(K1,K2)=2.D0*E(K1,K2)+DEL(K1,K2)
            S0(K1,K2)=SF(K1,K2)
          END DO
        END DO
        IYIELD = ' '
      ELSE IF(F.GT.0.) THEN
        IF(FACTOR.EQ.1.) THEN
          FACTOR = 1.D-2
          DO K1=1,3
            DO K2=1,3
              SDOT(K2,K1)=FACTOR*SDOT(K2,K1)
              EDOT(K2,K1)=FACTOR*ED(K2,K1)
            END DO
          END DO
          GO TO 34
        END IF
        CALL YIELD(S0,C,Z,WORK,DJAC,C2,C3,SY,F0,F1,F2)
        FACSUM = FACSUM + FACTOR
        CALL FDER(S0,C,Z,DJAC,F1,F2,C2,C3)
        CALL ELPLD(S0,Z,RR,DJAC,BETA,DEN,1)
        ALAMDA = 0.D0
        AMUDOT = 0.D0
        DO K2 = 1 , 3
          DO K1 = 1 , 3
            AMUDOT=AMUDOT+AMU(K1,K2)*EDOT(K1,K2)
            ALAMDA=ALAMDA+ALAM(K1,K2)*EDOT(K1,K2)
          END DO
        END DO
        DO K2 = 1 , 3
          DO K1 = 1 , 3
            E(K1 , K2) = E(K1 , K2) + EDOT(K1 , K2)
            C(K1 , K2) = 2.D0*E(K1,K2)+DEL(K1,K2)
            EDOTPL(K1 , K2) = ALAMDA*FS(K1 , K2)
            EDOTEL(K1 , K2) = EDOT(K1 , K2) - EDOTPL(K1 , K2)
            Z(K1 , K2 ) = Z(K1,K2) + (S0(K1,K2)-Z(K1,K2))*AMUDOT
          END DO
        END DO
        DO K2 = 1 , 3
          DO K1 = 1 , 3
            CST = 0.D0
            DO K4 = 1 , 3
              DO K3 = 1 , 3
                CST = CST + AD(K1 , K2 , K3 , K4)*EDOTEL(K3 , K4)
              END DO
            END DO
            WORK=WORK+(S0(K1,K2)+0.5D0*CST)*EDOTPL(K1,K2)/DJAC
            S0(K1 , K2) = S0(K1 , K2) + CST
          END DO
        END DO
        CALL VECTOR(ELEM_TYPE,EDOTEL,DELAS,2.0D0)
        DO K1 = 1 , IEND
          STRELA( K1 ) = STRELA( K1 ) + DELAS( K1 )
        END DO
        IYIELD = 'Y'
      END IF
      IF (FACSUM.LT.1.) GO TO 34
C
C       DEFINE THE 'IYIEL' VECTOR FOR FUTURE PLOTTING
C
      IF (IYIELD.EQ.'Y') THEN
        ITEMP = IBSET(IYIEL( ELNUM ) , INTGPN)
        IYIEL( ELNUM ) = ITEMP
      ELSE
        ITEMP = IBCLR(IYIEL( ELNUM ) , INTGPN)
        IYIEL( ELNUM ) = ITEMP
      END IF
      DO K1 = 1 , IEND             
        STRAIN( K1 ) = STRN( K1 )
      END DO
      CALL VECTOR(ELEM_TYPE,S0,STRS,1.D0)
      CALL VECTOR(ELEM_TYPE,S0,STRESS,1.D0)
      CALL VECTOR(ELEM_TYPE,Z,CENTER,1.D0)
      WRITE(LDEV2) STRESS,STRAIN,STRELA,CENTER,WORK,IYIELD
      RETURN
C
C ================= E N T R Y    M I S E S 1 ==========================
C
      ENTRY MISES1(ELNUM,ELEM_TYPE,MATNUM,INTGPN,STRS_STRN_REL,IEND)
      IYIELD = ' '
      IF (INCREM.GT.1) THEN
        IF (NIT.EQ.1) THEN
          READ(LDEV1) STRESS,STRAIN,STRELA,CENTER,WORK,IYIELD
        ELSE
          READ(LDEV2) STRESS,STRAIN,STRELA,CENTER,WORK,IYIELD
        END IF
        BACKSPACE(UNIT=LDEV)
      END IF
C
C --- GET THE MATERIAL PARAMETERS
C
        C2 = P2X( MATNUM )
        C3 = P1Y( MATNUM )
        SY = P1Z( MATNUM )
        BETA = P1X( MATNUM )
        YOUNG = EX( MATNUM )
        POISS = NUX( MATNUM )
      IF (IYIELD.EQ.'Y') THEN
C
C --- CALCULATION OF THE USEFUL MATRICES
C
        CALL TENSOR(ELEM_TYPE,STRESS,S0,1.D0)
        CALL TENSOR(ELEM_TYPE,STRAIN,E,0.5D0)
        CALL TENSOR(ELEM_TYPE,CENTER,Z,1.D0)
        DO K1 = 1 , 3
          DO K2 = 1 , 3
            C(K1 , K2) = 2.D0*E(K1 , K2) + DEL(K1 , K2)
          END DO
        END DO
C
C --- CALCULATION OF THE FOURTH ORDER ELASTIC STIFFNESS MATRIX
C
        CALL ADMAT(YOUNG,POISS)
C
C --- CALCULATION OF THE JACOBIAN OF DEFORMATION
C
        CALL DEFJAC(E,DEL,RR,DJAC)
C
C --- CALCULATION OF THE YIELD FUNCTION
C
        CALL YIELD(S0,C,Z,WORK,DJAC,C2,C3,SY,F,F1,F2)        
C
C --- CALCULATION OF THE PARTIAL DERIVATIVE OF THE YIELD FUNCTION
C --- F WITH RESPECT TO THE <STRESS>,<STRAIN>, THE JACOBIAN.
C
        CALL FDER(S0,C,Z,DJAC,F1,F2,C2,C3)
C
C --- CALCULATION OF THE ELASTOPLASTIC STIFFNESS MATRIX
C
        CALL ELPLD(S0,Z,RR,DJAC,BETA,DEN,0)
C
C --- CONVERSION OF THE FORTH ORDER STIFFNESS TENSOR TO A SECOND
C --- ORDER TENSOR
C
        CALL CONVER(DEPM,DEP,STRS_STRN_REL,ELEM_TYPE)
      ELSE
        CALL DELAST(ELEM_TYPE,MATNUM,STRS_STRN_REL)
      END IF
C     
      END
C
C ====================================================================
C ========================= T E N S O R ==============================
C ====================================================================
C
      SUBROUTINE TENSOR(ELEM_TYPE,VECT,TENS,FACT)
C                              
C ====================================================================
C I                                                                  I
C I     THIS PROGRAM CALCULATES MATRICES WHICH ARE COMMON IN         I
C I     MOST OF THE SUBROUTINES THAT CONSTITUTE THE PLASTICITY       I
C I     FORMULATIONS.                                                I
C I                                                                  I
C I       VECT( I )   = VECTOR TO BE CONVERTED TO A TENSOR           I
C I       TENS(I , J) = TENSOR EQUIVALENT OF VECT(I)                 I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      REAL*8 VECT(6),TENS(3,3),FACT
      INTEGER ELEM_TYPE
C
      TENS(1 , 1) = VECT( 1 )
      TENS(2 , 2) = VECT( 2 )
      IF (ELEM_TYPE.LT.300) THEN
        TENS(3 , 3) = VECT( 4 )
        TENS(1 , 2) = VECT( 3 )*FACT
        TENS(2 , 1) = TENS(1 , 2)
        TENS(1 , 3) = 0.D0
        TENS(3 , 1) = 0.D0
        TENS(2 , 3) = 0.D0
        TENS(3 , 2) = 0.D0
      ELSE
        TENS(3 , 3) = VECT( 3 )
        TENS(1 , 2) = VECT( 4 )*FACT
        TENS(2 , 1) = TENS(1 , 2)
        TENS(1 , 3) = VECT( 6 )*FACT
        TENS(3 , 1) = TENS(1 , 3)
        TENS(2 , 3) = VECT( 5 )*FACT
        TENS(3 , 2) = TENS(2 , 3)
      END IF
C
      END
C
C ====================================================================
C ========================= V E C T O R ==============================
C ====================================================================
C
      SUBROUTINE VECTOR(ELEM_TYPE,TENS,VECT,FACT)
C
C ====================================================================
C I                                                                  I
C I     THIS PROGRAM CALCULATES MATRICES WHICH ARE COMMON IN         I
C I     MOST OF THE SUBROUTINES THAT CONSTITUTE THE PLASTICITY       I
C I     FORMULATIONS.                                                I
C I                                                                  I
C I       TENS(I , J) = TENSOR TO BE CONVERTED TO A VECTOR           I
C I       VECT( I )   = VECTOR EQUIVALENT OT TENS(I , J)             I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      REAL*8 VECT(6),TENS(3,3),FACT
      INTEGER ELEM_TYPE
C
      VECT( 1 ) = TENS(1 , 1)
      VECT( 2 ) = TENS(2 , 2)
      IF (ELEM_TYPE.LT.300) THEN
        VECT( 4 ) = TENS(3 , 3)
        VECT( 3 ) = TENS(1 , 2)*FACT
      ELSE
        VECT( 3 ) = TENS(3 , 3)
        VECT( 4 ) = TENS(1 , 2)*FACT
        VECT( 6 ) = TENS(1 , 3)*FACT
        VECT( 5 ) = TENS(2 , 3)*FACT
      END IF
C
      END
C
C =====================================================================
C ========================= A D M A T =================================
C =====================================================================
C
      SUBROUTINE ADMAT(YOUNG,POISS)
C
C ====================================================================
C I                                                                  I
C I   P R O G R A M:                                                 I
C I                                                                  I
C I   'ADMAT' CALCULATES THE FOURTH ORDER ELASTIC STRESS-STRAIN      I
C I   TENSOR.                                                        I
C I                                                                  I
C I   A R G U M E N T     L I S T:                                   I
C I                                                                  I
C I   YOUNG  = YOUGS MODULUS                                         I
C I   POISS  = POISSONS RATIO                                        I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      REAL*8 ALAM,AMUE,POISS,YOUNG,AD
      COMMON/ADMAT1/AD(3,3,3,3)
C
C --- ALAM =  THE LAMDA LAME CONSTANT
C --- AMUE =  THE MU LAME CONSTANT (THE SHEAR MODULUS G)
C
      ALAM=POISS*YOUNG/(1.D0+POISS)/(1.D0-2.D0*POISS)
      AMUE = YOUNG/2.D0/(1.D0 + POISS)
      AD(1 , 1 , 1 , 1) = ALAM + 2.D0*AMUE
      AD(1 , 1 , 2 , 2) = ALAM
      AD(1 , 1 , 3 , 3) = ALAM
      AD(2 , 2 , 1 , 1) = ALAM
      AD(2 , 2 , 2 , 2) = ALAM + 2.D0*AMUE
      AD(2 , 2 , 3 , 3) = ALAM
      AD(3 , 3 , 1 , 1) = ALAM
      AD(3 , 3 , 2 , 2) = ALAM
      AD(3 , 3 , 3 , 3) = ALAM + 2.D0*AMUE
      AD(1 , 2 , 1 , 2) = AMUE
      AD(2 , 1 , 2 , 1) = AMUE
      AD(1 , 3 , 1 , 3) = AMUE
      AD(3 , 1 , 3 , 1) = AMUE
      AD(2 , 3 , 2 , 3) = AMUE
      AD(3 , 2 , 3 , 2) = AMUE
      AD(1 , 2 , 2 , 1) = AMUE
      AD(2 , 1 , 1 , 2) = AMUE
      AD(1 , 3 , 3 , 1) = AMUE
      AD(3 , 1 , 1 , 3) = AMUE
      AD(2 , 3 , 3 , 2) = AMUE
      AD(3 , 2 , 2 , 3) = AMUE
C
      END
C
C =====================================================================
C ========================= D E F J A C ===============================
C =====================================================================
C
      SUBROUTINE DEFJAC(E,DEL,RR,DJAC)
C
C ====================================================================
C I                                                                  I
C I        THIS SUBPROGRAM CALCULATES THE DETERMINANT OF THE         I
C I        DEFORMATION JACOBIAN AND THE <RR> MATRIX.                 I
C I                                                                  I
C I        EINV1     = FIRST STRAIN INVARIANT                        I
C I        EINV2     = SECOND STRAIN INVARIANT                       I
C I        EINV3     = THIRD STRAIN INVARIANT                        I
C I        DJAC      = DETERMINANT OF THE JACOBIAN                   I
C I        RR(K1 , K2) = THIS MATRIX WHEN DOTTED WITH THE STRAIN     I
C I                    TENSOR WILL RESULT IN THE INCREMENT OF THE    I
C I                    JACOBIAN.                                     I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      REAL*8 E(3,3),DEL(3,3),RR(3,3),C23,CST1,DELTA,DJAC,DJAC1,EINV1
      REAL*8 EINV2,EINV3
      INTEGER I_GRAPH,I_IN,I_OUT,K1,K2,K3
      COMMON/IN_IO/I_OUT,I_IN,I_GRAPH
C
C --- CALCULATION OF THE STRAIN INVARIANTS
C
      EINV1 = 0.D0
      EINV2 = 0.D0
      EINV3 = 0.D0
      DO K1=1,3
        EINV1=EINV1+E(K1,K1)
        DO K2=1,3
          EINV2=EINV2+E(K1,K2)**2
          DO K3=1,3
            EINV3=EINV3+E(K1,K2)*E(K2,K3)*E(K3,K1)
          END DO
        END DO
      END DO
      EINV2 = 0.5D0*EINV2
      EINV3 = 0.3333333333333333D0*EINV3
C
C --- CALCULATION OF THE DEFORMATION JACOBIAN DETERMINANT
C
      C23 = 0.66666666666666666D0
      DJAC1=1.D0+2.D0*EINV1*(1.D0+EINV1+C23*EINV1**2)-
     .      4.D0*EINV2*(1.D0+2.D0*EINV1)+8.D0*EINV3
      IF (DJAC1.LT.0.D0) THEN
        WRITE(I_OUT,'(1X,''INVALID DEFORMATION JACOBIAN DETERMINANT'',
     .        G10.3)')DJAC1
        STOP 'INVALID DEFORMATION JACOBIAN DETERMINANT'
      ENDIF
      DJAC = DJAC1**(0.5D0)
C
C --- CALCULATION OF THE MATRIX RR(K1 , K2)
C
      DO K1=1,3
        DO K2=1,K1
          CST1=0.D0
          DO K3=1,3
            CST1 = CST1+E(K1,K3)*E(K3,K2)
          END DO
          DELTA = DEL(K1,K2)
          RR(K1,K2)=2.D0*(DELTA*(EINV1-2.D0*EINV2+EINV1**2)-(1.D0
     .              +2.D0*EINV1)*E(K1,K2)+2.D0*CST1+0.5D0*DELTA)/DJAC
          RR(K2,K1)=RR(K1,K2)
        END DO
      END DO    
C      
      END
C
C =====================================================================
C =========================== Y I E L D ===============================
C =====================================================================
C
      SUBROUTINE YIELD(S,C,Z,WORK,DJAC,C2,C3,SY,F,F1,F2)
C
C =====================================================================
C I                                                                   I
C I    THIS SUBPROGRAM CALCULATES THE VALUE OF THE YIELD FUNCTION.    I
C I    THE PROGRAMED YIED FUNCTION IS AN EXTENDE FORM OF THE          I
C I    VON MISES YIELD CRITERION. THIS YIELD FUNCTION IS THE          I
C I    EQUIVALANT LAGRANGIAN FORMULATION OF THE EULERIAN VON MISES    I
C I    TYPE YIELD CRITERIA.                                           I
C I                                                                   I
C I    THE YIELD FUNCTION HAS THE FOLLOWING FORM.                     I
C I                                                                   I
C I        F = (F1)+(C2)(F2)+(C3)(F3)-AKEY**2                         I
C I                                                                   I
C I    C2        KINEMATIC WORK-HARDENING COEFFECIENT                 I
C I    C3        IS THE ISOTROPIC WORKHARDENING COEFFECIENT           I
C I    SY        IS THE YIELD STRESS IN SIMPLE TENSION TEST           I
C I    F1        IS THE SECOUND EULERIAN STRESS TENSOR INVAR.         I
C I    F2        IS THE PART WHICK ACOUNTS FOR THE KINAMATIC WORK     I
C I                HARDENING.                                         I
C I    F3        IS THE PLASTIC WORK.                                 I
C I                                                                   I
C I    FOR DEFENITION OF THE OTHER TERMS AND MATRICES REFER TO THE    I
C I    SUBPROGRAMS "JACOB" AND "MATRIC".                              I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      REAL*8 S(3,3),C(3,3),Z(3,3),C13,C16,C2,C3,CST,CST1,CST2,CST3
      REAL*8 CST4,CST5,DJAC,DJACO,F,F1,F2,F3,SY,WORK
      INTEGER K1,K2,K3,K4
C
      DJACO = 1./DJAC**2
      CST1 = 0.D0
      CST2 = 0.D0
      CST3 = 0.D0
      CST4 = 0.D0
      CST5 = 0.D0
      DO K2 = 1 , 3
        DO K1 = 1 , 3
          CST1 = CST1+S(K1 , K2)*C(K1 , K2)
          CST2 = CST2+Z(K1 , K2)*C(K1 , K2)
          DO K4 = 1 , 3
            DO K3 = 1 , 3
              CST = C(K1 , K3)*C(K2 , K4)
              CST3 = CST3+S(K1 , K2)*S(K3 , K4)*CST
              CST4 = CST4+S(K1 , K2)*Z(K3 , K4)*CST
              CST5 = CST5+Z(K1 , K2)*Z(K3 , K4)*CST
            END DO
          END DO
        END DO
      END DO
      C13 = 0.3333333333333333D0
      C16 = 0.1666666666666666D0
      F1 = DJACO*(0.5D0*CST3-C16*CST1**2)
      F2 = DJACO*(C13*CST1*CST2-CST4+0.5D0*CST5-C16*CST2**2)
      F3 = -WORK
      F = F1+C2*F2+C3*F3-SY**2
C
      END
C
C ====================================================================
C ========================= F D E R ==================================
C ====================================================================
C
      SUBROUTINE FDER(S,C,Z,DJAC,F1,F2,C2,C3)
C
C ====================================================================
C I                                                                  I
C I       THIS PROGRAM CALCULATES THE DERIVATIVE OF "F" WRT          I
C I       <STRESS>, <STRAIN>, JACOBIAN, AND PLASTIC WORD WKC         I
C I                                                                  I
C I       F1S =  PARTIAL DERIVATIVE OF F1 WRT <STRESS>               I
C I       F2S =  PARTIAL DERIVATIVE OF F2 WRT <STRESS>               I
C I       F1E =  PARTIAL DERIVATIVE OF F1 WRT <STRAIN>               I
C I       F2E =  PARTIAL DERIVATIVE OF F2 WRT <STRAIN>               I
C I       F1J =  PARTIAL DERIVATIVE OF F1 WRT JACOBIAN               I
C I       F2J =  PARTIAL DERIVATIVE OF F2 WRT JACOBIAN               I
C I       F3J =  PARTIAL DERIVATIVE OF F3 WRT JACOBIAN               I
C I                                                                  I
C I       FOR THE DEFENITIONS OF F1,F2 REFER TO THE                  I
C I       SUBPROGTAM "YIELD".                                        I
C I                                                                  I
C I                                                                  I
C I       FS = DERIVATIVE OF F WRT <STRESS>                          I
C I       FE = DERIVATIVE OF F WRT <STRAIN>                          I
C I       FZ = DERIVATIVE OF F WRT <SHIFT TENSOR>                    I
C I       FK = DERIVATIVE OF F WRT WK                                I
C I       FJ = DERIVATIVE OF F WRT JACOBIAN                          I
C I                                                                  I
C I       FOR THE DEFENITION OF THE OTHER TERMS OR MATRICES REFER    I
C I       TO SUBPROGRAMS "JACOB" AND "MATRIC".                       I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      REAL*8 S(3,3),C(3,3),Z(3,3),C12,C2,C3,C34,CONST,CST1,CST2,CST3
      REAL*8 CST4,CST5,CST6,CST7,DJAC,DJACO,F1,F1E,F1J,F1S,F2,F2E,F2J
      REAL*8 F2S,F2Z,FJ,FK,S12,FE,FS,FZ
      INTEGER K1,K2,K3,K4
      COMMON/FDER1/FJ,FK,FS(3,3),FE(3,3),FZ(3,3)
C      
      DJACO = 1.D0/DJAC**2
      CONST = 0.3333333333333333D0
      CST1 = 0.D0
      CST2 = 0.D0
      DO K2 = 1 , 3
        DO K1 = 1 , 3
          CST1 = CST1 + S(K1 , K2)*C(K1 , K2)
          CST2 = CST2 + Z(K1 , K2)*C(K1 , K2)
        END DO
      END DO
      DO K1 = 1 , 3
        DO K2 = 1 , K1
          CST3 = 0.D0
          CST4 = 0.D0
          CST5 = 0.D0
          CST6 = 0.D0
          CST7 = 0.D0
          DO K3 = 1 , 3
            DO K4 = 1 , 3
              C34 = C(K3 , K4)
              CST3 = CST3 + S(K3 , K1)*S(K4 , K2)*C34
              CST4 = CST4 + C(K1 , K3)*C(K2 , K4)*S(K3 , K4)
              CST5 = CST5 + Z(K3 , K1)*Z(K4 , K2)*C34
              CST6 = CST6 + S(K3 , K1)*Z(K4 , K2)*C34
              CST7 = CST7 + C(K1 , K3)*C(K2 , K4)*Z(K3 , K4)
            END DO
          END DO
          C12 = C(K1 , K2)
          S12 = S(K1 , K2)
          F1S = CST4 - CONST*CST1*C12
          F1E = CST3 - CONST*CST1*S12
          F2S = CONST*CST2*C12 - CST7
          F2Z = CST7 - CST4 + CONST*(CST1 - CST2)*C12
          F2E = CST5 - 2.D0*CST6 + CONST*((CST1 - CST2)
     #          *Z(K1 , K2) + CST2*S12)
          FS(K1 , K2) = DJACO*(F1S + C2*F2S)
          FE(K1 , K2) = 2.D0*DJACO*(F1E + C2*F2E)
          FZ(K1 , K2) = C2*F2Z*DJACO
          FS(K2 , K1) = FS(K1 , K2)
          FE(K2 , K1) = FE(K1 , K2)
          FZ(K2 , K1) = FZ(K1 , K2)
        END DO
      END DO
      F1J = -2.D0*F1/DJAC
      F2J = -2.D0*F2/DJAC
      FJ = F1J+C2*F2J
      FK = -C3
C
      END
C
C =====================================================================
C ======================== E L P L D ==================================
C =====================================================================
C
      SUBROUTINE ELPLD(S,Z,RR,DJAC,BETA,DEN,ICODE)
C
C =====================================================================
C I                                                                   I
C I        THIS PROGRAM CALCULATES THE ELASTOPLASTIC MATRIX           I
C I        THAT CORRESPONDS TO THE YIELD FUNCTION F                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      REAL*8 EFF(3,3),S(3,3),Z(3,3),RR(3,3),BETA,CST2,CST3,D1,D2,D3,DEN
      REAL*8 DEN1,DEN2,DJAC,FJ,FK,AD,ALAM,AMU,DEPM,FE,FS,FZ
      INTEGER ICODE,K1,K2,K3,K4
      COMMON/FDER1/FJ,FK,FS(3,3),FE(3,3),FZ(3,3)
      COMMON/ADMAT1/AD(3,3,3,3)
      COMMON/ELPLD1/DEPM(3,3,3,3),ALAM(3,3),AMU(3,3)
C      
      D1 = 0.D0
      D2 = 0.D0
      D3 = 0.D0
      DEN1 = 0.D0
      DEN2 = 0.D0
      DO K1 = 1 , 3
        DO K2 = 1 , 3
          EFF(K1 , K2) = 0.D0
          D1 = D1 + FZ(K1 , K2)*(S(K1 , K2) - Z(K1 , K2))
          D2 = D2 + FS(K1 , K2)**2
          D3 = D3 + (S(K1 , K2) - Z(K1 , K2))*FS(K1 , K2)
          DEN2 = DEN2+S(K1 , K2)*FS(K1 , K2)
          DO K3 = 1 , 3
            DO K4 = 1 , 3
              EFF(K1 , K2) = EFF(K1 , K2) + AD(K3 , K4 , K1 , K2)*
     .                       FS(K3 , K4)
            END DO
          END DO  
          DEN1 = DEN1 + EFF(K1 , K2)*FS(K1 , K2)
        END DO
      END DO
      DEN = DEN1 - DEN2*FK/DJAC - BETA*D1*D2/D3
      IF (ICODE.EQ.0) THEN
        DO K1 = 1 , 3
          DO K2 = 1 , K1
            CST3 = 0.D0
            DO K3 = 1 , 3
              DO K4 = 1 , 3
                CST3 = CST3 + AD(K1 , K2 , K3 , K4)*FS(K3 , K4)
              END DO
            END DO
            DO K3 = 1 , 3
              DO K4 = 1 , 3
                CST2 = CST3*(FE(K3 , K4) + FJ*RR(K3 , K4) + 
     .                 EFF(K3 , K4))
                DEPM(K1 , K2 , K3 , K4) = AD(K1 , K2 , K3 , K4) - 
     .                                    CST2/DEN
                DEPM(K2 , K1 , K3 , K4) = DEPM(K1 , K2 , K3 , K4)
              END DO
            END DO
          END DO
        END DO        
      ELSE
        DO K1 = 1 , 3
          DO K2 = 1 , K1
            ALAM(K1,K2)=(EFF(K1,K2) + FE(K1 , K2) + RR(K1 , K2)*FJ)/DEN
            AMU(K1 , K2) = ALAM(K1 , K2)*BETA*D2/D3
            ALAM(K2 , K1) = ALAM(K1 , K2)
            AMU(K2 , K1) = AMU(K1 , K2)
          END DO
        END DO
      END IF
C
      END
C
C =====================================================================
C ========================= C O N V E R ===============================
C =====================================================================
C
      SUBROUTINE CONVER(D4,D2,STRS_STRN_REL,ELEM_TYPE)
C
C ====================================================================
C I                                                                  I
C I        THIS PROGRAM TRANSFORMS THE FOURTH ORDER STIFFNESS        I
C I        TENSOR TO A SECOND ORDER MATRIX                           I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      INTEGER ELEM_TYPE,K1
      REAL*8 D4(3,3,3,3),D2(6,6),CST1,CST2,CST3
C
C     D2 = THE SECOND ORDER STIFFNESS MATRIX
C
      IF (ELEM_TYPE.LT.300) THEN
        D2(1,1) = D4(1,1,1,1)
        D2(1,2) = D4(1,1,2,2)
        D2(1,3) = D4(1,1,1,2)
        D2(1,4) = D4(1,1,3,3)
        D2(2,1) = D4(2,2,1,1)
        D2(2,2) = D4(2,2,2,2)
        D2(2,3) = D4(2,2,1,2)
        D2(2,4) = D4(2,2,3,3)
        D2(3,1) = D4(1,2,1,1)
        D2(3,2) = D4(1,2,2,2)
        D2(3,3) = D4(1,2,1,2)
        D2(3,4) = D4(1,2,3,3)
        D2(4,1) = D4(3,3,1,1)
        D2(4,2) = D4(3,3,2,2)
        D2(4,3) = D4(3,3,1,2)
        D2(4,4) = D4(3,3,3,3)
        IF(STRS_STRN_REL.NE.PLANE_STRESS) RETURN
        CST1 = D4(3,3,1,1)/D4(3,3,3,3)
        CST2 = D4(3,3,2,2)/D4(3,3,3,3)
        CST3 = (D4(3,3,1,2)+D4(3,3,2,1))/D4(3,3,3,3)/2.D0
        D2(1,1) = D2(1,1)-CST1*D4(1,1,3,3)
        D2(1,2) = D2(1,2)-CST2*D4(1,1,3,3)
        D2(1,3) = D2(1,3)-CST3*D4(1,1,3,3)
        D2(2,1) = D2(2,1)-CST1*D4(2,2,3,3)
        D2(2,2) = D2(2,2)-CST2*D4(2,2,3,3)
        D2(2,3) = D2(2,3)-CST3*D4(2,2,3,3)
        D2(3,1) = D2(3,1)-CST1*D4(1,2,3,3)
        D2(3,2) = D2(3,2)-CST2*D4(1,2,3,3)
        D2(3,3) = D2(3,3)-CST3*D4(1,2,3,3)
        DO K1 = 1,4
          D2(4,K1) = 0.D0
          D2(K1,4) = 0.D0
        END DO
      ELSE
        D2(1,1) = D4(1,1,1,1)
        D2(1,2) = D4(1,1,2,2)
        D2(1,3) = D4(1,1,3,3)
        D2(1,4) = D4(1,1,1,2)
        D2(1,5) = D4(1,1,2,3)
        D2(1,6) = D4(1,1,1,3)
        D2(2,1) = D4(2,2,1,1)
        D2(2,2) = D4(2,2,2,2)
        D2(2,3) = D4(2,2,3,3)
        D2(2,4) = D4(2,2,1,2)
        D2(2,5) = D4(2,2,2,3)
        D2(2,6) = D4(2,2,1,3)
        D2(3,1) = D4(3,3,1,1)
        D2(3,2) = D4(3,3,2,2)
        D2(3,3) = D4(3,3,3,3)
        D2(3,4) = D4(3,3,1,2)
        D2(3,5) = D4(3,3,2,3)
        D2(3,6) = D4(3,3,1,3)
        D2(4,1) = D4(1,2,1,1)
        D2(4,2) = D4(1,2,2,2)
        D2(4,3) = D4(1,2,3,3)
        D2(4,4) = D4(1,2,1,2)
        D2(4,5) = D4(1,2,2,3)
        D2(4,6) = D4(1,2,1,3)
        D2(5,1) = D4(2,3,1,1)
        D2(5,2) = D4(2,3,2,2)
        D2(5,3) = D4(2,3,3,3)
        D2(5,4) = D4(2,3,1,2)
        D2(5,5) = D4(2,3,2,3)
        D2(5,6) = D4(2,3,1,3)
        D2(6,1) = D4(1,3,1,1)
        D2(6,2) = D4(1,3,2,2)
        D2(6,3) = D4(1,3,3,3)
        D2(6,4) = D4(1,3,1,2)
        D2(6,5) = D4(1,3,2,3)
        D2(6,6) = D4(1,3,1,3)
      END IF
C  
      END
C
C =====================================================================
C ======================= C O M P R O =================================
C =====================================================================
C
      SUBROUTINE COMPRO(BUFFER,BUFF,COMM,NEXT,K)
      IMPLICIT NONE
      CHARACTER*80 BUFFER,BUFF
      CHARACTER HT,CURRCHAR,NEXTCHAR,EOF
      CHARACTER*4 COMM
      INTEGER STR$FIND_FIRST_IN_SET,STR$FIND_FIRST_NOT_IN_SET
      INTEGER IBEGIN,ICOMM2,ICONT,INB,INE,INUMB,ISPACE,ISTART,K,NEXT
C
C =========================================================================
C I   NOTE: THIS COMMAND LINE INTERPERTER ASSUMES THAT COMMAND NAMES DO   I
C I   NOT CONTAIN ANY OF THE FOLLOWING CHARACTERS '.,+-0123456789'.       I
C I   REAL NUMBERS CAN BE ENTERED USING AN 'F' OR 'E' FORMAT WITH         I
C I   "D" OR "E" EXPONENT NOTATION. COMMANDS MUST BE SEPERATED FROM       I
C I   THEIR NUMERIC ARGUMENTS WITH WHITE SPACE (I.E. BLANK SPACE OR       I
C I   TAB CHARACTER). NUMERIC ARGUMENTS CAN BE SEPERATED BY WHITE         I
C I   SPACE OR COMMA. ADDITIONALLY COMMANDS MUST BE SEPERATED FROM        I
C I   PREVIOUS COMMAND W/ W/O ARGUMENTS WITH WHITE SPACE.                 I
C I   SPECIAL NOTE: COMMANDS THAT DO NOT HAVE NUMERIC ARGUMENTS CANNOT    I
C I   BE FOLLOWED BY ADDITIONAL COMMENTS UNLESS CONCATANATED WITH THE     I
C I   THE COMMAND WITH SOME CHARACTER THAT WILL NOT LEAVE WHITE SPACE     I
C I   BETWEEN THE COMMAND AND THE COMMENTS (E.G. THE UNDERSCORE)          I
C =========================================================================
C
      HT=CHAR(9)
      EOF=CHAR(26)
      NEXT=0
      COMM=' '
      IBEGIN=STR$FIND_FIRST_NOT_IN_SET(BUFFER(K:),' '//HT)
      IF(IBEGIN.EQ.0) THEN                       ! BLANK LINE
        COMM='BLAN'
        RETURN
      ENDIF
      IF(BUFFER(IBEGIN:IBEGIN).EQ.EOF) THEN      ! End of File
        COMM='ENDF'
        RETURN
      ENDIF
      ISTART=K+IBEGIN-1
      ISPACE=STR$FIND_FIRST_IN_SET(BUFFER(ISTART:),' '//HT)
      IF(ISPACE.EQ.0) THEN
        COMM=BUFFER(ISTART:)
        RETURN ! COMMAND W/O ARG AT EOL
      ENDIF
      ISPACE=ISTART+ISPACE-1
      COMM=BUFFER(ISTART:ISPACE)
      ICOMM2=STR$FIND_FIRST_NOT_IN_SET(BUFFER(ISPACE:),' '//HT)
      IF(ICOMM2.EQ.0) RETURN ! COMMAND W/O ARG AT EOL
      ICOMM2=ICOMM2+ISPACE-1
      K=ICOMM2
      BUFF=BUFFER(ICOMM2:)
      CURRCHAR=BUFFER(ICOMM2:ICOMM2)
      INUMB=STR$FIND_FIRST_IN_SET(CURRCHAR,'+-.,0123456789')
      IF(INUMB.EQ.0) THEN ! PERFORM FURTHER PARSING IN ROUTINES INPUT & GRAPHIX
        NEXT=1
        RETURN
      ELSE
        INB=ICOMM2
100     INE=STR$FIND_FIRST_NOT_IN_SET(BUFFER(INB:),
     .                                 ' ,.+-0123456789'//HT)
        IF(INE.EQ.0) RETURN          ! NOTHING FOLLOWS CMD W/ NUM ARGUMENT
        INB=INB+INE
        CURRCHAR=BUFFER(INB-1:INB-1)
        NEXTCHAR=BUFFER(INB:INB)
        ICONT=STR$FIND_FIRST_IN_SET(NEXTCHAR,'+-0123456789')
        IF((CURRCHAR .EQ. 'D' .OR. CURRCHAR .EQ. 'E') .AND. 
     .        ICONT .NE.0) GOTO 100
        NEXT=1
        RETURN
      ENDIF
C
      END
C
C =====================================================================
C ======================= C O M P R O 1 ===============================
C =====================================================================
C
      SUBROUTINE COMPRO1(BUFF,IPOS,MORE)
      IMPLICIT NONE
      CHARACTER*80 BUFF,TMPSTR
      CHARACTER CURRCHAR,NEXTCHAR,HT
      INTEGER STR$FIND_FIRST_IN_SET,STR$FIND_FIRST_NOT_IN_SET
      INTEGER STR$LENGTH,IEXP,INUMB,INUME,IPOS,MORE,MORER
C
C =========================================================================
C I   ADDITION TO COMMAND PROCEDURE TO FURTHER PARSE COMMAND THAT CONTAINSI
C I   ADDITIONAL TEXT BETWEEN THE COMMAND AND ITS NUMERIC ARGUMENT.       I
C =========================================================================
C
      HT=CHAR(9)
      MORE=0
      MORER=0
      INUMB=STR$FIND_FIRST_IN_SET(BUFF,'.+-0123456789')
      MORE=STR$FIND_FIRST_NOT_IN_SET(BUFF(INUMB:),' .+-0123456789'//HT)
      IF(MORE.EQ.0) THEN
        TMPSTR=BUFF(INUMB:)
        BUFF=TMPSTR
        RETURN
      ELSE
        INUME=INUMB+MORE-1
        CURRCHAR=BUFF(INUME:INUME)
        NEXTCHAR=BUFF(INUME+1:INUME+1)
        IEXP=STR$FIND_FIRST_IN_SET(NEXTCHAR,'+-0123456789')
        IF((CURRCHAR .EQ. 'D' .OR. CURRCHAR .EQ. 'E') .AND. 
     .             IEXP .NE. 0) THEN
          MORER=STR$FIND_FIRST_NOT_IN_SET(
     .                  BUFF(INUME+1:),' .+-0123456789'//HT)
          IF(MORER.EQ.0) THEN
            MORE=0
            INUME=INUME+STR$LENGTH(BUFF(INUME+1:))+1
          ELSE
            INUME=INUME+MORER
          ENDIF
        ENDIF
        TMPSTR=BUFF(INUMB:INUME-1)
        BUFF=TMPSTR
        IPOS=IPOS+INUME-1
      ENDIF
C
      END
C
C =====================================================================
C ======================== I N P U T ==================================
C =====================================================================
C
      SUBROUTINE INPUT(IDOF)
C
C =====================================================================
C I                                                                   I
C I      SUBROUTINE INPUT READS ALL THE INPUT INFORMATION FROM        I
C I      CARD SETS 2 THROUGH 10. IT ALSO READS THE INFORMATION FROM   I
C I      THE PREVIOUS RUNS IF THE PROGRAM IS RESUBMITED.              I
C I                                                                   I
C I                                                                   I
C I                                                                   I
C =====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEMENTS,MAX_ELEM_NODES,MAX_MAT_TYPE
      INTEGER MAX_SKEW_BC,MAX_INTFAC_NODES,MNNDF,MAX_NODES_DOF
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAX_NODES=3000,MAX_ELEMENTS=400,MAX_ELEM_NODES=20,
     .           MAX_MAT_TYPE=10,MAX_SKEW_BC=300,MAX_INTFAC_NODES=500,
     .           MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      INTEGER ELEM_TYPE,DIVER_STOP,GRAPHICS_INTR,OUTPUT_INTR,IDIM,IDIR
      INTEGER STR$COMPRESS,STR$LENGTH,STR$COLLAPSE,I,ICNT,ICOMMENT,ID
      INTEGER IELEM,IELEM1,IEND,IETYPE,ILENTO,INCR,INCREMENTS,INTCOD
      INTEGER IPOS,ISTART,ITERATIONS,I_GRAPH,I_IN,I_OUT,J,K,K1,K2,LELEM
      INTEGER LINCI,LINES,LTEMP,MAT,MATNUM,MORE,N,N1,NDIVER,NELEM,NEXT
      INTEGER NINODE,NIP,NIPETA,NIPSI,NIPXI,NNDF,NNEL,NNODES,NODE,NUMBER
      INTEGER IDOF(*),INFOEL,INTFAC,ISPB,M(MAX_ELEM_NODES),MATYPE,NOP
      INTEGER LSTR1,LSTR2
      REAL*8 NUX,NUY,NUZ,CONV_FAC,CST,DX,DY,DZ,ENRG1,THICK,COSTX
      REAL*8 COSTY,COSTZ,DUMMY(6),EX,EY,EZ,P,P1X,P1Y,P1Z,P2X,P2Y,P2Z
      REAL*8 P3X,P4X,P5X,RX,RY,RZ,U,WGTX,WGTY,WGTZ
      REAL*4 X,Y,Z,PSXMIN,PSXMAX,PSYMIN,PSYMAX
      CHARACTER*80 BUFFER,BUFF,TITLE,SINCI
      CHARACTER*40 COMM*4,SELEM,STEMP,STR1,STR2
      LOGICAL LINEAR,RESTART,SYMMETRIC,GRAPHICS_OUT
C
C ==========================================================================
C I                                                                        I
C I   ALL INTERNAL FILE READS OF A SINGLE VARIABLE WERE CHANGED            I
C I   FROM '*' TO A FORMAT SPECIFICATION OF 'I20' OR 'G20.0' DEPENDING     I
C I   ON THE VARIABLE TYPE. THIS CAN ALSO BE CHANGED TO '*' IF THE         I
C I   COMPILER SUPPORTS LIST-DIRECTED I/O ON INTERNAL FILES.               I
C I                                                                        I
C I   FINAL NOTE: IF COMPLIED WITH NON LIST-DIRECTED INTERNAL FILE SUPPORT,I
C I   SEPERATE MULTIPLE NUMERIC FILEDS ON THE SAME INPUT LINE AS A COMMAND I
C I   WITH COMMAS.                                                         I
C ==========================================================================
C
C     COMMENTS CAN BE ADDED TO THE INPUT FILE BY PRECEEDING THEM WITH
C     THE TWO CHARACTER SEQUENCE '/*'.
C
      COMMON/MAIN1/U(MAX_NODES_DOF)
      COMMON/IN_IO/I_OUT,I_IN,I_GRAPH
      COMMON/INPUT1/NIPXI,NIPETA,NIPSI,NIP,INTCOD
      COMMON/INPUT2/NOP(MAX_ELEM_NODES,MAX_ELEMENTS)
      COMMON/INPUT3/X(MAX_NODES),Y(MAX_NODES),Z(MAX_NODES)
      COMMON/INPUT5/NUX(MAX_MAT_TYPE),NUY(MAX_MAT_TYPE),
     .              NUZ(MAX_MAT_TYPE),EX(MAX_MAT_TYPE),
     .              EY(MAX_MAT_TYPE),EZ(MAX_MAT_TYPE),
     .              P1X(MAX_MAT_TYPE),P1Y(MAX_MAT_TYPE),
     .              P1Z(MAX_MAT_TYPE),P2X(MAX_MAT_TYPE),
     .              P2Y(MAX_MAT_TYPE),P2Z(MAX_MAT_TYPE)
      COMMON/INPUT6/WGTX(MAX_MAT_TYPE),WGTY(MAX_MAT_TYPE),
     .              WGTZ(MAX_MAT_TYPE)
      COMMON/INPUT7/RX(MAX_NODES_DOF),RY(MAX_NODES_DOF),
     .              RZ(MAX_NODES_DOF)
      COMMON/INPUT8/NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,
     .              SYMMETRIC,IDIM,NINODE
      COMMON/INPUT9/THICK,STRS_STRN_REL
      COMMON/INPUTA/INFOEL(MAX_ELEMENTS)
      COMMON/INPUTB/CONV_FAC,ENRG1,NDIVER,DIVER_STOP
      COMMON/INPUTC/TITLE
      COMMON/INPUTD/COSTX(MAX_SKEW_BC),COSTY(MAX_SKEW_BC),
     .              COSTZ(MAX_SKEW_BC)
      COMMON/INPUTE/ISPB(MAX_NODES)
      COMMON/INPUTF/MATYPE(MAX_MAT_TYPE)
      COMMON/INPUTG/RESTART,OUTPUT_INTR,GRAPHICS_INTR,GRAPHICS_OUT
      COMMON/INPUTI/INTFAC(MAX_INTFAC_NODES)
      COMMON/INPUTJ/P3X(MAX_MAT_TYPE),P4X(MAX_MAT_TYPE),
     .              P5X(MAX_MAT_TYPE)
      COMMON/POINTS/P(4 , 2)
      COMMON/POSTS/PSXMIN,PSXMAX,PSYMIN,PSYMAX
C
      DATA MATNUM /1/
C
C       ICNT = COUTER FOR THE 'ISPB' ARRAY WHICH DETERMINES WHERE
C       TO LOOK FOR THE DIRECTION COSINES OF THE SKEW BOUNDARY IN
C       THE 'COSTX', 'COSTY' AND 'COSTZ' ARRAYS.
C
      ICNT = 1
C
C          READ THE COMMAND LINE BUFFER
C
  100 IPOS = 1
      READ(I_IN , 101 ,END=1000,ERR=2000) BUFFER
      ICOMMENT=INDEX(BUFFER,'/*')
      IF(ICOMMENT.NE.0) BUFFER(ICOMMENT:)=' '
      CALL STR$UPCASE(BUFFER,BUFFER)
      ILENTO=STR$COMPRESS(BUFFER,BUFFER)
  101 FORMAT(A80)
  105 CALL COMPRO(BUFFER,BUFF,COMM,N,IPOS)
      ASSIGN 100 TO NEXT
C
C          EXTRACT THE FIRST FOUR CHARACTERS OF THE BUFFER AND REPLACE
C          ALL OTHER CHARACERS BY A BLANK EXCEPT NUMBERS 1-9.
C
      IF (COMM.EQ.'TITL') THEN
        GO TO 200
      ELSE IF (COMM.EQ.'COOR'.OR.COMM.EQ.'NODE'.OR.COMM.EQ.'JOIN'
     .         .OR.COMM.EQ. 'NODA') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        GO TO 300
      ELSE IF (COMM.EQ.'MEMB'.OR.COMM.EQ.'INCI'.OR.COMM.EQ.'CONE') THEN
        IF(N.EQ.1) CALL COMPRO1(BUFF,IPOS,MORE)
        GO TO 400
      ELSE IF (COMM.EQ.'SKEW') THEN
        IF(N.EQ.1) CALL COMPRO1(BUFF,IPOS,MORE)
        GO TO 500
      ELSE IF (COMM.EQ.'DISP') THEN
        IF(N.EQ.1) CALL COMPRO1(BUFF,IPOS,MORE)
        GO TO 600
      ELSE IF (COMM.EQ.'LOAD') THEN
        IF(N.EQ.1) CALL COMPRO1(BUFF,IPOS,MORE)
        GO TO 700
      ELSE IF (COMM.EQ.'GRAP') THEN
        IF(N.EQ.1) CALL COMPRO1(BUFF,IPOS,MORE)
C       READ(BUFF , *, ERR = 2000) GRAPHICS_INTR
        READ(BUFF , '(I20)' , ERR = 2000) GRAPHICS_INTR
        GRAPHICS_OUT=.TRUE.
        CALL GRAPHX(I_IN,I_OUT)
        GO TO 100
      ELSE IF (COMM.EQ.'BOUN') THEN
        IF(N.EQ.1) CALL COMPRO1(BUFF,IPOS,MORE)
        GO TO 900
      ELSE IF (COMM.EQ.'MATE') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) MATNUM
        READ(BUFF , '(I20)' , ERR = 2000) MATNUM
        IF(MATNUM.GT.MAX_MAT_TYPE) THEN
          WRITE(STR1,'(I39)')MATNUM
          WRITE(STR2,'(I39)')MAX_MAT_TYPE
          LSTR1=STR$COLLAPSE(STR1,STR1)
          LSTR2=STR$COLLAPSE(STR2,STR2)
          WRITE(I_OUT,*)'NUMBER OF MATERIAL TYPES ('//STR1(:LSTR1)//
     .                  ') EXCEEDS ALLOWABLE (MAX_MAT_TYPE='//
     .                  STR2(:LSTR2)//'). PROGRAM TERMINATED'
          WRITE(*,*)'NUMBER OF MATERIAL TYPES ('//STR1(:LSTR1)//
     .                  ') EXCEEDS ALLOWABLE (MAX_MAT_TYPE='//
     .                  STR2(:LSTR2)//'). PROGRAM TERMINATED'
          STOP
        ENDIF
      ELSE IF (COMM.EQ.'STOP') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , END=2000) DIVER_STOP
        READ(BUFF , '(I20)' , END=2000) DIVER_STOP
      ELSE IF (COMM.EQ.'LINE') THEN
        IF(N.EQ.1) ASSIGN 105 TO NEXT
        LINEAR = .TRUE.
      ELSE IF (COMM.EQ.'NONL') THEN
        IF(N.EQ.1) ASSIGN 105 TO NEXT
        LINEAR = .FALSE.
      ELSE IF (COMM.EQ.'NONS') THEN
        IF(N.EQ.1) ASSIGN 105 TO NEXT
        SYMMETRIC = .FALSE.
      ELSE IF (COMM.EQ.'SYMM') THEN
        IF(N.EQ.1) ASSIGN 105 TO NEXT
        SYMMETRIC = .TRUE.
      ELSE IF (COMM.EQ.'IRON') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) INTCOD
        READ(BUFF , '(I20)' , ERR = 2000) INTCOD
      ELSE IF (COMM.EQ.'NIPX') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) NIPXI
        READ(BUFF , '(I20)' , ERR = 2000) NIPXI
        IF(NIPXI.GT.3) THEN
          WRITE(STR1,'(I39)')NIPXI
          LSTR1=STR$COLLAPSE(STR1,STR1)
          WRITE(I_OUT,*)'NIPXI='//STR1(:LSTR1)//' EXCEEDS ALLOWABLE '//
     .                  'VALUE OF 3. PROGRAM TERMINATED'
          WRITE(*,*)'NIPXI='//STR1(:LSTR1)//' EXCEEDS ALLOWABLE '
     .                  //'VALUE OF 3. PROGRAM TERMINATED'
          STOP
        ENDIF
      ELSE IF (COMM.EQ.'NIPE') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) NIPETA
        READ(BUFF , '(I20)' , ERR = 2000) NIPETA
        IF(NIPETA.GT.3) THEN
          WRITE(STR1,'(I39)')NIPETA
          LSTR1=STR$COLLAPSE(STR1,STR1)
          WRITE(I_OUT,*)'NIPETA='//STR1(:LSTR1)//' EXCEEDS ALLOWABLE '//
     .                  'VALUE OF 3. PROGRAM TERMINATED'
          WRITE(*,*)'NIPETA='//STR1(:LSTR1)//' EXCEEDS ALLOWABLE '
     .                  //'VALUE OF 3. PROGRAM TERMINATED'
          STOP
        ENDIF
      ELSE IF (COMM.EQ.'NIPS') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) NIPSI
        READ(BUFF , '(I20)' , ERR = 2000) NIPSI
        IF(NIPSI.GT.3) THEN
          WRITE(STR1,'(I39)')NIPSI
          LSTR1=STR$COLLAPSE(STR1,STR1)
          WRITE(I_OUT,*)'NIPSI='//STR1(:LSTR1)//' EXCEEDS ALLOWABLE '//
     .                  'VALUE OF 3. PROGRAM TERMINATED'
          WRITE(*,*)'NIPSI='//STR1(:LSTR1)//' EXCEEDS ALLOWABLE '
     .                  //'VALUE OF 3. PROGRAM TERMINATED'
          STOP
        ENDIF
      ELSE IF (COMM.EQ.'THIC') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) THICK
        READ(BUFF , '(G20.0)' , ERR = 2000) THICK
      ELSE IF (COMM.EQ.'DIME') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) IDIM
        READ(BUFF , '(I20)' , ERR = 2000) IDIM
        IF(IDIM.GT.3) THEN
          WRITE(STR1,'(I39)')IDIM
          LSTR1=STR$COLLAPSE(STR1,STR1)
          WRITE(I_OUT,*)'IDIM='//STR1(:LSTR1)//' EXCEEDS ALLOWABLE '//
     .                  'VALUE OF 3. PROGRAM TERMINATED'
          WRITE(*,*)'IDIM='//STR1(:LSTR1)//' EXCEEDS ALLOWABLE '
     .                  //'VALUE OF 3. PROGRAM TERMINATED'
          STOP
        ENDIF
        NNDF = IDIM
      ELSE IF (COMM.EQ.'ITER') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) ITERATIONS
        READ(BUFF , '(I20)' , ERR = 2000) ITERATIONS
      ELSE IF (COMM.EQ.'INCR') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) INCREMENTS
        READ(BUFF , '(I20)' , ERR = 2000) INCREMENTS
      ELSE IF (COMM.EQ.'CONV') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) CONV_FAC
        READ(BUFF , '(G20.0)' , ERR = 2000) CONV_FAC
      ELSE IF (COMM.EQ.'FACL') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        WRITE(I_OUT,*)' COMMAND: '//COMM//' IS UNSUPPORTED. IGNORED'
        PRINT*,' COMMAND: '//COMM//' IS UNSUPPORTED. IGNORED'
      ELSE IF (COMM.EQ.'FACH') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        WRITE(I_OUT,*)' COMMAND: '//COMM//' IS UNSUPPORTED. IGNORED'
        PRINT*,' COMMAND: '//COMM//' IS UNSUPPORTED. IGNORED'
      ELSE IF (COMM.EQ.'NU') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) NUX(MATNUM)
        READ(BUFF , '(G20.0)' , ERR = 2000) NUX(MATNUM)
      ELSE IF (COMM.EQ.'E') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) EX(MATNUM)
        READ(BUFF , '(G20.0)' , ERR = 2000) EX(MATNUM)
      ELSE IF (COMM.EQ.'WX') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) WGTX(MATNUM)
        READ(BUFF , '(G20.0)' , ERR = 2000) WGTX(MATNUM)
      ELSE IF (COMM.EQ.'WY') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF, * , ERR = 2000) WGTY(MATNUM)
        READ(BUFF, '(G20.0)' , ERR = 2000) WGTY(MATNUM)
      ELSE IF (COMM.EQ.'WZ') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) WGTZ(MATNUM)
        READ(BUFF , '(G20.0)' , ERR = 2000) WGTZ(MATNUM)
      ELSE IF (COMM.EQ.'TYPE') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) MATYPE( MATNUM )
        READ(BUFF , '(I20)' , ERR = 2000) MATYPE( MATNUM )
      ELSE IF(COMM.EQ.'YIEL') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P1Z( MATNUM )
        READ(BUFF , '(G20.0)' , ERR = 2000) P1Z( MATNUM )
      ELSE IF(COMM.EQ.'ISOT') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P1Y( MATNUM )
        READ(BUFF , '(G20.0)' , ERR = 2000) P1Y( MATNUM )
      ELSE IF(COMM.EQ.'KINE') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P1X( MATNUM )
        READ(BUFF , '(G20.0)' , ERR = 2000) P1X( MATNUM )
      ELSE IF(COMM.EQ.'BETA') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P2X( MATNUM )
        READ(BUFF , '(G20.0)' , ERR = 2000) P2X( MATNUM )
      ELSE IF(COMM.EQ.'DAMA') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P3X( MATNUM )
        READ(BUFF , '(G20.0)' , ERR = 2000) P3X( MATNUM )
      ELSE IF(COMM.EQ.'COEF') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P4X( MATNUM )
        READ(BUFF , '(G20.0)' , ERR = 2000) P4X( MATNUM )
      ELSE IF(COMM.EQ.'DBBE') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P5X( MATNUM )
        READ(BUFF , '(G20.0)' , ERR = 2000) P5X( MATNUM )
      ELSE IF(COMM.EQ.'REST') THEN
        IF(N.EQ.1) ASSIGN 105 TO NEXT
        RESTART = .TRUE.
      ELSE IF(COMM.EQ.'OUTP') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) OUTPUT_INTR
        READ(BUFF , '(I20)' , ERR = 2000) OUTPUT_INTR
      ELSE IF(COMM.EQ.'INTE') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        GO TO 1100
      ELSE IF (COMM.EQ.'PAX') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P(1 , 1)
        READ(BUFF , '(G20.0)' , ERR = 2000) P(1 , 1)
      ELSE IF(COMM.EQ.'PAY') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P(1 , 2)
        READ(BUFF , '(G20.0)' , ERR = 2000) P(1 , 2)
      ELSE IF(COMM.EQ.'PBX') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P(2 , 1)
        READ(BUFF , '(G20.0)' , ERR = 2000) P(2 , 1)
      ELSE IF(COMM.EQ.'PBY') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P(2 , 2)
        READ(BUFF , '(G20.0)' , ERR = 2000) P(2 , 2)
      ELSE IF(COMM.EQ.'RAX') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P(3 , 1)
        READ(BUFF , '(G20.0)' , ERR = 2000) P(3 , 1)
      ELSE IF(COMM.EQ.'RAY') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P(3 , 2)
        READ(BUFF , '(G20.0)' , ERR = 2000) P(3 , 2)
      ELSE IF(COMM.EQ.'RBX') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P(4 , 1)
        READ(BUFF , '(G20.0)' , ERR = 2000) P(4 , 1)
      ELSE IF(COMM.EQ.'RBY') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) P(4 , 2)
        READ(BUFF , '(G20.0)' , ERR = 2000) P(4 , 2)
      ELSE IF(COMM.EQ.'BLAN') THEN
        GOTO 100
      ELSE IF(COMM.EQ.'ENDF') THEN
        RETURN
      ELSE
        WRITE(I_OUT , 160) COMM
 160    FORMAT(1X,'COMMAND ''',A,''' IS NOT RECOGNIZED BY *DNA*')
        GO TO 2000
      END IF
      GO TO NEXT
C
C ----- READ THE TITLE OF THE PROGRAM (CARD SET1)
C
C 200 READ(BUFF , * , ERR = 2000) NUMBER
  200 READ(BUFF , '(I20)' , ERR = 2000) NUMBER
      DO K = 1 , NUMBER
        READ(I_IN , 101) TITLE
        WRITE(I_OUT , '(1X,A)') TITLE
      END DO
      GO TO NEXT
C                     
C ----- READ AND GENERATE THE NODAL COORDINATES
C
  300 I=0
C     READ(BUFF , * , ERR = 2000) NNODES
      READ(BUFF , '(I20)' , ERR = 2000) NNODES
      IF(NNODES.GT.MAX_NODES) THEN
        WRITE(STR1,'(I39)')NNODES
        WRITE(STR1,'(I39)')MAX_NODES
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'NUMBER OF NODES ('//STR1(:LSTR1)//') EXCEEDES '//
     .                'ALLOWABLE (MAX_NODES='//STR2(:LSTR2)//'). '//
     .                'PROGRAM TERMINATED'
        WRITE(*,*)'NUMBER OF NODES ('//STR1(:LSTR1)//') EXCEEDES '//
     .                'ALLOWABLE (MAX_NODES='//STR2(:LSTR2)//'). '//
     .                'PROGRAM TERMINATED'
        STOP
      ENDIF
  310 READ (I_IN , *,ERR=2000) K,(DUMMY( IDIR ) , IDIR = 1 , IDIM),INCR
      X( K ) = DUMMY( 1 )
      Y( K ) = DUMMY( 2 )
      Z( K ) = DUMMY( 3 )
      I=I+1
      IF (INCR.EQ.0) GO TO 330
      N=(K-K1)/INCR
      DX=(X(K)-X(K1))/N
      DY=(Y(K)-Y(K1))/N
      DZ=(Z(K)-Z(K1))/N
      K2=K-INCR
      DO J=K1,K2,INCR
        N1=(J-K1)/INCR
        X(J)=X(K1)+N1*DX
        Y(J)=Y(K1)+N1*DY
        Z(J)=Z(K1)+N1*DZ
        I=I+1
      END DO
      I=I-1
  330 K1=K
      IF(I.LT.NNODES) GO TO 310
      WRITE(I_OUT , 6009)
      PSXMIN=X(1)
      PSXMAX=X(1)
      PSYMIN=Y(1)
      PSYMAX=Y(1)
      DO K1 = 1 , NNODES
        PSXMIN=AMIN1(PSXMIN,X(K1))
        PSXMAX=AMAX1(PSXMAX,X(K1))
        PSYMIN=AMIN1(PSYMIN,Y(K1))
        PSYMAX=AMAX1(PSYMAX,Y(K1))
        WRITE(I_OUT , 5004)K1,X( K1 ),Y( K1 ),Z( K1 )
      END DO
      GO TO NEXT
C                                 
C ----- READ AND WRITE AND GENERATE THE ELEMENTS
C
  400 I = 0
C     READ(BUFF , * , ERR = 2000) NELEM
      READ(BUFF , '(I20)' , ERR = 2000) NELEM
      IF(NELEM.GT.MAX_ELEMENTS) THEN
        WRITE(STR1,'(I39)')NELEM
        WRITE(STR1,'(I39)')MAX_ELEMENTS
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'NUMBER OF ELEMENTS ('//STR1(:LSTR1)//') EXCEEDES'
     .                //' ALLOWABLE (MAX_ELEMENTS='//STR2(:LSTR2)//').'
     .                //' PROGRAM TERMINATED'
        WRITE(*,*)'NUMBER OF ELEMENTS ('//STR1(:LSTR1)//') EXCEEDES'
     .                //' ALLOWABLE (MAX_ELEMENTS='//STR2(:LSTR2)//').'
     .                //' PROGRAM TERMINATED'
        STOP
      ENDIF
  410 READ(I_IN ,*,ERR=2000) K,ELEM_TYPE,NNEL,(NOP(NODE,K),NODE=1,NNEL),
     .               MAT,INCR
      IETYPE=ELEM_TYPE
      STRS_STRN_REL = ELEM_TYPE/1000
      STRS_STRN_REL = ELEM_TYPE - STRS_STRN_REL*1000
      STRS_STRN_REL = STRS_STRN_REL/100
      ELEM_TYPE = ELEM_TYPE/1000
      ELEM_TYPE = ELEM_TYPE*100 + NNEL
      IF (ELEM_TYPE.LT.300) THEN
        IF (NNEL.EQ.4) THEN
          ISTART = 1
          LINES  = 4
        ELSE
          ISTART = 5
          LINES  = 8
        END IF
      ELSE IF(ELEM_TYPE.GT.300) THEN
        IF (NNEL.EQ.8) THEN
          ISTART = 13
          LINES  = 12
        ELSE IF(NNEL.EQ.20) THEN
          ISTART = 25
          LINES = 24
        END IF
      END IF
C
C     NOTE: INFOEL IS ASSUMED( AND MUST BE) AN INTEGER*4 ARRAY.
C     THE QUANITIES MAT,NNEL,ELEM_TYPE,STRS_STRN_REL,ISTART,AND LINES ARE
C     PACKED INTO EACH ELEMENT OF INFOEL ARRAY. THE PACKING
C     SEQUENCE IS AS FOLLOWS:
C         ITEM          BITS
C         -----         ----
C          MAT          0-2
C         NNEL          3-7
C         ELEM_TYPE     8-16
C         STRS_STRN_REL 17-19
C         ISTART        20-25
C         LINES         26-31
C
      I = I + 1
      INFOEL( K ) = MAT + NNEL*8 + ELEM_TYPE*256 + STRS_STRN_REL*131072
     .              + ISTART*1048576 + LINES*67108864
      IF(INCR.EQ.0) THEN
        K1 = K
      ELSE
        K2 = (K - K1)/INCR
        DO NODE = 1 , NNEL
          M( NODE ) = (NOP(NODE , K ) - NOP(NODE , K1))/K2
        END DO
        DO IELEM = K1+INCR , K-INCR , INCR
          INFOEL( IELEM ) = INFOEL( K )
          I = I + 1
          IELEM1 = IELEM - INCR
          DO NODE = 1 , NNEL
            NOP(NODE , IELEM) = NOP(NODE , IELEM1) + M( NODE )
          END DO
        END DO
      END IF
      IF(I.LT.NELEM) GO TO 410
      WRITE(I_OUT,'(//1X,T18,A,I5,A)')'ELEMENT INCIDENCES (ELEMENT'//
     .   ' TYPE:',IETYPE,')'
      WRITE(I_OUT,'(1X,A,4X,A)')'ELEMENT NO.','INCIDENCES'
      DO I=1,NELEM
        SINCI=' '
        WRITE(SELEM,'(I20)')I
        LELEM=STR$COLLAPSE(SELEM,SELEM)
        DO K=1,NNEL
          WRITE(STEMP,'(I20)')NOP(K,I)
          LTEMP=STR$COLLAPSE(STEMP,STEMP)
          SINCI(STR$LENGTH(SINCI)+1:)=' '//STEMP(:LTEMP)
        END DO
        LINCI=STR$LENGTH(SINCI)
        WRITE(I_OUT,'(2X,A10,4X,A)')SELEM(:LELEM),SINCI(:LINCI)
      END DO
      GO TO NEXT
C
C ----- READ THE DIRECTION ANGLES OF SKEW B.C.'S
C
  500 CST = 3.141592653589793/180.
C     READ(BUFF , * , ERR = 2000) NUMBER
      READ(BUFF , '(I20)' , ERR = 2000) NUMBER
      IF(NUMBER.GT.MAX_SKEW_BC) THEN
        WRITE(STR1,'(I39)')NUMBER
        WRITE(STR1,'(I39)')MAX_SKEW_BC
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'NUMBER OF SKEW BC''S ('//STR1(:LSTR1)//') '
     .                //'EXCEEDES ALLOWABLE (MAX_SKEW_BC='//STR2(:LSTR2)
     .                //'). PROGRAM TERMINATED'
        WRITE(*,*)'NUMBER OF SKEW BC''S ('//STR1(:LSTR1)//') '
     .                //'EXCEEDES ALLOWABLE (MAX_SKEW_BC='//STR2(:LSTR2)
     .                //'). PROGRAM TERMINATED'
        STOP
      ENDIF
      DO K1 = 1 , NUMBER
        READ(I_IN , *,ERR=2000)K,DUMMY(1),DUMMY(2),DUMMY(3)
        IF (ISPB( K ).EQ.0) THEN
          ISPB( K ) = ICNT
          K2 = ICNT
          ICNT = ICNT + 1
        ELSE IF (ISPB( K ).LT.0) THEN
          ISPB( K ) = -ISPB( K )
          K2 = ISPB( K )
        ELSE IF (ISPB( K ).GT.0) THEN
          WRITE(I_OUT , 6003) K
          STOP
        END IF
        COSTX( K2 ) = DCOS(DUMMY( 1 )*CST)
        COSTY( K2 ) = DCOS(DUMMY( 2 )*CST)
        COSTZ( K2 ) = DCOS(DUMMY( 3 )*CST)
      END DO
      GO TO NEXT
C
C ----- READ AND WRITE THE APPLIED DISPLACEMENTS
C
C 600 READ(BUFF , * , ERR = 2000) NUMBER
  600 READ(BUFF , '(I20)' , ERR = 2000) NUMBER
      IF((NUMBER*NNDF).GT.MAX_NODES_DOF) THEN
        WRITE(STR1,'(I39)')NUMBER
        WRITE(STR1,'(I39)')MAX_NODES_DOF
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'NUMBER OF APPLIED DISP ('//STR1(:LSTR1)//') '
     .                //'EXCEEDES ALLOWABLE (MAX_NODES_DOF='
     .                //STR2(:LSTR2)//'). PROGRAM TERMINATED'
        WRITE(*,*)'NUMBER OF APPLIED DISP ('//STR1(:LSTR1)//') '
     .                //'EXCEEDES ALLOWABLE (MAX_NODES_DOF='
     .                //STR2(:LSTR2)//'). PROGRAM TERMINATED'
        STOP 
      ENDIF
      DO I = 1 , NUMBER
        READ(I_IN , *,ERR=2000)K,(DUMMY(K1),K1 = 1 , NNDF)
        DO IDIR = 1 , NNDF
          ID = NNDF*(K - 1) + IDIR
          U( ID ) = DUMMY( IDIR )
        END DO
      END DO
      GO TO NEXT
C
C ----- READ AND WRITE THE APPLIED FORCE LOADS (CARD SET 9)
C
C 700 READ(BUFF , * , ERR = 2000) NUMBER
  700 READ(BUFF , '(I20)' , ERR = 2000) NUMBER
      IF(NUMBER.GT.NNODES) THEN
        WRITE(STR1,'(I39)')NUMBER
        WRITE(STR2,'(I39)')NNODES
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'WARNING!!!! NUMBER OF NODAL LOADS SPECIFIED ('//
     .                 STR1(:LSTR1)//') EXCEEDES NUMBER OF NODES ('//
     .                 STR2(:LSTR2)//')'
        WRITE(*,*)'WARNING!!!! NUMBER OF NODAL LOADS SPECIFIED ('//
     .                 STR1(:LSTR1)//') EXCEEDES NUMBER OF NODES ('//
     .                 STR2(:LSTR2)//')'
      ENDIF
      IF(NUMBER.GT.MAX_NODES) THEN
        WRITE(STR1,'(I39)')NUMBER
        WRITE(STR2,'(I39)')MAX_NODES
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'NUMBER OF NODAL LOADS ('//STR1(:LSTR1)//') '//
     .              'EXCEEDES ALLOWABLE (MAX_NODES='//STR2(:LSTR2)//
     .                '). PROGRAM TERMINATED'
        WRITE(*,*)'NUMBER OF NODAL LOADS ('//STR1(:LSTR1)//') '//
     .              'EXCEEDES ALLOWABLE (MAX_NODES='//STR2(:LSTR2)//
     .                '). PROGRAM TERMINATED'
        STOP 
      ENDIF
      WRITE(I_OUT,'(//1X,T25,A)')'NODAL LOADS'
      WRITE(I_OUT,'(1X,A,10X,A,2(14X,A))')'NODE NUMBER','X','Y','Z'
      DO K1 = 1 , NUMBER
        READ(I_IN , *,ERR=2000) K2,RX(K2),RY(K2),RZ(K2)
        WRITE(I_OUT,'(4X,I5,7X,3(G13.4,4X))')K2,RX(K2),RY(K2),RZ(K2)
      END DO
      GO TO NEXT
C
C ----- READ AND GENERATE THE BOUNDARY CONDITION CODES
C
  900 I = 0
C     READ(BUFF , * , ERR = 2000) NUMBER
      READ(BUFF , '(I20)' , ERR = 2000) NUMBER
      IF(NUMBER.GT.NNODES) THEN
        WRITE(STR1,'(I39)')NUMBER
        WRITE(STR2,'(I39)')NNODES
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'WARNING!!!! NUMBER OF BOUN COND SPECIFIED ('//
     .                 STR1(:LSTR1)//') EXCEEDES NUMBER OF NODES ('//
     .                 STR2(:LSTR2)//')'
        WRITE(*,*)'WARNING!!!! NUMBER OF BOUN COND SPECIFIED ('//
     .                 STR1(:LSTR1)//') EXCEEDES NUMBER OF NODES ('//
     .                 STR2(:LSTR2)//')'
      ENDIF
      IF(NUMBER.GT.MAX_NODES) THEN
        WRITE(STR1,'(I39)')NUMBER
        WRITE(STR2,'(I39)')MAX_NODES
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'NUMBER OF BOUN COND ('//STR1(:LSTR1)//') '//
     .              'EXCEEDES ALLOWABLE (MAX_NODES='//STR2(:LSTR2)//
     .                '). PROGRAM TERMINATED'
        WRITE(*,*)'NUMBER OF BOUN COND ('//STR1(:LSTR1)//') '//
     .              'EXCEEDES ALLOWABLE (MAX_NODES='//STR2(:LSTR2)//
     .                '). PROGRAM TERMINATED'
        STOP 
      ENDIF
  910 READ (I_IN , *,ERR=2000) K,(M(IDIR),IDIR=1,NNDF),INCR
      DO IDIR = 1 , NNDF
        ID = NNDF*(K - 1) + IDIR
        IDOF( ID ) = M( IDIR )
      END DO
      I = I + 1
      IF(INCR.EQ.0) THEN
        K1 = K
      ELSE
        ISTART = K1 + INCR
        IEND   = K - INCR
        DO J = ISTART , IEND , INCR
          I = I + 1
          DO IDIR = 1 , NNDF
            ID = NNDF*(J - 1) + IDIR
            IDOF( ID ) = M( IDIR )
          END DO
        END DO
      END IF
      IF (I.LT.NUMBER) GO TO 910
      GO TO NEXT
C
C ----- READ AND GENERATE THE INTERFACE NODES
C
 1100 I = 0
C     READ(BUFF , * , ERR = 2000) NINODE
      READ(BUFF , '(I20)' , ERR = 2000) NINODE
      IF(NINODE.GT.MAX_INTFAC_NODES) THEN
        WRITE(STR1,'(I39)')NINODE
        WRITE(STR2,'(I39)')MAX_INTFAC_NODES
        LSTR1=STR$COLLAPSE(STR1,STR1)
        LSTR2=STR$COLLAPSE(STR2,STR2)
        WRITE(I_OUT,*)'NUMBER OF INTERFACE NODES ('//STR1(:LSTR1)//') '
     .                //'EXCEEDS ALLOWABLE (MAX_INTFAC_NODES='//
     .                STR2(:LSTR2)//'). PROGRAM TERMINATED'
        WRITE(*,*)'NUMBER OF INTERFACE NODES ('//STR1(:LSTR1)//') '
     .                //'EXCEEDS ALLOWABLE (MAX_INTFAC_NODES='//
     .                STR2(:LSTR2)//'). PROGRAM TERMINATED'
        STOP
      ENDIF
 1110 READ (I_IN , *,ERR=2000) K,INCR
      IF(INCR.EQ.0) THEN
        I = I + 1
        INTFAC( I ) = K
        IF (ISPB( K ).EQ.0) THEN
          ISPB( K ) = -ICNT
          ICNT = ICNT + 1
        END IF
      ELSE
        ISTART = INTFAC( I ) + INCR
        IEND   = K
        DO J = ISTART , IEND , INCR
          IF (ISPB( J ).EQ.0) THEN
            ISPB( J ) = -ICNT
            ICNT = ICNT + 1
          END IF
          I = I + 1
          INTFAC( I ) = J
        END DO
      END IF
      IF (I.LT.NINODE) GO TO 1110
      GO TO NEXT
 2000 STOP 'Error reading input file'
 1000 RETURN
 5004 FORMAT(I5,1P,3G20.10)
 6002 FORMAT(//,1X,'PHYSICAL DIMENSION = ',I3/1X,'NUMBER OF NODES = ',
     .  I6/1X,'NUMBER OF ELEMENTS = ',I6/1X,'NUMBER OF NODAL D.O.F. = ',
     .  I6/,
     .  1X,'NUMBER OF APPLIED NODAL LOADS = ',I6/1X,'NUMBER OF IMPOSED'
     .  ,' NODAL DISPLACEMENTS = ',I6/1X,'NUMBER OF SKEW BOUNDARIES = ',
     .  I6/1X,'INTEGRATION CODE = ',I6/1X,'NUMBER OF LOAD INCREMENTS = '
     .  ,I6/1X,'GEOMETRIC LINEAR/NONLINEAR CODE = ',I6/1X,'MAXIMUM ',
     .  'NUMBER OF ITERATION ALLOWED = ',I6/1X,'FACTOR = ',F14.7)
 6003 FORMAT(/1X,'>>>>>>> PROGRAM STOPPED DUE TO MULTIPLE DEFINITIONS'/
     .      9X,'OF THE SKEW DIRECTION FOR NODE ',I4)
 6009 FORMAT(/,20X,'COORDINATES OF THE NODES'/' NODE NO.',11X,'X',
     .       19X,'Y',19X,'Z'/)
C     
      END
C                                                
C =====================================================================
C ======================== G R A P H X ===============================
C =====================================================================
C
      SUBROUTINE GRAPHX(I_IN,I_OUT)
C
C     READ IN PARAMETERS FOR GRAPHICAL OUTPUT
C     PARAMETERS:
C           DMAG   - MAGNIFICATION FACTOR FOR DISPLACEMENTS
C           FMAG   - MAGNIFICATION FACTOR FOR ORIGINAL GEOMETRY
C           XL     - LOWER LEFT X-COOR OF WINDOW IN WORLD COORDINATES
C           YB     - LOWER LEFT Y-COOR OF WINDOW IN WORLD COORDINATES
C           XR     - UPPER RIGHT X-COOR OF WINDOW IN WORLD COORDINATES
C           YT     - UPPER RIGHT Y-COOR OF WINDOW IN WORLD COORDINATES
C           XVL    - LOWER LEFT X-COOR OF VIEWPORT IN DEVICE COORDINATES
C           YVB    - LOWER LEFT Y-COOR OF VIEWPORT IN DEVICE COORDINATES
C           XVR    - UPPER RIGHT X-COOR OF VIEWPORT IN DEVICE COORDINATES
C           YVT    - UPPER RIGHT Y-COORD OF VIEWPORT IN DEVICE COORDINATES
C           ITHICK - THICKNESS OF ALL LINES TO BE DRAWN
C     
C     NOTE: THE VIEWPORT COORDINATES ARE IGNORED. THEY REMAIN FOR COMPABILITY
C           WITH PREVIOUS INPUT FILES WRITTEN FOR THE BENSON PLOTTER.
C
      IMPLICIT NONE
      CHARACTER*80 BUFFER,BUFF
      CHARACTER*4 COMM
      INTEGER STR$COMPRESS,ICOMMENT,ICOMP,IPOS,ITHICK,I_IN,I_OUT,MORE
      INTEGER N,NEXT,NLINES
      REAL*4 D,SX,SY,XL,XR,XVL,XVR,YB,YT,YVB,YVT,ZF,DMAG,FMAG
      LOGICAL CONTOURS
      COMMON/GRAPH3/XL,XR,YB,YT,ZF,D
      COMMON/GRAPH4/XVL,XVR,YVB,YVT,SX,SY
      COMMON/GRAPH5/FMAG,DMAG,CONTOURS,ITHICK,NLINES
C
C     SET THE VIEWPORT COORDINATES IN INCHES MULTIPLIED BY 1000. THIS
C     WILL ALLOW MOVEMENTS ON THE PAGE TO ONE THOUSANDTH OF AN INCH 
C     GIVING AN APPARENT RESOLUTION OF 1000 PIXELS/INCH. THE TRUE 
C     RESOLUTION WILL BE DEVICE DEPENDENT. THE PAGE DIMENSIONS HAVE BEEN
C     DECREASED BY 500 MILLI-INCHES TO LEAVE A 250 MILL-INCH BORDER
C     ALL AROUND. 
C
      XVL=250
      YVB=2000   ! INCREASE BY 1.5 INCH FOR LEGEND + .25 INCH FOR BORDER
      XVR=8000
      YVT=10500
C
C          READ THE COMMAND LINE BUFFER
C
C     SEE COMMENTS IN ROUTINE INPUT REGARDING LIST-DIRECTED I/O ON
C     INTERNAL FILES.
C
  100 IPOS = 1
      READ(I_IN , 101 ,END=1000) BUFFER
      ICOMMENT=INDEX(BUFFER,'/*')
      IF(ICOMMENT.NE.0) BUFFER(ICOMMENT:)=' '
      CALL STR$UPCASE(BUFFER,BUFFER)
      ICOMP=STR$COMPRESS(BUFFER,BUFFER)
  101 FORMAT(A80)
  105 CALL COMPRO(BUFFER,BUFF,COMM,N,IPOS)
      ASSIGN 100 TO NEXT
      IF (COMM.EQ.'FMAG') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) FMAG
        READ(BUFF , '(G20.0)' , ERR = 2000) FMAG
      ELSE IF(COMM.EQ.'DMAG') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) DMAG
        READ(BUFF , '(G20.0)' , ERR = 2000) DMAG
      ELSE IF(COMM.EQ.'CONT') THEN
        IF(N.EQ.1) ASSIGN 105 TO NEXT
        CONTOURS = .TRUE.
      ELSE IF(COMM.EQ.'WL') THEN
        IF(N.EQ.1)THEN            
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) XL
        READ(BUFF , '(G20.0)' , ERR = 2000) XL
      ELSE IF(COMM.EQ.'WR') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) XR
        READ(BUFF , '(G20.0)' , ERR = 2000) XR
      ELSE IF(COMM.EQ.'WT') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) YT
        READ(BUFF , '(G20.0)' , ERR = 2000) YT
      ELSE IF(COMM.EQ.'WB') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) YB
        READ(BUFF , '(G20.0)' , ERR = 2000) YB
      ELSE IF(COMM.EQ.'VL') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        WRITE(I_OUT,*)'COMMAND ''VL'' IGNORED. LEFT X-COOR'//
     .       ' OF VIEWPORT PERMANENTLY SET TO 0.25 INCHES'
        PRINT*,'COMMAND ''VL'' IGNORED. LEFT X-COOR'//
     .       ' OF VIEWPORT PERMANENTLY SET TO 0.25 INCHES'
C       READ(BUFF , * , ERR = 2000) XVL
C       READ(BUFF , '(G20.0)' , ERR = 2000) XVL
      ELSE IF(COMM.EQ.'VR') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        WRITE(I_OUT,*)'COMMAND ''VR'' IGNORED. RIGHT X-COOR'//
     .       ' OF VIEWPORT PERMANENTLY SET TO 8.00 INCHES'
        PRINT*,'COMMAND ''VR'' IGNORED. RIGHT X-COOR'//
     .       ' OF VIEWPORT PERMANENTLY SET TO 8.00 INCHES'
C       READ(BUFF , * , ERR = 2000) XVR
C       READ(BUFF , '(G20.0)' , ERR = 2000) XVR
      ELSE IF(COMM.EQ.'VT') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        WRITE(I_OUT,*)'COMMAND ''VT'' IGNORED. TOP Y-COOR'//
     .       ' OF VIEWPORT PERMANENTLY SET TO 10.50 INCHES'
        PRINT*,'COMMAND ''VT'' IGNORED. TOP Y-COOR'//
     .       ' OF VIEWPORT PERMANENTLY SET TO 10.50 INCHES'
C       READ(BUFF , * , ERR = 2000) YVT
C       READ(BUFF , '(G20.0)' , ERR = 2000) YVT
      ELSE IF(COMM.EQ.'VB') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        WRITE(I_OUT,*)'COMMAND ''VB'' IGNORED. BOTTOM Y-COOR'//
     .       ' OF VIEWPORT PERMANENTLY SET TO 1.75 INCHES'
        PRINT*,'COMMAND ''VB'' IGNORED. BOTTOM Y-COOR'//
     .       ' OF VIEWPORT PERMANENTLY SET TO 1.75 INCHES'
C       READ(BUFF , * , ERR = 2000) YVB
C       READ(BUFF , '(G20.0)' , ERR = 2000) YVB
      ELSE IF(COMM.EQ.'LINE') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
C       READ(BUFF , * , ERR = 2000) ITHICK
        READ(BUFF , '(I20)' , ERR = 2000) ITHICK
      ELSE IF (COMM.EQ.'ANGL') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        WRITE(I_OUT,*)'COMMAND: '//COMM//' IS UNSUPPORTED. IGNORED'
        PRINT*,'COMMAND: '//COMM//' IS UNSUPPORTED. IGNORED'
      ELSE IF (COMM.EQ.'HIGH') THEN
        IF(N.EQ.1)THEN
          CALL COMPRO1(BUFF,IPOS,MORE)
          IF(MORE.NE.0)ASSIGN 105 TO NEXT
        ENDIF
        WRITE(I_OUT,*)'COMMAND: '//COMM//' IS UNSUPPORTED. IGNORED'
        PRINT*,'COMMAND: '//COMM//' IS UNSUPPORTED. IGNORED'
      ELSE IF(COMM.EQ.'BLAN') THEN
        GOTO 100
      ELSE IF(COMM.EQ.'END') THEN
        RETURN
      ELSE
        WRITE(I_OUT , 200) COMM
 200    FORMAT(1X,'>>>>>>> COMMAND "',A4,'" IS NOT RECOGNIZED BY'
     .    ,' ROUTINE GRAPHX')
        GO TO 2000
      END IF
      GO TO NEXT
 1000 RETURN
 2000 STOP 'Error reading input file'
C 
      END
C
C ====================================================================
C ======================== O U T P U T ===============================
C ====================================================================
C
      SUBROUTINE OUTPUT(I_OUT)
      IMPLICIT NONE
      INTEGER MAT_ELAS,MAT_PLAS,MAT_ELAS_DAM,MAT_PLAS_DAM
      INTEGER MAX_NODES,MAX_MAT_TYPE,MAX_GAUSS_PTS,MNNDF,MAX_NODES_DOF
      INTEGER STRS_STRN_REL,PLANE_STRESS,PLANE_STRAIN,AXISYMMETRIC
      PARAMETER (PLANE_STRESS=1,PLANE_STRAIN=2,AXISYMMETRIC=3)
      PARAMETER (MAT_ELAS=1,MAT_PLAS=2,MAT_ELAS_DAM=3,MAT_PLAS_DAM=4)
      PARAMETER (MAX_NODES=3000,MAX_MAT_TYPE=10,MAX_GAUSS_PTS=27,
     .           MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      INTEGER ELNUM,ELEM_TYPE,IA,IDIM,IEND,IF1,IF2,IFOR,IFOR1
      INTEGER INCREMENTS,INTGPN,ISTART,ITERATIONS,I_OUT,K1,K2,K3,LDEV
      INTEGER LDEV1,LDEV10,LDEV2,LDEV3,LDEV4,LDEV5,LDEV6,LDEV7,LDEV8
      INTEGER LDEV9,LDEVST,LINES,MATNUM,NELEM,NINODE,NIP
      INTEGER NNDF,NNEL,NNODES,MATYPE
      INTEGER NIPXI,NIPETA,NIPSI,INTCOD      
      LOGICAL LINEAR,SYMMETRIC
      REAL*8 STRESS(6),STRAIN(6),COORDS(3),FORCES(6),DISPL(6),THICK
      REAL*8 CSTR(6),STRPLA(6),STRELA(6),RE,UTOTAL,WGTX,WGTY,WGTZ
      REAL*8 TSELA(6,MAX_GAUSS_PTS),TSTRS(6,MAX_GAUSS_PTS)
      REAL*8 TSTRN(6,MAX_GAUSS_PTS)
      COMMON/INPUT1/NIPXI,NIPETA,NIPSI,NIP,INTCOD
      COMMON/INPUT6/WGTX(MAX_MAT_TYPE),WGTY(MAX_MAT_TYPE),
     .              WGTZ(MAX_MAT_TYPE)
      COMMON/INPUT8/NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,
     .              SYMMETRIC,IDIM,NINODE
      COMMON/INPUT9/THICK,STRS_STRN_REL
      COMMON/INPUTF/MATYPE(MAX_MAT_TYPE)                      
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
      COMMON/DEV1/LDEV5,LDEV6,LDEV7,LDEV8,LDEV9,LDEV10
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/MAIN4/RE(MAX_NODES_DOF)
C
      DO ELNUM = 1 , NELEM
        CALL ELINFO(ELNUM,ELEM_TYPE,NNEL,MATNUM,STRS_STRN_REL,
     .              ISTART,LINES)
        IF (ELEM_TYPE.GT.300) THEN
          ASSIGN 3001 TO IFOR
          ASSIGN 3101 TO IFOR1
          IF (MATYPE( MATNUM ).EQ.MAT_PLAS) THEN
            ASSIGN 3102 TO IF1
          ELSE
            ASSIGN 3002 TO IF1
          END IF
          IF (.NOT.LINEAR) THEN
            ASSIGN 3103 TO IF2
          ELSE
            ASSIGN 3003 TO IF2
          END IF
          IEND = 6
        ELSE IF(STRS_STRN_REL.EQ.AXISYMMETRIC) THEN
          ASSIGN 2001 TO IFOR
          ASSIGN 2101 TO IFOR1
          IF (MATYPE( MATNUM ).EQ.MAT_PLAS) THEN
            ASSIGN 2104 TO IF1
          ELSE
            ASSIGN 2004 TO IF1
          END IF
          IF (.NOT.LINEAR) THEN
            ASSIGN 2105 TO IF2
          ELSE
            ASSIGN 2005 TO IF2
          END IF
          IEND = 4
        ELSE
          ASSIGN 2001 TO IFOR
          ASSIGN 2101 TO IFOR1
          IF (MATYPE( MATNUM ).EQ.MAT_PLAS) THEN
            ASSIGN 2102 TO IF1
          ELSE
            ASSIGN 2002 TO IF1
          END IF
          IF (.NOT.LINEAR) THEN
            ASSIGN 2103 TO IF2
          ELSE
            ASSIGN 2003 TO IF2
          END IF
          IEND = 4
        END IF
        IF (MATYPE(MATNUM).EQ.MAT_ELAS) THEN
          DO K1 = 1 , NIP
            READ(LDEV1)(TSTRS(IA,K1),IA=1,6),(TSTRN(IA,K1),IA=1,6)
          END DO
        ELSE IF (MATYPE(MATNUM).EQ.MAT_PLAS) THEN
          DO K1 = 1 , NIP
            READ(LDEV1)(TSTRS(IA,K1),IA=1,6),(TSTRN(IA,K1),IA=1,6),
     .                (TSELA(IA,K1),IA=1,6)
          END DO
        END IF
        WRITE(I_OUT , 5002) ELNUM
        WRITE(I_OUT , IF1)
        DO INTGPN = 1 , NIP
          CALL COORD1(ELNUM,NNEL,INTGPN,COORDS(1),COORDS(2),COORDS(3))
          DO IA=1,6
            STRAIN(IA)=TSTRN(IA,INTGPN)
          ENDDO
          WRITE(I_OUT , IFOR) INTGPN,(COORDS(K1),K1=1,IDIM),
     .                        (STRAIN(K1),K1=1,IEND)
          IF (MATYPE(MATNUM).EQ.MAT_PLAS) THEN
            DO IA=1,6
              STRELA(IA)=TSELA(IA,INTGPN)
            ENDDO
            DO K1 = 1 , IEND
              STRPLA( K1 ) = STRAIN( K1 ) - STRELA( K1 )
            END DO
            WRITE(I_OUT ,IFOR1) (STRELA(K1),K1=1,IEND)
            WRITE(I_OUT ,IFOR1) (STRPLA(K1),K1=1,IEND)
          END IF
        END DO
        WRITE(I_OUT , IF2)
        DO INTGPN = 1 , NIP
          CALL COORD1(ELNUM,NNEL,INTGPN,COORDS(1),COORDS(2),COORDS(3))
          DO IA=1,6
            STRESS(IA)=TSTRS(IA,INTGPN)
          ENDDO
          WRITE(I_OUT , IFOR) INTGPN,(COORDS(K1),K1=1,IDIM),
     .                        (STRESS(K1),K1=1,IEND)
          IF(.NOT.LINEAR) THEN
            CALL CAUCHY(ELNUM,ELEM_TYPE,NNEL,NNDF,INTGPN,STRESS,CSTR)
            WRITE(I_OUT , IFOR1) (CSTR(K1),K1=1,IEND)
          END IF
        END DO
      END DO
      WRITE(I_OUT , 6009)
      DO K1 = 1 , NNODES
        DO K2 = 1 , NNDF
          K3 = (K1 -1)*NNDF + K2
          FORCES( K2 ) = RE( K3 )
        END DO
        WRITE(I_OUT , 5004) K1,(FORCES(K2),K2 = 1 , NNDF)
      END DO
      WRITE(I_OUT , 6007)
      DO K1 = 1 , NNODES
        DO K2 = 1 , NNDF
          K3 = (K1 -1)*NNDF + K2
          DISPL( K2 ) = UTOTAL( K3 )
        END DO
        WRITE(I_OUT , 5004) K1,(DISPL( K2 ),K2 = 1 , NNDF)
      END DO
 2001 FORMAT(I4,1P,6G14.5)
 2101 FORMAT(32X,1P,4G14.5)
 2002 FORMAT(50X,'STRAIN COMPONENTS'/1X,'POINT',5X,'X',14X,'Y',
     .12X,'EXX',11X,'EYY',11X,'EXY',11X,'EZZ')
 2102 FORMAT(70X,'STRAIN COMPONENTS'/1X,'POINT',5X,'X',14X,'Y',
     .7X,' TOTAL_X   ',3X,' TOTAL_Y   ',3X,' TOTAL_XY   ',2X,
     .' TOTAL_Z   '/
     .34X,' ELAST_X',6X,' ELAST_Y',6X,' ELAST_XY',5X,' ELAST_Z'/
     .34X,' PLAST_X',6X,' PLAST_Y',6X,' PLAST_XY',5X,' PLAST_Z')
 2003 FORMAT(70X,'STRESS COMPONENTS'/1X,'POINT',5X,'X',14X,'Y',
     .12X,'SXX',11X,'SYY',11X,'SXY',11X,'SZZ')
 2103 FORMAT(70X,'STRESS COMPONENTS'/1X,'POINT',5X,'X',14X,'Y',
     .7X,'2ND PIOLA_X',3X,'2ND PIOLA_Y',3X,'2ND PIOLA_XY',2X,
     .'2ND_PIOLA_Z'/
     .34X,'CAUCHY_X',6X,'CAUCHY_Y',6X,'CAUCHY_XY',5X,'CAUCHY_Z')
 2004 FORMAT(50X,'STRAIN COMPONENTS'/1X,'POINT',5X,'X',14X,'Y',
     .11X,'ER ',11X,'EY ',11X,'ERY',11X,'ET ')
 2104 FORMAT(70X,'STRAIN COMPONENTS'/1X,'POINT',5X,'X',14X,'Y',
     .7X,' TOTAL_R   ',3X,' TOTAL_Y   ',3X,' TOTAL_RY   ',2X,
     .' TOTAL_T   '/
     .34X,' ELAST_R',6X,' ELAST_Y',6X,' ELAST_RY',5X,' ELAST_T'/
     .34X,' PLAST_R',6X,' PLAST_Y',6X,' PLAST_RY',5X,' PLAST_T')
 2005 FORMAT(50X,'STRESS COMPONENTS'/1X,'POINT',5X,'X',14X,'Y',
     .12X,'SR ',11X,'SY ',11X,'SRY',11X,'ST ')
 2105 FORMAT(70X,'STRESS COMPONENTS'/1X,'POINT',5X,'X',14X,'Y',
     .7X,'2ND PIOLA_R',3X,'2ND PIOLA_Y',3X,'2ND PIOLA_RY',2X,
     .'2ND_PIOLA_T'/
     .34X,'CAUCHY_R',6X,'CAUCHY_Y',6X,'CAUCHY_RY',5X,'CAUCHY_T')
 3001 FORMAT(I3,1P,9G14.5)
 3101 FORMAT(45X,1P,6G14.5)
 3002 FORMAT(50X,'STRAIN COMPONENTS'/1X,'POINT',5X,'X',13X,'Y',13X,
     .'Z',11X,'EXX',11X,'EYY',11X,'EZZ',11X,'EXY',11X,'EYZ',11X,'EXZ')
 3102 FORMAT(50X,'STRAIN COMPONENTS'/1X,'POINT',5X,'X',13X,'Y',
     .14X,'Z',7X,' TOTAL_X   ',3X,' TOTAL_Y   ',3X,' TOTAL_Z   ',2X,
     .' TOTAL_XY   ',2X,' TOTAL_YZ   ',2X,' TOTAL_XZ   '/
     .48X,' ELAST_X',6X,' ELAST_Y',6X,' ELAST_Z',5X,' ELAST_XY',5X,
     .' ELAST_YZ',5X,' ELAST_XZ'/
     .48X,' PLAST_X',6X,' PLAST_Y',6X,' PLAST_Z',5X,' PLAST_XY',5X,
     .' PLAST_YZ',5X,' PLAST_XZ')
 3003 FORMAT(50X,'STRESS COMPONENTS'/1X,'POINT',5X,'X',13X,'Y',13X,
     .'Z',11X,'SXX',11X,'SYY',11X,'SZZ',11X,'SXY',11X,'SYZ',11X,'SXZ')
 3103 FORMAT(50X,'STRESS COMPONENTS'/1X,'POINT',5X,'X',13X,'Y',
     .14X,'Z',7X,'2ND PIOLA_X',3X,'2ND PIOLA_Y',3X,'2ND PIOLA_Z',2X,
     .'2ND_PIOLA_XY',2X,'2ND PIOLA_YZ',2X,'2ND PIOLA_XZ'/
     .48X,'CAUCHY_X',6X,'CAUCHY_Y',6X,'CAUCHY_Z',5X,'CAUCHY_XY',5X,
     .'CAUCHY_YZ',5X,'CAUCHY_XZ')
 5002 FORMAT(20X,'**********',' ELEMENT=',I5,' **********')
 5004 FORMAT(I5,1P,3G20.10)
 5005 FORMAT(I3,9(1X,G12.9))
 6007 FORMAT(20X,'DISPLACEMENT OF THE NODES'/' NODE NO.',10X,'UX',
     .18X,'UY',18X,'UZ')
 6008 FORMAT(45X,'TOTAL PLASTIC WORK AT GAUSSIAN POINTS'/11X,'P1',
     .11X,'P1',11X,'P3',11X,'P4',11X,'P5',11X,'P6',11X,'P7',11X,'P8'
     .,11X,'P9')
 6009 FORMAT(20X,'REACTIONS AT THE NODES'/' NODE NO.',10X,'RX',
     .18X,'RY',18X,'RZ')
 6010 FORMAT(20X,'POINTS THAT HAVE YIELDED'/12X,'P1',5X,'P2',5X,'P3',
     .5X,'P4',5X,'P5',5X,'P6',5X,'P7',5X,'P8',5X,'P9')
C
      END
C
C ====================================================================
C ======================= B O U N D ==================================
C ====================================================================
C
      SUBROUTINE BOUND(IDOF,NNDF,NINODE,ICODE,I_OUT)
C      
C ====================================================================
C I                                                                  I
C I   P R O G R A M:                                                 I
C I                                                                  I
C I   SUBROUTINE 'BOUND' CHECKS THE MOTION OF ROLLERS ON CURVED      I
C I   BOUNDARIES AND INSURES THAT THE ROLLERS STAY ON THE BOUNDARY   I
C I   BY DETERMINING THE APPROPRIATE DISPLACEMENT CORRECTIONS.       I
C I                                                                  I
C I   A R G U M E N T     L I S T:                                   I
C I                                                                  I
C I   IDOF(I)   = THE ARRAY CONTAINING THE D.O.F. NUMBERS            I
C I   NNDF      = NUMBER OF NODAL DEGREES OF FREEDOM                 I
C I   ICODE     = RETURN CODE PASSED TO THE CALLING ROUTINE          I
C I               =0; NO CHANGE IN THE D.O.F. NUMBERS                I
C I               =1; RECALCULATION OF THE 'IDOF' AARAY IS NEEDED    I
C I   I_OUT     = OUTPUT DEVICE NUMBER                               I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_SKEW_BC,MAX_INTFAC_NODES,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MAX_SKEW_BC=300,MAX_INTFAC_NODES=500,
     .           MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      REAL*4 X,Y,Z
      INTEGER ICODE,ID1,ID2,IRELE,I_OUT,K1,NINODE,NNDF,NODE,IDOF(*)
      INTEGER INTFAC,ISPB,IRINC(MAX_INTFAC_NODES)
      REAL*8 DOT,DX,DY,R,RP,T,TOL,XFINAL,XNODE,XP,YFINAL,YNODE,YP
      REAL*8 COSTX,COSTY,COSTZ,P,RE,RINC,RIT,U,UINC,UTOTAL
      COMMON/MAIN1/U(MAX_NODES_DOF)
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/MAIN4/RE(MAX_NODES_DOF)
      COMMON/INPUT3/X(MAX_NODES),Y(MAX_NODES),Z(MAX_NODES)
      COMMON/INPUT7/RIT(MAX_NODES_DOF),RINC(MAX_NODES_DOF),
     .              UINC(MAX_NODES_DOF)
      COMMON/INPUTD/COSTX(MAX_SKEW_BC),COSTY(MAX_SKEW_BC),
     .              COSTZ(MAX_SKEW_BC)
      COMMON/INPUTE/ISPB(MAX_NODES)
      COMMON/INPUTI/INTFAC(MAX_INTFAC_NODES)
      COMMON/POINTS/P(4 , 2)
C
      TOL = 10D-18
      IRELE = 20
      ICODE = 0
C
C       NINODE = NUMBER OF INTERFACE NODES
C
      DO K1 = 1 , NINODE
        NODE = INTFAC( K1 )
        ID1 = NNDF*(NODE - 1) + 1
        ID2 = ID1 + 1
C
C       YNODE = FINAL Y-COORD OF THE NODE
C
        YNODE = Y( NODE ) + UTOTAL( ID2 )
C
C       CHECK TO SEE IF THE NODE HAS PENETRATED THE DIE
C
        IF (YNODE.GT.P(1,2).AND.YNODE.LE.P(2,2)) THEN
          XNODE = X( NODE ) + UTOTAL( ID1 )
C
C            FIND THE POINT ON THE DIE FOR A NORMAL RETURN CORRECTION
C            THE DIE IS MODELED USING THE 'HERMITE PARAMETRIC CURVE'
C            SUBROUTINE MULLER FINDS THE PARAMETER 'T'
C            SUBROUTINE HERMXY FINDS THE 'X' AND 'Y' COORDINATES OF THE
C            RETURN POINT ON THE DIE
C
          CALL MULLER(XNODE,YNODE,T,I_OUT)
          CALL HERMXY(T,XFINAL,YFINAL)
          CALL XYPRIM(T,XP,YP)
          DX = XFINAL - XNODE
          DY = YFINAL - YNODE
          R = DSQRT(DX**2 + DY**2)
          RP = DSQRT(XP**2 + YP**2)
C
C            CHANGE THE NEGATIVE 'ISPB' ADDRESSES TO POSITIVE SO THAT
C            THEY ARE RECOGNIZED IN THE SOLUTION PROCESS
C
          IF (ISPB( NODE ).LT.0) THEN
            ISPB( NODE ) = - ISPB( NODE )
          ELSE IF(ISPB( NODE ).EQ.0) THEN
            WRITE(I_OUT , 1000) NODE
            STOP '>>>>>>> PROGRAM STOPPED IN ROUTINE ''BOUND'' '
          END IF
C
C            FIND THE DIRECTION COSINES OF THE ROLLERS ON THE DIE
C
          COSTX(ISPB( NODE )) = -YP/RP
          COSTY(ISPB( NODE )) = XP/RP
          IF (IDOF( ID1 ).GT.0) THEN
            ICODE = 1
            IDOF( ID1 ) = -1
            IDOF( ID2 ) = 1
          ELSE
            IDOF( ID1 ) = -1
          END IF
C
C            IMPOSE THE APPROPRIATE DISPLACEMENT FOR THE NORMAL RETURN
C            CORRECTION DURING THE NEXT LOAD INCREMENT
C
          DOT = -YP*DX + XP*DY
          IF (DOT.GE.0) THEN
            UINC( ID1 ) = R
          ELSE
            UINC( ID1 ) = -R
          END IF
C
C       IF THE NODE EXISTS THEN RELEASE IT AND SET ICODE EQUAL TO 1 TO
C       MAKE SURE THAT THE CALLING ROUTINE RECALCULATES THE 'IDOF' ARRAY
C
        ELSE IF(YNODE.GT.P(2,2)) THEN
          UINC( ID1 ) = 0.
          IF(ISPB( NODE ).GT.0) ISPB( NODE ) = -ISPB( NODE )
          IF(IDOF( ID1 ).LE.0) THEN
            ICODE = 1
            IRINC( K1 ) = 1
            IDOF( ID1 ) = 1
            RINC( ID1 ) = -RE( ID1 )/IRELE
            RINC( ID2 ) = -RE( ID2 )/IRELE
          ELSE IF (IRINC(K1).NE.0) THEN
            IRINC( K1 ) = IRINC( K1 ) + 1
            IF (IRINC(K1).GT.IRELE) THEN
              IRINC( K1 ) = 0
              RINC( ID1 ) = 0.0
              RINC( ID2 ) = 0.0
            END IF
          END IF
        END IF
      END DO
 1000 FORMAT(1X,'>>>>>>> PROGRAM STOPPED IN ROUTINE "BOUND" DUE TO A'/
     . 9X,'ZERO ISPB FOR INTERFACE NODE ',I4)
C     
      END
C
C ====================================================================
C ===================== C U R V E ====================================
C ====================================================================
C
      SUBROUTINE CURVE
      IMPLICIT NONE
      REAL*8 T,X,Y
      REAL*4 DMAG,FMAG,XE,XS,YE,YS,DT
      INTEGER ITHICK,NLINES,K1
      LOGICAL CONTOURS
      COMMON/GRAPH5/FMAG,DMAG,CONTOURS,ITHICK,NLINES
C      
      CALL VTHICK(3)
      DT = 0.05
      T =  0.
      CALL HERMXY(T,X,Y)
      XS = X*FMAG
      YS = Y*FMAG

      DO K1 = 1 , 20
        T = T + DT
        CALL HERMXY(T,X,Y)
        XE = X*FMAG
        YE = Y*FMAG
        CALL CLIP(XS,YS,0.,1.,XE,YE,0.,1.)
        XS = XE
        YS = YE
      END DO
      CALL VTHICK(2)
C
      END
C
C ====================================================================
C ==================== M U L L E R ===================================
C ====================================================================
C
      SUBROUTINE MULLER(XD,YD,T,I_OUT)
      IMPLICIT NONE
      INTEGER MAX_ROOT
      PARAMETER (MAX_ROOT=5)
      REAL*8 ROOT(MAX_ROOT),A,B,C0,C1,C2,C3,C4,C5,D,D0,D1,D2,F0,F1
      REAL*8 F2,GAM,H1,H1S,H2,T0,T1,T2,TOL,XD,YD,HMAT,HMATP,T
      INTEGER K1,K2,NROOT,I_OUT,STR$COLLAPSE,LSTR1,LSTR2
      CHARACTER*40 STR1,STR2
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
      COMMON/CONST/C0,C1,C2,C3,C4,C5
C
      TOL = .000000001
      D2 = C2 + 3.*(XD*HMATP(1 , 1) + YD*HMATP(1 , 2))
      D1 = C1 + 2.*(XD*HMATP(2 , 1) + YD*HMATP(2 , 2))
      D0 = C0 + XD*HMATP(3 , 1) + YD*HMATP(3 , 2)
      NROOT = 0
  10  T1 = 0.
      T2 = 1.
      T0 = 0.5
      F1 = D0
      F2 = C5 + C4 + C3 + D2 + D1 + D0
      DO K1 = 1 , NROOT
        F1 = F1/(-ROOT( K1 ))
        F2 = F2/(1. - ROOT( K1 ))
      END DO
      DO K1 = 1 , 20
        F0 = ((((C5*T0 + C4)*T0 + C3)*T0 + D2)*T0 + D1)*T0 + D0
        DO K2 = 1 , NROOT
          F0 = F0/(T0 - ROOT( K2 ))
        END DO
        H2 = T0 - T2
        H1 = T1 - T0
        H1S = H1**2
        GAM = H2/H1
        A = (GAM*F1 - F0*(1.+GAM) + F2)/(GAM*H1S*(1 + GAM))
        B = (F1 - F0 - A*H1S)/H1
        IF (B.LE.0.) THEN
          D = -DSQRT(B**2 - 4.*A*F0)
        ELSE
          D = DSQRT(B**2 - 4.*A*F0)
        END IF
        T = T0 - 2.*F0/(B+D)
        IF (DABS(T-T0).LE.TOL) GO TO 50
        IF (T.GT.T0.AND.T.NE.T2) THEN
          T1 = T0
          T0 = T
          F1 = F0
        ELSE IF(T.LT.T0.AND.T.NE.T1) THEN
          T2 = T0
          T0 = T
          F2 = F0
        ELSE
          GO TO 50
        END IF
      END DO
      WRITE(I_OUT , 1000)
 50   IF (T.GT.1..OR.T.LT.0.) THEN
        IF (NROOT.EQ.4) THEN
          WRITE(I_OUT , 1001) T
          STOP 'PROGRAM HAS STOPPED DUE TO ''T'' OUT OF RANGE'
        ELSE
          NROOT = NROOT + 1
          IF(NROOT.GT.MAX_ROOT) THEN
            WRITE(STR1,'(I39)')NROOT
            WRITE(STR2,'(I39)')MAX_ROOT
            LSTR1=STR$COLLAPSE(STR1,STR1)
            LSTR2=STR$COLLAPSE(STR2,STR2)
            WRITE(I_OUT,*)'NUMBER OF ROOTS ('//STR1(:LSTR1)//') EXCEEDS'
     .          //' ALLOWABLE (MAX_ROOT='//STR2(:LSTR2)//') IN ROUTINE '
     .          //'MULLER. PROGRAM TERMINATED'
            WRITE(*,*)'NUMBER OF ROOTS ('//STR1(:LSTR1)//') EXCEEDS'
     .          //' ALLOWABLE (MAX_ROOT='//STR2(:LSTR2)//') IN ROUTINE '
     .          //'MULLER. PROGRAM TERMINATED'
            STOP
          ENDIF
          ROOT( NROOT ) = T
          GO TO 10
        END IF
      END IF
 1000 FORMAT(/1X,'>>>>>>> FIXED POINT ITERATION FAILED')
 1001 FORMAT(/1X,'>>>>>>> PROGRAM HAS STOPPED DUE TO THE OUT OF RANGE ',
     .      'VALUE OF "T"'/9X,'T = ',F6.3)
C     
      END
C
C ====================================================================
C ======================== C O E F I C ===============================
C ====================================================================
C
      SUBROUTINE COEFIC
      IMPLICIT NONE
      INTEGER K1
      REAL*8 C0,C1,C2,C3,C4,C5,HMAT,HMATP
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
      COMMON/CONST/C0,C1,C2,C3,C4,C5
C
      C0 = 0.
      C1 = 0.
      C2 = 0.
      C3 = 0.
      C4 = 0.
      C5 = 0.
      DO K1 = 1 , 2
        C0 = C0 - HMATP(3 , K1)*HMATP(4 , K1)
        C1 = C1 - HMATP(3 , K1)**2 - 2.*HMATP(2 , K1)*HMATP(4 , K1)
        C2 = C2 - 3.*HMATP(1 , K1)*HMATP(4 , K1) - 3.*HMATP(2 , K1)*
     .       HMATP(3 , K1)
        C3 = C3 - 2.*HMATP(2 , K1)**2 - 4.*HMATP(1 , K1)*HMATP(3 , K1)
        C4 = C4 - 5.*HMATP(1 , K1)*HMATP(2 , K1)
        C5 = C5 - 3.*HMATP(1 , K1)**2
      END DO
C
      END
C
C ====================================================================
C ======================== H E R M I T ===============================
C ====================================================================
C
      SUBROUTINE HERMIT
      IMPLICIT NONE
      INTEGER K1,K2,K3
      REAL*8 HMAT,HMATP,P
      COMMON/POINTS/P(4 , 2)
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
C
      DO K1 = 1 , 4
        DO K2 = 1 , 2
          HMATP(K1 , K2) = 0.
          DO K3 = 1 , 4
            HMATP(K1 , K2) = HMATP(K1 , K2) + HMAT(K1 , K3)*P(K3 , K2)
          END DO
        END DO
      END DO
C
      END
C
C ====================================================================
C ======================== H E R M X Y ===============================
C ====================================================================
C
      SUBROUTINE HERMXY(T,X,Y)
      IMPLICIT NONE
      REAL*8 HMAT,HMATP,T,T1(4),X,Y
      INTEGER K1
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
C
      T1( 4 ) = 1.
      T1( 3 ) = T
      T1( 2 ) = T*T1( 3 )
      T1( 1 ) = T*T1( 2 )
      X = 0.
      Y = 0.
      DO K1 = 1 , 4
        X = X + T1( K1 ) * HMATP(K1 , 1)
        Y = Y + T1( K1 ) * HMATP(K1 , 2)
      END DO
C
      END
C
C ====================================================================
C ======================== X Y P R I M ===============================
C ====================================================================
C
      SUBROUTINE XYPRIM(T,XP,YP)
      IMPLICIT NONE
      REAL*8 HMAT,HMATP,T,T1(4),XP,YP
      INTEGER K1
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
C
      T1( 4 ) = 0.
      T1( 3 ) = 1.
      T1( 2 ) = 2.*T
      T1( 1 ) = 3.*T**2
C
      XP=0.
      YP=0.
      DO K1=1,4
        XP=XP+T1(K1)*HMATP(K1,1)
        YP=YP+T1(K1)*HMATP(K1,2)
      END DO
C
      END   
C
C ===========================================================================
C ================= P O S T S C R I P T __ D R I V E R ======================
C ===========================================================================
C I                                                                         I
C I   THIS SUBROUTINE SERVES AS A POSTSCRIPT DRIVER TO WRITE A POSTSCRIPT   I
C I   FILE FOR THE GRAPHICAL OUTPUT THAT WAS ROUTED TO THE BENSON PLOTTER.  I
C I   THE FORMER PLOTTER ROUTINES IDENT,EOJOB,JOBPLT,PLOT,VTHICK,EOPLOT,    I
C I   SYMBOL, AND NUMBER AS USED IN THIS PROGRAM ARE IMPLEMENTED AS         I
C I   ENTRY STATEMENTS IN THIS SUBROUTINE.                                  I
C ===========================================================================
C               
      SUBROUTINE POSTSCRIPT_DRIVER
      IMPLICIT NONE
      CHARACTER STRING_OUT*500,TMPSTR*100,LEGSTR(8)*80,FCN_OUT*256
      CHARACTER*20 SX_OUT,SY_OUT,STHICK,SHT,SFPN,SANG,FMT,CURR_FONT
      CHARACTER*60 FILENAME,FONTS_USED,DATE_TIME*30,SPSXV*20
      CHARACTER SPAGE*7,COMMAND*20,SSYM*4
      CHARACTER*20 SXORG,CURR_THICK,LAST_FONT*60
C     CHARACTER SDATE*9,STIME*8  ! VAX DATE/TIME
      CHARACTER*7 HOUR,MINU,SEC,HUNSEC,YEAR,DAY,MONTH(12)*3 ! MICROSOFT
      INTEGER*2 IHR,IMIN,ISEC,I100TH,IYR,IMON,IDAY          ! DATE/TIME
      INTEGER X_OUT,Y_OUT,STR$LENGTH,STR$COLLAPSE,STR$COMPRESS
      INTEGER STR$FIND_FIRST_IN_SET_R,PAGE,CURR_XORG
      INTEGER IDTL,IDUMMY,IFPN,IHT,IPEN,IPSXV,ISYM,ITHICK,I_GRAPH,I_IN
      INTEGER I_OUT,LANG,LCOM,LCTHICK,LFCN_OUT,LFN,LFON,LFPN,LHT
      INTEGER LINE_OUT,LL1,LL2,LL3,LL4,LL5,LLFNT,LOUT,LPAGE,LPSXV,LSO
      INTEGER LTHK,LXORG,LX_OUT,LY_OUT,I1,I2,I3,I4,I5,I6
      REAL*4 ANG,CURR_HT,D,FPN,HT,SX,X
      REAL*4 XL,XR,XVL,XVR,Y,YB,YT,YVB,YVT,ZF,SY,RDUMMY
      LOGICAL GRAPH_OPEN,NEWPAGE
      COMMON/GRAPH3/XL,XR,YB,YT,ZF,D
      COMMON/GRAPH4/XVL,XVR,YVB,YVT,SX,SY
      COMMON/IN_IO/I_OUT,I_IN,I_GRAPH
C
      SAVE STRING_OUT,PAGE,LINE_OUT,CURR_FONT,CURR_HT,GRAPH_OPEN,NEWPAGE
     . ,SPSXV,LPSXV,CURR_XORG,CURR_THICK,LCTHICK,LAST_FONT,LLFNT
      DATA MONTH/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG',
     .           'SEP','OCT','NOV','DEC'/
      DATA PAGE /0/, FMT /'(1X,TL1,A)'/, STRING_OUT / ' '/
      DATA CURR_FONT /' '/ ! INITIALIZE CURRENT FONT TO BE NULL
      DATA FONTS_USED /' '/ ! INITIALIZE FONTS USED TO BE NULL
      DATA CURR_XORG /1/ ! NOT THE TRUE X-ORGIN HAS TO BE COMPUTED
C                        ! BUT WILL NOT BE SET AT 0
C
C ======================== E N T R Y    I D E N T =====================
C
      ENTRY IDENT                                   
      ASSIGN 200 TO LINE_OUT
C     CALL DATE(SDATE)    ! VAX DATE ROUTINE
C     CALL TIME(STIME)    ! VAX TIME ROUTINE
      CALL GETTIM(IHR,IMIN,ISEC,I100TH)
      CALL GETDAT(IYR,IMON,IDAY)
      INQUIRE(I_GRAPH,NAME=FILENAME,OPENED=GRAPH_OPEN)
      IF(.NOT. GRAPH_OPEN)THEN
        PRINT*,'CANNOT WRITE TO GRAPH FILE'
        WRITE(I_OUT,FMT)'CANNOT WRITE TO GRAPH FILE'
        RETURN
      ENDIF
      WRITE(HOUR,'(I7)')IHR
      WRITE(MINU,'(I7)')IMIN
      WRITE(SEC,'(I7)')ISEC
      WRITE(HUNSEC,'(I7)')I100TH
      WRITE(YEAR,'(I7)')IYR
      WRITE(DAY,'(I7)')IDAY
      I1=STR$COLLAPSE(HOUR,HOUR)
      I2=STR$COLLAPSE(MINU,MINU)
      I3=STR$COLLAPSE(SEC,SEC)
      I4=STR$COLLAPSE(HUNSEC,HUNSEC)
      I5=STR$COLLAPSE(YEAR,YEAR)
      I6=STR$COLLAPSE(DAY,DAY)
      LFN=STR$COLLAPSE(FILENAME,FILENAME)
      DATE_TIME=DAY(:I6)//'-'//MONTH(IMON)//'-'//YEAR(:I5)//'    '//
     .        HOUR(:I1)//':'//MINU(:I2)//':'//SEC(:I3)//':'//HUNSEC(:I4)
C     DATE_TIME=SDATE//'    '//STIME   ! VAX DATE/TIME STRING
C     CALL FDATE_(DATE_TIME)           ! UNIX XL FORTRAN DATE/TIME STRING
      IDTL=STR$LENGTH(DATE_TIME)
      WRITE(I_GRAPH,FMT)'%!PS-Adobe-3.0'
      WRITE(I_GRAPH,FMT)'%%Creator: DNA Finite Element Program'
      WRITE(I_GRAPH,FMT)'%%Title: '//FILENAME(:LFN)
      WRITE(I_GRAPH,FMT)'%%CreationDate: '//DATE_TIME(:IDTL)
      WRITE(I_GRAPH,FMT)'%%BoundingBox: 18 18 576 756'
      WRITE(I_GRAPH,FMT)'%%DocumentFonts: (atend)'
      WRITE(I_GRAPH,FMT)'%%Pages: (atend)'
      WRITE(I_GRAPH,FMT)'%%EndComments'
      WRITE(I_GRAPH,FMT)'%%BeginProlog'
      WRITE(I_GRAPH,FMT)'/bd{bind def} bind def /l{lineto}bd '//
     .                  '/m{moveto}bd /t{translate}bd /s{show}bd'
      WRITE(I_GRAPH,FMT)'/slw{5 mul setlinewidth}bd '//
     .                  '/SYMFONT{/Symbol findfont}bd'
      WRITE(I_GRAPH,FMT)'/TEXTFONT{/Helvetica findfont}bd'//
     .                  ' /FONTSIZE{scalefont setfont}bd'
      WRITE(I_GRAPH,FMT)'/st{stroke}bd '//
     .                  '/gs{gsave}bd /gr{grestore}bd'//
     .                  ' /r{rotate}bd /c{currentpoint}bd'
      WRITE(I_GRAPH,FMT)'/lsm{l c st m}bd /lst{l c st t}bd '//
     .                  '/rm{rmoveto}bd'
      WRITE(I_GRAPH,FMT)'/center{dup stringwidth pop 7750 exch '//
     .                  'sub 2 div 0 rm s}bd'
      WRITE(I_GRAPH,FMT)'/censym{dup gs newpath 0 0 m true charpath'//
     .                  ' flattenpath pathbbox'
      WRITE(I_GRAPH,FMT)'2 div -1 mul /ht exch def 2'//
     .                  ' div -1 mul /wd exch def pop pop gr}bd'
      WRITE(I_GRAPH,FMT)'%%EndProlog'
C     TRY TO CENTER THE GRAPH ON THE PAGE HORIZONTALLY
      IPSXV = INT((XVR-XVL-SX*(XR - XL))/2+XVL)
      WRITE(SPSXV,'(I20)')IPSXV
      LPSXV=STR$COLLAPSE(SPSXV,SPSXV)
      PAGE=PAGE+1
      WRITE(SPAGE,'(I7)')PAGE
      LPAGE=STR$COLLAPSE(SPAGE,SPAGE)
      WRITE(I_GRAPH,FMT)
      WRITE(I_GRAPH,FMT)'%%Page: '//SPAGE(:LPAGE)//' '//SPAGE(:LPAGE)
      WRITE(I_GRAPH,FMT)'%%BeginPageSetup'
      WRITE(I_GRAPH,FMT)'/pgsave save def 0.072 0.072 scale '//
     .                   SPSXV(:LPSXV)//' 0 t'
      CURR_THICK='1'
      LCTHICK=1
      WRITE(I_GRAPH,FMT)'1 setlinejoin 1 setlinecap 0 setgray 1 slw'
      WRITE(I_GRAPH,FMT)'%%EndPageSetup'
      NEWPAGE=.FALSE.
      CURR_XORG=1
      RETURN
C
C ======================== E N T R Y    J O B P L T ===================
C
      ENTRY JOBPLT
      RETURN
C
C ======================== E N T R Y    P L O T =======================
C
      ENTRY PLOT(X,Y,IPEN)                          
      IF(.NOT. GRAPH_OPEN)THEN
        PRINT*,'CANNOT WRITE TO GRAPH FILE'
        WRITE(I_OUT,FMT)'CANNOT WRITE TO GRAPH FILE'
        RETURN
      ENDIF
      IF(NEWPAGE) THEN
        PAGE=PAGE+1
        WRITE(SPAGE,'(I7)')PAGE
        LPAGE=STR$COLLAPSE(SPAGE,SPAGE)
        WRITE(I_GRAPH,FMT)
        WRITE(I_GRAPH,FMT)'%%Page: '//SPAGE(:LPAGE)//' '//SPAGE(:LPAGE)
        WRITE(I_GRAPH,FMT)'%%BeginPageSetup'
        WRITE(I_GRAPH,FMT)'/pgsave save def 0.072 0.072 scale '//
     .                     SPSXV(:LPSXV)//' 0 t'             
        WRITE(I_GRAPH,FMT)'1 setlinejoin 1 setlinecap 0 setgray '//
     .     CURR_THICK(:LCTHICK)//' slw'
        WRITE(I_GRAPH,FMT)'%%EndPageSetup'
        NEWPAGE=.FALSE.
        CURR_XORG=1
        CURR_FONT=' '
        CURR_HT=0
      ENDIF
      SXORG=' '
      LXORG=1
      IF(CURR_XORG.EQ.0) THEN
        CURR_XORG=1
        SXORG=' '//SPSXV(:LPSXV)//' 0 t '
        LXORG=STR$LENGTH(SXORG)
      ENDIF
      X_OUT=INT(X)
      Y_OUT=INT(Y)
      WRITE(SX_OUT,'(I20)')X_OUT
      WRITE(SY_OUT,'(I20)')Y_OUT
      LX_OUT=STR$COLLAPSE(SX_OUT,SX_OUT)
      LY_OUT=STR$COLLAPSE(SY_OUT,SY_OUT)             
      IF(IPEN.EQ.3) THEN
        COMMAND='m'
      ELSEIF(IPEN.EQ.2)THEN
        COMMAND='lsm'
      ELSEIF(IPEN.EQ.-3) THEN
        COMMAND='t'
      ELSEIF(IPEN.EQ.-2)THEN
        COMMAND='lst'
      ENDIF                                         
      LCOM=STR$COMPRESS(COMMAND,COMMAND)
      FCN_OUT=SXORG(:LXORG)//SX_OUT(:LX_OUT)//' '//SY_OUT(:LY_OUT)//
     .        ' '//COMMAND(:LCOM)
      LFCN_OUT=STR$LENGTH(FCN_OUT)
      GOTO LINE_OUT
C
C ======================== E N T R Y    V T H I C K ===================
C
      ENTRY VTHICK(ITHICK)                         
      IF(.NOT. GRAPH_OPEN)THEN
        PRINT*,'CANNOT WRITE TO GRAPH FILE'
        WRITE(I_OUT,FMT)'CANNOT WRITE TO GRAPH FILE'
        RETURN
      ENDIF
      IF(NEWPAGE) THEN
        PAGE=PAGE+1
        WRITE(SPAGE,'(I7)')PAGE
        LPAGE=STR$COLLAPSE(SPAGE,SPAGE)
        WRITE(I_GRAPH,FMT)
        WRITE(I_GRAPH,FMT)'%%Page: '//SPAGE(:LPAGE)//' '//SPAGE(:LPAGE)
        WRITE(I_GRAPH,FMT)'%%BeginPageSetup'
        WRITE(I_GRAPH,FMT)'/pgsave save def 0.072 0.072 scale '//
     .                     SPSXV(:LPSXV)//' 0 t'             
        WRITE(I_GRAPH,FMT)'1 setlinejoin 1 setlinecap 0 setgray '
        WRITE(I_GRAPH,FMT)'%%EndPageSetup'
        NEWPAGE=.FALSE.
        CURR_XORG=1
        CURR_FONT=' '
        CURR_HT=0
      ENDIF
      WRITE(STHICK,'(I20)')ITHICK
      LTHK=STR$COLLAPSE(STHICK,STHICK)
      CURR_THICK=STHICK
      LCTHICK=LTHK
      FCN_OUT=' '//STHICK(:LTHK)//' slw'
      LFCN_OUT=STR$LENGTH(FCN_OUT)
      GOTO LINE_OUT
C
C ======================== E N T R Y    S Y M B O L ===================
C
      ENTRY SYMBOL(X,Y,HT,ISYM,RDUMMY,IDUMMY)      
      RDUMMY=RDUMMY
      IDUMMY=IDUMMY
      IF(.NOT. GRAPH_OPEN)THEN
        PRINT*,'CANNOT WRITE TO GRAPH FILE'
        WRITE(I_OUT,FMT)'CANNOT WRITE TO GRAPH FILE'
        RETURN
      ENDIF
      IF(NEWPAGE) THEN
        PAGE=PAGE+1
        WRITE(SPAGE,'(I7)')PAGE
        LPAGE=STR$COLLAPSE(SPAGE,SPAGE)
        WRITE(I_GRAPH,FMT)
        WRITE(I_GRAPH,FMT)'%%Page: '//SPAGE(:LPAGE)//' '//SPAGE(:LPAGE)
        WRITE(I_GRAPH,FMT)'%%BeginPageSetup'
        WRITE(I_GRAPH,FMT)'/pgsave save def 0.072 0.072 scale '//
     .                     SPSXV(:LPSXV)//' 0 t'             
        WRITE(I_GRAPH,FMT)'1 setlinejoin 1 setlinecap 0 setgray '//
     .        CURR_THICK(:LCTHICK)//' slw'
        WRITE(I_GRAPH,FMT)'%%EndPageSetup'
        NEWPAGE=.FALSE.
        CURR_XORG=1
        CURR_FONT=' '
        CURR_HT=0
      ENDIF
      SXORG=' '
      LXORG=1
      IF(CURR_XORG.EQ.0) THEN
        CURR_XORG=1
        SXORG=' '//SPSXV(:LPSXV)//' 0 t '
        LXORG=STR$LENGTH(SXORG)
      ENDIF
      X_OUT=INT(X)
      Y_OUT=INT(Y)
      IHT=NINT(HT*1000)
      IF(ISYM.EQ.5) SSYM='\250'
      IF(ISYM.EQ.11) SSYM='\267'
      WRITE(SX_OUT,'(I20)')X_OUT
      WRITE(SY_OUT,'(I20)')Y_OUT
      WRITE(SHT,'(I20)')IHT
      LX_OUT=STR$COLLAPSE(SX_OUT,SX_OUT)
      LY_OUT=STR$COLLAPSE(SY_OUT,SY_OUT)
      LHT=STR$COLLAPSE(SHT,SHT)
      IF(CURR_FONT.NE.'Symbol') THEN
        CURR_FONT='Symbol'
        CURR_HT=HT
        LAST_FONT='SYMBOL '//SHT(:LHT)//' FONTSIZE'
        LLFNT=STR$LENGTH(LAST_FONT)
        IF(INDEX(FONTS_USED,'Symbol').EQ.0) THEN
          FONTS_USED(STR$LENGTH(FONTS_USED)+1:)=' Symbol'
          LFON=STR$LENGTH(FONTS_USED)
        ENDIF
        FCN_OUT=SXORG(:LXORG)//SX_OUT(:LX_OUT)//' '//SY_OUT(:LY_OUT)//
     .          ' m SYMFONT '//SHT(:LHT)//' FONTSIZE ('//SSYM//
     .          ') censym wd ht rm s'
      ELSE
        FCN_OUT=SXORG(:LXORG)//SX_OUT(:LX_OUT)//' '//SY_OUT(:LY_OUT)//
     .          ' m ('//SSYM//') wd ht rm s'
      ENDIF
      LFCN_OUT=STR$LENGTH(FCN_OUT)
      GOTO LINE_OUT
C
C ======================== E N T R Y    N U M B E R ===================
C
      ENTRY NUMBER(X,Y,HT,FPN,ANG,IDUMMY)          
      IDUMMY=IDUMMY
      IF(.NOT. GRAPH_OPEN)THEN
        PRINT*,'CANNOT WRITE TO GRAPH FILE'
        WRITE(I_OUT,FMT)'CANNOT WRITE TO GRAPH FILE'
        RETURN
      ENDIF
      IF(NEWPAGE) THEN
        PAGE=PAGE+1
        WRITE(SPAGE,'(I7)')PAGE
        LPAGE=STR$COLLAPSE(SPAGE,SPAGE)
        WRITE(I_GRAPH,FMT)
        WRITE(I_GRAPH,FMT)'%%Page: '//SPAGE(:LPAGE)//' '//SPAGE(:LPAGE)
        WRITE(I_GRAPH,FMT)'%%BeginPageSetup'
        WRITE(I_GRAPH,FMT)'/pgsave save def 0.072 0.072 scale '//
     .                     SPSXV(:LPSXV)//' 0 t'             
        WRITE(I_GRAPH,FMT)'1 setlinejoin 1 setlinecap 0 setgray '//
     .         CURR_THICK(:LCTHICK)//' slw'
        WRITE(I_GRAPH,FMT)'%%EndPageSetup'
        NEWPAGE=.FALSE.
        CURR_XORG=1
        CURR_FONT=' '
        CURR_HT=0
      ENDIF
      SXORG=' '
      LXORG=1
      IF(CURR_XORG.EQ.0) THEN
        CURR_XORG=1
        SXORG=' '//SPSXV(:LPSXV)//' 0 t '
        LXORG=STR$LENGTH(SXORG)
      ENDIF
      X_OUT=INT(X)           
      Y_OUT=INT(Y)
      IHT=NINT(HT*1000)
      IFPN=NINT(FPN)
      WRITE(SX_OUT,'(I20)')X_OUT
      WRITE(SY_OUT,'(I20)')Y_OUT
      WRITE(SHT,'(I20)')IHT
      WRITE(SFPN,'(I20)')IFPN
      WRITE(SANG,'(F20.6)')ANG
      LX_OUT=STR$COLLAPSE(SX_OUT,SX_OUT)
      LY_OUT=STR$COLLAPSE(SY_OUT,SY_OUT)
      LHT=STR$COLLAPSE(SHT,SHT)
      LFPN=STR$COLLAPSE(SFPN,SFPN)
      LANG=STR$COLLAPSE(SANG,SANG)
      IF(CURR_FONT.NE.'Helvetica' .OR. CURR_HT .NE. HT) THEN
        CURR_FONT='Helvetica'
        CURR_HT=HT
        LAST_FONT='SYMFONT '//SHT(:LHT)//' FONTSIZE'
        LLFNT=STR$LENGTH(LAST_FONT)
        IF(INDEX(FONTS_USED,'Helvetica') .EQ. 0) THEN
          FONTS_USED(STR$LENGTH(FONTS_USED)+1:)=' Helvetica'
          LFON=STR$LENGTH(FONTS_USED)
        ENDIF
        FCN_OUT=SXORG(:LXORG)//SX_OUT(:LX_OUT)//' '//
     .          SY_OUT(:LY_OUT)//' m SYMFONT '//SHT(:LHT)//
     .          ' FONTSIZE gs '//SANG(:LANG)//' r ('//
     .          SFPN(:LFPN)//') s gr'
      ELSE
        FCN_OUT=SXORG(:LXORG)//SX_OUT(:LX_OUT)//' '//
     .          SY_OUT(:LY_OUT)//' m gs '//SANG(:LANG)//
     .          ' r ('//SFPN(:LFPN)//') s gr'
      ENDIF
      LFCN_OUT=STR$LENGTH(FCN_OUT)
      GOTO LINE_OUT
C
C ================== E N T R Y    L E G E N D __ O U T ================
C
      ENTRY LEGEND_OUT(LEGSTR)                            
      IF(.NOT. GRAPH_OPEN)THEN
        PRINT*,'CANNOT WRITE TO GRAPH FILE'
        WRITE(I_OUT,FMT)'CANNOT WRITE TO GRAPH FILE'
        RETURN
      ENDIF
      IF(NEWPAGE) THEN
        PAGE=PAGE+1
        WRITE(SPAGE,'(I7)')PAGE
        LPAGE=STR$COLLAPSE(SPAGE,SPAGE)
        WRITE(I_GRAPH,FMT)
        WRITE(I_GRAPH,FMT)'%%Page: '//SPAGE(:LPAGE)//' '//SPAGE(:LPAGE)
        WRITE(I_GRAPH,FMT)'%%BeginPageSetup'
        WRITE(I_GRAPH,FMT)'/pgsave save def 0.072 0.072 scale'
        WRITE(I_GRAPH,FMT)'1 setlinejoin 1 setlinecap 0 setgray'
        WRITE(I_GRAPH,FMT)LAST_FONT(:LLFNT)
        WRITE(I_GRAPH,FMT)'%%EndPageSetup'
        NEWPAGE=.FALSE.
        CURR_XORG=0
        CURR_FONT=' '
        CURR_HT=0
      ENDIF
      LSO=STR$LENGTH(STRING_OUT)
      IF(LSO.NE.0) WRITE(I_GRAPH,FMT)STRING_OUT(:LSO)
      STRING_OUT=' '
      LL1=STR$LENGTH(LEGSTR(1))
      LL2=STR$LENGTH(LEGSTR(2))
      LL3=STR$LENGTH(LEGSTR(3))
      LL4=STR$LENGTH(LEGSTR(4))
      LL5=MAX(STR$LENGTH(LEGSTR(5)),LL4)
      IF(CURR_FONT.NE.'Helvetica' .OR. CURR_HT .NE. 12) THEN
        CURR_FONT='Helvetica'        
        CURR_HT=12
        IF(INDEX(FONTS_USED,'Helvetica').EQ.0) THEN
          FONTS_USED(STR$LENGTH(FONTS_USED)+1:)=' Helvetica'
          LFON=STR$LENGTH(FONTS_USED)
        ENDIF
        WRITE(I_GRAPH,FMT)'TEXTFONT 10 1000 mul 72 div FONTSIZE'
      ENDIF        
      WRITE(I_GRAPH,FMT)SPSXV(:LPSXV)//' -1 mul 0 t 3 slw newpath '//
     .                  '250 250 m 0 1500 rlineto 7750 0 rlineto '//
     .                  '0 -1500 '
      WRITE(I_GRAPH,FMT)'rlineto closepath st 1 slw'
      WRITE(I_GRAPH,FMT)'250 1440 m ('//LEGSTR(1)(:LL1)//') center'
      WRITE(I_GRAPH,FMT)'250 985 m ('//LEGSTR(2)(:LL2)//') center'
      WRITE(I_GRAPH,FMT)'250 679 m ('//LEGSTR(3)(:LL3)//') center'
      WRITE(I_GRAPH,FMT)'250 526 m ('//LEGSTR(4)(:LL4)//') center'
      WRITE(I_GRAPH,FMT)'250 373 m ('//LEGSTR(5)(:LL5)//') center'
      RETURN     
C
C ======================== E N T R Y    E O P L O T ===================
C
      ENTRY EOPLOT(IDUMMY)                         
      IDUMMY=IDUMMY
      IF(.NOT. GRAPH_OPEN)THEN
        PRINT*,'CANNOT WRITE TO GRAPH FILE'
        WRITE(I_OUT,FMT)'CANNOT WRITE TO GRAPH FILE'
        RETURN
      ENDIF
      LSO=STR$LENGTH(STRING_OUT)
      IF(LSO.NE.0) WRITE(I_GRAPH,FMT)STRING_OUT(:LSO)
      WRITE(I_GRAPH,FMT)'pgsave restore showpage'
      STRING_OUT=' '
      NEWPAGE=.TRUE.
      RETURN
C
C ======================== E N T R Y    E O J O B =====================
C
      ENTRY EOJOB
      WRITE(SPAGE,'(I7)')PAGE
      LPAGE=STR$COLLAPSE(SPAGE,SPAGE)
      WRITE(I_GRAPH,FMT)
      WRITE(I_GRAPH,FMT)'%%Trailer'
      WRITE(I_GRAPH,FMT)'%%DocumentFonts: '//FONTS_USED(:LFON)
      WRITE(I_GRAPH,FMT)'%%Pages: '//SPAGE(:LPAGE)
      WRITE(I_GRAPH,FMT)'%%EOF'
      CLOSE(I_GRAPH)
      RETURN
200   LSO=STR$LENGTH(STRING_OUT)
      STRING_OUT(LSO+1:)=FCN_OUT(:LFCN_OUT)
210   LSO=STR$LENGTH(STRING_OUT)
      IF(LSO.GT.78) THEN
        LOUT=STR$FIND_FIRST_IN_SET_R(STRING_OUT(:78),' ')
        TMPSTR=STRING_OUT(LOUT+1:)
        STRING_OUT(LOUT+1:)=' '
        WRITE(I_GRAPH,FMT)STRING_OUT(:LOUT)
        STRING_OUT=TMPSTR
        GOTO 210
      ENDIF
C                                                    
      END
C
C =====================================================================
C ===================== B L O C K   D A T A ===========================
C =====================================================================
C
      BLOCK DATA
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_ELEM_NODES,MAX_MAT_TYPE,MAX_ELEM_BOUND
      INTEGER MAX_LINES,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MAX_ELEM_NODES=20,MAX_MAT_TYPE=10,
     .           MAX_ELEM_BOUND=48,MAX_LINES=3000,MNNDF=3,
     .           MAX_NODES_DOF=MAX_NODES*MNNDF)
      INTEGER GRAPHICS_INTR,OUTPUT_INTR,DIVER_STOP,IDIM,INCREMENTS
      INTEGER ITERATIONS,ITHICK,LDEV,LDEV1,LDEV2,LDEV3,LDEV4,LDEVST
      INTEGER NDIVER,NELEM,NINODE,NLINES,NNDF,NNODES,IE,INT22,INT33
      INTEGER IREP,IS,ISPB,MATYPE,I,J,K
      REAL*8 CONV_FAC,ENRG1,AD,HMAT,HMATP,RE,RX,RY,RZ,U
      REAL*4 XII,ETAI,SII,FMAG,DMAG,XVL,XVR,YVB,YVT,SX,SY
      LOGICAL LINEAR,RESTART,SYMMETRIC,CONTOURS,GRAPHICS_OUT
      COMMON/MAIN1/U(MAX_NODES_DOF)
      COMMON/MAIN4/RE(MAX_NODES_DOF)
      COMMON/INPUT7/RX(MAX_NODES_DOF),RY(MAX_NODES_DOF),
     .              RZ(MAX_NODES_DOF)
      COMMON/INPUT8/NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,
     .              SYMMETRIC,IDIM,NINODE
      COMMON/INPUTB/CONV_FAC,ENRG1,NDIVER,DIVER_STOP
      COMMON/INPUTE/ISPB(MAX_NODES)
      COMMON/INPUTF/MATYPE(MAX_MAT_TYPE)
      COMMON/INPUTG/RESTART,OUTPUT_INTR,GRAPHICS_INTR,GRAPHICS_OUT
      COMMON/ADMAT1/AD(81)
      COMMON/DEVICE/LDEV1,LDEV2,LDEV3,LDEV4,LDEV,LDEVST
      COMMON/ELLIB1/XII(MAX_ELEM_NODES),ETAI(MAX_ELEM_NODES),
     .              SII(MAX_ELEM_NODES)
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)            
      COMMON/GRAPH1/IS(MAX_ELEM_BOUND),IE(MAX_ELEM_BOUND)
      COMMON/IREP1/IREP(MAX_LINES)
      COMMON/GRAPH4/XVL,XVR,YVB,YVT,SX,SY
      COMMON/GRAPH5/FMAG,DMAG,CONTOURS,ITHICK,NLINES
      COMMON/EXTRP1/INT33(9),INT22(4)
C                                                      
      DATA ((HMAT(I,J),J=1,4),I=1,4)/2.,-2.,1.,1.,-3.,3.,-2.,-1.,0.,0.,
     .      1.,0.,1.,0.,0.,0./
      DATA U/MAX_NODES_DOF*0.D0/
      DATA RE/MAX_NODES_DOF*0.D0/,RX/MAX_NODES_DOF*0.D0/
      DATA RY/MAX_NODES_DOF*0.D0/, RZ/MAX_NODES_DOF*0.D0/
      DATA LDEV1,LDEV2,LDEV3,LDEV4,LDEVST/1,2,3,4,14/,ISPB/MAX_NODES*0/
      DATA (XII(K),K=1,20)/-1.,1.,1.,-1.,-1.,1.,1.,-1.,0.,1.,0.,-1.,
     .    -1.,1.,1.,-1.,0.,1.,0.,-1./
      DATA (ETAI(K),K=1,20)/-1.,-1.,1.,1.,-1.,-1.,1.,1.,-1.,0.,1.,
     .     0.,-1.,-1.,1.,1.,-1.,0.,1.,0./
      DATA (SII(K),K=1,20)/-1.,-1.,-1.,-1.,1.,1.,1.,1.,-1.,-1.,-1.,-1.,
     .     0.,0.,0.,0.,1.,1.,1.,1./
      DATA NNODES,NELEM,NNDF,INCREMENTS,ITERATIONS,LINEAR,SYMMETRIC,IDIM
     .     /0,0,2,1,1,.TRUE.,.TRUE.,2/,RESTART,OUTPUT_INTR,
     .     GRAPHICS_INTR,GRAPHICS_OUT/.FALSE.,0,0,.FALSE./
      DATA NDIVER,CONV_FAC,DIVER_STOP/0,.001,5/,MATYPE/MAX_MAT_TYPE*1/,
     .     AD/81*0./
C
C        GRAPHICS ELEMENT LINE CONECTIVITY DATA
C
      DATA IS/1,2,3,4,1,5,2,6,3,7,4,8,1,2,3,4,5,6,7,8,2,3,1,4,
     .    1,9,2,10,3,11,4,12,5,17,6,18,7,19,8,20,1,13,4,16,3,15,2,14/
      DATA IE/2,3,4,1,5,2,6,3,7,4,8,1,2,3,4,1,6,7,8,5,6,7,5,8,
     .    9,2,10,3,11,4,12,1,17,6,18,7,19,8,20,5,13,5,16,8,15,7,14,6/
      DATA FMAG,DMAG,CONTOURS,ITHICK/1.,1.,.FALSE.,1/,NLINES/0/
      DATA XVL,XVR,YVB,YVT,SX,SY /0.0,0.0,0.0,0.0,0.0,0.0/
C
C       GAUSSIAN POINT TO NODE CONNECTIVITY DATA FOR NODAL EXTRAPOLATION
C
      DATA INT33/1,3,9,7,2,6,8,4,5/,INT22/1,2,4,3/,IREP/MAX_LINES*0/
C      
      END
