      PROGRAM MFP2D
C*******************************************************************************
C
C                                 M F P 2 D
C
C               N U M E R I C A L   S I M U L A T I O N   O F
C
C         S H E E T   M E T A L   F O R M I N G   P R O C E S S E S 
C
C                                 written by
C
C                          C. AGELET DE SARACIBAR
C
C         INTERNATIONAL CENTER FOR NUMERICAL METHODS IN ENGINEERING
C                 ESCUELA TECNICA SUPERIOR DE INGENIEROS DE
C                  CAMINOS, CANALES Y PUERTOS DE BARCELONA
C                    UNIVERSITAT POLITECNICA DE CATALUNYA
C
C                         BARCELONA, NOVEMBER 1988
C                              
C   VERSION: 1.0
C   LAST UPDATE: January 25, 1991
C   VERSION: 1.1 - Change node normal computation on the rigid surfaces
C   LAST UPDATE:     July 3, 1992
C   VERSION: 1.2 - Include (simple) deep drawing model
C   LAST UPDATE:  October 9, 1992
C
C*******************************************************************************
c
c.... OUTPUT FILES
c
c     IOUT1 = 11   TTIME,PRESS,EPMAX,IINCS,IITER,ERNRM   if(press.ne.0.0)
c     IOUT2 = 12   TTIME,EPMAX,EPMIN,IINCS,IITER,ERNRM   if(nautp.gt.  0)
c     IOUT3 = 13   IINCS,ERNRM,EVNRM<IITER,TTIME,PRESS,EPMAX,EPMIN
c     IOUT4 = 14   NTITE,NINCS,MNITE
c
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TABLAS/ NTABP ,NTABT
      COMMON /NPARAM/ NPARA
      COMMON /VOIDML/ NVOID
      COMMON /EXTRAP/ NEXTR ,NGST2 ,NROWS
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /ERRNRM/ ERNRM ,EVNRM 
      COMMON /VNORMS/ VNORM ,VENRM
      COMMON /ACTNRM/ IRNRM ,IVNRM
      COMMON /PROFIL/ NEQNS ,NWKTL
      COMMON /DYNMEM/ MAXIM
      common /bhcom1/ ibhol,xbh0,xbh1,bhf,idbhn(300),bhlod(300)              !oct'92
      COMMON  M(1000000)
      DATA  MAXIM/1000000/ ,IPR/2/
C
C     DICTIONARY OF VARIABLES
C
C        STNRA   GENERALIZED STRAIN RATE AT TIME T+DT, ITERATION K
C        STNRI   GENERALIZED STRAIN RATE AT TIME T
C        EPSRA   STRAIN RATE AT TIME T+DT, ITERATION K
C        EPSRI   STRAIN RATE AT TIME T
C        EEPRA   EQUIVALENT (PLASTIC) STRAIN RATE AT TIME T+DT, ITERATION K 
C        EEPRI   EQUIVALENT (PLASTIC) STRAIN RATE AT TIME T
C
C        STRAN   GENERALIZED STRAIN AT TIME T+DT, ITERATION K
C        STRAI   GENERALIZED STRAIN AT TIME T
C        EEPSN   EQUIVALENT (PLASTIC) STRAIN AT TIME T+DT, ITERATION K
C        EEPSI   EQUIVALENT (PLASTIC) STRAIN AT TIME T
C
C        STRES   GENERALIZED STRESS
C        SIGMA   STRESS
C        EFSIG   EFFECTIVE STRESS
C
C
C     SET UP I/O PATHS AND OPEN FILES
C
      CALL IOFILE
C
C
C     R E A D   C O N T R O L   V A R I A B L E S   T O   S E T   U P 
C     D Y N A M I C   D I M E N S I O N I N G 
C
C
      CALL DIMEN 
      if(npoin.gt.300) then
         print *, 'npoin>300 ---> se necesita redimensionar variables'
         stop
      end if

C
C     SET UP POINTERS FOR DYNAMIC DIMENSIONING
C
      N1  = 1
      N2  = N1  + NDIME*NPOIN*IPR         ! COORD(NDIME,NPOIN) 
      N3  = N2  + NDIME*NPOIN*IPR         ! COORI(NDIME,NPOIN)
      N4  = N3  + NNODE*NELEM             ! LNODS(NNODE,NELEM)
      N5  = N4  + NELEM                   ! MATNO(NELEM)
      
      N6  = N5  + NPROP*NMATS*IPR         ! PROPS(NPROP,NMATS)

      N7  = N6  + NVFIX                   ! NOFIX(NVFIX)
      N8  = N7  + NDOFN*NVFIX             ! IFPRE(NDOFN,NVFIX)
      N9  = N8  + NDOFN*NVFIX*IPR         ! PRESC(NDOFN,NVFIX)
      N10 = N9  + NTOTV                   ! IFFIX(NTOTV)
      N11 = N10 + NTOTV*IPR               ! FIXED(NTOTV)

      N12 = N11 + 2*NTABP*IPR             ! TABPR(2,NTABP)
      N13 = N12 + 2*NTABT*IPR             ! TABDT(2,NTABT)

      N14 = N13 + NTOTV*IPR               ! VELOC(NTOTV) 
      N15 = N14 + NTOTV*IPR               ! VELOI(NTOTV)

      N16 = N15 + NGSTR*NEVAB*IPR         ! BMATX(NGSTR,NEVAB)
      N17 = N16 + NGSTR*NGSTR*IPR         ! DMATX(NGSTR,NGSTR)
      N18 = N17 + NGSTR*NEVAB*IPR         ! DBMAT(NGSTR,NEVAB)
      N19 = N18 + NGSTR*NGSTR*IPR         ! DMATS(NGSTR,NGSTR)
      N20 = N19 + NGSTR*NGSTR*IPR         ! DMATT(NGSTR,NGSTR)
      N21 = N20 + NGSTR*NEVAB*NEVAB*IPR   ! DERIB(NGSTR,NEVAB,NEVAB)

      N22 = N21 + NGSTR*NGAST*IPR         ! STRAN(NGSTR,NGAST)
      N23 = N22 + NGSTR*NGAST*IPR         ! STRAI(NGSTR,NGAST)
      N24 = N23 + NGAZT*IPR               ! EEPSN(NGAZT)
      N25 = N24 + NGAZT*IPR               ! EEPSI(NGAZT)

      N26 = N25 + NGSTR*NGAST*IPR         ! STNRA(NGSTR,NGAST)
      N27 = N26 + NGSTR*NGAST*IPR         ! STNRI(NGSTR,NGAST)
      N28 = N27 + NGAZT*IPR               ! EEPRA(NGAZT)
      N29 = N28 + NGAZT*IPR               ! EEPRI(NGAZT)

      N30 = N29 + NGSTR*NGAST*IPR         ! STRES(NGSTR,NGAST)
      N31 = N30 + NSTRE*NGAZT*IPR         ! SIGMA(NSTRE,NGAZT)

      N32 = N31 + NGAST*IPR               ! THICK(NGAST)

      N33 = N32 + NPARA*NGAZT*IPR         ! PARAM(NPARA,NGAZT)

      N34 = N33 + NVOID*IPR               ! VOIDS(NVOID)
      N35 = N34 + NVOID*IPR               ! VOIDI(NVOID)
      N36 = N35 + NVOID*IPR               ! VOIRA(NVOID)
      N37 = N36 + NVOID*IPR               ! VOIRI(NVOID)

      N38 = N37 + NEVAB*NELEM*IPR         ! ELOAD(NEVAB,NELEM)
      N39 = N38 + NEVAB*NELEM*IPR         ! RLOAD(NEVAB,NELEM)
      N40 = N39 + NDOFN*NPOIN*IPR         ! PLOAD(NDOFN,NPOIN)
      N41 = N40 + NDOFN*NPOIN*IPR         ! RESID(NDOFN,NPOIN)
      N42 = N41 + NDOFN*NPOIN*IPR         ! RCLOD(NDOFN,NPOIN)
      N43 = N42 + NRSUR                   ! NELRS(NRSUR)
      N44 = N43 + NDIME*NRSUR*IPR         ! VELRS(NDIME,NRSUR)
      N45 = N44 + NRSUR*IPR               ! FRICT(NRSUR)
      N46 = N45 + NNODR*NRELE             ! LNODR(NNODR,NRELE)
      N47 = N46 + NDIME*NRPOI*IPR         ! RSCOR(NDIME,NRPOI)
      N47A= N47 + NRELE*IPR               ! SEANG(NRELE)
      N48 = N47A+ NRPOI*IPR               ! SNANG(NRPOI)
      N49 = N48 + NPOIN                   ! LELCO(NPOIN)
      N50 = N49 + NPOIN                   ! ISTAT(NPOIN)
      N51 = N50 + NDIME*NPOIN*IPR         ! OVERL(NDIME,NPOIN)

      NE  = N51
      CALL CHECKM(NE)
      CALL ZERO(M(N1),NE-N1)
C
C
C     R E A D   M A I N   D A T A    
C
C
      CALL INPUT(M( N1) ,M( N3) ,M( N4) ,M( N5) ,M( N6) ,M( N7) ,
     1           M( N8) ,M( N9) ,M(N10) ,M(N11) ,M(N12) ,M(N42) ,
     2           M(N43) ,M(N44) ,M(N45) ,M(N46) ,M( NE) )
C
C     SET UP VARIABLES FOR PROFILE SOLUTION 
C
      N52 = N51 + NEVAB*NELEM             ! LEQNS(NEVAB,NELEM)
      N53 = N52 + NTOTV+1                 ! MAXAD(NEQNS+1)
      NE  = N53
      CALL CHECKM(NE)
      CALL ZERO(M(N51),NE-N51)
      MLARG = (MAXIM - NE)/IPR + 1
      CALL LINKIN(M( N9) ,M(N51) ,M( N3) ,M(N52) ,M(NE) ,NDOFN ,
     1            NELEM  ,NEQNS  ,NNODE  ,NPOIN  ,NEVAB ,NTOTV ,
     2            NWKTL  ,MLARG  )
      N53 = N52 + NEQNS+1                 ! MAXAD(NEQNS+1)
C
C     ALLOCATE MAXIMUM MEMORY SPACE REQUIRED FOR STIFFNESS MATRICES AND
C     FORCES STORAGE
C
      N54 = N53 + NSTIF*IPR               ! ESTIF(NSTIF)
      N55 = N54 + NEQNS*IPR               ! FORCE(NEQNS)
      N56 = N55 + NWKTL*IPR               ! STIFF(NWKTL)
      NE  = N56
      CALL CHECKM(NE)
      CALL ZERO(M(N53),NE-N53)
C
C
C     I N I T I A L I Z E   V A R I A B L E S
C
C
      IF(TIME0.GT.0.0) GO TO 10
      CALL INITI(M( N4) ,M( N5) ,M(N13) ,M(N21) ,M(N23) ,M(N32) ,
     1           M(N33) ,M(N35) )
      GO TO 20
10    CALL RSTART(M( N1) ,M(N13) ,M(N21) ,M(N23) ,M(N25) ,M(N27) ,
     1            M(N32) ,M(N33) ,M(N35) ,M(N46) ,     1 )
20    CONTINUE
C
C     C O M P U T E   T O O L   D A T A 
C
C
C     ALLOCATE TEMPORAL WORK SPACE MEMORY
C
      NW1 = NE  + NRPOI                   ! KOUNT(NRPOI)
      nw2 = nw1 + nrpoi*2*ipr             ! sntan(2,nrpoi)
      CALL CHECKM(NW2)
      CALL ZERO(M(NE),NW2-NE)
C
C     COMPUTE TOOL DATA
C
      IF(NCNTC.EQ.2)
     1CALL DATOOL(M(N42) ,M(N45) ,M(N46) ,M(N47) ,M(N47A) ,M(NE) ,
     2            m(nw1) )                                            !July 1992
C
C     INITIALIZE SUMMARY ANALYSIS VARIABLES
C
      NTITE = 0
      NBADS = 0
C
C
C     S T A R T   I N C R E M E N T A L   T I M E   I N T E G R A T I O N
C     S C H E M E
C
C
      DO 300 IINCS = 1,NINCS
C
C     TIME INCREMENT
C
      IF(NAUTT.EQ.0) THEN
        IF(NTABT.GT.0) CALL DELTA(M(N12)) 
      ELSE
        CALL AUTDT
      END IF
      TTIME = TTIME + DTIME
      IF(TTIME.GT.TIMEF) GO TO 400
C
C     I N C R E M E N T   T H E   L E V E L   O F   E X T E R N A L 
C     A P P L I E D   L O A D S 
C
      CALL INCREM(M(N11) ,M(N42) ,M(N43) ,M(N45) ,M(N46))
C
C
C     P R E D I C T O R   P H A S E
C
C
      CALL PREDIC(M( N1) ,M( N2) ,M(N13) ,M(N14) ,M(N21) ,M(N22) ,
     1            M(N23) ,M(N24) ,M(N25) ,M(N26) ,M(N27) ,M(N28) ,
     2            M(N33) ,M(N34) ,M(N35) ,M(N36) )
C
C
C     C O R R E C T O R   P H A S E
C
C
      DO 100 IITER = 1,MITER
C
C     SET TO ZERO SOME VECTORS
C
      CALL SETZER(M(N38) ,M(N39) ,M(N40) ,M(N41) ,M(N54) ,M(N55) )
c
c     identify blank-holder nodes and compute bh loads for deep-drawing processes
c
      if(ibhol.eq.1) 
     1call bhold(m(n1),m(n2),m(n3),m(n13),m(n39),m(n40),m(n44),
     2           m(n9),m(n52),m(n54),m(n55))
C
C     C O N T A C T   S E A R C H I N G   P R O C E D U R E
C
      IF(NCNTC.EQ.2)
     1CALL SEARCH(M( N1) ,M(N42) ,M(N45) ,M(N46) ,M(N47) ,M(N47A),
     2            M(N48) ,M(N49) ,M(N50) )
C
C     C O M P U T E   T H E   C O N T A C T   O P E R A T O R S
C
      IF(NCNTC.EQ.2)
     1CALL CONTAC(M( N9) ,M(N10) ,M(N13) ,M(N41) ,M(N42) ,M(N43) ,
     2            M(N44) ,M(N47) ,M(N48) ,M(N49) ,M(N50) ,M(N52) ,
     3            M(N53) ,M(N54) ,M(N55) )
C
C     C O M P U T E   T H E   N O D A L   E Q U I V A L E N T   F O R C E S  
C     D U E   T O   T H E   P R E S S U R E
C
      CALL ELOADS(M( N1) ,M( N3) ,M(N37))
C
C     C O M P U T E   T H E   R E S I D U A L   F O R C E S
C
      CALL RESIDU(M( N1) ,M( N3) ,M( N4) ,M( N5) ,M(N13) ,M(N15) ,
     1            M(N16) ,M(N20) ,M(N21) ,M(N22) ,M(N23) ,M(N24) ,
     2            M(N25) ,M(N26) ,M(N27) ,M(N28) ,M(N29) ,M(N31) ,
     3            M(N32) ,M(N33) ,M(N34) ,M(N35) ,M(N36) ,M(N37) ,
     4            M(N38) ,M(N39) ,M(N40) ,M(N41) ,M(N51) )
C
C     C O M P U T E   E R R O R   N O R M S
C
      CALL ERNORM(M(N13) ,M(N14) ,M(N39) ,M(N40) ,ERNRM ,EVNRM ,
     1            VNORM)
C
C     C H E C K   C O N V E R G E N C E
C
      CALL CONVER(ERNRM ,EVNRM ,NCHEK) 
      IF(NCHEK.EQ.1) GO TO 200
      NTITE = NTITE + 1
C
C     C O M P U T E   T H E   T A N G E N T   S T I F F N E S S   M A T R I X
C
      CALL STIFNS(M( N1) ,M( N3) ,M( N4) ,M( N5) ,M(N10) ,M(N13) ,
     1            M(N15) ,M(N16) ,M(N17) ,M(N18) ,M(N19) ,M(N20) ,
     2            M(N23) ,M(N24) ,M(N25) ,M(N27) ,M(N28) ,M(N29) ,
     3            M(N31) ,M(N32) ,M(N33) ,M(N34) ,M(N35) ,M(N36) ,
     4            M(N38) ,M(N51) ,M(N52) ,M(N53) ,M(N54) ,M(N55) )
C
C     S O L V E   T H E   S Y S T E M   O F   E Q U A T I O N S
C
      CALL SOLVE(M(N52) ,M(N54) ,M(N55))
C
C     U P D A T E   V A R I A B L E S
C
      CALL UPDATE(M( N1) ,M( N2) ,M( N9) ,M(N10) ,M(N13) ,M(N14) ,
     1            M(N54) )
100   CONTINUE
      NBADS = NBADS + 1
200   CONTINUE
C
C
C     O U T P U T   R E S U L T S 
C
C
C     PRINT MEAN NUMBER OF ITERATIONS
C
      CALL OUTITE(NTITE,IINCS)
C
C     ALLOCATE TEMPORAL WORK MEMORY SPACE
C
      NW1 = NE  + NDIME*NRSUR*IPR         ! REARS(NDIME,NRSUR)
      NW2 = NW1 + NPOIN                   ! KOUNT(NPOIN)
      NW3 = NW2 + NEXTR*NPOIN*IPR         ! EXTRA(NEXTR,NPOIN)
      CALL CHECKM(NW3)
      CALL ZERO(M(NE),NW3-NE)
C
C     PRINT RESULTS
C
      CALL OUTPUT(M( N1) ,M( N3) ,M(N13) ,M(N21) ,M(N23) ,M(N25) ,
     1            M(N27) ,M(N29) ,M(N31) ,M(N33) ,M(N39) ,M(N40) ,
     2            M(N41) ,M(N42) ,M(N46) ,M(N48) ,M( NE) ,M(NW1) ,
     3            M(NW2) )
C
C     WRITE PORTHOLE FILE
C
      CALL PRTHOL(M( N1) ,M( N2) ,M( N3) ,M(N13) ,M(NW2))
C
C     WRITE RESTART FILE 
C
      CALL RSTART(M( N1) ,M(N13) ,M(N21) ,M(N23) ,M(N25) ,M(N27) ,
     1            M(N32) ,M(N33) ,M(N35) ,M(N46) ,     2 )
300   CONTINUE
400   CONTINUE
C
C     WRITE SUMMARY OF THE ANALYSIS
C
      IF(IINCS.GT.NINCS) IINCS = NINCS
      CALL SUMMARY(NTITE,IINCS,NBADS)
      END

      SUBROUTINE OUTITE(NTITE,NINCS)
C*******************************************************************************
C
C*** PRINT MEAN NUMBER OF ITERATIONS EVOLUTION
C
C*******************************************************************************
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      MNITE = NTITE/NINCS
      IF(MOD(NTITE,NINCS).GT.0.5) MNITE = MNITE + 1
      WRITE(IOUT4,2000) NTITE,NINCS,MNITE
      RETURN
2000  FORMAT(1X,3I5)
      END

      SUBROUTINE SUMMARY(NTITE,NINCS,NBADS)
C*******************************************************************************
C
C*** PRINT SUMMARY OF THE ANALYSIS
C
C*******************************************************************************
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      MNITE = NTITE/NINCS
      IF(MOD(NTITE,NINCS).GT.0.5) MNITE = MNITE + 1
      WRITE(IOUT4,2000) NTITE,NINCS,NBADS,MNITE
      RETURN
2000  FORMAT(5X,'TOTAL NUMBER OF ITERATIONS ............. =',I10/
     1       5X,'TOTAL NUMBER OF TIME STEPS ............. =',I10/
     2       5X,'TOTAL NUMBER OF NON-CONVERGED STEPS .... =',I10/
     3       5X,'MEAN NUMBER OF ITERATIONS/STEP ......... =',I10)
      END

      SUBROUTINE IOFILE
C*******************************************************************************
C
C*** SET UP I/O PATHS AND OPEN FILES
C
C*******************************************************************************
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
C
C     SET UP I/O PATHS
C
      IINPT = 5
      IOUTP = 6
      ISAVE = 1
      IRSTA = 2
      IPHOL = 3
      IOUT1 = 11
      IOUT2 = 12
      IOUT3 = 13
      IOUT4 = 14
      IOUT5 = 15
      IOUT6 = 16
      IOUT7 = 17
C
C     OPEN FILES
C
      open(5,file='saran1.dts')
      open(6,file='saran1.o')
      
      OPEN(UNIT=ISAVE,
     1     NAME='MEFORM.SAV',
     2     TYPE='UNKNOWN',
     3     FORM='UNFORMATTED')
      OPEN(UNIT=IRSTA,
     1     NAME='MEFORM.RST',
     2     TYPE='UNKNOWN',
     3     FORM='UNFORMATTED')
      OPEN(UNIT=IPHOL,
     1     NAME='MEFORM.PHL',
     2     TYPE='UNKNOWN',
     3     FORM='UNFORMATTED')
      RETURN
      END

      SUBROUTINE DIMEN
C*******************************************************************************
C
C*** READ CONTROL VARIABLES TO SET UP DYNAMIC DIMENSIONING
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER*80 TITLE
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /TITLEP/ TITLE
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /CTRSCD/ NSURF ,NPAIR ,NCNOD ,NTNOD
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TABLAS/ NTABP ,NTABT
      COMMON /NPARAM/ NPARA
      COMMON /VOIDML/ NVOID
      COMMON /MIDZGP/ NMIDZ
      COMMON /DEFAUL/ IDSTA
      COMMON /EXTRAP/ NEXTR ,NGST2 ,NROWS
      common /bhcom1/ ibhol,xbh0,xbh1,bhf,idbhn(300),bhlod(300)
C
C     P R O B L E M   T I T L E
C
      READ(IINPT,*)
      READ(IINPT,1000) TITLE
      READ(IINPT,*)
      WRITE(IOUTP,2000) TITLE
C
C     PRE-ASSIGN CONTROL VALUES
C
C...    NUMBER OF SPACE DIMENSIONS (NDIME) = 2
C...    NUMBER OF NODES OF THE RIGID SEGMENTS (NNODR) = 2
C
      NDIME = 2
      NNODR = 2
C
C
C     C O N T R O L   V A R I A B L E S   F O R   
C     D Y N A M I C   D I M E N S I O N I N G
C
C...    NUMBER OF POINTS (NPOIN)
C...    NUMBER OF ELEMENTS (NELEM)
C...    NUMBER OF MATERIALS (NMATS)
C...    NUMBER OF NODES PER ELEMENT (NNODE)
C...    NUMBER OF DEGREES OF FREEDOM (NDOFN)
C...    NUMBER OF RESTRAINED NODES (NVFIX)
C
      READ(IINPT,*)
      READ(IINPT,1001) NPOIN,NELEM,NMATS,NNODE,NDOFN,NVFIX
      READ(IINPT,*)

      NEVAB = NNODE*NDOFN
      NTOTV = NPOIN*NDOFN
      NSTIF = 0.5*NEVAB*(NEVAB+1)

      WRITE(IOUTP,2001) NPOIN,NELEM,NMATS,NNODE,NDOFN,NVFIX
C
C
C     R E A D   C O N T R O L   V A R I A B L E S   F O R   T H E  
C     C O N T A C T   P R O B L E M 
C
C...    NUMBER OF RIGID SURFACES (NRSUR)
C...    NUMBER OF POINTS DEFINING ALL THE RIGID SURFACES (NRPOI)
C...    NUMBER OF ELEMENTS DEFINING ALL THE RIGID SURFACES (NRELE)
C
      READ(IINPT,*)
      READ(IINPT,1001) NRSUR,NRPOI,NRELE
C     READ(IINPT,1001) NSURF,NPAIR,NCNOD,NTNOD
      READ(IINPT,*)

      WRITE(IOUTP,2006) NRSUR,NRPOI,NRELE,NNODR
C     WRITE(IOUTP,2007) NSURF,NPAIR,NCNOD,NTNOD
C
C
C     S E L E C T   A N A L Y S I S   T Y P E   V A R I A B L E S
C
C...    NTYPE = 1     PLANE STRAIN
C...    NTYPE = 2     AXISYMMETRIC
C
C...    NFORM = 1     MEMBRANE KINEMATIC ELEMENTS
C...    NFORM = 2     SHELL KINEMATIC ELEMENTS
C...    NFORM = 3     SELECTIVE SHELL/MEMBRANE KINEMATIC ELEMENTS
C
C...    MODEL = 1     VON MISES PLASTIC MODEL
C...    MODEL = 2     VON MISES VISCOPLASTICO MODEL
C...    MODEL = 3     GURSON DAMAGE/PLASTIC MODEL
C...    MODEL = 4     GURSON DAMEGE/VISCOPLASTICO MODEL
C
C...    NHARD = 1     PERFECT PLASTICITY (WITHOUT HARDENING)
C...    NHARD > 1     HARDENING PLASTICITY LAWS
C
C...    NALGO = 1     APPROXIMATE FULL NEWTON-RAPHSON
C...    NALGO = 2     SECANT + GEOMETRIC STIFFNESS MATRICES 
C...    NALGO = 3     SECANT STIFFNESS MATRIX
C
C...    NCNTC = 1     ACTIVATE CONTACT
C...    NCNTC = 2     DEACTIVATE CONTACT
C
C...    NFRIC = 1     PERFECT SLIP CONDITION (ZERO FRICTION)
C...    NFRIC = 2     NONLINEAR COULOMB FRICTION MODEL
C...    NFRIC = 3     TRESCA KINEMATIC FRICTION MODEL
C...    NFRIC = 4     STICK CONDITION
C
C...    NAUTP = 0     NO AUTOMATIC PRESSURE COMPUTATION
C...    NAUTP = 1     AUTOMATIC PRESSURE CYCLE COMPUTATION
C
C...    NAUTT = 0     NO AUTOMATIC TIME INCREMENT COMPUTATION
C...    NAUTT = 1     AUTOMATIC TIME INCREMENT COMPUTATION
C
      READ(IINPT,*)
      READ(IINPT,1001) NTYPE,NFORM,MODEL,NHARD,NALGO,NCNTC,
     1                 NFRIC,NAUTP,NAUTT,ibhol
      READ(IINPT,*)
      WRITE(IOUTP,2002) NTYPE,NFORM
      WRITE(IOUTP,2003) MODEL,NHARD
      WRITE(IOUTP,2004) NALGO,NCNTC
      WRITE(IOUTP,2008) NFRIC,NAUTP
      WRITE(IOUTP,2009) NAUTT
C
C
C     R E A D   P A R A M E T E R S   O F   P R E S S U R E   A N D   
C     T I M E   I N C R E M E N T   T A B L E S 
C
C...    NUMBER OF ROWS FOR THE PRESSURE TABLE (NTABP)
C...    NUMBER OF ROWS FOR THE TIME INCREMENT TABLE (NTABT)
C
      READ(IINPT,*)
      READ(IINPT,1001) NTABP,NTABT
      READ(IINPT,*)
      WRITE(IOUTP,2005) NTABP,NTABT
C
C     SET UP CONTROL VARIABLES ACCORDING TO THE ANALYSIS TYPE
C
C...    NUMBER OF GENERALIZED STRESS COMPONENTS (NGSTR)
C...    NUMBER OF STRESS COMPONENTS (NSTRE)
C...    NUMBER OF INTEGRATION POINTS ALONG THE MIDSURFACE (NGAUS)
C...    NUMBER OF INTEGRATION POINTS ACCROSS THE THICKNESS (NGAUZ)
C...    NUMBER OF MATERIAL PROPERTIES (NPROP)
C...    NUMBER OF INTERNAL MATERIAL CONSTITUTIVE PARAMETERS (NPARA)
C
      IF(NTYPE.EQ.1.AND.NFORM.EQ.1) NGSTR = 1
      IF(NTYPE.EQ.1.AND.NFORM.GT.1) NGSTR = 3
      IF(NTYPE.EQ.2.AND.NFORM.EQ.1) NGSTR = 2
      IF(NTYPE.EQ.2.AND.NFORM.GT.1) NGSTR = 5

      IF(NTYPE.EQ.1.AND.NFORM.EQ.1) NSTRE = 1
      IF(NTYPE.EQ.1.AND.NFORM.GT.1) NSTRE = 2
      IF(NTYPE.EQ.2.AND.NFORM.EQ.1) NSTRE = 2
      IF(NTYPE.EQ.2.AND.NFORM.GT.1) NSTRE = 3

      IF(NFORM.EQ.1) NGAUZ = 1
      IF(NFORM.GT.1) NGAUZ = 3

      IF(MODEL.EQ.1) NPROP = 1
      IF(MODEL.EQ.2) NPROP = 3
      IF(MODEL.EQ.3) NPROP = 3
      IF(MODEL.EQ.4) NPROP = 5
      IF(MODEL.EQ.5) NPROP = 3

      IF(MODEL.EQ.1.OR.MODEL.EQ.2) NPARA = 1
      IF(MODEL.EQ.3.OR.MODEL.EQ.4) NPARA = 2
      IF(MODEL.EQ.5)               NPARA = 1

      IF(NFRIC.LT.4) IDSTA = 1
      IF(NFRIC.EQ.4) IDSTA = 2

      NGAUS = 1
      NGASP = NGAUS
      NGAZP = NGAUS*NGAUZ
      NGAST = NGASP*NELEM
      NGAZT = NGAZP*NELEM
      NMIDZ = NGAUZ/2 + 1

      IF(MODEL.EQ.1.OR.MODEL.EQ.2) NVOID = 1
      IF(MODEL.EQ.3.OR.MODEL.EQ.4) NVOID = NGAZT
      IF(MODEL.EQ.5)               NVOID = 1

      NGST2 = 2*NGSTR
      NROWS = 3
      IF(MODEL.EQ.3.OR.MODEL.EQ.4) NROWS = NROWS + 1
      NEXTR = NGST2 + NROWS

      RETURN
C
C     FORMATS
C
1000  FORMAT(1A80)
1001  FORMAT(16I5)
2000  FORMAT(1X,1A80)
2001  FORMAT(//' P A R A M E T R O S   D E   C O N T R O L'//
     1   5X,'NUMERO DE PUNTOS NODALES ......................... = ',I5/ 
     2   5X,'NUMERO DE ELEMENTOS .............................. = ',I5/
     3   5X,'NUMERO DE MATERIALES ............................. = ',I5/
     4   5X,'NUMERO DE NODOS POR ELEMENTO ..................... = ',I5/
     5   5X,'NUMERO DE GRADOS DE LIBERTAD POR NODO ............ = ',I5/
     6   5X,'NUMERO DE NODOS CON VELOCIDAD PRESCRITA .......... = ',I5)
2006  FORMAT(//' P A R A M E T R O S   D E   C O N T R O L '
     1         '  D E L   C O N T A C T O'//
     2   5X,'NUMERO DE SUPERFICIES RIGIDAS DE CONTACTO ........ = ',I5/
     3   5X,'NUMERO DE NODOS QUE DEFINEN LAS SUPERFICIES ...... = ',I5/
     4   5X,'NUMERO DE ELEMENTOS QUE DEFINEN LAS SUPERFICIES .. = ',I5/
     5   5X,'NUMERO DE NODOS POR ELEMENTO ..................... = ',I5)
C2007  FORMAT(/
C    1   5X,'NUMERO DE SUPERFICIES DEFORMABLES DE CONTACTO .... = ',I5/
C    2   5X,'NUMERO DE PARES DE SUPEFICIES .................... = ',I5/
C    3   5X,'NUMERO DE NODOS CONTACTOR ........................ = ',I5/
C    4   5X,'NUMERO DE NODOS OBJETIVO ......................... = ',I5)
2002  FORMAT(//' P A R A M E T R O S   D E L   A N A L I S I S'//
     1   5X,'TIPO DE ANALISIS ................................. = ',I5/
     2   5X,'   1 = DEFORMACION PLANA'/
     3   5X,'   2 = AXISIMETRICO'/
     4   5X,'TIPO DE FORMULACION .............................. = ',I5/
     5   5X,'   1 = MEMBRANA'/
     6   5X,'   2 = COMPLETA MEMBRANA/FLEXION/CORTANTE')
2003  FORMAT(
     1   5X,'MODELO CONSTITUTIVO MATERIAL ..................... = ',I5/
     2   5X,'   1 = PLASTICO DE VON MISES'/
     3   5X,'   2 = VISCOPLASTICO DE VON MISES'/
     4   5X,'   3 = PLASTICO CON DEGRADACION DE GURSON'/
     5   5X,'   4 = VISCOPLASTICO CON DEGRADACION DE GURSON'/
     6   5X,'   5 = ELASTICO NO LINEAL'/
     7   5X,'TIPO DE PLASTICIDAD .............................. = ',I5/
     8   5X,'   1 = PLASTICIDAD PERFECTA'/
     9   5X,'   2 = PLASTICIDAD CON ENDURECIMIENTO')
2004  FORMAT(
     1   5X,'ALGORITMO DE SOLUCION ............................ = ',I5/
     2   5X,'   1 = FULL NEWTON'/
     3   5X,'   2 = SECANTE + GEOMETRICA (IS)'/
     4   5X,'   3 = SECANTE'/
     5   5X,'CONTACTO ......................................... = ',I5/
     6   5X,'   1 = CONTACTO NO ACTIVADO'/
     7   5X,'   2 = CONTACTO ACTIVADO')
2008  FORMAT(
     1   5X,'MODELO DE FRICCION ............................... = ',I5/
     2   5X,'   1 = NO FRICCION'/
     3   5X,'   2 = MODELO DE FRICCION DE COULOMB'/
     4   5X,'   3 = MODELO DE FRICCION DE TRESCA'/
     5   5X,'   4 = FRICCION INFINITA'/
     6   5X,'CALCULO AUTOMATICO DEL CICLO DE PRESION .......... = ',I5/
     7   5X,'   0 = NO'/
     8   5X,'   1 = SI')
2009  FORMAT(
     1   5X,'CALCULO AUTOMATICO DEL INCREMENTO DE TIEMPO ...... = ',I5/
     2   5X,'   0 = NO'/
     3   5X,'   1 = SI')
2005  FORMAT(//' P A R A M E T R O S   D E   C O N T R O L   D E '
     1         '  T A B L A S'//
     2   5X,'NUMERO DE PUNTOS DE DEFINICION DE LA'/
     3   5X,'   TABLA DE PRESIONES ........................ = ',I5/
     4   5X,'NUMERO DE PUNTOS DE DEFINICION DE LA'/ 
     5   5X,'   TABLA DE INCREMENTOS DE TIEMPO ............ = ',I5)
      END

      SUBROUTINE INPUT(COORD,LNODS,MATNO,PROPS,NOFIX,IFPRE,
     1                 PRESC,IFFIX,FIXED,TABPR,TABDT,NELRS,
     2                 VELRS,FRICT,LNODR,RSCOR,WORKA)
C*******************************************************************************
C
C*** READ MAIN DATA PROBLEM
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TABLAS/ NTABP ,NTABT
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /PLOADS/ PRESS
      COMMON /TOLERA/ TOLEF ,TOLEV 
      COMMON /ACTNRM/ IRNRM ,IVNRM
      COMMON /GAUSS / POSGP(3) ,WEIGP(3)
      COMMON /GAUSSZ/ POSZP(5) ,WEIZP(5)
      COMMON /INITHK/ THIKI
      COMMON /INISTR/ HSTRI(3) ,STRIN(5)
      COMMON /PENALT/ PNLTC ,PNLTF
      COMMON /PRINTS/ IPCCS ,IPVEL ,IPREA ,IPSNR ,IPSTN ,IPSTR ,
     1                IPTHG ,IPPOR ,IPAVN
      COMMON /OUTFIL/ IPPHL ,IPRST
      COMMON /AUTPRC/ EPFIX ,EXPON
      COMMON /AUTODT/ DEMAX
      common /bhcom1/ ibhol,xbh0,xbh1,bhf,idbhn(100),bhlod(100)
      DIMENSION 
     1   LNODS(NNODE,    1) ,MATNO(    1) ,COORD(NDIME,    1) ,
     2   PROPS(NPROP,    1) ,NOFIX(    1) ,IFPRE(NDOFN,    1) ,
     3   PRESC(NDOFN,    1) ,IFFIX(    1) ,FIXED(          1) ,
     4   TABPR(    2,    1) ,TABDT( 2, 1) ,NELRS(          1) ,
     5   VELRS(NDIME,    1) ,FRICT(    1) ,LNODR(NNODR,    1) ,
     6   RSCOR(NDIME,    1) ,WORKA(    1)
C
C
C     T I M E   I N T E G R A T I O N   P A R A M E T E R S
C
C...    NUMBER OF TIME INCREMENTS (NINCS)
C...    INITIAL ANALYSIS TIME (TIME0)
C...      (RESTART ANALYSIS ALLOWED FOR TIME0.GT.0)
C...    FINAL ANALYSIS TIME (TIMEF)
C...    CONSTANT/INITIAL TIME INCREMENT (DTIME)
C...    TIME INTEGRATION PARAMETER (ACOEF)
C
      READ(IINPT,*)
      READ(IINPT,1000) NINCS,TIME0,TIMEF,DTIME,ACOEF
      READ(IINPT,*)
      IF(TIMEF.EQ.0.0) TIMEF = 1.0E+30
      WRITE(IOUTP,2000) NINCS,TIME0,TIMEF,DTIME,ACOEF
C
C     
C     E Q U I L I B R I U M   I T E R A T I O N S   A N D  
C     C O N V E R G E N C E   T O L E R A N C E 
C
C...    MAXIMUM NUMBER OF ITERATIONS (MITER)
C...    EQUILIBRIUM TOLERANCE IN FORCES (TOLEF)
C...    CONVERGENCE TOLERANCE IN VELOCITIES (TOLEV)
C...    CODE FOR CONVERGENCE IN FORCES (IRNRM)
C...    CODE FOR CONVERGENCE IN VELOCITIES (IVNRM)
C
      READ(IINPT,*)
      READ(IINPT,1005) MITER,TOLEF,TOLEV,IRNRM,IVNRM
      READ(IINPT,*)
      WRITE(IOUTP,2100) MITER,TOLEF,TOLEV,IRNRM,IVNRM
C
C
C     P R I N T E R   C O D E S 
C
C
      READ(IINPT,*)
      READ(IINPT,1001) IPMSH,IPMAT,IPFIX,IPTPR,IPTDT,IPCTC
      READ(IINPT,1001) IPCCS,IPVEL,IPREA,IPSNR,IPSTN,IPSTR,
     1                 IPTHG,IPPOR,IPAVN
      READ(IINPT,*)
      WRITE(IOUTP,2002) IPMSH,IPMAT,IPFIX,IPTPR,IPTDT,IPCTC
      WRITE(IOUTP,2102) IPCCS,IPVEL,IPREA,IPSNR,IPSTN,IPSTR
      WRITE(IOUTP,2202) IPTHG,IPPOR,IPAVN
C
C
C     N O D A L   C O O R D I N A T E S   
C
C
      READ(IINPT,*)
      DO 10 I = 1,NPOIN
      READ(IINPT,1002) IPOIN,(COORD(IDIME,IPOIN),IDIME=1,NDIME)
10    CONTINUE
      READ(IINPT,*)
C
C     PRINT NODAL COORDINATES
C
      IF(IPMSH.EQ.0) GO TO 12
      WRITE(IOUTP,2005)
      DO 11 IPOIN = 1,NPOIN,4
      JPOIN = IPOIN + 3
      IF(JPOIN.GT.NPOIN) JPOIN = NPOIN
      WRITE(IOUTP,2006) (I,COORD(1,I),COORD(2,I),I=IPOIN,JPOIN)
11    CONTINUE
12    CONTINUE
C
C
C     E L E M E N T   D A T A
C
C...    MATERIAL NUMBER (MATNO(NUMEL))
C...    ELEMENT NODE NUMBERS (LNODS(NNODE,NELEM))
C
      READ(IINPT,*)
      DO 20 IELEM = 1,NELEM
      READ(IINPT,1001) NUMEL,MATNO(NUMEL),
     1   (LNODS(INODE,NUMEL),INODE=1,NNODE)
20    CONTINUE
      READ(IINPT,*)
C
C     PRINT ELEMENT DATA
C
      IF(IPMSH.EQ.0) GO TO 22
      WRITE(IOUTP,2003)
      DO 21 IELEM = 1,NELEM
      WRITE(IOUTP,2004) IELEM,MATNO(IELEM),
     1   (LNODS(INODE,IELEM),INODE=1,NNODE)
21    CONTINUE
22    CONTINUE
C
C
C     M A T E R I A L   P R O P E R T I E S
C
C
C        MODEL 1
C           PROPS(1) = INITIAL UNIAXIAL YIELD STRESS
C
C        MODEL 2
C           PROPS(1) = INITIAL UNIAXIAL YIELD STRESS
C           PROPS(2) = VISCOPLASTIC CONSISTENCY PARAMETER GAMMA 
C           PROPS(3) = VISCOPLASTIC SENSITIVITY PARAMETER
C
C        MODEL 3
C           PROPS(1) = INITIAL UNIAXIAL YIELD STRESS
C           PROPS(2) = UNIFORM INITIAL POROSITY
C           PROPS(3) = VOID NUCLEATION PARAMETER
C
C        MODEL 4
C           PROPS(1) = INITIAL UNIAXIAL YIELD STRESS
C           PROPS(2) = VISCOPLASTIC CONSISTENCY PARAMETER GAMMA 
C           PROPS(3) = VISCOPLASTIC SENSITIVITY PARAMETER
C           PROPS(4) = UNIFORM INITIAL POROSITY
C           PROPS(5) = VOID NUCLEATION PARAMETER
C
C        MODEL 5
C           PROPS(1) = DUMMY VARIABLE
C           PROPS(2) = YOUNG ELASTICITY MODULI
C           PROPS(3) = POISSON COEFFICIENT
C
      READ(IINPT,*)
      DO 30 IMATS = 1,NMATS
      READ(IINPT,1001) NUMAT
      READ(IINPT,1003) (PROPS(IPROP,NUMAT),IPROP=1,NPROP)
30    CONTINUE
      IF(IPMAT.EQ.0) GO TO 32
      WRITE(IOUTP,2007)
      DO 31 IMATS = 1,NMATS
      WRITE(IOUTP,2008) IMATS,(PROPS(IPROP,IMATS),IPROP=1,NPROP)
31    CONTINUE
32    CONTINUE
      READ(IINPT,*)
C
C
C     U N I F O R M   I N I T I A L   T H I C K N E S S
C
C
      READ(IINPT,*)
      READ(IINPT,1003) THIKI
      IF(IPMSH.NE.0) WRITE(IOUTP,2106) THIKI
      READ(IINPT,*)
C
C
C     F I C T I T I O U S   H O M O G E N E U S   I N I T I A L   S T R E S S
C
C
      READ(IINPT,*)
      READ(IINPT,1003) (HSTRI(ISTRE),ISTRE=1,NSTRE)
      IF(IPMAT.NE.0) 
     1WRITE(IOUTP,2016) (HSTRI(ISTRE),ISTRE=1,NSTRE)
      READ(IINPT,*)
      DO 40 IGSTR = 1,NGSTR
      STRIN(IGSTR) = 0.0
40    CONTINUE
C
C
C     P R E S C R I B E D   V E L O C I T I E S 
C
C...    PRESCRIBED CODES (IFFIX(NTOTV))
C...       (FREE = 0, FIXED = 1)
C...    PRESCRIBED VALUES (FIXED(NTOTV))
C
      IF(NVFIX.EQ.0) GO TO 53
      DO 50 ITOTV = 1,NTOTV
      IFFIX(ITOTV) = 0
      FIXED(ITOTV) = 0.0
50    CONTINUE
      READ(IINPT,*)
      DO 51 IVFIX = 1,NVFIX
      READ(IINPT,1004) NOFIX(IVFIX),
     1                (IFPRE(IDOFN,IVFIX),IDOFN=1,NDOFN),
     2                (PRESC(IDOFN,IVFIX),IDOFN=1,NDOFN)
      LVFIX = NOFIX(IVFIX)
      LEVAB = (LVFIX-1)*NDOFN
      DO 51 IDOFN = 1,NDOFN
      LEVAB = LEVAB + 1
      IFFIX(LEVAB) = IFPRE(IDOFN,IVFIX)
      FIXED(LEVAB) = PRESC(IDOFN,IVFIX) 
51    CONTINUE
      READ(IINPT,*)
C
C     PRINT PRESCRIBED VELOCITIES DATA
C
      IF(IPFIX.EQ.0) GO TO 53
      WRITE(IOUTP,2009)
      DO 52 IVFIX = 1,NVFIX
      WRITE(IOUTP,2010) NOFIX(IVFIX),
     1                 (IFPRE(IDOFN,IVFIX),IDOFN=1,NDOFN),
     2                 (PRESC(IDOFN,IVFIX),IDOFN=1,NDOFN)
52    CONTINUE
53    CONTINUE
C
C
C     P R E S S U R E   T A B L E
C
C...    TIME/PRESSURE
C
      IF(NTABP.EQ.0) GO TO 63
      READ(IINPT,*)
      DO 60 ITABP = 1,NTABP
      READ(IINPT,1003) (TABPR(I,ITABP),I=1,2)
60    CONTINUE
      PRESS = TABPR(2,1)
      READ(IINPT,*)
C
C     PRINT PRESSURE TABLE
C
      IF(IPTPR.EQ.0) GO TO 64
      WRITE(IOUTP,2011)
      DO 61 ITABP = 1,NTABP
      WRITE(IOUTP,2012) TABPR(1,ITABP),TABPR(2,ITABP)
61    CONTINUE
      GO TO 64
63    CONTINUE
      READ(IINPT,1003) PRESS
      IF(IPTPR.EQ.0) GO TO 64
      WRITE(IOUTP,2013) PRESS
64    CONTINUE     
C
C
C     T I M E   I N C R E M E N T   T A B L E 
C
C...    TIME/TIME INCREMENT
C
      IF(NTABT.EQ.0) GO TO 72
      READ(IINPT,*)
      DO 70 ITABT = 1,NTABT
      READ(IINPT,1003) (TABDT(I,ITABT),I=1,2)
70    CONTINUE
      READ(IINPT,*)
C
C     PRINT TIME INCREMENT TABLE
C
      IF(IPTDT.EQ.0) GO TO 72
      WRITE(IOUTP,2014)
      DO 71 ITABT = 1,NTABT
      WRITE(IOUTP,2015) TABDT(1,ITABT),TABDT(2,ITABT)
71    CONTINUE
72    CONTINUE
C
C
C     R I G I D   C O N T A C T   S U R F A C E S
C
C
C...    NUMBER OF SEGMENTS FOR EACH RIGID SURFACE (NELRS(IRSUR))
C...    FRICTION COEFFICIENT FOR EACH RIGID SURFACE (FRICT(IRSUR))
C...    VELOCITY FOR EACH RIGID SURFACE (VELRS(IDIME,IRSUR))
C...    SEGMENT NODES FOR ALL RIGID SURFACES (LNODR(INODR,IELRS))
C
      READ(IINPT,*)
      KELRS = 0
      DO 80 JRSUR = 1,NRSUR
      READ(IINPT,1001) IRSUR,NELRS(IRSUR)
      READ(IINPT,1003) (VELRS(IDIME,IRSUR),IDIME=1,NDIME)
      READ(IINPT,1003) FRICT(IRSUR)
      DO 80 IELRS = 1,NELRS(IRSUR)
      KELRS = KELRS + 1
      READ(IINPT,1001) (LNODR(INODR,KELRS),INODR=1,NNODR)
80    CONTINUE
      READ(IINPT,*)
C
C     RIGID POINTS COORDINATES
C
      READ(IINPT,*)
      DO 81 JRPOI = 1,NRPOI
      READ(IINPT,1000) IRPOI,(RSCOR(IDIME,IRPOI),IDIME=1,NDIME)
81    CONTINUE
      READ(IINPT,*)
C
C     PENALTY FACTORS FOR CONTACT AND FRICTION
C
C...    CONTACT PENALTY (PNLTC)
C...    FRICTION PENALTY (PNLTF)
C
      READ(IINPT,*)
      READ(IINPT,1003) PNLTC,PNLTF
      READ(IINPT,*)
      IF(PNLTC.EQ.0.0) PNLTC = 1.0E+15
      IF(PNLTF.EQ.0.0) PNLTF = 1.0E+07
C
C     PRINT RIGID SURFACES DATA
C
      IF(IPCTC.EQ.0) GO TO 84
      WRITE(IOUTP,2017)
      KELRS = 0
      DO 82 IRSUR = 1,NRSUR
      WRITE(IOUTP,2018) IRSUR,NELRS(IRSUR),
     1   (VELRS(IDIME,IRSUR),IDIME=1,NDIME),FRICT(IRSUR)
      WRITE(IOUTP,2019) 
      DO 82 IELRS = 1,NELRS(IRSUR)
      KELRS = KELRS + 1
      WRITE(IOUTP,2020) KELRS,(LNODR(INODR,KELRS),INODR=1,NNODR)
82    CONTINUE
      WRITE(IOUTP,2021) 
      DO 83 IRPOI = 1,NRPOI,4
      JRPOI = IRPOI + 3
      IF(JRPOI.GT.NRPOI) JRPOI = NRPOI
      WRITE(IOUTP,2006) (I,RSCOR(1,I),RSCOR(2,I),I=IRPOI,JRPOI)
83    CONTINUE
      WRITE(IOUTP,2022) PNLTC,PNLTF
84    CONTINUE
C
C     O U T P U T   F I L E S   W R I T E   C O D E S 
C
C...    PORTHOLE CODE (FOR POSTPROCESS) (IPPHL)
C...    RESTART CODE (IPRST)
C
      READ(IINPT,*)
      READ(IINPT,1001) IPPHL,IPRST
      READ(IINPT,*)
      WRITE(IOUTP,2023) IPPHL,IPRST
C
C     A U T O M A T I C   P R E S S U R E   C Y C L E   C O M P U T A T I O N 
C     P A R A M E T E R S 
C
C...    TARGET VALUE OF THE MAXIMUM EQUIVALENT PLASTIC STRAIN RATE (EPFIX)
C...    EXPONENT TO USE IN THE COMPUTATION OF THE PRESSURE (EXPON)
C
      IF(NAUTP.GT.0) THEN
        READ(IINPT,*)
        READ(IINPT,1003) EPFIX,EXPON
        READ(IINPT,*)
        WRITE(IOUTP,2024) EPFIX,EXPON
      END IF
C
C     A U T O M A T I C   T I M E   I N C R E M E N T   C O M P U T A T I O N 
C     P A R A M E T E R S 
C
C...    MAXIMUM INCREMENTAL EQUIVALENT PLASTIC STRAIN (DEMAX)
C
      IF(NAUTT.GT.0) THEN
        READ(IINPT,*)
        READ(IINPT,1003) DEMAX
        READ(IINPT,*)
        WRITE(IOUTP,2025) DEMAX
      END IF
c
c     blank-holder data
c
      if(ibhol.gt.0) then
        read(iinpt,*)
        read(iinpt,1003) xbh0,xbh1,bhf
        print *, '> read blank-holder data'
        print *, xbh0,'  ',xbh1,'  ',bhf
      end if
C
C     SET UP GAUSS INTEGRATION PARAMETERS
C
      CALL PGAUS(NGAUS,POSGP,WEIGP)
      CALL PGAUS(NGAUZ,POSZP,WEIZP)
      RETURN
C
C     FORMATOS 
C
1000  FORMAT(I5,4F10.0)
1001  FORMAT(16I5)
1002  FORMAT(I5,3F10.0) 
1003  FORMAT(8F10.0)
1004  FORMAT(I5,<NDOFN>I5,3F10.0)
1005  FORMAT(I5,2F10.0,2I5)
2000  FORMAT(//' P A R A M E T R O S   D E   I N T E G R A C I O N '
     1         '  E N   E L   T I E M P O'//
     2   5X,'NUMERO DE INCREMENTOS DE TIEMPO .............. = ',I5/
     3   5X,'TIEMPO INICIAL DEL ANALISIS .................. = ',E10.4/
     4   5X,'TIEMPO FINAL DEL ANALISIS .................... = ',E10.4/
     5   5X,'INCREMENTO DE TIEMPO ......................... = ',F10.3/
     6   5X,'COEFICIENTE DE AVANCE EN EL TIEMPO ........... = ',F10.3)
2100  FORMAT(//' I T E R A C I O N E S   D E   E Q U I L I B R I O'//
     1   5X,'NUMERO MAXIMO DE ITERACIONES DE EQUILIBRIO ... = ',I5/
     2   5X,'TOLERANCIA DE CONVERGENCIA EN FUERZAS ........ = ',E10.4/
     3   5X,'TOLERANCIA DE CONVERGENCIA EN VELOCIDADES..... = ',E10.4/
     4   5X,'CODIGO ACTIVACION TOLERANCIA FUERZAS ......... = ',I5/
     5   5X,'CODIGO ACTIVACION TOLERANCIA VELOCIDADES ..... = ',I5)
2002  FORMAT(//' C O D I G O S   D E   I M P R E S I O N'//
     1   5X,'DATOS DEL ANALISIS'/
     2   5X,'   DATOS DE LA MALLA ......................... = ',I5/
     3   5X,'   DATOS DE PROPIEDADES DE LOS MATERIALES .... = ',I5/
     4   5X,'   DATOS DE CONDICIONES DE CONTORNO .......... = ',I5/
     5   5X,'   DATOS DE LA TABLA DE PRESIONES ............ = ',I5/
     6   5X,'   DATOS DE LA TABLA DE INCREMENTOS DE TIEMPO. = ',I5/
     7   5X,'   DATOS DE LAS SUPERFICIES DE CONTACTO ...... = ',I5)
2102  FORMAT(
     1   5X,'RESULTADOS DEL ANALISIS'/
     2   5X,'   INFORME DEL ANALISIS DE CONTACTO .......... = ',I5/
     3   5X,'   VELOCIDADES ............................... = ',I5/
     4   5X,'   FUERZAS INTERNAS / REACCIONES ............. = ',I5/
     5   5X,'   VELOCIDADES DE DEFORMACION ................ = ',I5/
     6   5X,'   DEFORMACIONES ............................. = ',I5/
     7   5X,'   TENSIONES GENERALIZADAS ................... = ',I5)
2202  FORMAT(
     1   5X,'   ESPESOR EN LOS PUNTOS DE GAUSS ............ = ',I5/
     2   5X,'   POROSIDAD EN LOS PUNTOS DE GAUSS .......... = ',I5/
     3   5X,'   VALORES PROMEDIADOS EN LOS NODOS .......... = ',I5)
2003  FORMAT(//' D A T O S   D E   L O S   E L E M E N T O S'//
     1   1X,5X,'ELEMENTO',2X,'MATERIAL',2X,'CONEXIONES NODALES')
2004  FORMAT(1X,5X,I5,5X,I5,5X,8I5)
2005  FORMAT(//' C O O R D E N A D A S   N O D A L E S'//,
     1   1X,4(1X,' NODO','       COORDENADAS      '))
2006  FORMAT(1X,4(1X,I5,2E12.3))
2106  FORMAT(//' E S P E S O R   I N I C I A L'//,
     1   5X,'ESPESOR INICIAL UNIFORME ..................... = ',F10.5)
2007  FORMAT(//' P R O P I E D A D E S   D E L   M A T E R I A L'//)
2008  FORMAT(1X,I5,5E12.3)
2009  FORMAT(//' V E L O C I D A D E S   P R E S C R I T A S'//
     1   1X,5X,' NODO    CODIGO     VALORES  PRESCRITOS')
2010  FORMAT(1X,5X,I5,<10-NDOFN>X,<NDOFN>I1,3F12.5)
2011  FORMAT(//' T A B L A   D E   P R E S I O N E S'//,
     1   1X,10X,'TIEMPO',5X,'   PRESION'/,
     2   1X,10X,6('-')  ,5X,   10('-')   )
2012  FORMAT(1X,F16.5,F15.3)
2013  FORMAT('PRESION = ',F15.3)
2014  FORMAT(//' T A B L A   D E   I N C R E M E N T O S   D E '
     1   '  T I E M P O'//,
     2   1X,10X,'TIEMPO',5X,'INCREMENTO'/,
     3   1X,10X, 6('-') ,5X,   10('-')   )
2015  FORMAT(1X,F16.4,F15.3)
2016  FORMAT(//' T E N S I O N E S   H O M O G E N E A S '
     1   '  I N I C I A L E S'//,
     2   1X,5X,3E12.3)   
2017  FORMAT(//' D A T O S   D E   L O S   E L E M E N T O S   D E '
     1   '  L A S   S U P E R F I C I E S   D E   C O N T A C T O')
2018  FORMAT(/,
     1   5X,'SUPERFICIE DE CONTACTO RIGIDA NUMERO',I5,/
     2   5X,'   NUMERO DE ELEMENTOS ....................... = ',I3/
     3   5X,'   VELOCIDAD PRESCRITA'/
     4   5X,'      DIRECCION - X .......................... = ',F10.5/
     5   5X,'      DIRECCION - Y .......................... = ',F10.5/
     6   5X,'   COEFICIENTE DE FRICCION ................... = ',F10.5)
2019  FORMAT(/,1X,5X,'ELEMENTO',3X,'NODOS')
2020  FORMAT(1X,5X,I8,3X,2I5)
2021  FORMAT(/,
     1   5X,'COORDENADAS NODOS DE LAS SUPERFICIES DE CONTACTO'//
     2   1X,4(1X,' NODO','       COORDENADAS      '))
2022  FORMAT(/,
     1   5X,'FACTOR DE PENALIZACION DEL CONTACTO .......... = ',E10.3/
     2   5X,'FACTOR DE PENALIZACION DE LA FRICCION ........ = ',E10.3)
2023  FORMAT(//' C O D I G O S   D E   E S C R I T U R A   D E '
     1   '  F I C H E R O S   D E   S A L I D A'//
     2   5X,'FICHERO PORTHOLE ............................. = ',I5/
     3   5X,'FICHERO RESTART .............................. = ',I5)
2024  FORMAT(//' P A R A M E T R O S   D E L   C A L C U L O '
     1   '  A U T O M A T I C O   D E L   C I C L O   D E '
     2   '  P R E S I O N'//
     3   5X,'VALOR OBJETIVO DE LA MAX. EQPSTR ............. = ',E10.3/
     4   5X,'EXPONENTE ..... .............................. = ',E10.3)
2025  FORMAT(//' P A R A M E T R O S   D E L   C A L C U L O '
     1   '  A U T O M A T I C O   D E L   I N C R E M E N T O'
     2   '   D E   T I E M P O'//
     3   5X,'MAX. DEFORMACION PLASTICA EFECTIVA INCREMENTAL = ',E10.3)
      END

      SUBROUTINE PGAUS(NGAUS,POSGP,WEIGP)
C*******************************************************************************
C
C*** CALCULA LOS PARAMETROS DE INTEGRACION NUMERICA
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION POSGP(5) ,WEIGP(5)
      IF(NGAUS.GT.1) GO TO 2
C
C     1 PUNTO DE INTEGRACION
C
      POSGP(1) = 0.0
      WEIGP(1) = 2.0
      RETURN
C
C     2 PUNTOS DE INTEGRACION
C
2     IF(NGAUS.GT.2) GO TO 3
      POSGP(1) = -0.577350269189626
      WEIGP(1) = 1.0
      POSGP(2) = -POSGP(1)
      WEIGP(2) = WEIGP(1)
      RETURN
C
C     3 PUNTOS DE INTEGRACION
C
3     IF(NGAUS.GT.3) GO TO 5
      POSGP(1) = -0.774596669241483
      POSGP(2) = 0.0
      WEIGP(1) = 0.5555555555555556
      WEIGP(2) = 0.8888888888888889
      POSGP(3) = -POSGP(1)
      WEIGP(3) = WEIGP(1)
      RETURN
C
C     5 PUNTOS DE INTEGRACION
C
5     G = DSQRT(40.D0/7.D0)
      H = 45.5D0*G
      POSGP(1) = -DSQRT(5.D0+G)/3.D0
      POSGP(2) = -POSGP(1)
      POSGP(3) = 0.D0
      POSGP(4) = -DSQRT(5.D0-G)/3.D0
      POSGP(5) = -POSGP(4)
      WEIGP(1) = (322.D0-H)/900.D0
      WEIGP(2) = WEIGP(1)
      WEIGP(3) = 128.D0/225.D0
      WEIGP(4) = (322.D0+H)/900.D0
      WEIGP(5) = WEIGP(4)
      RETURN
      END

      SUBROUTINE LINKIN(IFFIX,LEQNS,LNODS,MAXAD,MHIGH,NDOFN,
     1                  NELEM,NEQNS,NNODE,NPOIN,NEVAB,NTOTV,
     2                  NWKTL,MLARG)
C*******************************************************************************
C
C*** LINKADO CON SOLUCION EN SKYLINE
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      DIMENSION
     1   LNODS(NNODE,    1) ,IFFIX(          1) ,MAXAD(    1) ,
     2   MHIGH(          1) ,LEQNS(NEVAB,    1)
C
C     DETERMINA EL NUMERO DE ECUACIONES
C
      NEQNS = 0
      DO 100 ITOTV = 1,NTOTV
      IF(IFFIX(ITOTV)) 110,120,110
  120 NEQNS = NEQNS + 1
      IFFIX(ITOTV) = NEQNS
      GO TO 150
  110 IFFIX(ITOTV) = 0
  150 CONTINUE
  100 CONTINUE
C
C     FORMA LA MATRIZ DE DIRECCIONES DE LOS GRADOS DE LIBERTAD
C     DE CADA ELEMENTO Y CALCULA LAS ALTURAS DEL PERFIL
C                   
      DO 50 IELEM = 1,NELEM
      IEVAB = 1
      DO 80 INODE = 1,NNODE
      IDENT = LNODS(INODE,IELEM)
      DO 80 IDOFN = 1,NDOFN
      ITOTV = (IDENT-1)*NDOFN + IDOFN
      LEQNS(IEVAB,IELEM) = IFFIX(ITOTV)
   80 IEVAB = IEVAB + 1 
      CALL COLMHT(MHIGH,NEVAB,LEQNS(1,IELEM))
   50 CONTINUE
C
C     DIRECCIONES DE LOS ELEMENTOS DE LA DIAGONAL - MAXAD -
C
      CALL ADDRES(NEQNS,NWKTL,MKOUN,MAXAD,MHIGH)
      WRITE(IOUTP,920) NEQNS,NWKTL
C     WRITE(IOUTP,930) (MAXAD(I),I=1,NEQNS+1)
C 930 FORMAT(5X,20I5)
  920 FORMAT(/5X,'NEQNS = ',I10,10X,'NWKTL = ',I10/)
      IF(NWKTL.GE.MLARG) GO TO 210
      GO TO 220
  210 WRITE(IOUTP,910)
  910 FORMAT(/'SET DIMENSION EXCEEDED - CHECK LINKIN '/)
      STOP
  220 CONTINUE
      RETURN
      END          

      SUBROUTINE COLMHT(MHIGH,NEVAB,LEQNS)
C*******************************************************************************
C
C*** EVALUA LAS ALTURAS DE COLUMNA DE LA MATRIZ DE RIGIDEZ
C
C*******************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION LEQNS(1),MHIGH(1)
      MAXAM = 100000
      DO 100 IEVAB = 1,NEVAB
      IF(LEQNS(IEVAB)) 110,100,110
  110 IF(LEQNS(IEVAB)-MAXAM) 120,100,100
  120 MAXAM = LEQNS(IEVAB)
  100 CONTINUE
      DO 200 IEVAB = 1,NEVAB
      IEQNS = LEQNS(IEVAB)
      IF(IEQNS.EQ.0) GO TO 200
      JHIGH = IEQNS-MAXAM
      IF(JHIGH.GT.MHIGH(IEQNS)) MHIGH(IEQNS) = JHIGH
  200 CONTINUE
      RETURN
      END

      SUBROUTINE ADDRES(NEQNS,NWKTL,MKOUN,MAXAD,MHIGH)
C*******************************************************************************
C
C*** EVALUA LAS DIRECCIONES DE LOS ELEMENTOS DE LA DIAGONAL
C
C*******************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z) 
      DIMENSION MAXAD(1),MHIGH(1)
      NEQNN = NEQNS + 1
      DO 10 IEQNN = 1,NEQNN
   10 MAXAD(IEQNN) = 0.0
      MAXAD(1) = 1
      MAXAD(2) = 2
      MKOUN = 0
      IF(NEQNS.EQ.1) GO TO 30
      DO 20 IEQNS = 2,NEQNS
      IF(MHIGH(IEQNS).GT.MKOUN) MKOUN = MHIGH(IEQNS)
   20 MAXAD(IEQNS+1) = MAXAD(IEQNS) + MHIGH(IEQNS) + 1
   30 MKOUN = MKOUN + 1
      NWKTL = MAXAD(NEQNS+1) - MAXAD(1)
      RETURN
      END

      SUBROUTINE INITI(MATNO,PROPS,VELOC,STRAN,EEPSN,PARAM,
     1                 VOIDS,VOIRA)
C*******************************************************************************
C
C*** INICIALIZA VARIABLES
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /NPARAM/ NPARA
      DIMENSION
     1   VELOC(    1) ,STRAN(NGSTR,1) ,EEPSN(      1) ,
     2   MATNO(    1) ,PROPS(NPROP,1) ,PARAM(NPARA,1) ,
     3   VOIDS(    1) ,VOIRA(      1)
C
C     INICIALIZA EL TIEMPO DE ANALISIS A CERO
C
      TTIME = 0.0
C
C     INICIALIZA LA VELOCIDAD A CERO
C
      DO 10 ITOTV = 1,NTOTV
      VELOC(ITOTV) = 0.0
10    CONTINUE
C
C     INICIALIZA LAS DEFORMACIONES GENERALIZADAS A CERO
C
      DO 20 IGAST = 1,NGAST
      DO 20 IGSTR = 1,NGSTR
      STRAN(IGSTR,IGAST) = 0.0
20    CONTINUE
      DO 30 IGAZT = 1,NGAZT
      EEPSN(IGAZT) = 0.0
30    CONTINUE
      IF(MODEL.EQ.1) RETURN
      IF(MODEL.EQ.2) RETURN
      IF(MODEL.EQ.5) RETURN
C
C     INICIALIZA LA POROSIDAD, LA VISCOSIDAD Y EL COEFICIENTE DE POISSON
C
      IF(MODEL.EQ.3) IPROP = 2
      IF(MODEL.EQ.4) IPROP = 4
      KGAZT = 0
      DO 40 IELEM = 1,NELEM
      LPROP = MATNO(IELEM)
      POROS = PROPS(IPROP,LPROP)
      DO 40 IGAZP = 1,NGAZP
      KGAZT = KGAZT + 1
      VOIDS(KGAZT) = POROS
      PARAM(1,KGAZT) = 1.0E+00
      PARAM(2,KGAZT) = 0.5
40    CONTINUE
C
C     INICIALIZA A CERO LA VELOCIDAD DE POROS
C
      DO 50 IGAZT = 1,NGAZT
      VOIRA(IGAZT) = 0.0
50    CONTINUE
      RETURN
      END

      SUBROUTINE INCREM(TABPR,NELRS,VELRS,LNODR,RSCOR)
C*******************************************************************************
C
C*** INCREMENTA EL NIVEL DE CARGAS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /PLOADS/ PRESS
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TABLAS/ NTABP ,NTABT
      DIMENSION 
     1   TABPR(    2,1) ,NELRS(      1) ,VELRS(NDIME,1) ,
     2   LNODR(NNODR,1) ,RSCOR(NDIME,1)
C
C     CALCULA LA NUEVA CONFIGURACION DE LAS SUPERFICIES DE 
C     CONTACTO RIGIDAS
C
      CALL MOVERS(NELRS ,VELRS ,LNODR ,RSCOR)
C
C     CALCULA LA PRESION EN FUNCION DEL TIEMPO
C
      IF(NAUTP.EQ.0) THEN
        IF(NTABP.GT.0) CALL INTPRE(TTIME ,PRESS ,TABPR ,NTABP)
      ELSE
        CALL AUTPRE
      END IF
      RETURN
      END

      SUBROUTINE MOVERS(NELRS,VELRS,LNODR,RSCOR)
C*******************************************************************************
C
C*** MUEVE LAS SUPERFICIES DE CONTACTO RIGIDAS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      DIMENSION
     1   NELRS(      1) ,VELRS(NDIME,1) ,LNODR(NNODR,1) ,
     2   RSCOR(NDIME,1) ,RVELO(      2)
      FACTO = 1.0
      IF(TTIME.EQ.0.0) FACTO = ACOEF
C
C     LOOP PARA TODAS LAS SUPERFICIES DE CONTACTO RIGIDAS
C
      IFIRS = 1
      DO 60 IRSUR = 1,NRSUR
      ILAST = IFIRS + NELRS(IRSUR) - 1
      RVELO(1) = VELRS(1,IRSUR)
      RVELO(2) = VELRS(2,IRSUR)
      VELOM = SQRT(DOT(RVELO,RVELO,2))
      IF(VELOM.EQ.0.0) GO TO 50
C
C     MUEVE SUPERFICIES RIGIDAS 
C
      DO 30 IELRS = IFIRS,ILAST
      DO 30 INODR = 1,NNODR
      IRPOI = LNODR(INODR,IELRS)
      IF(IRPOI.LT.0) GO TO 30
      DO 10 IDIME = 1,NDIME
      RSCOR(IDIME,IRPOI) = RSCOR(IDIME,IRPOI) + 
     1   RVELO(IDIME)*DTIME*FACTO
10    CONTINUE
      DO 20 JELRS = IELRS+1,ILAST
      DO 20 JNODR = 1,NNODR
      IF(LNODR(JNODR,JELRS).EQ.IRPOI) LNODR(JNODR,JELRS) = -IRPOI
20    CONTINUE
30    CONTINUE
      DO 40 IELRS = IFIRS,ILAST
      DO 40 INODR = 1,NNODR
      LNODR(INODR,IELRS) = IABS(LNODR(INODR,IELRS))
40    CONTINUE
50    IFIRS = ILAST + 1
60    CONTINUE
      RETURN
      END

      SUBROUTINE INTPRE(TTIME,PRESS,TABPR,NTABP)
C*******************************************************************************
C
C*** INTERPOLA LINEALMENTE LA PRESION EN FUNCION DEL TIEMPO
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      DIMENSION TABPR(2,NTABP)
      TIMIN = TABPR(1,    1)
      TIMAX = TABPR(1,NTABP)
      IF(TTIME.LT.TIMIN.OR.TTIME.GT.TIMAX) GO TO 900
      DO 10 ITABP = 1,NTABP
      TIME2 = TABPR(1,ITABP)
      IF(TIME2.GT.TTIME) GO TO 20
10    CONTINUE
20    CONTINUE
      TIME1 = TABPR(1,ITABP-1)
      FACTO = (TTIME-TIME1)/(TIME2-TIME1)
      PROP1 = TABPR(2,ITABP-1)
      PROP2 = TABPR(2,ITABP)
      PRESS = PROP1 + FACTO*(PROP2-PROP1)
      RETURN
900   WRITE(IOUTP,3000) TTIME
      STOP
3000  FORMAT(//' *** ERROR EN SUBRUTINA INTPRE *** '
     1         ' TIEMPO FUERA DEL RANGO DE TABLAS  ',E16.6)
      END 

      SUBROUTINE AUTPRE
C*******************************************************************************
C
C*** AUTOMATIC PRESSURE CYCLE COMPUTATION
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /EPSRMM/ EPMAX ,EPMIN
      COMMON /AUTPRC/ EPFIX ,EXPON
      COMMON /PLOADS/ PRESS
      EPRAT = 1.0
      IF(PRESS.EQ.0.0) PRESS = 1.0E-05
      IF(EPMAX.GT.0.0) EPRAT = EPFIX/EPMAX
      PRESS = PRESS*(EPRAT**EXPON)
      RETURN
      END

      SUBROUTINE PREDIC(COORD,COORI,VELOC,VELOI,STRAN,STRAI,
     1                  EEPSN,EEPSI,STNRA,STNRI,EEPRA,EEPRI,
     2                  VOIDS,VOIDI,VOIRA,VOIRI)
C*******************************************************************************
C
C*** REALIZA LA PREDICCION DE VARIABLES
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      DIMENSION 
     1   COORD(NDIME,    1) ,COORI(NDIME,    1) ,
     2   VELOC(NDOFN,    1) ,VELOI(NDOFN,    1) ,
     3   STRAN(NGSTR,    1) ,STRAI(NGSTR,    1) ,
     4   EEPSN(          1) ,EEPSI(          1) ,
     5   STNRA(NGSTR,    1) ,STNRI(NGSTR,    1) ,
     6   EEPRA(          1) ,EEPRI(          1) ,
     7   VOIDS(          1) ,VOIDI(          1) ,
     8   VOIRA(          1) ,VOIRI(          1)
C
C     ALMACENA LAS VARIABLES AL PRINCIPIO DEL INCREMENTO Y 
C     EFECTUA LA PREDICCION PARA EL SIGUIENTE INCREMENTO
C
C     VELOCIDADES
C
      DO 10 IPOIN = 1,NPOIN
      DO 10 IDOFN = 1,NDOFN
      VELOI(IDOFN,IPOIN) = VELOC(IDOFN,IPOIN)
10    CONTINUE
C
C     COORDENADAS
C
      DO 20 IPOIN = 1,NPOIN
      DO 20 IDIME = 1,NDIME
      COORI(IDIME,IPOIN) = COORD(IDIME,IPOIN) 
      COORD(IDIME,IPOIN) = COORI(IDIME,IPOIN) + 
     1                     VELOI(IDIME,IPOIN)*DTIME
20    CONTINUE
C
C     ALMACENA DEFORMACIONES GENERALIZADAS Y VELOCIDADES DE DEFORMACION 
C     GENERALIZADAS, CORRESPONDIENTES AL INICIO DEL INCREMENTO
C
      DO 30 IGAST = 1,NGAST
      DO 30 ISTRE = 1,NGSTR
      STRAI(ISTRE,IGAST) = STRAN(ISTRE,IGAST)
      STNRI(ISTRE,IGAST) = STNRA(ISTRE,IGAST)
30    CONTINUE
C
C     ALMACENA DEFORMACION EQUIVALENTE, VELOCIDAD DE DEFORMACION EQUIVALENTE,
C     CORRESPONDIENTES AL INICIO DEL INCREMENTO
C
      DO 40 IGAZT = 1,NGAZT
      EEPSI(IGAZT) = EEPSN(IGAZT)
      EEPRI(IGAZT) = EEPRA(IGAZT)
40    CONTINUE
      IF(MODEL.EQ.1) RETURN
      IF(MODEL.EQ.2) RETURN
      IF(MODEL.EQ.5) RETURN
C
C     ALMACENA LA POROSIDAD Y SU DERIVADA CON RESPECTO AL TIEMPO
C     CORRESPONDIENTES AL INICIO DEL INCREMENTO
C
      DO 50 IGAZT = 1,NGAZT
      VOIDI(IGAZT) = VOIDS(IGAZT)
      VOIRI(IGAZT) = VOIRA(IGAZT)
50    CONTINUE
      RETURN
      END

      SUBROUTINE DATOOL(NELRS,LNODR,RSCOR,SEANG,SNANG,KOUNT,sntan)
C*******************************************************************************
C
C*** BUSQUEDA DE POSIBLES CONTACTOS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /DEFAUL/ IDSTA
      COMMON /PRINTS/ IPCCS ,IPVEL ,IPREA ,IPSNR ,IPSTN ,IPSTR ,
     1                IPTHG ,IPPOR ,IPAVN 
      DIMENSION
     1   NELRS(   1) ,LNODR(NNODR,1) ,RSCOR(NDIME,1) ,
     2   SEANG(   1) ,SNANG(      1) ,KOUNT(      1)
      dimension 
     1   sntan(2,*)
      TWOPI = 8.0*ATAN(1.0)
C
C
C     P R E P R O C E S O   D E L   A N A L I S I S   D E   
C     B U S Q U E D A   D E   C O N T A C T O S
C
C     CALCULA LOS VECTORES SEGMENTOS, Y EJES LOCALES UNITARIOS 
C     EN LOS ELEMENTOS DE LAS SUPERFICIES DE CONTACTO
C
      DO 100 IRELE = 1,NRELE
      NODE1 = LNODR(1,IRELE)
      NODE2 = LNODR(2,IRELE)
      XPROJ = RSCOR(1,NODE2) - RSCOR(1,NODE1)
      YPROJ = RSCOR(2,NODE2) - RSCOR(2,NODE1)
      SEANG(IRELE) = ATAN2(YPROJ,XPROJ)
100   CONTINUE
C
C     CALCULA LOS EJES LOCALES UNITARIOS EN LOS NODOS
C     DE LAS SUPPERFICIES DE CONTACTO 
C
      DO 200 IRPOI = 1,NRPOI
c      KOUNT(IRPOI) = 0                                               !July 1992
c      SNANG(IRPOI) = 0.0                                             !July 1992
      sntan(1,irpoi) = 0.0                                            !July 1992
      sntan(2,irpoi) = 0.0                                            !July 1992
200   CONTINUE
      KELRS =0
      DO 210 IRSUR = 1,NRSUR
      DO 210 IELRS = 1,NELRS(IRSUR)
      KELRS = KELRS + 1
      ANG = SEANG(KELRS)
      cs = cos(ang)                                                   !July 1992
      sn = sin(ang)                                                   !July 1992
c      IF(ANG.LT.0.0) ANG = ANG + TWOPI                               !July 1992
      DO 210 INODR = 1,NNODR      
      NODRS = LNODR(INODR,KELRS)
c      KOUNT(NODRS) = KOUNT(NODRS) + 1                                !July 1992
c      SNANG(NODRS) = SNANG(NODRS) + ANG                              !July 1992
      sntan(1,nodrs) = sntan(1,nodrs) + cs                            !July 1992
      sntan(2,nodrs) = sntan(2,nodrs) + sn                            !July 1992
210   CONTINUE
      do irpoi = 1,nrpoi                                              !July 1992
        xproj = sntan(1,irpoi)                                        !July 1992
        yproj = sntan(2,irpoi)                                        !July 1992
        snang(irpoi) = atan2(yproj,xproj)                             !July 1992
      end do                                                          !July 1992
c      DO 220 IRPOI = 1,NRPOI                                         !July 1992
c      SNANG(IRPOI) = SNANG(IRPOI)/FLOAT(KOUNT(IRPOI))                !July 1992
c220   CONTINUE                                                       !July 1992
      RETURN
      END

      SUBROUTINE SEARCH(COORD,NELRS,LNODR,RSCOR,SEANG,SNANG,
     1                  LELCO,ISTAT,OVERL)
C*******************************************************************************
C
C*** BUSQUEDA DE POSIBLES CONTACTOS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /DEFAUL/ IDSTA
      COMMON /PRINTS/ IPCCS ,IPVEL ,IPREA ,IPSNR ,IPSTN ,IPSTR ,
     1                IPTHG ,IPPOR ,IPAVN 
      common /bhcom1/ ibhol,xbh0,xbh1,bhf,idbhn(300),bhlod(300)              !oct'92
      DIMENSION
     1   COORD(NDIME,1) ,NELRS(      1) ,
     2   LNODR(NNODR,1) ,RSCOR(NDIME,1) ,SEANG(      1) ,
     3   SNANG(      1) ,LELCO(      1) ,ISTAT(      1) ,
     4   OVERL(NDIME,1) ,VEAXE(  2,  2) ,
     5   VDIST(      2) ,VDMIN(      2) ,VDUMM(      2)
C
C
C     P R O C E S O   D E   B U S Q U E D A   D E   C O N T A C T O S
C
C     DETERMINA PARA CADA PUNTO DE LA LAMINA EL NODO DE LA SUPERFICIE DE
C     CONTACTO MAS CERCANO Y CALCULA LA DISTANCIA
C
      ICHNG = 0
      DO 400 IPOIN = 1,NPOIN
c...oct'92
c     skip search procedure for prescribed/penalized nodes
c
      if(idbhn(ipoin).eq.1) go to 400                                    !oct'92
C
C     DETERMINA EL NODO DE LA SUPERFICIE MAS CERCANO PARA CADA NODO
C
      DIMIN = 1.0E+10
      DO 300 IRPOI = 1,NRPOI
      DO 10 IDIME = 1,NDIME
      VDIST(IDIME) = COORD(IDIME,IPOIN) - RSCOR(IDIME,IRPOI)
10    CONTINUE
      DISTA = SQRT(DOT(VDIST,VDIST,NDIME))
      IF(DISTA.GE.DIMIN) GO TO 300
      NEARN = IRPOI
      DIMIN = DISTA
      DO 20 IDIME = 1,NDIME
      VDMIN(IDIME) = VDIST(IDIME)
20    CONTINUE
300   CONTINUE
C
C     DETERMINA EL ELEMENTO MAS CERCANO AL NODO
C
      CS = COS(SNANG(NEARN))
      SN = SIN(SNANG(NEARN))
      VDUMM(1) = CS
      VDUMM(2) = SN
      DUMMY = DOT(VDMIN,VDUMM,2)
      IPOSI = 1
      IF(DUMMY.LT.0.0) IPOSI = 2
      DO 310 IRELE = 1,NRELE
      IF(LNODR(IPOSI,IRELE).EQ.NEARN) GO TO 330
310   CONTINUE
      IRELE = 0
      DO 320 IRSUR = 1,NRSUR
      IRELE = IRELE + 1
      IF(LNODR(1,IRELE).EQ.NEARN) GO TO 330
      IRELE = IRELE + NELRS(IRSUR) - 1
      IF(LNODR(2,IRELE).EQ.NEARN) GO TO 330
320   CONTINUE
330   CONTINUE
C
C     ASIGNA EJES LOCALES DEL ELEMENTO
C
      CSE = COS(SEANG(IRELE))
      SNE = SIN(SEANG(IRELE))
      VEAXE(1,1) = CSE
      VEAXE(2,1) = SNE
      VEAXE(1,2) = -SNE
      VEAXE(2,2) = CSE
C
C     DETERMINA SI SE PRODUCE PENETRACION Y EN CASO AFIRMATIVO
C     CALCULA LA PENETRACION Y LA POSICION RELATIVA
C
      IOLDE = LELCO(IPOIN)
      IOLDS = ISTAT(IPOIN)
      LELCO(  IPOIN) = 0
      OVERL(1,IPOIN) = 0.0
      OVERL(2,IPOIN) = 0.0
C     RCPOS(  IPOIN) = 0.0
      ISTAT(  IPOIN) = 0
      OVLAP = DOT(VDMIN,VEAXE(1,2),2)
      IF(OVLAP.LT.-1.0E-10) GO TO 400
      IF(OVLAP.LT.0.0) OVLAP = 0.0
      LELCO(  IPOIN) = IRELE
      OVERL(1,IPOIN) = OVLAP*VEAXE(1,2)
      OVERL(2,IPOIN) = OVLAP*VEAXE(2,2)
C     RCPOS(  IPOIN) = DOT(VDMIN,VEAXE(1,1),2)
      ISTAT(  IPOIN) = IABS(IOLDS)
      IF(IOLDS.EQ.0) ISTAT(IPOIN) = - IDSTA
      IF(IOLDE.NE.IRELE) ICHNG = 1
400   CONTINUE
C     MODIFICA EL PERFIL DE LA MATRIZ DE RIGIDEZ EN CASO NECESARIO
C
C     INFORMA DEL ANALISIS DE BUSQUEDA DE CONTACTO
C
      IF(IPCCS.EQ.0) RETURN
      IF(MOD(IINCS,IPCCS).GT.0) RETURN
      WRITE(IOUTP,2000) IINCS,TTIME
      DO 500 IPOIN = 1,NPOIN
      WRITE(IOUTP,2001) IPOIN,ISTAT(IPOIN),LELCO(IPOIN),
     1   OVERL(1,IPOIN),OVERL(2,IPOIN)
500   CONTINUE
      RETURN
2000  FORMAT(//' B U S Q U E D A   D E   C O N T A C T O S'//
     1   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',E12.4,//,
     2   5X,' NODO',4X,'STATUS',2X,'SEGMENTO',7X,'PENETRACION')
2001  FORMAT(5X,I5,5X,I5,5X,I5,3E12.4)
      END

      SUBROUTINE SETZER(RLOAD,PLOAD,RESID,RCLOD,FORCE,STIFF)
C*******************************************************************************
C
C*** INICIALIZA A CERO ALGUNOS VECTORES
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /PROFIL/ NEQNS ,NWKTL
      DIMENSION 
     1   RLOAD(NEVAB,1) ,PLOAD(NDOFN,1) ,RESID(NDOFN,1) ,
     2   RCLOD(NDOFN,1) ,FORCE(      1) ,STIFF(      1)
C
C     INICIALIZA A CERO LOS VECTORES DE FUERZAS
C
      DO 10 IELEM = 1,NELEM
      DO 10 IEVAB = 1,NEVAB
      RLOAD(IEVAB,IELEM) = 0.0
10    CONTINUE
      DO 20 IPOIN = 1,NPOIN
      DO 20 IDOFN = 1,NDOFN
      PLOAD(IDOFN,IPOIN) = 0.0
      RESID(IDOFN,IPOIN) = 0.0
      RCLOD(IDOFN,IPOIN) = 0.0
20    CONTINUE
C
C     INICIALIZA A CERO EL VECTOR DE FUERZAS RESIDUALES ACTIVAS
C     Y LA MATRIZ DE RIGIDEZ DEL SISTEMA
C
      DO 30 IEQNS = 1,NEQNS
      FORCE(IEQNS) = 0.0
30    CONTINUE
      DO 40 IWKTL = 1,NWKTL
      STIFF(IWKTL) = 0.0
40    CONTINUE
      RETURN
      END

      SUBROUTINE CONTAC(IFFIX,FIXED,VELOC,RCLOD,NELRS,VELRS,
     1                  FRICT,SEANG,LELCO,ISTAT,OVERL,MAXAD,
     2                  ESTIF,FORCE,STIFF)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ DE RIGIDEZ Y EL VECTOR DE FUERZAS PARA
C    PROBLEMAS DE CONTACTO POR EL METODO DE PENALIZACION
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /PENALT/ PNLTC ,PNLTF
      DIMENSION
     1   IFFIX(NDOFN,1) ,FIXED(NDOFN,1) ,VELOC(NDOFN,1) ,
     2   FORCE(      1) ,ESTIF(      1) ,MAXAD(      1) ,
     3   STIFF(      1) ,NELRS(      1) ,VELRS(NDIME,1) ,
     4   FRICT(      1) ,ISTAT(      1) ,LELCO(      1) ,
     5   OVERL(NDIME,1) ,SEANG(      1) ,LEQNC(      2) ,
     6   CLOAD(      2) ,RCLOD(NDOFN,1)
C
C     CALCULA EL FACTOR DE PENALIZACION EN FUNCION DEL INCREMENTO
C     DE TIEMPO
C
      PNLTY = PNLTC/DTIME
C
C     FORMA Y ENSAMBLA LA MATRIZ DE RIGIDEZ Y EL VECTOR DE FUERZAS
C     DE CONTACTO, PARA EL CASO DE SUPERFICIES RIGIDAS
C
      DO 200 IPOIN = 1,NPOIN
      ISLST = ISTAT(IPOIN)
      IF(ISLST.EQ.0) GO TO 200
      LEQNC(1) = IFFIX(1,IPOIN)
      LEQNC(2) = IFFIX(2,IPOIN)
      GO TO (1,2), IABS(ISLST)
      STOP
C
C     S L I P
C
1     IRELE = LELCO(IPOIN)
      ANG   = SEANG(IRELE)
      CS    = COS(ANG)
      SN    = SIN(ANG)
      CS2   = CS*CS
      SN2   = SN*SN
      CSN   = CS*SN
      ESTIF(1) =   PNLTY*ACOEF*ACOEF*DTIME*DTIME*SN2
      ESTIF(2) = - PNLTY*ACOEF*ACOEF*DTIME*DTIME*CSN
      ESTIF(3) =   PNLTY*ACOEF*ACOEF*DTIME*DTIME*CS2

      OVLPX = OVERL(1,IPOIN)
      OVLPY = OVERL(2,IPOIN)
      OVLAP = - OVLPX*SN + OVLPY*CS
      IF(OVLAP.LT.0.0) THEN
        PRINT *, 'STOP *** OVLAP < 0'
        STOP
      END IF
      CLOAD(1) =   PNLTY*ACOEF*DTIME*OVLAP*SN
      CLOAD(2) = - PNLTY*ACOEF*DTIME*OVLAP*CS
C
C     F R I C C I O N
C
C     CALCULA LA VELOCIDAD DE DESLIZAMIENTO RELATIVA Y 
C     ASIGNA EL COEFICIENTE DE FRICCION
C
      IF(NFRIC.EQ.1) GO TO 100
      IF(IITER.EQ.1) GO TO 100 
      IF(ISLST.LT.0) GO TO 100
      KELRS = 0
      DO 10 IRSUR = 1,NRSUR
      KELRS = KELRS + NELRS(IRSUR)
      IF(IRELE.LE.KELRS) GO TO 11
10    CONTINUE
11    CONTINUE
      COEFF = FRICT(IRSUR)
      VSLIP = VELOC(1,IPOIN)*CS + VELOC(2,IPOIN)*SN
      WSLIP = VELRS(1,IRSUR)*CS + VELRS(2,IRSUR)*SN
      VSLIP = VSLIP - WSLIP
      ISIGN = 1
      IF(VSLIP.LT.0.0) ISIGN = -1
      VSLIP = ABS(VSLIP)
      RNMOD = PNLTY*ACOEF*DTIME*OVLAP
C
C     FORMA Y ENSAMBLA LA MATRIZ DE RIGIDEZ Y EL VECTOR DE FUERZAS
C     DE FRICCION, PARA EL CASO DE SUPERFICIES RIGIDAS
C
      GO TO (100,101,102), NFRIC
C
C     MODELO DE FRICCION DE COULOMB
C
C     --- FUNCION CONTINUA PROPUESTA ---
C
101   FUNCT = TANH(PNLTF*VSLIP)
      DFUNC = PNLTF*(1.0-FUNCT*FUNCT)
C
C     --- R.H. WAGONER AND E. NAKAMACHI ---
C
      VEPSI = COEFF*RNMOD/PNLTF
      IF(VSLIP.GE.VEPSI) THEN
        FUNCT = 1.0
        DFUNC = 0.0
      ELSE
        FUNCT = VSLIP/VEPSI
        DFUNC = 1.0/VEPSI
      END IF

      FACTR = COEFF*RNMOD
      ESTIF(1) = ESTIF(1) + FACTR*DFUNC*CS2
      ESTIF(2) = ESTIF(2) + FACTR*DFUNC*CSN
      ESTIF(3) = ESTIF(3) + FACTR*DFUNC*SN2

      CLOAD(1) = CLOAD(1) - FACTR*FUNCT*CS*FLOAT(ISIGN)
      CLOAD(2) = CLOAD(2) - FACTR*FUNCT*SN*FLOAT(ISIGN)
      GO TO 100
C
C     MODELO DE FRICCION DE TRESCA
C
102   ESTIF(1) = ESTIF(1) + COEFF*CS2
      ESTIF(2) = ESTIF(2) + COEFF*CSN
      ESTIF(3) = ESTIF(3) + COEFF*SN2

      CLOAD(1) = CLOAD(1) - COEFF*VSLIP*CS*FLOAT(ISIGN)
      CLOAD(2) = CLOAD(2) - COEFF*VSLIP*SN*FLOAT(ISIGN)
      GO TO 100
C
C     S T I C K
C
2     ESTIF(1) = PNLTY*ACOEF*ACOEF*DTIME*DTIME
      ESTIF(2) = 0.0
      ESTIF(3) = PNLTY*ACOEF*ACOEF*DTIME*DTIME

      OVLPX = OVERL(1,IPOIN)
      OVLPY = OVERL(2,IPOIN)
      CLOAD(1) = - PNLTY*ACOEF*DTIME*OVLPX
      CLOAD(2) = - PNLTY*ACOEF*DTIME*OVLPY
100   CONTINUE
C
C     ENSAMBLA LA MATRIZ DE RIGIDEZ Y EL VECTOR DE FUERZAS
C
      CALL ADDBAN(STIFF,MAXAD,ESTIF,LEQNC,2)
      IF(LEQNC(1).GT.0) RCLOD(1,IPOIN) = RCLOD(1,IPOIN) + CLOAD(1)
      IF(LEQNC(2).GT.0) RCLOD(2,IPOIN) = RCLOD(2,IPOIN) + CLOAD(2)
C
C     CORRIGE EL VECTOR DE FUERZAS PARA VELOCIDADES PRESCRITAS NO NULAS
C
      IF(LEQNC(1).LE.0) 
     1   CLOAD(2) = CLOAD(2) - ESTIF(2)*(FIXED(1,IPOIN)-VELOC(1,IPOIN))
      IF(LEQNC(2).LE.0)
     1   CLOAD(1) = CLOAD(1) - ESTIF(2)*(FIXED(2,IPOIN)-VELOC(2,IPOIN))
C
C     ENSAMBLA EL VECTOR DE FUERZAS
C
      IF(LEQNC(1).GT.0) FORCE(LEQNC(1)) = FORCE(LEQNC(1)) + CLOAD(1)
      IF(LEQNC(2).GT.0) FORCE(LEQNC(2)) = FORCE(LEQNC(2)) + CLOAD(2)
200   CONTINUE
      RETURN
      END

c      subroutine bholdtry
c*******************************************************************************
c
c*** build a (simplified) blankholder model
c
c*******************************************************************************
c      implicit real*8(a-h,o-z)
c      pival = 4.0*atan(1.0)
c.... determine active dmin,dmax
c      xmax = coord(1,npoin)
c      dmax = min1(xmax,bhd2)
c      dmin = min1(xmax,bhd1)
c.... compute area and bhp
c      if(ntype.eq.1) then
c        area = dmax - dmin
c      else if(ntype.eq.2) then
c        area = pival*(dmax*dmax - dmin*dmin)
c      end if
c      bhp = bhf/area
c.... compute equivalent bh nodal forces
c      do ielem = 1, nelem
c        x1 = coord(1,lnods(1,ielem))
c        x2 = coord(1,lnods(2,ielem))
c        xmax = max1(x1,x2)
c        xmin = min1(x1,x2)
c        if(xmax.ge.dmin.or.xmin.le.dmax) then
c          if(xmin.ge.dmin.or.xmax.le.dmax) then
c            if(ntype.eq.1) then
c              areae = xmax - xmin
c            else if(ntype.eq.2) then
c              areae = pival*(xmax*xmax - xmin*xmin)
c            end if
c            bhf1 = 0.5*bhp*areae
c            bhf2 = bhf1
c          else if(xmax.ge.dmin.and.xmin.lt.dmin) then
c            if(ntype.eq.1) then
c              areae = xmax - dmin
c            else if(ntype.eq.2) then
c              areae = pival*(xmax*xmax - dmin*dmin)
c            end if
c            bhf0 = 0.5*bhp*areae
c            bhf2 = bhf0
c            ratio = areae/(xmax-xmin)
c            bhf1 = bhf0*ratio
c            bhf2 = bhf2 + bhf0*(1.0-ratio)
c          else if(xmin.le.dmax.and.xmax.gt.dmax) then
c            if(ntype.eq.1) then
c              areae = dmax - xmin
c            else if(ntype.eq.2) then
c              areae = pival*(dmax*dmax - xmin*xmin)
c            end if
c            bhf0 = 0.5*bhp*areae
c            bhf1 = bhf0
c            ratio = areae/(xmax-xmin)
c            bhf1 = bhf1 + bhf0*(1.0-ratio)
c            bhf2 = bhf0*ratio
c          end if
c        end if
c      end do
c      return
c      end

      SUBROUTINE ELOADS(COORD,LNODS,ELOAD)
C*******************************************************************************
C
C*** CALCULA LAS CARGAS NODALES EQUIVALENTES 
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /PLOADS/ PRESS
      DIMENSION 
     1   COORD(NDIME,1) ,LNODS(NNODE,1) ,ELOAD(NEVAB,1)
C
C     CALCULA LAS CARGAS NODALES EQUIVALENTES DEBIDAS A LA PRESION
C      
      IF(PRESS.NE.0.0) CALL LOADS(COORD ,LNODS ,ELOAD ,PRESS)
      RETURN
      END

      SUBROUTINE LOADS(COORD,LNODS,ELOAD,PRESS)
C*******************************************************************************
C
C*** CALCULA LAS CARGAS NODALES EQUIVALENTES DE PRESION
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /GAUSS / POSGP(3) ,WEIGP(3)
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      DIMENSION
     1   COORD(NDIME,1) ,LNODS(NNODE,1) ,ELOAD(NEVAB,1)
      TWOPI = 8.0*ATAN(1.0)
C
C     INICIALIZA LAS CARGAS A CERO
C
      DO 100 IELEM = 1,NELEM
      DO 100 IEVAB = 1,NEVAB
      ELOAD(IEVAB,IELEM) = 0.0
100   CONTINUE
C
C     LOOP PARA TODOS LOS ELEMENTOS
C
      DO 200 IELEM = 1,NELEM
C
C     LOCALIZA COORDENADAS DEL ELEMENTO
C      
      DO 10 INODE = 1,NNODE
      LNODE = LNODS(INODE,IELEM)
      DO 10 IDIME = 1,NDIME
      ELCOD(IDIME,INODE) = COORD(IDIME,LNODE)
10    CONTINUE
C
C     INTEGRA LA CARGA DE PRESION EN COORDENADAS GLOBALES
C
      KGASP = 0
      DO 20 IGAUS = 1,NGAUS
      KGASP = KGASP + 1
      EXISP = POSGP(IGAUS)
      CALL SFR1(EXISP ,SHAPE ,DERIV ,NNODE)
      CALL JACOB1(IELEM ,KGASP)
      CS = COS(ANGLE)
      SN = SIN(ANGLE)
      DAREA = DJACB*WEIGP(IGAUS)
      IF(NTYPE.EQ.2) DAREA = DAREA*TWOPI*GPCOD(1,KGASP)
      KEVAB = 1
      DO 20 INODE = 1,NNODE
      ELOAD(KEVAB  ,IELEM) = ELOAD(KEVAB  ,IELEM) +
     1                       SHAPE(INODE)*PRESS*SN*DAREA
      ELOAD(KEVAB+1,IELEM) = ELOAD(KEVAB+1,IELEM) -
     1                       SHAPE(INODE)*PRESS*CS*DAREA
      KEVAB = KEVAB + NDOFN
20    CONTINUE
200   CONTINUE
      RETURN
      END

      SUBROUTINE RESIDU(COORD,LNODS,MATNO,PROPS,VELOC,BMATX,
     1                  DMATX,DERIB,STRAN,STRAI,EEPSN,EEPSI,
     2                  STNRA,STNRI,EEPRA,EEPRI,STRES,THICK,
     3                  PARAM,VOIDS,VOIDI,VOIRA,VOIRI,ELOAD,
     4                  RLOAD,PLOAD,RESID,RCLOD,LEQNS)
C*******************************************************************************
C
C*** CALCULA FUERZAS RESIDUALES
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /NPARAM/ NPARA
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /PROFIL/ NEQNS ,NWKTL
      DIMENSION
     1   COORD(NDIME,      1) ,LNODS(NNODE,1) ,ELOAD(NEVAB,1) ,
     2   RLOAD(NEVAB,      1) ,PLOAD(NDOFN,1) ,RESID(NDOFN,1) ,
     3   RCLOD(NDOFN,      1) ,BMATX(NGSTR,1) ,STRES(NGSTR,1) ,
     4   THICK(            1) ,DMATX(NGSTR,1) ,VELOC(NDOFN,1) ,
     5   STNRA(NGSTR,      1) ,EEPRA(      1) ,EEPRI(      1) ,
     6   EEPSN(            1) ,EEPSI(      1) ,PARAM(NPARA,1) ,
     7   PROPS(NPROP,      1) ,MATNO(      1) ,LEQNS(NEVAB,1) ,
     8   STRAN(NGSTR,      1) ,STRAI(NGSTR,1) ,STNRI(NGSTR,1) ,
     9   DERIB(NGSTR,NEVAB,1) 
      DIMENSION
     1   VOIDS(      1) ,VOIDI(            1) ,VOIRA(      1) ,
     2   VOIRI(      1) 
      KGAST = 1
      KGAZT = 1
C
C     LOOP PARA TODOS LOS ELEMENTOS
C
      DO 100 IELEM = 1,NELEM
C
C     LOCALIZA MATERIAL, COORDENADAS Y VELOCIDAD DEL ELEMENTO
C
      LPROP = MATNO(IELEM)
      DO 20 INODE = 1,NNODE
      LNODE = LNODS(INODE,IELEM)
      DO 10 IDIME = 1,NDIME
      ELCOD(IDIME,INODE) = COORD(IDIME,LNODE)
10    CONTINUE
      DO 20 IDOFN = 1,NDOFN
      ELVEL(IDOFN,INODE) = VELOC(IDOFN,LNODE)
20    CONTINUE
C
C     CALCULA LAS TENSIONES EN LOS PUNTOS DE GAUSS DEL ELEMENTO
C     Y LAS FUERZAS INTERNAS DEL ELEMENTO
C
      CALL STRESS(BMATX  ,DMATX  ,STNRA(1,KGAST) ,THICK(  KGAST) ,
     1            EEPRA(  KGAZT) ,EEPRI(  KGAZT) ,EEPSN(  KGAZT) ,
     2            EEPSI(  KGAZT) ,STRES(1,KGAST) ,PARAM(1,KGAZT) ,
     3            PROPS(1,LPROP) ,STRAN(1,KGAST) ,STRAI(1,KGAST) ,
     4            STNRI(1,KGAST) ,RLOAD(1,IELEM) ,         DERIB ,
     5            VOIDS(  KGAZT) ,VOIDI(  KGAZT) ,VOIRA(  KGAZT) ,
     6            VOIRI(  KGAZT) ,IELEM )
C
C     ACTUALIZA PUNTEROS DE DIRECCIONAMIENTO DE LOS PUNTOS DE GAUSS
C
      KGAST = KGAST + NGASP
      KGAZT = KGAZT + NGAZP
100   CONTINUE
C
C     CALCULA LAS FUERZAS RESIDUALES
C
      DO 200 IELEM = 1,NELEM
      DO 200 IEVAB = 1,NEVAB
      IEQNS = LEQNS(IEVAB,IELEM)
      IF(IEQNS.LE.0) ELOAD(IEVAB,IELEM) = RLOAD(IEVAB,IELEM)
      RLOAD(IEVAB,IELEM) = ELOAD(IEVAB,IELEM) - RLOAD(IEVAB,IELEM)
200   CONTINUE
C
C     EVALUA EL VECTOR DE FUERZAS EXTERNAS Y FUERZAS RESIDUALES 
C     DEL SISTEMA
C
      DO 300 IELEM = 1,NELEM
      KEVAB = 0
      DO 300 INODE = 1,NNODE
      LNODE = LNODS(INODE,IELEM)
      DO 300 IDOFN = 1,NDOFN
      KEVAB = KEVAB + 1
      PLOAD(IDOFN,LNODE) = PLOAD(IDOFN,LNODE) + ELOAD(KEVAB,IELEM)
      RESID(IDOFN,LNODE) = RESID(IDOFN,LNODE) + RLOAD(KEVAB,IELEM)
300   CONTINUE
      DO 310 IPOIN = 1,NPOIN
      DO 310 IDOFN = 1,NDOFN
      PLOAD(IDOFN,IPOIN) = PLOAD(IDOFN,IPOIN) + RCLOD(IDOFN,IPOIN)
      RESID(IDOFN,IPOIN) = RESID(IDOFN,IPOIN) + RCLOD(IDOFN,IPOIN)
310   CONTINUE
      RETURN
      END

      SUBROUTINE STRESS(BMATX,DMATX,STNRA,THICK,EEPRA,EEPRI,
     1                  EEPSN,EEPSI,STRES,PARAM,PROPS,STRAN,
     2                  STRAI,STNRI,RLOAD,DERIB,VOIDS,VOIDI,
     3                  VOIRA,VOIRI,IELEM)
C*******************************************************************************
C
C*** CALCULA TENSIONES EN LOS PUNTOS DE GAUSS DEL ELEMENTO
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /NPARAM/ NPARA
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      COMMON /GAUSS / POSGP(3) ,WEIGP(3)
      DIMENSION 
     1   BMATX(NGSTR,      1) ,STNRA(NGSTR,    1) ,THICK(      1) ,
     2   DMATX(NGSTR,      1) ,EEPRA(          1) ,EEPRI(      1) ,
     3   EEPSN(            1) ,EEPSI(          1) ,PARAM(NPARA,1) ,
     4   STRES(NGSTR,      1) ,PROPS(          1) ,STRAN(NGSTR,1) ,
     5   STRAI(NGSTR,      1) ,STNRI(NGSTR,    1) ,RLOAD(      1) ,
     6   DERIB(NGSTR,NEVAB,1) ,VOIDS(          1) ,VOIDI(      1) ,
     7   VOIRA(            1) ,VOIRI(          1)
      TWOPI = 8.0*ATAN(1.0)
C
C     LOOP PARA TODOS LOS PUNTOS DE GAUSS
C
      KGASP = 0
      KGAZP = 1
      DO 100 IGAUS = 1,NGAUS
      KGASP = KGASP + 1
      EXISP = POSGP(IGAUS)
C
C     EVALUA FUNCIONES DE FORMA, ETC. PARA CADA PUNTO DE GAUSS
C
      CALL SFR1(EXISP ,SHAPE ,DERIV ,NNODE)
      CALL JACOB1(IELEM ,KGASP)
      RADUS = GPCOD(1,KGASP)
      DAREA = DJACB*WEIGP(IGAUS)
      IF(NTYPE.EQ.2) DAREA = DAREA*TWOPI*RADUS
C
C     EVALUA LA MATRIZ B
C           
      CALL BMATRX(BMATX)
C
C     CALCULA VELOCIDADES DE DEFORMACION Y DEFORMACIONES GENERALIZADAS
C
      CALL STRARA(BMATX ,STNRA(1,KGASP) ,STNRI(1,KGASP) ,
     1            STRAN(1,KGASP) ,STRAI(1,KGASP) )

cc      call gstre2(
cc     1  props,param(1,kgazp),thick(kgasp),
cc     2  stnra(1,kgasp),stran(1,kgasp),eepra(kgazp),
cc     3  eepri(kgazp), eepsn(kgazp), eepsi(kgazp),
cc     4  stres(1,kgasp))

C
C     CALCULA LA MATRIZ CONSTITUTIVA GENERALIZADA
C
      CALL DMATRX(DMATX  ,PROPS  ,PARAM(1,KGAZP) ,THICK(KGASP) ,
     1            STNRA(1,KGASP) ,STRAN(1,KGASP) ,EEPRA(KGAZP) ,
     2            EEPRI(  KGAZP) ,EEPSN(  KGAZP) ,EEPSI(KGAZP) ,
     3            VOIDS(  KGAZP) ,VOIDI(  KGAZP) ,VOIRA(KGAZP) ,
     4            VOIRI(  KGAZP) )
C
C     CALCULA TENSIONES GENERALIZADAS
C
      CALL GSTRES(STRES(1,KGASP) ,DMATX ,STNRA(1,KGASP))
C
C     CALCULA LAS FUERZAS INTERNAS DEL ELEMENTO
C
      DO 10 IEVAB = 1,NEVAB
      DO 10 IGSTR = 1,NGSTR
      RLOAD(IEVAB) = RLOAD(IEVAB) +
     1               BMATX(IGSTR,IEVAB)*STRES(IGSTR,KGASP)*DAREA
10    CONTINUE
      KGAZP = KGAZP + NGAUZ
100   CONTINUE
      RETURN
      END

      SUBROUTINE STRARA(BMATX,STNRA,STNRI,STRAN,STRAI)
C*******************************************************************************
C
C*** CALCULA VELOCIDADES DE DEFORMACION Y DEFORMACIONES GENERALIZADAS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      DIMENSION 
     1   BMATX(NGSTR,    1) ,STNRA(    1) ,STNRI(    1),
     2   STRAN(          1) ,STRAI(    1) 
C
C     CALCULA LAS VELOCIDADES DE DEFORMACION GENERALIZADAS
C
      DO 10 IGSTR = 1,NGSTR
      STNRA(IGSTR) = 0.0
10    CONTINUE
      KEVAB = 0
      DO 20 INODE = 1,NNODE
      DO 20 IDOFN = 1,NDOFN
      KEVAB = KEVAB + 1
      DO 20 IGSTR = 1,NGSTR
      STNRA(IGSTR) = STNRA(IGSTR) + 
     1   BMATX(IGSTR,KEVAB)*ELVEL(IDOFN,INODE)
20    CONTINUE
C
C     CALCULA DEFORMACIONES GENERALIZADAS
C
      DO 30 IGSTR = 1,NGSTR
      STRAN(IGSTR) = STRAI(IGSTR) +
     1   ((1.0-ACOEF)*STNRI(IGSTR) + ACOEF*STNRA(IGSTR))*DTIME
30    CONTINUE
      RETURN
      END

      SUBROUTINE BMATRX(BMATX)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ VELOCIDAD DE DEFORMACION - VELOCIDAD
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      DIMENSION  BMATX(NGSTR,1)
      CS = COS(ANGLE)
      SN = SIN(ANGLE)
C
C     INICIALIZA BMATX A CERO
C
      DO 10 IEVAB = 1,NEVAB
      DO 10 IGSTR = 1,NGSTR
      BMATX(IGSTR,IEVAB) = 0.0
10    CONTINUE
C
C     SELECCIONA TIPO DE PROBLEMA
C
      GO TO (100,200), NTYPE
      STOP
C
C
C     T I P O   1 :   D E F O R M A C I O N   P L A N A
C
C     
C     FORMA LA MATRIZ B PARA LA FORMULACION DE 
C     MEMBRANA
C
100   KEVAB = 1
      DO 110 INODE = 1,NNODE
      DNIDS = CARTD(INODE)
      BMATX(1,  KEVAB) = DNIDS*CS
      BMATX(1,1+KEVAB) = DNIDS*SN
      KEVAB = KEVAB + NDOFN
110   CONTINUE
      IF(NDOFN.EQ.2) RETURN 
C
C     COMPLETA LA MATRIZ B PARA LA FORMULACION DE 
C     MEMBRANA/FLEXION/CORTANTE
C
      KEVAB = 1
      DO 120 INODE = 1,NNODE
      SHAPI = SHAPE(INODE)
      DNIDS = CARTD(INODE)
C
C     CONTRIBUCION DE FLEXION
C
      BMATX(2,2+KEVAB) = - DNIDS
C
C     CONTRIBUCION DE CORTANTE
C
      BMATX(3,  KEVAB) = - DNIDS*SN
      BMATX(3,1+KEVAB) = DNIDS*CS
      BMATX(3,2+KEVAB) = - SHAPI
      KEVAB = KEVAB + NDOFN
120   CONTINUE
      RETURN
C
C
C     T I P O   2 :   A X I S I M E T R I C O
C
C     
C     FORMA LA MATRIZ B PARA LA FORMULACION DE 
C     MEMBRANA
C
200   KEVAB = 1
      DO 210 INODE = 1,NNODE
      SHAPI = SHAPE(INODE)
      DNIDS = CARTD(INODE)
      BMATX(1,  KEVAB) = DNIDS*CS
      BMATX(2,  KEVAB) = SHAPI/RADUS
      BMATX(1,1+KEVAB) = DNIDS*SN
      KEVAB = KEVAB + NDOFN
210   CONTINUE
      IF(NDOFN.EQ.2) RETURN
C
C     COMPLETA LA MATRIZ B PARA LA FORMULACION DE 
C     MEMBRANA/FLEXION/CORTANTE
C
      KEVAB = 1
      DO 220 INODE = 1,NNODE
      SHAPI = SHAPE(INODE)
      DNIDS = CARTD(INODE)
C
C     CONTRIBUCION DE FLEXION
C
      BMATX(3,2+KEVAB) = - DNIDS
      BMATX(4,2+KEVAB) = - SHAPI*CS/RADUS
C
C     CONTRIBUCION DE CORTANTE
C
      BMATX(5,  KEVAB) = - DNIDS*SN
      BMATX(5,1+KEVAB) = DNIDS*CS
      BMATX(5,2+KEVAB) = - SHAPI
      KEVAB = KEVAB + NDOFN
220   CONTINUE
      RETURN
      END

      subroutine gstre2(
     1  props,param,thick,
     2  stnra,stran,eepra,
     3  eepri,eepsn,eepsi,
     4  stres)
C*******************************************************************************
C
C*******************************************************************************
      implicit real*8(a-h,o-z)
      common /contro/ npoin ,nelem ,nmats ,nvfix ,ndime ,nnode ,
     1                ndofn ,nprop ,ngaus ,ngauz ,nstre ,ngstr ,
     2                nevab ,ntotv ,ngasp ,ngast ,ngazp ,ngazt ,
     3                nstif
      common /select/ ntype ,nform ,model ,nhard ,nalgo ,ncntc ,
     1                nfric ,nautp ,nautt
      common /elemnt/ shape(  3) ,deriv(2,3) ,cartd(  3) ,xjacm(  2) ,
     1                elcod(2,3) ,gpcod(2,3) ,elvel(3,3) ,
     2                secdr(  2)
      common /gauss / posgp(3) ,weigp(3)
      common /gaussz/ poszp(5) ,weizp(5)
      common /transi/ time0 ,timef ,ttime ,dtime ,acoef
      common /paramm/ visco ,poiss
      common /nparam/ npara
      common /midzgp/ nmidz
      common /inithk/ thiki
      dimension 
     1   stnra(      1) ,eepra(      1) ,eepri(      1) ,
     2   eepsn(      1) ,eepsi(      1) ,epsra(      3) ,props(    1) ,
     3   param(npara,1) ,stran(      1) ,stres(      1)
      data  const /0.8333333333333333/
      c1 = 2.0/sqrt(3.0)
      if(model.gt.2) then
        print *, 'stress computation not implemented'
        stop
      end if
c
c     selecciona tipo de problema
c
      go to (100), ntype
      stop
c
c
c     t i p o   1 :   d e f o r m a c i o n   p l a n a
c
c
c     selecciona formulacion
c
100   go to (110,120), nform
      stop
c
c
c     f o r m u l a c i o n   m e m b r a n a
c
c      
110   epsra(1) = stnra(1)
      epsra(2) = 0.0
      epsra(3) = 0.0
      eepra(1) = c1*abs(epsra(1))
      eepsn(1) = eepsi(1) + 
     1   ((1.0-acoef)*eepri(1) + acoef*eepra(1))*dtime
      call yieldf(yield,harde,nhard,eepsn,props)
      depsn = eepsn(1) - eepsi(1)
      if(depsn.le.1.0e-10) yield = yield*depsn/1.0e-10
      eps33 = - stran(1)
      thick = thiki*exp(eps33)
c.... compute (generalized) stresses
      isign = 1
      if(epsra(1).lt.0.0) isign = -1
      if(epsra(1).eq.0.0) isign = 0
      stres(1) = c1*yield*thick*isign
c.... compute viscosity
      visco = 1.0e+10
      if(eepra(1).gt.1.0e-10) visco = yield/(3.0*eepra(1))
      param(1,1) = visco
      if(model.eq.1) return
      gamma = props(2)
      vpsen = props(3)
c.... compute (generalized) stresses
      stres(1) = stres(1) + c1*thick*(eepra(1)/gamma)**vpsen*isign
c.... compute viscosity
      visco = visco + 
     1   (eepra(1)**(vpsen-1.0))*((1.0/gamma)**vpsen)/3.0
      param(1,1) = visco
      return
c
c
c     f o r m u l a c i o n   c o m p l e t a  
c     m e m b r a n a / f l e x i o n / c o r t a n t e
c
c
120   eps33 = - stran(1)
      thick = thiki*exp(eps33)
      if(model.gt.1) then
         print *, 'model not implemented'
         stop
      end if
c
      oldst1 = stres(1)
      oldst2 = stres(2)
      oldst3 = stres(3)
      stres(1) = 0.0
      stres(2) = 0.0
      stres(3) = 0.0
      kgauz = 0
      do 20 igauz = 1,ngauz
      kgauz = kgauz + 1
      etazp = poszp(igauz)
      dzlen = 0.5*thick*weizp(igauz)
      zgasp = 0.5*thick*etazp
      epsra(1) = stnra(1) + zgasp*stnra(2)
      epsra(2) = 0.0
      epsra(3) = stnra(3)
c      if(epsra(1).le.1.0e-10) epsra(1) = 0.0    !----
c      if(epsra(3).le.1.0e-10) epsra(3) = 0.0    !----
c
c     calcula la viscosidad
c
      eepra(kgauz) = c1*sqrt(epsra(1)**2+0.25*epsra(3)**2)
c      if(eepra(kgauz).le.1.0e-10) eepra(kgauz) = 0.0     !------
      eepsn(kgauz) = eepsi(kgauz) + 
     1   ((1.0-acoef)*eepri(kgauz) + acoef*eepra(kgauz))*dtime
      call yieldf(yield,harde,nhard,eepsn(kgauz),props)
      depsn = eepsn(kgauz) - eepsi(kgauz)
      if(depsn.le.1.0e-10) yield = yield*depsn/1.0e-10
c      print *, 'depsn=',depsn,'  yield=',yield
c.... compute (generalized) stresses
      gelas = 21300.0       !------------------OSU test
      if(epsra(1).ne.0.0) then
        cons1 = 0.5*epsra(3)/epsra(1)
        cons2 = cons1*cons1
        isign = 1
        if(epsra(1).lt.0.0) isign = -1
        sig11 = c1*yield/sqrt(1+cons2)*isign
        if(depsn.le.1.0e-10) dsig11 = 4.0*gelas*epsra(1)*dtime
      else 
        if(epsra(3).ne.0.0) sig11 = 0.0
        sig11 = 0.0
        dsig11 = 0.0
c        if(epsra(3).eq.0.0) sig11 = c1*yield
      end if
      if(epsra(3).ne.0.0) then
        isign = 1
        if(epsra(3).lt.0.0) isign = -1
        tau = 2.0*yield/(3.0*c1*sqrt(1+4.0*(epsra(1)/epsra(3))**2))
        tau = tau*isign
        if(kgauz.eq.2) tau0 = tau
        if(depsn.le.1.0e-10) dtau = gelas*epsra(3)*dtime
      else 
        if(epsra(1).ne.0.0) tau = 0.0
        tau = 0.0
        dtau = 0.0
        if(kgauz.eq.2) tau0 = tau
c        if(epsra(1).eq.0.0) tau = 2.0*yield/(3.0*c1)
      end if
      if(depsn.le.1.0e-10) then
        stres(1) = stres(1) + dsig11*dzlen
        stres(2) = stres(2) + dsig11*zgasp*dzlen
        stres(3) = stres(3) + dtau*const*dzlen
      else
        stres(1) = stres(1) + sig11*dzlen
        stres(2) = stres(2) + sig11*zgasp*dzlen
        stres(3) = stres(3) + tau*const*dzlen
      end if
c      print *, 'kgauz= ',kgauz 
c      print *, epsra(1),epsra(3)
c      print *, sig11,tau
c.... compute viscosity
      visco = yield/(3.0*(eepra(kgauz)+1.0e-10))
      if(yield.eq.0.0) visco = 1.0e+15
c      print *, visco
      param(1,kgauz) = visco
20    continue
      stres(3) = tau0*const*thick  !-------------1point tau
      if(depsn.le.1.0e-10) then
        stres(1) = stres(1) + oldst1
        stres(2) = stres(2) + oldst2
        stres(3) = stres(3) + oldst3
      end if
c      print *, 'N M Q',stres(1),stres(2),stres(3)
      return
      end

      SUBROUTINE DMATRX(DMATX,PROPS,PARAM,THICK,STNRA,STRAN,
     1                  EEPRA,EEPRI,EEPSN,EEPSI,VOIDS,VOIDI,
     2                  VOIRA,VOIRI)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ CONSTITUTIVA 
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /GAUSS / POSGP(3) ,WEIGP(3)
      COMMON /GAUSSZ/ POSZP(5) ,WEIZP(5)
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /NPARAM/ NPARA
      COMMON /MIDZGP/ NMIDZ
      COMMON /INITHK/ THIKI
      DIMENSION 
     1   DMATX(NGSTR,1) ,STNRA(      1) ,EEPRA(      1) ,EEPRI(    1) ,
     2   EEPSN(      1) ,EEPSI(      1) ,EPSRA(      3) ,PROPS(    1) ,
     3   PARAM(NPARA,1) ,STRAN(      1) ,VOIDS(      1) ,VOIDI(    1) ,
     4   VOIRA(      1) ,VOIRI(      1)
      DATA  CONST /0.8333333333333333/
C
C     INICIALIZA A CERO LA MATRIZ CONSTITUTIVA
C
      DO 10 IGSTR = 1,NGSTR
      DO 10 JGSTR = 1,NGSTR
      DMATX(JGSTR,IGSTR) = 0.0
10    CONTINUE
C
C     SELECCIONA TIPO DE PROBLEMA
C
      GO TO (100,200), NTYPE
      STOP
C
C
C     T I P O   1 :   D E F O R M A C I O N   P L A N A
C
C
C     SELECCIONA FORMULACION
C
100   GO TO (110,120), NFORM
      STOP
C
C
C     F O R M U L A C I O N   M E M B R A N A
C
C      
110   EPSRA(1) = STNRA(1)
      EPSRA(2) = 0.0
      EPSRA(3) = 0.0
C
C     CALCULA LA VISCOSIDAD
C
      CALL VISCOS(EPSRA ,EEPRA ,EEPRI ,EEPSN ,EEPSI ,PARAM ,
     1            PROPS ,VOIDS ,VOIDI ,VOIRA ,VOIRI )
C
C     CALCULA EL ESPESOR
C
      EPS33 = - POISS/(1.0-POISS)*STRAN(1)
      THICK = THIKI*EXP(EPS33)
C
C     F O R M A   L A   M A T R I Z   C O N S T I T U T I V A   D E
C     M E M B R A N A
C
      DMATX(1,1) = 2.0*VISCO/(1.0-POISS)*THICK
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
120   EPSRA(1) = STNRA(1)
      EPSRA(2) = 0.0
      EPSRA(3) = STNRA(3)
C
C     CALCULA LA VISCOSIDAD
C
      CALL VISCOS(EPSRA ,EEPRA(NMIDZ) ,EEPRI(NMIDZ) ,EEPSN(NMIDZ) ,
     1            EEPSI(NMIDZ) ,PARAM(1,NMIDZ) ,PROPS ,VOIDS(NMIDZ) ,
     2            VOIDI(NMIDZ) ,VOIRA(NMIDZ) ,VOIRI(NMIDZ) )
C
C     CALCULA EL ESPESOR
C
      EPS33 = - POISS/(1.0-POISS)*STRAN(1)
      THICK = THIKI*EXP(EPS33)
C
C     F O R M A   L A   M A T R I Z   C O N S T I T U T I V A   D E  
C     M E M B R A N A ,  F L E X I O N ,  A C O P L A M I E N T O   Y
C     C O R T A N T E
C
      KGAUZ = 0
      DO 20 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(2)
      EPSRA(2) = 0.0
      EPSRA(3) = STNRA(3)
C
C     CALCULA LA VISCOSIDAD
C
      CALL VISCOS(EPSRA ,EEPRA(KGAUZ) ,EEPRI(KGAUZ) ,EEPSN(KGAUZ) ,
     1            EEPSI(KGAUZ) ,PARAM(1,KGAUZ) ,PROPS ,VOIDS(KGAUZ) ,
     2            VOIDI(KGAUZ) ,VOIRA(KGAUZ) ,VOIRI(KGAUZ) )
C
C     FORMA LA MATRIZ CONSTITUTIVA DE MEMBRANA
C
      FACT1 = 2.0*VISCO/(1.0-POISS)*DZLEN
      DMATX(1,1) = DMATX(1,1) + FACT1
C
C     FORMA LA MATRIZ CONSTITUTIVA DE ACOPLAMIENTO
C
      FACT1 = FACT1*ZGASP
      DMATX(1,2) = DMATX(1,2) + FACT1
C
C     FORMA LA MATRIZ CONSTITUTIVA DE FLEXION
C
      FACT1 = FACT1*ZGASP
      DMATX(2,2) = DMATX(2,2) + FACT1
C
C     FORMA LA MATRIZ CONSTITUTIVA DE CORTANTE
C
      DMATX(3,3) = DMATX(3,3) + VISCO*CONST*DZLEN
20    CONTINUE
C
C     COMPLETA LA MATRIZ POR SIMETRIA
C
      DMATX(2,1) = DMATX(1,2)
      RETURN
C
C
C     T I P O   2 :   A X I S I M E T R I C O
C
C
C     SELECCCIONA FORMULACION
C
200   GO TO (210,220), NFORM
      STOP
C
C
C     F O R M U L A C I O N   M E M B R A N A
C
C
210   EPSRA(1) = STNRA(1)
      EPSRA(2) = STNRA(2)
      EPSRA(3) = 0.0
C
C     CALCULA LA VISCOSIDAD
C
      CALL VISCOS(EPSRA ,EEPRA ,EEPRI ,EEPSN ,EEPSI ,PARAM ,
     1            PROPS ,VOIDS ,VOIDI ,VOIRA ,VOIRI )
C
C     CALCULA EL ESPESOR
C
      EPS33 = - POISS/(1.0-POISS)*(STRAN(1)+STRAN(2))
      THICK = THIKI*EXP(EPS33)
C
C     F O R M A   L A   M A T R I Z   C O N S T I T U T I V A   D E
C     M E M B R A N A
C
      FACT1 = 2.0*VISCO/(1.0-POISS)*THICK
      FACT2 = FACT1*POISS
      DMATX(1,1) = FACT1
      DMATX(2,1) = FACT2
      DMATX(1,2) = FACT2
      DMATX(2,2) = FACT1
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
220   EPSRA(1) = STNRA(1)
      EPSRA(2) = STNRA(2)
      EPSRA(3) = STNRA(5)
C
C     CALCULA LA VISCOSIDAD
C
      CALL VISCOS(EPSRA ,EEPRA(NMIDZ) ,EEPRI(NMIDZ) ,EEPSN(NMIDZ) ,
     1            EEPSI(NMIDZ) ,PARAM(1,NMIDZ) ,PROPS ,VOIDS(NMIDZ) ,
     2            VOIDI(NMIDZ) ,VOIRA(NMIDZ) ,VOIRI(NMIDZ) )
C
C     CALCULA EL ESPESOR
C
      EPS33 = - POISS/(1.0-POISS)*(STRAN(1)+STRAN(2))
      THICK = THIKI*EXP(EPS33)
C
C     F O R M A   L A   M A T R I Z   C O N S T I T U T I V A   D E  
C     M E M B R A N A ,  F L E X I O N ,  A C O P L A M I E N T O   Y
C     C O R T A N T E
C
      KGAUZ = 0
      DO 30 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(3)
      EPSRA(2) = STNRA(2) + ZGASP*STNRA(4)
      EPSRA(3) = STNRA(5)
C
C     CALCULA LA VISCOSIDAD
C
      CALL VISCOS(EPSRA ,EEPRA(KGAUZ) ,EEPRI(KGAUZ) ,EEPSN(KGAUZ) ,
     1            EEPSI(KGAUZ) ,PARAM(1,KGAUZ) ,PROPS ,VOIDS(KGAUZ) ,
     2            VOIDI(KGAUZ) ,VOIRA(KGAUZ) ,VOIRI(KGAUZ) )
C
C     FORMA LA MATRIZ CONSTITUTIVA DE MEMBRANA
C
      FACT1 = 2.0*VISCO/(1.0-POISS)*DZLEN
      FACT2 = FACT1*POISS
      DMATX(1,1) = DMATX(1,1) + FACT1
      DMATX(2,1) = DMATX(2,1) + FACT2
      DMATX(1,2) = DMATX(1,2) + FACT2
      DMATX(2,2) = DMATX(2,2) + FACT1
C
C     FORMA LA MATRIZ CONSTITUTIVA DE ACOPLAMIENTO
C
      FACT1 = FACT1*ZGASP
      FACT2 = FACT2*ZGASP
      DMATX(1,3) = DMATX(1,3) + FACT1
      DMATX(2,3) = DMATX(2,3) + FACT2
      DMATX(1,4) = DMATX(1,4) + FACT2
      DMATX(2,4) = DMATX(2,4) + FACT1
C
C     FORMA LA MATRIZ CONSTITUTIVA DE FLEXION
C
      FACT1 = FACT1*ZGASP
      FACT2 = FACT2*ZGASP
      DMATX(3,3) = DMATX(3,3) + FACT1
      DMATX(4,3) = DMATX(4,3) + FACT2
      DMATX(3,4) = DMATX(3,4) + FACT2
      DMATX(4,4) = DMATX(4,4) + FACT1
C
C     FORMA LA MATRIZ CONSTITUTIVA DE CORTANTE
C
      DMATX(5,5) = DMATX(5,5) + VISCO*CONST*DZLEN
30    CONTINUE
C
C     COMPLETA LA MATRIZ CONSTITUTIVA POR SIMETRIA
C
      DO 40 IGSTR =     1,NGSTR
      DO 40 JGSTR = IGSTR,NGSTR
      DMATX(JGSTR,IGSTR) = DMATX(IGSTR,JGSTR)
40    CONTINUE
      RETURN
      END

      SUBROUTINE VISCOS(EPSRA,EEPRA,EEPRI,EEPSN,EEPSI,PARAM,
     1                  PROPS,VOIDS,VOIDI,VOIRA,VOIRI)
C*******************************************************************************
C
C*** CALCULA LA VISCOSIDAD EN UN PUNTO DE GAUSS 
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /NPARAM/ NPARA
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /MODEL2/ VPCON ,GAMMA ,VPSEN
      DIMENSION
     1   PROPS(    1) ,EPSRA(   3) ,PARAM(NPARA)
      DATA  NITER /20/
      DATA  VTOL,PTOL /1.0E-07,1.0E-07/
C
C     SELECCIONA MODELO MATERIAL
C
      GO TO (1,2,3,4,5), MODEL
      STOP
C
C     M O D E L O   1 :   M O D E L O   P L A S T I C O   D E   
C                         V O N   M I S E S
C
1     POISS = 0.5
      CALL INVAR(EPSRA(1),EPSRA(2),EPSRA(3),EEPRA,POISS)
      EEPSN = EEPSI + ((1.0-ACOEF)*EEPRI + ACOEF*EEPRA)*DTIME
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN,PROPS)
      VISCO = YIELD/(3.0*EEPRA)
      PARAM(1) = VISCO
      RETURN
C
C     M O D E L O   2 :   M O D E L O   V I S C O P L A S T I C O   D E   
C                         V O N   M I S E S
C
2     POISS = 0.5
      CALL INVAR(EPSRA(1),EPSRA(2),EPSRA(3),EEPRA,POISS)
      EEPSN = EEPSI + ((1.0-ACOEF)*EEPRI + ACOEF*EEPRA)*DTIME
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN,PROPS)
      GAMMA = PROPS(2)
      VPSEN = PROPS(3)
      VISCO = (YIELD + (EEPRA/GAMMA)**VPSEN)/(3.0*EEPRA)
      PARAM(1) = VISCO
      RETURN
C
C     M O D E L O   3 :   M O D E L O   P L A S T I C O   C O N   
C                         D E G R A D A C I O N   D E   G U R S O N
C
3     VISCO = PARAM(1)
      POISS = PARAM(2)
      DO 300 ITERA = 1,NITER
      CALL SETVAR(EPSRA ,EEPRA ,EEPRI ,EEPSN ,EEPSI ,PROPS ,
     1            VOIDS ,VOIDI ,VOIRA ,VOIRI )
      CALL SETSY1(VOIDS)
      CALL SETSOL(VERR  ,PERR  ,VTOL  ,PTOL  ,NCHK2)
      IF(NCHK2.EQ.1) GO TO 310
300   CONTINUE
      WRITE(IOUTP,2000) VERR,PERR
310   CONTINUE
      PARAM(1) = VISCO
      PARAM(2) = POISS
      RETURN
C
C     M O D E L O   4 :   M O D E L O   V I S C O P L A S T I C O   C O N  
C                         D E G R A D A C I O N   D E   G U R S O N
C
4     VISCO = PARAM(1)
      POISS = PARAM(2)
      GAMMA = PROPS(2)
      VPSEN = PROPS(3)
      VPCON = (1.0/GAMMA)**VPSEN
      DO 400 ITERA = 1,NITER
      CALL SETVAR(EPSRA ,EEPRA ,EEPRI ,EEPSN ,EEPSI ,PROPS ,
     1            VOIDS ,VOIDI ,VOIRA ,VOIRI )
      CALL SETSY2(VOIDS)
      CALL SETSOL(VERR  ,PERR  ,VTOL  ,PTOL  ,NCHK2)
      IF(NCHK2.EQ.1) GO TO 410
400   CONTINUE
      WRITE(IOUTP,2000) VERR,PERR
410   CONTINUE
      PARAM(1) = VISCO
      PARAM(2) = POISS
      RETURN
C
C     M O D E L O   5 :   M O D E L O   E L A S T I C O  
C                         N O   L I N E A L
C     
5     YOUNG = PROPS(2)
      POISS = PROPS(3)
      CALL INVAR(EPSRA(1),EPSRA(2),EPSRA(3),EEPRA,POISS)
      EEPSN = EEPSI + ((1.0-ACOEF)*EEPRI + ACOEF*EEPRA)*DTIME
      GAMMA = 2.0*(1.0+POISS)/(3.0*YOUNG)
      VPSEN = 1.0
      VPCON = 1.0/GAMMA
      VISCO = 1.0/3.0*VPCON
      PARAM(1) = VISCO
      RETURN
C
C     FORMATOS
C
2000  FORMAT(/,' EL PROCESO ITERATIVO LOCAL NO HA CONVERGIDO'/
     1  5X,' NORMA DE ERROR VISCOSIDAD             = ',E12.4,/
     2  5X,' NORMA DE ERROR COEFICIENTE DE POISSON = ',E12.4)
      END

      SUBROUTINE SETVAR(EPSRA,EEPRA,EEPRI,EEPSN,EEPSI,PROPS,
     1                  VOIDS,VOIDI,VOIRA,VOIRI)
C*******************************************************************************
C
C*** CALCULO ITERATIVO DE LOS PARAMETROS DEL MATERIAL PARA LOS
C    MODELOS CON DEGRADACION
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /MODEL2/ VPCON ,GAMMA ,VPSEN
      COMMON /INTERN/ EPSKK ,SIGKK ,YIELD ,AFACT ,CFACT ,SFACT ,
     1                SDIVA ,VOIDC ,OMEGA ,BFACT ,EQVPR ,
     2                DEPR2 ,DEKK2 ,DSKK2 ,DYLD2 ,DERA2 ,DVOI2 ,
     3                DOMG1 ,DOMG2 ,DEQV1 ,DEQV2 
      DIMENSION  EPSRA(3) ,PROPS(1) 
C
C     CALCULA EL INVARIANTE DE LA VELOCIDAD DE DEFORMACION,
C     LA DEFORMACION EFECTIVA Y LA TENSION DE FLUENCIA
C
      CALL INVAR(EPSRA(1),EPSRA(2),EPSRA(3),EEPRA,POISS)
      EEPSN = EEPSI + ((1.0-ACOEF)*EEPRI + ACOEF*EEPRA)*DTIME
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN,PROPS)
C
C     CALCULA LA VELOCIDAD DE DEFORMACION VOLUMETRICA Y
C     TENSION VOLUMETRICA 
C
      EPSKK = (1.0-2.0*POISS)/(1.0-POISS)*(EPSRA(1)+EPSRA(2))
      SIGKK = 2.0*VISCO*(1.0+POISS)/(1.0-POISS)*(EPSRA(1)+EPSRA(2))
C
C     CALCULA LOS PARAMETROS A,C Y S
C
      AFACT = SIGKK/(2.0*YIELD)

      amaxi = 10.0
      if(voids.ne.0.0) cmaxi = (1.0 + voids*voids)/(2.0*voids)
      if(voids.ne.0.0) amax2 = log(2.0*cmaxi)
      if(voids.ne.0.0.and.amax2.lt.amaxi) amaxi = amax2
      if(afact.gt.amaxi) then
      afact = 0.9*amaxi
      vimax = (1.0-poiss)/(1.0+poiss)*yield/(epsra(1)+epsra(2))*afact
      sigkk = sigkk*vimax/visco
      visco = vimax
      end if

      CFACT = COSH(AFACT)
      SFACT = SINH(AFACT)
      SDIVA = 1.0
      IF(AFACT.NE.0.0) SDIVA = SFACT/AFACT
C
C     CALCULA EL INDICE DE POROS 
C     SE CONSIDERA EN LA LEY DE EVOLUCION DEL INDICE DE POROS, LA
C     VARIACION POR CRECIMIENTO UNICAMENTE
C
      VOIDC = VOIDI + (1.0-ACOEF)*VOIRI*DTIME
      VOIDS = (VOIDC + ACOEF*DTIME*EPSKK)/(1.0+ACOEF*DTIME*EPSKK)
      VOIRA = (1.0 - VOIDS)*EPSKK
C
C     CALCULA EL PARAMETRO OMEGA Y EL PARAMETRO B
C
      OMEGA = 1.0 + VOIDS*VOIDS - 2.0*VOIDS*CFACT
      BFACT = 0.5*VOIDS*SDIVA      
C
C     CALCULA LA VELOCIDAD DE DEFORMACION EQUIVALENTE
C
      EQVPR = SQRT((EEPRA*EEPRA - 2.D0/9.D0*EPSKK*EPSKK)/OMEGA)
C
C     CALCULA LA DERIVADA DE LA VELOCIDAD DE DEFORMACION EFECTIVA
C     CON RESPECTO AL COEFICIENTE DE POISSON
C
      AUXI1 = POISS/(1.0-POISS)**3
      AUXI2 = EPSRA(1) + EPSRA(2)
      DEPR2 = 2.0/(3.0*EEPRA)*AUXI1*AUXI2*AUXI2
C
C     CALCULA LA DERIVADA DE LA VELOCIDAD DE DEFORMACION VOLUMETRICA
C     CON RESPECTO AL COEFICIENTE DE POISSON
C
      DEKK2 = - (EPSRA(1)+EPSRA(2))/(1.0-POISS)**2
C
C     CALCULA LA DERIVADA DE LA TENSION VOLUMETRICA
C     CON RESPECTO AL COEFICIENTE DE POISSON
C
      DSKK2 = 2.0*SIGKK/(1.0-POISS*POISS)
C
C     CALCULA LA DERIVADA DE LA TENSION DE FLUENCIA
C     CON RESPECTO AL COEFICIENTE DE POISSON
C
      DYLD2 = HARDE*ACOEF*DTIME*DEPR2
C
C     CALCULA LA DERIVADA DEL PARAMETRO A
C     CON RESPECTO AL COEFICIENTE DE POISSON
C
      DERA2 = DSKK2/(2.0*YIELD) - DYLD2*SIGKK/(2.0*YIELD*YIELD)
C
C     CALCULA LA DERIVADA DEL INDICE DE POROS
C     CON RESPECTO AL COEFICIENTE DE POISSON
C
      AUXI1 = 1.0 + EPSKK*ACOEF*DTIME
      DVOI2 = (1.0-VOIDC)*ACOEF*DTIME*DEKK2/(AUXI1*AUXI1)
C
C     CALCULA LA DERIVADA DE OMEGA
C     CON RESPECTO A LA VISCOSIDAD Y AL COEFICIENTE DE POISSON
C
      DOMG1 = - 2.0*VOIDS*AFACT*SFACT/VISCO
      DOMG2 = 2.0*((VOIDS-CFACT)*DVOI2 - VOIDS*SFACT*DERA2)
C
C     CALCULA LA DERIVADA DE LA VELOCIDAD DE DEFORMACION EQUIVALENTE
C     CON RESPECTO A LA VISCOSIDAD Y AL COEFICIENTE DE POISSON
C
      DEQV1 = - EQVPR*DOMG1/(2.0*OMEGA)
      DEQV2 = ((OMEGA*(2.0*EEPRA*DEPR2 - 4.0/9.0*EPSKK*DEKK2) -
     1   (EEPRA*EEPRA - 2.0/9.0*EPSKK*EPSKK)*DOMG2)/
     2   (OMEGA*OMEGA))/(2.0*EQVPR)
      RETURN
      END

      SUBROUTINE SETSY1(VOIDS)
C*******************************************************************************
C
C*** CALCULA LOS GRADIENTES DE LAS FUNCIONES RESIDUOS DE LA VISCODIDAD
C    Y DEL COEFICIENTE DE POISSON PARA EL MODELO 3 
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /INTERN/ EPSKK ,SIGKK ,YIELD ,AFACT ,CFACT ,SFACT ,
     1                SDIVA ,VOIDC ,OMEGA ,BFACT ,EQVPR ,
     2                DEPR2 ,DEKK2 ,DSKK2 ,DYLD2 ,DERA2 ,DVOI2 ,
     3                DOMG1 ,DOMG2 ,DEQV1 ,DEQV2 
      COMMON /GRADS / GRADM(2,2) ,RESIV(2)
C
C     CALCULA LOS GRADIENTES DE LAS FUNCIONES RESIDUOS
C
      AUXI1 = SDIVA - CFACT
      AUXI2 = 2.0 + BFACT
      AUXI2 = AUXI2*AUXI2
      AUXI3 = 2.0/(1.0-POISS*POISS) - DYLD2/YIELD
      GRADM(1,1) = 1.0 - (- VOIDS*AFACT*SFACT/OMEGA)
      GRADM(1,2) =     - (EQVPR*DYLD2 - DEQV2*YIELD)/(3.0*EQVPR*EQVPR)
      GRADM(2,1) =     - 3.0/(2.0*VISCO)*VOIDS*AUXI1/AUXI2
      GRADM(2,2) = 1.0 - 3.0/(2.0*AUXI2)*(VOIDS*AUXI1*AUXI3-SDIVA*DVOI2)
C
C     CALCULA LAS FUNCIONES RESIDUOS
C
      RESIV(1) = YIELD/(3.0*EQVPR) - VISCO
      RESIV(2) = (1.0-0.5*VOIDS*SDIVA)/(2.0+0.5*VOIDS*SDIVA) - POISS
      RETURN
      END

      SUBROUTINE SETSY2(VOIDS)
C*******************************************************************************
C
C*** CALCULA LOS GRADIENTES DE LAS FUNCIONES RESIDUOS DE LA VISCODIDAD
C    Y DEL COEFICIENTE DE POISSON PARA EL MODELO 4 
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /MODEL2/ VPCON ,GAMMA ,VPSEN
      COMMON /INTERN/ EPSKK ,SIGKK ,YIELD ,AFACT ,CFACT ,SFACT ,
     1                SDIVA ,VOIDC ,OMEGA ,BFACT ,EQVPR ,
     2                DEPR2 ,DEKK2 ,DSKK2 ,DYLD2 ,DERA2 ,DVOI2 ,
     3                DOMG1 ,DOMG2 ,DEQV1 ,DEQV2 
      COMMON /GRADS / GRADM(2,2) ,RESIV(2)
C
C     CALCULA LA TENSION EQUIVALENTE PARA EL MODELO VISCOPLASTICO
C
      EQVST = YIELD + (OMEGA/GAMMA)**VPSEN*EQVPR**VPSEN
C
C     CALCULA LA DERIVADA DE LA TENSION EQUIVALENTE
C     RESPECTO A LA VISCOSIDAD Y AL COEFICIENTE DE POISSON
C
      DEQS1 = 
     1   VPSEN*VPCON*OMEGA**(VPSEN-1.0)*EQVPR**VPSEN*DOMG1 +
     2   VPSEN*VPCON*EQVPR**(VPSEN-1.0)*OMEGA**VPSEN*DEQV1
      DEQS2 = 
     1   DYLD2 + 
     2   VPSEN*VPCON*OMEGA**(VPSEN-1.0)*EQVPR**VPSEN*DOMG2 +
     3   VPSEN*VPCON*EQVPR**(VPSEN-1.0)*OMEGA**VPSEN*DEQV2
C
C     CALCULA LOS GRADIENTES DE LAS FUNCIONES RESIDUOS
C
      AUXI1 = SDIVA - CFACT
      AUXI2 = 2.0 + BFACT
      AUXI2 = AUXI2*AUXI2
      AUXI3 = 2.0/(1.0-POISS*POISS) - DYLD2/YIELD
      GRADM(1,1) = 1.0 - (EQVPR*DEQS1 - EQVST*DEQV1)/(3.0*EQVPR*EQVPR) 
      GRADM(1,2) =     - (EQVPR*DEQS2 - EQVST*DEQV2)/(3.0*EQVPR*EQVPR)
      GRADM(2,1) =     - 3.0/(2.0*VISCO)*VOIDS*AUXI1/AUXI2
      GRADM(2,2) = 1.0 - 3.0/(2.0*AUXI2)*(VOIDS*AUXI1*AUXI3-SDIVA*DVOI2)
C
C     CALCULA LAS FUNCIONES RESIDUOS
C
      RESIV(1) = EQVST/(3.0*EQVPR) - VISCO
      RESIV(2) = (1.0-0.5*VOIDS*SDIVA)/(2.0+0.5*VOIDS*SDIVA) - POISS
      RETURN
      END

      SUBROUTINE SETSOL(VERR ,PERR ,VTOL ,PTOL ,NCHK2)
C*******************************************************************************
C
C*** RESUELVE EL SISTEMA DE ECUACIONES A NIVEL DE PUNTO DE GAUSS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /GRADS / GRADM(2,2) ,RESIV(2)
C
C     RESUELVE EL SISTEMA DE ECUACIONES
C
      DETER = GRADM(1,1)*GRADM(2,2) - GRADM(1,2)*GRADM(2,1)
      POINC = (GRADM(1,1)*RESIV(2) - GRADM(2,1)*RESIV(1))/DETER
      VIINC = (RESIV(1) - GRADM(1,2)*POINC)/GRADM(1,1)
C
C     CORRIGE LOS VALORES DE LA VISCOSIDAD Y DEL COEFICIENTE DE POISSON
C
      VISCO = VISCO + VIINC
      POISS = POISS + POINC
C
C     COMPRUEBA CONVERGENCIA
C
      VERR = ABS(VIINC)/VISCO
      PERR = ABS(POINC)/POISS
      NCHK2 = 0
      IF(VERR.LE.VTOL.AND.PERR.LE.PTOL) NCHK2 = 1
      RETURN
      END

      SUBROUTINE INVAR(EPS11,EPS22,EPS12,EEPRA,POISS)
C*******************************************************************************
C
C*** CALCULA LA VELOCIDAD DE DEFORMACION EFECTIVA
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      EPS33 = - POISS/(1.0 - POISS)*(EPS11 + EPS22)
      EEPRA = SQRT(2.D0/3.D0*(EPS11*EPS11 + EPS22*EPS22 + EPS33*EPS33 +
     1                  0.5D0*EPS12*EPS12))
      IF(EEPRA.LT.1.0E-10) EEPRA = 1.0E-10
      RETURN
      END

      SUBROUTINE YIELDF(YIELD,HARDE,NHARD,EEPSN,PROPS)
C*******************************************************************************
C
C*** CALCULA LA TENSION DE FLUENCIA 
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION PROPS(1)
C
C     SELECCIONA TIPO DE FUNCION
C
      GO TO (1,2,3,4,5,6,7), NHARD
      STOP
C
C     TIPO 1: PLASTICIDAD PERFECTA
C
1     YIELD = PROPS(1)
      HARDE = 0.0
      RETURN
C
C     TIPO 2: PLASTICIDAD CON ENDURECIMIENTO #1
C
C     --- HPS BENCHMARK / WOO ---
C
2     IF(EEPSN.LE.0.36) YIELD = 5.4D0 + 27.8D0*EEPSN**0.504D0
      IF(EEPSN.GT.0.36) YIELD = 5.4D0 + 24.4D0*EEPSN**0.375D0
      HARDE = 1.0E+10
      IF(EEPSN.EQ.0.00) RETURN
      IF(EEPSN.LE.0.36) HARDE = 14.011D0/EEPSN**0.496D0
      IF(EEPSN.GT.0.36) HARDE =  9.150D0/EEPSN**0.625D0
      RETURN
C
C     TIPO 3: PLASTICIDAD CON ENDURECIMIENTO #2
C
C     --- HPS BENCHMARK / WAGONER ---
C
3     YIELD = 589.D0*(1.0E-04+EEPSN)**0.216D0
      HARDE = 589.D0*0.216D0/(1.0E-04+EEPSN)**0.784D0
      RETURN
C
C     TIPO 4: PLASTICIDAD CON ENDURECIMIENTO #3
C
C     --- FLAT SHEET NECKING / DOLTSINIS ---
C
4     YIELD = 520.D0*EEPSN**0.25D0
      HARDE = 130.D0/EEPSN**0.75D0
      RETURN
C
C     TIPO 5: PLASTICIDAD CON ENDURECIMIENTO #4
C
C     --- NUMISHEET / PLANE STRAIN / MILD STEEL ---
C
5     YIELD = 565.32d0*(0.007117d0 + EEPSN)**0.2589d0
      HARDE = 146.36135d0/(0.007117d0 + EEPSN)**0.7411d0
      RETURN
C
C     TIPO 6: PLASTICIDAD CON ENDURECIMIENTO #5
C
C     --- NUMISHEET / PLANE STRAIN / ALUMINIUM ---
C
6     YIELD = 576.79d0*(0.01658 + EEPSN)**0.3593d0
      HARDE = 576.79d0*0.3593d0/(0.01658 + EEPSN)**0.6407d0
      RETURN
C
C     TIPO 7: PLASTICIDAD CON ENDURECIMIENTO #6
C
C     --- NUMISHEET / PLANE STRAIN / HIGH TENSILE STEEL ---
C
7     YIELD = 680.61d0*(0.01250 + EEPSN)**0.2182d0
      HARDE = 680.61d0*0.2182d0/(0.01250 + EEPSN)**0.7818d0
      RETURN
      END

      SUBROUTINE GSTRES(STRES,DMATX,STNRA)
C*******************************************************************************
C
C*** CALCULA TENSIONES GENERALIZADAS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      DIMENSION
     1   STRES(    1) ,DMATX(NGSTR,    1) ,STNRA(    1)
      DO 10 IGSTR = 1,NGSTR
      STRES(IGSTR) = 0.0
      DO 10 JGSTR = 1,NGSTR
      STRES(IGSTR) = STRES(IGSTR) + DMATX(IGSTR,JGSTR)*STNRA(JGSTR) 
10    CONTINUE
      RETURN
      END

      SUBROUTINE SFR1(EXISP,SHAPE,DERIV,NNODE)
C******************************************************************************
C
C*** CALCULA LAS FUNCIONES DE FORMA Y SUS DERIVADAS PARA EL ELEMENTO
C    LINEAL Y CUADRATICO DE LAMINA AXISIMETRICA
C
C******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION  SHAPE(3) ,DERIV(2,3)
      IF(NNODE.GT.2) GO TO 10
C
C
C     E L E M E N T O   D E   2   N O D O S
C
C
      S = EXISP
C
C     FUNCIONES DE FORMA
C
      SHAPE(1) = (1.D0-S)/2.D0
      SHAPE(2) = (1.D0+S)/2.D0
C
C     DERIVADAS PRIMERAS DE LAS FUNCIONES DE FORMA
C
      DERIV(1,1) = -0.5D0
      DERIV(1,2) =  0.5D0
C
C     DERIVADAS SEGUNDAS DE LAS FUNCIONES DE FORMA
C
      DERIV(2,1) = 0.D0
      DERIV(2,2) = 0.D0
      RETURN
10    CONTINUE
C
C
C     E L E M E N T O   D E   3   N O D O S
C
C
      S = EXISP
      SS = S*S
      S2 = S*2.D0
C
C     FUNCIONES DE FORMA
C
      SHAPE(1) = (SS-S)/2.D0
      SHAPE(2) = 1.D0-SS
      SHAPE(3) = (SS+S)/2.D0
C
C     DERIVADAS PRIMERAS DE LAS FUNCIONES DE FORMA
C
      DERIV(1,1) = (S2-1.D0)/2.D0
      DERIV(1,2) = -S2
      DERIV(1,3) = (S2+1.D0)/2.D0
C
C     DERIVADAS SEGUNDAS DE LAS FUNCIONES DE FORMA
C
      DERIV(2,1) = 1.D0
      DERIV(2,2) = -2.D0
      DERIV(2,3) = 1.D0
      RETURN
      END

      SUBROUTINE JACOB1(IELEM,KGASP)
C******************************************************************************
C
C*** CALCULA LA MATRIZ JACOBIANO, EL ANGULO Y LAS DERIVADAS DE LAS
C    FUNCIONES DE FORMA RESPECTO LA COORDENADA CURVILINEA
C
C******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
C
C     CALCULA LAS COORDENADAS CARTESIANAS DE LOS PUNTOS DE GAUSS
C
      DO 10 IDIME = 1,NDIME
      GPCOD(IDIME,KGASP) = 0.D0
      DO 10 INODE = 1,NNODE
      GPCOD(IDIME,KGASP) = GPCOD(IDIME,KGASP) + ELCOD(IDIME,INODE)*
     1                     SHAPE(INODE)
10    CONTINUE
C
C     CALCULA LA MATRIZ JACOBIANO (DX/DXI,DY/DXI)
C
      DO 20 IDIME = 1,NDIME
      XJACM(IDIME) = 0.D0
      SECDR(IDIME) = 0.D0
      DO 20 INODE = 1,NNODE
      XJACM(IDIME) = XJACM(IDIME) + ELCOD(IDIME,INODE)*DERIV(1,INODE)
      SECDR(IDIME) = SECDR(IDIME) + ELCOD(IDIME,INODE)*DERIV(2,INODE)
20    CONTINUE
C
C     CALCULA EL DETERMINANTE
C
      DJACB = SQRT(XJACM(1)*XJACM(1) + XJACM(2)*XJACM(2))
      IF(DJACB) 30,30,40
30    WRITE(IOUTP,3000) IELEM
      STOP
40    CONTINUE
C
C     CALCULA EL ANGULO Y EL RADIO DE CURVATURA
C
      ANGLE = ATAN2(XJACM(2),XJACM(1))
      DENOM = SECDR(1)*XJACM(2) - SECDR(2)*XJACM(1)
      IF(ABS(DENOM).LT.1.0E-10) DENOM = 1.0E-10
      RCURV = DJACB**3/DENOM
C
C     CALCULA LA DERIVADA DE LAS FUNCIONES DE FORMA RESPECTO 
C     LA COORDENADA CURVILINEA
C
      DO 50 INODE = 1,NNODE
      CARTD(INODE) = DERIV(1,INODE)/DJACB
50    CONTINUE
      RETURN
3000  FORMAT(//' PROGRAM HALTED IN SUBROUTINE JACOB1',/,11X,'ZERO
     1       OR NEGATIVE AREA',/,10X,'ELEMENT NUMBER ',I5)
      END

      SUBROUTINE ERNORM(VELOC,VELOI,PLOAD,RESID,ERNRM,EVNRM,VNORM)
C*******************************************************************************
C
C*** CALCULA NORMAS DE ERROR
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      DIMENSION
     1   RESID(NDOFN,1) ,PLOAD(NDOFN,1), VELOC(NDOFN,1),
     2   VELOI(NDOFN,1)
C
C     EVALUA NORMAS DE ERROR
C
      RNORM = 0.0
      FNORM = 0.0
      VENRM = 0.0
      DO 30 IPOIN = 1,NPOIN
      DO 30 IDOFN = 1,NDOFN
      RVALU = RESID(IDOFN,IPOIN)
      FVALU = PLOAD(IDOFN,IPOIN)
      VVALU = VELOC(IDOFN,IPOIN)
      RNORM = RNORM + RVALU*RVALU
      FNORM = FNORM + FVALU*FVALU
      VENRM = VENRM + VVALU*VVALU
30    CONTINUE
      RNORM = SQRT(RNORM)
      FNORM = SQRT(FNORM)
      VENRM = SQRT(VENRM)
      ERNRM = 1.0
      IF(FNORM.GT.0.0) ERNRM = RNORM/FNORM
      IF(FNORM.LT.1.0E-10.AND.RNORM.LT.1.0E-10) ERNRM = 0.0
      IF(FNORM.EQ.0.0) ERNRM = 1.0
      EVNRM = 1.0
      IF(IITER.GT.1) THEN
        IF(VENRM.GT.0.0) EVNRM = VNORM/VENRM
        IF(VENRM.EQ.0.0) EVNRM = 1.0
      END IF
C
C     ESCRIBE NORMAS DE FUERZAS Y NORMAS DE ERROR
C
      WRITE(IOUTP,2000) IINCS,IITER,TTIME,RNORM,FNORM,ERNRM,EVNRM
      RETURN
C
C     FORMATOS
C
2000  FORMAT(/' NORMAS DE ERROR',3X,'INCREMENTO =',I3,
     1   3X,'ITERACION =',I3,3X,'TIEMPO = ',E10.4/
     2   5X,' NORMA FUERZAS RESIDUALES = ',E10.4/
     3   5X,' NORMA FUERZAS            = ',E10.4/
     4   5X,' NORMA ERROR FUERZAS      = ',E10.4/
     5   5X,' NORMA ERROR VELOCIDADES  = ',E10.4)
      END

      SUBROUTINE CONVER(ERNRM,EVNRM,NCHEK)
C*******************************************************************************
C
C*** CHEQUEA CONVERGENCIA DE LA SOLUCION
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /ACTNRM/ IRNRM ,IVNRM
      COMMON /TOLERA/ TOLEF ,TOLEV
      NCHEK = 0
      IF(IRNRM.EQ.1.AND.IVNRM.EQ.0) THEN
        IF(ERNRM.LT.TOLEF) NCHEK = 1
      ELSE IF(IRNRM.EQ.0.AND.IVNRM.EQ.1) THEN
        IF(EVNRM.LT.TOLEV) NCHEK = 1
      ELSE IF(IRNRM.EQ.1.AND.IVNRM.EQ.1) THEN
        IF(ERNRM.LT.TOLEF.AND.EVNRM.LT.TOLEV) NCHEK = 1
      ELSE IF(IRNRM.EQ.-1.AND.IVNRM.EQ.-1) THEN
        IF(ERNRM.LT.TOLEF.OR.EVNRM.LT.TOLEV) NCHEK = 1
      END IF
      RETURN
      END

      SUBROUTINE STIFNS(COORD,LNODS,MATNO,PROPS,FIXED,VELOC,
     1                  BMATX,DMATX,DBMAT,DMATS,DMATT,DERIB,
     2                  EEPSN,EEPSI,STNRA,EEPRA,EEPRI,STRES,
     3                  THICK,PARAM,VOIDS,VOIDI,VOIRA,VOIRI,
     4                  RLOAD,LEQNS,MAXAD,ESTIF,FORCE,STIFF)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ DE RIGIDEZ TANGENTE
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /PROFIL/ NEQNS ,NWKTL
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /NPARAM/ NPARA
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      COMMON /GAUSS / POSGP(3) ,WEIGP(3)
      DIMENSION 
     1   COORD(NDIME,1) ,LNODS(NNODE,1) ,MATNO(      1) ,
     2   PROPS(NPROP,1) ,FIXED(NDOFN,1) ,VELOC(NDOFN,1) ,
     3   BMATX(NGSTR,1) ,DMATX(NGSTR,1) ,DBMAT(NGSTR,1) ,
     4   DMATS(NGSTR,1) ,DMATT(NGSTR,1) ,DERIB(      1) ,
     5   EEPSN(      1) ,EEPSI(      1) ,STNRA(NGSTR,1) ,
     6   EEPRA(      1) ,EEPRI(      1) ,STRES(NGSTR,1) ,
     7   THICK(      1) ,PARAM(NPARA,1) ,VOIDS(      1) ,
     8   VOIDI(      1) ,VOIRA(      1) ,VOIRI(      1) ,
     9   RLOAD(NEVAB,1) ,LEQNS(NEVAB,1) ,MAXAD(      1) 
      DIMENSION
     1   ESTIF(      1) ,FORCE(      1) ,STIFF(      1)
      TWOPI = 8.0*ATAN(1.0)
C
C     LOOP PARA TODOS LOS ELEMENTOS
C
      KGAST = 0
      KGAZT = 1
      DO 200 IELEM = 1,NELEM
C
C     LOCALIZA MATERIAL, COORDENADAS Y VELOCIDAD DEL ELEMENTO
C
      LPROP = MATNO(IELEM)
      DO 40 INODE = 1,NNODE
      LNODE = LNODS(INODE,IELEM)
      DO 30 IDIME = 1,NDIME
      ELCOD(IDIME,INODE) = COORD(IDIME,LNODE)
30    CONTINUE
      DO 40 IDOFN = 1,NDOFN
      ELVEL(IDOFN,INODE) = VELOC(IDOFN,LNODE)
40    CONTINUE
C
C     INICIALIZA A CERO LA MATRIZ DE RIGIDEZ DEL ELEMENTO
C
      DO 50 ISTIF = 1,NSTIF
      ESTIF(ISTIF) = 0.0
50    CONTINUE
C
C     LOOP PARA TODOS LOS PUNTOS DE GAUSS DEL ELEMENTO
C
      KGASP = 0
      KGAZP = 1
      DO 100 IGAUS = 1,NGAUS
      KGASP = KGASP + 1
      KGAST = KGAST + 1
      EXISP = POSGP(IGAUS)
C
C     EVALUA FUNCIONES DE FORMA, ETC. PARA CADA PUNTO DE GAUSS
C
      CALL SFR1(EXISP ,SHAPE ,DERIV ,NNODE)
      CALL JACOB1(IELEM ,KGASP)
      RADUS = GPCOD(1,KGASP)
      DAREA = DJACB*WEIGP(IGAUS)
      IF(NTYPE.EQ.2) DAREA = DAREA*TWOPI*RADUS
C
C     CALCULA LA MATRIZ B GENERALIZADA
C
      CALL BMATRX(BMATX)
C
C     CALCULA LA DERIVADA DE LA MATRIZ B CON RESPECTO A LAS
C     VELOCIDADES NODALES
C
      CALL DERIVB(DERIB)
C
C     CALCULA LA MATRIZ CONSTITUTIVA TANGENTE GENERALIZADA
C
      CALL DMATAN(STNRA(1,KGAST) ,PARAM(1,KGAZT) ,EEPSN(  KGAZT) ,
     1            EEPRA(  KGAZT) ,THICK(  KGAST) ,PROPS(1,LPROP) ,
     2            EEPRI(  KGAZT) ,EEPSI(  KGAZT) ,VOIDS(  KGAZT) ,
     3            VOIDI(  KGAZT) ,VOIRA(  KGAZT) ,VOIRI(  KGAZT) ,
     4            DMATX   ,DMATS ,DMATT )
C
C     CALCULA D*B
C
      CALL DBMATX(DMATX ,BMATX ,DBMAT)
C
C     CALCULA LA MATRIZ DE RIGIDEZ TANGENTE DEL ELEMENTO
C
      KSTIF = 0
      DO 60 IEVAB = 1,NEVAB
      DO 60 JEVAB = IEVAB,NEVAB
      KSTIF = KSTIF + 1
      DO 60 IGSTR = 1,NGSTR
      ESTIF(KSTIF) = ESTIF(KSTIF) + 
     1   BMATX(IGSTR,IEVAB)*DBMAT(IGSTR,JEVAB)*DAREA
60    CONTINUE
C
C     CALCULA Y SUMA LA MATRIZ DE RIGIDEZ DE TENSIONES INICIALES
C
      CALL STIFIS(ESTIF ,DERIB ,STRES(1,KGAST))
      KGAZP = KGAZP + NGAUZ
      KGAZT = KGAZT + NGAUZ
100   CONTINUE
C
C     ENSAMBLA LA MATRIZ DE RIGIDEZ DEL ELEMENTO
C
      CALL ADDBAN(STIFF,MAXAD,ESTIF,LEQNS(1,IELEM),NEVAB)
C
C     CORRIGE EL VECTOR DE FUERZAS RESIDUALES PARA EL CASO DE 
C     VELOCIDADES PRESCRITAS NO NULAS
C
      CALL NZPRVE(RLOAD(1,IELEM) ,ESTIF ,LNODS(1,IELEM) ,
     1            LEQNS(1,IELEM) ,FIXED )
C
C     ENSAMBLA EL VECTOR DE FUERZAS RESIDUALES
C
      DO 70 IEVAB = 1,NEVAB
      IEQNS = LEQNS(IEVAB,IELEM)
      IF(IEQNS.GT.0) FORCE(IEQNS) = FORCE(IEQNS) + RLOAD(IEVAB,IELEM)
70    CONTINUE
200   CONTINUE
      RETURN
      END

      SUBROUTINE DMATAN(STNRA,PARAM,EEPSN,EEPRA,THICK,PROPS,
     1                  EEPRI,EEPSI,VOIDS,VOIDI,VOIRA,VOIRI,
     2                  DMATX,DMATS,DMATT)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ CONSTITUTIVA D TANGENTE
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /MODEL2/ VPCON ,GAMMA ,VPSEN
      DIMENSION  
     1   DMATX(NGSTR,1) ,DMATS(NGSTR,1) ,DMATT(NGSTR,1) ,
     2   PROPS(      1)
C
C     INICIALIZA A CERO LA MATRIZ CONSTITUTIVA
C
      DO 10 IGSTR = 1,NGSTR
      DO 10 JGSTR = 1,NGSTR
      DMATX(JGSTR,IGSTR) = 0.0
      DMATS(JGSTR,IGSTR) = 0.0
      DMATT(JGSTR,IGSTR) = 0.0
10    CONTINUE
C
C     SELECCIONA EL MODELO
C
      GO TO (1,2,3,4,5), MODEL
      STOP
C
C     M O D E L O   1 :   M O D E L O   P L A S T I C O   D E   
C                         V O N   M I S E S
C
1     POISS = 0.5
      CALL DMATT1(STNRA ,PARAM ,EEPSN ,EEPRA ,THICK ,PROPS ,
     1            DMATX ,DMATS ,DMATT )
      CALL ADDMAT(DMATX ,DMATS ,DMATT )
      RETURN
C
C     M O D E L O   2 :   M O D E L O   V I S C O P L A S T I C O   D E   
C                         V O N   M I S E S
C
2     POISS = 0.5
      GAMMA = PROPS(2)
      VPSEN = PROPS(3)
      VPCON = (1.0/GAMMA)**VPSEN
      CALL DMATT2(STNRA ,PARAM ,EEPSN ,EEPRA ,THICK ,PROPS ,
     1            DMATX ,DMATS ,DMATT )
      CALL ADDMAT(DMATX ,DMATS ,DMATT )
      RETURN
C
C     M O D E L O   3 :   M O D E L O   P L A S T I C O   C O N   
C                         D E G R A D A C I O N   D E   G U R S O N
C
3     CALL DMATT3
      call dmatt4(stnra ,param ,eepsn ,eepra ,thick ,props ,
     1            eepri ,eepsi ,voids ,voidi ,voira ,voiri ,
     2            dmatx ,dmats ,dmatt )
      CALL ADDMAT(DMATX ,DMATS ,DMATT )
      RETURN
C
C     M O D E L O   4 :   M O D E L O   V I S C O P L A S T I C O   C O N   
C                         D E G R A D A C I O N   D E   G U R S O N
C
4     CALL DMATT4(STNRA ,PARAM ,EEPSN ,EEPRA ,THICK ,PROPS ,
     1            EEPRI ,EEPSI ,VOIDS ,VOIDI ,VOIRA ,VOIRI ,
     2            DMATX ,DMATS ,DMATT )
      CALL ADDMAT(DMATX ,DMATS ,DMATT )
      RETURN
C
C     M O D E L O   5 :   M O D E L O   E L A S T I C O   
C                         N O   L I N E A L
C
5     YOUNG = PROPS(2)
      POISS = PROPS(3)
      GAMMA = 2.0*(1.0+POISS)/(3.0*YOUNG)
      VPSEN = 1.0
      VPCON = 1.0/GAMMA
      VISCO = 1.0/3.0*VPCON
      CALL DMATT0(STNRA ,PARAM ,EEPSN ,EEPRA ,THICK ,PROPS ,
     1            DMATX ,DMATS ,DMATT )
      CALL ADDMAT(DMATX ,DMATS ,DMATT )
      RETURN
      END

      SUBROUTINE DMATT1(STNRA,PARAM,EEPSN,EEPRA,THICK,PROPS,
     1                  DMATX,DMATS,DMATT)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ D TANGENTE PARA EL MODELO 1
C    MODELO PLASTICO DE VON MISES
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      COMMON /GAUSSZ/ POSZP(5) ,WEIZP(5)
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /NPARAM/ NPARA
      COMMON /MIDZGP/ NMIDZ
      COMMON /INISTR/ HSTRI(3) ,STRIN(5)
      DIMENSION
     1   STNRA(      1) ,PARAM(NPARA,1) ,
     2   EEPSN(      1) ,EEPRA(      1) ,
     3   PROPS(      1) ,EPSRA(      3) ,
     4   DMATX(NGSTR,1) ,DMATS(NGSTR,1) ,DMATT(NGSTR,1)
      DATA  CONST /0.8333333333333333/
      POISS = 0.5
C
C     SELECCIONA TIPO DE PROBLEMA
C
      GO TO (100,200), NTYPE
      STOP
C
C
C     T I P O   1 :   D E F O R M A C I O N   P L A N A
C
C
C     SELECCIONA FORMULACION
C
100   GO TO (110,120), NFORM
      STOP
C
C
C     F O R M U L A C I O N   M E M B R A N A
C
C      
110   EPSRA(1) = STNRA(1)
      EPSRA(2) = 0.0
      EPSRA(3) = 0.0
      VISCO = PARAM(1,NMIDZ)
C
C     M A T R I Z   S E C A N T E
C
      DMATS(1,1) = 2.0*VISCO/(1.0-POISS)*THICK
C
C     M A T R I Z   T A N G E N T E 
C
      IF(NALGO.GT.1) GO TO 10
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(NMIDZ),PROPS)
      FACTO = HARDE*ACOEF*DTIME - 3.0*VISCO
      DMATT(1,1) = 4.0/3.0*FACTO*THICK
10    CONTINUE
C
C     TENSION GENERALIZADA INICIAL DE MEMBRANA
C
      STRIN(1) = HSTRI(1)*THICK
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
120   KGAUZ = 0
      DO 20 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(2)
      EPSRA(2) = 0.0
      EPSRA(3) = STNRA(3)
      VISCO = PARAM(1,KGAUZ)
C
C     M A T R I Z   S E C A N T E
C
C     MEMBRANA
C
      DMS11 = 2.0*VISCO/(1.0-POISS)*DZLEN
      DMATS(1,1) = DMATS(1,1) + DMS11
C
C     ACOPLAMIENTO MEMBRANA/FLEXION
C
      DMATS(1,2) = DMATS(1,2) + DMS11*ZGASP
C
C     FLEXION
C
      DMATS(2,2) = DMATS(2,2) + DMS11*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATS(3,3) = DMATS(3,3) + VISCO*CONST*DZLEN
C
C     M A T R I Z   T A N G E N T E
C
      IF(NALGO.GT.1) GO TO 20
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(KGAUZ),PROPS)
      DENOM = 9.0*EEPRA(KGAUZ)*EEPRA(KGAUZ)
      if(denom.eq.0.0) go to 20
      depsn = eepra(kgauz)*dtime    !---------------------full implicit
      if(depsn.le.1.0e-10) harde = yield/1.0e-10
      FACTO = HARDE*ACOEF*DTIME - 3.0*VISCO
      FACTO = 2.0*FACTO/DENOM*DZLEN
C
C     MEMBRANA
C
      DMT11 = FACTO*8.0*EPSRA(1)*EPSRA(1)
      DMATT(1,1) = DMATT(1,1) + DMT11
C
C     ACOPLAMIENTO MEMBRANA/FLEXION
C
      DMATT(1,2) = DMATT(1,2) + DMT11*ZGASP
C
C     ACOPLAMIENTO MEMBRANA/CORTANTE Y FLEXION/CORTANTE
C
      DMT13 = FACTO*2.0*EPSRA(1)*EPSRA(3)
      DMATT(1,3) = DMATT(1,3) + DMT13
      DMATT(2,3) = DMATT(2,3) + DMT13*ZGASP
C
C     FLEXION
C
      DMATT(2,2) = DMATT(2,2) + DMT11*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATT(3,3) = DMATT(3,3) + FACTO*0.5*EPSRA(3)*EPSRA(3)
20    CONTINUE

      visco = param(1,2)                !-------mid-point
      dmats(3,3) = const*visco*thick    !-------1point int for shear

C
C     COMPLETA LA MATRIZ POR SIMETRIA
C
      DMATS(2,1) = DMATS(1,2)
      DMATT(2,1) = DMATT(1,2)
      DMATT(3,1) = DMATT(1,3)
      DMATT(3,2) = DMATT(2,3)
      RETURN
C
C
C     T I P O   2 :   A X I S I M E T R I C O
C
C
C     SELECCCIONA FORMULACION
C
200   GO TO (210,220), NFORM
      STOP
C
C
C     F O R M U L A C I O N   M E M B R A N A
C
C
210   EPSRA(1) = STNRA(1)
      EPSRA(2) = STNRA(2)
      EPSRA(3) = 0.0
      VISCO = PARAM(1,NMIDZ)
C
C     M A T R I Z   S E C A N T E 
C
      FACT1 = 2.0*VISCO/(1.0-POISS)*THICK
      FACT2 = FACT1*POISS
      DMATS(1,1) = FACT1
      DMATS(2,1) = FACT2
      DMATS(1,2) = FACT2
      DMATS(2,2) = FACT1
C
C     M A T R I Z   T A N G E N T E 
C
      IF(NALGO.GT.1) GO TO 30
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(NMIDZ),PROPS)
      DENOM = 9.0*EEPRA(NMIDZ)*EEPRA(NMIDZ)
      FACTO = HARDE*ACOEF*DTIME - 3.0*VISCO
      FACTO = 2.0*FACTO/DENOM*THICK
      E11 = EPSRA(2) + 2.0*EPSRA(1)
      E22 = EPSRA(1) + 2.0*EPSRA(2)
      E12 = EPSRA(1) + EPSRA(2)
      DMATT(1,1) = FACTO*2.0*E11*E11
      DMATT(1,2) = FACTO*(4.0*E12*E12+2.0*EPSRA(1)*EPSRA(2))
      DMATT(2,2) = FACTO*2.0*E22*E22
      DMATT(2,1) = DMATT(1,2)
30    CONTINUE
C
C     TENSION GENERALIZADA INICIAL DE MEMBRANA
C
      STRIN(1) = HSTRI(1)*THICK
      STRIN(2) = HSTRI(2)*THICK
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
220   KGAUZ = 0
      DO 40 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(3)
      EPSRA(2) = STNRA(2) + ZGASP*STNRA(4)
      EPSRA(3) = STNRA(5)
      VISCO = PARAM(1,KGAUZ)
C
C     M A T R I Z   S E C A N T E
C
C     MEMBRANA
C
      DMS11 = 2.0*VISCO/(1.0-POISS)*DZLEN
      DMS12 = DMS11*POISS
      DMS22 = DMS11
      DMATS(1,1) = DMATS(1,1) + DMS11
      DMATS(1,2) = DMATS(1,2) + DMS12
      DMATS(2,2) = DMATS(2,2) + DMS22
C
C     ACOPLAMIENTO MEMBRANA/FLEXION
C
      DMATS(1,3) = DMATS(1,3) + DMS11*ZGASP
      DMATS(2,3) = DMATS(2,3) + DMS12*ZGASP
      DMATS(1,4) = DMATS(1,4) + DMS12*ZGASP
      DMATS(2,4) = DMATS(2,4) + DMS22*ZGASP
C
C     FLEXION
C
      DMATS(3,3) = DMATS(3,3) + DMS11*ZGASP*ZGASP
      DMATS(3,4) = DMATS(3,4) + DMS12*ZGASP*ZGASP
      DMATS(4,4) = DMATS(4,4) + DMS22*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATS(5,5) = DMATS(5,5) + VISCO*CONST*DZLEN
C
C     M A T R I Z   T A N G E N T E
C
      IF(NALGO.GT.1) GO TO 40
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(KGAUZ),PROPS)
      DENOM = 9.0*EEPRA(KGAUZ)*EEPRA(KGAUZ)
      FACTO = HARDE*ACOEF*DTIME - 3.0*VISCO
      FACTO = 2.0*FACTO/DENOM*DZLEN
      E11 = EPSRA(2) + 2.0*EPSRA(1)
      E22 = EPSRA(1) + 2.0*EPSRA(2)
      E12 = EPSRA(1) + EPSRA(2)
C
C     MEMBRANA
C
      DMT11 = FACTO*2.0*E11*E11
      DMT12 = FACTO*(4.0*E12*E12+2.0*EPSRA(1)*EPSRA(2))
      DMT22 = FACTO*2.0*E22*E22
      DMATT(1,1) = DMATT(1,1) + DMT11
      DMATT(1,2) = DMATT(1,2) + DMT12
      DMATT(2,2) = DMATT(2,2) + DMT22
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATT(1,3) = DMATT(1,3) + DMT11*ZGASP
      DMATT(2,3) = DMATT(2,3) + DMT12*ZGASP
      DMATT(1,4) = DMATT(1,4) + DMT12*ZGASP
      DMATT(2,4) = DMATT(2,4) + DMT22*ZGASP
C
C     ACOPLADA MEMBRANA/CORTANTE Y FLEXION/CORTANTE
C
      DMT15 = FACTO*E11*EPSRA(3)
      DMT25 = FACTO*E22*EPSRA(3)
      DMATT(1,5) = DMATT(1,5) + DMT15 
      DMATT(2,5) = DMATT(2,5) + DMT25
      DMATT(3,5) = DMATT(3,5) + DMT15*ZGASP
      DMATT(4,5) = DMATT(4,5) + DMT25*ZGASP
C
C     FLEXION
C
      DMATT(3,3) = DMATT(3,3) + DMT11*ZGASP*ZGASP
      DMATT(3,4) = DMATT(3,4) + DMT12*ZGASP*ZGASP
      DMATT(4,4) = DMATT(4,4) + DMT22*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATT(5,5) = DMATT(5,5) + FACTO*0.5*EPSRA(3)*EPSRA(3)
40    CONTINUE
C
C     COMPLETA LA MATRIZ CONSTITUTIVA POR SIMETRIA
C
      DO 50 IGSTR = 1,NGSTR
      DO 50 JGSTR = IGSTR,NGSTR
      DMATS(JGSTR,IGSTR) = DMATS(IGSTR,JGSTR)
      DMATT(JGSTR,IGSTR) = DMATT(IGSTR,JGSTR)
50    CONTINUE
      RETURN
      END

      SUBROUTINE DMATT2(STNRA,PARAM,EEPSN,EEPRA,THICK,PROPS,
     1                  DMATX,DMATS,DMATT)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ D TANGENTE PARA EL MODELO 2
C    MODELO VISCOPLASTICO DE VON MISES
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      COMMON /GAUSSZ/ POSZP(5) ,WEIZP(5)
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /NPARAM/ NPARA
      COMMON /MIDZGP/ NMIDZ
      COMMON /MODEL2/ VPCON ,GAMMA ,VPSEN
      COMMON /INISTR/ HSTRI(3) ,STRIN(5)
      DIMENSION
     1   STNRA(      1) ,PARAM(NPARA,1) ,
     2   EEPSN(      1) ,EEPRA(      1) ,
     3   PROPS(      1) ,EPSRA(      3) ,
     4   DMATX(NGSTR,1) ,DMATS(NGSTR,1) ,DMATT(NGSTR,1)
      DATA  CONST/0.8333333333333333/
      POISS = 0.5
C
C     SELECCIONA TIPO DE PROBLEMA
C
      GO TO (100,200), NTYPE
      STOP
C
C
C     T I P O   1 :   D E F O R M A C I O N   P L A N A
C
C
C     SELECCIONA FORMULACION
C
100   GO TO (110,120), NFORM
      STOP
C
C
C     F O R M U L A C I O N   M E M B R A N A
C
C      
110   EPSRA(1) = STNRA(1)
      EPSRA(2) = 0.0
      EPSRA(3) = 0.0
      VISCO = PARAM(1,NMIDZ)
C
C     M A T R I Z   S E C A N T E 
C
      DMATS(1,1) = 2.0*VISCO/(1.0-POISS)*THICK
C
C     M A T R I Z   T A N G E N T E
C
      IF(NALGO.GT.1) GO TO 10
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(NMIDZ),PROPS)
      FACTO = HARDE*ACOEF*DTIME - YIELD/EEPRA(NMIDZ) +
     1   (VPSEN-1.0)*VPCON*EEPRA(NMIDZ)**(VPSEN-1.0)
      DMATT(1,1) = 4.0/3.0*FACTO*THICK
10    CONTINUE
C
C     TENSION GENERALIZADA INICIAL DE MEMBRANA
C
      STRIN(1) = HSTRI(1)*THICK
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
120   KGAUZ = 0
      DO 20 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(2)
      EPSRA(2) = 0.0
      EPSRA(3) = STNRA(3)
      VISCO = PARAM(1,KGAUZ)
C
C     M A T R I Z   S E C A N T E 
C
C     MEMBRANA
C
      DMS11 = 2.0*VISCO/(1.0-POISS)*DZLEN
      DMATS(1,1) = DMATS(1,1) + DMS11
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATS(1,2) = DMATS(1,2) + DMS11*ZGASP
C
C     FLEXION
C
      DMATS(2,2) = DMATS(2,2) + DMS11*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATS(3,3) = DMATS(3,3) + VISCO*CONST*DZLEN
C
C     M A T R I Z   T A N G E N T E
C
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(KGAUZ),PROPS)
      DENOM = 9.0*EEPRA(KGAUZ)*EEPRA(KGAUZ)
      FACTO = HARDE*ACOEF*DTIME - YIELD/EEPRA(KGAUZ) +
     1   (VPSEN-1.0)*VPCON*EEPRA(KGAUZ)**(VPSEN-1.0)
      FACTO = 2.0*FACTO/DENOM*DZLEN
C
C     MEMBRANA
C
      DMT11 = FACTO*8.0*EPSRA(1)*EPSRA(1)
      DMATT(1,1) = DMATT(1,1) + DMT11
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATT(1,2) = DMATT(1,2) + DMT11*ZGASP
C
C     ACOPLADA MEMBRANA/CORTANTE Y FLEXION/CORTANTE
C
      DMT13 = FACTO*2.0*EPSRA(1)*EPSRA(3)
      DMATT(1,3) = DMATT(1,3) + DMT13
      DMATT(2,3) = DMATT(2,3) + DMT13*ZGASP
C
C     FLEXION
C
      DMATT(2,2) = DMATT(2,2) + DMT11*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATT(3,3) = DMATT(3,3) + FACTO*0.5*EPSRA(3)*EPSRA(3)
20    CONTINUE
C
C     COMPLETA LA MATRIZ POR SIMETRIA
C
      DMATS(2,1) = DMATS(1,2)
      DMATT(2,1) = DMATT(1,2)
      DMATT(3,1) = DMATT(1,3)
      DMATT(3,2) = DMATT(2,3)
      RETURN
C
C
C     T I P O   2 :   A X I S I M E T R I C O
C
C
C     SELECCCIONA FORMULACION
C
200   GO TO (210,220), NFORM
      STOP
C
C     F O R M U L A C I O N   M E M B R A N A
C
C
210   EPSRA(1) = STNRA(1)
      EPSRA(2) = STNRA(2)
      EPSRA(3) = 0.0
      VISCO = PARAM(1,NMIDZ)
C
C     M A T R I Z   S E C A N T E 
C
      FACT1 = 2.0*VISCO/(1.0-POISS)*THICK
      FACT2 = FACT1*POISS
      DMATS(1,1) = FACT1
      DMATS(2,1) = FACT2
      DMATS(1,2) = FACT2
      DMATS(2,2) = FACT1
C
C     M A T R I Z   T A N G E N T E 
C
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(NMIDZ),PROPS)
      DENOM = 9.0*EEPRA(NMIDZ)*EEPRA(NMIDZ)
      FACTO = HARDE*ACOEF*DTIME - YIELD/EEPRA(NMIDZ) +
     1   (VPSEN-1.0)*VPCON*EEPRA(NMIDZ)**(VPSEN-1.0)
      FACTO = 2.0*FACTO/DENOM*THICK
      E11 = EPSRA(2) + 2.0*EPSRA(1)
      E22 = EPSRA(1) + 2.0*EPSRA(2)
      E12 = EPSRA(1) + EPSRA(2)
      DMATT(1,1) = FACTO*2.0*E11*E11
      DMATT(1,2) = FACTO*(4.0*E12*E12+2.0*EPSRA(1)*EPSRA(2))
      DMATT(2,2) = FACTO*2.0*E22*E22
      DMATT(2,1) = DMATT(1,2)
C
C     TENSION GENERALIZADA INICIAL DE MEMBRANA
C
      STRIN(1) = HSTRI(1)*THICK
      STRIN(2) = HSTRI(2)*THICK
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
220   KGAUZ = 0
      DO 40 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(3)
      EPSRA(2) = STNRA(2) + ZGASP*STNRA(4)
      EPSRA(3) = STNRA(5)
      VISCO = PARAM(1,KGAUZ)
C
C     M A T R I Z   S E C A N T E 
C
C     MEMBRANA
C
      DMS11 = 2.0*VISCO/(1.0-POISS)*DZLEN
      DMS12 = DMS11*POISS
      DMS22 = DMS11
      DMATS(1,1) = DMATS(1,1) + DMS11
      DMATS(1,2) = DMATS(1,2) + DMS12
      DMATS(2,2) = DMATS(2,2) + DMS22
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATS(1,3) = DMATS(1,3) + DMS11*ZGASP
      DMATS(2,3) = DMATS(2,3) + DMS12*ZGASP
      DMATS(1,4) = DMATS(1,4) + DMS12*ZGASP
      DMATS(2,4) = DMATS(2,4) + DMS22*ZGASP
C
C     FLEXION
C
      DMATS(3,3) = DMATS(3,3) + DMS11*ZGASP*ZGASP
      DMATS(3,4) = DMATS(3,4) + DMS12*ZGASP*ZGASP
      DMATS(4,4) = DMATS(4,4) + DMS22*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATS(5,5) = DMATS(5,5) + VISCO*CONST*DZLEN
C
C     M A T R I Z   T A N G E N T E 
C
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(KGAUZ),PROPS)
      DENOM = 9.0*EEPRA(KGAUZ)*EEPRA(KGAUZ)
      FACTO = HARDE*ACOEF*DTIME - YIELD/EEPRA(KGAUZ) +
     1   (VPSEN-1.0)*VPCON*EEPRA(KGAUZ)**(VPSEN-1.0)
      FACTO = 2.0*FACTO/DENOM*DZLEN
      E11 = EPSRA(2) + 2.0*EPSRA(1)
      E22 = EPSRA(1) + 2.0*EPSRA(2)
      E12 = EPSRA(1) + EPSRA(2)
C
C     MEMBRANA
C
      DMT11 = FACTO*2.0*E11*E11
      DMT12 = FACTO*(4.0*E12*E12+2.0*EPSRA(1)*EPSRA(2))
      DMT22 = FACTO*2.0*E22*E22
      DMATT(1,1) = DMATT(1,1) + DMT11
      DMATT(1,2) = DMATT(1,2) + DMT12
      DMATT(2,2) = DMATT(2,2) + DMT22
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATT(1,3) = DMATT(1,3) + DMT11*ZGASP
      DMATT(2,3) = DMATT(2,3) + DMT12*ZGASP
      DMATT(1,4) = DMATT(1,4) + DMT12*ZGASP
      DMATT(2,4) = DMATT(2,4) + DMT22*ZGASP
C
C     ACOPLADA MEMBRANA/CORTANTE Y FLEXION/CORTANTE
C
      DMT15 = FACTO*E11*EPSRA(3)
      DMT25 = FACTO*E22*EPSRA(3)
      DMATT(1,5) = DMATT(1,5) + DMT15
      DMATT(2,5) = DMATT(2,5) + DMT25
      DMATT(3,5) = DMATT(3,5) + DMT15*ZGASP
      DMATT(4,5) = DMATT(4,5) + DMT25*ZGASP
C
C     FLEXION
C
      DMATT(3,3) = DMATT(3,3) + DMT11*ZGASP*ZGASP
      DMATT(3,4) = DMATT(3,4) + DMT12*ZGASP*ZGASP
      DMATT(4,4) = DMATT(4,4) + DMT22*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATT(5,5) = DMATT(5,5) + FACTO*0.5*EPSRA(3)*EPSRA(3)
40    CONTINUE
C
C     COMPLETA LA MATRIZ CONSTITUTIVA POR SIMETRIA
C
      DO 50 IGSTR = 1,NGSTR
      DO 50 JGSTR = IGSTR,NGSTR
      DMATS(JGSTR,IGSTR) = DMATS(IGSTR,JGSTR)
      DMATT(JGSTR,IGSTR) = DMATT(IGSTR,JGSTR)
50    CONTINUE
      RETURN
      END

      SUBROUTINE DMATT0(STNRA,PARAM,EEPSN,EEPRA,THICK,PROPS,
     1                  DMATX,DMATS,DMATT)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ D TANGENTE PARA UN MODELO VISCOPLASTICO
C    GENERALIZADO DE 2 PARAMETROS (VISCOSIDAD Y COEFICIENTE DE POISSON)
C    SE PUEDE UTILIZAR PARA EL MODELO 2 VISCOPLASTICO DE VON MISES Y
C    PARA EL MODELO 5 ELASTICO NO LINEAL
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      COMMON /GAUSSZ/ POSZP(5) ,WEIZP(5)
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /NPARAM/ NPARA
      COMMON /MIDZGP/ NMIDZ
      COMMON /MODEL2/ VPCON ,GAMMA ,VPSEN
      COMMON /INISTR/ HSTRI(3) ,STRIN(5)
      DIMENSION
     1   STNRA(      1) ,PARAM(NPARA,1) ,
     2   EEPSN(      1) ,EEPRA(      1) ,
     3   PROPS(      1) ,EPSRA(      3) ,
     4   DMATX(NGSTR,1) ,DMATS(NGSTR,1) ,DMATT(NGSTR,1) ,
     5   DERD1(  3,  3) ,DEREF(      3)
      DATA  CONST/0.8333333333333333/
C
C     CALCULA LA DERIVADA DE LA MATRIZ D CON RESPECTO A LA 
C     VISCOSIDAD
C
      DERD1(1,1) = 2.0/(1.0-POISS)
      DERD1(2,1) = 2.0/(1.0-POISS)*POISS
      DERD1(3,1) = 0.0
      DERD1(1,2) = DERD1(2,1)
      DERD1(2,2) = DERD1(1,1)
      DERD1(3,2) = 0.0
      DERD1(1,3) = 0.0
      DERD1(2,3) = 0.0
      DERD1(3,3) = 1.0
C
C     SELECCIONA TIPO DE PROBLEMA
C
      GO TO (100,200), NTYPE
      STOP
C
C
C     T I P O   1 :   D E F O R M A C I O N   P L A N A
C
C
C     SELECCIONA FORMULACION
C
100   GO TO (110,120), NFORM
      STOP
C
C
C     F O R M U L A C I O N   M E M B R A N A
C
C      
110   EPSRA(1) = STNRA(1)
      EPSRA(2) = 0.0
      EPSRA(3) = 0.0
      VISCO = PARAM(1,NMIDZ)
C
C     M A T R I Z   S E C A N T E 
C
      DMATS(1,1) = 2.0*VISCO/(1.0-POISS)*THICK
C
C     M A T R I Z   T A N G E N T E
C
      IF(NALGO.GT.1) GO TO 10
C
C     CALCULA LA DERIVADA DE LA VISCOSIDAD CON RESPECTO A LA
C     VELOCIDAD DE DEFORMACION EFECTIVA
C
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(NMIDZ),PROPS)
      DERVE = (HARDE*ACOEF*DTIME - YIELD/EEPRA(NMIDZ) +
     1   (VPSEN-1.0)*VPCON*EEPRA(NMIDZ)**(VPSEN-1.0))/
     2   (3.0*EEPRA(NMIDZ))
C
C     CALCULA LA DERIVADA DE LA VELOCIDAD DE DEFORMACION EFECTIVA 
C     CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
      DEREF(1) = 2.0/(3.0*EEPRA(NMIDZ))*
     1   (EPSRA(1)*(1.0+(POISS/(1.0-POISS))**2) +
     2    EPSRA(2)*     (POISS/(1.0-POISS))**2)
C
C     MATRIZ DE MEMBRANA TANGENTE
C
      DMATT(1,1) = DERD1(1,1)*EPSRA(1)*DEREF(1)*DERVE*THICK
10    CONTINUE
C
C     TENSION GENERALIZADA INICIAL DE MEMBRANA
C
      STRIN(1) = HSTRI(1)*THICK
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
120   KGAUZ = 0
      DO 20 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(2)
      EPSRA(2) = 0.0
      EPSRA(3) = STNRA(3)
      VISCO = PARAM(1,KGAUZ)
C
C     M A T R I Z   S E C A N T E
C
C     MEMBRANA
C
      DMS11 = 2.0*VISCO/(1.0-POISS)*DZLEN
      DMATS(1,1) = DMATS(1,1) + DMS11
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATS(1,2) = DMATS(1,2) + DMS11*ZGASP
C
C     FLEXION
C
      DMATS(2,2) = DMATS(2,2) + DMS11*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATS(3,3) = DMATS(3,3) + VISCO*CONST*DZLEN
C
C     M A T R I Z   T A N G E N T E
C
      IF(NALGO.GT.1) GO TO 20
C
C     CALCULA LA DERIVADA DE LA VISCOSIDAD CON RESPECTO A LA
C     VELOCIDAD DE DEFORMACION EFECTIVA
C
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(KGAUZ),PROPS)
      DERVE = (HARDE*ACOEF*DTIME - YIELD/EEPRA(KGAUZ) +
     1   (VPSEN-1.0)*VPCON*EEPRA(KGAUZ)**(VPSEN-1.0))/
     2   (3.0*EEPRA(KGAUZ))
C
C     CALCULA LA DERIVADA DE LA VELOCIDAD DE DEFORMACION EFECTIVA 
C     CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
      DEREF(1) = 2.0/(3.0*EEPRA(KGAUZ))*
     1   (EPSRA(1)*(1.0+(POISS/(1.0-POISS))**2) +
     2    EPSRA(2)*     (POISS/(1.0-POISS))**2)
      DEREF(2) = 0.0
      DEREF(3) = 1.0/(3.0*EEPRA(KGAUZ))*EPSRA(3)
C
C     MEMBRANA
C
      DMT11 = (DERD1(1,1)*EPSRA(1)*DEREF(1) +
     1         DERD1(1,2)*EPSRA(2)*DEREF(1))*DERVE*DZLEN
      DMATT(1,1) = DMATT(1,1) + DMT11
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATT(1,2) = DMATT(1,2) + DMT11*ZGASP
C
C     ACOPLADA MEMBRANA/CORTANTE Y FLEXION/CORTANTE
C
      DMT13 = (DERD1(1,1)*EPSRA(1)*DEREF(3) +
     1         DERD1(1,2)*EPSRA(2)*DEREF(3))*DERVE*DZLEN
      DMATT(1,3) = DMATT(1,3) + DMT13
      DMATT(2,3) = DMATT(2,3) + DMT13*ZGASP
C
C     FLEXION
C
      DMATT(2,2) = DMATT(2,2) + DMT11*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATT(3,3) = DMATT(3,3) + 
     1   DERD1(3,3)*EPSRA(3)*DEREF(3)*DERVE*DZLEN
20    CONTINUE
C
C     COMPLETA LA MATRIZ POR SIMETRIA
C
      DMATS(2,1) = DMATS(1,2)
      DMATT(2,1) = DMATT(1,2)
      DMATT(3,1) = DMATT(1,3)
      DMATT(3,2) = DMATT(2,3)
      RETURN
C
C
C     T I P O   2 :   A X I S I M E T R I C O
C
C
C     SELECCCIONA FORMULACION
C
200   GO TO (210,220), NFORM
      STOP
C
C
C     F O R M U L A C I O N   M E M B R A N A
C
C
210   EPSRA(1) = STNRA(1)
      EPSRA(2) = STNRA(2)
      EPSRA(3) = 0.0
      VISCO = PARAM(1,NMIDZ)
C
C     M A T R I Z   S E C A N T E
C
      FACT1 = 2.0*VISCO/(1.0-POISS)*THICK
      FACT2 = FACT1*POISS
      DMATS(1,1) = FACT1
      DMATS(2,1) = FACT2
      DMATS(1,2) = FACT2
      DMATS(2,2) = FACT1
C
C     M A T R I Z   T A N G E N T E
C
      IF(NALGO.GT.1) GO TO 30
C
C     CALCULA LA DERIVADA DE LA VISCOSIDAD CON RESPECTO A LA
C     VELOCIDAD DE DEFORMACION EFECTIVA
C
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(NMIDZ),PROPS)
      DERVE = (HARDE*ACOEF*DTIME - YIELD/EEPRA(NMIDZ) +
     1   (VPSEN-1.0)*VPCON*EEPRA(NMIDZ)**(VPSEN-1.0))/
     2   (3.0*EEPRA(NMIDZ))
C
C     CALCULA LA DERIVADA DE LA VELOCIDAD DE DEFORMACION EFECTIVA 
C     CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
      DEREF(1) = 2.0/(3.0*EEPRA(NMIDZ))*
     1   (EPSRA(1)*(1.0+(POISS/(1.0-POISS))**2) +
     2    EPSRA(2)*     (POISS/(1.0-POISS))**2)
      DEREF(2) = 2.0/(3.0*EEPRA(NMIDZ))*
     1   (EPSRA(1)*(    (POISS/(1.0-POISS))**2) +
     2    EPSRA(2)*(1.0+(POISS/(1.0-POISS))**2))
      DEREF(3) = 1.0/(3.0*EEPRA(NMIDZ))*EPSRA(3)
C
C     MATRIZ DE MEMBRANA TANGENTE
C
      DMATT(1,1) = (DERD1(1,1)*EPSRA(1)*DEREF(1) +
     1              DERD1(1,2)*EPSRA(2)*DEREF(1))*DERVE*THICK
      DMATT(1,2) = (DERD1(1,1)*EPSRA(1)*DEREF(2) +
     1              DERD1(1,2)*EPSRA(2)*DEREF(2))*DERVE*THICK
      DMATT(2,2) = (DERD1(2,1)*EPSRA(1)*DEREF(2) +
     1              DERD1(2,2)*EPSRA(2)*DEREF(2))*DERVE*THICK
      DMATT(2,1) = DMATT(1,2)
30    CONTINUE
C
C     TENSION GENERALIZADA INICIAL DE MEMBRANA
C
      STRIN(1) = HSTRI(1)*THICK
      STRIN(2) = HSTRI(2)*THICK
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
220   KGAUZ = 0
      DO 40 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(3)
      EPSRA(2) = STNRA(2) + ZGASP*STNRA(4)
      EPSRA(3) = STNRA(5)
      VISCO = PARAM(1,KGAUZ)
C
C     M A T R I Z   S E C A N T E
C
C     MEMBRANA
C
      DMS11 = 2.0*VISCO/(1.0-POISS)*DZLEN
      DMS12 = DMS11*POISS
      DMS22 = DMS11
      DMATS(1,1) = DMATS(1,1) + DMS11
      DMATS(1,2) = DMATS(1,2) + DMS12
      DMATS(2,2) = DMATS(2,2) + DMS22
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATS(1,3) = DMATS(1,3) + DMS11*ZGASP
      DMATS(2,3) = DMATS(2,3) + DMS12*ZGASP
      DMATS(1,4) = DMATS(1,4) + DMS12*ZGASP
      DMATS(2,4) = DMATS(2,4) + DMS22*ZGASP
C
C     FLEXION
C
      DMATS(3,3) = DMATS(3,3) + DMS11*ZGASP*ZGASP
      DMATS(3,4) = DMATS(3,4) + DMS12*ZGASP*ZGASP
      DMATS(4,4) = DMATS(4,4) + DMS22*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATS(5,5) = DMATS(5,5) + VISCO*CONST*DZLEN
C
C     M A T R I Z   T A N G E N T E
C
      IF(NALGO.GT.1) GO TO 40
C
C     CALCULA LA DERIVADA DE LA VISCOSIDAD CON RESPECTO A LA
C     VELOCIDAD DE DEFORMACION EFECTIVA
C
      CALL YIELDF(YIELD,HARDE,NHARD,EEPSN(KGAUZ),PROPS)
      DERVE = (HARDE*ACOEF*DTIME - YIELD/EEPRA(KGAUZ) +
     1   (VPSEN-1.0)*VPCON*EEPRA(KGAUZ)**(VPSEN-1.0))/
     2   (3.0*EEPRA(KGAUZ))
C
C     CALCULA LA DERIVADA DE LA VELOCIDAD DE DEFORMACION EFECTIVA 
C     CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
      DEREF(1) = 2.0/(3.0*EEPRA(KGAUZ))*
     1   (EPSRA(1)*(1.0+(POISS/(1.0-POISS))**2) +
     2    EPSRA(2)*     (POISS/(1.0-POISS))**2)
      DEREF(2) = 2.0/(3.0*EEPRA(KGAUZ))*
     1   (EPSRA(1)*(    (POISS/(1.0-POISS))**2) +
     2    EPSRA(2)*(1.0+(POISS/(1.0-POISS))**2))
      DEREF(3) = 1.0/(3.0*EEPRA(KGAUZ))*EPSRA(3)
C
C     MEMBRANA
C
      DMT11 = (DERD1(1,1)*EPSRA(1)*DEREF(1) +
     1         DERD1(1,2)*EPSRA(2)*DEREF(1))*DERVE*DZLEN
      DMT12 = (DERD1(1,1)*EPSRA(1)*DEREF(2) +
     1         DERD1(1,2)*EPSRA(2)*DEREF(2))*DERVE*DZLEN
      DMT22 = (DERD1(2,1)*EPSRA(1)*DEREF(2) +
     1         DERD1(2,2)*EPSRA(2)*DEREF(2))*DERVE*DZLEN
      DMATT(1,1) = DMATT(1,1) + DMT11
      DMATT(1,2) = DMATT(1,2) + DMT12
      DMATT(2,2) = DMATT(2,2) + DMT22
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATT(1,3) = DMATT(1,3) + DMT11*ZGASP
      DMATT(2,3) = DMATT(2,3) + DMT12*ZGASP
      DMATT(1,4) = DMATT(1,4) + DMT12*ZGASP
      DMATT(2,4) = DMATT(2,4) + DMT22*ZGASP
C
C     ACOPLADA MEMBRANA/CORTANTE Y FLEXION/CORTANTE
C
      DMT15 = (DERD1(1,1)*EPSRA(1)*DEREF(3) +
     1         DERD1(1,2)*EPSRA(2)*DEREF(3))*DERVE*DZLEN
      DMT25 = (DERD1(2,1)*EPSRA(1)*DEREF(3) +
     1         DERD1(2,2)*EPSRA(2)*DEREF(3))*DERVE*DZLEN
      DMATT(1,5) = DMATT(1,5) + DMT15
      DMATT(2,5) = DMATT(2,5) + DMT25
      DMATT(3,5) = DMATT(3,5) + DMT15*ZGASP
      DMATT(4,5) = DMATT(4,5) + DMT25*ZGASP
C
C     FLEXION
C
      DMATT(3,3) = DMATT(3,3) + DMT11*ZGASP*ZGASP
      DMATT(3,4) = DMATT(3,4) + DMT12*ZGASP*ZGASP
      DMATT(4,4) = DMATT(4,4) + DMT22*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATT(5,5) = DMATT(5,5) + 
     1   DERD1(3,3)*EPSRA(3)*DEREF(3)*DERVE*DZLEN
40    CONTINUE
C
C     COMPLETA LA MATRIZ CONSTITUTIVA POR SIMETRIA
C
      DO 50 IGSTR = 1,NGSTR
      DO 50 JGSTR = IGSTR,NGSTR
      DMATS(JGSTR,IGSTR) = DMATS(IGSTR,JGSTR)
      DMATT(JGSTR,IGSTR) = DMATT(IGSTR,JGSTR)
50    CONTINUE
      RETURN
      END

      SUBROUTINE DMATT3
      RETURN
      END

      SUBROUTINE DMATT4(STNRA,PARAM,EEPSN,EEPRA,THICK,PROPS,
     1                  EEPRI,EEPSI,VOIDS,VOIDI,VOIRA,VOIRI,
     2                  DMATX,DMATS,DMATT)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ D TANGENTE EL MODELO 4
C    MODELO VISCOPLASTICO CON DEGRADACION DE GURSON
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      COMMON /GAUSSZ/ POSZP(5) ,WEIZP(5)
      COMMON /PARAMM/ VISCO ,POISS
      COMMON /NPARAM/ NPARA
      COMMON /MIDZGP/ NMIDZ
      COMMON /MODEL2/ VPCON ,GAMMA ,VPSEN
      COMMON /INISTR/ HSTRI(3) ,STRIN(5)
      DIMENSION
     1   STNRA(      1) ,PARAM(NPARA,1) ,
     2   EEPSN(      1) ,EEPRA(      1) ,
     3   PROPS(      1) ,EPSRA(      3) ,
     4   DMATX(NGSTR,1) ,DMATS(NGSTR,1) ,DMATT(NGSTR,1) ,
     5   DERD1(  3,  3) ,DERD2(  3,  3) ,
     6   DERVI(      3) ,DERPO(      3) 
      DATA  CONST/0.8333333333333333/
C
C     SELECCIONA TIPO DE PROBLEMA
C
      GO TO (100,200), NTYPE
      STOP
C
C
C     T I P O   1 :   D E F O R M A C I O N   P L A N A
C
C
C     SELECCIONA FORMULACION
C
100   GO TO (110,120), NFORM
      STOP
C
C
C     F O R M U L A C I O N   M E M B R A N A
C
C      
110   EPSRA(1) = STNRA(1)
      EPSRA(2) = 0.0
      EPSRA(3) = 0.0
      VISCO = PARAM(1,NMIDZ)
      POISS = PARAM(2,NMIDZ)
C
C     M A T R I Z   S E C A N T E
C
      DMATS(1,1) = 2.0*VISCO/(1.0-POISS)*THICK
C
C     M A T R I Z   T A N G E N T E 
C
      IF(NALGO.GT.1) GO TO 10
C
C     CALCULA LA DERIVADA DE LA MATRIZ CONSTITUTIVA CON RESPECTO A LA 
C     VISCOSIDAD Y AL COEFICIENTE DE POISSON
C
      CALL DERDPA(DERD1 ,DERD2 ,1 ,1)
C
C     CALCULA LAS DERIVADAS DE LA VISCOSIDAD Y DEL COEFICIENTE DE POISSON
C     CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
      CALL DERPAR(EPSRA ,EEPRA ,EEPRI ,EEPSN ,EEPSI ,PROPS ,
     1            VOIDS ,VOIDI ,VOIRA ,VOIRI ,DERVI ,DERPO )
C
C     MATRIZ DE MEMBRANA TANGENTE
C
      DMATT(1,1) = (DERD1(1,1)*EPSRA(1)*DERVI(1) +
     1              DERD2(1,1)*EPSRA(1)*DERPO(1))*THICK
10    CONTINUE
C
C     TENSION GENERALIZADA INICIAL DE MEMBRANA
C
      STRIN(1) = HSTRI(1)*THICK
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
120   KGAUZ = 0
      DO 20 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(2)
      EPSRA(2) = 0.0
      EPSRA(3) = STNRA(3)
      VISCO = PARAM(1,KGAUZ)
      POISS = PARAM(2,KGAUZ)
C
C     M A T R I Z   S E C A N T E
C
C     MEMBRANA
C
      DMS11 = 2.0*VISCO/(1.0-POISS)*DZLEN
      DMATS(1,1) = DMATS(1,1) + DMS11
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATS(1,2) = DMATS(1,2) + DMS11*ZGASP
C
C     FLEXION
C
      DMATS(2,2) = DMATS(2,2) + DMS11*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATS(3,3) = DMATS(3,3) + VISCO*CONST*DZLEN
C
C     M A T R I Z   T A N G E N T E
C
      IF(NALGO.GT.1) GO TO 20
C
C     CALCULA LA DERIVADA DE LA MATRIZ CONSTITUTIVA CON RESPECTO A LA 
C     VISCOSIDAD Y AL COEFICIENTE DE POISSON
C
      CALL DERDPA(DERD1 ,DERD2 ,1 ,1)
C
C     CALCULA LAS DERIVADAS DE LA VISCOSIDAD Y DEL COEFICIENTE DE POISSON
C     CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
      CALL DERPAR(EPSRA ,EEPRA ,EEPRI ,EEPSN ,EEPSI ,PROPS ,
     1            VOIDS ,VOIDI ,VOIRA ,VOIRI ,DERVI ,DERPO )
C
C     MEMBRANA
C
      DMT11 = (DERD1(1,1)*EPSRA(1)*DERVI(1) +
     1         DERD1(1,2)*EPSRA(2)*DERVI(1) +
     2         DERD2(1,1)*EPSRA(1)*DERPO(1) +
     3         DERD2(1,2)*EPSRA(2)*DERPO(1))*DZLEN
      DMATT(1,1) = DMATT(1,1) + DMT11 
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATT(1,2) = DMATT(1,2) + DMT11*ZGASP
C
C     ACOPLADA MEMBRANA/CORTANTE Y FLEXION/CORTANTE
C
      DMT13 = (DERD1(1,1)*EPSRA(1)*DERVI(3) +
     1         DERD1(1,2)*EPSRA(2)*DERVI(3) +
     2         DERD2(1,1)*EPSRA(1)*DERPO(3) +
     1         DERD2(1,2)*EPSRA(2)*DERPO(3))*DZLEN
      DMATT(1,3) = DMATT(1,3) + DMT13
      DMATT(2,3) = DMATT(2,3) + DMT13*ZGASP
C
C     FLEXION
C
      DMATT(2,2) = DMATT(2,2) + DMT11*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATT(3,3) = DMATT(3,3) + DERD1(3,3)*EPSRA(3)*DERVI(3)*DZLEN
20    CONTINUE
C
C     COMPLETA LA MATRIZ POR SIMETRIA
C
      DMATS(2,1) = DMATS(1,2)
      DMATT(2,1) = DMATT(1,2)
      DMATT(3,1) = DMATT(1,3)
      DMATT(3,2) = DMATT(2,3)
      RETURN
C
C
C     T I P O   2 :   A X I S I M E T R I C O
C
C
C     SELECCCIONA FORMULACION
C
200   GO TO (210,220), NFORM
      STOP
C
C
C     F O R M U L A C I O N   M E M B R A N A
C
C
210   EPSRA(1) = STNRA(1)
      EPSRA(2) = STNRA(2)
      EPSRA(3) = 0.0
      VISCO = PARAM(1,NMIDZ)
      POISS = PARAM(2,NMIDZ)
C
C     M A T R I Z   S E C A N T E
C
      FACT1 = 2.0*VISCO/(1.0-POISS)*THICK
      FACT2 = FACT1*POISS
      DMATS(1,1) = FACT1
      DMATS(2,1) = FACT2
      DMATS(1,2) = FACT2
      DMATS(2,2) = FACT1
C
C     M A T R I Z   T A N G E N T E
C 
      IF(NALGO.GT.1) GO TO 30
C
C     CALCULA LA DERIVADA DE LA MATRIZ CONSTITUTIVA CON RESPECTO A LA 
C     VISCOSIDAD Y AL COEFICIENTE DE POISSON
C
      CALL DERDPA(DERD1 ,DERD2 ,1 ,1)
C
C     CALCULA LAS DERIVADAS DE LA VISCOSIDAD Y DEL COEFICIENTE DE POISSON
C     CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
      CALL DERPAR(EPSRA ,EEPRA ,EEPRI ,EEPSN ,EEPSI ,PROPS ,
     1            VOIDS ,VOIDI ,VOIRA ,VOIRI ,DERVI ,DERPO )
C
C     MATRIZ DE MEMBRANA TANGENTE
C
      DMATT(1,1) = (DERD1(1,1)*EPSRA(1)*DERVI(1) +
     1              DERD1(1,2)*EPSRA(2)*DERVI(1) +
     2              DERD2(1,1)*EPSRA(1)*DERPO(1) +
     3              DERD2(1,2)*EPSRA(2)*DERPO(1))*THICK
      DMATT(1,2) = (DERD1(1,1)*EPSRA(1)*DERVI(2) +
     1              DERD1(1,2)*EPSRA(2)*DERVI(2) +
     2              DERD2(1,1)*EPSRA(1)*DERPO(2) +
     3              DERD2(1,2)*EPSRA(2)*DERPO(2))*THICK
      DMATT(2,2) = (DERD1(2,1)*EPSRA(1)*DERVI(2) +
     1              DERD1(2,2)*EPSRA(2)*DERVI(2) +
     2              DERD2(2,1)*EPSRA(1)*DERPO(2) +
     3              DERD2(2,2)*EPSRA(2)*DERPO(2))*THICK
      DMATT(2,1) = DMATT(1,2)
30    CONTINUE
C
C     TENSION GENERALIZADA INICIAL DE MEMBRANA
C
      STRIN(1) = HSTRI(1)*THICK
      STRIN(2) = HSTRI(2)*THICK
      RETURN
C
C
C     F O R M U L A C I O N   C O M P L E T A  
C     M E M B R A N A / F L E X I O N / C O R T A N T E
C
C
220   KGAUZ = 0
      DO 40 IGAUZ = 1,NGAUZ
      KGAUZ = KGAUZ + 1
      ETAZP = POSZP(IGAUZ)
      DZLEN = 0.5*THICK*WEIZP(IGAUZ)
      ZGASP = 0.5*THICK*ETAZP
      EPSRA(1) = STNRA(1) + ZGASP*STNRA(3)
      EPSRA(2) = STNRA(2) + ZGASP*STNRA(4)
      EPSRA(3) = STNRA(5)
      VISCO = PARAM(1,KGAUZ)
      POISS = PARAM(2,KGAUZ)
C
C     M A T R I Z   S E C A N T E
C
C     MEMBRANA
C
      DMS11 = 2.0*VISCO/(1.0-POISS)*DZLEN
      DMS12 = DMS11*POISS
      DMS22 = DMS11
      DMATS(1,1) = DMATS(1,1) + DMS11
      DMATS(1,2) = DMATS(1,2) + DMS12
      DMATS(2,2) = DMATS(2,2) + DMS22
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATS(1,3) = DMATS(1,3) + DMS11*ZGASP
      DMATS(2,3) = DMATS(2,3) + DMS12*ZGASP
      DMATS(1,4) = DMATS(1,4) + DMS12*ZGASP
      DMATS(2,4) = DMATS(2,4) + DMS22*ZGASP
C
C     FLEXION
C
      DMATS(3,3) = DMATS(3,3) + DMS11*ZGASP*ZGASP
      DMATS(3,4) = DMATS(3,4) + DMS12*ZGASP*ZGASP
      DMATS(4,4) = DMATS(4,4) + DMS22*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATS(5,5) = DMATS(5,5) + VISCO*CONST*DZLEN
C
C     M A T R I Z   T A N G E N T E
C
      IF(NALGO.GT.1) GO TO 40
C
C     CALCULA LA DERIVADA DE LA MATRIZ CONSTITUTIVA CON RESPECTO A LA 
C     VISCOSIDAD Y AL COEFICIENTE DE POISSON
C
      CALL DERDPA(DERD1 ,DERD2 ,1 ,1)
C
C     CALCULA LAS DERIVADAS DE LA VISCOSIDAD Y DEL COEFICIENTE DE POISSON
C     CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
      CALL DERPAR(EPSRA ,EEPRA ,EEPRI ,EEPSN ,EEPSI ,PROPS ,
     1            VOIDS ,VOIDI ,VOIRA ,VOIRI ,DERVI ,DERPO )
C
C     MEMBRANA
C
      DMT11 = (DERD1(1,1)*EPSRA(1)*DERVI(1) +
     1         DERD1(1,2)*EPSRA(2)*DERVI(1) +
     2         DERD2(1,1)*EPSRA(1)*DERPO(1) +
     3         DERD2(1,2)*EPSRA(2)*DERPO(1))*DZLEN
      DMT12 = (DERD1(1,1)*EPSRA(1)*DERVI(2) +
     1         DERD1(1,2)*EPSRA(2)*DERVI(2) +
     2         DERD2(1,1)*EPSRA(1)*DERPO(2) +
     3         DERD2(1,2)*EPSRA(2)*DERPO(2))*DZLEN
      DMT22 = (DERD1(2,1)*EPSRA(1)*DERVI(2) +
     1         DERD1(2,2)*EPSRA(2)*DERVI(2) +
     2         DERD2(2,1)*EPSRA(1)*DERPO(2) +
     3         DERD2(2,2)*EPSRA(2)*DERPO(2))*DZLEN
      DMATT(1,1) = DMATT(1,1) + DMT11
      DMATT(1,2) = DMATT(1,2) + DMT12
      DMATT(2,2) = DMATT(2,2) + DMT22
C
C     ACOPLADA MEMBRANA/FLEXION
C
      DMATT(1,3) = DMATT(1,3) + DMT11*ZGASP
      DMATT(2,3) = DMATT(2,3) + DMT12*ZGASP
      DMATT(1,4) = DMATT(1,4) + DMT12*ZGASP
      DMATT(2,4) = DMATT(2,4) + DMT22*ZGASP
C
C     ACOPLADA MEMBRANA/CORTANTE Y FLEXION/CORTANTE
C
      DMT15 = (DERD1(1,1)*EPSRA(1)*DERVI(3) +
     1         DERD1(1,2)*EPSRA(2)*DERVI(3) +
     2         DERD2(1,1)*EPSRA(1)*DERPO(3) +
     3         DERD2(1,2)*EPSRA(2)*DERPO(3))*DZLEN
      DMT25 = (DERD1(2,1)*EPSRA(1)*DERVI(3) +
     1         DERD1(2,2)*EPSRA(2)*DERVI(3) +
     2         DERD2(2,1)*EPSRA(1)*DERPO(3) +
     3         DERD2(2,2)*EPSRA(2)*DERPO(3))*DZLEN
      DMATT(1,5) = DMATT(1,5) + DMT15
      DMATT(2,5) = DMATT(2,5) + DMT25
      DMATT(3,5) = DMATT(3,5) + DMT15*ZGASP
      DMATT(4,5) = DMATT(4,5) + DMT25*ZGASP
C
C     FLEXION
C
      DMATT(3,3) = DMATT(3,3) + DMT11*ZGASP*ZGASP
      DMATT(3,4) = DMATT(3,4) + DMT12*ZGASP*ZGASP
      DMATT(4,4) = DMATT(4,4) + DMT22*ZGASP*ZGASP
C
C     CORTANTE
C
      DMATT(5,5) = DMATT(5,5) + DERD1(3,3)*EPSRA(3)*DERVI(3)*DZLEN
40    CONTINUE
C
C     COMPLETA LA MATRIZ CONSTITUTIVA POR SIMETRIA
C
      DO 50 IGSTR = 1,NGSTR
      DO 50 JGSTR = IGSTR,NGSTR
      DMATS(JGSTR,IGSTR) = DMATS(IGSTR,JGSTR)
      DMATT(JGSTR,IGSTR) = DMATT(IGSTR,JGSTR)
50    CONTINUE
      RETURN
      END

      SUBROUTINE DERDPA(DERD1,DERD2,IDER1,IDER2)
C*******************************************************************************
C
C*** CALCULA LA DERIVADA DE LA MATRIZ CONSTITUTIVA CON RESPECTO A
C    LA VISCOSIDAD Y/O EL COEFICIENTE DE POISSON
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /PARAMM/ VISCO ,POISS
      DIMENSION  DERD1(3,3) ,DERD2(3,3)
C
C     CALCULA LA DERIVADA DE LA MATRIZ CONSTITUTIVA CON RESPECTO A LA 
C     VISCOSIDAD
C
      IF(IDER1.EQ.0) GO TO 10
      DERD1(1,1) = 2.0/(1.0-POISS)
      DERD1(2,1) = 2.0/(1.0-POISS)*POISS
      DERD1(3,1) = 0.0
      DERD1(1,2) = DERD1(2,1)
      DERD1(2,2) = DERD1(1,1)
      DERD1(3,2) = 0.0
      DERD1(1,3) = 0.0
      DERD1(2,3) = 0.0
      DERD1(3,3) = 1.0
C
C     CALCULA LA DERIVADA DE LA MATRIZ CONSTITUTIVA CON RESPECTO AL
C     COEFICIENTE DE POISSON
C
10    IF(IDER2.EQ.0) RETURN
      DERD2(1,1) = 2.0*VISCO/(1.0-POISS)**2
      DERD2(2,1) = DERD2(1,1)
      DERD2(3,1) = 0.0
      DERD2(1,2) = DERD2(1,1)
      DERD2(2,2) = DERD2(1,1)
      DERD2(3,2) = 0.0
      DERD2(1,3) = 0.0
      DERD2(2,3) = 0.0
      DERD2(3,3) = 0.0
      RETURN
      END

      SUBROUTINE DERPAR(EPSRA,EEPRA,EEPRI,EEPSN,EEPSI,PROPS,
     1                  VOIDS,VOIDI,VOIRA,VOIRI,DERVI,DERPO)
C*******************************************************************************
C
C*** CALCULA LAS DERIVADAS DE LA VISCOSIDAD Y DEL COEFICIENTE DE POISSON
C    CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /GRADS / GRADM(2,2) ,RESIV(2)
      DATA  NITER /20/
C
C     CALCULA DE FORMA ITERATIVA LAS DERIVADAS DE LA VISCOSIDAD Y DEL
C     COEFICIENTE DE POISSON CON RESPECTO A LA VELOCIDAD DE DEFORMACION
C
      DO 10 ITERA = 1,NITER
C
C     CALCULA VARIABLES INTERNAS
C
      CALL SETVAR(EPSRA ,EEPRA ,EEPRI ,EEPSN ,EEPSI ,PROPS ,
     1            VOIDS ,VOIDI ,VOIRA ,VOIRI )
C
C     FORMA LA MATRIZ DEL SISTEMA
C
      IF(MODEL.EQ.3) CALL SETSY1(VOIDS)
      IF(MODEL.EQ.4) CALL SETSY2(VOIDS)
C
C     CALCULA LAS DERIVADAS DE LAS FUNCIONES CON RESPECTO A LA 
C     VELOCIDAD DE DEFORMACION (RHS)
C
      CALL DERFPA
      CALL SETSOL(VERR  ,PERR  ,VTOL  ,PTOL  ,NCHK2 )
10    CONTINUE
      RETURN
      END

      SUBROUTINE DERFPA
C*******************************************************************************
C
C*** CALCULA LA DERIVADA DE LAS FUNCIONES PARAMETRO CON RESPECTO A
C    LA VELOCIDAD DE DEFORMACION
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      RETURN
      END

      SUBROUTINE ADDMAT(DMATX,DMATS,DMATT)
C*******************************************************************************
C
C*** SUMA LAS MATRICES D SECANTE Y TANGENTE
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      DIMENSION
     1   DMATX(NGSTR,    1) ,DMATS(NGSTR,    1) ,DMATT(NGSTR,    1)
C
C     SUMA LAS MATRICES DMATS Y DMATT 
C
      IALGO = 1
      IF(NALGO.GT.1) IALGO = 0
      DO 10 IGSTR = 1,NGSTR
      DO 10 JGSTR = 1,NGSTR
      DMATX(JGSTR,IGSTR) = 
     1   DMATS(JGSTR,IGSTR) + IALGO*DMATT(JGSTR,IGSTR)
10    CONTINUE
      RETURN
      END

      SUBROUTINE DBMATX(DMATX,BMATX,DBMAT)
C*******************************************************************************
C
C*** CALCULA EL PRODUCTO D*B
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      DIMENSION
     1   DMATX(NGSTR,    1) ,BMATX(NGSTR,    1) ,DBMAT(NGSTR,    1)
C
C     MULTIPLICA D*B
C
      DO 10 IGSTR = 1,NGSTR
      DO 10 IEVAB = 1,NEVAB
      DBMAT(IGSTR,IEVAB) = 0.0
      DO 10 JGSTR = 1,NGSTR
      DBMAT(IGSTR,IEVAB) = DBMAT(IGSTR,IEVAB) + 
     1   DMATX(IGSTR,JGSTR)*BMATX(JGSTR,IEVAB)
10    CONTINUE
      RETURN
      END

      SUBROUTINE STIFIS(ESTIF,DERIB,STRES)
C*******************************************************************************
C
C*** CALCULA LA MATRIZ DE RIGIDEZ DE TENSIONES INICIALES
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      COMMON /DERIVA/ DERNI(2,2,2) ,DERDN(2,2,2) ,DERCS(2,2) ,
     1                DERSN( 2, 2) ,DERAN( 2, 2)
      COMMON /INISTR/ HSTRI(3) ,STRIN(5)
      DIMENSION
     1   DERIB(NGSTR,NEVAB,1) ,ESTIF(1) ,STRES(1) 
      IF(NALGO.GT.2) RETURN
C
C     FORMA LA MATRIZ DE RIGIDEZ DE TENSIONES INICIALES
C
      KSTIF = 0
      DO 10 IEVAB = 1,NEVAB
      DO 10 JEVAB = IEVAB,NEVAB
      KSTIF = KSTIF + 1
      DO 10 IGSTR = 1,NGSTR
      ESTIF(KSTIF) = ESTIF(KSTIF) +
     1   DERIB(IGSTR,IEVAB,JEVAB)*(STRES(IGSTR)+STRIN(IGSTR))*DAREA
10    CONTINUE
      RETURN
      END
 
      SUBROUTINE DERIVB(DERIB)
C*******************************************************************************
C
C*** CALCULA LA DERIVADA DE LA MATRIZ B CON RESPECTO A LAS 
C    VELOCIDADES DE LOS NODOS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      COMMON /ELGAUS/ DAREA ,DJACB ,RADUS ,ANGLE
      COMMON /DERIVA/ DERNI(2,2,2) ,DERDN(2,2,2) ,DERCS(2,2) ,
     1                DERSN( 2, 2) ,DERAN( 2, 2)
      DIMENSION 
     1   DERIB(NGSTR,NEVAB,    1) ,DUMMY(2)
      IF(NALGO.GT.2) RETURN
      CS = COS(ANGLE)
      SN = SIN(ANGLE)
C
C     CALCULA LAS DERIVADAS DE LAS FUNCIONES DE FORMA Y DE SUS 
C     DERIVADAS CURVILINEAS CON RESPECTO A LAS VELOCIDADES NODALES
C
      DO 10 INODE = 1,NNODE
      DNIDS = CARTD(INODE)
      DO 10 JNODE = 1,NNODE
      SHAPJ = SHAPE(JNODE)
      DNJDS = CARTD(JNODE)
      DERNI(1,JNODE,INODE) = 0.0
      DERNI(2,JNODE,INODE) = 0.0
      DERDN(1,JNODE,INODE) = - DNIDS*DNJDS*CS*ACOEF*DTIME
      DERDN(2,JNODE,INODE) = - DNIDS*DNJDS*SN*ACOEF*DTIME
10    CONTINUE
C
C     CALCULA LAS DERIVADAS DEL ANGULO, DEL COSENO Y DEL SENO
C     CON RESPECTO A LAS VELOCIDADES DE LOS NODOS
C
      DO 20 INODE = 1,NNODE
      DNIDS = CARTD(INODE)
      DERAN(1,INODE) = - DNIDS*SN*ACOEF*DTIME
      DERAN(2,INODE) = DNIDS*CS*ACOEF*DTIME
      DO 20 IDIME = 1,NDIME
      DERCS(IDIME,INODE) = - SN*DERAN(IDIME,INODE)
      DERSN(IDIME,INODE) = CS*DERAN(IDIME,INODE)
20    CONTINUE
C
C     SELECCIONA TIPO DE PROBLEMA
C
      GO TO (100,200), NTYPE
      STOP
C
C
C     T I P O   1 :   D E F O R M A C I O N   P L A N A
C
C     
C     FORMA LA DERIVADA DE LA MATRIZ B PARA LA FORMULACION DE 
C     MEMBRANA
C
100   KEVAB = 1
      DO 130 INODE = 1,NNODE
      DNIDS = CARTD(INODE)
      JEVAB = 0
      DO 120 JNODE = 1,NNODE
      DO 110 JDIME = 1,NDIME
      JEVAB = JEVAB + 1
      DERIB(1,  KEVAB,JEVAB) = DERDN(JDIME,JNODE,INODE)*CS +
     1   DNIDS*DERCS(JDIME,JNODE)
      DERIB(1,1+KEVAB,JEVAB) = DERDN(JDIME,JNODE,INODE)*SN +
     1   DNIDS*DERSN(JDIME,JNODE)
110   CONTINUE
      JEVAB = JEVAB + NDOFN - NDIME
120   CONTINUE
      KEVAB = KEVAB + NDOFN
130   CONTINUE
      IF(NDOFN.EQ.2) RETURN 
C
C     COMPLETA LA DERIVADA DE LA MATRIZ B PARA LA FORMULACION DE 
C     MEMBRANA/FLEXION/CORTANTE
C
      KEVAB = 1
      DO 160 INODE = 1,NNODE
      SHAPI = SHAPE(INODE)
      DNIDS = CARTD(INODE)
      JEVAB = 0
      DO 150 JNODE = 1,NNODE
      DO 140 JDIME = 1,NDIME
      JEVAB = JEVAB + 1
C
C     CONTRIBUCION DE FLEXION
C
      DERIB(2,2+KEVAB,JEVAB) = - DERDN(JDIME,JNODE,INODE)
C
C     CONTRIBUCION DE CORTANTE
C
      DERIB(3,  KEVAB,JEVAB) = - DERDN(JDIME,JNODE,INODE)*SN -
     1   DNIDS*DERSN(JDIME,JNODE)
      DERIB(3,1+KEVAB,JEVAB) = DERDN(JDIME,JNODE,INODE)*CS +
     1   DNIDS*DERCS(JDIME,JNODE)
      DERIB(3,2+KEVAB,JEVAB) = - DERNI(JDIME,JNODE,INODE)
140   CONTINUE
      JEVAB = JEVAB + 1
150   CONTINUE
      KEVAB = KEVAB + NDOFN
160   CONTINUE
      RETURN
C
C
C     T I P O   2 :   A X I S I M E T R I C O
C
C     
C     FORMA LA DERIVADA DE LA MATRIZ B PARA LA FORMULACION DE 
C     MEMBRANA
C
200   KEVAB = 1
      DUMMY(1) = ACOEF*DTIME
      DUMMY(2) = 0.0
      DO 230 INODE = 1,NNODE
      SHAPI = SHAPE(INODE)
      DNIDS = CARTD(INODE)
      JEVAB = 0
      DO 220 JNODE = 1,NNODE
      SHAPJ = SHAPE(JNODE)
      DO 210 JDIME = 1,NDIME
      JEVAB = JEVAB + 1
      DERIB(1,  KEVAB,JEVAB) = DERDN(JDIME,JNODE,INODE)*CS +
     1   DNIDS*DERCS(JDIME,JNODE)
      DERIB(2,  KEVAB,JEVAB) = DERNI(JDIME,JNODE,INODE)/RADUS -
     1   SHAPI*SHAPJ/(RADUS*RADUS)*DUMMY(JDIME)
      DERIB(1,1+KEVAB,JEVAB) = DERDN(JDIME,JNODE,INODE)*SN +
     1   DNIDS*DERSN(JDIME,JNODE)
210   CONTINUE
      JEVAB = JEVAB + NDOFN - NDIME
220   CONTINUE
      KEVAB = KEVAB + NDOFN
230   CONTINUE
      IF(NDOFN.EQ.2) RETURN
C
C     COMPLETA LA DERIVADA DE LA MATRIZ B PARA LA FORMULACION DE 
C     MEMBRANA/FLEXION/CORTANTE
C
      KEVAB = 1
      DO 260 INODE = 1,NNODE
      SHAPI = SHAPE(INODE)
      DNIDS = CARTD(INODE)
      JEVAB = 0
      DO 250 JNODE = 1,NNODE
      SHAPJ = SHAPE(JNODE)
      DO 240 JDIME = 1,NDIME
      JEVAB = JEVAB + 1
C
C     CONTRIBUCION DE FLEXION
C
      DERIB(3,2+KEVAB,JEVAB) = - DERDN(JDIME,JNODE,INODE)
      DERIB(4,2+KEVAB,JEVAB) = - DERNI(JDIME,JNODE,INODE)*CS/RADUS -
     1   SHAPI*DERCS(JDIME,JNODE)/RADUS +
     2   SHAPI*SHAPJ*CS/(RADUS*RADUS)*DUMMY(JDIME)
C
C     CONTRIBUCION DE CORTANTE
C
      DERIB(5,  KEVAB,JEVAB) = -DERDN(JDIME,JNODE,INODE)*SN -
     1   DNIDS*DERSN(JDIME,JNODE)
      DERIB(5,1+KEVAB,JEVAB) = DERDN(JDIME,JNODE,INODE)*CS +
     1   DNIDS*DERCS(JDIME,JNODE)
      DERIB(5,2+KEVAB,JEVAB) = - DERNI(JDIME,JNODE,INODE)
240   CONTINUE
      JEVAB = JEVAB + 1
250   CONTINUE
      KEVAB = KEVAB + NDOFN
260   CONTINUE
      RETURN
      END

      SUBROUTINE ADDBAN(STIFF,MAXAD,ESTIF,LEQNS,NEVAB)
C*******************************************************************************
C
C*** ENSAMBLA LA MATRIZ DE RIGIDEZ 
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION STIFF(1),MAXAD(1),ESTIF(1),LEQNS(1)
      KOUNT = 0
      DO 200 IEVAB = 1,NEVAB
      IEQNS = LEQNS(IEVAB)
      IF(IEQNS)200,200,100
  100 IMAXA = MAXAD(IEQNS)
      KEVAB = IEVAB
      DO 220 JEVAB = 1,NEVAB
      JEQNS = LEQNS(JEVAB)
      IF(JEQNS)220,220,110
  110 IJEQN = IEQNS - JEQNS
      IF(IJEQN) 220,210,210
  210 ISIZE = IMAXA + IJEQN
      JSIZE = KEVAB
      IF(JEVAB.GE.IEVAB) JSIZE = JEVAB + KOUNT
      STIFF(ISIZE) = STIFF(ISIZE) + ESTIF(JSIZE)
  220 KEVAB = KEVAB + NEVAB - JEVAB
  200 KOUNT = KOUNT + NEVAB - IEVAB
      RETURN
      END

      SUBROUTINE SOLVE(MAXAD,FORCE,STIFF)
C*******************************************************************************
C
C*** RESUELVE EL SISTEMA DE ECUACIONES
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /PROFIL/ NEQNS ,NWKTL
      COMMON /VNORMS/ VNORM ,VELON
      DIMENSION  MAXAD(1) ,FORCE(1) ,STIFF(1)
C
C     F A C T O R I Z A   L A   M A T R I Z   D E   R I G I D E Z 
C
      CALL DECOMP(STIFF ,MAXAD ,NEQNS)
C
C     R E S U E L V E   E L   S I S T E M A   D E   E C U A C I O N E S
C
      CALL REDBAK(STIFF ,FORCE ,MAXAD ,NEQNS)
C
C     CALCULA NORMAS DE VELOCIDADES
C
      VNORM = 0.0
      DO 10 IEQNS = 1,NEQNS
      VNORM = VNORM + FORCE(IEQNS)*FORCE(IEQNS)
10    CONTINUE
      VNORM = SQRT(VNORM)
C
C     ESCRIBE NORMAS DE VELOCIDADES
C
      WRITE(IOUTP,2000) VNORM
      RETURN
2000  FORMAT(5X,' NORMA INCREMENTO VELOCIDADES = ',E10.4)
      END

      SUBROUTINE DECOMP(STIFF,MAXAD,NEQNS)
C*******************************************************************************
C
C*** FACTORIZA LA MATRIZ DE RIGIDEZ  (L)*(D)*(L)T
C
C*******************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      DIMENSION STIFF(1),MAXAD(1)
      DATA  ISHOT/0/
      IF(NEQNS.EQ.1) RETURN
      DO 200 IEQNS = 1,NEQNS
      IMAXA = MAXAD(IEQNS)
      LOWER = IMAXA + 1
      KUPER = MAXAD(IEQNS+1) - 1
      KHIGH = KUPER - LOWER
      IF(KHIGH) 304,240,210
  210 KSIZE = IEQNS - KHIGH
      ICOUN = 0
      JUPER = KUPER
      DO 260 JHIGH = 1,KHIGH
      ICOUN = ICOUN + 1
      JUPER = JUPER - 1
      KMAXA = MAXAD(KSIZE)
      NDIAG = MAXAD(KSIZE+1) - KMAXA - 1
      IF(NDIAG) 260,260,270
  270 NCOLM = MIN0(ICOUN,NDIAG)
      COUNT = 0.
      DO 280 ICOLM = 1,NCOLM
  280 COUNT = COUNT + STIFF(KMAXA+ICOLM)*STIFF(JUPER+ICOLM)
      STIFF(JUPER) = STIFF(JUPER) - COUNT
  260 KSIZE = KSIZE + 1
  240 KSIZE = IEQNS
      BSUMM = 0.
      DO 300 ICOLM = LOWER,KUPER
      KSIZE = KSIZE - 1
      JMAXA = MAXAD(KSIZE)
      RATIO = STIFF(ICOLM)/STIFF(JMAXA)
      BSUMM = BSUMM + RATIO*STIFF(ICOLM)
  300 STIFF(ICOLM) = RATIO
      STIFF(IMAXA) = STIFF(IMAXA) - BSUMM
  304 IF(STIFF(IMAXA)) 310,310,200
  310 IF(ISHOT.EQ.0) GO TO 320
      IF(STIFF(IMAXA).EQ.0.0) STIFF(IMAXA) = -1.E-16
      GO TO 200
  320 WRITE(IOUTP,2000) IEQNS,STIFF(IMAXA)
      STOP
  200 CONTINUE
      RETURN
 2000 FORMAT(//48H STOP - STIFFNESS MATRIX NOT POSITIVE DEFINITE  ,//
     .32H NONPOSITIVE PIVOT FOR EQUATION ,I4,//10H PIVOT  =   ,E20.12 )
      END

      SUBROUTINE REDBAK(STIFF,FORCE,MAXAD,NEQNS)
C*******************************************************************************
C
C*** REDUCE Y SUSTITUYE HACIA ATRAS PARA OBTENER LA SOLUCION DEL SISTEMA
C
C*******************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION STIFF(1),FORCE(1),MAXAD(1)
      DO 400 IEQNS = 1,NEQNS
      LOWER = MAXAD(IEQNS)+1
      KUPER = MAXAD(IEQNS+1) - 1
      IF(KUPER-LOWER) 400,410,410
  410 JEQNS = IEQNS   
      SUMCC = 0.0
      DO 420 ICOLM = LOWER,KUPER
      JEQNS = JEQNS - 1
  420 SUMCC = SUMCC + STIFF(ICOLM)*FORCE(JEQNS)
      FORCE(IEQNS) = FORCE(IEQNS) - SUMCC
  400 CONTINUE
C
      DO 480 IEQNS = 1,NEQNS
      KMAXA = MAXAD(IEQNS)
  480 FORCE(IEQNS) = FORCE(IEQNS)/STIFF(KMAXA)
      IF(NEQNS.EQ.1) RETURN
      JEQNS = NEQNS
      DO 500 IEQNS = 2,NEQNS
      LOWER = MAXAD(JEQNS) + 1
      KUPER = MAXAD(JEQNS+1) - 1
      IF(KUPER-LOWER) 500,510,510
  510 KEQNS = JEQNS
      DO 520 ICOLM = LOWER,KUPER
      KEQNS = KEQNS - 1
  520 FORCE(KEQNS) = FORCE(KEQNS) - STIFF(ICOLM)*FORCE(JEQNS)
  500 JEQNS = JEQNS - 1
      RETURN
      END

      SUBROUTINE UPDATE(COORD,COORI,IFFIX,FIXED,VELOC,VELOI,
     1                  FORCE)
C*******************************************************************************
C
C*** ACTUALIZA LAS VARIABLES
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      DIMENSION
     1   VELOC(NDOFN,    1) ,VELOI(NDOFN,    1) ,
     2   COORD(NDIME,    1) ,COORI(NDIME,    1) ,
     3   IFFIX(NDOFN,    1) ,FIXED(NDOFN,    1) ,
     4   FORCE(          1) 
C
C     ACTUALIZA VELOCIDADES
C
      DO 10 IPOIN = 1,NPOIN
      DO 10 IDOFN = 1,NDOFN
      IEQNS = IFFIX(IDOFN,IPOIN)
      IF(IEQNS.LE.0) 
     1   VELOC(IDOFN,IPOIN) = FIXED(IDOFN,IPOIN)
      IF(IEQNS.GT.0) 
     1   VELOC(IDOFN,IPOIN) = VELOC(IDOFN,IPOIN) + FORCE(IEQNS) 
10    CONTINUE
C
C     ACTUALIZA CONFIGURACION
C
      DO 20 IPOIN = 1,NPOIN
      DO 20 IDIME = 1,NDIME
      COORD(IDIME,IPOIN) = COORI(IDIME,IPOIN) +
     1   ((1.0-ACOEF)*VELOI(IDIME,IPOIN) + ACOEF*VELOC(IDIME,IPOIN))*
     2   DTIME
20    CONTINUE
      RETURN
      END

      SUBROUTINE NZPRVE(RLOAD,ESTIF,LNODS,LEQNS,FIXED)
C*******************************************************************************
C
C*** CORRIGE EL VECTOR DE FUERZAS RESIDUALES DEL ELEMENTO
C    DEBIDO A VELOCIDADES PRESCRITAS NO NULAS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /ELEMNT/ SHAPE(  3) ,DERIV(2,3) ,CARTD(  3) ,XJACM(  2) ,
     1                ELCOD(2,3) ,GPCOD(2,3) ,ELVEL(3,3) ,
     2                SECDR(  2)
      DIMENSION 
     1   RLOAD(      1) ,ESTIF(      1) ,LNODS(     1) ,
     2   LEQNS(      1) ,FIXED(NDOFN,1)
C
C     MODIFICA EL VECTOR DE FUERZAS RESIDUALES PARA EL CASO DE 
C     VELOCIDADES PRESCRITAS NO NULAS
C
C     IF(IINCS.GT.1) RETURN
      IF(IITER.GT.1) RETURN
      KEVAB = 0
      DO 30 INODE = 1,NNODE
      IPOIN = LNODS(INODE)
      DO 30 IDOFN = 1,NDOFN
      KEVAB = KEVAB + 1
      IF(LEQNS(KEVAB).GT.0) GO TO 30
      FINCV = FIXED(IDOFN,IPOIN) - ELVEL(IDOFN,INODE)
      IF(FINCV.EQ.0.0) GO TO 30
      KSTIF = KEVAB
      KOUNT = 0
      DO 10 IEVAB = 1,KEVAB-1
      RLOAD(IEVAB) = RLOAD(IEVAB) - FINCV*ESTIF(KSTIF)
      KOUNT = KOUNT + 1
      KSTIF = KSTIF + NEVAB - KOUNT
10    CONTINUE
      DO 20 IEVAB = KEVAB,NEVAB
      RLOAD(IEVAB) = RLOAD(IEVAB) - FINCV*ESTIF(KSTIF)
      KSTIF = KSTIF + 1
20    CONTINUE
30    CONTINUE
      RETURN
      END

      SUBROUTINE MULPLY(A,X,B,N)
C*******************************************************************************
C
C*** CALCULA EL PRODUCTO A*X=B SIENDO A UNA MATRIZ SIMETRICA N*N 
C    ALMACENADA DE FORMA COMPACTA POR FILAS Y X UN VECTOR COLUMNA
C
C*******************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),X(1),B(1)
      DO 10 I = 1,N
      B(I) = 0.0
10    CONTINUE
      K = 0
      DO 20 I = 1,N
      K = K + 1
      B(I) = B(I) + A(K)*X(I)
      DO 20 J = I+1,N
      K = K + 1
      B(I) = B(I) + A(K)*X(J)
      B(J) = B(J) + A(K)*X(I)
20    CONTINUE
      RETURN
      END

      SUBROUTINE DELTA(TABDT)
C*******************************************************************************
C
C*** DETERMINA EL INCREMENTO DE TIEMPO EN FUNCION DE LA TABLA
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /TABLAS/ NTABP ,NTABT
      DIMENSION  TABDT(2,1)
      DO 10 ITABT = 1,NTABT
      TIEMP = TABDT(1,ITABT)
      DTIME = TABDT(2,ITABT)
      IF(TTIME.LT.TIEMP) RETURN
10    CONTINUE
      RETURN
      END

      SUBROUTINE AUTDT
C*******************************************************************************
C
C*** DETERMINA EL INCREMENTO DE TIEMPO EN FUNCION DE LA TABLA
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /EPSRMM/ EPMAX ,EPMIN
      COMMON /AUTPRC/ EPFIX ,EXPON
      COMMON /PLOADS/ PRESS
      COMMON /AUTODT/ DEMAX
      DTCUT = 1.5*DTIME
      IF(EPMAX.GT.0.0) DTIME = DEMAX/EPMAX
      IF(DTIME.GT.DTCUT) DTIME = DTCUT
      IF(DTIME.EQ.0.0) DTIME = 1.0E-05
      RETURN
      END

      SUBROUTINE CHECKM(NA)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /DYNMEM/ MAXIM
      IF(NA.LE.MAXIM) RETURN
      WRITE(IOUTP,3000) NA,MAXIM
3000  FORMAT(//' *** ESPACIO DE DIMENSIONAMIENTO DINAMICO EXCEDIDO',
     1       5X,'ESPACIO NECESARIO =',I10,
     2       5X,'ESPACIO DISPONIBLE =',I10)
      STOP
      END

      SUBROUTINE ZERO(IA,L)
      DIMENSION IA(1)
      DO 10 I = 1,L
      IA(I) = 0
10    CONTINUE
      RETURN
      END

      SUBROUTINE OUTPUT(COORD,LNODS,VELOC,STRAN,EEPSN,STNRA,
     1                  EEPRA,STRES,THICK,VOIDS,PLOAD,RESID,
     2                  RCLOD,NELRS,RSCOR,LELCO,REARS,KOUNT,
     3                  EXTRA)
C*******************************************************************************
C
C*** SALIDA DE RESULTADOS
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /PLOADS/ PRESS
      COMMON /MIDZGP/ NMIDZ
      COMMON /EXTRAP/ NEXTR ,NGST2 ,NROWS
      COMMON /PRINTS/ IPCCS ,IPVEL ,IPREA ,IPSNR ,IPSTN ,IPSTR ,
     1                IPTHG ,IPPOR ,IPAVN 
      COMMON /EPSRMM/ EPMAX ,EPMIN 
      COMMON /ERRNRM/ ERNRM ,EVNRM
      DIMENSION
     1   COORD(NDIME,1) ,LNODS(NNODE,1) ,VELOC(NDOFN,1) ,
     2   STRAN(NGSTR,1) ,EEPSN(      1) ,STNRA(NGSTR,1) ,
     3   EEPRA(      1) ,STRES(NGSTR,1) ,THICK(      1) ,
     4   VOIDS(      1) ,PLOAD(NDOFN,1) ,RESID(NDOFN,1) ,
     5   RCLOD(NDOFN,1) ,NELRS(      1) ,RSCOR(NDIME,1) ,
     6   LELCO(      1) ,REARS(NDIME,1) ,KOUNT(      1) ,
     7   EXTRA(NEXTR,1)
      DIMENSION 
     1   REACT(      3) ,SUMM(       3) ,ASUM(       3) 
C
C     V E L O C I D A D E S
C
      IF(IPVEL.EQ.0) GO TO 100
      IF(MOD(IINCS,IPVEL).GT.0) GO TO 100
      WRITE(IOUTP,2000) IINCS,TTIME,PRESS
      DO 10 IPOIN = 1,NPOIN
      WRITE(IOUTP,2001) 
     1   IPOIN,(COORD(IDIME,IPOIN),IDIME=1,NDIME),
     2         (VELOC(IDOFN,IPOIN),IDOFN=1,NDOFN)
10    CONTINUE
100   CONTINUE
C
C     F U E R Z A S   I N T E R N A S / R E A C C I O N E S
C
      IF(IPREA.EQ.0) GO TO 200
      IF(MOD(IINCS,IPREA).GT.0) GO TO 200
      WRITE(IOUTP,2002) IINCS,TTIME,PRESS
      DO 20 IDOFN = 1,NDOFN
      SUMM(IDOFN) = 0.0
      ASUM(IDOFN) = 0.0
20    CONTINUE
      DO 22 IPOIN = 1,NPOIN
      DO 21 IDOFN = 1,NDOFN
      REACT(IDOFN) = PLOAD(IDOFN,IPOIN) - RESID(IDOFN,IPOIN)
      SUMM(IDOFN) = SUMM(IDOFN) +     REACT(IDOFN)
      ASUM(IDOFN) = ASUM(IDOFN) + ABS(REACT(IDOFN))
21    CONTINUE
      WRITE(IOUTP,2001)
     1   IPOIN,(COORD(IDIME,IPOIN),IDIME=1,NDIME),
     2         (REACT(IDOFN),IDOFN=1,NDOFN)
22    CONTINUE
      WRITE(IOUTP,2003) (SUMM(IDOFN),IDOFN=1,NDOFN),
     1                  (ASUM(IDOFN),IDOFN=1,NDOFN)
200   CONTINUE
C
C     F U E R Z A S / R E A C C I O N E S   D E   C O N T A C T O
C     E N   L A S   S U P E R F I C I E S   R I G I D A S
C
      DO 30 IRSUR = 1,NRSUR
      DO 30 IDIME = 1,NDIME
      REARS(IDIME,IRSUR) = 0.0
30    CONTINUE
      DO 34 IPOIN = 1,NPOIN
      IRELE = LELCO(IPOIN)
      IF(IRELE.EQ.0) GO TO 34
      IFIRS = 1
      DO 33 IRSUR = 1,NRSUR
      ILAST = IFIRS + NELRS(IRSUR) - 1
      IF(IRELE.LT.IFIRS.OR.IRELE.GT.ILAST) GO TO 32
      DO 31 IDIME = 1,NDIME
      REARS(IDIME,IRSUR) = REARS(IDIME,IRSUR) + RCLOD(IDIME,IPOIN)
31    CONTINUE
32    IFIRS = ILAST + 1
33    CONTINUE
34    CONTINUE
C
C     P R I N T   P U N C H   ( R I G I D   S U R F A CE   # 1 )   L O A D 
C     v s   P U N C H ( R S   # 1 )   D I S P L A C E M E N T
C
      WRITE(IOUT5,2014) RSCOR(2,1),REARS(2,1)
C
C     PRINT RIGID SURFACES REACTIONS
C
      IF(NCNTC.EQ.1) GO TO 300
      IF(IPREA.EQ.0) GO TO 300
      IF(MOD(IINCS,IPREA).GT.0) GO TO 300
      WRITE(IOUTP,2004) IINCS,TTIME,PRESS
      DO 35 IRSUR = 1,NRSUR
      WRITE(IOUTP,2005) IRSUR,(REARS(IDIME,IRSUR),IDIME=1,NDIME)
35    CONTINUE
300   CONTINUE
C
C     V E L O C I D A D   D E   D E F O R M A C I O N   E F E C T I V A 
C     Y   V E L O C I D A D E S   D E   D E F O R M A C I O N 
C     G E N E R A L I Z A D A S   E N   L O S   P U N T O S   D E 
C     G A U S S   D E   L O S   E L E M E N T O S 
C
      IF(IPSNR.EQ.0) GO TO 400
      IF(MOD(IINCS,IPSNR).GT.0) GO TO 400
      WRITE(IOUTP,2006) IINCS,TTIME,PRESS
      KGAST = 0
      KGAZT = NMIDZ 
      DO 40 IELEM = 1,NELEM
      WRITE(IOUTP,2007) IELEM
      DO 40 IGAUS = 1,NGAUS
      KGAST = KGAST + 1
      WRITE(IOUTP,2008) EEPRA(KGAZT),(STNRA(IGSTR,KGAST),IGSTR=1,NGSTR)
      KGAZT = KGAZT + NGAUZ
40    CONTINUE
400   CONTINUE
C
C     COMPUTE THE MAXIMUM AND MINIMUM EQUIVALENT PLASTIC STRAIN RATE
C
      EPMAX = -1.0E+10
      EPMIN =  1.0E+10
      KGAZT = NMIDZ
      DO IELEM = 1,NELEM
        DO IGAUS = 1,NGAUS
          IF(EEPRA(KGAZT).GT.EPMAX) EPMAX = EEPRA(KGAZT)
          IF(EEPRA(KGAZT).LT.EPMIN) EPMIN = EEPRA(KGAZT)
          KGAZT = KGAZT + NGAUZ
        END DO
      END DO
C
C     O U T P U T   T I M E   S T E P   C O N T R O L   D A T A 
C
      WRITE(IOUT3,2015) IINCS,ERNRM,EVNRM,IITER,TTIME,
     1                  PRESS,EPMAX,EPMIN
C
C     T I M E / P R E S S U R E   C Y C L E
C
      IF(PRESS.NE.0.0) THEN
        WRITE(IOUT1,2014) TTIME,PRESS,EPMAX,IINCS,IITER,ERNRM
      END IF
C
C     M A X I M U M   E Q U I V A L E N T   P L A S T I C   
C     S T R A I N   R A T E
C
      IF(NAUTP.EQ.1) THEN
        WRITE(IOUT2,2014) TTIME,EPMAX,EPMIN,IINCS,IITER,ERNRM
      END IF
C
C     D E F O R M A C I O N   E F E C T I V A   Y   
C     D E F O R M A C I O N E S   G E N E R A L I Z A D A S   E N   L O S
C     P U N T O S   D E   G A U S S   D E   L O S   E L E M E N T O S
C
      IF(IPSTN.EQ.0) GO TO 500
      IF(MOD(IINCS,IPSTN).GT.0) GO TO 500
      WRITE(IOUTP,2009) IINCS,TTIME,PRESS
      KGAST = 0
      KGAZT = NMIDZ 
      DO 50 IELEM = 1,NELEM
      WRITE(IOUTP,2007) IELEM
      DO 50 IGAUS = 1,NGAUS
      KGAST = KGAST + 1
      WRITE(IOUTP,2008) EEPSN(KGAZT),(STRAN(IGSTR,KGAST),IGSTR=1,NGSTR)
      KGAZT = KGAZT + NGAUZ
50    CONTINUE
500   CONTINUE
C
C     T E N S I O N E S   G E N E R A L I Z A D A S   E N   L O S
C     P U N T O S   D E   G A U S S   D E   L O S   E L E M E N T O S
C
      IF(IPSTR.EQ.0) GO TO 600
      IF(MOD(IINCS,IPSTR).GT.0) GO TO 600
      WRITE(IOUTP,2010) IINCS,TTIME,PRESS
      KGAST = 0
      KGAZT = NMIDZ 
      DO 60 IELEM = 1,NELEM
      WRITE(IOUTP,2007) IELEM
      DO 60 IGAUS = 1,NGAUS
      KGAST = KGAST + 1
      WRITE(IOUTP,2008) (STRES(IGSTR,KGAST),IGSTR=1,NGSTR)
      KGAZT = KGAZT + NGAUZ
60    CONTINUE
600   CONTINUE
C
C     E S P E S O R   E N   L O S   P U N T O S   D E   G A U S S 
C     D E   L O S   E L E M E N T O S 
C
      IF(IPTHG.EQ.0) GO TO 700
      IF(MOD(IINCS,IPTHG).GT.0) GO TO 700
      WRITE(IOUTP,2011) IINCS,TTIME,PRESS
      KGAST = 0
      DO 70 IELEM = 1,NELEM
      WRITE(IOUTP,2007) IELEM
      DO 70 IGAUS = 1,NGAUS
      KGAST = KGAST + 1
      WRITE(IOUTP,2008) THICK(KGAST)
70    CONTINUE
700   CONTINUE
C
C     P O R O S I D A D   E N   L O S   P U N T O S   D E   G A U S S 
C     D E   L O S   E L E M E N T O S 
C
      IF(MODEL.NE.3.AND.MODEL.NE.4) GO TO 800
      IF(IPPOR.EQ.0) GO TO 800
      IF(MOD(IINCS,IPPOR).GT.0) GO TO 800
      WRITE(IOUTP,2012) IINCS,TTIME,PRESS
      KGAST = 1
      KGAZT = NMIDZ
      DO 80 IELEM = 1,NELEM
      WRITE(IOUTP,2007) IELEM
      DO 80 IGAUS = 1,NGAUS
      WRITE(IOUTP,2008) VOIDS(KGAZT)
      KGAST = KGAST + 1
      KGAZT = KGAZT + NGAUZ
80    CONTINUE
800   CONTINUE
C
C     E X T R A P O L A   V A L O R E S   D E   L O S   P U N T O S 
C     D E   G A U S S   A   L O S   N O D O S 
C
C     >>> VALIDO PARA 1 SOLO PUNTO DE GAUSS <<<
C
      KGAST = 1
      KGAZT = NMIDZ 
      DO 92 IELEM = 1,NELEM
      DO 91 INODE = 1,NNODE
      LNODE = LNODS(INODE,IELEM)
      KOUNT(LNODE) = KOUNT(LNODE) + 1
      DO 90 IGSTR = 1,NGSTR
      JGSTR = IGSTR + NGSTR
      EXTRA(IGSTR,LNODE) = EXTRA(IGSTR,LNODE) + STRES(IGSTR,KGAST)
      EXTRA(JGSTR,LNODE) = EXTRA(JGSTR,LNODE) + STRAN(IGSTR,KGAST)
90    CONTINUE
      EXTRA(NGST2+1,LNODE) = EXTRA(NGST2+1,LNODE) + THICK(KGAST)
      EXTRA(NGST2+2,LNODE) = EXTRA(NGST2+2,LNODE) + EEPSN(KGAZT)
      EXTRA(NGST2+3,LNODE) = EXTRA(NGST2+3,LNODE) + EEPRA(KGAZT)
      IF(MODEL.EQ.3.OR.MODEL.EQ.4)
     1EXTRA(NGST2+4,LNODE) = EXTRA(NGST2+4,LNODE) + VOIDS(KGAZT)
91    CONTINUE
      KGAST = KGAST + 1
      KGAZT = KGAZT + NGAUZ
92    CONTINUE
      DO 93 IPOIN = 1,NPOIN
      DO 93 IEXTR = 1,NEXTR
      EXTRA(IEXTR,IPOIN) = EXTRA(IEXTR,IPOIN)/FLOAT(KOUNT(IPOIN))
93    CONTINUE
C
C     V A L O R E S   P R O M E D I A D O S   E N   L O S   N O D O S
C
      IF(IPAVN.EQ.0) GO TO 900
      IF(MOD(IINCS,IPAVN).GT.0) GO TO 900
      WRITE(IOUTP,2013) IINCS,TTIME,PRESS
      DO 94 IPOIN = 1,NPOIN
      WRITE(IOUTP,2001) IPOIN,EXTRA(NGST2+1,IPOIN),EXTRA(NGST2+2,IPOIN),
     1   (EXTRA(IGSTR,IPOIN),IGSTR=1,NGSTR)
94    CONTINUE
900   CONTINUE
      RETURN
C
C     FORMATOS
C
2000  FORMAT(//' V E L O C I D A D E S   N O D A L E S'//
     1   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',F10.3,
     2   5X,'PRESION = ',E10.3//
     3   1X,' NODO',5X,'1-COORD',5X,'2-COORD',13X,'VELOCIDADES')
2001  FORMAT(1X,I5,7E12.4)
2002  FORMAT(//' R E A C C I O N E S'//
     1   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',F10.3,
     2   5X,'PRESION = ',E10.3//
     3   1X,' NODO',5X,'1-COORD',5X,'2-COORD',13X,' REACCIONES')
2003  FORMAT(/,5X,'SUMA REACCIONES       ',3X,<NDOFN>E12.4,
     1       /,5X,'SUMA VALORES ABSOLUTOS',3X,<NDOFN>E12.4)
2004  FORMAT(//' R E A C C I O N E S   S U P E R F I C I E S '
     1         '  R I G I D A S'//
     2   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',F10.3,
     3   5X,'PRESION = ',E10.3/)
2005  FORMAT(5X,'SUPERFICIE RIGIDA NUMERO ',I3,7X,3E12.4)
2006  FORMAT(//' V E L O C I D A D E S   D E   D E F O R M A C I O N'//
     1   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',F10.3,
     2   5X,'PRESION = ',E10.3//
     3   1X,9X,'EFECTIVA',11X,'GENERALIZADAS')
2007  FORMAT(/' ELEMENTO = ',I5)
2008  FORMAT(1X,5X,6E12.4)
2009  FORMAT(//' D E F O R M A C I O N E S'//
     1   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',F10.3,
     2   5X,'PRESION = ',E10.3//
     2   1X,9X,'EFECTIVA',11X,'GENERALIZADAS')
2010  FORMAT(//' T E N S I O N E S   G E N E R A L I Z A D A S'//
     1   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',F10.3,
     2   5X,'PRESION = ',E10.3)
2011  FORMAT(//' E S P E S O R E S'//
     1   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',F10.3,
     2   5X,'PRESION = ',E10.3)
2012  FORMAT(//' P O R O S I D A D'//
     1   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',F10.3,
     2   5X,'PRESION = ',E10.3)
2013  FORMAT(//' V A L O R E S   P R O M E D I A D O S' 
     1         '   E N   L O S   N O D O S'//
     2   5X,'INCREMENTO = ',I5,5X,'TIEMPO = ',F10.3,
     3   5X,'PRESION = ',E10.3//
     4   1X,' NODO',5X,'ESPESOR',3X,'DEF EFECT',7X,'TENSIONES')
2014  FORMAT(1X,3E12.4,2I5,E12.4)
2015  FORMAT(1X,I5,2E12.4,I5,4E12.4)
      END

      SUBROUTINE PRTHOL(COORD,COORI,LNODS,VELOC,EXTRA)
C*******************************************************************************
C
C*** ESCRIBE UN FICHERO PORTHOLE
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER TITLE*80,TITLD*64
      COMMON /TITLEP/ TITLE
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /SELECT/ NTYPE ,NFORM ,MODEL ,NHARD ,NALGO ,NCNTC ,
     1                NFRIC ,NAUTP ,NAUTT
      COMMON /TABLAS/ NTABP ,NTABT
      COMMON /NPARAM/ NPARA
      COMMON /VOIDML/ NVOID
      COMMON /EXTRAP/ NEXTR ,NGST2 ,NROWS
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /OUTFIL/ IPPHL ,IPRST
      DIMENSION
     1   COORD(NDIME,NPOIN) ,COORI(NDIME,NPOIN) ,LNODS(NNODE,NELEM) ,
     2   VELOC(NDOFN,NPOIN) ,EXTRA(NEXTR,NPOIN) 
      DATA IFLAG/1/
C
C     ESCRIBE DATOS DE CONTROL Y DE DEFINICION DE LA MALLA
C
      IF(IFLAG.EQ.1) THEN
      WRITE(IPHOL) NPOIN,NELEM,NNODE,NDIME,NDOFN,NGAUS,
     1             NMATS,NPROP,NGSTR,NGSTR,NTYPE,MODEL,
     2             TITLD
      IF(TIME0.EQ.0.0) THEN
      WRITE(IPHOL) 
     1   ((SNGL(COORI(IDIME,IPOIN)),IDIME=1,NDIME),IPOIN=1,NPOIN),
     2   ((     LNODS(INODE,IELEM) ,INODE=1,NNODE),IELEM=1,NELEM)
      ELSE
      WRITE(IPHOL) 
     1   ((SNGL(COORD(IDIME,IPOIN)),IDIME=1,NDIME),IPOIN=1,NPOIN),
     2   ((     LNODS(INODE,IELEM) ,INODE=1,NNODE),IELEM=1,NELEM)
      END IF
      IFLAG = 0
      END IF
C
C     ESCRIBE RESULTADOS PARA CADA INCREMENTO DE TIEMPO
C
C        CONTROL
C           NUMERO DE INCREMENTO
C           ITERACIONES DE EQUILIBRIO
C           TIEMPO
C        VALORES NODALES
C           COORDENADAS
C           VELOCIDADES 
C           TENSIONES GENERALIZADAS
C           DEFORMACIONES GENERALIZADAS
C           ESPESORES
C           DEFORMACION EFECTIVA
C           VELOCIDAD DE DEFORMACION EFECTIVA
C           POROSIDAD *
C
      IF(IPPHL.EQ.0) RETURN
      IF(MOD(IINCS,IPPHL).GT.0) RETURN
      WRITE(IPHOL)
     1   TITLD,TITLD,IINCS,IINCS,IITER,SNGL(TTIME),
     2   ((SNGL(COORD(      IDIME,IPOIN)),IDIME=1,NDIME),IPOIN=1,NPOIN),
     3   ((SNGL(VELOC(      IDOFN,IPOIN)),IDOFN=1,NDOFN),IPOIN=1,NPOIN),
     4   ((SNGL(EXTRA(      IGSTR,IPOIN)),IGSTR=1,NGSTR),IPOIN=1,NPOIN),
     5   ((SNGL(EXTRA(NGSTR+IGSTR,IPOIN)),IGSTR=1,NGSTR),IPOIN=1,NPOIN),
     6   ((SNGL(EXTRA(NGST2+IROWS,IPOIN)),IPOIN=1,NPOIN),IROWS=1,NROWS)
      RETURN
      END

      SUBROUTINE RSTART(COORD,VELOC,STRAN,EEPSN,STNRA,EEPRA,
     1                  PARAM,VOIDS,VOIRA,RSCOR,IOPCN)
C*******************************************************************************
C
C*** REALIZA LA LECTURA/ESCRITURA DEL FICHERO DE RESTART
C
C*******************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON /IOPATH/ IINPT ,IOUTP ,ISAVE ,IRSTA ,IPHOL ,IOUT1 ,
     1                IOUT2 ,IOUT3 ,IOUT4 ,IOUT5 ,IOUT6 ,IOUT7
      COMMON /CONTRO/ NPOIN ,NELEM ,NMATS ,NVFIX ,NDIME ,NNODE ,
     1                NDOFN ,NPROP ,NGAUS ,NGAUZ ,NSTRE ,NGSTR ,
     2                NEVAB ,NTOTV ,NGASP ,NGAST ,NGAZP ,NGAZT ,
     3                NSTIF
      COMMON /CTRSCR/ NRSUR ,NRPOI ,NRELE ,NNODR 
      COMMON /NPARAM/ NPARA
      COMMON /VOIDML/ NVOID
      COMMON /TRANSI/ TIME0 ,TIMEF ,TTIME ,DTIME ,ACOEF
      COMMON /SOLVER/ NINCS ,IINCS ,MITER ,IITER ,NCHEK
      COMMON /OUTFIL/ IPPHL ,IPRST
      DIMENSION
     1   COORD(NDIME,NPOIN) ,VELOC(NDOFN,NPOIN) ,STRAN(NGSTR,NGAST) ,
     2   EEPSN(      NGAZT) ,STNRA(NGSTR,NGAST) ,EEPRA(      NGAZT) ,
     3   PARAM(NPARA,NGAZT) ,VOIDS(      NVOID) ,VOIRA(      NVOID) ,
     4   RSCOR(NDIME,NRPOI)
      GO TO (1,2), IOPCN
C
C     LEE FICHERO RESTART
C
1     READ(IRSTA,END=10)
     1   TTIME,COORD,VELOC,STRAN,EEPSN,STNRA,EEPRA,PARAM,
     2   VOIDS,VOIRA,RSCOR
      IF(TTIME.LT.TIME0) GO TO 1
10    RETURN
C
C     ESCRIBE FICHERO RESTART
C
2     IF(IPRST.EQ.0) RETURN
      IF(MOD(IINCS,IPRST).GT.0) RETURN
      WRITE(ISAVE) 
     1   TTIME,COORD,VELOC,STRAN,EEPSN,STNRA,EEPRA,PARAM,
     2   VOIDS,VOIRA,RSCOR
      RETURN
      END

      FUNCTION DOT(VECT1,VECT2,LENGT)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION VECT1(1) ,VECT2(1)
      DOT = 0.0
      DO 10 ILENG = 1,LENGT
      DOT = DOT + VECT1(ILENG)*VECT2(ILENG)
10    CONTINUE
      RETURN
      END

      subroutine bhold(coord,coori,lnods,veloc,pload,resid,
     1                 frict,iffix,maxad,force,stiff)
      implicit real*8(a-h,o-z)
      common /select/ ntype ,nform ,model ,nhard ,nalgo ,ncntc ,
     1                nfric ,nautp ,nautt
      common /contro/ npoin ,nelem ,nmats ,nvfix ,ndime ,nnode ,
     1                ndofn ,nprop ,ngaus ,ngauz ,nstre ,ngstr ,
     2                nevab ,ntotv ,ngasp ,ngast ,ngazp ,ngazt ,
     3                nstif
      common /transi/ time0 ,timef ,ttime ,dtime ,acoef
      common /penalt/ pnltc ,pnltf
      common /bhcom1/ ibhol,xbh0,xbh1,bhf,idbhn(300),bhlod(300)

      common /revsli/ irevs(300),parea(300),creac(300),
     1                cesti(300)

      dimension coord(ndime,1),coori(ndime,1),lnods(nnode,1),
     1   veloc(ndofn,1),frict(1),pload(ndofn,1),resid(ndofn,1),
     2   iffix(ndofn,1),maxad(1),force(1),stiff(1)
      pival = 4.0*atan(1.0)
      twopi = 2.0*pival

c      print *, 'node/coord/veloc'
c      do i=1,npoin
c        print *, 'node ', i
c        print *, coord(1,i),'  ', coord(2,i)
c        print *, veloc(1,i),'  ', veloc(2,i)
c      end do
c
c
c     identify nodes in bh area and compute bh length
c
      bhlen = 0.0
      xbmax = 0.0
      do ipoin = 1, npoin
        idbhn(ipoin) = 0
        x = coord(1,ipoin)
        if(x.ge.xbh0.and.x.le.xbh1) then
          idbhn(ipoin) = 1
          d = x - xbh0
          if(d.gt.bhlen) bhlen = d
          if(x.gt.xbmax) xbmax = x
        end if
      end do
      if(xbh1.gt.xbmax) xbmax = xbh1
c
c     compute bh pressure
c
      if(ntype.eq.1) then
c
c     plane strain case
c
        bhpre = bhf/bhlen
      else if(ntype.eq.2) then
c
c     axisymmetric case
c
        bhare = pival*(xbmax*xbmax-xbh0*xbh0)
        bhpre = bhf/bhare
      end if
c
c     compute bh nodal forces
c
      do ipoin = 1, npoin
        bhlod(ipoin) = 0.0
        parea(ipoin) = 0.0
        creac(ipoin) = 0.0
        cesti(ipoin) = 0.0
      end do
      do ielem = 1, nelem
        ln1 = lnods(1,ielem)
        ln2 = lnods(2,ielem)
        x1 = coord(1,ln1)
        x2 = coord(1,ln2)
        if(idbhn(ln1).eq.1.and.idbhn(ln2).eq.1) then
          eleng = abs(x2-x1)
          if(ntype.eq.1) then
            earea = eleng
            bhfn = bhpre*earea
          else if(ntype.eq.2) then
            radus = 0.5*(x1+x2)
            earea = eleng*twopi*radus
            bhfn = bhpre*earea
          end if
          bhlod(ln1) = bhlod(ln1) + 0.5*bhfn
          bhlod(ln2) = bhlod(ln2) + 0.5*bhfn
          parea(ln1) = parea(ln1) + 0.5*earea
          parea(ln2) = parea(ln2) + 0.5*earea
          ymean = 0.5*(coord(2,ln1) + coord(2,ln2))
          vmean = 0.5*(veloc(2,ln1) + veloc(2,ln2))
          ymean = ymean + vmean
          creac(ln1) = creac(ln1) - 0.5*pnltc*earea*ymean
          creac(ln2) = creac(ln2) - 0.5*pnltc*earea*ymean
          cesti(ln1) = cesti(ln1) + 0.5*pnltc*earea
          cesti(ln2) = cesti(ln2) + 0.5*pnltc*earea
        else  if(idbhn(ln1).eq.1.and.idbhn(ln2).eq.0) then
          eleng = xbh1-x1
          if(ntype.eq.1) then
            earea = eleng
            bhfn = bhpre*earea
          else if(ntype.eq.2) then
            radus = 0.5*(xbh1+x1)
            earea = eleng*twopi*radus
            bhfn = bhpre*earea
          end if
          alpha = 0.5*(x2-xbh1)/(x2-x1)
          bhlod(ln1) = bhlod(ln1) + 0.5*(1.0+alpha)*bhfn
          bhlod(ln2) = bhlod(ln2) + 0.5*(1.0-alpha)*bhfn
          parea(ln1) = parea(ln1) + 0.5*(1.0+alpha)*earea
          parea(ln2) = parea(ln2) + 0.5*(1.0-alpha)*earea
          ymean = 0.5*((1.0+alpha)*coord(2,ln1) + 
     1                 (1.0-alpha)*coord(2,ln2))
          vmean = 0.5*((1.0+alpha)*veloc(2,ln1) + 
     1                 (1.0-alpha)*veloc(2,ln2))
          ymean = ymean + vmean
          creac(ln1) = creac(ln1) - 
     1      0.5*(1.0+alpha)*pnltc*earea*ymean
          creac(ln2) = creac(ln2) - 
     1      0.5*(1.0-alpha)*pnltc*earea*ymean
          cesti(ln1) = cesti(ln1) + 0.5*(1.0+alpha)*pnltc*earea
          cesti(ln2) = cesti(ln2) + 0.5*(1.0-alpha)*pnltc*earea
        else  if(idbhn(ln1).eq.0.and.idbhn(ln2).eq.1) then
          eleng = x2-xbh0
          if(ntype.eq.1) then
            earea = eleng
            bhfn = bhpre*earea
          else if(ntype.eq.2) then
            radus = 0.5*(x2+xbh0)
            earea = eleng*twopi*radus
            bhfn = bhpre*earea
          end if
          alpha = 0.5*(x2-xbh0)/(x2-x1)
          bhlod(ln1) = bhlod(ln1) + 0.5*(1.0-alpha)*bhfn
          bhlod(ln2) = bhlod(ln2) + 0.5*(1.0+alpha)*bhfn
          parea(ln1) = parea(ln1) + 0.5*(1.0-alpha)*earea
          parea(ln2) = parea(ln2) + 0.5*(1.0+alpha)*earea
          ymean = 0.5*((1.0-alpha)*coord(2,ln1) + 
     1                 (1.0+alpha)*coord(2,ln2))
          vmean = 0.5*((1.0-alpha)*veloc(2,ln1) + 
     1                 (1.0+alpha)*veloc(2,ln2))
          ymean = ymean + vmean
          creac(ln1) = creac(ln1) - 
     1      0.5*(1.0-alpha)*pnltc*earea*ymean
          creac(ln2) = creac(ln2) - 
     1      0.5*(1.0+alpha)*pnltc*earea*ymean
          cesti(ln1) = cesti(ln1) + 0.5*(1.0-alpha)*pnltc*earea
          cesti(ln2) = cesti(ln2) + 0.5*(1.0+alpha)*pnltc*earea
        end if
      end do
c
c     penalize y-veloc for bh nodes
c
      do ipoin = 1, npoin
        if(idbhn(ipoin).eq.1) then
c.... normal component
          ieqns = iffix(2,ipoin)
          if(ieqns.gt.0) then
            imaxa = maxad(ieqns)
c            stiff(imaxa) = stiff(imaxa) + pnltc*dtime
c            stiff(imaxa) = stiff(imaxa) + cesti(ipoin)*dtime
            stiff(imaxa) = stiff(imaxa) + 
     1                     cesti(ipoin)*(1.0+dtime)
            value = pnltc*coord(2,ipoin)*parea(ipoin)
c            force(ieqns) = force(ieqns) - value
c            pload(2,ipoin) = pload(2,ipoin) - value
c            resid(2,ipoin) = resid(2,ipoin) - value
            force(ieqns) = force(ieqns) + creac(ipoin)
            pload(2,ipoin) = pload(2,ipoin) + creac(ipoin)
            resid(2,ipoin) = resid(2,ipoin) + creac(ipoin)

ccc            print *, 'ipoin=',ipoin,' reacn=',-value
c            print *, 'ipoin=',ipoin,' reacn=',creac(ipoin)

          end if 
          if(nfric.eq.1) return
          if(nfric.eq.3) then
            print *, 'not implemented'
            stop
          end if
          if(nfric.eq.2) then
c.... tangential component (slip)
            ieqns = iffix(1,ipoin)
            if(ieqns.gt.0) then
              imaxa = maxad(ieqns)
              vslip = veloc(1,ipoin)
              if(vslip.gt.0.0) isign = 1
              if(vslip.lt.0.0) isign = -1
              if(vslip.eq.0.0) isign = 0
              ireve = 0
              if(irevs(ipoin).eq.0) then
                irevs(ipoin) = isign
              else
                if(irevs(ipoin)*isign.eq.-1) then
                  ireve = 1
                end if
              end if

              reacn = - pnltc*coori(2,ipoin)*parea(ipoin)
c              reacn = - pnltc*coord(2,ipoin)
              if( (reacn.gt.0.0.and.bhlod(ipoin).le.0.0) .or.
     1            (reacn.lt.0.0.and.bhlod(ipoin).ge.0.0) ) then
                rnmod = abs(reacn) + abs(bhlod(ipoin))
              else 
                rnmod = abs(bhlod(ipoin))
              end if
              rnmod = 2.0*rnmod

c            print *, 'ipoin=',ipoin,' rnmod=',rnmod


c              rnmod = pnltc*abs(coord(2,ipoin))
              factr = frict(2)*rnmod
              vepsi = factr/pnltf
              vslip = abs(vslip)
              if(ireve.eq.1) then
                vslip = .1*vepsi
                irevs(ipoin) = -irevs(ipoin)
c                print *, 'REVERSE SLIP NODE= ',ipoin
              end if
              if(vslip.ge.vepsi) then
                funct = 1.0
                dfunc = 0.0
                ikey = 1
              else
                if(vepsi.eq.0.0) vepsi = 1.0e-10
                funct = vslip/vepsi
                dfunc = 1.0/vepsi
                ikey = 0
              end if
              tfric = - factr*funct*float(isign)
c              value = pnltc*abs(coord(2,ipoin))
c              tfric = 2.0*frict(2)*value*float(isign)
c              trial = pnltf*veloc(1,ipoin)*dtime
c              if(value.gt.0.0) trial = trial/value
c              if(abs(trial).lt.abs(tfric)) then
c                tfric = trial 
c                stiff(imaxa) = stiff(imaxa) + pnltf*dtime
c              end if
              stiff(imaxa) = stiff(imaxa) + factr*dfunc
              force(ieqns) = force(ieqns) + tfric
              pload(1,ipoin) = pload(1,ipoin) + tfric
              resid(1,ipoin) = resid(1,ipoin) + tfric

c       print *, 'node = ',ipoin,'  ','frict = ', tfric,'  ',ikey
c       print *, coord(1,ipoin),veloc(1,ipoin)

            end if
          else if(nfric.eq.4) then
c.... tangential component (stick)
            ieqns = iffix(1,ipoin)
            if(ieqns.gt.0) then
              imaxa = maxad(ieqns)
              stiff(imaxa) = stiff(imaxa) + pnltc*dtime
              value = - pnltc*(coord(1,ipoin) - coori(1,ipoin))
              force(ieqns) = force(ieqns) + value
              pload(1,ipoin) = pload(1,ipoin) + value
              resid(1,ipoin) = resid(1,ipoin) + value
            end if
          end if
        end if
      end do 
      return
      end



