Sources Esope | Cast3M

C COMEFF    SOURCE    BP208322  17/03/01    21:16:07     9325           
      SUBROUTINE COMEFF(IQMOD,IWRK52,IWRK53,IWRK54,IECOU,ICAS,IRETOU)
*----------------------------------------------------------
*     cas des milieux poreux isotropes:
*
*     appele par COMARA et COMSOR
*
*     rearrangement dans  XMAT
*     passage en contraintes effectives et reciproquement
*
* pb: IRETOU=1
*----------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC CCOPTIO
-INC SMMODEL
-INC SMCHAML
-INC DECHE
*
*  SEGMENT IECOU: sert de fourre-tout pour les initialisations
*  d'entiers
*
      SEGMENT IECOU
      INTEGER NYOG,NYNU,NYALFA,NYSMAX,NYN,NYM,NYKK,
     .  NYALF1,NYBET1,NYR,NYA,NYRHO,NSIGY,NNKX,NYKX,IND,
     .  NSOM,NINV,NINCMA,NCOMP,JELEM,LEGAUS,INAT,NCXMAT,
     .  LTRAC,MFRbi,IELE,NHRM,NBNNbi,NBELMb,ICARA,
     .  LW2bi,NDEF,NSTRSS,MFR1,NBGMAT,NELMAT,MSOUPA,
     .  NUMAT1,LENDO,NBBB,NNVARI,KERR1,MELEME
      INTEGER NYOG1,NYNU1,NYALFT1,NYSMAX1,NYN1,NYM1,
     .  NYKK1,NYALF2,NYBET2,NYR1,NYA1,NYQ1,NYRHO1,NSIGY1
      ENDSEGMENT
*
*
       imodel = iqmod
       wrk52 = iwrk52
******      segact wrk52*mod
       wrk53 = iwrk53
********      segact wrk53*mod
*       write(6,*) 'comeff ', mfrbi, idim,mele, ifour,icara,xcarb(/1)
*       write(6,*) 'comeff ', MFR, MFRBI, NSTRS
       ncara = xmat(/1)
       wrk54=iwrk54
       IRETOU=1
       NSTMU=2
       IF(IFOUR.GE.0) NSTMU=3
 
*
*      CAS MODELE EXTERIEUR
*
       IF(INPLAS.LT.0) GO TO 1990
 
 
*
*---------------------------------------------------------------------
*
        IF(ICAS.EQ.1) THEN
*
*
*             milieu poreux  cas elastique isotrope
*
           IF (MFRbi.EQ.33.AND.MATE.EQ.1) THEN
 
*
*         CAS DES JOINTS
*
             IF(MELE.GE.108.AND.MELE.LE.110)THEN
                NSTMU=2
                IF(IFOUR.GE.0) NSTMU=3
*
*             rearrangement
*
                LIND=3
                COB=XMAT(LIND)
                XMOB=XMAT(LIND+1)
 
                DO 1991 IC=1,NMATT-LIND-1
                XMAT(LIND-1+IC)=XMAT(LIND+1+IC)
                XMAT0(LIND-1+IC)=XMAT0(LIND+1+IC)
1991            CONTINUE
*
 
*                PRINT *,'NMATT=',NMATT
*                DO IJ=1,NMATT
*                WRITE(6,77882) XMAT(IJ)
*77882 FORMAT(2X,1PE12.5)
*                  ENDDO
 
                XMAT(NMATT-1)=COB
                XMAT0(NMATT-1)=COB
                XMAT(NMATT)=XMOB
                XMAT0(NMATT)=XMOB
*
*             calcul des contraintes effectives
*
                SIG0(NSTMU) =SIG0(NSTMU)  + COB* EPST0(NSTRS)
C
             ELSE
*
*            CAS MASSIF ISOTROPE
*
C
                IF(IFOUR.EQ.-3.OR.IFOUR.EQ.1) THEN
                  KERR0=99
                  GO TO 1000
                ENDIF
*
*             rearrangement
*
                LIND=5
                COB=XMAT(LIND)
                XMOB=XMAT(LIND+1)
                DO 1992 IC=1,NMATT-LIND-1
                XMAT(LIND-1+IC)=XMAT(LIND+1+IC)
                XMAT0(LIND-1+IC)=XMAT0(LIND+1+IC)
1992            CONTINUE
*
                XMAT(NMATT-1)=COB
                XMAT0(NMATT-1)=COB
                XMAT(NMATT)=XMOB
                XMAT0(NMATT)=XMOB
 
 
*                PRINT *,'NMATT=',NMATT
*                DO IJ=1,NMATT
*                WRITE(6,77882) XMAT(IJ)
*77882 FORMAT(2X,1PE12.5)
*                 ENDDO
 
*
*             calcul des contraintes effectives
*
                DO 1993 IC=1,3
                IF(IFOUR.EQ.-2.AND.IC.EQ.3) GO TO 1993
                SIG0(IC) =SIG0(IC)  + COB* EPST0(NSTRS)
1993            continue
             ENDIF
*
           ELSE
*
*            CAS NON PREVU
*
              GO TO 1000
 
           ENDIF
*
           GO TO 1990
        ENDIF
 
*
*---------------------------------------------------------------------
*               calcul des contraintes totales
*
        IF(ICAS.EQ.2) THEN
 
           IF (MFRbi.EQ.33.AND.MATE.EQ.1) THEN
*
*             attention : a prendre dans XMAT0 et pas XMAT
*
 
*
*         CAS DES JOINTS
*
             IF(MELE.GE.108.AND.MELE.LE.110)THEN
*
               NSTMU=2
               IF(IFOUR.GE.0) NSTMU=3
               COB= XMAT0(NMATT-1)
               XMOB=XMAT0(NMATT)
               IF(XMOB.EQ.0.D0) THEN
                 UNSURM=0.D0
               ELSE
                 UNSURM=1.D0/XMOB
               ENDIF
*
*              PRINT *, 'COB=',COB,'  XMOB=',XMOB
*              PRINT *, 'NSTMU=',NSTMU
*              PRINT *, 'NSTRS=',NSTRS
*              PRINT *, 'SIG0(NSTRS)=',SIG0(NSTRS)
*              PRINT *, 'DEPST(NSTRS)=',DEPST(NSTRS)
               SIGF(NSTRS) = SIG0(NSTRS)+DEPST(NSTRS)*UNSURM
     &                         +COB*DEPST(NSTMU)
               SIGF(NSTMU) = SIGF(NSTMU)
     &                    -COB*(EPST0(NSTRS)+DEPST(NSTRS))
 
             ELSE
 
*
*              CAS MASSIF ISOTROPE
*
                COB= XMAT0(NMATT-1)
                XMOB=XMAT0(NMATT)
                IF(XMOB.EQ.0.D0) THEN
                  UNSURM=0.D0
                ELSE
                  UNSURM=1.D0/XMOB
                ENDIF
*                PRINT *,' COB=', COB
*                IRETOU=1
*                GO TO 1000
 
                SIGF(NSTRS) = SIG0(NSTRS)+DEPST(NSTRS)*UNSURM
                DO 1994 IC=1,3
                  IF(IFOUR.EQ.-2.AND.IC.EQ.3) GO TO 1994
                  SIGF(IC) = SIGF(IC)
     &                    -COB*(EPST0(NSTRS)+DEPST(NSTRS))
*
*
                   SIGF(NSTRS) = SIGF(NSTRS)
     &                       +COB*DEPST(IC)
 
1994            CONTINUE
             ENDIF
*
           ELSE
*
*            CAS NON PREVU
*
              GO TO 1000
 
           ENDIF
 
           GO TO 1990
        ENDIF
 
 
*
 
1000   CONTINUE
       RETURN
*
1990   CONTINUE
 
 
 
       IRETOU=0
       RETURN
       END