Numérotation des lignes :

C POIRIG    SOURCE    PV        20/03/30    21:22:15     10567                SUBROUTINE POIRIG(IPIRG,IMUL)CC    EXTRACTION DE MAILLAGE D'UNE RIGIDITECC----------------------------------------------------------------------C    IMUL = 1  ON VEUT TOUS LES NOEUDS SAUF CEUX DES MULTIPLICATEURSC    IMUL = 2  ON NE VEUT QUE LES NOEUDS DES MULTIPLICATEURSC    IMUL = 3  ON NE VEUT QUE LES MULTILICATEURS ASSOCIES AUX JEUXC              OU LES ELEMENTS GEOMETRQIUES DES CONTACTS UNILATERAUXC----------------------------------------------------------------------      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 1000CC   cas de l'extraction des multiplicateurs associes a des conditionsC     unilaterales  option 'UNIL'C      CALL LIRMOT(NOMU,1,IRET,0)C      IF (IRET.EQ.1) THENC      cas ou l'on sort des tri3        ITRI3 = 0C        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 ) THENC           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     CONTINUEC           construction de l'objet meleme         NBSOUS = 0         NBREF = 0         NBNN = 3         NBELEM = ITRI3         SEGINI MELEME         ITYPEL = 4         DO 520 I=1,ITRI3C   ici on peut tester si les elements sont bien orientesC       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      ENDIFCC        cas ou l'on ne sort que les points supports desC        multiplicateurs de conditions unilateralesC        octobre 2010 on met en queue les frottementsC      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      RETURNCC        CAS IMUL = 1 OU 2CC  BOUCLE SUR LES RIGIDITES ELEMENTAIRESC 1000 CONTINUE      SEGINI INDIC      DO 191 I=1,NR      IGEO=IRIGEL(1,I)      MELEME=IGEO      SEGACT MELEMECC  TEST SUR LE TYPE D ELEMENT ( EGAL A MULT ? )C      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      ELSECC  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      ENDIFC      NBPOIN=NUM(/2)      DO 199 J=1,NBPOIN      DO 198 IJ=NBDEB,NBFINCC  BOUCLE SUR LES POINTS EXISTANTSC      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 MRIGIDCC  REMPLISSAGE DU RESULTATC      NBELEM=INDIC(/1)/2      IF (NBELEM.EQ.0) THEN      IF(IMUL.EQ.1) GO TO 211** creation d'un maillage vide**    CALL ERREUR(18)**    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

© Cast3M 2003 - Tous droits réservés.
Mentions légales