1 : C KDOM4A SOURCE PV 13/04/16 21:15:17 7765 2 : SUBROUTINE KDOM4A(MTAB,MELEMQ) 3 : C 4 : C************************************************************************ 5 : C 6 : C PROJET : CASTEM 2000 7 : C 8 : C NOM : KDOM4A 9 : C 9 : C DESCRIPTION : Subroutine called by KDOM2A 10 : C Axial-symmetric case, TRI7 and QUA8 11 : C We compute 12 : C MTAB . 'MAILLAGE' 13 : C MTAB . 'CENTRE' 14 : C MTAB . 'XCEN2D' 15 : C MTAB . 'YCEN2D' 16 : C MTAB . 'XXVOLUM' 17 : C MTAB . 'XXSURF2D' 18 : C and we change the position for the central points 19 : C of MELEMQ 20 : C 21 : C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec estensions CISI) 22 : C 23 : C AUTEUR : A. BECCANTINI, DRN/DMT/SEMT/LTMF 24 : C 25 : C************************************************************************ 26 : C 27 : C INPUT/OUTPUT : MTAB : domaine table 28 : C MELEMQ : QUAF mesh 29 : C************************************************************************ 30 : C 31 : C Created the 24/02/04 32 : C 33 : C 34 : C**** Variables de COOPTIO 35 : C 36 : C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR 37 : C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ 38 : C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES 39 : C & ,IECHO, IIMPI, IOSPI 40 : C & ,IDIM, IFICLE, IPREFI 41 : CC & ,MCOORD 42 : C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE 43 : C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU 44 : C & ,NORINC,NORVAL,NORIND,NORVAD 45 : C & ,NUCROU, IPSAUV, IREFOR, ISAFOR 46 : CC 47 : C 48 : IMPLICIT INTEGER(I-N) 49 : -INC CCOPTIO 50 : -INC SMCOORD 51 : -INC SMELEME 52 : -INC SMLMOTS 53 : -INC SMCHPOI 54 : -INC SMLENTI 55 : INTEGER MTAB, MELEMQ 56 : & ,MCHPSU,MCHPNO,MCHPMR,MCHX2D,MCHY2D 57 : & , NBS, NBREF, ITSOUS, NBNN, NBELEM, NBSOUS,NBE0 58 : & , JGM, JGN, IGEOM, ISOUS, IELEM 59 : & , NN1, NN2, NN3, NNC, NN4 60 : & , NFAC, NSOM, NTP, JG, LAST, LASTS 61 : & , LISFAC(4), LISSOM(4), NNS, NNOEU 62 : & , INOE 63 : & , LIFAC(3,4), MCHDIA 64 : REAL*8 X1,Y1,X2,Y2,X3,Y3,XCEN,YCEN, SURF, VOLU 65 : & ,X4,Y4,SURF0,VOLU0,XCEN0,YCEN0,XC2D,YC2D,XC20,YC20 66 : CHARACTER*8 TYPI 67 : POINTEUR MELMAI.MELEME, MELCEN.MELEME, MELTFA.MELEME 68 : & , MELSOM.MELEME, MELFAC.MELEME, MELFAL.MELEME, MELFAP.MELEME 69 : POINTEUR MCHVOL.MCHPOI, MPOVOL.MPOVAL 70 : & , MCHS2D.MCHPOI, MPOSUR.MPOVAL, MPOX2D.MPOVAL, MPOY2D.MPOVAL 71 : POINTEUR MLRES.MLENTI, MLRESS.MLENTI, MLEFAC.MLENTI, MLETOF.MLENTI 72 : C 73 : C**** 'MAILLAGE' 74 : C 75 : MELEME=MELEMQ 76 : SEGACT MELEME 77 : SEGINI, MELMAI=MELEME 78 : NBS=MELEME.LISOUS(/1) 79 : IF(NBS.EQ.0)NBS=1 80 : NBREF=0 81 : IF(NBS .EQ. 1)THEN 82 : ITSOUS=MELEME.ITYPEL 83 : IF(ITSOUS .EQ. 7)THEN 84 : C TRI7 -> TRI3 85 : MELMAI.ITYPEL=4 86 : NBNN=3 87 : ELSEIF(ITSOUS .EQ. 11)THEN 88 : C QUA9 -> QUA4 89 : MELMAI.ITYPEL=8 90 : NBNN=4 91 : ENDIF 92 : NBELEM=MELEME.NUM(/2) 93 : NBSOUS=0 94 : SEGADJ MELMAI 95 : NBE0=NBELEM 96 : ELSE 97 : NBE0=0 98 : DO ISOUS=1,NBS,1 99 : IPT1=MELEME.LISOUS(ISOUS) 100 : SEGACT IPT1 101 : ITSOUS=IPT1.ITYPEL 102 : NBELEM=IPT1.NUM(/2) 103 : IF(ITSOUS .EQ. 7)THEN 104 : C TRI7 -> TRI3 105 : NBNN=3 106 : MELMAI.ITYPEL=4 107 : ELSEIF(ITSOUS .EQ. 11)THEN 108 : C QUA9 -> QUA4 109 : MELMAI.ITYPEL=8 110 : NBNN=4 111 : ENDIF 112 : NBSOUS=0 113 : SEGINI IPT2 114 : MELMAI.LISOUS(ISOUS)=IPT2 115 : IPT2.ITYPEL=MELMAI.ITYPEL 116 : MELMAI.ITYPEL=0 117 : NBE0=NBE0+NBELEM 118 : IPT1=MELEME.LISOUS(ISOUS) 119 : ENDDO 120 : ENDIF 120 : CALL ECMO(MTAB,'MAILLAGE','MAILLAGE',MELMAI) 121 : C 122 : C**** 'CENTRE' 123 : C 124 : NBELEM=NBE0 125 : NBNN=1 126 : NBSOUS=0 127 : NBREF=0 128 : SEGINI MELCEN 129 : MELCEN.ITYPEL=1 129 : CALL ECMO(MTAB,'CENTRE','MAILLAGE',MELCEN) 130 : C 131 : C**** 'XXVOLUM', 'XXSURF2D', 'XCEN2D', 'YCEN2D' 132 : C 133 : TYPI='CENTRE ' 134 : JGN=4 135 : JGM=1 136 : SEGINI MLMOTS 137 : MLMOTS.MOTS(1)='SCAL' 137 : CALL KRCHP1(TYPI,MELCEN,MCHVOL,MLMOTS) 138 : IF(IERR.NE.0) GOTO 9999 138 : CALL ECMO(MTAB,'XXVOLUM','CHPOINT',MCHVOL) 139 : IF(IERR.NE.0) GOTO 9999 139 : CALL LICHT(MCHVOL,MPOVOL,TYPI,IGEOM) 140 : IF(IERR.NE.0) GOTO 9999 141 : C SEGACT MPOVOL 142 : C 142 : CALL KRCHP1(TYPI,MELCEN,MCHS2D,MLMOTS) 143 : IF(IERR.NE.0) GOTO 9999 143 : CALL ECMO(MTAB,'XXSUR2D','CHPOINT',MCHS2D) 144 : IF(IERR.NE.0) GOTO 9999 144 : CALL LICHT(MCHS2D,MPOSUR,TYPI,IGEOM) 145 : IF(IERR.NE.0) GOTO 9999 146 : C SEGACT MPOSUR 147 : C 147 : CALL KRCHP1(TYPI,MELCEN,MCHX2D,MLMOTS) 148 : IF(IERR.NE.0) GOTO 9999 148 : CALL ECMO(MTAB,'XCEN2D','CHPOINT',MCHX2D) 149 : IF(IERR.NE.0) GOTO 9999 149 : CALL LICHT(MCHX2D,MPOX2D,TYPI,IGEOM) 150 : IF(IERR.NE.0) GOTO 9999 151 : C SEGACT MPOX2D 152 : C 152 : CALL KRCHP1(TYPI,MELCEN,MCHY2D,MLMOTS) 153 : IF(IERR.NE.0) GOTO 9999 153 : CALL ECMO(MTAB,'YCEN2D','CHPOINT',MCHY2D) 154 : IF(IERR.NE.0) GOTO 9999 154 : CALL LICHT(MCHY2D,MPOY2D,TYPI,IGEOM) 155 : IF(IERR.NE.0) GOTO 9999 156 : C SEGACT MPOY2D 157 : SEGSUP MLMOTS 158 : C 159 : C In KRIPAD 160 : C SEGDES MELCEN 161 : SEGACT MELCEN*MOD 162 : C 163 : C**** Filling 164 : C 165 : NBE0=0 166 : DO ISOUS=1,NBS,1 167 : IF(NBS.EQ.1)THEN 168 : IPT1=MELEME 169 : IPT2=MELMAI 170 : ELSE 171 : IPT1=MELEME.LISOUS(ISOUS) 172 : IPT2=MELMAI.LISOUS(ISOUS) 173 : ENDIF 174 : NBELEM=IPT1.NUM(/2) 175 : ITSOUS=IPT1.ITYPEL 176 : IF(ITSOUS .EQ. 7)THEN 177 : C TRI 178 : DO IELEM=1,NBELEM,1 179 : NBE0=NBE0+1 180 : NN1=IPT1.NUM(1,IELEM) 181 : NN2=IPT1.NUM(3,IELEM) 182 : NN3=IPT1.NUM(5,IELEM) 183 : NNC=IPT1.NUM(7,IELEM) 184 : C 185 : IPT2.NUM(1,IELEM)=NN1 186 : IPT2.NUM(2,IELEM)=NN2 187 : IPT2.NUM(3,IELEM)=NN3 188 : IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM) 189 : MELCEN.NUM(1,NBE0)=NNC 190 : MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM) 191 : C 192 : C************* We compute the position of the center 193 : C the 'XXVOLUM' 194 : C the 'XXSUR2D' 195 : C 196 : X1=XCOOR((NN1-1)*(IDIM+1)+1) 197 : Y1=XCOOR((NN1-1)*(IDIM+1)+2) 198 : X2=XCOOR((NN2-1)*(IDIM+1)+1) 199 : Y2=XCOOR((NN2-1)*(IDIM+1)+2) 200 : X3=XCOOR((NN3-1)*(IDIM+1)+1) 201 : Y3=XCOOR((NN3-1)*(IDIM+1)+2) 201 : CALL KDOM4B(X1,Y1,X2,Y2,X3,Y3,VOLU,SURF 202 : & ,XCEN,YCEN,XC2D,YC2D) 203 : C 204 : MPOVOL.VPOCHA(NBE0,1)=VOLU 205 : MPOSUR.VPOCHA(NBE0,1)=SURF 206 : MPOX2D.VPOCHA(NBE0,1)=XC2D 207 : MPOY2D.VPOCHA(NBE0,1)=YC2D 208 : XCOOR((NNC-1)*(IDIM+1)+1)=XCEN 209 : XCOOR((NNC-1)*(IDIM+1)+2)=YCEN 210 : ENDDO 211 : ELSEIF(ITSOUS .EQ. 11)THEN 212 : C QUA 213 : DO IELEM=1,NBELEM,1 214 : NBE0=NBE0+1 215 : NN1=IPT1.NUM(1,IELEM) 216 : NN2=IPT1.NUM(3,IELEM) 217 : NN3=IPT1.NUM(5,IELEM) 218 : NN4=IPT1.NUM(7,IELEM) 219 : NNC=IPT1.NUM(9,IELEM) 220 : C 221 : IPT2.NUM(1,IELEM)=NN1 222 : IPT2.NUM(2,IELEM)=NN2 223 : IPT2.NUM(3,IELEM)=NN3 224 : IPT2.NUM(4,IELEM)=NN4 225 : IPT2.ICOLOR(IELEM)=IPT1.ICOLOR(IELEM) 226 : MELCEN.NUM(1,NBE0)=NNC 227 : MELCEN.ICOLOR(NBE0)=IPT1.ICOLOR(IELEM) 228 : C 229 : C************* We compute the position of the center 230 : C the 'XXVOLUM' 231 : C the 'XXSUR2D' 232 : C 233 : X1=XCOOR((NN1-1)*(IDIM+1)+1) 234 : Y1=XCOOR((NN1-1)*(IDIM+1)+2) 235 : X2=XCOOR((NN2-1)*(IDIM+1)+1) 236 : Y2=XCOOR((NN2-1)*(IDIM+1)+2) 237 : X3=XCOOR((NN3-1)*(IDIM+1)+1) 238 : Y3=XCOOR((NN3-1)*(IDIM+1)+2) 239 : X4=XCOOR((NN4-1)*(IDIM+1)+1) 240 : Y4=XCOOR((NN4-1)*(IDIM+1)+2) 240 : CALL KDOM4B(X1,Y1,X2,Y2,X4,Y4,VOLU0,SURF0,XCEN0,YCEN0 241 : $ ,XC20,YC20) 241 : CALL KDOM4B(X2,Y2,X3,Y3,X4,Y4,VOLU,SURF,XCEN,YCEN 242 : $ ,XC2D,YC2D) 243 : C 244 : MPOVOL.VPOCHA(NBE0,1)=VOLU+VOLU0 245 : MPOSUR.VPOCHA(NBE0,1)=SURF+SURF0 246 : MPOX2D.VPOCHA(NBE0,1)=((XC20*SURF0)+(XC2D*SURF)) 247 : $ /(SURF+SURF0) 248 : MPOY2D.VPOCHA(NBE0,1)=((YC20*SURF0)+(YC2D*SURF)) 249 : $ /(SURF+SURF0) 250 : XCOOR((NNC-1)*(IDIM+1)+1)=((XCEN0*VOLU0)+(XCEN*VOLU)) 251 : $ /(VOLU+VOLU0) 252 : XCOOR((NNC-1)*(IDIM+1)+2)=((YCEN0*VOLU0)+(YCEN*VOLU)) 253 : $ /(VOLU+VOLU0) 254 : ENDDO 255 : ENDIF 256 : SEGDES IPT2 257 : ENDDO 258 : C 259 : IF(NBS.NE.1)THEN 260 : SEGDES MELMAI 261 : ENDIF 262 : C 263 : SEGDES MPOSUR 264 : SEGDES MPOVOL 265 : SEGDES MELCEN 266 : C 267 : C MELEME et ses "fils" sont toujours actifs 268 : C 269 : C**** We create ELTFA, FACE and SOMMET 270 : C N.B. The position of the noeud belonging to the FACE 271 : C is not correct 272 : C 273 : SEGINI, MELTFA=MELEME 274 : NBREF=0 275 : IF(NBS .EQ. 1)THEN 276 : ITSOUS=MELEME.ITYPEL 277 : IF(ITSOUS .EQ. 7)THEN 278 : C TRI3 279 : NBNN=3 280 : MELTFA.ITYPEL=4 281 : C ELTFA TRI3 282 : ELSEIF(ITSOUS .EQ. 11)THEN 283 : C QUA4 284 : NBNN=4 285 : MELTFA.ITYPEL=8 286 : C ELTFA QUA4 287 : ENDIF 288 : NBELEM=MELEME.NUM(/2) 289 : NBSOUS=0 290 : SEGADJ MELTFA 291 : ELSE 292 : DO ISOUS=1,NBS,1 293 : IPT1=MELEME.LISOUS(ISOUS) 294 : NBELEM=IPT1.NUM(/2) 295 : ITSOUS=IPT1.ITYPEL 296 : IF(ITSOUS .EQ. 7)THEN 297 : C TRI3 298 : NBNN=3 299 : MELTFA.ITYPEL=4 300 : ELSEIF(ITSOUS .EQ. 11)THEN 301 : C QUA4 302 : NBNN=4 303 : MELTFA.ITYPEL=8 304 : C ELTFA QUA4 305 : ENDIF 306 : NBSOUS=0 307 : SEGINI IPT2 308 : MELTFA.LISOUS(ISOUS)=IPT2 309 : C 310 : IPT2.ITYPEL=MELTFA.ITYPEL 311 : MELTFA.ITYPEL=0 312 : ENDDO 313 : ENDIF 314 : C 315 : C**** We fill ELTFA 316 : C We also count: 317 : C NFAC = number of non-triangular faces 318 : C NSOM = number of SOMMET 319 : C 320 : NTP=MCOORD.XCOOR(/1)/(IDIM+1) 321 : JG=NTP 322 : NFAC=0 323 : NSOM=0 324 : 325 : LAST=-1 326 : SEGINI MLRES 327 : LASTS=-1 328 : SEGINI MLRESS 329 : C LAST+MLRES = chaining list to find the faces 330 : C LASTS+MLRESS = chaining list to find the sommet 331 : 332 : DO ISOUS=1,NBS,1 333 : IF(NBS.EQ.1) THEN 334 : IPT1=MELEME 335 : IPT2=MELTFA 336 : ELSE 337 : IPT1=MELEME.LISOUS(ISOUS) 338 : IPT2=MELTFA.LISOUS(ISOUS) 339 : ENDIF 340 : C 341 : NBELEM=IPT1.NUM(/2) 342 : ITSOUS=IPT1.ITYPEL 343 : IF(ITSOUS .EQ. 7)THEN 344 : C TRI (2D) 345 : LISFAC(1)=2 346 : LISFAC(2)=4 347 : LISFAC(3)=6 348 : LISSOM(1)=1 349 : LISSOM(2)=3 350 : LISSOM(3)=5 351 : NNS=3 352 : NNOEU=3 353 : ELSEIF(ITSOUS .EQ. 11)THEN 354 : C QUA (2D) 355 : LISFAC(1)=2 356 : LISFAC(2)=4 357 : LISFAC(3)=6 358 : LISFAC(4)=8 359 : LISSOM(1)=1 360 : LISSOM(2)=3 361 : LISSOM(3)=5 362 : LISSOM(4)=7 363 : NNS=4 364 : NNOEU=4 365 : ENDIF 366 : C 367 : DO IELEM=1,NBELEM,1 368 : DO INOE=1,NNOEU,1 369 : NN1=IPT1.NUM(LISFAC(INOE),IELEM) 370 : IPT2.NUM(INOE,IELEM)=NN1 371 : IF(MLRES.LECT(NN1) .EQ. 0)THEN 372 : NFAC=NFAC+1 373 : MLRES.LECT(NN1)=LAST 374 : LAST=NN1 375 : ENDIF 376 : ENDDO 377 : DO INOE=1,NNS,1 378 : NN1=IPT1.NUM(LISSOM(INOE),IELEM) 379 : IF(MLRESS.LECT(NN1) .EQ. 0)THEN 380 : NSOM=NSOM+1 381 : MLRESS.LECT(NN1)=LASTS 382 : LASTS=NN1 383 : ENDIF 384 : ENDDO 385 : ENDDO 386 : C 387 : SEGDES IPT2 388 : C 389 : ENDDO 390 : IF(NBS. NE. 1) SEGDES MELTFA 390 : CALL ECMO(MTAB,'ELTFA','MAILLAGE',MELTFA) 391 : IF(IERR .NE. 0) GOTO 9999 392 : C 393 : C******** Creation of SOMMET 394 : C 395 : NBELEM=NSOM 396 : NBNN=1 397 : NBSOUS=0 398 : NBREF=0 399 : SEGINI MELSOM 400 : MELSOM.ITYPEL=1 401 : DO IELEM=1,NSOM,1 402 : MELSOM.NUM(1,IELEM)=LASTS 403 : LASTS=MLRESS.LECT(LASTS) 404 : ENDDO 405 : IF(LASTS .NE. -1)THEN 406 : WRITE(IOIMP,*) 'Subroutine kdom10.eso' 406 : CALL ERREUR(5) 407 : ENDIF 407 : call crech1(melsom,1) 408 : SEGDES MELSOM 408 : CALL ECMO(MTAB,'SOMMET','MAILLAGE',MELSOM) 409 : SEGSUP MLRESS 410 : C 411 : C**** Creation of FACE 412 : C 413 : NBELEM=NFAC 414 : NBNN=1 415 : NBSOUS=0 416 : NBREF=0 417 : SEGINI MELFAC 418 : MELFAC.ITYPEL=1 419 : DO IELEM=1,NFAC,1 420 : MELFAC.NUM(1,IELEM)=LAST 421 : LAST=MLRES.LECT(LAST) 422 : ENDDO 423 : IF(LAST .NE. -1)THEN 424 : WRITE(IOIMP,*) 'Subroutine kdom10.eso' 424 : CALL ERREUR(5) 425 : ENDIF 426 : SEGDES MELFAC 427 : SEGSUP MLRES 427 : CALL ECMO(MTAB,'FACE','MAILLAGE',MELFAC) 428 : C 429 : C******* Creation of FACEL and FACEP 430 : C 430 : CALL KRIPAD(MELFAC,MLEFAC) 431 : C SEGINI MLEFAC 432 : JG=NFAC 433 : SEGINI MLETOF 434 : C 435 : C MLETOF.LECT(I1) = how many times has the i-th face of MELFAP 436 : C already been touched? 437 : C 438 : NBELEM=NFAC 439 : NBNN=3 440 : NBSOUS=0 441 : NBREF=0 442 : SEGINI MELFAL 443 : MELFAL.ITYPEL=3 444 : C 445 : C FACEP is a SEG3 446 : C 447 : NBELEM=NFAC 448 : NBNN=3 449 : NBSOUS=0 450 : NBREF=0 451 : SEGINI MELFAP 452 : MELFAP.ITYPEL=3 453 : C 454 : DO ISOUS=1,NBS,1 455 : C 456 : C********** Loop on the elementary mesh of the QUAF 457 : C 458 : IF(NBS.EQ.1) THEN 459 : IPT1=MELEME 460 : ELSE 461 : IPT1=MELEME.LISOUS(ISOUS) 462 : ENDIF 463 : C 464 : ITSOUS=IPT1.ITYPEL 465 : IF(ITSOUS .EQ. 7)THEN 466 : C TRI (2D) 467 : LIFAC(1,1)=2 468 : LIFAC(2,1)=1 469 : LIFAC(3,1)=3 470 : LIFAC(1,2)=4 471 : LIFAC(2,2)=3 472 : LIFAC(3,2)=5 473 : LIFAC(1,3)=6 474 : LIFAC(2,3)=5 475 : LIFAC(3,3)=1 476 : C Here we put the center point in LISSOM 477 : LISSOM(1)=7 478 : NNOEU=3 479 : C 480 : ELSEIF(ITSOUS .EQ. 11)THEN 481 : C QUA (2D) 482 : LIFAC(1,1)=2 483 : LIFAC(2,1)=1 484 : LIFAC(3,1)=3 485 : LIFAC(1,2)=4 486 : LIFAC(2,2)=3 487 : LIFAC(3,2)=5 488 : LIFAC(1,3)=6 489 : LIFAC(2,3)=5 490 : LIFAC(3,3)=7 491 : LIFAC(1,4)=8 492 : LIFAC(2,4)=7 493 : LIFAC(3,4)=1 494 : LISSOM(1)=9 495 : NNOEU=4 496 : ENDIF 497 : C 498 : NBELEM=IPT1.NUM(/2) 499 : DO IELEM=1,NBELEM,1 500 : C NNOEU = number of quagrangular elements 501 : DO INOE=1,NNOEU,1 502 : C NN1 is the global number of the face 503 : C NN2 is the local number of the face in the MELEME 504 : C 'FACE' 505 : C 506 : NN1=IPT1.NUM(LIFAC(1,INOE),IELEM) 507 : NN2=MLEFAC.LECT(NN1) 508 : IF(MLETOF.LECT(NN2).EQ.0)THEN 509 : C 510 : C MLETOF.LECT(NN2) = how many times the face NN2 has 511 : C been touched? 512 : C 513 : MLETOF.LECT(NN2)=1 514 : MELFAL.NUM(2,NN2)=NN1 515 : MELFAL.NUM(1,NN2)=IPT1.NUM(LISSOM(1),IELEM) 516 : MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM) 517 : MELFAP.NUM(1,NN2)=IPT1.NUM(LIFAC(2,INOE),IELEM) 518 : MELFAP.NUM(2,NN2)=IPT1.NUM(LIFAC(3,INOE),IELEM) 519 : MELFAP.NUM(3,NN2)=NN1 520 : ELSEIF(MLETOF.LECT(NN2).EQ.1)THEN 521 : MLETOF.LECT(NN2)=2 522 : MELFAL.NUM(3,NN2)=IPT1.NUM(LISSOM(1),IELEM) 523 : ELSE 524 : WRITE(IOIMP,*) 'Subroutine kdom10.eso' 524 : CALL ERREUR(5) 525 : ENDIF 526 : ENDDO 527 : ENDDO 528 : ENDDO 529 : SEGDES MELFAL 530 : SEGDES MELFAP 531 : SEGSUP MLETOF 532 : SEGSUP MLEFAC 532 : CALL ECMO(MTAB,'FACEL','MAILLAGE',MELFAL) 533 : IF(IERR .NE. 0) GOTO 9999 533 : CALL ECMO(MTAB,'FACEP','MAILLAGE',MELFAP) 534 : IF(IERR .NE. 0) GOTO 9999 535 : IF(NBS.NE.1)THEN 536 : SEGDES MELEME 537 : ENDIF 538 : C 539 : C**** We have to create 540 : C 'XXSURFAC' 541 : C 'XXNORMAF' 542 : C 'MATROT' 543 : C and to put the face centre in the right position! 544 : C 544 : CALL KDOM4C(MELFAC,MELFAL,MELFAP,MCHPSU,MCHPNO,MCHPMR) 545 : IF(IERR.NE.0)GOTO 9999 546 : C 546 : CALL ECMO(MTAB,'XXSURFAC','CHPOINT',MCHPSU) 547 : IF(IERR.NE.0) GOTO 9999 547 : CALL ECMO(MTAB,'XXNORMAF','CHPOINT',MCHPNO) 548 : IF(IERR.NE.0) GOTO 9999 548 : CALL ECMO(MTAB,'MATROT','CHPOINT',MCHPMR) 549 : IF(IERR.NE.0) GOTO 9999 550 : C 551 : C**** Finally, we compute XXDIEMIN 552 : C 552 : CALL KDOM12(MELTFA,MELCEN,MELFAC,MCHPNO,MCHDIA) 553 : IF(IERR.NE.0) GOTO 9999 553 : CALL ECMO(MTAB,'XXDIEMIN','CHPOINT',MCHDIA) 554 : IF(IERR.NE.0) GOTO 9999 555 : C 556 : 9999 RETURN 557 : END 558 : 559 : 560 : 561 :
© Cast3M 2003 - All rights reserved.
Disclaimer