Sources Esope | Cast3M

pinoto
C PINOTO    SOURCE    CHAT      05/01/13    02:13:59     5004
C PINOTO     SOURCE    INSL       24/10/96
      SUBROUTINE PINOTO(EPSR,STRN,STRNR,SIGR,SIGMR,SIGM,S1,V1,D,IPLA,
     1 JFRIS,NSTRS,IFOUR,EPEQC,SEQC,EBC,EPEQ0,SEQ0,SEQB1,XE,NBNN,MELE,
     2 EQSTR1,EPSEQ1,AA,BB,DK1,DK2,ILOI,ALPHA,RB,EX,PXY,EPO,ICAL,wrk12)
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION S1(NSTRS),D(NSTRS,NSTRS),S2(6),EPSR(6)
      DIMENSION STRN(NSTRS),SIGMR(6),SIGR(6),STRNR(6)
      DIMENSION V1(4),V3(4),SIGM(NSTRS),XE(3,NBNN)
      DIMENSION SI0(6),ST0(6),DST(6),DSI(6),D1(6,6)
C
      SEGMENT WRK12
      real*8  bbet1,bbet2,bbet3,bbet4,bbet5,bbet6,bbet7,bbet8,bbet9
      real*8 bbet10,bbet11,bbet12,bbet13,bbet14,bbet15,bbet16,bbet17
      real*8 bbet18,bbet19,bbet20,sct,teta,DTR1,dtr2,bbet25
      real*8 bbet26,bbet27,bbet28,bbet29,bbet30,bbet31,bbet32,bbet33
      real*8 bbet34,bbet35,bbet36,bbet37,bbet38,bbet39,bbet40,bbet41
      real*8 bbet42,bbet43,bbet44,bbet45,bbet46,bbet47,bbet48,bbet49
      real*8 bbet50,bbet51,bbet52,bbet53,bbet54,bbet55
      integer ibet1,ibet2,ibet3,ibet4,ibet5,ibet6,ibet7,ibet8
      integer ibet9,ibet10,ibet11,ibet12,ibet13,ibet14,ibet15,ibet16
      ENDSEGMENT
*      COMMON /CINSA/ POUI(20),SCT,TETA,DTR1,DTR2,POUJ(31),IPOU(16)
C
C           ########################################################
C           *     TRACTION-COMPRESSION  OU  BI-TRACTION            *
C           *                                                      *
C           *       IPLA          = INDICE DE PLASTICITE           *
C           *                     =1 ECROUISSAGE                   *
C           *                     =2 SOFTENING                     *
C           *                     =3 RUPTURE (deformation > EMAX)  *
C           *                                                      *
C           *       JFRIS          = INDICE DE FISSURATION         *
C           *                     =0 PAS DE FISSURE                *
C           *                     =2 POINT FISSURE                 *
C           ########################################################
C----------------------------------------------------------------------
      SEQ00=SEQ0
      EPEQ00=EPEQ0
      CALL ZERO(S2,6,1)
      DO 11 I=1,NSTRS
        S1(I) =SIGMR(I)
        DSI(I)=SIGM(I)
        S2(I) =STRNR(I)
   11 CONTINUE
      IF(NSTRS.EQ.4.OR.NSTRS.EQ.6) THEN
        S2(3)=STRNR(4)
        S2(4)=STRNR(3)
      ENDIF
      S2(3)=S2(3)/2.D0
      CALL PRINC(S2,V3,NSTRS)
      S2(3)=S2(3)*2.D0
C----------------------------------------------------------------------
      IPLA =0
      TU=RB
      ITES=0
      IRUP=0
      CALL CRIOTO(SIGMR,SEQB1,FCRI,NSTRS,TU,AA,BB,DK1,DK2)
C----------------------------------------------------------------------
      IF(EPEQC.GE.EPO) THEN
C   --------------------------------------------------------------
C   *  ON TEST SI ON A DEPASSE LE PIC EN DEFORMATION EQUIVALENTE *
C   --------------------------------------------------------------
        IRUP=1
        ITES=1
        IPLA=2
        CALL SCALT(SIGM,SIGR,SI0,V1,SCT,NSTRS,DTAU,RB,AA,BB,DK1,DK2,
     &  ALPHA,RB,DTR1,DTR2,TETA)
        DO 10 I=1,NSTRS
          S1(I)=SI0(I)
  10    CONTINUE
        GOTO 300
      ENDIF
C==================================================================
      IF(ICAL.EQ.1) GOTO 200
C----------------------------------------------------------------------
      CALL CALPIN(IFOUR,STRN,SIGM,SIGR,S1,D,NSTRS,EBC,AA,BB,DK1,DK2,
     1 ILOI,RB,EX,PXY)
      CALL CRIOTO(S1,SEQB,FCRI,NSTRS,TU,AA,BB,DK1,DK2)
      IF(SEQB.LT.TU) GOTO 200
C----------------------------------------------------------------------
      DO  I=1,NSTRS
         DSI(I)=S1(I)-SIGR(I)
      END DO
      CALL SCALT(DSI,SIGR,SI0,V1,SCT,NSTRS,DTAU,RB,AA,BB,DK1,DK2,
     & ALPHA,RB,DTR1,DTR2,TETA)
      DO 21 I=1,NSTRS
         S1(I)=SI0(I)
  21  CONTINUE
C==================================================================
  300 CONTINUE
C              ***************************
C              * LE CRITERE EST VIOLE    *
C              ***************************
C
      IF(V1(1).GE.0.D0.OR.V1(2).GE.0.D0.OR.JFRIS.NE.0) THEN
C              *******************************************
C              * LE CRITERE EST VIOLE PAR FISSURATION    *
C              *******************************************
       TETA=V1(4)
       JFRIS=2
       IPLA=0
       CALL FISPLA(EPSR,STRN,STRNR,SIGR,DSI,S1,NSTRS,IFOUR,0,
     &  XE,NBNN,MELE,wrk12)
       GOTO 200
      ENDIF
C----------------------------------------------------------
      TETA=0.D0
      DTR1=0.D0
      DTR2=0.D0
      SCT =0.D0
      IF(IRUP.EQ.0) GOTO 200
C==================================================================
C              *******************************************
C              * LE CRITERE EST VIOLE EN BICOMPRESSION   *
C              *******************************************
C
      CALL CALPEC(IFOUR,STRN,SIGR,SIGM,S1,D,NSTRS,SEQC,EBC,EPEQC,
     1 EPSR,STRNR,JFRIS,IPLA,EPEQ00,SEQ00,XE,NBNN,MELE,EQSTR1,EPSEQ1,
     2 AA,BB,DK1,DK2,ILOI,RB,ALPHA,EX,PXY,EPO,wrk12)
C
C==================================================================
  200 CONTINUE
1991  FORMAT(18(1X,E12.5))
C----------------------------------------------------------------------
      RETURN
      END