1 : C FPCOQU SOURCE CHAT 11/03/16 21:22:58 6902 2 : SUBROUTINE FPCOQU(P,IPCHE1,IPMODL,JMLU,IPTFP,IRET,ICONV) 3 : *_____________________________________________________________________ 4 : * 5 : * CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES COQUES 6 : * 7 : * ENTREES : 8 : * --------- 9 : * 10 : * P VALEUR DE LA PRESSION SI ELLE EST CONSTANTE 11 : * IPCHE1 CHPOINT CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS 12 : * ICONV FLAG DE CONVERSION 13 : * IPMODL OBJET AFFECTE SUR LEQUEL S APPLIQUE LA PRESSION 14 : * JMLU 1 SI MOT CLE NORMAL 15 : * 0 SINON IL FAUT APPELER PRORIE 16 : * 0 SI LE MOT CLE NORM A ETE INDIQUE 17 : * 18 : * SORTIES : 19 : * --------- 20 : * 21 : * IPTFP CHPOINT DES FORCES NODALES EQUIVALENTES 22 : * IRET 1 OU 0 SUIVANT SUCCES OU NON 23 : * 24 : * 25 : * REVISION JACQUELINE BROCHARD SEPTEMBRE 86 26 : * 27 : * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 05 09 90 28 : * 29 : *_____________________________________________________________________ 30 : * 31 : IMPLICIT INTEGER(I-N) 32 : IMPLICIT REAL*8(A-H,O-Z) 33 : -INC CCOPTIO 34 : -INC CCHAMP 35 : -INC SMCOORD 36 : -INC SMELEME 37 : -INC SMMODEL 38 : -INC SMCHAML 39 : -INC SMCHPOI 40 : -INC SMINTE 41 : * 42 : logical ltelq 43 : SEGMENT NOTYPE 44 : CHARACTER*16 TYPE(NBTYPE) 45 : ENDSEGMENT 46 : * 47 : SEGMENT MPTVAL 48 : INTEGER IPOS(NS) ,NSOF(NS) 49 : INTEGER IVAL(NCOSOU) 50 : CHARACTER*16 TYVAL(NCOSOU) 51 : ENDSEGMENT 52 : * 53 : * Segment donnant le pointeur de maillage correcte au MCHAML de 54 : * caracteristique apres creation d'un MMODEL 55 : * 56 : SEGMENT JPMAIL 57 : INTEGER MAIL1 (NSOUS1) 58 : INTEGER MAIL2 (NSOUS1) 59 : ENDSEGMENT 60 : * 61 : CHARACTER*8 MOT 62 : CHARACTER*(NCONCH) CONM 63 : PARAMETER (NINF=3) 64 : INTEGER INFOS(NINF) 65 : LOGICAL lsupfo 66 : DATA MOT/'NOEUD '/ 67 : * 68 : IRET = 0 69 : 70 : NHRM=NIFOUR 71 : * 72 : IFLAG=0 73 : IND=0 74 : IVACAR=0 75 : IPCHE2=0 76 : JPMAIL=0 77 : * 78 : * LE FLAG SERT A INDIQUER SI L'ON DOIT OU NON DETRUIRE LE MODELE 79 : * EN CAS DE CREATION ( 0 : DESTRUCTION D'UN MMODEL CREE ) 80 : * 81 : IF (IPCHE1.NE.0) THEN 82 : * 83 : * ON CREE LE MMODEL S'ACCROCHANT AU CHPOINT 84 : * 84 : CALL NOMCOM(IPCHE1,'SCAL',IPCHE,IRETOU) 85 : IF (IERR.NE.0) RETURN 86 : * 87 : * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINT DU CHPOINT 88 : * 89 : MCHPOI=IPCHE 90 : SEGACT MCHPOI 91 : NSOUPO=IPCHP(/1) 92 : IPGEOM = 0 93 : DO 1140 I=1,NSOUPO 94 : MSOUPO=IPCHP(I) 95 : SEGACT MSOUPO 96 : IF (IPGEOM.EQ.0) THEN 97 : IPGEOM = IGEOC 98 : ELSE 99 : IPP2 = IGEOC 100 : ltelq=.false. 100 : CALL FUSE (IPGEOM,IPP2,IPPT,ltelq) 101 : IPGEOM = IPPT 102 : ENDIF 103 : SEGDES MSOUPO 104 : 1140 CONTINUE 105 : SEGDES MCHPOI 106 : * 107 : N1=0 108 : SEGINI MMODEL 109 : IPMOD=MMODEL 110 : * 111 : MMODE1=IPMODL 112 : SEGACT MMODE1 113 : NSOUS1=MMODE1.KMODEL(/1) 114 : * 115 : * BOUCLE SUR LES SOUS ZONE GEOMETRIQUE ELEMENTAIRE 116 : * 117 : IRRT=0 118 : DO 50 ISOUS=1,NSOUS1 119 : IMODE1=MMODE1.KMODEL(ISOUS) 120 : SEGACT IMODE1 121 : ITGEOM=IMODE1.IMAMOD 121 : CALL ECROBJ('MAILLAGE',IPGEOM) 121 : CALL ECRCHA('STRI') 121 : CALL ECRCHA('APPU') 121 : CALL ECROBJ('MAILLAGE',ITGEOM) 121 : CALL EXTREL(IRR,0,IBNOR) 122 : IF (IRR.EQ.0) THEN 123 : * 124 : * ON A VERIFIER L ADHERENCE DU CHPOINT A CE MAILLAGE 125 : * 125 : CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU) 126 : IF (IERR.NE.0) THEN 127 : SEGDES MMODE1 128 : SEGDES IMODE1 129 : SEGSUP MMODEL 130 : RETURN 131 : ENDIF 132 : N1=N1+1 133 : SEGADJ MMODEL 134 : * 135 : * CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE 136 : * 137 : NFOR=IMODE1.FORMOD(/2) 138 : NMAT=IMODE1.MATMOD(/2) 139 : MN3 =IMODE1.INFMOD(/1) 140 : NPARMO=0 141 : nobmod=0 142 : SEGINI IMODEL 143 : conmod(17:24)=' ' 144 : IMAMOD=IPOGEO 145 : NEFMOD=IMODE1.NEFMOD 146 : CONMOD=IMODE1.CONMOD 147 : IPDPGE=IMODE1.IPDPGE 148 : * 149 : * CREATION D'UN TABLEAU DE CORRESPONDANCE LE IMAMOD DU 150 : * MMODEL (IPMODL) ET DU IMAMOD DU NVX MMODEL QUE L'ON CREE 151 : * (UTILISE DANS LE KOMCHA POUR LE MCHAML DE CARATERISTIQUE 152 : * POUR LES COQ6 ET COQ8) 153 : * 154 : IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN 155 : IF (JPMAIL.EQ.0) SEGINI JPMAIL 156 : MAIL1(ISOUS)=ITGEOM 157 : MAIL2(ISOUS)=IPOGEO 158 : ENDIF 159 : DO 47 I=1,MN3 160 : INFMOD(I)=IMODE1.INFMOD(I) 161 : 47 CONTINUE 162 : CONMOD=IMODE1.CONMOD 163 : DO 48 I=1,NFOR 164 : FORMOD(I)=IMODE1.FORMOD(I) 165 : 48 CONTINUE 166 : DO 49 I=1,NMAT 167 : MATMOD(I)=IMODE1.MATMOD(I) 168 : 49 CONTINUE 169 : KMODEL(N1)=IMODEL 170 : lzero=0 170 : call inomid(imodel,' ',iret,lzero,lzero,lzero,lzero) 170 : call prquoi(imodel) 171 : SEGDES IMODEL 172 : ELSE 173 : * 174 : * LE CHPOINT N'ADHERE PAS A CETTE ZONE 175 : * 176 : IRRT=IRRT+1 177 : ENDIF 178 : SEGDES IMODE1 179 : 50 CONTINUE 180 : SEGDES MMODE1 181 : SEGDES MMODEL 182 : * 183 : IF (NSOUPO.GT.1) THEN 184 : MELEME=IPGEOM 185 : SEGSUP MELEME 186 : ENDIF 187 : * 188 : IF (IRRT.EQ.NSOUS1) THEN 189 : * 190 : * L'OBJET MAILLAGE ET LE CHPOINT SONT INCOMPATIBLES 191 : * 192 : MOTERR(1:8)='MAILLAGE' 193 : MOTERR(9:16)='CHPOINT' 193 : CALL ERREUR(135) 194 : MMODEL=IPMOD 195 : SEGSUP MMODEL 196 : IF (JPMAIL.NE.0) SEGSUP JPMAIL 197 : RETURN 198 : ENDIF 199 : IPMODI=IPMOD 200 : ELSE 201 : IPMODI=IPMODL 202 : IFLAG=1 203 : ENDIF 204 : * 205 : * 206 : *-------EN 3D ET DANS LE CAS OU NORM N'A PAS ETE INDIQUE 207 : * ON CHARGE PRORIE DE REORIENTER LES ELEMENTS 208 : * 209 : IF (IDIM.EQ.3.AND.JMLU.EQ.0) THEN 210 : MMODE1=IPMODI 211 : SEGACT MMODE1 212 : NSOUS=MMODE1.KMODEL(/1) 213 : N1=NSOUS 214 : SEGINI MMODEL 215 : IPMOD=MMODEL 216 : NBELEM=0 217 : NBNN=0 218 : NBREF=0 219 : NBSOUS=NSOUS 220 : SEGINI MELEME 221 : DO 9 ISOUS=1,NSOUS 222 : IMODEL=MMODE1.KMODEL(ISOUS) 223 : SEGACT IMODEL 224 : LISOUS(ISOUS)=IMAMOD 225 : SEGDES IMODEL 226 : 9 CONTINUE 227 : * 228 : * MAILLAGE A REORIENTER 229 : * 229 : CALL ECROBJ('MAILLAGE',MELEME) 230 : * 231 : * ORIENTATION PRORIE LIT LES DONNEES QUI LE CONCERNE 232 : * 232 : CALL PRORIE 233 : * 234 : * MAILLAGE REORIENTE 235 : * 235 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 236 : IF (IERR.NE.0) THEN 237 : SEGSUP MMODEL 237 : IF (IFLAG.EQ.0) CALL DTMODL(IPMODI) 238 : IF (JPMAIL.NE.0) SEGSUP JPMAIL 239 : RETURN 240 : ENDIF 241 : SEGACT MELEME 242 : DO 10 ISOUS=1,NSOUS 243 : IMODE1=MMODE1.KMODEL(ISOUS) 244 : SEGACT IMODE1 245 : NFOR=IMODE1.FORMOD(/2) 246 : NMAT=IMODE1.MATMOD(/2) 247 : MN3 =IMODE1.INFMOD(/1) 248 : NPARMO=0 249 : nobmod=0 250 : SEGINI IMODEL 251 : conmod(17:24)=' ' 252 : KMODEL(ISOUS)=IMODEL 253 : * 254 : * IMAMOD REORIENTE 255 : * 256 : IMAMOD=LISOUS(ISOUS) 257 : NEFMOD=IMODE1.NEFMOD 258 : CONMOD=IMODE1.CONMOD 259 : IPDPGE=IMODE1.IPDPGE 260 : * 261 : * MISE A JOUR DU TABLEAU DE CORRESONDANCE DES IMAMOD 262 : * 263 : IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN 264 : IF (JPMAIL.EQ.0) THEN 265 : NSOUS1=NSOUS 266 : SEGINI JPMAIL 267 : ENDIF 268 : IF (IFLAG.EQ.1) MAIL1(ISOUS)=IMODE1.IMAMOD 269 : MAIL2(ISOUS)=IMAMOD 270 : ENDIF 271 : DO 3 I=1,MN3 272 : INFMOD(I)=IMODE1.INFMOD(I) 273 : 3 CONTINUE 274 : CONMOD=IMODE1.CONMOD 275 : DO 1 I=1,NFOR 276 : FORMOD(I)=IMODE1.FORMOD(I) 277 : 1 CONTINUE 278 : DO 2 I=1,NMAT 279 : MATMOD(I)=IMODE1.MATMOD(I) 280 : 2 CONTINUE 281 : SEGDES IMODEL 282 : IF (IFLAG.EQ.1) THEN 283 : SEGDES IMODE1 284 : ELSE 285 : SEGSUP IMODE1 286 : ENDIF 287 : lzer=0 287 : call inomid(imodel,' ',iret,lzer,lzer,lzer,lzer) 287 : call prquoi(imodel ) 288 : SEGDES IMODEL 289 : 10 CONTINUE 290 : SEGDES MMODEL 291 : IF (IFLAG.EQ.1) THEN 292 : SEGDES MMODE1 293 : ELSE 294 : SEGSUP MMODE1 295 : ENDIF 296 : IFLAG=0 297 : ELSE 298 : IPMOD=IPMODI 299 : ENDIF 300 : * 301 : * EN 2D ET EN 3D , ON VERIFIE QUE 2 ELEMENTS ADJACENTS 302 : * ONT LA MEME ORIENTATION 303 : * 304 : MMODEL=IPMOD 305 : SEGACT MMODEL 306 : DO 11 ISOUS=1,KMODEL(/1) 307 : IMODEL=KMODEL(ISOUS) 308 : SEGACT IMODEL 309 : IF (ISOUS.GT.1) THEN 310 : IPTGEO=IMAMOD 311 : ltelq=.false. 311 : CALL FUSE(IGEOM,IPTGEO,IPPT,ltelq) 312 : IGEOM=IPPT 313 : ELSE 314 : IGEOM=IMAMOD 315 : ENDIF 316 : SEGDES IMODEL 317 : 11 CONTINUE 317 : CALL ECROBJ('MAILLAGE',IGEOM) 317 : CALL VERSEN 317 : CALL LIROBJ('MAILLAGE',IGEOM,1,IRETOU) 318 : IF (IERR.NE.0) THEN 318 : IF (IFLAG.EQ.0) CALL DTMODL(IPMOD) 319 : IF (JPMAIL.NE.0) SEGSUP JPMAIL 320 : RETURN 321 : ENDIF 322 : * 323 : IF (KMODEL(/1).GT.1) THEN 324 : MELEME=IGEOM 325 : SEGSUP MELEME 326 : ENDIF 327 : SEGDES MMODEL 328 : * 329 : * ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM 330 : * 331 : IF (IPCHE1.EQ.0) THEN 331 : CALL ZEROP(IPMOD,MOT,IPCH1) 332 : IF (IERR.NE.0) RETURN 333 : MCHEL1=IPCH1 334 : SEGACT MCHEL1 335 : NSOUS=MCHEL1.ICHAML(/1) 336 : DO 12 ISOUS=1,NSOUS 337 : MCHAM1=MCHEL1.ICHAML(ISOUS) 338 : SEGACT MCHAM1 339 : MELVA1=MCHAM1.IELVAL(1) 340 : SEGACT MELVA1*MOD 341 : N1PTEL=MELVA1.VELCHE(/1) 342 : N1EL =MELVA1.VELCHE(/2) 343 : DO 13 IGAU=1,N1PTEL 344 : DO 13 IB=1,N1EL 345 : MELVA1.VELCHE(IGAU,IB)=P 346 : 13 CONTINUE 347 : SEGDES MELVA1 348 : SEGDES MCHAM1 349 : 12 CONTINUE 350 : SEGDES MCHEL1 351 : ELSE 352 : * 353 : * On met le MCHAML aux noeuds 354 : * 354 : CALL CHAME1(0,IPMOD,IPCHE,' ',IPCH1,1) 355 : IF (IERR.NE.0) THEN 355 : IF (IFLAG.EQ.0) CALL DTMODL(IPMOD) 356 : IF (JPMAIL.NE.0) SEGSUP JPMAIL 357 : RETURN 358 : ENDIF 359 : ENDIF 360 : * 361 : * ACTIVATION DU MODEL 362 : * 363 : MMODEL=IPMOD 364 : SEGACT MMODEL 365 : NSOUS=KMODEL(/1) 366 : DO 100 ISOUS=1,NSOUS 367 : * 368 : * INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES 369 : * 370 : N1=1 371 : L1=6 372 : N3=5 373 : SEGINI MCHELM 374 : IPCHEL=MCHELM 375 : TITCHE='FORCES' 376 : IFOCHE=IFOUR 377 : * 378 : * ON RECUPERE L INFORMATION GENERALE 379 : * 380 : IMODEL=KMODEL(ISOUS) 381 : SEGACT IMODEL 382 : IPMAIL=IMAMOD 383 : CONM =CONMOD 384 : IMACHE(1)=IPMAIL 385 : * 386 : * TRAITEMENT DU MODEL 387 : * 388 : MELE=NEFMOD 389 : MELEME=IMAMOD 390 : * 391 : * INFORMATION SUR L ELEMENT FINI 392 : * 392 : * CALL ELQUOI (MELE,0,3,IPINF,IMODEL) 393 : IF (IERR.NE.0) THEN 394 : SEGDES IMODEL,MMODEL 395 : SEGSUP MCHELM 395 : IF (IFLAG.EQ.0) CALL DTMODL (IPMOD) 396 : IF (JPMAIL.NE.0) SEGSUP JPMAIL 396 : CALL DTCHAM(IPCH1) 397 : RETURN 398 : ENDIF 399 : * 400 : * INFO=IPINF 401 : MFR =INFELE(13) 402 : * IPTINT=INFELE(11) 403 : IPTINT=infmod(5) 404 : IPTNOE=INFMOD(8) 405 : * 406 : * CREATION DU TABLEAU INFO 407 : * 407 : CALL IDENT (IPMAIL,CONM,IPCH1,0,INFOS,IRTD) 408 : IF (IRTD.EQ.0) THEN 409 : SEGDES IMODEL,MMODEL 410 : SEGSUP MCHELM 410 : IF (IFLAG.EQ.0) CALL DTMODL (IPMOD) 411 : IF (JPMAIL.NE.0) SEGSUP JPMAIL 411 : CALL DTCHAM(IPCH1) 412 : RETURN 413 : ENDIF 414 : * 415 : INFCHE(1,1)=0 416 : INFCHE(1,2)=0 417 : INFCHE(1,3)=NHRM 418 : INFCHE(1,4)=IPTINT 419 : INFCHE(1,5)=0 420 : * 421 : SEGACT MELEME 422 : NBELEM=NUM(/2) 423 : NBNN=NUM(/1) 424 : IPPORE=0 425 : IF(MFR.EQ.33) IPPORE=NBNN 426 : * 427 : MINTE=IPTINT 428 : SEGACT,MINTE 429 : * 430 : * RECHERCHE DU MELVAL DU CHAMELEM DE PRESSION 431 : * 432 : NCARA=0 433 : NCARF=0 434 : MOCARA=0 435 : NFOR=0 436 : MOFORC=0 437 : * 438 : NBROBL=1 439 : NBRFAC=0 440 : SEGINI NOMID 441 : MOSCAL=NOMID 442 : LESOBL(1)='SCAL' 443 : * 444 : NBTYPE=1 445 : SEGINI NOTYPE 446 : MOTYPE=NOTYPE 447 : TYPE(1)='REAL*8' 448 : * 448 : CALL KOMCHA(IPCH1,IPMAIL,CONM,MOSCAL,MOTYPE,1,INFOS,3,IVASCA) 449 : SEGSUP NOTYPE 450 : IF (IERR.NE.0) GOTO 9990 451 : SEGDES NOMID 452 : MPTVAL=IVASCA 453 : IPTVPR=IVAL(1) 454 : * 455 : * RECHERCHE DES NOMS DE COMPOSANTES 456 : * 457 : if(lnomid(2).ne.0) then 458 : nomid=lnomid(2) 459 : segact nomid 460 : moforc=nomid 461 : nfor=lesobl(/2) 462 : lsupfo=.false. 463 : nfac=0 464 : else 465 : lsupfo=.true. 465 : CALL IDFORC (MFR,IFOUR,MOFORC,NFOR,NFAC) 466 : endif 467 : NCOMP=NFOR 468 : nomid=moforc 469 : segact nomid 470 : IF(IFOUR.EQ.-3) NCOMP=NFOR-3 471 : * 472 : * CREATION DU MCHAML DE LA SOUS ZONE 473 : * 474 : IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45 475 : 1 .OR.MELE.EQ.93) THEN 476 : N1PTEL=3 477 : ELSE IF (MELE.EQ.44) THEN 478 : N1PTEL=2 479 : ELSE IF (MELE.EQ.49.OR.MELE.EQ.41.OR.MELE.EQ.56) THEN 480 : N1PTEL=NBNN 481 : ELSE 482 : * 483 : * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE 484 : * 485 : MOTERR(1:4)=NOMTP(MELE) 486 : MOTERR(5:12)='FPCOQU ' 486 : CALL ERREUR(86) 487 : GOTO 9990 488 : ENDIF 489 : * 490 : N1EL=NBELEM 491 : N2PTEL=0 492 : N2EL =0 493 : N2=NCOMP 494 : SEGINI MCHAML 495 : ICHAML(1)=MCHAML 496 : NS=1 497 : NCOSOU=NCOMP 498 : SEGINI MPTVAL 499 : IVAFOR=MPTVAL 500 : NOMID=MOFORC 501 : SEGACT NOMID 502 : DO 4 ICOMP=1,NCOMP 503 : NOMCHE(ICOMP)=LESOBL(ICOMP) 504 : TYPCHE(ICOMP)='REAL*8' 505 : SEGINI MELVAL 506 : IELVAL(ICOMP)=MELVAL 507 : IVAL(ICOMP)=MELVAL 508 : 4 CONTINUE 509 : SEGDES NOMID 510 : *_______________________________________________________________________ 511 : * 512 : * CALCUL DES FORCES NODALES EQUIVALENTES 513 : * DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS 514 : *_______________________________________________________________________ 515 : * 516 : IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45 517 : 1 .OR.MELE.EQ.93) THEN 518 : * 519 : * ELEMENTS COQ3 , DKT OU DKTC 520 : * --------------------------- 520 : CALL FPCO3D(IPTVPR,IPMAIL,IVAFOR) 521 : ELSE IF (MELE.EQ.44) THEN 522 : * 523 : * ELEMENT COQ2 524 : * ------------ 525 : * 526 : * TRAITEMENT DU CHAMP DE CARACTERISTIQUES 527 : * 528 : IF (IFOUR.EQ.-2.AND.IND.EQ.0) THEN 528 : CALL LIROBJ('MCHAML',IPCHE2,0,IRT3) 529 : IND=1 530 : IF (IERR.NE.0) GOTO 9990 531 : IF (IPCHE2.NE.0) THEN 532 : * 533 : * Verification du lieu support du MCHAML de caracteristique 534 : * 534 : CALL QUESUP(IPMODL,IPCHE2,3,1,ISUP,IRETCA) 535 : IF (ISUP.GT.1) GOTO 9990 536 : * 537 : * CREATION DU TABLEAU INFO 538 : * 538 : CALL IDENT (IPMAIL,CONM,IPCHE2,0,INFOS,IRTD) 539 : IF (IRTD.EQ.0) GOTO 9990 540 : * 541 : NCARA=0 542 : NCARF=0 543 : NBROBL=0 544 : NBRFAC=1 545 : SEGINI NOMID 546 : MOCARA=NOMID 547 : LESFAC(1)='DIM3' 548 : * 549 : NBTYPE=1 550 : SEGINI NOTYPE 551 : MOTYPE=NOTYPE 552 : TYPE(1)='REAL*8' 553 : * 553 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,0, 554 : + INFOS,3,IVACAR) 555 : SEGSUP NOTYPE 556 : IF (IERR.NE.0) GOTO 9990 557 : NCARA=NBROBL 558 : NCARF=NBRFAC 559 : NCARR=NCARA+NCARF 560 : * 561 : IF (ISUP.EQ.1) THEN 561 : CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE) 562 : ENDIF 563 : * 564 : SEGDES NOMID 565 : ENDIF 566 : ENDIF 566 : CALL FPCO2D (IPTVPR,IPMAIL,IVAFOR,IVACAR) 567 : ELSE IF (MELE.EQ.49) THEN 568 : * 569 : * ELEMENTS COQ4 570 : * ------------- 570 : CALL FPCOQ4(IPTVPR,IPMAIL,IPTINT,IVAFOR) 571 : ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN 572 : * 573 : * ELEMENTS COQ6 OU COQ8 574 : * --------------------- 575 : IF(IPCHE2.EQ.0) THEN 575 : CALL LIROBJ('MCHAML',IPCHE2,1,IRT3) 576 : IF (IRT3.EQ.0) GOTO 9990 577 : * 578 : * Verification du lieu support du MCHAML de caracteristique 579 : * 579 : CALL QUESUP(IPMODL,IPCHE2,3,0,ISUP,IRETCA) 580 : IF (ISUP.GT.1) GOTO 9990 581 : ENDIF 582 : *____________________________________________________________________ 583 : * 584 : * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES 585 : * CARACTERISTIQUES POUR LES COQ8 ET COQ6 586 : *____________________________________________________________________ 587 : * 588 : IVACAR=0 589 : NCARA=0 590 : NCARF=0 591 : NBROBL=1 592 : NBRFAC=0 593 : SEGINI NOMID 594 : MOCARA=NOMID 595 : LESOBL(1)='EPAI' 596 : IF (IFLAG.EQ.0) THEN 597 : * 598 : * ON RECUPERE LE IMAMOD DU MMODEL D'ORIGINE POUR QUE LE IPMAIL 599 : * DONNE CORRESPONDE A CELUI DE IPCHE21 600 : * 601 : DO 60 KISOUS=1,NSOUS1 602 : IF (IPMAIL.EQ.MAIL2(KISOUS)) THEN 603 : IPMAI1=MAIL1(KISOUS) 604 : GOTO 61 605 : ENDIF 606 : 60 CONTINUE 607 : * 608 : * NE DOIT NORMALEMENT JAMAIS SE PRODUIRE 609 : * 609 : CALL ERREUR (472) 610 : GOTO 9990 611 : ELSE 612 : IPMAI1=IPMAIL 613 : ENDIF 614 : 61 CONTINUE 615 : * 616 : NBTYPE=1 617 : SEGINI NOTYPE 618 : MOTYPE=NOTYPE 619 : TYPE(1)='REAL*8' 620 : * 620 : CALL KOMCHA(IPCHE2,IPMAI1,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) 621 : SEGSUP NOTYPE 622 : IF (IERR.NE.0) GOTO 9990 623 : NCARA=NBROBL 624 : NCARF=NBRFAC 625 : NCARR=NCARA+NCARF 626 : * 627 : IF (ISUP.EQ.1) THEN 627 : CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE) 628 : ENDIF 629 : * 630 : SEGDES NOMID 630 : CALL FPCOQ8(IPTVPR,IPMAIL,IPTINT,IVACAR,IPTNOE,IVAFOR) 631 : ELSE 632 : * 633 : * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE 634 : * 635 : MOTERR(1:4)=NOMTP(MELE) 636 : MOTERR(5:12)='FPCOQU' 636 : CALL ERREUR(86) 637 : GOTO 9990 638 : ENDIF 639 : * 640 : * ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN 641 : * 641 : CALL CHAMPO(IPCHEL,0,IPCHPO,IRET) 641 : CALL DTCHAM(IPCHEL) 642 : IF (IRET.EQ.0) GOTO 9990 643 : * 644 : IF (ISOUS.GT.1) THEN 644 : CALL ADCHPO(IPCHPO,IPTFP,IRET,1D0,1D0) 644 : CALL DTCHPO(IPCHPO) 644 : CALL DTCHPO(IPTFP) 645 : IF (IRET.EQ.0) GOTO 9990 646 : IPTFP=IRET 647 : ELSE 648 : IPTFP=IPCHPO 649 : ENDIF 650 : * 651 : SEGDES IMODEL 652 : * 653 : IF (ISUP.EQ.1) THEN 653 : CALL DTMVAL(IVACAR,3) 654 : ELSE 654 : CALL DTMVAL(IVACAR,1) 655 : ENDIF 656 : * 657 : MPTVAL=IVASCA 658 : MELVAL=IVAL(1) 659 : SEGDES MELVAL 660 : SEGSUP MPTVAL 661 : * 662 : MPTVAL=IVAFOR 663 : SEGSUP MPTVAL 664 : * 665 : NOMID=MOFORC 666 : if(lsupfo)SEGSUP NOMID 667 : NOMID=MOSCAL 668 : SEGSUP NOMID 669 : SEGDES,MINTE 670 : SEGDES MELEME 671 : NOMID=MOCARA 672 : IF (MOCARA.NE.0) SEGSUP NOMID 673 : * 674 : 100 CONTINUE 675 : IRET=1 676 : IF (JPMAIL.NE.0) SEGSUP JPMAIL 676 : CALL DTCHAM(IPCH1) 677 : SEGDES MMODEL 677 : IF (IFLAG.EQ.0) CALL DTMODL(IPMOD) 678 : RETURN 679 : * 680 : * 681 : * 682 : 9990 CONTINUE 683 : IRET=0 684 : SEGSUP MCHELM 685 : * 686 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR 687 : * 688 : IF (ISUP.EQ.1) THEN 688 : CALL DTMVAL(IVACAR,3) 689 : ELSE 689 : CALL DTMVAL(IVACAR,1) 690 : ENDIF 691 : * 691 : CALL DTMVAL(IVAFOR,1) 692 : * 693 : SEGDES,MINTE 694 : SEGDES MELEME 695 : * 696 : MPTVAL=IVASCA 697 : MELVAL=IVAL(1) 698 : SEGDES MELVAL 699 : SEGSUP MPTVAL 700 : * 701 : NOMID=MOCARA 702 : IF (MOCARA.NE.0) SEGSUP NOMID 703 : NOMID=MOFORC 704 : IF (lsupfo.and.MOFORC.NE.0) SEGSUP NOMID 705 : * 706 : SEGDES IMODEL 707 : SEGDES MMODEL 708 : * 708 : IF (IFLAG.EQ.0) CALL DTMODL(IPMOD) 709 : IF (JPMAIL.NE.0) SEGSUP JPMAIL 710 : * 710 : CALL DTCHAM(IPCH1) 711 : * 712 : RETURN 713 : END 714 : 715 : 716 :
© Cast3M 2003 - All rights reserved.
Disclaimer