Sources Esope | Cast3M

poirig
C POIRIG    SOURCE    SP204843  25/02/19    21:15:03     12161          
      SUBROUTINE POIRIG(IPIRG,IMUL)
C
C    EXTRACTION DE MAILLAGE D'UNE RIGIDITE
C
C----------------------------------------------------------------------
C    IMUL = 1  ON VEUT TOUS LES NOEUDS SAUF CEUX DES MULTIPLICATEURS
C    IMUL = 2  ON NE VEUT QUE LES NOEUDS DES MULTIPLICATEURS
C    IMUL = 3  ON NE VEUT QUE LES MULTILICATEURS ASSOCIES AUX JEUX
C              OU LES ELEMENTS GEOMETRQIUES DES CONTACTS UNILATERAUX
C----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
-INC SMRIGID
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
      logical ltelq
      SEGMENT ICPR(nbpts)
      SEGMENT MULTRI
          INTEGER ICTC(nbpts,3)
      ENDSEGMENT
      SEGMENT INDIC(0)
      CHARACTER NOMU(1)*4
      DATA NOMU  /'TRI3'/
 
      MRIGID=IPIRG
       if (mrigid.le.0) then
         call erreur(26)
         return
       endif
      SEGACT MRIGID
      NR=IRIGEL(/2)
      IPP1=0
      IF(IMUL.NE.3) GO TO 1000
C
C   cas de l'extraction des multiplicateurs associes a des conditions
C     unilaterales  option 'UNIL'
C
      CALL LIRMOT(NOMU,1,IRET,0)
C
      IF (IRET.EQ.1) THEN
C      cas ou l'on sort des tri3
        ITRI3 = 0
C        itri3 ets le nombre de tri3 generes
        SEGINI MULTRI
        DO 500 I=1,NR
          IF(IRIGEL(6,I).EQ.0) GO TO 500
          MELEME = IRIGEL( 1,I)
          IF (MELEME .EQ. 0) GO TO 500
          SEGACT MELEME
          IF ( ITYPEL.NE.22) THEN
            CALL ERREUR(5)
            RETURN
          ENDIF
          IF ( NUM(/1) .EQ. 5 ) THEN
C           les élements contiennent 3 points geometriques
            DO 510 J=1,NUM(/2)
              ITRI3 = ITRI3 + 1
              ICTC(ITRI3,1)=NUM(3,J)
              ICTC(ITRI3,2)=NUM(4,J)
              ICTC(ITRI3,3)=NUM(5,J)
 510        CONTINUE
          ENDIF
 500     CONTINUE
C           construction de l'objet meleme
         NBSOUS = 0
         NBREF = 0
         NBNN = 3
         NBELEM = ITRI3
         SEGINI MELEME
         ITYPEL = 4
         DO 520 I=1,ITRI3
C   ici on peut tester si les elements sont bien orientes
C       avec l'inversion 2,1 ca devrait marcher
           NUM(1,I)=ICTC(I,2)
           NUM(2,I)=ICTC(I,1)
           NUM(3,I)=ICTC(I,3)
 520     CONTINUE
         SEGSUP MULTRI
         CALL ACTOBJ('MAILLAGE',MELEME,1)
         CALL ECROBJ('MAILLAGE',MELEME)
         RETURN
      ENDIF
C
C        cas ou l'on ne sort que les points supports des
C        multiplicateurs de conditions unilaterales
C        octobre 2010 on met en queue les frottements
C
      SEGINI ICPR
      DO 1100 I=1,NR
        IF(IRIGEL(6,I).EQ.0) GO TO 1100
        ityp=irigel(6,i)
        MELEME = IRIGEL( 1,I)
        IF (MELEME .EQ. 0) GO TO 1100
        SEGACT MELEME
        IF ( ITYPEL.NE.22) THEN
            GO TO 1100
        ENDIF
        DO 1101 J=1,NUM(/2)
          ICPR(NUM(1,J))=ityp
 1101   CONTINUE
 1100 CONTINUE
      NBELEM=0
      DO 1102 I=1,ICPR(/1)
        if (icpr(i).ne.0) NBELEM=NBELEM + 1
 1102 CONTINUE
      NBNN = 1
      NBSOUS=0
      NBREF=0
      SEGINI MELEME
      IA=1
      ITYPEL=1
      DO 1103 I=1,ICPR(/1)
        IF( ICPR(I).ne.-1) GO TO 1103
        NUM(1,IA)=I
        IA = IA + 1
 1103 CONTINUE
      DO 1104 I=1,ICPR(/1)
        IF( ICPR(I).ne. 1) GO TO 1104
        NUM(1,IA)=I
        IA = IA + 1
 1104 CONTINUE
      DO 1105 I=1,ICPR(/1)
        IF( ICPR(I).ne. 2) GO TO 1105
        NUM(1,IA)=I
        IA = IA + 1
 1105 CONTINUE
      CALL ACTOBJ('MAILLAGE',MELEME,1)
      CALL ECROBJ('MAILLAGE',MELEME)
      SEGSUP ICPR
      RETURN
C
C        CAS IMUL = 1 OU 2
C
C  BOUCLE SUR LES RIGIDITES ELEMENTAIRES
C
 1000 CONTINUE
      SEGINI INDIC
      DO 191 I=1,NR
      IGEO=IRIGEL(1,I)
      MELEME=IGEO
      SEGACT MELEME
C
C  TEST SUR LE TYPE D ELEMENT ( EGAL A MULT ? )
C
C     write(6,*) 'poirig:itypel=',itypel
      IF(ITYPEL.NE.22) THEN
        IF(IMUL.EQ.2) GO TO 191
        IF(IPP1.EQ.0) THEN
          IPP1=IGEO
          GO TO 191
        ELSE
          IPP2=IGEO
          ltelq=.false.
          CALL FUSE(IPP1,IPP2,IRET,ltelq)
          IPP1=IRET
          GO TO 191
        ENDIF
      ELSE
C
C  TRAITEMENT D'UN ELEMENT DE TYPE BLOCAGE,RELATION,....
C
        IF(IMUL.EQ.1) THEN
          NBDEB=2
          NBFIN=NUM(/1)
        ELSE IF(IMUL.EQ.2) THEN
          NBDEB=1
          NBFIN=1
        ENDIF
      ENDIF
C
C     write(6,*) 'poirig:NBDEB,NBFIN=',NBDEB,NBFIN
      NBPOIN=NUM(/2)
      DO 199 J=1,NBPOIN
      DO 198 IJ=NBDEB,NBFIN
C
C  BOUCLE SUR LES POINTS EXISTANTS
C
      NINDIC=INDIC(/1)
      DO 302 IK=1,NINDIC,2
      IF(INDIC(IK).EQ.NUM(IJ,J)) GO TO 303
  302 CONTINUE
      INDIC(**)=NUM(IJ,J)
      INDIC(**)=ICOLOR(J)
  303 CONTINUE
  198 CONTINUE
  199 CONTINUE
  191 CONTINUE
      SEGDES MRIGID
C
C  REMPLISSAGE DU RESULTAT
C
      NBELEM=INDIC(/1)/2
C     write(6,*) 'poirig: NBELEM=',NBELEM
      IF (NBELEM.EQ.0.AND.IPP1.EQ.0.AND.IMUL.EQ.1) THEN
C     IF(IMUL.EQ.1) GO TO 211
        CALL ERREUR(503)
        RETURN
      ENDIF
      NBNN=1
      NBSOUS=0
      NBREF=0
      SEGINI IPT1
      IPT1.ITYPEL=1
      DO 1001 IP=1,NBELEM
      IP2=2*IP
      IP1=IP2-1
      IPT1.NUM(1,IP)=INDIC(IP1)
      IPT1.ICOLOR(IP)=INDIC(IP2)
 1001 CONTINUE
      IF(IPP1.EQ.0) THEN
      IPP1=IPT1
      ELSE
      ltelq=.false.
      CALL FUSE(IPP1,IPT1,IRET,ltelq)
      IPP1=IRET
      ENDIF
  211 SEGSUP INDIC
      CALL ACTOBJ('MAILLAGE',IPP1,1)
      CALL ECROBJ('MAILLAGE',IPP1)
      END