1 : C PRTRAN SOURCE PV 11/01/12 21:15:04 6849 2 : C PREPARATION DE LA TRANSLATION ET DE LA ROTATION D'UNE LIGNE 3 : C 4 : C MODIFICATION NOVEMBRE 1984 INTRODUCTION DE LA DEGENERESCENCE DANS 5 : C LE CAS DE ROTATION DONT L'AXE PASSE PAR UN (OU DEUX) POINT DE 6 : C LA LIGNE (MODIFICATION NON TERMINE) 7 : C 8 : SUBROUTINE PRTRAN(IOPTG) 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-Z) 11 : DIMENSION XCO(4) 12 : DIMENSION XROT1(3),XROT2(3) 13 : CHARACTER*4 MCLE(2) 14 : -INC CCREEL 15 : -INC CCOPTIO 16 : logical ltelq 17 : SEGMENT TABPAR 18 : REAL*8 TABPA1(NCOUCH) 19 : ENDSEGMENT 20 : -INC CCGEOME 21 : -INC SMCOORD 22 : -INC SMELEME 23 : SEGMENT ICPR 24 : INTEGER ICPR1(2,NBELEC) 25 : ENDSEGMENT 26 : SEGMENT ICPP 27 : INTEGER ICPP1(XCOOR(/1)/(IDIM+1)) 28 : ENDSEGMENT 29 : COMMON/CTOURN/XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,XVEC,YVEC, 30 : # ZVEC,ANGLE,ICLE 31 : DATA MCLE/'DINI','DFIN'/ 32 : XDIS=0.D0 33 : YDIS=0.D0 34 : ZDIS=0.D0 35 : IMPOI=0 36 : IMPOF=0 37 : C Y A T IL UN DECOUPAGE IMPOSE 38 : INBR=0 38 : CALL MESLIR(-236) 38 : CALL LIRENT(INBR,0,IRETOU) 39 : 40 : * IF (IRETOU.EQ.1) INBR=MAX(1,INBR) 41 : IF (IDIM.EQ.3.AND.IOPTG.EQ.2) IOPTG=3 41 : IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16) 42 : C CAS DE LA ROTATION DONNEE OBLIGATOIRE L'ANGLE 43 : IF (IOPTG.EQ.1) GOTO 1 44 : IOB=0 45 : IF (INBR.EQ.0) IOB=1 45 : CALL MESLIR(-235) 45 : CALL LIRREE(XXX,IOB,IRETOU) 46 : FLOT=XXX 47 : IF (IERR.NE.0) RETURN 48 : IF (IRETOU.EQ.1) GOTO 2 49 : IF (INBR.NE.0) FLOT=INBR 50 : INBR=0 51 : 2 CONTINUE 52 : ANGLE=FLOT*XPI/180.D0 53 : 54 : IF (IERR.NE.0) RETURN 55 : 1 CONTINUE 56 : C Y A T-IL DES DENSITES IMPOSEES 57 : 3 CONTINUE 57 : CALL MESLIR(-234) 57 : CALL LIRMOT(MCLE,2,IRETOU,0) 58 : IF (IRETOU.EQ.1) THEN 58 : CALL MESLIR(-170) 58 : CALL LIRREE(XXX,1,IRETOU) 59 : DEN1D=XXX 60 : IF (IERR.NE.0) RETURN 61 : IMPOI=1 62 : GOTO 3 63 : ELSEIF (IRETOU.EQ.2) THEN 63 : CALL MESLIR(-169) 63 : CALL LIRREE(XXX,1,IRETOU) 64 : DEN2D=XXX 65 : IF (IERR.NE.0) RETURN 66 : IMPOF=1 67 : GOTO 3 68 : ENDIF 68 : CALL MESLIR(-131) 68 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 69 : IF (IERR.NE.0) RETURN 69 : CALL EXTRLI(IPT1,3,IRET,-1) 70 : IF (IERR.NE.0) RETURN 71 : IFUSE=0 72 : IF (IPT1.NE.IRET) IFUSE=IPT1 73 : IPT1=IRET 73 : IF (IOPTG.EQ.1) CALL MESLIR(-233) 73 : IF (IOPTG.EQ.2) CALL MESLIR(-232) 73 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 74 : IF (IOPTG.EQ.3) THEN 74 : CALL MESLIR(-231) 74 : CALL LIROBJ('POINT ',IP2,1,IRETOU) 75 : IF (IERR.NE.0) RETURN 76 : ENDIF 77 : 12 SEGACT IPT1 78 : 11 SEGACT MCOORD 79 : NBNN=IPT1.NUM(/1) 80 : * VERIFIER TYPE D'ELEMENT ACCEPTABLE 80 : IF (IPT1.ITYPEL.NE.2.AND.IPT1.ITYPEL.NE.3) CALL ERREUR(16) 81 : IF (IERR.NE.0) RETURN 82 : NBELEM=IPT1.NUM(/2) 83 : XG=0.D0 84 : YG=0.D0 85 : ZG=0.D0 86 : DEN1=0.D0 87 : IBOUCL=0 88 : IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1 89 : DO 17 I=1,NBNN 90 : DO 171 J=1,NBELEM 91 : IREF=IPT1.NUM(I,J)*(IDIM+1) 92 : XG=XCOOR(IREF-IDIM)+XG 93 : YG=XCOOR(IREF-IDIM+1)+YG 94 : IF (IDIM.GE.3) ZG=XCOOR(IREF-IDIM+2)+ZG 95 : DEN1=XCOOR(IREF)+DEN1 96 : 171 CONTINUE 97 : 17 CONTINUE 98 : XG=XG/(NBNN*NBELEM) 99 : YG=YG/(NBNN*NBELEM) 100 : ZG=ZG/(NBNN*NBELEM) 101 : DEN1=DEN1/(NBNN*NBELEM) 102 : IF (IMPOI.EQ.1) DEN1=DEN1D 103 : DEN1A=DEN1 104 : DEN1B=DEN1 105 : IF (IOPTG.NE.1) GOTO 13 106 : IREF=IP1*(IDIM+1) 107 : IREFT=IREF-IDIM 108 : XTRAN=XCOOR(IREF-IDIM) 109 : YTRAN=XCOOR(IREF-IDIM+1) 110 : ZTRAN=0 111 : IF (IDIM.GE.3) ZTRAN=XCOOR(IREF-IDIM+2) 112 : DEN2=XCOOR(IREF) 113 : IF (IMPOF.EQ.1) DEN2=DEN2D 114 : DEN2A=DEN2 115 : DEN2B=DEN2 116 : XDIS=XTRAN 117 : YDIS=YTRAN 118 : ZDIS=ZTRAN 119 : DLONG=SQRT(XDIS**2+YDIS**2+ZDIS**2) 120 : GOTO 16 121 : 13 IREF=IP1*(IDIM+1) 122 : XROT1(1)=XCOOR(IREF-IDIM) 123 : XROT1(2)=XCOOR(IREF-IDIM+1) 124 : XROT1(3)=XCOOR(IREF-IDIM+2) 125 : IF (IDIM.EQ.2) XROT1(3)=0 126 : DEN2=XCOOR(IREF) 127 : IF (IMPOF.EQ.1) DEN2=DEN2D 128 : DDIS=ABS(XG-XROT1(1))+ABS(YG-XROT1(2))+ABS(ZG-XROT1(3)) 129 : IF (IOPTG.EQ.3) GOTO 15 130 : XROT2(1)=XROT1(1) 131 : XROT2(2)=XROT1(2) 132 : XROT2(3)=DDIS 133 : GOTO 18 134 : 15 IREF=IP2*(IDIM+1) 135 : XROT2(1)=XCOOR(IREF-IDIM) 136 : XROT2(2)=XCOOR(IREF-IDIM+1) 137 : XROT2(3)=XCOOR(IREF-IDIM+2) 138 : DEN2=(DEN2+XCOOR(IREF))/2.D0 139 : IF (IMPOF.EQ.1) DEN2=DEN2D 140 : 18 CONTINUE 141 : DEN2A=DEN2 142 : DEN2B=DEN2 143 : XPT1=XROT1(1) 144 : YPT1=XROT1(2) 145 : ZPT1=XROT1(3) 146 : XVEC=XROT2(1)-XROT1(1) 147 : YVEC=XROT2(2)-XROT1(2) 148 : ZVEC=XROT2(3)-XROT1(3) 149 : RAY=SQRT(XVEC**2+YVEC**2+ZVEC**2) 150 : XVEC=XVEC/RAY 151 : YVEC=YVEC/RAY 152 : ZVEC=ZVEC/RAY 153 : 154 : C Ajout DI VALENTIN : on rajoute la normale dans le 155 : C tableau de points 156 : 157 : NORMAL = XCOOR(/1)/(IDIM+1) + 1 158 : NBPTS = NORMAL 159 : SEGADJ MCOORD 160 : 161 : XCOOR((NORMAL-1)*(IDIM+1)+1) = XVEC 162 : XCOOR((NORMAL-1)*(IDIM+1)+2) = YVEC 163 : XCOOR((NORMAL-1)*(IDIM+1)+3) = ZVEC 164 : 165 : C Fin de l'ajout 166 : 167 : 168 : XV1=XG-XROT1(1) 169 : YV1=YG-XROT1(2) 170 : ZV1=ZG-XROT1(3) 171 : PV1=XV1*XVEC+YV1*YVEC+ZV1*ZVEC 172 : XV1=XV1-PV1*XVEC 173 : YV1=YV1-PV1*YVEC 174 : ZV1=ZV1-PV1*ZVEC 175 : RAY=SQRT(XV1**2+YV1**2+ZV1**2) 176 : XV1=XV1/RAY 177 : YV1=YV1/RAY 178 : ZV1=ZV1/RAY 179 : XV2=YVEC*ZV1-ZVEC*YV1 180 : YV2=ZVEC*XV1-XVEC*ZV1 181 : ZV2=XVEC*YV1-YVEC*XV1 182 : IREF=IPT1.NUM(1,1)*(IDIM+1)-IDIM 183 : X1=XCOOR(IREF) 184 : Y1=XCOOR(IREF+1) 185 : Z1=XCOOR(IREF+2) 186 : IF (IDIM.EQ.2) Z1=0.D0 187 : XV=X1-XPT1 188 : YV=Y1-YPT1 189 : ZV=Z1-ZPT1 190 : PV=XV*XVEC+YV*YVEC+ZV*ZVEC 191 : XV=XV-PV*XVEC 192 : YV=YV-PV*YVEC 193 : ZV=ZV-PV*ZVEC 194 : RL1=SQRT(XV**2+YV**2+ZV**2) 195 : * ON CREE LES DEUX CENTRES DES CERCLES POUR LES COTES 2 ET 4 196 : NBPTA=XCOOR(/1)/(IDIM+1) 197 : NBPTS=NBPTA+2 198 : SEGADJ MCOORD 199 : XCOOR(NBPTA*(IDIM+1)+1)=XPT1+PV*XVEC 200 : XCOOR(NBPTA*(IDIM+1)+2)=YPT1+PV*YVEC 201 : IF (IDIM.GE.3) XCOOR(NBPTA*(IDIM+1)+3)=ZPT1+PV*ZVEC 202 : XCOOR((NBPTA+1)*(IDIM+1))=DEN2 203 : NBPTA=NBPTA+1 204 : NUCEN1=NBPTA 205 : IREF=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))*(IDIM+1)-IDIM 206 : X1=XCOOR(IREF) 207 : Y1=XCOOR(IREF+1) 208 : Z1=XCOOR(IREF+2) 209 : IF (IDIM.EQ.2) Z1=0.D0 210 : XV=X1-XPT1 211 : YV=Y1-YPT1 212 : ZV=Z1-ZPT1 213 : PV=XV*XVEC+YV*YVEC+ZV*ZVEC 214 : XV=XV-PV*XVEC 215 : YV=YV-PV*YVEC 216 : ZV=ZV-PV*ZVEC 217 : RL2=SQRT(XV**2+YV**2+ZV**2) 218 : XCOOR(NBPTA*(IDIM+1)+1)=XPT1+PV*XVEC 219 : XCOOR(NBPTA*(IDIM+1)+2)=YPT1+PV*YVEC 220 : IF (IDIM.GE.3) XCOOR(NBPTA*(IDIM+1)+3)=ZPT1+PV*ZVEC 221 : XCOOR((NBPTA+1)*(IDIM+1))=DEN2 222 : NBPTA=NBPTA+1 223 : NUCEN2=NBPTA 224 : C RAYON MOYEN 225 : C ANGLE EN RADIANS D'OU LONGUEUR MOYENNE 226 : DLONG=ABS(RAY*ANGLE) 227 : 16 CONTINUE 228 : DENI=DEN1 229 : DECA=DEN2-DEN1 230 : DEN1=DEN1/DLONG 231 : DEN2=DEN2/DLONG 231 : CALL DECOUP(INBR,DEN1,DEN2,APROG,NCOUCH,DENI,DECA,DLONG) 232 : IF (IOPTG.NE.1) DLONG=RAY*ANGLE 233 : IF (INBR.LE.0) INBR=-NCOUCH 234 : NX=NCOUCH-1 235 : IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH,APROG 236 : 1000 FORMAT(/' COUCHES ',I6,' RAISON ',G12.5) 237 : NBNN=4 238 : NBELEM=IPT1.NUM(/2)*NCOUCH 239 : NBSOUS=0 240 : NBREF=4 241 : SEGINI MELEME 242 : SEGINI TABPAR 243 : ITYPEL=8 244 : IDEB=XCOOR(/1)/(IDIM+1)+1 245 : INCR=IPT1.ITYPEL-1 246 : NBELEC=IPT1.NUM(/2) 247 : SEGINI ICPR 248 : C ON FAIT D'ABORD L' EXTREMITEE 249 : SEGINI ICPP 250 : DO 52 I=1,ICPP1(/1) 251 : ICPP1(I)=0 252 : 52 CONTINUE 253 : IF (IOPTG.NE.1) GOTO 51 254 : ICLE=1 255 : XCO(4)=0 256 : DO 200 I=1,IDIM+1 257 : XCO(I)=XCOOR(IREFT-1+I) 258 : 200 CONTINUE 258 : CALL ADDITE(XCO,IPT1,IPT3,ICPP,0) 259 : IF (IERR.NE.0) RETURN 260 : GOTO 50 261 : 51 ICLE=2 261 : CALL ADDITE(XROT1,IPT1,IPT3,ICPP,0) 262 : 50 CONTINUE 263 : SEGSUP ICPP 264 : SEGACT IPT3 264 : CALL INVERS(IPT3,IPT4) 265 : SEGDES IPT4 266 : LISREF(3)=IPT4 267 : C ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS 268 : IDEB=XCOOR(/1)/(IDIM+1)+1 269 : DO 70 I=1,2 270 : DO 701 J=1,NBELEC 271 : ICPR1(I,J)=0 272 : 701 CONTINUE 273 : 70 CONTINUE 274 : LCPR=0 275 : DO 71 J=1,NBELEC 276 : DO 711 I=1,2 277 : I1=IPT1.NUM((I-1)*INCR+1,J) 278 : LCPR=LCPR+1 279 : DO 72 JJ=1,J 280 : DO 721 II=1,2 281 : IF (IPT1.NUM((II-1)*INCR+1,JJ).NE.I1) GOTO 721 282 : IF (II.NE.I) GOTO 73 283 : IF (JJ.EQ.J) GOTO 711 284 : 73 ICPR1(I,J)=II+(JJ-1)*2 285 : LCPR=LCPR-1 286 : IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 75 287 : GOTO 711 288 : 75 IF (IBOUCL.EQ.1) GOTO 711 289 : ICPR1(I,J)=0 290 : ICPR1(II,JJ)=I+(J-1)*2 291 : GOTO 711 292 : 721 CONTINUE 293 : 72 CONTINUE 294 : 711 CONTINUE 295 : 71 CONTINUE 296 : C ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR 297 : C LE MOMENT D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER 298 : DIN=DEN1 299 : DO 40 I=1,IPT1.NUM(/2) 300 : NUM(1,I)=IPT1.NUM(1,I) 301 : NUM(2,I)=IPT1.NUM(1+INCR,I) 302 : 40 CONTINUE 303 : ILASI=IDEB-1 304 : ILASJ=ILASI+(INCR*NX)+INCR-1 305 : IF (IBOUCL.EQ.1) ILASJ=ILASI 306 : ILAS=ILASJ+INCR*NX+INCR 307 : DO 42 ICOUCH=1,NCOUCH 308 : DIN=DIN*APROG 309 : TABPA1(ICOUCH)=DIN 310 : IF (NCOUCH.EQ.ICOUCH) GOTO 41 311 : ILASI=ILASI+INCR 312 : ILASJ=ILASJ+INCR 313 : INI=(ICOUCH-1)*IPT1.NUM(/2) 314 : NUM(1,1+INI+NBELEC)=ILASI 315 : NUM(4,1+INI)=ILASI 316 : NUM(2,INI+2*NBELEC)=ILASJ 317 : NUM(3,INI+NBELEC)=ILASJ 318 : DO 421 J=1,IPT1.NUM(/2) 319 : DO 422 I=1,2 320 : ILL=ILAS 321 : IF (I.EQ.1.AND.J.EQ.1) GOTO 422 322 : IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 422 323 : IF (ICPR1(I,J).NE.0) ILL=NUM(MOD(ICPR1(I,J)-1,2)+1, 324 : # (ICPR1(I,J)-1)/2+1+INI+NBELEC) 325 : NUM(I,J+INI+NBELEC)=ILL 326 : NUM(5-I,J+INI)=ILL 327 : IF (ICPR1(I,J).NE.0) GOTO 422 328 : ILAS=ILL+1 329 : 422 CONTINUE 330 : 421 CONTINUE 331 : 42 CONTINUE 332 : TABPA1(NCOUCH)=DIN*APROG 333 : 41 CONTINUE 334 : INI=(NCOUCH-1)*IPT1.NUM(/2) 335 : DO 43 I=1,NBELEC 336 : NUM(4,INI+I)=IPT3.NUM(1,I) 337 : NUM(3,INI+I)=IPT3.NUM(1+INCR,I) 338 : 43 CONTINUE 339 : DO 44 I=1,NCOUCH 340 : DO 441 J=1,IPT1.NUM(/2) 341 : II=(I-1)*IPT1.NUM(/2)+J 342 : ICOLOR(II)=IPT1.ICOLOR(J) 343 : 441 CONTINUE 344 : 44 CONTINUE 345 : LISREF(1)=IPT1 346 : C CREATION DES BORDS LATERAUX PAR LIGNE 347 : C PRESENTEMENT CAS DE LA TRANSLATION OU DE LA ROTATION 348 : C IMPOSONS ILCOUR POUR CETTE MANIP (LES BORDS LATERAUX DOIVENT ETRE 349 : C CONSISTANT AVEC LES AUTRES ) 350 : ILSAUV=ILCOUR 351 : IDSAUV=IDCOUL 352 : ILCOUR=IPT1.ITYPEL 353 : IDCOUL=IPT1.ICOLOR(1) 354 : ITYPL=1 355 : LP2=IPT3.NUM(1,1) 356 : 357 : IF (IOPTG.EQ.1) THEN 357 : CALL ECROBJ('POINT ',LP2) 358 : LP1=IPT1.NUM(1,1) 358 : CALL ECROBJ('POINT ',LP1) 359 : INBB=INBR 359 : CALL LIGNE(ITYPL,0,DEN1A,DEN2A,INBB) 360 : 361 : ELSE 362 : ITYPL=3 363 : DEN1A=DEN1A*RL1/RAY 364 : DEN2A=DEN2A*RL1/RAY 365 : DEN1B=DEN1B*RL2/RAY 366 : DEN2B=DEN2B*RL2/RAY 367 : LP1=IPT1.NUM(1,1) 368 : INBB=INBR 368 : CALL ARC(LP1,NUCEN1,NORMAL,ANGLE,INBB,DEN1A,DEN2A,LP2) 369 : ENDIF 370 : 371 : C RESTAURER ILCOUR,IDSAUV 372 : ILCOUR=ILSAUV 373 : IDCOUL=IDSAUV 374 : IF (IERR.NE.0) RETURN 374 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 375 : SEGACT IPT2 375 : CALL INVERS(IPT2,IPT4) 376 : SEGDES IPT2 377 : LISREF(4)=IPT4 378 : SEGDES IPT4 379 : IF (IBOUCL.EQ.0) GOTO 46 380 : LISREF(2)=IPT2 381 : GOTO 45 382 : 46 CONTINUE 383 : LP1=IPT3.NUM(IPT3.NUM(/1),IPT3.NUM(/2)) 384 : 385 : IF (IOPTG.EQ.1) THEN 385 : CALL ECROBJ('POINT ',LP1) 386 : LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2)) 386 : CALL ECROBJ('POINT ',LP1) 387 : ILCOUR=IPT1.ITYPEL 388 : IDCOUL=IPT1.ICOLOR(IPT1.NUM(/2)) 388 : CALL LIGNE(ITYPL,0,DEN1B,DEN2B,INBR) 389 : 390 : ELSE 391 : LPLAUR = LP1 392 : LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2)) 393 : ILCOUR=IPT1.ITYPEL 394 : IDCOUL=IPT1.ICOLOR(IPT1.NUM(/2)) 394 : CALL ARC(LP1,NUCEN2,NORMAL,ANGLE,INBB,DEN1B,DEN2B,LPLAUR) 395 : 396 : ENDIF 397 : 397 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 398 : ILCOUR=ILSAUV 399 : IF (IERR.NE.0) RETURN 400 : SEGACT IPT2 401 : LISREF(2)=IPT2 402 : 45 CONTINUE 403 : SEGSUP IPT3 404 : C ON RESTAURE ILCOUR 405 : ILCOUR=ILSAUV 406 : IDCOUL=IDSAUV 407 : C CREATION DES POINTS (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES 408 : C EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS) 409 : DPAR=0 410 : SEGACT MCOORD 411 : IADR=XCOOR(/1)/(IDIM+1) 412 : NBPTS=IADR+(NCOUCH-1)*IPT1.NUM(/2)*2 413 : SEGADJ MCOORD 414 : IF (NCOUCH.EQ.1) GOTO 60 415 : DO 61 I=2,NCOUCH 416 : DIN=TABPA1(I-1) 417 : DPAR=DPAR+DIN 418 : IF (IOPTG.EQ.1) GOTO 83 419 : ANG=DPAR*DLONG/RAY 420 : SI=SIN(ANG) 421 : CO=COS(ANG) 422 : 83 CONTINUE 423 : IF (IPT1.NUM(/2).EQ.1) GOTO 60 424 : DO 62 J=1,IPT1.NUM(/2) 425 : DO 621 K=1,2 426 : IF (K.EQ.1.AND.J.EQ.1) GOTO 621 427 : IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 621 428 : IF (ICPR1(K,J).NE.0) GOTO 621 429 : IREF=(IDIM+1)*IPT1.NUM((K-1)*INCR+1,J)-IDIM 430 : IF (IOPTG.NE.1) GOTO 84 431 : XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF)+DPAR*XDIS 432 : XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+1)+DPAR*YDIS 433 : IF (IDIM.NE.2) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+2)+DPAR 434 : $ *ZDIS 435 : GOTO 85 436 : 84 X1=XCOOR(IREF)-XPT1 437 : Y1=XCOOR(IREF+1)-YPT1 438 : Z1=XCOOR(IREF+2)-ZPT1 439 : IF (IDIM.EQ.2) Z1=0 440 : XV=X1*XV1+Y1*YV1+Z1*ZV1 441 : YV=X1*XV2+Y1*YV2+Z1*ZV2 442 : ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC 443 : XD=XV*CO-YV*SI 444 : YD=XV*SI+YV*CO 445 : ZD=ZV 446 : XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 447 : XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 448 : IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD 449 : $ *ZVEC+ZPT1 450 : 85 XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR 451 : IADR=IADR+1 452 : 621 CONTINUE 453 : 62 CONTINUE 454 : 61 CONTINUE 455 : 60 CONTINUE 456 : NBPTS=IADR 457 : SEGADJ MCOORD 458 : IF (KSURF(ILCOUR).EQ.8) GOTO 101 459 : IF (KSURF(ILCOUR).NE.4) GOTO 102 460 : NBNN=3 461 : NBELEM=2*NUM(/2) 462 : NBREF=4 463 : NBSOUS=0 464 : SEGINI IPT1 465 : IPT1.ITYPEL=4 466 : IPT1.LISREF(1)=LISREF(1) 467 : IPT1.LISREF(2)=LISREF(2) 468 : IPT1.LISREF(3)=LISREF(3) 469 : IPT1.LISREF(4)=LISREF(4) 470 : DO 103 I=1,NUM(/2),2 471 : J=2*I-1 472 : IPT1.NUM(1,J)=NUM(1,I) 473 : IPT1.NUM(2,J)=NUM(2,I) 474 : IPT1.NUM(3,J)=NUM(3,I) 475 : IPT1.ICOLOR(J)=ICOLOR(I) 476 : J=J+1 477 : IPT1.NUM(1,J)=NUM(1,I) 478 : IPT1.NUM(2,J)=NUM(3,I) 479 : IPT1.NUM(3,J)=NUM(4,I) 480 : IPT1.ICOLOR(J)=ICOLOR(I) 481 : J=J+1 482 : IF (J.GT.IPT1.NUM(/2)) GOTO 103 483 : IPT1.NUM(1,J)=NUM(1,I+1) 484 : IPT1.NUM(2,J)=NUM(2,I+1) 485 : IPT1.NUM(3,J)=NUM(4,I+1) 486 : IPT1.ICOLOR(J)=ICOLOR(I+1) 487 : J=J+1 488 : IPT1.NUM(1,J)=NUM(2,I+1) 489 : IPT1.NUM(2,J)=NUM(3,I+1) 490 : IPT1.NUM(3,J)=NUM(4,I+1) 491 : IPT1.ICOLOR(J)=ICOLOR(I+1) 492 : 103 CONTINUE 493 : SEGSUP MELEME 494 : MELEME=IPT1 495 : GOTO 101 496 : 102 CONTINUE 497 : IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104 498 : C ON FAIT DES QUA8 OU DES TRI6 499 : NBNN=8 500 : NBELEM=NUM(/2) 501 : NBREF=4 502 : NBSOUS=0 503 : SEGINI IPT5 504 : IPT5.ITYPEL=10 505 : IPT1=LISREF(1) 506 : IPT2=LISREF(2) 507 : IPT3=LISREF(3) 508 : IPT4=LISREF(4) 509 : IPT5.LISREF(1)=IPT1 510 : IPT5.LISREF(2)=IPT2 511 : IPT5.LISREF(3)=IPT3 512 : IPT5.LISREF(4)=IPT4 513 : SEGACT IPT1,IPT2,IPT3,IPT4 514 : DO 105 J=1,NUM(/1) 515 : JJ=2*J-1 516 : DO 1051 I=1,NBELEM 517 : IPT5.NUM(JJ,I)=NUM(J,I) 518 : 1051 CONTINUE 519 : 105 CONTINUE 520 : DO 135 I=1,NBELEM 521 : IPT5.ICOLOR(I)=ICOLOR(I) 522 : 135 CONTINUE 523 : NLIG=IPT1.NUM(/2) 524 : DO 106 I=1,NLIG 525 : IPT5.NUM(2,I)=IPT1.NUM(2,I) 526 : IPT5.NUM(6,NBELEM+1-I)=IPT3.NUM(2,I) 527 : 106 CONTINUE 528 : DPAR=0 529 : NBPTS=IADR+NCOUCH*NLIG*3 530 : SEGADJ MCOORD 531 : DO 107 I=1,NCOUCH 532 : IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I) 533 : IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I) 534 : C ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS) 535 : C CREATION DES NOEUDS 536 : DIN=TABPA1(I) 537 : DPAR=DPAR+DIN 538 : IF (IOPTG.EQ.1) GOTO 110 539 : ANG=DPAR*DLONG/RAY 540 : SI=SIN(ANG) 541 : CO=COS(ANG) 542 : 110 CONTINUE 543 : IF (I.EQ.NCOUCH) GOTO 108 544 : DO 109 J=1,NLIG 545 : IREF=(IDIM+1)*(IPT1.NUM(2,J)-1) 546 : IF (IOPTG.NE.1) GOTO 111 547 : XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+DPAR*XDIS 548 : XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+DPAR*YDIS 549 : IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+DPAR 550 : $ *ZDIS 551 : GOTO 112 552 : 111 X1=XCOOR(IREF+1)-XPT1 553 : Y1=XCOOR(IREF+2)-YPT1 554 : Z1=XCOOR(IREF+3)-ZPT1 555 : IF (IDIM.EQ.2) Z1=0.D0 556 : XV=X1*XV1+Y1*YV1+Z1*ZV1 557 : YV=X1*XV2+Y1*YV2+Z1*ZV2 558 : ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC 559 : XD=XV*CO-YV*SI 560 : YD=XV*SI+YV*CO 561 : ZD=ZV 562 : XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 563 : XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 564 : IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD*ZVEC 565 : $ +ZPT1 566 : 112 XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*DPAR 567 : IADR=IADR+1 568 : C ON MET LE NOEUD DANS LES ELEMENTS 569 : IPT5.NUM(6,(I-1)*NLIG+J)=IADR 570 : IPT5.NUM(2,I*NLIG+J)=IADR 571 : 109 CONTINUE 572 : 108 CONTINUE 573 : IF (NLIG.EQ.1) GOTO 113 574 : C ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE 575 : C CREATION DES NOEUDS 576 : EPAR=DPAR-TABPA1(I)*0.5D0 577 : IF (IOPTG.EQ.1) GOTO 114 578 : ANG=EPAR*DLONG/RAY 579 : SI=SIN(ANG) 580 : CO=COS(ANG) 581 : 114 CONTINUE 582 : DO 115 J=1,NLIG 583 : DO 1151 K=1,2 584 : IF (K.EQ.1.AND.J.EQ.1) GOTO 1151 585 : IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 1151 586 : IF (ICPR1(K,J).NE.0) GOTO 116 587 : IREF=(IPT1.NUM(2*K-1,J)-1)*(IDIM+1) 588 : IF (IOPTG.NE.1) GOTO 117 589 : XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+EPAR*XDIS 590 : XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+EPAR*YDIS 591 : IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+EPAR 592 : $ *ZDIS 593 : GOTO 118 594 : 117 X1=XCOOR(IREF+1)-XPT1 595 : Y1=XCOOR(IREF+2)-YPT1 596 : Z1=XCOOR(IREF+3)-ZPT1 597 : IF (IDIM.EQ.2) Z1=0 598 : XV=X1*XV1+Y1*YV1+Z1*ZV1 599 : YV=X1*XV2+Y1*YV2+Z1*ZV2 600 : ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC 601 : XD=XV*CO-YV*SI 602 : YD=XV*SI+YV*CO 603 : ZD=ZV 604 : XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 605 : XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 606 : IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD 607 : $ *ZVEC+ZPT1 608 : 118 XCOOR((IADR+1)*(IDIM+1))=DEN1+DECA*EPAR 609 : IADR=IADR+1 610 : 116 CONTINUE 611 : C NOEUDS DES ELEM 612 : IF (ICPR1(K,J).NE.0) GOTO 119 613 : IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR 614 : GOTO 1151 615 : 119 CONTINUE 616 : IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR1(K 617 : $ ,J)-1,2)),(ICPR1(K,J)+1)/2+(I-1)*NLIG) 618 : 1151 CONTINUE 619 : 115 CONTINUE 620 : 113 CONTINUE 621 : 107 CONTINUE 622 : NBPTS=IADR 623 : SEGADJ MCOORD 624 : SEGSUP MELEME 625 : MELEME=IPT5 626 : SEGDES IPT1,IPT2,IPT3,IPT4 627 : IF (KSURF(ILCOUR).NE.6) GOTO 101 628 : C ON FAIT DES TRI6 629 : NBNN=6 630 : NBELEM=2*NUM(/2) 631 : NBREF=4 632 : NBSOUS=0 633 : SEGINI IPT1 634 : IPT1.ITYPEL=6 635 : IPT1.LISREF(1)=LISREF(1) 636 : IPT1.LISREF(2)=LISREF(2) 637 : IPT1.LISREF(3)=LISREF(3) 638 : IPT1.LISREF(4)=LISREF(4) 639 : DPAR=0 640 : IALT=1 641 : NBPTS=IADR+NCOUCH*NLIG 642 : SEGADJ MCOORD 643 : DO 120 I=1,NCOUCH 644 : DIN=TABPA1(I) 645 : DPAR=DPAR+DIN 646 : EPAR=DPAR-DIN*0.5D0 647 : IF (IOPTG.EQ.1) GOTO 121 648 : ANG=EPAR*DLONG/RAY 649 : SI=SIN(ANG) 650 : CO=COS(ANG) 651 : 121 CONTINUE 652 : DO 1201 J=1,NLIG 653 : INU=(I-1)*NLIG+J 654 : IALT=3-IALT 655 : C CREATION DU POINT SUPPLEMENTAIRE 656 : IREF=(NUM(2,J)-1)*(IDIM+1) 657 : IF (IOPTG.NE.1) GOTO 122 658 : XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+EPAR*XDIS 659 : XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+EPAR*YDIS 660 : IF (IDIM.EQ.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+EPAR 661 : $ *ZDIS 662 : GOTO 123 663 : 122 X1=XCOOR(IREF+1)-XPT1 664 : Y1=XCOOR(IREF+2)-YPT1 665 : Z1=XCOOR(IREF+3)-ZPT1 666 : IF (IDIM.EQ.2) Z1=0.D0 667 : XV=X1*XV1+Y1*YV1+Z1*ZV1 668 : YV=X1*XV2+Y1*YV2+Z1*ZV2 669 : ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC 670 : XD=XV*CO-YV*SI 671 : YD=XV*SI+YV*CO 672 : ZD=ZV 673 : XCOOR(IADR*(IDIM+1)+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 674 : XCOOR(IADR*(IDIM+1)+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 675 : IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XD*ZV1+YD*ZV2+ZD*ZVEC 676 : $ +ZPT1 677 : 123 XCOOR((IADR+1)*(IDIM+1))=DENI+DECA*EPAR 678 : IADR=IADR+1 679 : ITR1=2*INU-1 680 : ITR2=2*INU 681 : GOTO (124,125),IALT 682 : C CREATION DES TRIANGLES 683 : 124 IPT1.NUM(1,ITR1)=NUM(1,INU) 684 : IPT1.NUM(2,ITR1)=NUM(2,INU) 685 : IPT1.NUM(3,ITR1)=NUM(3,INU) 686 : IPT1.NUM(5,ITR1)=NUM(7,INU) 687 : IPT1.NUM(6,ITR1)=NUM(8,INU) 688 : IPT1.NUM(4,ITR1)=IADR 689 : IPT1.NUM(1,ITR2)=NUM(3,INU) 690 : IPT1.NUM(2,ITR2)=NUM(4,INU) 691 : IPT1.NUM(3,ITR2)=NUM(5,INU) 692 : IPT1.NUM(4,ITR2)=NUM(6,INU) 693 : IPT1.NUM(5,ITR2)=NUM(7,INU) 694 : IPT1.NUM(6,ITR2)=IADR 695 : IPT1.ICOLOR(ITR1)=ICOLOR(INU) 696 : IPT1.ICOLOR(ITR2)=ICOLOR(INU) 697 : GOTO 126 698 : 125 IPT1.NUM(1,ITR1)=NUM(1,INU) 699 : IPT1.NUM(2,ITR1)=NUM(2,INU) 700 : IPT1.NUM(3,ITR1)=NUM(3,INU) 701 : IPT1.NUM(4,ITR1)=NUM(4,INU) 702 : IPT1.NUM(5,ITR1)=NUM(5,INU) 703 : IPT1.NUM(6,ITR1)=IADR 704 : IPT1.NUM(1,ITR2)=NUM(5,INU) 705 : IPT1.NUM(2,ITR2)=NUM(6,INU) 706 : IPT1.NUM(3,ITR2)=NUM(7,INU) 707 : IPT1.NUM(4,ITR2)=NUM(8,INU) 708 : IPT1.NUM(5,ITR2)=NUM(1,INU) 709 : IPT1.NUM(6,ITR2)=IADR 710 : IPT1.ICOLOR(ITR1)=ICOLOR(INU) 711 : IPT1.ICOLOR(ITR2)=ICOLOR(INU) 712 : GOTO 126 713 : 126 CONTINUE 714 : 1201 CONTINUE 715 : 120 CONTINUE 716 : SEGSUP MELEME 717 : MELEME=IPT1 718 : GOTO 101 719 : 104 CONTINUE 720 : 101 CONTINUE 721 : SEGSUP TABPAR,ICPR 722 : C S'IL Y A LIEU EXAMINER LA DEGENERESCENCE (ROTATION) 723 : SEGDES IPT1 724 : ** degsur n'a pas grand sens en 3D et ne marche pas 724 : ***** IF (IOPTG.NE.1) CALL DEGSUR(MELEME,IP1,IP2) 725 : IF (IFUSE.EQ.0) GOTO 63 726 : IPT5=IFUSE 727 : SEGACT IPT5,MELEME 728 : ltelq=.false. 728 : CALL FUSE(IPT5,MELEME,IRET,ltelq) 729 : SEGACT IPT5,MELEME 730 : IF (ITYPEL.EQ.IPT5.ITYPEL) SEGSUP MELEME 731 : SEGDES IPT5 732 : MELEME=IRET 733 : 63 CONTINUE 733 : CALL ECROBJ('MAILLAGE',MELEME) 734 : SEGDES MELEME 735 : RETURN 736 : END 737 : 738 : 739 : 740 : 741 : 742 : 743 : 744 : 745 : 746 : 747 : 748 : 749 : 750 : 751 : 752 :
© Cast3M 2003 - All rights reserved.
Disclaimer