1 : C VOLUMG SOURCE PV 07/11/23 21:19:53 5978 2 : C FABRICATION DE CUBES ET PRISMES PAR TRANSLATION D'UNE SURFACE 3 : C SELON UNE GENERATRICE (NOVEMBRE 1985) 4 : SUBROUTINE VOLUMG 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT real*8 (a-h,o-z) 7 : -INC SMELEME 8 : -INC CCOPTIO 9 : -INC SMCOORD 10 : -INC CCGEOME 11 : logical ltelq 12 : SEGMENT ICPR(NBNNEL,NBELEC) 12 : IF (ILCOUR.LT.14.OR.ILCOUR.GT.17) CALL ERREUR(16) 13 : IF (IERR.NE.0) RETURN 13 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 13 : CALL LIROBJ('MAILLAGE',IPT9,1,IRETOU) 14 : IF(IERR.NE.0) RETURN 15 : C IPT9 EST LA GENERATRICE VERIFICATION DU TYPE 16 : SEGACT IPT9 17 : IF (IPT9.ITYPEL.NE.KDEGRE(ILCOUR)) THEN 17 : CALL ERREUR(16) 18 : SEGDES IPT9 19 : RETURN 20 : ENDIF 21 : ISVOL1=0 22 : SEGACT IPT1 23 : C SI IPT1 VOLUME IL FAUT EN EXTRAIRE LA FACE 2 24 : 3100 IF (IPT1.LISOUS(/1).EQ.0) GOTO 1000 25 : IF (IPT1.LISOUS(/1).NE.2) GOTO 3102 26 : IDEUX=2 27 : IPT3=IPT1.LISOUS(1) 28 : IPT4=IPT1.LISOUS(2) 29 : SEGACT IPT3,IPT4 30 : IP=IPT3.ITYPEL*IPT4.ITYPEL 31 : IF (IP.NE.32.AND.IP.NE.60) GOTO 3101 32 : IS=IPT3.ITYPEL+IPT4.ITYPEL 33 : IF (IS.NE.12.AND.IS.NE.16) GOTO 3101 34 : INCR=1 35 : IF (IS.EQ.16) INCR=2 36 : NBNNEL=4*INCR 37 : C EN FAIT ON CREE UN SEGMENT QUI CONTIENT LES CUBES ET LES TRIANGLES 38 : C 0 DANS LA DERNIERE POSITION DU TRIANGLE 39 : NBSOUS=0 40 : NBREF=0 41 : NBNN=NBNNEL 42 : NBELE3=IPT3.NUM(/2) 43 : IF (IPT3.ITYPEL.LE.6) NBTRI=NBELE3 44 : IF (IPT3.ITYPEL.GE.8) NBQUA=NBELE3 45 : NBELE4=IPT4.NUM(/2) 46 : IF (IPT4.ITYPEL.LE.6) NBTRI=NBELE4 47 : IF (IPT4.ITYPEL.GE.8) NBQUA=NBELE4 48 : NBELEM=NBELE3+NBELE4 49 : SEGINI MELEME 50 : DO 1100 I=1,NBNN 51 : DO 1100 J=1,NBELEM 52 : NUM(I,J)=0 53 : 1100 CONTINUE 54 : DO 1101 J=1,NBELE3 55 : ICOLOR(J)=IPT3.ICOLOR(J) 56 : DO 1101 I=1,IPT3.NUM(/1) 57 : NUM(I,J)=IPT3.NUM(I,J) 58 : 1101 CONTINUE 59 : DO 1102 J=1,NBELE4 60 : ICOLOR(J+NBELE3)=IPT4.ICOLOR(J) 61 : DO 1102 I=1,IPT4.NUM(/1) 62 : NUM(I,J+NBELE3)=IPT4.NUM(I,J) 63 : 1102 CONTINUE 64 : SEGDES IPT3,IPT4 65 : GOTO 1001 66 : C RECHERCHE DE LA PREMIERE FACE DE IPT1 67 : 3101 SEGDES IPT3,IPT4 67 : 3102 IF (IPT1.LISREF(/1).LT.2) CALL ERREUR(16) 68 : IF (IERR.NE.0) RETURN 69 : ISVOL1=IPT1 70 : IAUX=IPT1.LISREF(2) 71 : SEGDES IPT1 72 : IPT1=IAUX 73 : SEGACT IPT1 74 : GOTO 3100 75 : 1000 CONTINUE 76 : IDEUX=1 77 : NBNNEL=IPT1.NUM(/1) 78 : NBELEM=IPT1.NUM(/2) 79 : IF (IPT1.ITYPEL.NE.8.AND.IPT1.ITYPEL.NE.10.AND.IPT1.ITYPEL.NE.4 80 : #.AND.IPT1.ITYPEL.NE.6) GOTO 3102 81 : INCR=1 82 : IF (KDEGRE(IPT1.ITYPEL).EQ.3) INCR=2 83 : MELEME=IPT1 84 : 1001 SEGACT MCOORD 85 : IPT3=MELEME 86 : NCOUCH=IPT9.NUM(/2) 87 : NX=NCOUCH-1 88 : IF (IIMPI.EQ.1) WRITE(IOIMP,9000) NCOUCH 89 : 9000 FORMAT(/,' COUCHES ',I6) 90 : C ON FAIT TOUJOURS COMME SI IL N'Y AVAIT QU'UN TYPE D'ELEMENT 91 : NBSOUS=0 92 : C MODIF POUR CONSTRUIRE TOUJOURS LE POURTOUR 93 : NBREF=3 94 : IF (IPT1.LISREF(/1).NE.0) NBREF=3 95 : NBNN=2*NBNNEL+(INCR-1)*(NBNNEL/2) 96 : NBNNV=NBNN 97 : NBASE=NBELEM 98 : NBELEM=NBELEM*NCOUCH 99 : SEGINI IPT7 100 : IF (NBNNV.EQ.6 ) IPT7.ITYPEL=16 101 : IF (NBNNV.EQ.15) IPT7.ITYPEL=17 102 : IF (NBNNV.EQ.8 ) IPT7.ITYPEL=14 103 : IF (NBNNV.EQ.20) IPT7.ITYPEL=15 104 : IPT7.LISREF(1)=IPT1 105 : DO 1040 I=1,NBNN 106 : DO 1040 J=1,NBELEM 107 : IPT7.NUM(I,J)=0 108 : 1040 CONTINUE 109 : IOPTG=1 110 : C CALCUL DU VECTEUR TRANSLATION TOTALE 111 : IREFB=(IPT9.NUM(1,1)-1)*4 112 : IREFH=(IPT9.NUM(IPT9.NUM(/1),NCOUCH)-1)*4 113 : NBPTS=XCOOR(/1)/4+1 114 : SEGADJ MCOORD 115 : XCOOR((NBPTS-1)*(IDIM+1)+1)=XCOOR(IREFH+1)-XCOOR(IREFB+1) 116 : XCOOR((NBPTS-1)*(IDIM+1)+2)=XCOOR(IREFH+2)-XCOOR(IREFB+2) 117 : XCOOR((NBPTS-1)*(IDIM+1)+3)=XCOOR(IREFH+3)-XCOOR(IREFB+3) 118 : XCOOR(NBPTS*(IDIM+1))=XCOOR(IREFH+4) 119 : IVEC=NBPTS 120 : IDEB=IVEC+1 120 : CALL ECROBJ('POINT ',IVEC) 120 : CALL ECROBJ('MAILLAGE',IPT1) 120 : CALL PROPER(IOPTG) 120 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 121 : IF (IERR.NE.0) RETURN 122 : C IPT3 ET IPT4 ONT ETE DESCENDU DANS L'OPERATION AINSI QUE MCOORD/REFPO 123 : 16 SEGACT IPT1,IPT2,MCOORD 124 : IPT4=IPT2 125 : IF (IDEUX.EQ.1) GOTO 15 126 : IPT5=IPT2.LISOUS(1) 127 : IPT6=IPT2.LISOUS(2) 128 : SEGACT IPT5,IPT6 129 : C ON FAIT COMME POUR LE BAS 130 : NBSOUS=0 131 : NBREF=0 132 : NBNN=4*INCR 133 : NBNNR=NBNN 134 : NBELEM=NBELE3+NBELE4 135 : SEGINI MELEME 136 : DO 1110 J=1,NBELEM 137 : DO 1110 I=1,NBNN 138 : NUM(I,J)=0 139 : 1110 CONTINUE 140 : DO 1111 J=1,NBELE3 141 : ICOLOR(J)=IPT5.ICOLOR(J) 142 : DO 1111 I=1,IPT5.NUM(/1) 143 : NUM(I,J)=IPT5.NUM(I,J) 144 : 1111 CONTINUE 145 : DO 1112 J=1,NBELE4 146 : ICOLOR(J+NBELE3)=IPT6.ICOLOR(J) 147 : DO 1112 I=1,IPT6.NUM(/1) 148 : NUM(I,J+NBELE3)=IPT6.NUM(I,J) 149 : 1112 CONTINUE 150 : SEGDES IPT5,IPT6,IPT2 151 : IPT4=MELEME 152 : 15 IPT7.LISREF(2)=IPT2 153 : C CONSTRUCTION DE LA TABLE DES POINTS EFFECTIFS 154 : NBELEC=IPT3.NUM(/2) 155 : SEGINI ICPR 156 : DO 12 I=1,NBNNEL 157 : DO 12 J=1,NBELEC 158 : 12 ICPR(I,J)=0 159 : DO 13 J=1,NBELEC 160 : DO 13 I=1,NBNNEL 161 : IR=IPT3.NUM(I,J) 162 : IR2=IPT4.NUM(I,J) 163 : IF (IR.EQ.0) GOTO 1120 164 : IF (IR2.EQ.0) GOTO 8833 165 : I1=IR 166 : I1R2=IR2 167 : IF (J.EQ.1) GOTO 13 168 : JM1=J-1 169 : DO 14 JJ=1,JM1 170 : DO 14 II=1,NBNNEL 171 : IR=IPT3.NUM(II,JJ) 172 : IR2=IPT4.NUM(II,JJ) 173 : IF (IR.EQ.0) GOTO 14 174 : IF (IR.NE.I1) GOTO 8834 175 : IF (IR2.NE.I1R2) GOTO 8833 176 : ICPR(I,J)=II+(JJ-1)*8 177 : GOTO 13 178 : 8834 IF (IR2.EQ.I1R2) GOTO 8833 179 : 14 CONTINUE 180 : GOTO 13 181 : 1120 ICPR(I,J)=-1 182 : IF (IR2.NE.0) GOTO 8833 183 : 13 CONTINUE 184 : GOTO 8835 185 : 8833 CONTINUE 186 : C LES TOPOLOGIES SONT DIFFERENTES 187 : SEGSUP ICPR 187 : CALL ERREUR(21) 188 : RETURN 189 : 8835 CONTINUE 190 : C ON FABRIQUE POUR LE MOMENT DES CUBES A 8 OU 20 NOEUDS ET DES PRISMES 191 : C A 6 OU 15 NOEUDS 192 : C D'ABORD LES POINTS DU BAS 193 : DO 20 I=1,NBELEC 194 : IPT7.ICOLOR(I)=IPT3.ICOLOR(I) 195 : DO 20 J=1,NBNNEL 196 : IR=IPT3.NUM(J,I) 197 : IF (IR.EQ.0) GOTO 20 198 : IPT7.NUM(J,I)=IR 199 : 20 CONTINUE 200 : IBASE=XCOOR(/1)/(IDIM+1) 201 : C ON FABRIQUE ENSUITE LES COUCHES 202 : C ON AFFECTE SEULEMENT LES NUMEROS DE NOEUDS 203 : IDIF=(INCR-1)*(NBNNEL/2) 204 : NX=NCOUCH-1 205 : DO 21 ICOUCH=1,NCOUCH 206 : IF (ICOUCH.EQ.NCOUCH) GOTO 21 207 : JBASE=(ICOUCH-1)*NBELEC 208 : IF (INCR.EQ.1) GOTO 2000 209 : C ON FABRIQUE D'ABORD LA COUCHE INTERMEDIAIRE 210 : DO 2001 J=1,NBELEC 211 : IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J) 212 : DO 2001 IA=1,(NBNNEL/2) 213 : I=2*IA-1 214 : IF (ICPR(I,J).EQ.-1) GOTO 2001 215 : IF (ICPR(I,J).NE.0) GOTO 2002 216 : IBASE=IBASE+1 217 : IPT7.NUM(IA+NBNNEL,J+JBASE)=IBASE 218 : GOTO 2001 219 : 2002 IAUX=ICPR(I,J) 220 : JJ=(IAUX-1)/8+1 221 : II=IAUX-8*JJ+8 222 : IIA=(II+1)/2 223 : IPT7.NUM(IA+NBNNEL,J+JBASE)=IPT7.NUM(IIA+NBNNEL,JJ+JBASE) 224 : 2001 CONTINUE 225 : 2000 CONTINUE 226 : DO 22 J=1,NBELEC 227 : IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J) 228 : DO 22 I=1,NBNNEL 229 : IF (ICPR(I,J).EQ.-1) GOTO 22 230 : IF (ICPR(I,J).NE.0) GOTO 23 231 : IBASE=IBASE+1 232 : IPT7.NUM(I,J+JBASE+NBELEC)=IBASE 233 : IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IBASE 234 : GOTO 22 235 : 23 IAUX=ICPR(I,J) 236 : JJ=(IAUX-1)/8+1 237 : II=IAUX-8*JJ+8 238 : IPT7.NUM(I,J+JBASE+NBELEC)=IPT7.NUM(II,JJ+JBASE+NBELEC) 239 : IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IPT7.NUM(II+NBNNEL+IDIF,JJ+JBASE) 240 : 22 CONTINUE 241 : 21 CONTINUE 242 : 25 CONTINUE 243 : C ON FAIT LES POINTS DU HAUT ET EVENTUELLEMENT LA COUCHE INTERMEDIAIRE 244 : C PRECEDENTE 245 : JBASE=NBELEC*NX 246 : IF (INCR.EQ.1) GOTO 2003 247 : DO 2004 J=1,NBELEC 248 : IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J) 249 : DO 2004 IA=1,(NBNNEL/2) 250 : I=2*IA-1 251 : IF (ICPR(I,J).EQ.-1) GOTO 2004 252 : IF (ICPR(I,J).NE.0) GOTO 2005 253 : IBASE=IBASE+1 254 : IPT7.NUM(IA+NBNNEL,J+JBASE)=IBASE 255 : GOTO 2004 256 : 2005 IAUX=ICPR(I,J) 257 : JJ=(IAUX-1)/8+1 258 : II=IAUX-8*JJ+8 259 : IIA=(II+1)/2 260 : IPT7.NUM(IA+NBNNEL,J+JBASE)=IPT7.NUM(IIA+NBNNEL,JJ+JBASE) 261 : 2004 CONTINUE 262 : 2003 CONTINUE 263 : DO 30 J=1,NBELEC 264 : IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J) 265 : DO 30 I=1,NBNNEL 266 : IF (ICPR(I,J).EQ.-1) GOTO 30 267 : IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IPT4.NUM(I,J) 268 : 30 CONTINUE 269 : C CREATION DES POINTS 270 : IADR=XCOOR(/1)/4 271 : NBPTS=IADR+NCOUCH*INCR*NBELEC*NBNNEL 272 : SEGADJ MCOORD 273 : DO 61 ICOUCH=1,NCOUCH 274 : DO 610 IC=1,INCR 275 : IREFC=(IPT9.NUM(IC+1,ICOUCH)-1)*4 276 : XPLUS=XCOOR(IREFC+1)-XCOOR(IREFB+1) 277 : YPLUS=XCOOR(IREFC+2)-XCOOR(IREFB+2) 278 : ZPLUS=XCOOR(IREFC+3)-XCOOR(IREFB+3) 279 : TPLUS=XCOOR(IREFC+4) 280 : IC1=INCR+1-IC 281 : IF (ICOUCH.EQ.NCOUCH.AND.IC.EQ.INCR) GOTO 610 282 : DO 620 J=1,NBELEC 283 : DO 62 I=1,NBNNEL,IC1 284 : IF (ICPR(I,J).NE.0) GOTO 62 285 : IREF=4*IPT3.NUM(I,J)-4 286 : XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XPLUS 287 : XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YPLUS 288 : XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZPLUS 289 : XCOOR((IADR+1)*(IDIM+1))=TPLUS 290 : IADR=IADR+1 291 : 62 CONTINUE 292 : 620 CONTINUE 293 : 610 CONTINUE 294 : 61 CONTINUE 295 : NBPTS=IADR 296 : SEGADJ MCOORD 297 : C C'EST FINI 298 : C IL RESTE DANS LE CAS OU ON A DES CUBES ET DES PRISMES A LES SEPARER 299 : C ET A SUPPRIMER LES SEGMENTS SUPPLEMENTAIRES DE TRAVAIL 300 : C D'ABORD FAIRE LE POURTOUR A PARTIR DU CONTOUR 301 : IF (IPT7.LISREF(/1).EQ.2) GOTO 3000 301 : CALL ECROBJ('MAILLAGE',IPT1) 301 : CALL PRCONT 301 : CALL LIROBJ('MAILLAGE',IPT5,1,IRETOU) 302 : IF (IERR.NE.0) GOTO 3000 303 : C IPT5 LE CONTOUR IPT6 SERA LE POURTOUR 304 : SEGACT IPT5 305 : NBASE=IPT5.NUM(/2) 306 : NBNN=INCR*4 307 : NBELEM=NBASE*NCOUCH 308 : NBSOUS=0 309 : NBREF=0 310 : SEGINI IPT6 311 : IPT6.ITYPEL=6+2*INCR 312 : SEGACT IPT3 313 : DO 3001 IEL=1,NBASE 314 : DO 3001 IP=1,INCR+1 315 : INP=IPT5.NUM(IP,IEL) 316 : DO 3003 IELS=1,NBELEC 317 : DO 3003 IPS=1,NBNNEL 318 : IPSP=IPT3.NUM(IPS,IELS) 319 : IF (IPSP.EQ.0) GOTO 3003 320 : IF (IPSP.EQ.INP) GOTO 3002 321 : 3003 CONTINUE 322 : GOTO 3000 323 : 3002 CONTINUE 324 : DO 3004 IC=1,NCOUCH 325 : IBASE=(IC-1)*NBASE 326 : JBASE=(IC-1)*NBELEC 327 : C PTS DU BAS 328 : IPT6.NUM(IP,IEL+IBASE)=IPT7.NUM(IPS,IELS+JBASE) 329 : C PTS DU HAUT 330 : IPT6.NUM(NBNN+2-INCR-IP,IEL+IBASE)= 331 : # IPT7.NUM(IPS+NBNNEL+IDIF,IELS+JBASE) 332 : C EVENTUELLEMENT PTS MILIEUX 333 : IF (INCR.EQ.1.OR.IP.EQ.2) GOTO 3004 334 : IPT6.NUM(10-2*IP,IEL+IBASE)=IPT7.NUM((IPS+1)/2+NBNNEL,IELS+JBASE) 335 : 3004 CONTINUE 336 : 3001 CONTINUE 337 : DO 3005 I=1,NCOUCH 338 : DO 3005 J=1,NBASE 339 : IPT6.ICOLOR(J+(I-1)*NBASE)=IPT5.ICOLOR(J) 340 : 3005 CONTINUE 341 : SEGDES IPT5,IPT6 342 : IPT7.LISREF(3)=IPT6 343 : 3000 CONTINUE 344 : IF (IDEUX.EQ.1) GOTO 1500 345 : SEGSUP IPT3,IPT4 346 : MELEME=IPT7 347 : NBSOUS=2 348 : NBREF=LISREF(/1) 349 : NBNN=0 350 : NBELEM=0 351 : SEGINI IPT7 352 : IPT7.LISREF(1)=LISREF(1) 353 : IPT7.LISREF(2)=LISREF(2) 354 : IF (NBREF.EQ.3) IPT7.LISREF(3)=LISREF(3) 355 : NBSOUS=0 356 : NBREF=0 357 : NBNN=6 358 : IF (INCR.EQ.2) NBNN=15 359 : NBELEM=NBTRI*NCOUCH 360 : SEGINI IPT3 361 : IPT3.ITYPEL=16 362 : IF (INCR.EQ.2) IPT3.ITYPEL=17 363 : IPT7.LISOUS(1)=IPT3 364 : NBNN=8 365 : IF (INCR.EQ.2) NBNN=20 366 : NBELEM=NBQUA*NCOUCH 367 : SEGINI IPT4 368 : IPT4.ITYPEL=14 369 : IF (INCR.EQ.2) IPT4.ITYPEL=15 370 : IPT7.LISOUS(2)=IPT4 371 : IT=0 372 : IQ=0 373 : DO 1501 J=1,NUM(/2) 374 : IF (NUM(NBNNV,J).EQ.0) GOTO 1502 375 : C C'EST UN CUBE 376 : IQ=IQ+1 377 : IPT4.ICOLOR(IQ)=ICOLOR(J) 378 : DO 1503 K=1,IPT4.NUM(/1) 379 : IPT4.NUM(K,IQ)=NUM(K,J) 380 : 1503 CONTINUE 381 : GOTO 1501 382 : 1502 IT=IT+1 383 : IPT3.ICOLOR(IT)=ICOLOR(J) 384 : C C'EST UN PRISME 385 : IF (INCR.EQ.2) GOTO 2020 386 : IPT3.NUM(1,IT)=NUM(1,J) 387 : IPT3.NUM(2,IT)=NUM(2,J) 388 : IPT3.NUM(3,IT)=NUM(3,J) 389 : IPT3.NUM(4,IT)=NUM(NBNNEL+1,J) 390 : IPT3.NUM(5,IT)=NUM(NBNNEL+2,J) 391 : IPT3.NUM(6,IT)=NUM(NBNNEL+3,J) 392 : GOTO 1501 393 : 2020 CONTINUE 394 : DO 2021 L=1,6 395 : IPT3.NUM(L,IT)=NUM(L,J) 396 : 2021 CONTINUE 397 : IPT3.NUM(7,IT)=NUM(NBNNEL+1,J) 398 : IPT3.NUM(8,IT)=NUM(NBNNEL+2,J) 399 : IPT3.NUM(9,IT)=NUM(NBNNEL+3,J) 400 : DO 2022 L=1,6 401 : IPT3.NUM(L+9,IT)=NUM(NBNNEL+IDIF+L,J) 402 : 2022 CONTINUE 403 : 1501 CONTINUE 404 : SEGDES IPT3,IPT4 405 : SEGSUP MELEME 406 : 1500 SEGDES IPT1,IPT2 407 : SEGSUP ICPR 408 : IF (ISVOL1.EQ.0) GOTO 3200 409 : IPT8=ISVOL1 410 : SEGACT IPT8 411 : ltelq=.false. 411 : CALL FUSE(IPT8,IPT7,IRET,ltelq) 412 : SEGDES IPT7,IPT8 413 : IPT7=IRET 414 : 3200 CONTINUE 415 : SEGDES IPT7,IPT9 415 : CALL ECROBJ('MAILLAGE',IPT7) 416 : RETURN 417 : END 418 : 419 : 420 : 421 : 422 : 423 : 424 : 425 : 426 : 427 :
© Cast3M 2003 - All rights reserved.
Disclaimer