1 : C GENERA SOURCE CHAT 07/10/30 21:16:24 5942 2 : C OPTION GENERATRICE 3 : C 4 : SUBROUTINE GENERA 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : DIMENSION XCO(4) 8 : -INC CCOPTIO 9 : -INC CCGEOME 10 : -INC SMCOORD 11 : -INC SMELEME 12 : logical ltelq 13 : SEGMENT ICPR(2,NBELEC) 14 : SEGMENT ICPP(XCOOR(/1)/(IDIM+1)) 15 : COMMON/CTOURN/XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,XVEC,YVEC, 16 : # ZVEC,ANGLE,ICLE 16 : IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16) 17 : IF (IERR.NE.0) RETURN 17 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 18 : IF (IERR.NE.0) RETURN 18 : CALL EXTRLI(IPT1,3,IRET,-1) 19 : IF (IERR.NE.0) RETURN 20 : IFUSE=0 21 : IF (IPT1.NE.IRET) IFUSE=IPT1 22 : IPT1=IRET 22 : CALL LIROBJ('MAILLAGE',IPT8,1,IRETOU) 23 : IF (IERR.NE.0) RETURN 24 : SEGACT IPT8 24 : IF (IPT8.ITYPEL.NE.KDEGRE(ILCOUR)) CALL ERREUR(16) 25 : IF (IERR.NE.0) RETURN 26 : NCOUCH=IPT8.NUM(/2) 27 : SEGACT IPT1 28 : SEGACT MCOORD 29 : NBNN=IPT1.NUM(/1) 30 : NBELEM=IPT1.NUM(/2) 31 : IBOUCL=0 32 : IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1 33 : 20 CONTINUE 34 : NX=NCOUCH-1 35 : IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH 36 : 1000 FORMAT(/,' COUCHES ',I6) 37 : NBNN=4 38 : NBELEM=IPT1.NUM(/2)*NCOUCH 39 : NBSOUS=0 40 : NBREF=4 41 : SEGINI MELEME 42 : ITYPEL=8 43 : INCR=IPT1.ITYPEL-1 44 : IL=1 45 : NBELEC=IPT1.NUM(/2) 46 : SEGINI ICPR 47 : C ON FAIT D'ABORD L' EXTREMITEE 48 : SEGINI ICPP 49 : DO 52 I=1,ICPP(/1) 50 : 52 ICPP(I)=0 51 : ICLE=1 52 : IPBAS=IPT8.NUM(1,1) 53 : IPHAU=IPT8.NUM(IPT8.NUM(/1),NCOUCH) 54 : IREFB=(IDIM+1)*(IPBAS-1) 55 : IREFH=(IDIM+1)*(IPHAU-1) 56 : DO 200 I=1,4 57 : XCO(I)=XCOOR(IREFH+I)-XCOOR(IREFB+I) 58 : 200 CONTINUE 58 : CALL ADDITE(XCO,IPT1,IPT3,ICPP,0) 59 : IF (IERR.NE.0) RETURN 60 : SEGSUP ICPP 61 : SEGACT MCOORD 62 : SEGACT IPT3 62 : CALL INVERS(IPT3,IPT4) 63 : SEGDES IPT4 64 : LISREF(3)=IPT4 65 : C ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS 66 : IDEB=XCOOR(/1)/(IDIM+1)+1 67 : DO 70 I=1,2 68 : DO 70 J=1,NBELEC 69 : 70 ICPR(I,J)=0 70 : LCPR=0 71 : DO 71 J=1,NBELEC 72 : DO 71 I=1,2 73 : I1=IPT1.NUM((I-1)*INCR+1,J) 74 : LCPR=LCPR+1 75 : DO 72 JJ=1,J 76 : DO 72 II=1,2 77 : IF (IPT1.NUM((II-1)*INCR+1,JJ).NE.I1) GOTO 72 78 : IF (II.NE.I) GOTO 73 79 : IF (JJ.EQ.J) GOTO 71 80 : 73 ICPR(I,J)=II+(JJ-1)*2 81 : LCPR=LCPR-1 82 : IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 75 83 : GOTO 71 84 : 75 IF (IBOUCL.EQ.1) GOTO 71 85 : ICPR(I,J)=0 86 : ICPR(II,JJ)=I+(J-1)*2 87 : GOTO 71 88 : 72 CONTINUE 89 : 71 CONTINUE 90 : * IL SEMBLERAIT QUE L'ON AIT NCOUCH A FAIRE AVEC LCPR POINTS EFFECTIFS 91 : C ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR 92 : C LE MOMENT D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER 93 : DO 40 I=1,IPT1.NUM(/2) 94 : NUM(1,I)=IPT1.NUM(1,I) 95 : NUM(2,I)=IPT1.NUM(1+INCR,I) 96 : 40 CONTINUE 97 : ILASI=IDEB-1 98 : ILASJ=ILASI+(INCR*NX)+INCR-1 99 : IF (IBOUCL.EQ.1) ILASJ=ILASI 100 : ILAS=ILASJ+INCR*NX+INCR 101 : DO 42 ICOUCH=1,NCOUCH 102 : IF (NCOUCH.EQ.ICOUCH) GOTO 41 103 : ILASI=ILASI+INCR 104 : ILASJ=ILASJ+INCR 105 : INI=(ICOUCH-1)*IPT1.NUM(/2) 106 : NUM(1,1+INI+NBELEC)=ILASI 107 : NUM(4,1+INI)=ILASI 108 : NUM(2,INI+2*NBELEC)=ILASJ 109 : NUM(3,INI+NBELEC)=ILASJ 110 : DO 42 J=1,IPT1.NUM(/2) 111 : DO 42 I=1,2 112 : ILL=ILAS 113 : IF (I.EQ.1.AND.J.EQ.1) GOTO 42 114 : IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 42 115 : IF (ICPR(I,J).NE.0) ILL=NUM(MOD(ICPR(I,J)-1,2)+1, 116 : # (ICPR(I,J)-1)/2+1+INI+NBELEC) 117 : NUM(I,J+INI+NBELEC)=ILL 118 : NUM(5-I,J+INI)=ILL 119 : IF (ICPR(I,J).NE.0) GOTO 42 120 : ILAS=ILL+1 121 : 42 CONTINUE 122 : 41 CONTINUE 123 : INI=(NCOUCH-1)*IPT1.NUM(/2) 124 : DO 43 I=1,NBELEC 125 : NUM(4,INI+I)=IPT3.NUM(1,I) 126 : NUM(3,INI+I)=IPT3.NUM(1+INCR,I) 127 : 43 CONTINUE 128 : DO 44 I=1,NCOUCH 129 : DO 44 J=1,IPT1.NUM(/2) 130 : II=(I-1)*IPT1.NUM(/2)+J 131 : 44 ICOLOR(II)=IPT1.ICOLOR(J) 132 : LISREF(1)=IPT1 133 : C CREATION DES BORDS LATERAUX PAR LIGNE PETIT SOUCI 134 : C CECI EST A REVOIR (NOUVEAU S-P POUR CE CAS QUI RESPECTE LA 135 : C NUMEROTATION 136 : ILS=IPT1.ITYPEL 137 : IDS=IPT1.ICOLOR(1) 138 : LP1=IPT1.NUM(1,1) 139 : LP2=IPT3.NUM(1,1) 139 : CALL GENERL(LP1,LP2,IPT8,IPT2,IDS) 140 : IF (IERR.NE.0) RETURN 140 : CALL INVERS(IPT2,IPT4) 141 : LISREF(4)=IPT4 142 : SEGDES IPT4,IPT2 143 : IF (IBOUCL.EQ.0) GOTO 46 144 : LISREF(2)=IPT2 145 : GOTO 45 146 : 46 CONTINUE 147 : IDS=IPT1.ICOLOR(IPT1.ICOLOR(/1)) 148 : LP2=IPT3.NUM(IPT3.NUM(/1),IPT3.NUM(/2)) 149 : LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2)) 149 : CALL GENERL(LP1,LP2,IPT8,IPT2,IDS) 150 : IF (IERR.NE.0) RETURN 151 : SEGDES IPT2 152 : LISREF(2)=IPT2 153 : 45 CONTINUE 154 : SEGSUP IPT3 155 : C CREATION DES POINTS (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES 156 : C EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS) 157 : IADR=XCOOR(/1)/(IDIM+1) 158 : IF (NCOUCH.EQ.1) GOTO 60 159 : NBPTS=IADR+IPT1.NUM(/2)*(NCOUCH-1)*2 160 : SEGADJ MCOORD 161 : DO 61 I=2,NCOUCH 162 : IF (IPT1.NUM(/2).EQ.1) GOTO 60 163 : IREFI=(IDIM+1)*(IPT8.NUM(1,I)-1) 164 : XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1) 165 : YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2) 166 : ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3) 167 : DO 62 J=1,IPT1.NUM(/2) 168 : DO 62 K=1,2 169 : IF (K.EQ.1.AND.J.EQ.1) GOTO 62 170 : IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 62 171 : IF (ICPR(K,J).NE.0) GOTO 62 172 : IREF=(IDIM+1)*IPT1.NUM((K-1)*INCR+1,J)-IDIM 173 : XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF)+XVI 174 : XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+1)+YVI 175 : IF (IDIM.NE.2) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+2)+ZVI 176 : XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM) 177 : IADR=IADR+1 178 : 62 CONTINUE 179 : 61 CONTINUE 180 : 60 CONTINUE 181 : NBPTS=IADR 182 : SEGADJ MCOORD 183 : IF (KSURF(ILCOUR).EQ.8) GOTO 101 184 : IF (KSURF(ILCOUR).NE.4) GOTO 102 185 : NBNN=3 186 : NBELEM=2*NUM(/2) 187 : NBREF=4 188 : NBSOUS=0 189 : SEGINI IPT1 190 : IPT1.ITYPEL=4 191 : IPT1.LISREF(1)=LISREF(1) 192 : IPT1.LISREF(2)=LISREF(2) 193 : IPT1.LISREF(3)=LISREF(3) 194 : IPT1.LISREF(4)=LISREF(4) 195 : DO 103 I=1,NUM(/2),2 196 : J=2*I-1 197 : IPT1.NUM(1,J)=NUM(1,I) 198 : IPT1.NUM(2,J)=NUM(2,I) 199 : IPT1.NUM(3,J)=NUM(3,I) 200 : IPT1.ICOLOR(J)=ICOLOR(I) 201 : J=J+1 202 : IPT1.NUM(1,J)=NUM(1,I) 203 : IPT1.NUM(2,J)=NUM(3,I) 204 : IPT1.NUM(3,J)=NUM(4,I) 205 : IPT1.ICOLOR(J)=ICOLOR(I) 206 : J=J+1 207 : IF (J.GT.IPT1.NUM(/2)) GOTO 103 208 : IPT1.NUM(1,J)=NUM(1,I+1) 209 : IPT1.NUM(2,J)=NUM(2,I+1) 210 : IPT1.NUM(3,J)=NUM(4,I+1) 211 : IPT1.ICOLOR(J)=ICOLOR(I+1) 212 : J=J+1 213 : IPT1.NUM(1,J)=NUM(2,I+1) 214 : IPT1.NUM(2,J)=NUM(3,I+1) 215 : IPT1.NUM(3,J)=NUM(4,I+1) 216 : IPT1.ICOLOR(J)=ICOLOR(I+1) 217 : 103 CONTINUE 218 : SEGSUP MELEME 219 : MELEME=IPT1 220 : GOTO 101 221 : 102 CONTINUE 222 : IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104 223 : C ON FAIT DES QUA8 OU DES TRI6 224 : NBNN=8 225 : NBELEM=NUM(/2) 226 : NBREF=4 227 : NBSOUS=0 228 : SEGINI IPT5 229 : IPT5.ITYPEL=10 230 : IPT1=LISREF(1) 231 : IPT2=LISREF(2) 232 : IPT3=LISREF(3) 233 : IPT4=LISREF(4) 234 : IPT5.LISREF(1)=IPT1 235 : IPT5.LISREF(2)=IPT2 236 : IPT5.LISREF(3)=IPT3 237 : IPT5.LISREF(4)=IPT4 238 : SEGACT IPT1,IPT2,IPT3,IPT4 239 : DO 105 J=1,NUM(/1) 240 : JJ=2*J-1 241 : DO 105 I=1,NBELEM 242 : IPT5.NUM(JJ,I)=NUM(J,I) 243 : 105 CONTINUE 244 : DO 135 I=1,NBELEM 245 : 135 IPT5.ICOLOR(I)=ICOLOR(I) 246 : NLIG=IPT1.NUM(/2) 247 : DO 106 I=1,NLIG 248 : IPT5.NUM(2,I)=IPT1.NUM(2,I) 249 : IPT5.NUM(6,NBELEM+1-I)=IPT3.NUM(2,I) 250 : 106 CONTINUE 251 : NBPTA=XCOOR(/1)/(IDIM+1) 252 : NBPTS=NBPTA+NCOUCH*(NLIG+NLIG*2) 253 : SEGADJ MCOORD 254 : DO 107 I=1,NCOUCH 255 : IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I) 256 : IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I) 257 : C ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS) 258 : C CREATION DES NOEUDS 259 : IF (I.EQ.NCOUCH) GOTO 108 260 : IREFI=(IDIM+1)*(IPT8.NUM(IPT8.NUM(/1),I)-1) 261 : XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1) 262 : YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2) 263 : ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3) 264 : DO 109 J=1,NLIG 265 : IREF=(IDIM+1)*(IPT1.NUM(2,J)-1) 266 : XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XVI 267 : XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YVI 268 : IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZVI 269 : XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM+1) 270 : IADR=IADR+1 271 : C ON MET LE NOEUD DANS LES ELEMENTS 272 : IPT5.NUM(6,(I-1)*NLIG+J)=IADR 273 : IPT5.NUM(2,I*NLIG+J)=IADR 274 : 109 CONTINUE 275 : 108 CONTINUE 276 : IF (NLIG.EQ.1) GOTO 113 277 : C ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE 278 : C CREATION DES NOEUDS 279 : IREFI=(IDIM+1)*(IPT8.NUM(2,I)-1) 280 : XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1) 281 : YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2) 282 : ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3) 283 : DO 115 J=1,NLIG 284 : DO 115 K=1,2 285 : IF (K.EQ.1.AND.J.EQ.1) GOTO 115 286 : IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 115 287 : IF (ICPR(K,J).NE.0) GOTO 116 288 : IREF=(IPT1.NUM(2*K-1,J)-1)*(IDIM+1) 289 : XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XVI 290 : XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YVI 291 : IF (IDIM.GE.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZVI 292 : XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM+1) 293 : IADR=IADR+1 294 : 116 CONTINUE 295 : C NOEUDS DES ELEM 296 : IF (ICPR(K,J).NE.0) GOTO 119 297 : IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR 298 : GOTO 115 299 : 119 CONTINUE 300 : IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR(K,J)-1,2)), 301 : # (ICPR(K,J)+1)/2+(I-1)*NLIG) 302 : 115 CONTINUE 303 : 113 CONTINUE 304 : 107 CONTINUE 305 : NBPTS=IADR 306 : SEGADJ MCOORD 307 : SEGSUP MELEME 308 : MELEME=IPT5 309 : SEGDES IPT1,IPT2,IPT3,IPT4 310 : IF (KSURF(ILCOUR).NE.6) GOTO 101 311 : C ON FAIT DES TRI6 312 : NBNN=6 313 : NBELEM=2*NUM(/2) 314 : NBREF=4 315 : NBSOUS=0 316 : SEGINI IPT1 317 : IPT1.ITYPEL=6 318 : IPT1.LISREF(1)=LISREF(1) 319 : IPT1.LISREF(2)=LISREF(2) 320 : IPT1.LISREF(3)=LISREF(3) 321 : IPT1.LISREF(4)=LISREF(4) 322 : IALT=1 323 : NBPTS=XCOOR(/1)/(IDIM+1)+NCOUCH*NLIG 324 : SEGADJ MCOORD 325 : DO 120 I=1,NCOUCH 326 : IREFI=(IDIM+1)*(IPT8.NUM(2,I)-1) 327 : XVI=XCOOR(IREFI+1)-XCOOR(IREFB+1) 328 : YVI=XCOOR(IREFI+2)-XCOOR(IREFB+2) 329 : ZVI=XCOOR(IREFI+3)-XCOOR(IREFB+3) 330 : DO 120 J=1,NLIG 331 : INU=(I-1)*NLIG+J 332 : IALT=3-IALT 333 : C CREATION DU POINT SUPPLEMENTAIRE 334 : IREF=(NUM(2,J)-1)*(IDIM+1) 335 : XCOOR(IADR*(IDIM+1)+1)=XCOOR(IREF+1)+XVI 336 : XCOOR(IADR*(IDIM+1)+2)=XCOOR(IREF+2)+YVI 337 : IF (IDIM.EQ.3) XCOOR(IADR*(IDIM+1)+3)=XCOOR(IREF+3)+ZVI 338 : XCOOR(IADR*(IDIM+1)+(IDIM+1))=XCOOR(IREF+IDIM+1) 339 : IADR=IADR+1 340 : ITR1=2*INU-1 341 : ITR2=2*INU 342 : GOTO (124,125),IALT 343 : C CREATION DES TRIANGLES 344 : 124 IPT1.NUM(1,ITR1)=NUM(1,INU) 345 : IPT1.NUM(2,ITR1)=NUM(2,INU) 346 : IPT1.NUM(3,ITR1)=NUM(3,INU) 347 : IPT1.NUM(5,ITR1)=NUM(7,INU) 348 : IPT1.NUM(6,ITR1)=NUM(8,INU) 349 : IPT1.NUM(4,ITR1)=IADR 350 : IPT1.NUM(1,ITR2)=NUM(3,INU) 351 : IPT1.NUM(2,ITR2)=NUM(4,INU) 352 : IPT1.NUM(3,ITR2)=NUM(5,INU) 353 : IPT1.NUM(4,ITR2)=NUM(6,INU) 354 : IPT1.NUM(5,ITR2)=NUM(7,INU) 355 : IPT1.NUM(6,ITR2)=IADR 356 : IPT1.ICOLOR(ITR1)=ICOLOR(INU) 357 : IPT1.ICOLOR(ITR2)=ICOLOR(INU) 358 : GOTO 126 359 : 125 IPT1.NUM(1,ITR1)=NUM(1,INU) 360 : IPT1.NUM(2,ITR1)=NUM(2,INU) 361 : IPT1.NUM(3,ITR1)=NUM(3,INU) 362 : IPT1.NUM(4,ITR1)=NUM(4,INU) 363 : IPT1.NUM(5,ITR1)=NUM(5,INU) 364 : IPT1.NUM(6,ITR1)=IADR 365 : IPT1.NUM(1,ITR2)=NUM(5,INU) 366 : IPT1.NUM(2,ITR2)=NUM(6,INU) 367 : IPT1.NUM(3,ITR2)=NUM(7,INU) 368 : IPT1.NUM(4,ITR2)=NUM(8,INU) 369 : IPT1.NUM(5,ITR2)=NUM(1,INU) 370 : IPT1.NUM(6,ITR2)=IADR 371 : IPT1.ICOLOR(ITR1)=ICOLOR(INU) 372 : IPT1.ICOLOR(ITR2)=ICOLOR(INU) 373 : GOTO 126 374 : 126 CONTINUE 375 : 120 CONTINUE 376 : SEGSUP MELEME 377 : MELEME=IPT1 378 : GOTO 101 379 : 104 CONTINUE 380 : 101 CONTINUE 381 : SEGSUP ICPR 382 : C S'IL Y A LIEU EXAMINER LA DEGENERESCENCE (ROTATION) 383 : SEGDES IPT1 384 : IF (IFUSE.EQ.0) GOTO 63 385 : IPT5=IFUSE 386 : SEGACT IPT5,MELEME 387 : ltelq=.false. 387 : CALL FUSE(IPT5,MELEME,IRET,ltelq) 388 : SEGDES IPT5 389 : SEGSUP MELEME 390 : MELEME=IRET 391 : 63 CONTINUE 391 : CALL ECROBJ('MAILLAGE',MELEME) 392 : SEGDES MELEME,IPT8 393 : RETURN 394 : END 395 : 396 : 397 : 398 : 399 : 400 : 401 :
© Cast3M 2003 - All rights reserved.
Disclaimer