C FCOUL1    SOURCE    CHAT      12/04/06    21:15:07     7348           
      SUBROUTINE FCOUL1(DEPSI,IPMODL,IPCHE1,IPCHE2,IPCAR,
     &                  SIGMA,IPCHE7,IPCHE8,IRETO,NSTRS2)
**********************************************************************
*
*     ECOULEMENT INELASTIQUE POUR LES MODELE A SECTION
*     Boucle sur les ss-zone du modele de section
*
**********************************************************************
*     Pierre Pegon (ISPRA) Juillet/Aout 1993
**********************************************************************
*
*  ENTREES:
*
*  DEPSI(6) INCREMENT DE DEFORMATION POUR LA FIBRE CENTRALE
*  IPMODL = POINTEUR SUR UN OBJET MMODEL
*  IPCHE1 = POINTEUR SUR UN MCHAML DE CONTRAINTES INITIALES
*  IPCHE2 = POINTEUR SUR UN MCHAML DE VARIABLES INTERNES INITIALES
*  IPCAR  = POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
*
* SORTIES:
*
*  SIGMA(6) ELEMENT DE REDUCTION DES EFFORT POUR LA FIBRE CENTRALE
*  IPCHE7 = POINTEUR SUR UN MCHAML DE CONTRAINTES
*  IPCHE8 = POINTEUR SUR UN MCHAML DE VARIABLES INTERNES
*
************************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*
-INC CCOPTIO
-INC SMCHAML
-INC SMELEME
-INC SMCOORD
-INC SMMODEL
-INC SMINTE
-INC CCHAMP
C
      DIMENSION DEPSI(NSTRS2),SIGMA(NSTRS2)

      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
*
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
*
      CHARACTER*8 CMATE
      CHARACTER*(NCONCH) CONM
      CHARACTER*16 MOMODL(10)
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      LOGICAL lsupva,lsupco,lsupma,lsupca
C
      IRETO=0
      NHRM=NIFOUR
C
C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE CONTRAINTES
C
      CALL  QUESUP(IPMODL,IPCHE1,5,0,ISUP1,IRET1)
      IF (ISUP1.GT.1) RETURN
*
*     VERIFICATION DU LIEU SUPPORT DU MCHAML DE VARIABLES INTERNES
*
      CALL  QUESUP(IPMODL,IPCHE2,5,0,ISUP2,IRET2)
      IF (ISUP2.GT.1) RETURN
C
C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
C
      CALL  QUESUP(IPMODL,IPCAR,5,0,ISUP5,IRET5)
      IF (ISUP5.GT.1) RETURN
C
C     ACTIVATION DU MODELE
C
      MMODEL=IPMODL
      SEGACT MMODEL
      NSOUS=KMODEL(/1)
C
C     CREATION DES 2 MCHELMS
C
      N1=NSOUS
      L1=11
      N3=6
      SEGINI MCHELM
      TITCHE='CONTRAINTES'
      IFOCHE=IFOUR
      IPCHE7=MCHELM
      L1=18
      SEGINI MCHEL1
      MCHEL1.TITCHE='VARIABLES INTERNES'
      MCHEL1.IFOCHE=IFOUR
      IPCHE8=MCHEL1
C
C     MISE A ZERO DES CONTRAINTES
C
      DO IE1=1,NSTRS2
        SIGMA(IE1)=0.D0
      ENDDO
C____________________________________________________________________
C
C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
C____________________________________________________________________
C
*-DC-
      EPSUP=-1.0D10
      EPINF= 1.0D10
*
      DAMAG= 0.0D0
      ETIQE= 0.0D0
*-DC-

      DO 1000 ISOUS=1,NSOUS
*
*   INITIALISATION
*
         NSTR=0
         MOSTRS=0
         IVASTR=0
         MOVARI=0
         NVARI=0
         NVARF=0
         IVARI=0
         NMATF=0
         NMATR=0
         MOMATR=0
         IVAMAT=0
         NCARA=0
         NCARF=0
         MOCARA=0
         IVACAR=0
         IVASTF=0
         IVARIF=0
C
C     ON RECUPERE L INFORMATION GENERALE
C
         IMODEL=KMODEL(ISOUS)
         SEGACT IMODEL
         IPMAIL=IMAMOD
         CONM  =CONMOD
         IMACHE(ISOUS)=IPMAIL
         CONCHE(ISOUS)=CONMOD
         MCHEL1.IMACHE(ISOUS)=IPMAIL
         MCHEL1.CONCHE(ISOUS)=CONMOD
*
         MELE=NEFMOD
         MELEME=IMAMOD
         SEGACT MELEME
         NBNN=NUM(/1)
         NBELEM=NUM(/2)
C+PPf
C     ON EVACUE LE CAS DU SEGS EN 3D
         IF(MELE.EQ.166.AND.IDIM.EQ.3)THEN
            SEGDES IMODEL
            CALL ERREUR(832)
            GOTO 888
         ENDIF
C+PPf
C
C     TRAITEMENT DU MODELE
C
         NFOR=FORMOD(/2)
         NMAT=MATMOD(/2)
C
C     NATURE DU MATERIAU
C
         CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INFIBR)
         IF (CMATE.EQ.' ')THEN
            SEGDES IMODEL
            CALL ERREUR(251)
            GOTO 888
         ENDIF
         IF(MATE.NE.1)THEN
            SEGDES,IMODEL
            CALL ERREUR(635)
            GOTO 888
         ENDIF
         CALL TEMANF(INFIBR,NIFIBR)
         IF((NIFIBR.EQ.0).AND.(INFIBR.NE.0))THEN
            CALL ERREUR(636)
            SEGDES,IMODEL
            GOTO 888
         ENDIF
         INFIBR=NIFIBR
*
C____________________________________________________________________
C
C     INFORMATION SUR L'ELEMENT FINI
C____________________________________________________________________
C
*         CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
*         IF (IERR.NE.0) THEN
*            SEGDES,IMODEL
*            GOTO 888
*         ENDIF
*         INFO=IPINF
         MFR  =INFELE(13)
         IPPORE=0
         IF(MFR.EQ.33) IPPORE=NBNN
         IF (MFR.NE.47)THEN
            CALL ERREUR(637)
            SEGDES IMODEL,MMODEL
            SEGSUP MCHELM,MCHEL1
            RETURN
         ENDIF
         NBG  =INFELE(6)
         NBGS =INFELE(4)
         NSTRS=INFELE(16)
         LRE  =INFELE(9)
         LHOOK=INFELE(10)
         LHOO2=LHOOK*LHOOK
*         MINTE=INFELE(11)
         MINTE=infmod(7)
        IPMINT=MINTE
        SEGACT,MINTE
*
*   REMPLISSAGE DES TABLEAUX INFCHE
*
         INFCHE(ISOUS,1)=0
         INFCHE(ISOUS,2)=0
         INFCHE(ISOUS,3)=NHRM
         INFCHE(ISOUS,4)=IPMINT
         INFCHE(ISOUS,5)=0
         INFCHE(ISOUS,6)=5
*
         MCHEL1.INFCHE(ISOUS,1)=0
         MCHEL1.INFCHE(ISOUS,2)=0
         MCHEL1.INFCHE(ISOUS,3)=NHRM
         MCHEL1.INFCHE(ISOUS,4)=IPMINT
         MCHEL1.INFCHE(ISOUS,5)=0
         MCHEL1.INFCHE(ISOUS,6)=5
C
C     CREATION DU TABLEAU INFOS
C
         CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
         IF (IRTD.EQ.0)THEN
            SEGDES IMODEL,MINTE
*            INFO=IPINF
*            SEGSUP INFO
            GOTO 888
         ENDIF
*
*       TRAITEMENT DU CHAMP DE CONTRAINTES
*
        if(lnomid(4).ne.0) then
         nomid=lnomid(4)
         segact nomid
         mostrs=nomid
         nstr=lesobl(/2)
         nfac=lesfac(/2)
         lsupco=.false.
        else
         lsupco=.true.
         CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
        endif
         IF (MOSTRS.EQ.0) THEN
            MOTERR(1:4)='CONT'
            MOTERR(5:8)=NOMTP(MELE)
            CALL ERREUR (76)
            SEGDES,IMODEL,MINTE
*            INFO=IPINF
*            SEGSUP INFO
            GOTO 888
         ENDIF
*
         NBTYPE=1
         SEGINI NOTYPE
         MOTYPE=NOTYPE
         TYPE(1)='REAL*8'
         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
         IF(IERR.NE.0)THEN
            SEGSUP NOTYPE
            GOTO 9990
         ENDIF
*
        IF (ISUP1.EQ.1) THEN
           CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE)
           IF(IERR.NE.0)THEN
             SEGSUP NOTYPE
             ISUP1=0
             GOTO 9990
            ENDIF
        ENDIF
*
*       TRAITEMENT DU CHAMP DE VARIABLES INTERNES
*
       if(lnomid(10).ne.0) then
         nomid=lnomid(10)
         segact nomid
         movari=nomid
         nvari=lesobl(/2)
         nvarf=lesfac(/2)
         lsupva=.false.
       else
         lsupva=.true.
         CALL IDVARI(MFR,IMODEL,MOVARI,NVARI,NVARF)
       endif
*       write(6,*) ' lnomid(10) nvari nvarf ', lnomid(10),nvari,nvarf
         IF (MOVARI.EQ.0) THEN
            MOTERR(1:4)='VARI'
            MOTERR(5:8)=NOMTP(MELE)
            CALL ERREUR (76)
            SEGSUP NOTYPE
            GOTO 9990
         ENDIF
*
         CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOVARI,MOTYPE,1,INFOS,3,IVARI)
         IF(IERR.NE.0)THEN
            SEGSUP NOTYPE
            GOTO 9990
         ENDIF
*
        NVART=NVARI+NVARF
        IF (ISUP2.EQ.1) THEN
           CALL VALCHE(IVARI,NVART,IPMINT,IPPORE)
           IF(IERR.NE.0)THEN
             SEGSUP NOTYPE
             ISUP2=0
             GOTO 9990
            ENDIF
        ENDIF
*
*   TRAITEMENT DU CHAMP DE CARACTERISTIQUES MATERIELLES
*
        if(lnomid(6).ne.0) then
         nomid=lnomid(6)
         segact nomid
         momatr=nomid
         nmatr=lesobl(/2)
         nmatf=lesfac(/2)
         lsupma=.false.
        else 
         lsupma=.true.
         CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF)
        endif
        IF (MOMATR.EQ.0) THEN
           MOTERR(1:4)='MATE'
           MOTERR(5:8)=NOMTP(MELE)
           CALL ERREUR (76)
           GOTO 9990
        ENDIF
*
        IF (NIFIBR.NE.8) THEN
         NBTYPE=1
         SEGINI NOTYPE
         MOTYPE=NOTYPE
         TYPE(1)='REAL*8'
*
        ELSE
          NBTYPE=13
          SEGINI NOTYPE
          MOTYPE=NOTYPE
          DO I=1,NBTYPE
            TYPE(I)='REAL*8'
          ENDDO
          TYPE(10)='POINTEUREVOLUTIO'
          TYPE(11)='POINTEUREVOLUTIO'
*
        ENDIF
*
        CALL KOMCHA(IPCAR,IPMAIL,CONM,MOMATR,MOTYPE,1,
     &                                  INFOS,3,IVAMAT)
        SEGSUP NOTYPE
        IF(IERR.NE.0)THEN
           GOTO 9990
        ENDIF
        NMATT=NMATR+NMATF
*
        IF (ISUP5.EQ.1) THEN
           CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE)
           IF(IERR.NE.0)THEN
              ISUP5=0
              GOTO 9990
           ENDIF
        ENDIF
*
*      TRAITEMENT DU CHAMP DE CARACTERISTIQUES GEOMETRIQUES
*
        if(lnomid(7).ne.0) then
         nomid=lnomid(7)
         segact nomid
         mocara=nomid
         ncara=lesobl(/2)
         ncarf=lesfac(/2)
         lsupca=.false.
        else 
         lsupca=.true.
         CALL IDCARB(MELE,IFOUR,MOCARA,NCARA,NCARF)
        endif
*
*        write(6,*) ' lnomid(7) ncara ncarf ' , lnomid(7),ncara,ncarf
        NBTYPE=1
        SEGINI NOTYPE
        MOTYPE=NOTYPE
        TYPE(1)='REAL*8'
*
        CALL KOMCHA(IPCAR,IPMAIL,CONM,MOCARA,MOTYPE,1,
     &                                     INFOS,3,IVACAR)
        SEGSUP NOTYPE
        IF(IERR.NE.0)THEN
           GOTO 9990
        ENDIF
        NCARR=NCARA+NCARF
*
        IF (ISUP5.EQ.1.AND.MOCARA.NE.0) THEN
           CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE)
           IF(IERR.NE.0)THEN
              ISUP5=0
              GOTO 9990
           ENDIF
        ENDIF
*
*      CREATION DES MCHAMLS DE LA SOUS ZONE
*
         NBPTEL=NBGS
         NEL=NBELEM
         N1PTEL=NBPTEL
         N1EL=NEL
*
*   CONTRAINTES
*
         N2=NSTRS
         SEGINI MCHAML
         ICHAML(ISOUS)=MCHAML
         NS=1
         NCOSOU=NSTRS
         SEGINI MPTVAL
         IVASTF=MPTVAL
         NOMID=MOSTRS
         SEGACT NOMID
         DO 1100 ICOMP=1,NSTRS
            NOMCHE(ICOMP)=LESOBL(ICOMP)
            TYPCHE(ICOMP)='REAL*8'
            N2PTEL=0
            N2EL=0
            SEGINI MELVAL
            IELVAL(ICOMP)=MELVAL
            IVAL(ICOMP)=MELVAL
1100     CONTINUE
         SEGDES NOMID
*
*    VARIABLES INTERNES
*
         N2=NVART
         SEGINI MCHAM1
         MCHEL1.ICHAML(ISOUS)=MCHAM1
         NS=1
         NCOSOU=NVART
         SEGINI MPTVAL
         IVARIF=MPTVAL
         NOMID=MOVARI
         SEGACT NOMID
         DO 1200 ICOMP=1,NVARI
            MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
            MCHAM1.TYPCHE(ICOMP)='REAL*8'
            N2PTEL=0
            N2EL=0
            SEGINI MELVAL
            MCHAM1.IELVAL(ICOMP)=MELVAL
            IVAL(ICOMP)=MELVAL
1200     CONTINUE
         DO 1201 ICOMP=NVARI+1,NVART
            MCHAM1.NOMCHE(ICOMP)=LESFAC(ICOMP)
            MCHAM1.TYPCHE(ICOMP)='REAL*8'
            N2PTEL=0
            N2EL=0
            SEGINI MELVAL
            MCHAM1.IELVAL(ICOMP)=MELVAL
            IVAL(ICOMP)=MELVAL
1201     CONTINUE
         SEGDES NOMID
*
*     APPEL A L'ECOULEMENT PROPREMENT DIT
*
         CALL FCOUL2(DEPSI,INFIBR,MELE,IPMAIL,IPMINT,NBPTEL,IVASTR,
     1        IVARI,IVAMAT,IVACAR,NSTRS,NVART,NMATT,NCARR,
     2        SIGMA,IVASTF,IVARIF,EPSUP,EPINF,DAMAG,NSTRS2)
*
 9990    CONTINUE
*
ckich contraction eventuelle des melval 
        MPTVAL = IVASTF
        do ICOMP=1,NSTRS
          ichin = ival(icomp)
          call comred(ichin)
          ielval(icomp) = ichin
C*        ival(icomp) = ichin
        enddo
     
        MPTVAL=IVARIF
        do ICOMP=1,NVARI
          ichin = ival(icomp)
          call comred(ichin)
          mcham1.ielval(icomp) = ichin
C*        ival(icomp) = ichin
        enddo
        do ICOMP=NVARI+1,NVART
          ichin = ival(icomp)
          call comred(ichin)
          mcham1.ielval(icomp) = ichin
C*        ival(icomp) = ichin
        enddo
*     DESACTIVATION DES SEGMENTS
*
         IF(ISUP1.EQ.1)THEN
            CALL DTMVAL (IVASTR,3)
         ELSE
            CALL DTMVAL (IVASTR,1)
         ENDIF
         IF(ISUP2.EQ.1)THEN
            CALL DTMVAL (IVARI,3)
         ELSE
            CALL DTMVAL (IVARI,1)
         ENDIF
         IF(ISUP5.EQ.1)THEN
            CALL DTMVAL (IVAMAT,3)
            CALL DTMVAL (IVACAR,3)
         ELSE
            CALL DTMVAL (IVAMAT,1)
            CALL DTMVAL (IVACAR,1)
         ENDIF
         IF (IERR.EQ.0) THEN
            CALL DTMVAL (IVASTF,1)
            CALL DTMVAL (IVARIF,1)
         ELSE
            CALL DTMVAL (IVASTF,3)
            CALL DTMVAL (IVARIF,3)
         END IF
*
         IF (MOCARA.NE.0) THEN
            NOMID=MOCARA
            if(lsupca)SEGSUP NOMID
         END IF
*
         IF (MOMATR.NE.0) THEN
            NOMID=MOMATR
            if(lsupma)SEGSUP NOMID
         END IF
*
         IF (MOVARI.NE.0) THEN
            NOMID=MOVARI
            if(lsupva)SEGSUP NOMID
         END IF
*
         IF (MOSTRS.NE.0) THEN
            NOMID=MOSTRS
            if(lsupco)SEGSUP NOMID
         END IF
*
*         IF (IPINF .NE.0) THEN
*             INFO=IPINF
*             SEGSUP INFO
*         END IF
*
         SEGDES,MINTE
         SEGDES MELEME,IMODEL
*
         IF (IERR.EQ.0) THEN
            SEGDES MCHAML,MCHAM1
         ELSE
            SEGSUP MCHAML,MCHAM1
            GOTO 888
         ENDIF
1000  CONTINUE
*
 888  CONTINUE
      SEGDES MMODEL
      IF (IERR.EQ.0)THEN
         IRETO=1
         SEGDES MCHELM,MCHEL1
      ELSE
         IRETO=0
         SEGSUP MCHELM,MCHEL1
      ENDIF
*
      RETURN
      END