1 : C INCLU3 SOURCE PV 13/04/11 21:15:59 7755 2 : 3 : SUBROUTINE INCLU3(IPT1,IPT2) 4 : 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8(A-H,O-Z) 7 : 8 : -INC CCOPTIO 9 : -INC SMELEME 10 : -INC SMCOORD 11 : 12 : SEGMENT ICPR(NNNOE) 13 : SEGMENT IELOP(IN) 14 : 15 : CHARACTER*4 LEMOT(3),LEMO2(1) 16 : DATA LEMOT / 'STRI','LARG','BARY' / 17 : DATA LEMO2 / 'NOID' / 18 : 19 : C* IF (IDIM.NE.3) THEN 20 : C* INTERR(1)=IDIM 20 : C* CALL ERREUR(709) 21 : C* RETURN 22 : C* ENDIF 23 : IDIMP1=IDIM+1 24 : 24 : CALL LIRMOT(LEMOT,3,IMSLU,0) 25 : IF (IMSLU.EQ.0) IMSLU=1 26 : 27 : IVERI=0 27 : CALL LIRMOT(LEMO2,1,IRE2,0) 28 : IF (IRE2.EQ.1) IVERI=1 29 : 30 : C CRITERE D'INCLUSION : 30 : CALL LIRREE(XCRITT,0,IRET) 31 : IF (IRET.EQ.0) XCRITT=1.E-2 32 : 33 : SEGACT,IPT1,IPT2 34 : IPT1IN=IPT1 35 : IPT2IN=IPT2 36 : 37 : * Conversion de IPT1 en maillage de type POI1 38 : * --------------------------------------------- 39 : NBPTSI=XCOOR(/1)/IDIMP1 40 : IF (IPT1.ITYPEL .EQ. 1) THEN 41 : IF (IMSLU.EQ.3) IPT5=IPT1 42 : ELSE 43 : C* Traitement de l'option 'BARY' : 44 : C* IPT1 contiendra les centres de gravite de IPT1 (dans le meme ordre) 45 : IF (IMSLU.EQ.3) THEN 46 : NBPTS=NBPTSI 47 : NBNN=1 48 : NBELEM=0 49 : NBREF=0 50 : NBSOUS=0 51 : SEGINI,IPT5 52 : IPT5.ITYPEL=1 53 : IGRAV=NBPTSI 54 : IPT6=IPT1 55 : NSOU1=IPT6.LISOUS(/1) 56 : DO i=1,MAX(1,NSOU1) 57 : IF (NSOU1.NE.0) THEN 58 : IPT6=IPT1.LISOUS(i) 59 : SEGACT,IPT6 60 : ENDIF 61 : NBELE5=NBELEM 62 : NBELE1=IPT6.NUM(/2) 63 : NBELEM=NBELEM+NBELE1 64 : SEGADJ,IPT5 65 : NBPTS=NBPTS+NBELE1 66 : SEGADJ,MCOORD 67 : NBN1=IPT6.NUM(/1) 68 : DO j=1,NBELE1 69 : IGRAV=IGRAV+1 70 : IPT5.NUM(1,NBELE5+j)=IGRAV 71 : XP=0.D0 72 : YP=0.D0 73 : ZP=0.D0 74 : DO k=1,NBN1 75 : IREF=IPT6.NUM(k,j)*IDIMP1-IDIM 76 : XP=XCOOR(IREF) +XP 77 : YP=XCOOR(IREF+1)+YP 78 : ZP=XCOOR(IREF+2)+ZP 79 : ENDDO 80 : IREF=IGRAV*IDIMP1-IDIM 81 : XCOOR(IREF )=XP/FLOAT(NBN1) 82 : XCOOR(IREF+1)=YP/FLOAT(NBN1) 83 : XCOOR(IREF+2)=ZP/FLOAT(NBN1) 84 : ENDDO 85 : IF (NSOU1.NE.0) SEGDES,IPT6 86 : ENDDO 87 : SEGDES,IPT1 88 : IPT1=IPT5 89 : C* Traitement des options 'STRI' et 'LARG' 90 : ELSE 90 : CALL CHANGE(IPT1,1) 91 : ENDIF 92 : ENDIF 93 : NNNOE=IPT1.NUM(/2) 94 : * 95 : * Conversion de ipt2 en elements de type TET4 96 : * 97 : IF (IPT2.LISOUS(/1).NE.0) THEN 98 : IN=IPT2.LISOUS(/1) 99 : SEGINI IELOP 100 : NBELEM=0 101 : DO 36 I=1,IPT2.LISOUS(/1) 102 : MELEME=IPT2.LISOUS(I) 103 : SEGACT MELEME 104 : IF (MELEME.ITYPEL.NE.23) THEN 104 : CALL CHANGE(MELEME,23) 105 : * write(6,*) ' inclu3 conv faite' 106 : ENDIF 107 : NBELEM=NBELEM+NUM(/2) 108 : IELOP(I)=MELEME 109 : 36 CONTINUE 110 : NBNN=4 111 : NBREF=0 112 : NBSOUS=0 113 : SEGINI IPT3 114 : IA=0 115 : DO 37 I=1,IPT2.LISOUS(/1) 116 : MELEME=IELOP(I) 117 : DO 38 J=1,NUM(/2) 118 : DO 38 K=1,NUM(/1) 119 : IPT3.NUM(K,J+IA) = NUM(K,J) 120 : 38 CONTINUE 121 : IA=IA+NUM(/2) 122 : SEGDES MELEME 123 : 37 CONTINUE 124 : IPT3.ITYPEL=23 125 : IPT2=IPT3 126 : ELSE 127 : IF (IPT2.ITYPEL.NE.23) THEN 127 : CALL CHANGE (IPT2,23) 128 : * write(6,*) ' inclu3 conv faite' 129 : ENDIF 130 : ENDIF 131 : 131 : CALL INCLU4(IPT1,IPT2,ICPR,XCRITT) 132 : * write(6,FMT='(10i6)') (ICPR(IU),IU=1,ICPR(/1)) 133 : IF (IERR.NE.0) GOTO 999 134 : 135 : C TEST ET CREATION DU SEGMENT RESULTAT 136 : NBREF=0 137 : MELEME=IPT1IN 138 : SEGACT MELEME 139 : IPT2=MELEME 140 : NBSOU=LISOUS(/1) 141 : IF (NBSOU.NE.0) THEN 142 : NBNN=0 143 : NBELEM=0 144 : NBSOUS=NBSOU 145 : SEGINI IPT8 146 : ISO=0 147 : ENDIF 148 : IF (IMSLU.EQ.3) THEN 149 : NBELE5=0 150 : SEGACT,IPT5 151 : ENDIF 152 : DO 270 ISOUS=1,MAX(1,NBSOU) 153 : IF (NBSOU.NE.0) THEN 154 : IPT2=LISOUS(ISOUS) 155 : SEGACT IPT2 156 : ENDIF 157 : NBNN=IPT2.NUM(/1) 158 : NBELEM=IPT2.NUM(/2) 159 : ICOUNT=0 160 : DO 250 IEL=1,NBELEM 161 : IF (IMSLU.EQ.1) THEN 162 : DO 251 INOEU=1,NBNN 163 : IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 250 164 : 251 CONTINUE 165 : ICOUNT=ICOUNT+1 166 : ELSE IF (IMSLU.EQ.2) THEN 167 : DO 252 INOEU=1,NBNN 168 : IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) GOTO 253 169 : 252 CONTINUE 170 : GOTO 250 171 : 253 CONTINUE 172 : ICOUNT=ICOUNT+1 173 : C* ELSE IF (IMSLU.EQ.3) THEN 174 : ELSE 175 : IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) ICOUNT=ICOUNT+1 176 : ENDIF 177 : 250 CONTINUE 178 : NBSOUS=0 179 : NBREF=0 180 : NBEL=NBELEM 181 : NBELEM=ICOUNT 182 : ICOUNT=1 183 : IF (NBELEM.EQ.0) GOTO 260 184 : SEGINI IPT3 185 : IPT3.ITYPEL=IPT2.ITYPEL 186 : DO 255 IEL=1,NBEL 187 : IF (IMSLU.EQ.1) THEN 188 : DO 256 INOEU=1,NBNN 189 : IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 255 190 : IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL) 191 : 256 CONTINUE 192 : IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL) 193 : ICOUNT=ICOUNT+1 194 : IF (ICOUNT.GT.NBELEM) GOTO 260 195 : ELSE IF (IMSLU.EQ.2) THEN 196 : IOOK=0 197 : DO 257 INOEU=1,NBNN 198 : IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) IOOK=1 199 : IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL) 200 : 257 CONTINUE 201 : IF (IOOK.EQ.0) GOTO 255 202 : IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL) 203 : ICOUNT=ICOUNT+1 204 : IF (ICOUNT.GT.NBELEM) GOTO 260 205 : C* ELSE IF (IMSLU.EQ.3) THEN 206 : ELSE 207 : IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) THEN 208 : DO INOEU=1,NBNN 209 : IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL) 210 : ENDDO 211 : IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL) 212 : ICOUNT=ICOUNT+1 213 : IF (ICOUNT.GT.NBELEM) THEN 214 : NBELE5=NBELE5+NBEL 215 : GOTO 260 216 : ENDIF 217 : ENDIF 218 : ENDIF 219 : 255 CONTINUE 220 : 221 : * Bilan et sauvegarde 222 : 223 : 260 CONTINUE 224 : IF (NBSOU.EQ.0) THEN 225 : IF (NBELEM.EQ.0) THEN 226 : IF (IVERI.EQ.1) THEN 227 : * Ecriture d'un maillage vide 228 : NBSOUS=0 229 : NBREF=0 230 : NBNN=0 231 : NBELEM=0 232 : SEGINI IPT4 232 : CALL ECROBJ('MAILLAGE',IPT4) 233 : GOTO 999 234 : ELSE 235 : * Tache impossible. Probablement données erronées 235 : CALL ERREUR(26) 236 : RETURN 237 : ENDIF 238 : ENDIF 239 : GOTO 280 240 : ENDIF 241 : IF (NBELEM.NE.0) THEN 242 : IPT8.LISOUS(ISOUS)=IPT3 243 : ISO=ISO+1 244 : SEGDES IPT3 245 : ENDIF 246 : 270 CONTINUE 247 : 248 : IF (ISO.EQ.1) THEN 249 : SEGSUP IPT8 250 : GOTO 280 251 : ENDIF 252 : IF (ISO.EQ.0) THEN 253 : SEGSUP IPT8 254 : IF (IVERI.EQ.1) THEN 255 : * Ecriture d'un maillage vide 256 : NBSOUS=0 257 : NBREF=0 258 : NBNN=0 259 : NBELEM=0 260 : SEGINI IPT4 260 : CALL ECROBJ('MAILLAGE',IPT4) 261 : GOTO 999 262 : ELSE 263 : * Tache impossible. Probablement données erronées 263 : CALL ERREUR(26) 264 : RETURN 265 : ENDIF 266 : ENDIF 267 : IPT3=IPT8 268 : IF (ISO.EQ.NBSOU) GOTO 280 269 : NBSOUS=ISO 270 : NBREF=0 271 : NBNN=0 272 : NBELEM=0 273 : SEGINI IPT4 274 : ISO=0 275 : DO 275 IS=1,NBSOU 276 : IF (IPT3.LISOUS(IS).EQ.0) GOTO 275 277 : ISO=ISO+1 278 : IPT4.LISOUS(ISO)=IPT3.LISOUS(IS) 279 : 275 CONTINUE 280 : IF (ISO.EQ.0) THEN 281 : NBSOUS=0 282 : NBREF=0 283 : NBNN=0 284 : NBELEM=0 285 : SEGINI IPT4 285 : CALL ECROBJ('MAILLAGE',IPT4) 286 : GOTO 999 287 : ENDIF 288 : SEGSUP IPT3 289 : IPT3=IPT4 290 : 280 CONTINUE 291 : SEGDES IPT3 291 : CALL ECROBJ('MAILLAGE',IPT3) 292 : 293 : 999 CONTINUE 294 : *** IF (IPT1IN.NE.IPT1) SEGSUP,IPT1 295 : SEGSUP,ICPR 296 : IPT1=IPT1IN 297 : IPT2=IPT2IN 298 : SEGDES,IPT1,IPT2 299 : IF (IMSLU.EQ.3) THEN 300 : NBPTS=NBPTSI 301 : SEGADJ,MCOORD 302 : ENDIF 303 : 304 : RETURN 305 : END 306 : 307 : 308 : 309 : 310 : 311 : 312 :
© Cast3M 2003 - All rights reserved.
Disclaimer