1 : C POIRIG SOURCE KICH 12/10/17 21:15:01 7531 2 : SUBROUTINE POIRIG(IPIRG,IMUL) 3 : C 4 : C EXTRACTION DE MAILLAGE D'UNE RIGIDITE 5 : C 6 : C---------------------------------------------------------------------- 7 : C IMUL = 1 ON VEUT TOUS LES NOEUDS SAUF CEUX DES MULTIPLICATEURS 8 : C IMUL = 2 ON NE VEUT QUE LES NOEUDS DES MULTIPLICATEURS 9 : C IMUL = 3 ON NE VEUT QUE LES MULTILICATEURS ASSOCIES AUX JEUX 10 : C OU LES ELEMENTS GEOMETRQIUES DES CONTACTS UNILATERAUX 11 : C---------------------------------------------------------------------- 12 : IMPLICIT INTEGER(I-N) 13 : -INC SMRIGID 14 : -INC CCOPTIO 15 : -INC SMELEME 16 : -INC SMCOORD 17 : logical ltelq 18 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 19 : SEGMENT MULTRI 20 : INTEGER ICTC(XCOOR(/1)/(IDIM+1),3) 21 : ENDSEGMENT 22 : SEGMENT INDIC(0) 23 : CHARACTER NOMU(1)*4 24 : DATA NOMU /'TRI3'/ 25 : 26 : MRIGID=IPIRG 27 : if (mrigid.le.0) then 27 : call erreur(26) 28 : return 29 : endif 30 : SEGACT MRIGID 31 : NR=IRIGEL(/2) 32 : IPP1=0 33 : IF(IMUL.NE.3) GO TO 1000 34 : C 35 : C cas de l'extraction des multiplicateurs associes a des conditions 36 : C unilaterales option 'UNIL' 37 : C 37 : CALL LIRMOT(NOMU,1,IRET,0) 38 : C 39 : IF (IRET.EQ.1) THEN 40 : C cas ou l'on sort des tri3 41 : ITRI3 = 0 42 : C itri3 ets le nombre de tri3 generes 43 : SEGINI MULTRI 44 : DO 500 I=1,NR 45 : IF(IRIGEL(6,I).EQ.0) GO TO 500 46 : MELEME = IRIGEL( 1,I) 47 : IF (MELEME .EQ. 0) GO TO 500 48 : SEGACT MELEME 49 : IF ( ITYPEL.NE.22) THEN 49 : CALL ERREUR(5) 50 : SEGDES MELEME 51 : RETURN 52 : ENDIF 53 : IF ( NUM(/1) .EQ. 5 ) THEN 54 : C les élements contiennent 3 points geometriques 55 : DO 510 J=1,NUM(/2) 56 : ITRI3 = ITRI3 + 1 57 : ICTC(ITRI3,1)=NUM(3,J) 58 : ICTC(ITRI3,2)=NUM(4,J) 59 : ICTC(ITRI3,3)=NUM(5,J) 60 : 510 CONTINUE 61 : ENDIF 62 : SEGDES MELEME 63 : 500 CONTINUE 64 : C construction de l'objet meleme 65 : NBSOUS = 0 66 : NBREF = 0 67 : NBNN = 3 68 : NBELEM = ITRI3 69 : SEGINI MELEME 70 : ITYPEL = 4 71 : DO 520 I=1,ITRI3 72 : C ici on peut tester si les elements sont bien orientes 73 : C avec l'inversion 2,1 ca devrait marcher 74 : NUM(1,I)=ICTC(I,2) 75 : NUM(2,I)=ICTC(I,1) 76 : NUM(3,I)=ICTC(I,3) 77 : 520 CONTINUE 78 : SEGDES MELEME 79 : SEGSUP MULTRI 79 : CALL ECROBJ('MAILLAGE',MELEME) 80 : RETURN 81 : ENDIF 82 : C 83 : C cas ou l'on ne sort que les points supports des 84 : C multiplicateurs de conditions unilaterales 85 : C octobre 2010 on met en queue les frottements 86 : C 87 : SEGINI ICPR 88 : DO 1100 I=1,NR 89 : IF(IRIGEL(6,I).EQ.0) GO TO 1100 90 : ityp=irigel(6,i) 91 : MELEME = IRIGEL( 1,I) 92 : IF (MELEME .EQ. 0) GO TO 1100 93 : SEGACT MELEME 94 : IF ( ITYPEL.NE.22) THEN 95 : SEGDES MELEME 96 : GO TO 1100 97 : ENDIF 98 : DO 1101 J=1,NUM(/2) 99 : ICPR(NUM(1,J))=ityp 100 : 1101 CONTINUE 101 : SEGDES MELEME 102 : 1100 CONTINUE 103 : NBELEM=0 104 : DO 1102 I=1,ICPR(/1) 105 : if (icpr(i).ne.0) NBELEM=NBELEM + 1 106 : 1102 CONTINUE 107 : NBNN = 1 108 : NBSOUS=0 109 : NBREF=0 110 : SEGINI MELEME 111 : IA=1 112 : ITYPEL=1 113 : DO 1103 I=1,ICPR(/1) 114 : IF( ICPR(I).ne.-1) GO TO 1103 115 : NUM(1,IA)=I 116 : IA = IA + 1 117 : 1103 CONTINUE 118 : DO 1104 I=1,ICPR(/1) 119 : IF( ICPR(I).ne. 1) GO TO 1104 120 : NUM(1,IA)=I 121 : IA = IA + 1 122 : 1104 CONTINUE 123 : DO 1105 I=1,ICPR(/1) 124 : IF( ICPR(I).ne. 2) GO TO 1105 125 : NUM(1,IA)=I 126 : IA = IA + 1 127 : 1105 CONTINUE 128 : SEGDES MELEME 128 : CALL ECROBJ('MAILLAGE',MELEME) 129 : SEGSUP ICPR 130 : RETURN 131 : C 132 : C CAS IMUL = 1 OU 2 133 : C 134 : C BOUCLE SUR LES RIGIDITES ELEMENTAIRES 135 : C 136 : 1000 CONTINUE 137 : SEGINI INDIC 138 : DO 191 I=1,NR 139 : IGEO=IRIGEL(1,I) 140 : MELEME=IGEO 141 : SEGACT MELEME 142 : C 143 : C TEST SUR LE TYPE D ELEMENT ( EGAL A MULT ? ) 144 : C 145 : IF(ITYPEL.NE.22) THEN 146 : SEGDES MELEME 147 : IF(IMUL.EQ.2) GO TO 191 148 : IF(IPP1.EQ.0) THEN 149 : IPP1=IGEO 150 : GO TO 191 151 : ELSE 152 : IPP2=IGEO 153 : ltelq=.false. 153 : CALL FUSE(IPP1,IPP2,IRET,ltelq) 154 : IPP1=IRET 155 : GO TO 191 156 : ENDIF 157 : ELSE 158 : C 159 : C TRAITEMENT D'UN ELEMENT DE TYPE BLOCAGE,RELATION,.... 160 : C 161 : IF(IMUL.EQ.1) THEN 162 : NBDEB=2 163 : NBFIN=NUM(/1) 164 : ELSE IF(IMUL.EQ.2) THEN 165 : NBDEB=1 166 : NBFIN=1 167 : ENDIF 168 : ENDIF 169 : C 170 : NBPOIN=NUM(/2) 171 : DO 199 J=1,NBPOIN 172 : DO 198 IJ=NBDEB,NBFIN 173 : C 174 : C BOUCLE SUR LES POINTS EXISTANTS 175 : C 176 : NINDIC=INDIC(/1) 177 : DO 302 IK=1,NINDIC,2 178 : IF(INDIC(IK).EQ.NUM(IJ,J)) GO TO 303 179 : 302 CONTINUE 180 : INDIC(**)=NUM(IJ,J) 181 : INDIC(**)=ICOLOR(J) 182 : 303 CONTINUE 183 : 198 CONTINUE 184 : 199 CONTINUE 185 : SEGDES MELEME 186 : 191 CONTINUE 187 : SEGDES MRIGID 188 : C 189 : C REMPLISSAGE DU RESULTAT 190 : C 191 : NBELEM=INDIC(/1)/2 192 : IF (NBELEM.EQ.0) THEN 193 : IF(IMUL.EQ.1) GO TO 211 193 : CALL ERREUR(18) 194 : RETURN 195 : ENDIF 196 : NBNN=1 197 : NBSOUS=0 198 : NBREF=0 199 : SEGINI IPT1 200 : IPT1.ITYPEL=1 201 : DO 1001 IP=1,NBELEM 202 : IP2=2*IP 203 : IP1=IP2-1 204 : IPT1.NUM(1,IP)=INDIC(IP1) 205 : IPT1.ICOLOR(IP)=INDIC(IP2) 206 : 1001 CONTINUE 207 : SEGDES IPT1 208 : IF(IPP1.EQ.0) THEN 209 : IPP1=IPT1 210 : ELSE 211 : ltelq=.false. 211 : CALL FUSE(IPP1,IPT1,IRET,ltelq) 212 : IPP1=IRET 213 : ENDIF 214 : 211 SEGSUP INDIC 214 : CALL ECROBJ('MAILLAGE',IPP1) 215 : RETURN 216 : END 217 : 218 : 219 : 220 : 221 : 222 : 223 : 224 : 225 : 226 : 227 : 228 :
© Cast3M 2003 - All rights reserved.
Disclaimer