Sources Esope | Cast3M

resi1
C RESI1     SOURCE    CB215821  24/04/12    21:17:08     11897          
      SUBROUTINE RESI1(IPMODE,IPCHEL,IPRIGI)
************************************************************************
*
*                             R E S I 1
*                             ---------
*
*
* FONCTION:
* ---------
*     CREATION DE LA MATRICE DE RESISTANCE
*     GESTION DES SEGMENTS ET TESTS DE COMPATIBILITE
*
* PARAMETRES:  (E)=ENTREE    (S)=SORTIE   (+)=CONTENU DANS UN COMMUN
* -----------
*
*     IPMODE   (E)  POINTEUR SUR LE SEGMENT MMODEL
*     IPCHEL   (E)  POINTEUR SUR LE SEGMENT MCHELM
*     IPRIGI   (S)  POINTEUR SUR LE SEGMENT MRIGID
*
* MODULES UTILISES:
* -----------------
*
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC SMRIGID
-INC SMCHAML
-INC SMELEME
-INC SMMODEL
*
*
* VARIABLES:
* ----------
*
*     NBNN        NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE
*     NEF         NUMERO DE L'ELEMENT FINI DANS NOMTP
*     NBMAIL      NOMBRE DE MAILLAGES ELEMENTAIRES
*     NBELEM      NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE
*
      LOGICAL OK
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     YANN STEPHAN, LE 28 JANVIER 1997 (COPIE DE TCOND1).
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77
*
************************************************************************
*
*
*       VERIFICATION DU LIEU SUPPORT DU CHAMELEM DE CARACTERISTIQUES
*
      CALL QUESUP(IPMODE,IPCHEL,2,0,ISUP,IRETCA)
      IF(ISUP.GT.1)RETURN
*
*     SI LE CHAMELEM EST APPUYE AUX NOEUDS ,ON CHANGE LE SUPPORT
*     POUR LES CENTRES DE GRAVITE
*
       IF(ISUP.EQ.1)THEN
          CALL CHASUP(IPMODE,IPCHEL,IPCHE1,IRET,2)
          IF(IRET.NE.0)THEN
             CALL ERREUR(IRET)
             RETURN
          ENDIF
       ELSE
          IPCHE1=IPCHEL
      ENDIF
*
*     ACTIVATION DES SEGMENTS MCHELM ET MMODEL
*
      MCHELM=IPCHE1
      SEGACT,MCHELM
      NBMAIC=IMACHE(/1)
*
      MMODEL=IPMODE
      SEGACT,MMODEL
      NBMAIM=KMODEL(/1)
      IF (NBMAIM.GT.NBMAIC) THEN
*
*        IL MANQUE LES CARACTERISTIQUES D'UNE OU PLUSIEURS PARTIES
*        DU MODELE
*
         CALL ERREUR(404)
         IF(ISUP.EQ.1)SEGSUP MCHELM
         RETURN
      ENDIF
*
      NBMAIL=NBMAIM
*
*     INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE
*
      NRIGE=6
      NRIGEL=NBMAIL
      SEGINI,MRIGID
      IPRIGI=MRIGID
      ICHOLE=0
      IMGEO1=0
      IMGEO2=0
      IFORIG=IFOUR
      ISUPEQ=0
      MTYMAT='RIGIDITE'
      NBGEOR=0
*
      DO 40 IA=1,NBMAIL
         IRIGEL(4,IA)=0
         COERIG(IA)=1.D0
  40     CONTINUE
*     END DO
      IFOI=0
*
*     BOUCLE SUR LES MAILLAGES ELEMENTAIRES,ZONE IMAIL
*
      DO 50 IMAIL=1,NBMAIL
*
         IFOI=IFOI+1
         IMODEL=KMODEL(IMAIL)
         SEGACT,IMODEL
         ICOQ = 0
         NEF=NEFMOD
         MELEME=IMAMOD
         SEGACT,MELEME
         NBNN=NUM(/1)
         NBELEM=NUM(/2)
*
*        REMPLIR LE SEGMENT DESCRIPTEUR DE L'OBJET RIGIDITE
**
         CALL RESI2(NEF,NBNN,IDESCR)
*
         IF(IMAIL.GT.1)THEN
            MRIGID=IPRIGI
            SEGACT,MRIGID*MOD
         ENDIF
*
         NLIGRE=NBNN
         descr=idescr
         segact descr
         nligrp=noelep(/1)
         nligrd=noeled(/1)
         segdes descr
         LVAL=(NBNN*(NBNN+1))/2
*
         NELRIG=NBELEM
         SEGINI,xMATRI
         IRIGEL(1,IMAIL)=IMAMOD
         IRIGEL(2,IMAIL)=0
         IRIGEL(3,IMAIL)=IDESCR
         IRIGEL(4,IMAIL)=xMATRI
         IRIGEL(5,IMAIL)=0
         IRIGEL(6,IMAIL)=0
*
         SEGDES,xMATRI,MRIGID
*
         CALL RESI3(NEF,IMAIL,IMODEL,IPCHE1,IPRIGI)
         IF (IERR.NE.0)GOTO 99
 50      CONTINUE
 99   CONTINUE
      IF(ISUP.EQ.1)SEGSUP MCHELM
      END