1 : C REGLE SOURCE BP208322 13/02/07 21:15:12 7696 2 : C CONSTRUIT LA SURFACE REGLE ENTRE DEUX LIGNES DE MEME LONGUEUR 3 : C 4 : SUBROUTINE REGLE 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : -INC CCOPTIO 8 : -INC CCGEOME 9 : -INC SMCOORD 10 : -INC SMELEME 11 : 12 : SEGMENT TABPAR(NCOUCH) 13 : SEGMENT ICPR(2,NBELEC) 14 : 15 : logical ltelq 16 : * DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME =16 dans bdata 17 : DIMENSION ITEST(0:15) 18 : CHARACTER*(4) MLU 19 : 20 : IDIMP1 = IDIM+1 21 : IMPOI=0 22 : IMPOF=0 23 : DEN1=0. 24 : DEN2=0. 25 : C Y A T IL UN DECOUPAGE IMPOSE 26 : INBR=0 26 : CALL LIRENT(INBR,0,IRETOU) 27 : * IF (IRETOU.EQ.1) INBR=MAX(1,INBR) 28 : * SI INBR NEGATIF ALORS DECOUPAGE IMPOSE AVEC PROGRESSION D'APRES 29 : * LES DENSITES 30 : C Y A T-IL DES DENSITES IMPOSEES 30 : 80 CALL LIRCHA(MLU,0,IRETOU) 31 : IF (IRETOU.EQ.0) GOTO 83 32 : IF (MLU.NE.'DINI') GOTO 81 32 : CALL LIRREE(XXX,1,IRETOU) 33 : DEN1=XXX 34 : IF (IERR.NE.0) RETURN 35 : IMPOI=1 36 : IF (IMPOF.EQ.1) GOTO 83 36 : CALL LIRCHA(MLU,0,IRETOU) 37 : IF (IRETOU.EQ.0) GOTO 83 38 : 81 IF (MLU.NE.'DFIN') GOTO 82 38 : CALL LIRREE(XXX,1,IRETOU) 39 : DEN2=XXX 40 : IF (IERR.NE.0) RETURN 41 : IMPOF=1 42 : IF (IMPOI.EQ.0) GOTO 80 43 : GOTO 83 43 : 82 CALL REFUS 44 : 83 CONTINUE 44 : IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16) 44 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 45 : IF (IERR.NE.0) RETURN 45 : CALL EXTRLI(IPT1,3,IRET,-1) 46 : IF (IERR.NE.0) RETURN 47 : IFUSE1=0 48 : IF (IPT1.NE.IRET) IFUSE1=IPT1 49 : IPT1=IRET 49 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 50 : IF (IERR.NE.0) RETURN 50 : CALL EXTRLI(IPT2,1,IRET,1) 51 : IF (IERR.NE.0) RETURN 52 : IFUSE2=0 53 : IF (IPT2.NE.IRET) IFUSE2=IPT2 54 : IPT2=IRET 55 : SEGACT IPT1,IPT2 55 : IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) CALL ERREUR(16) 56 : NBELEM=IPT1.NUM(/2) 56 : IF (NBELEM.NE.IPT2.NUM(/2)) CALL ERREUR(33) 57 : IF (IERR.EQ.0) GOTO 2 58 : 1 SEGDES IPT1,IPT2 59 : RETURN 60 : 2 CONTINUE 61 : c c calcul de la couleur de melange via ITABM: 62 : c c fait ici, on va moyenner sur tous les elements 63 : c DO 90 I=0,(NBCOUL-1) 64 : c 90 ITEST(I)=0 65 : c DO 91 I=1,IPT1.NUM(/2) 66 : c ITEST(IPT1.ICOLOR(I))=1 67 : c 91 CONTINUE 68 : c DO 92 I=1,IPT2.NUM(/2) 69 : c ITEST(IPT2.ICOLOR(I))=1 70 : c 92 CONTINUE 71 : c ICHCOL=-1 72 : c DO 93 I=0,(NBCOUL-1) 73 : c IF (ITEST(I).EQ.1) THEN 74 : c IF (ICHCOL.EQ.-1) THEN 75 : c ICHCOL=I 76 : c ELSE 77 : c ICHCOL=ITABM(ICHCOL,I) 78 : c ENDIF 79 : c ENDIF 80 : c 93 CONTINUE 81 : SEGACT MCOORD 82 : NBNN=IPT1.NUM(/1) 83 : ZG1=0. 84 : ZG2=0. 85 : DLONG=0. 86 : IBOUCL=0 87 : IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1 88 : IF (IBOUCL.EQ.1.AND.IPT2.NUM(1,1).NE.IPT2.NUM(NBNN, 89 : #NBELEM)) THEN 89 : CALL ERREUR(33) 90 : GOTO 1 91 : ENDIF 92 : DEN1AU=DEN1 93 : DEN2AU=DEN2 94 : DO 10 I=1,NBNN 95 : DO 10 J=1,NBELEM 96 : IREF1=IPT1.NUM(I,J)*IDIMP1-IDIM 97 : XG1=XCOOR(IREF1) 98 : YG1=XCOOR(IREF1+1) 99 : IF (IDIM.GE.3) ZG1=XCOOR(IREF1+2) 100 : DEN1=XCOOR(IREF1+IDIM)+DEN1 101 : IREF2=IPT2.NUM(I,J)*IDIMP1-IDIM 102 : XG2=XCOOR(IREF2) 103 : YG2=XCOOR(IREF2+1) 104 : IF (IDIM.GE.3) ZG2=XCOOR(IREF2+2) 105 : DEN2=XCOOR(IREF2+IDIM)+DEN2 106 : XDIS=XG2-XG1 107 : YDIS=YG2-YG1 108 : ZDIS=ZG2-ZG1 109 : DLONG=SQRT(XDIS*XDIS+YDIS*YDIS+ZDIS*ZDIS)+DLONG 110 : 10 CONTINUE 111 : NBTOT=NBNN*NBELEM 112 : DEN1=DEN1/NBTOT 113 : DEN2=DEN2/NBTOT 114 : DLONG=DLONG/NBTOT 115 : IF (IMPOI.EQ.1) DEN1=DEN1AU 116 : IF (IMPOF.EQ.1) DEN2=DEN2AU 117 : DEN1A=DEN1 118 : DEN1B=DEN1 119 : DEN2A=DEN2 120 : DEN2B=DEN2 121 : DEN1=DEN1/DLONG 122 : DEN2=DEN2/DLONG 123 : DENI = 0. 124 : DECA = 0. 124 : CALL DECOUP(INBR,DEN1,DEN2,APROG,NCOUCH,DENI,DECA,DLONG) 125 : NX=NCOUCH-1 126 : IF(DENI.EQ. 0.D0) DENI = DLONG / NCOUCH 127 : IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH,APROG 128 : 1000 FORMAT(/' COUCHES ',I6,' RAISON ',G12.5) 129 : NBNN=4 130 : NBELEM=IPT1.NUM(/2)*NCOUCH 131 : NBSOUS=0 132 : NBREF=4 133 : SEGINI MELEME 134 : SEGINI TABPAR 135 : ITYPEL=8 136 : INCR=IPT1.ITYPEL-1 137 : IL=1 138 : NBELEC=IPT1.NUM(/2) 139 : SEGINI ICPR 139 : CALL INVERS(IPT2,IPT4) 140 : SEGDES IPT4 141 : LISREF(3)=IPT4 142 : C ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS 143 : IDEB=XCOOR(/1)/IDIMP1+1 144 : C* Redondant avec SEGINI ICPR ci-dessus 145 : C* DO 50 J=1,NBELEC 146 : C* DO 50 I=1,2 147 : C* 50 ICPR(I,J)=0 148 : LCPR=0 149 : DO 51 J=1,NBELEC 150 : DO 51 I=1,2 151 : I1=IPT1.NUM((I-1)*INCR+1,J) 152 : LCPR=LCPR+1 153 : DO 52 JJ=1,J 154 : DO 52 II=1,2 155 : IF (IPT1.NUM((II-1)*INCR+1,JJ).NE.I1) GOTO 52 156 : IF (II.NE.I) GOTO 53 157 : IF (JJ.EQ.J) GOTO 51 158 : 53 ICPR(I,J)=II+(JJ-1)*2 159 : LCPR=LCPR-1 160 : IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 55 161 : GOTO 51 162 : 55 IF (IBOUCL.EQ.1) GOTO 51 163 : ICPR(I,J)=0 164 : ICPR(II,JJ)=I+(J-1)*2 165 : GOTO 51 166 : 52 CONTINUE 167 : 51 CONTINUE 168 : C ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR 169 : C LE MOMENT D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER 170 : DIN=DEN1 171 : DO 60 I=1,IPT1.NUM(/2) 172 : NUM(1,I)=IPT1.NUM(1,I) 173 : NUM(2,I)=IPT1.NUM(1+INCR,I) 174 : c on crée la couleur moyenne par quadrangle 175 : ICOL1 = IPT1.ICOLOR(I) 176 : ICOL2 = IPT2.ICOLOR(I) 177 : ICOLOR(I)=ITABM(ICOL1,ICOL2) 178 : 60 CONTINUE 179 : ILASI=IDEB-1 180 : ILASJ=ILASI+(INCR*NX)+INCR-1 181 : IF (IBOUCL.EQ.1) ILASJ=ILASI 182 : ILAS=ILASJ+INCR*NX+INCR 183 : DO 62 ICOUCH=1,NCOUCH 184 : DIN=DIN*APROG 185 : TABPAR(ICOUCH)=DIN 186 : IF (NCOUCH.EQ.ICOUCH) GOTO 61 187 : ILASI=ILASI+INCR 188 : ILASJ=ILASJ+INCR 189 : INI=(ICOUCH-1)*IPT1.NUM(/2) 190 : NUM(1,1+INI+NBELEC)=ILASI 191 : NUM(4,1+INI)=ILASI 192 : NUM(2,INI+2*NBELEC)=ILASJ 193 : NUM(3,INI+NBELEC)=ILASJ 194 : INI=(ICOUCH-1)*IPT1.NUM(/2) 195 : DO 62 J=1,IPT1.NUM(/2) 196 : ICOLOR(J+INI+NBELEC)=ICOLOR(J) 197 : DO 62 I=1,2 198 : ILL=ILAS 199 : IF (I.EQ.1.AND.J.EQ.1) ILL=ILASI 200 : IF (I.EQ.2.AND.J.EQ.NBELEC) ILL=ILASJ 201 : IF (ICPR(I,J).NE.0) ILL=NUM(MOD(ICPR(I,J)-1,2)+1, 202 : # (ICPR(I,J)-1)/2+1+INI+NBELEC) 203 : NUM(I,J+INI+NBELEC)=ILL 204 : NUM(5-I,J+INI)=ILL 205 : IF (I.EQ.1.AND.J.EQ.1) GOTO 62 206 : IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 62 207 : IF (ICPR(I,J).NE.0) GOTO 62 208 : ILAS=ILL+1 209 : 62 CONTINUE 210 : TABPAR(NCOUCH)=DIN*APROG 211 : 61 CONTINUE 212 : INI=(NCOUCH-1)*IPT1.NUM(/2) 213 : DO 63 I=1,NBELEC 214 : NUM(4,INI+I)=IPT2.NUM(1,I) 215 : NUM(3,INI+I)=IPT2.NUM(1+INCR,I) 216 : 63 CONTINUE 217 : LISREF(1)=IPT1 218 : C CREATION DES BORDS LATERAUX PAR LIGNE (DROITE) 219 : C IMPOSONS ILCOUR POUR CETTE MANIP (LES BORDS LATERAUX DOIVENT ETRE 220 : C CONSISTANT AVEC LES AUTRES ) 221 : ILSAUV=ILCOUR 222 : ILCOUR=IPT1.ITYPEL 223 : ITYPL=1 224 : LP2=IPT2.NUM(1,1) 224 : CALL ECROBJ('POINT ',LP2) 225 : LP1=IPT1.NUM(1,1) 225 : CALL ECROBJ('POINT ',LP1) 226 : C CORRECTION POUR TENIR COMPTE DE LA DIFFERENCE DE LONGUEUR ENTRE 227 : C LE BORD ET LE MILIEU 228 : IREF1=(LP1-1)*IDIMP1 229 : IREF2=(LP2-1)*IDIMP1 230 : DL=0. 231 : DO 67 I=1,IDIM 232 : DL=DL+(XCOOR(IREF1+I)-XCOOR(IREF2+I))**2 233 : 67 CONTINUE 234 : DL=SQRT(DL) 235 : DEN1A=DEN1A*DL/DLONG 236 : DEN2A=DEN2A*DL/DLONG 236 : CALL LIGNE(ITYPL,0,DEN1A,DEN2A,INBR) 237 : IF (IERR.NE.0) GOTO 100 237 : CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU) 238 : SEGACT IPT3 238 : CALL INVERS(IPT3,IPT4) 239 : LISREF(4)=IPT4 240 : SEGDES IPT4 241 : IF (IBOUCL.EQ.0) GOTO 66 242 : LISREF(2)=IPT3 243 : SEGDES IPT3 244 : GOTO 65 245 : 66 CONTINUE 246 : SEGSUP IPT3 247 : LP2=IPT2.NUM(IPT2.NUM(/1),IPT2.NUM(/2)) 247 : CALL ECROBJ('POINT ',LP2) 248 : LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2)) 248 : CALL ECROBJ('POINT ',LP1) 249 : IREF1=(LP1-1)*IDIMP1 250 : IREF2=(LP2-1)*IDIMP1 251 : DL=0. 252 : DO 68 I=1,IDIM 253 : DL=DL+(XCOOR(IREF1+I)-XCOOR(IREF2+I))**2 254 : 68 CONTINUE 255 : DL=SQRT(DL) 256 : DEN1B=DEN1B*DL/DLONG 257 : DEN2B=DEN2B*DL/DLONG 257 : CALL LIGNE(ITYPL,0,DEN1B,DEN2B,INBR) 257 : CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU) 258 : IF (IERR.NE.0) GOTO 100 259 : SEGDES IPT3 260 : LISREF(2)=IPT3 261 : 65 CONTINUE 262 : C ON RESTAURE ILCOUR 263 : 100 CONTINUE 264 : ILCOUR=ILSAUV 265 : IF (IERR.NE.0) RETURN 266 : C CREATION DES POINTS (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES 267 : C EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS) 268 : DPAR=0. 269 : SEGACT MCOORD 270 : IADR=XCOOR(/1)/IDIMP1 271 : IF (NCOUCH.EQ.1) GOTO 70 272 : NBPTS=IADR+(NCOUCH-1)*IPT1.NUM(/2)*2 273 : SEGADJ MCOORD 274 : DO 71 I=2,NCOUCH 275 : DIN=TABPAR(I-1) 276 : DPAR=DPAR+DIN 277 : IF (IPT1.NUM(/2).EQ.1) GOTO 70 278 : UMDPAR=1.-DPAR 279 : DINA=DENI+DECA*DPAR 280 : DO 72 J=1,IPT1.NUM(/2) 281 : DO 72 K=1,2 282 : IF (K.EQ.1.AND.J.EQ.1) GOTO 72 283 : IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 72 284 : IF (ICPR(K,J).NE.0) GOTO 72 285 : IREF1=IDIMP1*IPT1.NUM((K-1)*INCR+1,J)-IDIM 286 : IREF2=IDIMP1*IPT2.NUM((K-1)*INCR+1,J)-IDIM 287 : IREFA=IADR*IDIMP1 288 : XCOOR(IREFA+1)=UMDPAR*XCOOR(IREF1) +DPAR*XCOOR(IREF2) 289 : XCOOR(IREFA+2)=UMDPAR*XCOOR(IREF1+1)+DPAR*XCOOR(IREF2+1) 290 : IF(IDIM.NE.2) 291 : #XCOOR(IREFA+3)=UMDPAR*XCOOR(IREF1+2)+DPAR*XCOOR(IREF2+2) 292 : XCOOR(IREFA+IDIMP1)=DINA 293 : IADR=IADR+1 294 : 72 CONTINUE 295 : 71 CONTINUE 296 : 70 CONTINUE 297 : NBPTS=IADR 298 : SEGADJ MCOORD 299 : IPT7=IPT1 300 : IPT8=IPT2 301 : IF (KSURF(ILCOUR).EQ.8) GOTO 101 302 : IF (KSURF(ILCOUR).NE.4) GOTO 102 303 : NBNN=3 304 : NBELEM=2*NUM(/2) 305 : NBREF=4 306 : NBSOUS=0 307 : SEGINI IPT1 308 : IPT1.ITYPEL=4 309 : IPT1.LISREF(1)=LISREF(1) 310 : IPT1.LISREF(2)=LISREF(2) 311 : IPT1.LISREF(3)=LISREF(3) 312 : IPT1.LISREF(4)=LISREF(4) 313 : DO 103 I=1,NUM(/2),2 314 : J=2*I-1 315 : IPT1.NUM(1,J)=NUM(1,I) 316 : IPT1.NUM(2,J)=NUM(2,I) 317 : IPT1.NUM(3,J)=NUM(3,I) 318 : IPT1.ICOLOR(J) = ICOLOR(I) 319 : J=J+1 320 : IPT1.NUM(1,J)=NUM(1,I) 321 : IPT1.NUM(2,J)=NUM(3,I) 322 : IPT1.NUM(3,J)=NUM(4,I) 323 : IPT1.ICOLOR(J) = ICOLOR(I) 324 : J=J+1 325 : IF (J.GT.IPT1.NUM(/2)) GOTO 103 326 : IPT1.NUM(1,J)=NUM(1,I+1) 327 : IPT1.NUM(2,J)=NUM(2,I+1) 328 : IPT1.NUM(3,J)=NUM(4,I+1) 329 : IPT1.ICOLOR(J) = ICOLOR(I) 330 : J=J+1 331 : IPT1.NUM(1,J)=NUM(2,I+1) 332 : IPT1.NUM(2,J)=NUM(3,I+1) 333 : IPT1.NUM(3,J)=NUM(4,I+1) 334 : IPT1.ICOLOR(J) = ICOLOR(I) 335 : 103 CONTINUE 336 : SEGSUP MELEME 337 : MELEME=IPT1 338 : GOTO 101 339 : 102 CONTINUE 340 : * write (6,*) ' ilcour ksurf ',ilcour,ksurf(ilcour) 341 : 342 : IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104 343 : if (ipt7.itypel.ne.3) goto 104 344 : C ON FAIT DES QUA8 OU DES TRI6 345 : NBNN=8 346 : NBELEM=NUM(/2) 347 : NBREF=4 348 : NBSOUS=0 349 : SEGINI IPT5 350 : IPT5.ITYPEL=10 351 : IPT1=LISREF(1) 352 : IPT2=LISREF(2) 353 : IPT3=LISREF(3) 354 : IPT4=LISREF(4) 355 : IPT5.LISREF(1)=IPT1 356 : IPT5.LISREF(2)=IPT2 357 : IPT5.LISREF(3)=IPT3 358 : IPT5.LISREF(4)=IPT4 359 : SEGACT IPT1,IPT2,IPT3,IPT4 360 : DO 105 J=1,NUM(/1) 361 : JJ=2*J-1 362 : DO 105 I=1,NBELEM 363 : IPT5.NUM(JJ,I)=NUM(J,I) 364 : 105 CONTINUE 365 : NLIG=IPT1.NUM(/2) 366 : DO 106 I=1,NLIG 367 : IPT5.NUM(2,I)=IPT7.NUM(2,I) 368 : IPT5.NUM(6,NBELEM-NLIG+I)=IPT8.NUM(2,I) 369 : IPT5.ICOLOR(I) = IPT1.ICOLOR(I) 370 : 106 CONTINUE 371 : DPAR=0. 372 : NBPTS=IADR+NCOUCH*3*NLIG 373 : SEGADJ MCOORD 374 : DO 107 I=1,NCOUCH 375 : IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I) 376 : IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I) 377 : C ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS) 378 : C CREATION DES NOEUDS 379 : DIN=TABPAR(I) 380 : DPAR=DPAR+DIN 381 : IF (I.EQ.NCOUCH) GOTO 108 382 : UMDPAR=1.-DPAR 383 : DINA=DENI+DECA*DPAR 384 : DO 109 J=1,NLIG 385 : IREF1=IDIMP1*(IPT7.NUM(2,J)-1) 386 : IREF2=IDIMP1*(IPT8.NUM(2,J)-1) 387 : IREFA=IADR*IDIMP1 388 : XCOOR(IREFA+1)=UMDPAR*XCOOR(IREF1+1)+DPAR*XCOOR(IREF2+1) 389 : XCOOR(IREFA+2)=UMDPAR*XCOOR(IREF1+2)+DPAR*XCOOR(IREF2+2) 390 : IF(IDIM.GE.3) 391 : #XCOOR(IREFA+3)=UMDPAR*XCOOR(IREF1+3)+DPAR*XCOOR(IREF2+3) 392 : XCOOR(IREFA+IDIMP1)=DINA 393 : IADR=IADR+1 394 : C ON MET LE NOEUD DANS LES ELEMENTS 395 : IPT5.NUM(6,(I-1)*NLIG+J)=IADR 396 : IPT5.NUM(2,I*NLIG+J)=IADR 397 : IPT5.ICOLOR(I*NLIG+J) = IPT1.ICOLOR(J) 398 : 109 CONTINUE 399 : 108 CONTINUE 400 : IF (NLIG.EQ.1) GOTO 113 401 : C ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE 402 : C CREATION DES NOEUDS 403 : EPAR=DPAR-TABPAR(I)*0.5 404 : UMEPAR=1.-EPAR 405 : DINA=DEN1+DECA*EPAR 406 : DO 115 J=1,NLIG 407 : DO 115 K=1,2 408 : IF (K.EQ.1.AND.J.EQ.1) GOTO 115 409 : IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 115 410 : IF (ICPR(K,J).NE.0) GOTO 116 411 : IREF1=(IPT7.NUM(2*K-1,J)-1)*IDIMP1 412 : IREF2=(IPT8.NUM(2*K-1,J)-1)*IDIMP1 413 : IREFA=IADR*IDIMP1 414 : XCOOR(IREFA+1)=UMEPAR*XCOOR(IREF1+1)+EPAR*XCOOR(IREF2+1) 415 : XCOOR(IREFA+2)=UMEPAR*XCOOR(IREF1+2)+EPAR*XCOOR(IREF2+2) 416 : IF(IDIM.GE.3) 417 : #XCOOR(IREFA+3)=UMEPAR*XCOOR(IREF1+3)+EPAR*XCOOR(IREF2+3) 418 : XCOOR(IREFA+IDIMP1)=DINA 419 : IADR=IADR+1 420 : 116 CONTINUE 421 : C NOEUDS DES ELEM 422 : IF (ICPR(K,J).NE.0) GOTO 119 423 : IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR 424 : GOTO 115 425 : 119 CONTINUE 426 : IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR(K,J)-1,2)), 427 : # (ICPR(K,J)+1)/2+(I-1)*NLIG) 428 : 115 CONTINUE 429 : 113 CONTINUE 430 : 107 CONTINUE 431 : NBPTS=IADR 432 : SEGADJ MCOORD 433 : SEGSUP MELEME 434 : MELEME=IPT5 435 : SEGDES IPT1,IPT2,IPT3,IPT4,IPT7,IPT8 436 : IF (KSURF(ILCOUR).NE.6) GOTO 101 437 : C ON FAIT DES TRI6 438 : NBNN=6 439 : NBELEM=2*NUM(/2) 440 : NBREF=4 441 : NBSOUS=0 442 : SEGINI IPT1 443 : IPT1.ITYPEL=6 444 : IPT1.LISREF(1)=LISREF(1) 445 : IPT1.LISREF(2)=LISREF(2) 446 : IPT1.LISREF(3)=LISREF(3) 447 : IPT1.LISREF(4)=LISREF(4) 448 : IALT=1 449 : NBPTS=IADR+NCOUCH*NLIG 450 : SEGADJ MCOORD 451 : DO 120 I=1,NCOUCH 452 : DO 120 J=1,NLIG 453 : INU=(I-1)*NLIG+J 454 : IALT=3-IALT 455 : C CREATION DU POINT SUPPLEMENTAIRE 456 : IREF1=(NUM(2,INU)-1)*IDIMP1 457 : IREF2=(NUM(6,INU)-1)*IDIMP1 458 : IREFA=IADR*IDIMP1 459 : XCOOR(IREFA+1)=(XCOOR(IREF1+1)+XCOOR(IREF2+1))*0.5 460 : XCOOR(IREFA+2)=(XCOOR(IREF1+2)+XCOOR(IREF2+2))*0.5 461 : IF (IDIM.GE.3) 462 : #XCOOR(IREFA+3)=(XCOOR(IREF1+3)+XCOOR(IREF2+3))*0.5 463 : XCOOR(IREFA+IDIMP1)= 464 : # (XCOOR(IREF1+IDIMP1)+XCOOR(IREF2+IDIMP1))*0.5 465 : IADR=IADR+1 466 : ITR1=2*INU-1 467 : ITR2=2*INU 468 : GOTO (124,125),IALT 469 : C CREATION DES TRIANGLES 470 : 124 IPT1.NUM(1,ITR1)=NUM(1,INU) 471 : IPT1.NUM(2,ITR1)=NUM(2,INU) 472 : IPT1.NUM(3,ITR1)=NUM(3,INU) 473 : IPT1.NUM(5,ITR1)=NUM(7,INU) 474 : IPT1.NUM(6,ITR1)=NUM(8,INU) 475 : IPT1.NUM(4,ITR1)=IADR 476 : IPT1.NUM(1,ITR2)=NUM(3,INU) 477 : IPT1.NUM(2,ITR2)=NUM(4,INU) 478 : IPT1.NUM(3,ITR2)=NUM(5,INU) 479 : IPT1.NUM(4,ITR2)=NUM(6,INU) 480 : IPT1.NUM(5,ITR2)=NUM(7,INU) 481 : IPT1.NUM(6,ITR2)=IADR 482 : IPT1.ICOLOR(ITR1) = ICOLOR(INU) 483 : IPT1.ICOLOR(ITR2) = ICOLOR(INU) 484 : GOTO 126 485 : 125 IPT1.NUM(1,ITR1)=NUM(1,INU) 486 : IPT1.NUM(2,ITR1)=NUM(2,INU) 487 : IPT1.NUM(3,ITR1)=NUM(3,INU) 488 : IPT1.NUM(4,ITR1)=NUM(4,INU) 489 : IPT1.NUM(5,ITR1)=NUM(5,INU) 490 : IPT1.NUM(6,ITR1)=IADR 491 : IPT1.NUM(1,ITR2)=NUM(5,INU) 492 : IPT1.NUM(2,ITR2)=NUM(6,INU) 493 : IPT1.NUM(3,ITR2)=NUM(7,INU) 494 : IPT1.NUM(4,ITR2)=NUM(8,INU) 495 : IPT1.NUM(5,ITR2)=NUM(1,INU) 496 : IPT1.NUM(6,ITR2)=IADR 497 : IPT1.ICOLOR(ITR1) = ICOLOR(INU) 498 : IPT1.ICOLOR(ITR2) = ICOLOR(INU) 499 : GOTO 126 500 : 126 CONTINUE 501 : 120 CONTINUE 502 : SEGSUP MELEME 503 : MELEME=IPT1 504 : GOTO 101 505 : 104 CONTINUE 506 : 101 CONTINUE 507 : SEGSUP TABPAR,ICPR 508 : c c attribution de la couleur "moyenne" 509 : c DO 152 I=1,NUM(/2) 510 : c 152 ICOLOR(I)=ICHCOL 511 : IF (IFUSE1.EQ.0) GOTO 150 512 : IPT5=IFUSE1 513 : SEGACT IPT5 514 : ltelq=.false. 514 : CALL FUSE(IPT5,MELEME,IRET,ltelq) 515 : SEGDES IPT5,MELEME 516 : MELEME=IRET 517 : 150 CONTINUE 518 : IF (IFUSE2.EQ.0) GOTO 151 519 : IPT5=IFUSE2 520 : SEGACT IPT5 521 : ltelq=.false. 521 : CALL FUSE(MELEME,IPT5,IRET,ltelq) 522 : SEGDES IPT5,MELEME 523 : MELEME=IRET 524 : 151 CONTINUE 524 : CALL ECROBJ('MAILLAGE',MELEME) 525 : SEGDES MELEME 526 : RETURN 527 : END 528 : 529 : 530 : 531 :
© Cast3M 2003 - All rights reserved.
Disclaimer