C CALP2     SOURCE    CHAT      11/03/16    21:16:20     6902           
      SUBROUTINE CALP2(IPTR1,IPTR2,IPMODL,LOC,IPTR4)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
*-----------------------------------------------------------
*
*     APPELE PAR CALP
*
*     AUTEUR : J.BRUN (AVRIL 90)
*
*     PARTIE CALCUL EN PEAU DES DEFORMATIONS
*
*-----------------------------------------------------------
*     PARAMETRES :
*        IPTR1 : POINTEUR SUR UN MCHAML DE TYPE CONTRAINTE
*        IPTR2 : POINTEUR SUR UN MCHAML DE TYPE CARACTERISTIQUE
*        IPMODL : POINTEUR SUR UN SEGMENT MMODEL
*        LOC   : MOT CLE INDIQUANT LE PLAN DE SORTIE DES R{SULTATS
*                SUPE  PEAU SUP
*                MOYE  PLAN MOYEN
*                INFE  PEAU INF
*        IPTR4 : POINTEUR SUR UN MCHMAL DU MEME TYPE QUE CELUI D'IPTR1
*                (SORTIE)
*
-INC SMMODEL
-INC SMCHAML
-INC SMELEME
-INC CCOPTIO
-INC CCHAMP
-INC CCGEOME
-INC SMCOORD
-INC SMINTE
*
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
*
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
*
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      CHARACTER*4 LOC
      CHARACTER*(NCONCH) CONM
      LOGICAL LSUPNO
C
      IPTR4 = 0
      IF (LOC.EQ.'SUPE') THEN
        I_LOC = 1
      ELSE IF (LOC.EQ.'MOYE') THEN
        I_LOC = 2
      ELSE IF (LOC.EQ.'INFE') THEN
        I_LOC = 3
      ELSE
        CALL ERREUR(5)
        RETURN
      ENDIF
C
C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE DEFORMATIONS
C
       CALL  QUESUP(IPMODL,IPTR1,5,0,ISUP1,IRET)
       IF (ISUP1.GT.1) RETURN
C
C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
C
       CALL  QUESUP(IPMODL,IPTR2,3,0,ISUP2,IRET1)
       IF (ISUP2.GT.1) RETURN

      NHRM=NIFOUR
C
C     ACTIVATION DU MODELE
C
      MMODEL=IPMODL
      SEGACT MMODEL
      NSOUS=KMODEL(/1)
C
C     CREATION DU MCHELM
C
      N1=NSOUS
      L1=12
      N3=6
      SEGINI MCHELM
      TITCHE='DEFORMATIONS'
      IFOCHE=IFOUR

*----------------------------------------------------------
*        TRAITEMENT POUR CHAQUE SOUS ZONE DU MODELE ORIGINE
*
      DO 1 NS=1,NSOUS

*   INITIALISATION
         IVADEF=0
         IVACAR=0
         MODEFO=0
         MOCARA=0
         lsupno=.false.

         IMODEL=KMODEL(NS)
         SEGACT IMODEL
         MELE=NEFMOD
*         CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
         MFR=INFELE(13)
         NBPGAU=INFELE(4)
*         MINTE=INFELE(11)
         minte=infmod(7)
         IPMING=MINTE
         IPPORE=0
         IF(MFR.EQ.33) IPPORE=NBNNE(NUMGEO(MELE))
*
         MELEME=IMAMOD
         SEGACT MELEME
         NBELEM=NUM(/2)
         SEGDES MELEME
         IPMAIL=IMAMOD
         CONM  =CONMOD
         IMACHE(NS)=IPMAIL
         CONCHE(NS)=CONMOD
C
C   COQUE INTEGREE OU PAS ?
C
      IF(INFMOD(/1).NE.0)THEN
          NPINT=INFMOD(1)
      ELSE
          NPINT=0
      ENDIF
      IF (NPINT.NE.0)THEN
         IF (I_LOC.EQ.2) THEN
            IF (MOD(INFMOD(1),2).EQ.0) THEN
               CALL ERREUR(722)
               RETURN
            ENDIF
            IENT1=(INFMOD(1)+1)/2
            IERR1=0
            CALL EXTRSK(IPTR1,IMODEL,NS,MCHELM,IENT1,IERR1)
            IF (IERR1.NE.0) GO TO 9990
            GO TO 1
         ELSE IF (I_LOC.EQ.1) THEN
            IENT1=INFMOD(1)
            IERR1=0
            CALL EXTRSK(IPTR1,IMODEL,NS,MCHELM,IENT1,IERR1)
            IF (IERR1.NE.0) GO TO 9990
            GO TO 1
         ELSE IF (I_LOC.EQ.3) THEN
            IERR1=0
            CALL EXTRSK(IPTR1,IMODEL,NS,MCHELM,1,IERR1)
            IF (IERR1.NE.0) GO TO 9990
            GO TO 1
         ENDIF
      ENDIF
C
C     CREATION DU TABLEAU INFOS
C
        CALL IDENT(IPMAIL,CONM,IPTR1,IPTR2,INFOS,IRTD)
        IF (IRTD.EQ.0) GOTO 9990
C
        INFCHE(NS,1)=1
        INFCHE(NS,2)=0
        INFCHE(NS,3)=NHRM
        INFCHE(NS,4)=MINTE
        INFCHE(NS,5)=1
        INFCHE(NS,6)=5
C____________________________________________________________________
C
C     RECHERCHE DES NOMS DE COMPOSANTES
C____________________________________________________________________
C
      if(lnomid(5).ne.0) then
        nomid=lnomid(5)
        segact nomid
        ndef=lesobl(/2)
        nfac=lesfac(/2)
        modefo=nomid    
       else  
        lsupno=.true.      
        CALL IDDEFO(IMODEL,IFOUR,MODEFO,NDEF,NFAC)
      endif  
C
C     VERIFICATION DE LEUR PRESENCE
C____________________________________________________________________
C
      NBTYPE=1
      SEGINI NOTYPE
      MOTYPE=NOTYPE
      TYPE(1)='REAL*8'
      CALL KOMCHA(IPTR1,IPMAIL,CONM,MODEFO,MOTYPE,1,INFOS,3,IVADEF)
      SEGSUP NOTYPE
      IF (IERR.NE.0) GOTO 9990
*
      SEGACT,MINTE
      IF (ISUP1.EQ.1) THEN
            CALL VALCHE(IVADEF,NDEF,IPMING,IPPORE)
      ENDIF
C
C     RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
C
      N1PTEL=0
      N1EL=0
      MPTVAL=IVADEF
      DO 110 IO=1,NDEF
        MELVAL=IVAL(IO)
        N1PTEL=MAX(N1PTEL,VELCHE(/1))
        N1EL  =MAX(N1EL  ,VELCHE(/2))
 110  CONTINUE
      NBGSTR=N1PTEL
      IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
        N1PTEL=1
      ELSE
        N1PTEL=NBPGAU
      ENDIF
      NBPTEL=N1PTEL
      NEL=N1EL
C____________________________________________________________________
C
* TRAITEMENT DES CHAMPS DE CARACTERISTIQUES                   *
C____________________________________________________________________
C
           NBROBL=0
           NBRFAC=0
           NOMID=0
           IVECT=0
*
* EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
*
         IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
           NBROBL=1
           NBRFAC=1
           SEGINI NOMID
           LESOBL(1)='EPAI'
           LESFAC(1)='EXCE'
*
           NBTYPE=1
           SEGINI NOTYPE
           TYPE(1)='REAL*8'
*
*        CARACTERISTIQUES POUR LES POUTRES
*
         ELSE IF (MFR.EQ.7 ) THEN
           NBROBL=2
           NBRFAC=0
           SEGINI NOMID
           LESOBL(1)='DY  '
           LESOBL(2)='DZ  '
*
           NBTYPE=1
           SEGINI NOTYPE
           TYPE(1)='REAL*8'
*
* CARACTERISTIQUES POUR LES TUYAUX
*
         ELSE IF (MFR.EQ.13) THEN
           NBROBL=2
           NBRFAC=2
           SEGINI NOMID
           LESOBL(1)='EPAI'
           LESOBL(2)='RAYO'
           LESFAC(1)='RACO'
           LESFAC(2)='PRES'
*
           NBTYPE=1
           SEGINI NOTYPE
           TYPE(1)='REAL*8'
         ENDIF
*
         MOCARA=NOMID
         NCARA=NBROBL
         NCARF=NBRFAC
         NCARR=NCARA+NCARF
         IF (MOCARA.NE.0) THEN
           MOTYPE=NOTYPE
         CALL KOMCHA(IPTR2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,
     $                IVACAR)
          SEGSUP NOTYPE
          IF (IERR.NE.0) GOTO 9990
*
          IF (ISUP2.EQ.1) THEN
            CALL VALCHE(IVACAR,NCARR,IPMING,IPPORE)
          ENDIF
         ENDIF

          N2=6
          SEGINI MCHAML
          ICHAML(NS)=MCHAML
          NOMCHE(1)='EPXX'
          TYPCHE(1)='REAL*8'
          NOMCHE(2)='EPYY'
          TYPCHE(2)='REAL*8'
          NOMCHE(3)='EPZZ'
          TYPCHE(3)='REAL*8'
          NOMCHE(4)='RTXY'
          TYPCHE(4)='REAL*8'
          NOMCHE(5)='RTYZ'
          TYPCHE(5)='REAL*8'
          NOMCHE(6)='RTXZ'
          TYPCHE(6)='REAL*8'
          N2PTEL=0
          N2EL=0

*-----------------------------------------------------------
*           CHAQUE MELVAL = COMPOSANTE SELON SIGMA
*
            SEGINI MELVA1,MELVA2,MELVA3,MELVA4,MELVA5,MELVA6
            IELVAL(1)=MELVA1
            IELVAL(2)=MELVA2
            IELVAL(3)=MELVA3
            IELVAL(4)=MELVA4
            IELVAL(5)=MELVA5
            IELVAL(6)=MELVA6
*
*--
*        BRANCHEMENT SELON ELEMENT FINI
*--
*        COQ3,COQ2,DKT
         IF ((MELE.EQ.27).OR.(MELE.EQ.28).OR.(MELE.EQ.44)) GOTO 3000
*        POUTRE
         IF (MELE.EQ.29) GOTO 2000
*        COQ4 ,DST
         IF (MELE.EQ.49.OR.MELE.EQ.93) GOTO 5000
*--
*        AUCUNE CREATION CAR NE SAIT PAS FAIRE POUR L'ELEMENT
*--
         MOTERR(1:4) =NOMTP(MELE)
         MOTERR(5:12)='CALP    '
         CALL ERREUR(86)
         SEGSUP MELVA1,MELVA2,MELVA2,MELVA3,MELVA4,MELVA5,MELVA6,MCHAML
         GOTO 9990
*
*-----------------------------------------------------------
*        POUTRE+DEFORMATION
*-----------------------------------------------------------
 2000     CONTINUE
            DO 2010 N2=1,NEL
               DO 2011 N1=1,NBPTEL
*
                  MPTVAL=IVADEF
*
                  MELVAL=IVAL(1)
                  EPS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(2)
                  GXY=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(3)
                  GXZ=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(4)
                  CX=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(5)
                  CY=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(6)
                  CZ=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MPTVAL=IVACAR
*
                  MELVAL=IVAL(1)
                  PY=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
                  MELVAL=IVAL(2)
                  PZ=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
*  CALCUL DES CONTRAINTES REELLES
                  MELVA1.VELCHE(N1,N2)=EPS-(PY*CZ)+(PZ*CY)
                  MELVA2.VELCHE(N1,N2)=0.
                  MELVA3.VELCHE(N1,N2)=0.
                  MELVA4.VELCHE(N1,N2)=GXY
                  MELVA5.VELCHE(N1,N2)=0.
                  MELVA6.VELCHE(N1,N2)=GXZ
 2011           CONTINUE
 2010        CONTINUE
*
         SEGDES MELVA1,MELVA2,MELVA2,MELVA3,MELVA4,MELVA5,MELVA6,MCHAML
*
         GOTO 510
*
*-----------------------------------------------------------
*        COQ2,COQ3,DKT + DEFORMATIONS
*-----------------------------------------------------------
 3000     CONTINUE
            IF (IFOUR.EQ.2.OR.IFOUR.EQ.1) THEN
               DO 3010 N2=1,NEL
                  DO 3011 N1=1,NBPTEL
*
                     MPTVAL=IVADEF
*
                     MELVAL=IVAL(1)
                     EPSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(2)
                     EPTT=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(3)
                     GAST=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(4)
                     RTSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(5)
                     RTTT=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(6)
                     RTST=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MPTVAL=IVACAR
*
                     MELVAL=IVAL(1)
                     EPAI=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     IF (I_LOC.EQ.3) THEN
                        r_z = 0.5 * EPAI
                        MELVA1.VELCHE(N1,N2)=EPSS-r_z*RTSS
                        MELVA2.VELCHE(N1,N2)=EPTT-r_z*RTTT
                        MELVA3.VELCHE(N1,N2)=0.
                        MELVA4.VELCHE(N1,N2)=GAST-r_z*RTST
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ELSE IF (I_LOC.EQ.1) THEN
                        r_z = 0.5 * EPAI
                        MELVA1.VELCHE(N1,N2)=EPSS+r_z*RTSS
                        MELVA2.VELCHE(N1,N2)=EPTT+r_z*RTTT
                        MELVA3.VELCHE(N1,N2)=0.
                        MELVA4.VELCHE(N1,N2)=GAST+r_z*RTST
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ELSE IF (I_LOC.EQ.2) THEN
                        MELVA1.VELCHE(N1,N2)=EPSS
                        MELVA2.VELCHE(N1,N2)=EPTT
                        MELVA3.VELCHE(N1,N2)=0.
                        MELVA4.VELCHE(N1,N2)=GAST
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ENDIF
 3011                 CONTINUE
 3010            CONTINUE
             ENDIF
*
            IF (IFOUR.EQ.0) THEN
               DO 3012 N2=1,NEL
                  DO 3013 N1=1,NBPTEL
*
                     MPTVAL=IVADEF
*
                     MELVAL=IVAL(1)
                     EPSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(2)
                     EPTT=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(3)
                     RTSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(4)
                     RTTT=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MPTVAL=IVACAR
*
                     MELVAL=IVAL(1)
                     EPAI=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     IF (I_LOC.EQ.3) THEN
                        r_z = 0.5 * EPAI
                        MELVA1.VELCHE(N1,N2)=EPSS-r_z*RTSS
                        MELVA2.VELCHE(N1,N2)=EPTT-r_z*RTTT
                        MELVA3.VELCHE(N1,N2)=0.
                        MELVA4.VELCHE(N1,N2)=0.
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ELSE IF (I_LOC.EQ.1) THEN
                        r_z = 0.5 * EPAI
                        MELVA1.VELCHE(N1,N2)=EPSS+r_z*RTSS
                        MELVA2.VELCHE(N1,N2)=EPTT+r_z*RTTT
                        MELVA3.VELCHE(N1,N2)=0.
                        MELVA4.VELCHE(N1,N2)=0.
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ELSE IF (I_LOC.EQ.2) THEN
                        MELVA1.VELCHE(N1,N2)=EPSS
                        MELVA2.VELCHE(N1,N2)=EPTT
                        MELVA3.VELCHE(N1,N2)=0.
                        MELVA4.VELCHE(N1,N2)=0.
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ENDIF
 3013                 CONTINUE
 3012            CONTINUE
             ENDIF
*
            IF (IFOUR.EQ.-1.OR.IFOUR.EQ.-2) THEN
               DO 3014 N2=1,NEL
                  DO 3015 N1=1,NBPTEL
*
                     MPTVAL=IVADEF
*
                     MELVAL=IVAL(1)
                     EPSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(2)
                     EPZZ=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(3)
                     RTSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(4)
                     RTZZ=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MPTVAL=IVACAR
*
                     MELVAL=IVAL(1)
                     EPAI=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     IF (I_LOC.EQ.3) THEN
                        r_z = 0.5 * EPAI
                        MELVA1.VELCHE(N1,N2)=EPSS-r_z*RTSS
                        MELVA2.VELCHE(N1,N2)=EPZZ-r_z*RTZZ
                        MELVA3.VELCHE(N1,N2)=0.
                        MELVA4.VELCHE(N1,N2)=0.
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ELSE IF (I_LOC.EQ.1) THEN
                        r_z = 0.5 * EPAI
                        MELVA1.VELCHE(N1,N2)=EPSS+r_z*RTSS
                        MELVA2.VELCHE(N1,N2)=EPZZ+r_z*RTZZ
                        MELVA3.VELCHE(N1,N2)=0.
                        MELVA4.VELCHE(N1,N2)=0.
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ELSE IF (I_LOC.EQ.2) THEN
                        MELVA1.VELCHE(N1,N2)=EPSS
                        MELVA2.VELCHE(N1,N2)=EPZZ
                        MELVA3.VELCHE(N1,N2)=0.
                        MELVA4.VELCHE(N1,N2)=0.
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ENDIF
 3015                 CONTINUE
 3014            CONTINUE
             ENDIF
            IF (IFOUR.EQ.-3) THEN
               DO 3016 N2=1,NEL
                  DO 3017 N1=1,NBPTEL
*
                     MPTVAL=IVADEF
*
                     MELVAL=IVAL(1)
                     EPSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(2)
                     EPZZ=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(3)
                     RTSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MELVAL=IVAL(4)
                     RTZZ=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     MPTVAL=IVACAR
*
                     MELVAL=IVAL(1)
                     EPAI=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                     IF (I_LOC.EQ.3) THEN
                        r_z = 0.5 * EPAI
                        MELVA1.VELCHE(N1,N2)=EPSS-r_z*RTSS
                        MELVA2.VELCHE(N1,N2)=0.
                        MELVA3.VELCHE(N1,N2)=EPZZ-r_z*RTZZ
                        MELVA4.VELCHE(N1,N2)=0.
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ELSE IF (I_LOC.EQ.1) THEN
                        r_z = 0.5 * EPAI
                        MELVA1.VELCHE(N1,N2)=EPSS+r_z*RTSS
                        MELVA2.VELCHE(N1,N2)=0.
                        MELVA3.VELCHE(N1,N2)=EPZZ+r_z*RTZZ
                        MELVA4.VELCHE(N1,N2)=0.
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ELSE IF (I_LOC.EQ.2) THEN
                        MELVA1.VELCHE(N1,N2)=EPSS
                        MELVA2.VELCHE(N1,N2)=0.
                        MELVA3.VELCHE(N1,N2)=EPZZ
                        MELVA4.VELCHE(N1,N2)=0.
                        MELVA5.VELCHE(N1,N2)=0.
                        MELVA6.VELCHE(N1,N2)=0.
                     ENDIF
 3017                 CONTINUE
 3016            CONTINUE
             ENDIF
         SEGDES MELVA1,MELVA2,MELVA2,MELVA3,MELVA4,MELVA5,MELVA6,MCHAML
         GOTO 510
*-----------------------------------------------------------
*        COQ4,DST + DEFORMATIONS
*-----------------------------------------------------------
 5000     CONTINUE
            DO 5010 N2=1,NEL
               DO 5011 N1=1,NBPTEL
*
                  MPTVAL=IVADEF

                  MELVAL=IVAL(1)
                  EPSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(2)
                  EPTT=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(3)
                  GAST=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(4)
                  RTSS=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))

                  MELVAL=IVAL(5)
                  RTTT=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(6)
                  RTST=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(7)
                  GASN=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MELVAL=IVAL(8)
                  GATN=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  MPTVAL=IVACAR
*
                  MELVAL=IVAL(1)
                  EPAI=VELCHE(MIN(N1,VELCHE(/1)),MIN(N2,VELCHE(/2)))
*
                  IF (I_LOC.EQ.3) THEN
                     r_z = 0.5 * EPAI
                     MELVA1.VELCHE(N1,N2)=EPSS-r_z*RTSS
                     MELVA2.VELCHE(N1,N2)=EPTT-r_z*RTTT
                     MELVA3.VELCHE(N1,N2)=0.
                     MELVA4.VELCHE(N1,N2)=GAST-r_z*RTST
                     MELVA5.VELCHE(N1,N2)=GATN
                     MELVA6.VELCHE(N1,N2)=GASN
                  ELSE IF (I_LOC.EQ.1) THEN
                     r_z = 0.5 * EPAI
                     MELVA1.VELCHE(N1,N2)=EPSS+r_z*RTSS
                     MELVA2.VELCHE(N1,N2)=EPTT+r_z*RTTT
                     MELVA3.VELCHE(N1,N2)=0.
                     MELVA4.VELCHE(N1,N2)=GAST+r_z*RTST
                     MELVA5.VELCHE(N1,N2)=GATN
                     MELVA6.VELCHE(N1,N2)=GASN
                  ELSE IF (I_LOC.EQ.2) THEN
                     MELVA1.VELCHE(N1,N2)=EPSS
                     MELVA2.VELCHE(N1,N2)=EPTT
                     MELVA3.VELCHE(N1,N2)=0.
                     MELVA4.VELCHE(N1,N2)=GAST
                     MELVA5.VELCHE(N1,N2)=GATN
                     MELVA6.VELCHE(N1,N2)=GASN
                  ENDIF

 5011           CONTINUE
 5010        CONTINUE
*
         SEGDES MELVA1,MELVA2,MELVA2,MELVA3,MELVA4,MELVA5,MELVA6,MCHAML
C_______________________________________________________________________
C
C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE NS
C_______________________________________________________________________
C
  510 CONTINUE
C
 9990 CONTINUE
      SEGDES IMODEL
      SEGDES,MINTE
*
      IF (ISUP1.EQ.1) THEN
               CALL DTMVAL(IVADEF,3)
      ELSE
               CALL DTMVAL(IVADEF,1)
      ENDIF
*
      IF (ISUP2.EQ.1) THEN
               CALL DTMVAL(IVACAR,3)
      ELSE
               CALL DTMVAL(IVACAR,1)
      ENDIF
      NOMID=MODEFO
      IF (lsupno.and.MODEFO.NE.0)SEGSUP NOMID
      NOMID=MOCARA
      IF (MOCARA.NE.0) SEGSUP NOMID

*  EN CAS D'ERREUR
        IF (IERR.NE.0) THEN
          SEGSUP,MCHELM
          IPTR4 = 0
          GOTO 999
        ENDIF

  1   CONTINUE
*
      SEGDES,MCHELM
      IPTR4 = MCHELM

 999  CONTINUE
      SEGDES,MMODEL
*
      RETURN
      END