1 : C RTENS SOURCE FANDEUR 13/01/29 21:16:25 7683 2 : SUBROUTINE RTENS(IPCHE,IPMODL,IMOT,KMOT, 3 : & IPTV1,IPTV2,IPTV3,IPCHE1,ICAS,IPCHAM) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8(A-H,O-Z) 6 : *-----------------------------------------------------------------------* 7 : * Operateur RTENS * 8 : * * 9 : * IPCHE (e) pointeur sur un MCHAML (CONTRAINTES ou DEFORMATIONS * 10 : * ou DEFORMATIONS INELASTIQUES) * 11 : * IPMODL (e) pointeur sur un MMODEL * 12 : * IMOT (e) 0 : repere cartesien ou repere d'orthotropie * 13 : * 1 : repere en coordonnees polaires * 14 : * 2 : repere en coordonnees cylindriques * 15 : * 3 : repere en coordonnees spheriques * 16 : * 4 : repere en coordonnees toriques circulaires * 17 : * 5 : repere en coordonnees toriques cartesiennes * 18 : * KMOT (e) 1 : transformation RT*A*R * 19 : * 2 : transformation R*A*RT * 20 : * utilisé avec le champ de gradient 21 : * IPTV1 (e) 1er vecteur (IMOT = 0) ou 1er point (IMOT <> 0) * 22 : * IPTV2 (e) 2eme vecteur (IMOT = 0) ou 2eme point (IMOT <> 0) * 23 : * IPTV3 (e) 3eme point (IMOT <> 0) * 24 : * IPCHE1 (e) pointeur sur un MCHAML de CARACTERISTIQUES * 25 : * ICAS (e) distingue les differents cas * 26 : * 1 = 27 : * 2 = 28 : * 3 = 29 : * 4 = option CHAM2 champ de gradient 30 : * IPCHAM (s) pointeur sur un MCHAML (CONTRAINTES ou DEFORMATIONS) * 31 : * (ou VARIABLES INTERNES ) * 32 : * * 33 : * Passage aux nouveaux Chamelem par S.RAMAHANDRY le 28/10/90 * 34 : * Corrections / redecoupage / ajouts D. R.-M. le 18/3/94 * 35 : *-----------------------------------------------------------------------* 36 : -INC CCOPTIO 37 : -INC CCHAMP 38 : -INC SMCHAML 39 : -INC SMMODEL 40 : -INC SMINTE 41 : -INC SMCOORD 42 : -INC SMELEME 43 : * 44 : SEGMENT NOTYPE 45 : CHARACTER*16 TYPE(NBTYPE) 46 : ENDSEGMENT 47 : SEGMENT MPTVAL 48 : INTEGER IPOS(NS) , NSOF(NS) 49 : INTEGER IVAL(NCOSOU) 50 : CHARACTER*16 TYVAL(NCOSOU) 51 : ENDSEGMENT 52 : POINTEUR MPTVA1.MPTVAL 53 : * 54 : DIMENSION V1(4),V2(4),W2(3),W3(3) 55 : DIMENSION CENTR1(3),CENTR2(3),AXEI1(3) 56 : * 57 : PARAMETER ( NINF=3 ) 58 : INTEGER INFOS(NINF) 59 : CHARACTER*(NCONCH) CONM 60 : CHARACTER*8 CMATE 61 : LOGICAL Lsupre,lsupgd 62 : * 63 : NHRM=NIFOUR 64 : * 65 : * Activation du MMODEL 66 : * 67 : MMODEL=IPMODL 68 : SEGACT MMODEL 69 : NSOUS=KMODEL(/1) 70 : * 71 : ICONT=0 72 : IDEFO=0 73 : IDEF = 0 74 : IVARI=0 75 : MOCOMP = 0 76 : MOEP = 0 77 : MOVEC = 0 78 : MCHELM=IPCHE 79 : SEGACT MCHELM 80 : IFOMEM=IFOCHE 81 : IF (TITCHE .EQ.'CONTRAINTES') ICONT = 1 82 : IF (TITCHE .EQ.'DEFORMATIONS') IDEFO = 1 83 : IF (TITCHE .EQ.'DEFORMATIONS INELASTIQUES') IDEFO = 2 84 : if (idefo.gt.0) idef= 1 85 : IF (TITCHE .EQ.'VARIABLES INTERNES') IVARI = 1 86 : SEGDES MCHELM 87 : IF (ICAS.NE.4.AND.ICONT.NE.1.AND.IDEFO.NE.1.AND.IDEFO.NE.2) THEN 88 : * 89 : * Le sous-type du MCHAML doit etre CONTRAINTES ou DEFORMATIONS 90 : * sauf dans le cas gradient pour le moment 91 : * 92 : MOTERR(1:8) ='CONTRAIN' 93 : MOTERR(9:16)='DEFORMAT' 93 : CALL ERREUR(109) 94 : SEGDES MMODEL 95 : RETURN 96 : ENDIF 97 : * 98 : * Verification du lieu support du MCHAML de contraintes 99 : * 99 : *** CALL QUESUP (IPMODL,IPCHE,5,0,ISUP,IRETCO) 100 : ISUP = 5 100 : CALL CHASUP (IPMODL,IPCHE,IPPV,IRET,5) 101 : IF (IRET.NE.0) RETURN 102 : IPCHE=IPPV 103 : * 104 : * Verification du lieu support du MCHAML de caracteristiques 105 : * 106 : IF (IPCHE1.NE.0) THEN 106 : ** CALL QUESUP (IPMODL,IPCHE1,5,1,ISUP1,IRETCA) 107 : ** IF (ISUP1.NE.0) RETURN 108 : ISUP1 = 5 108 : CALL CHASUP (IPMODL,IPCHE1,IPPV,IRET,5) 109 : IF (IRET.NE.0) RETURN 110 : IPCHE1=IPPV 111 : ENDIF 112 : SEGACT MMODEL 113 : * 114 : * Creation du MCHAML resultat (apres rotation) 115 : * 116 : * cas des champs de contraintes ou de deformations 117 : * 118 : N1=NSOUS 119 : L1=12 120 : IF (IVARI.EQ.1) L1=18 121 : if (idefo.eq.2) L1=25 122 : N3=6 123 : SEGINI MCHELM 124 : IF (ICONT.EQ.1) THEN 125 : TITCHE='CONTRAINTES' 126 : ELSE IF (IDEFO.EQ.1) THEN 127 : TITCHE='DEFORMATIONS' 128 : ELSE IF (IDEFO.EQ.2) THEN 129 : TITCHE='DEFORMATIONS INELASTIQUES' 130 : ELSE IF (IVARI.EQ.1) THEN 131 : TITCHE='VARIABLES INTERNES' 132 : ENDIF 133 : IFOCHE=IFOUR 134 : IPCHAM=MCHELM 135 : * 136 : * Boucle sur les zones du MMODEL 137 : * 138 : DO 500 ISOUS=1,NSOUS 139 : * 140 : * Initialisations 141 : * 142 : IVACOM=0 143 : IVARES=0 144 : IMODEL=0 145 : NCOMP=0 146 : MOCOMP=0 147 : IVAVEC=0 148 : MOVEC=0 149 : NVEC=0 150 : * 151 : * >>> Recuparation des informations generiques <<< 152 : * 153 : IMODEL=KMODEL(ISOUS) 154 : SEGACT IMODEL 155 : IPMAIL=IMAMOD 156 : CONM =CONMOD 157 : IMACHE(ISOUS)=IPMAIL 158 : CONCHE(ISOUS)=CONMOD 159 : * 160 : * Informations contenues dans le MMODEL 161 : * 162 : MELE=NEFMOD 163 : MELEME=IMAMOD 164 : * 165 : * Nature et formulation du materiau 166 : * 167 : C* NFOR=FORMOD(/2) 168 : C* NMAT=MATMOD(/2) 168 : C* CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) 169 : CMATE = CMATEE 170 : MATE = IMATEE 171 : INAT = INATUU 172 : * 173 : IF(IVARI.EQ.1) THEN 174 : * 175 : * test sur le type de modele de materiau 176 : * en cas de variables internes en attendant que 177 : * tous les modeles soient branches 178 : * on admet actuellement les modeles ou toutes 179 : * les variables internes sont scalaires 180 : * 181 : LEPROB=2 182 : * 183 : * cas des materiaux ou on n'a rien a faire 184 : * 185 : IF(INAT.EQ. 0.OR.INAT.EQ. 1.OR.INAT.EQ. 3.OR. 186 : & INAT.EQ. 5.OR.INAT.EQ.15.OR.INAT.EQ.33.OR. 187 : & INAT.EQ.48) THEN 188 : LEPROB=0 189 : ENDIF 190 : * 191 : * cas des materiaux a traiter ( A FAIRE ) 192 : * 193 : * IF(INAT.EQ. 4) THEN 194 : * LEPROB=1 195 : * .......... 196 : * ENDIF 197 : * 198 : * cas des materiaux non prevus 199 : * 200 : IF(LEPROB.EQ.2) THEN 200 : CALL ERREUR(19) 201 : SEGDES IMODEL,MMODEL 202 : SEGSUP MCHELM 203 : RETURN 204 : ENDIF 205 : ENDIF 206 : * 207 : * Coque integree ou non ? 208 : * 209 : IF(INFMOD(/1).NE.0)THEN 210 : NPINT=INFMOD(1) 211 : ELSE 212 : NPINT=0 213 : ENDIF 214 : * 215 : * Informations concernant l'element-fini 216 : * 216 : * CALL ELQUOI(MELE,0,5,IPINF,IMODEL) 217 : * IF (IERR.NE.0) THEN 218 : * SEGDES IMODEL,MMODEL 219 : * SEGSUP MCHELM 220 : * RETURN 221 : * ENDIF 222 : * INFO = IPINF 223 : MFR = INFELE(13) 224 : NBGS = INFELE(4) 225 : NSTRS = INFELE(16) 226 : * MINTE = INFELE(11) 227 : MINTE=INFMOD(7) 228 : IPMINT = MINTE 229 : MINTE1 = INFMOD(8) 230 : * SEGSUP INFO 231 : * 232 : * Test presence MCHAML CARACTERISTIQUES si MFR=5 et IMOT<>0 233 : * 234 : IF (MFR.EQ.5.AND.ICAS.NE.1.AND.ICAS.NE.4 235 : & .AND.IPCHE1.EQ.0) THEN 236 : MOTERR(1:16) = 'CARACTERISTIQUES' 236 : CALL ERREUR(565) 237 : SEGDES IMODEL,MMODEL 238 : SEGSUP MCHELM 239 : RETURN 240 : ENDIF 241 : * 242 : * L'option GRADIENT ne fonctionne qu'en massif actuellement 243 : * 244 : c IF (ICAS.EQ.4.AND.MFR.NE.1.AND.MFR.NE.31) THEN 245 : IF (ICAS.EQ.4.AND.MFR.NE.1.AND.MFR.NE.31.AND.MFR.NE.63) THEN 245 : CALL ERREUR(19) 246 : SEGDES IMODEL,MMODEL 247 : SEGSUP MCHELM 248 : RETURN 249 : ENDIF 250 : * 251 : * Creation du tableau INFOS 252 : * 252 : CALL IDENT(IPMAIL,CONM,IPCHE,IPCHE1,INFOS,IRTD) 253 : IF (IRTD.EQ.0) GOTO 9990 254 : * 255 : INFCHE(ISOUS,1)=0 256 : INFCHE(ISOUS,2)=0 257 : INFCHE(ISOUS,3)=NHRM 258 : INFCHE(ISOUS,4)=MINTE 259 : INFCHE(ISOUS,5)=0 260 : INFCHE(ISOUS,6)=5 261 : * 262 : * Activation du segment MINTE 263 : * 264 : SEGACT MINTE 265 : NBPGAU=POIGAU(/1) 266 : * 267 : * Activation du segment MELEME 268 : * 269 : SEGACT MELEME 270 : NBNN =NUM(/1) 271 : NBELEM=NUM(/2) 272 : IPPORE=0 273 : IF(MFR.EQ.33) IPPORE=NBNN 274 : * 275 : * Recherche des noms de composantes 276 : * 277 : lsupre=.true. 278 : IF (ICONT.EQ.1) THEN 279 : if(lnomid(4).ne.0) then 280 : nomid=lnomid(4) 281 : segact nomid 282 : mocomp=nomid 283 : ncomp=lesobl(/2) 284 : nfac=lesfac(/2) 285 : lsupre=.false. 286 : else 286 : CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC) 287 : endif 288 : ELSE IF (IDEFO.EQ.1) THEN 289 : if(lnomid(5).ne.0) then 290 : nomid=lnomid(5) 291 : segact nomid 292 : ncomp=lesobl(/2) 293 : mocomp=nomid 294 : lsupre=.false. 295 : else 295 : CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC) 296 : endif 297 : ELSE IF (IDEFO.EQ.2) THEN 298 : if(lnomid(13).ne.0) then 299 : nomid=lnomid(13) 300 : segact nomid 301 : mocomp=nomid 302 : ncomp=lesobl(/2) 303 : nfac=lesfac(/2) 304 : lsupre=.false. 305 : else 305 : CALL IDDEIN(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC) 306 : endif 307 : ELSE IF (IVARI.EQ.1) THEN 308 : if(lnomid(10).ne.0) then 309 : nomid=lnomid(10) 310 : segact nomid 311 : mocomp=nomid 312 : ncomp=lesobl(/2) 313 : nfac=lesfac(/2) 314 : lsupre=.false. 315 : else 315 : CALL IDVARI(MFR,IMODEL,MOCOMP,NCOMP,NFAC) 316 : endif 317 : ENDIF 318 : * 319 : * Verification de leur presence 320 : * 321 : IF(IVARI.EQ.1.AND.LEPROB.EQ.0) THEN 322 : NBTYPE=0 323 : SEGINI NOTYPE 324 : MOTYPE=NOTYPE 325 : ELSE 326 : NBTYPE=1 327 : SEGINI NOTYPE 328 : MOTYPE=NOTYPE 329 : TYPE(1)='REAL*8' 330 : ENDIF 331 : * 331 : CALL KOMCHA(IPCHE,IPMAIL,CONM,MOCOMP,MOTYPE,1,INFOS,3,IVACOM) 332 : SEGSUP NOTYPE 333 : IF (IERR.NE.0) GOTO 9990 334 : IF (ISUP.EQ.1) THEN 334 : CALL VALCHE(IVACOM,NCOMP,IPMINT,IPPORE) 335 : ENDIF 336 : * 337 : * Cas des variables internes 338 : * Si rien a faire, on se contente de recopier la 339 : * zone elementaire du MCHAML 340 : * 341 : IF(IVARI.EQ.1.AND.LEPROB.EQ.0) THEN 342 : MPTVAL=IVACOM 343 : NCOS=IVAL(/1) 344 : IE=0 345 : DO 1021 ICOMP=1,NCOS 346 : IF(IVAL(ICOMP).NE.0) IE=IE+1 347 : 1021 CONTINUE 348 : * 349 : N2=IE 350 : SEGINI MCHAML 351 : ICHAML(ISOUS)=MCHAML 352 : NCOSOU=N2 353 : NS=1 354 : SEGINI MPTVA1 355 : IVARES=MPTVA1 356 : NOMID=MOCOMP 357 : SEGACT NOMID 358 : NBROBL=LESOBL(/2) 359 : NBRFAC=LESFAC(/2) 360 : IE=0 361 : DO 1022 ICOMP=1,NCOMP 362 : IF(IVAL(ICOMP).NE.0) THEN 363 : IE=IE+1 364 : IF(ICOMP.LE.NBROBL) THEN 365 : NOMCHE(IE)=LESOBL(ICOMP) 366 : ELSE 367 : NOMCHE(IE)=LESFAC(ICOMP-NBROBL) 368 : ENDIF 369 : TYPCHE(IE)=TYVAL(ICOMP) 370 : MELVA1=IVAL(ICOMP) 371 : SEGINI,MELVAL=MELVA1 372 : IELVAL(IE)=MELVAL 373 : MPTVA1.IVAL(IE)=MELVAL 374 : ENDIF 375 : 1022 CONTINUE 376 : SEGDES NOMID 377 : GO TO 510 378 : ENDIF 379 : * 380 : * Taille des MELVAL a allouer (champ non constant a priori) 381 : * 382 : N1PTEL=NBGS 383 : N1EL =NBELEM 384 : NBPTEL=N1PTEL 385 : NEL =N1EL 386 : * 387 : * Creation du MCHAML pour la zone ISOUS 388 : * 389 : N2=NCOMP 390 : SEGINI MCHAML 391 : ICHAML(ISOUS)=MCHAML 392 : NS=1 393 : NCOSOU=NCOMP 394 : SEGINI MPTVAL 395 : IVARES=MPTVAL 396 : NOMID=MOCOMP 397 : SEGACT NOMID 398 : DO 102 ICOMP=1,NCOMP 399 : NOMCHE(ICOMP)=LESOBL(ICOMP) 400 : TYPCHE(ICOMP)='REAL*8' 401 : N2PTEL=0 402 : N2EL=0 403 : SEGINI MELVAL 404 : IELVAL(ICOMP)=MELVAL 405 : IVAL(ICOMP)=MELVAL 406 : 102 CONTINUE 407 : SEGDES NOMID 408 : * 409 : * Coordonnees des points caracterisant les 410 : * reperes choisis (spherique, cylindrique, ...) 411 : * 412 : lsupgd=.true. 413 : IF (IMOT.NE.0) THEN 414 : IF (IMOT.EQ.1) THEN 415 : * 416 : * Coordonnees POLAIRES 417 : * 418 : IF (IDIM.EQ.2) THEN 419 : IREF=(IPTV1-1)*(IDIM+1) 420 : CENTR1(1)=XCOOR(IREF+1) 421 : CENTR1(2)=XCOOR(IREF+2) 422 : DO 12 II=1,4 423 : V1(II)=0.D0 424 : 12 CONTINUE 425 : ELSE 425 : CALL ERREUR(31) 426 : GOTO 9990 427 : ENDIF 428 : ELSE IF (IDIM.EQ.3) THEN 429 : * 430 : * Autres coordonnees 431 : * 432 : IREF1=(IPTV1-1)*(IDIM+1) 433 : CENTR1(1)=XCOOR(IREF1+1) 434 : CENTR1(2)=XCOOR(IREF1+2) 435 : CENTR1(3)=XCOOR(IREF1+3) 436 : IREF2=(IPTV2-1)*(IDIM+1) 437 : AXEI1(1)=XCOOR(IREF2+1) 438 : AXEI1(2)=XCOOR(IREF2+2) 439 : AXEI1(3)=XCOOR(IREF2+3) 440 : DO 103 IC=1,IDIM 441 : V1(IC)=AXEI1(IC)-CENTR1(IC) 442 : 103 CONTINUE 443 : V1(4)=SQRT(V1(1)**2+V1(2)**2+V1(3)**2) 444 : IF (V1(4).EQ.0.D0) THEN 444 : CALL ERREUR(277) 445 : GOTO 9990 446 : ENDIF 447 : DO 104 IC=1,IDIM 448 : V1(IC) = V1(IC) / V1(4) 449 : 104 CONTINUE 450 : IF (IPTV3.NE.0) THEN 451 : IREF3=(IPTV3-1)*(IDIM+1) 452 : CENTR2(1)=XCOOR(IREF3+1) 453 : CENTR2(2)=XCOOR(IREF3+2) 454 : CENTR2(3)=XCOOR(IREF3+3) 455 : ENDIF 456 : ENDIF 457 : ELSE IF (ICAS.EQ.2) THEN 458 : * 459 : * Repere cartesien (IPCHE1 = 0 et IMOT = 0) 460 : * 461 : IF (IDIM.EQ.2) THEN 462 : IREF=(IPTV1-1)*(IDIM+1) 463 : V1(1)=XCOOR(IREF+1) 464 : V1(2)=XCOOR(IREF+2) 465 : V1(4)=SQRT(V1(1)**2+V1(2)**2) 466 : IF (V1(4).EQ.0.) THEN 466 : CALL ERREUR(277) 467 : GOTO 9990 468 : ENDIF 469 : ELSE IF (IDIM.EQ.3) THEN 470 : IREF1=(IPTV1-1)*(IDIM+1) 471 : V1(1)=XCOOR(IREF1+1) 472 : V1(2)=XCOOR(IREF1+2) 473 : V1(3)=XCOOR(IREF1+3) 474 : V1(4)=SQRT(V1(1)**2+V1(2)**2+V1(3)**2) 475 : IF (V1(4).EQ.0.D0) THEN 475 : CALL ERREUR(277) 476 : GOTO 9990 477 : ENDIF 478 : IF (IPTV2.NE.0) THEN 479 : IREF2=(IPTV2-1)*(IDIM+1) 480 : V2(1)=XCOOR(IREF2+1) 481 : V2(2)=XCOOR(IREF2+2) 482 : V2(3)=XCOOR(IREF2+3) 483 : V2(4)=SQRT(V2(1)**2+V2(2)**2+V2(3)**2) 484 : IF (V2(4).EQ.0.D0) THEN 484 : CALL ERREUR(277) 485 : GOTO 9990 486 : ENDIF 487 : W3(1)=(V1(2)*V2(3)-V1(3)*V2(2))/(V1(4)*V2(4)) 488 : W3(2)=(V1(3)*V2(1)-V1(1)*V2(3))/(V1(4)*V2(4)) 489 : W3(3)=(V1(1)*V2(2)-V1(2)*V2(1))/(V1(4)*V2(4)) 490 : W2(1)=(W3(2)*V1(3)-W3(3)*V1(2))/V1(4) 491 : W2(2)=(W3(3)*V1(1)-W3(1)*V1(3))/V1(4) 492 : W2(3)=(W3(1)*V1(2)-W3(2)*V1(1))/V1(4) 493 : ENDIF 494 : ENDIF 495 : ELSEIF (ICAS.EQ.1) THEN 496 : * 497 : * On veut le tenseur dans le repere d'orthotropie. Il est 498 : * stocke pour chaque element dans un MCHAML de CARACTERISTIQUES 499 : * (IMOT = 0 et IPCHE1 <> 0) 500 : * 501 : IF (MFR.EQ.1 .OR. MFR.EQ.31) THEN 502 : IF (IDIM.EQ.2) THEN 503 : NBROBL=2 504 : NBRFAC=0 505 : SEGINI NOMID 506 : MOVEC=NOMID 507 : LESOBL(1)='V1X ' 508 : LESOBL(2)='V1Y ' 509 : ELSE 510 : NBROBL=6 511 : NBRFAC=0 512 : SEGINI NOMID 513 : MOVEC=NOMID 514 : LESOBL(1)='V1X ' 515 : LESOBL(2)='V1Y ' 516 : LESOBL(3)='V1Z ' 517 : LESOBL(4)='V2X ' 518 : LESOBL(5)='V2Y ' 519 : LESOBL(6)='V2Z ' 520 : ENDIF 521 : ELSE IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN 522 : NBROBL=2 523 : NBRFAC=0 524 : SEGINI NOMID 525 : MOVEC=NOMID 526 : LESOBL(1)='V1X ' 527 : LESOBL(2)='V1Y ' 528 : ENDIF 529 : NVEC = NBROBL+NBRFAC 530 : NBTYPE=1 531 : SEGINI NOTYPE 532 : MOTYPE=NOTYPE 533 : TYPE(1)='REAL*8' 533 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOVEC,MOTYPE, 534 : & 1,INFOS,3,IVAVEC) 535 : SEGSUP NOTYPE 536 : IF (IERR.NE.0) GOTO 9990 537 : * 538 : * cas du champ de gradient 539 : * 540 : ELSE IF (ICAS.EQ.4) THEN 541 : * 542 : * On veut tourner le tenseur la matrice contenue dans 543 : * un MCHAML de GRADIENT ( IPCHE1 ) 544 : if(lnomid(3).ne.0) then 545 : nomid=lnomid(3) 546 : segact nomid 547 : movec=nomid 548 : nvec=lesobl(/2) 549 : nfac=lesfac(/2) 550 : lsupgd=.false. 551 : else 551 : CALL IDGRAD(MFR,IFOUR,MOVEC,NVEC,NFAC) 552 : lsupgd=.true. 553 : endif 554 : * 555 : * VERIFICATION DE LEUR PRESENCE 556 : * 557 : NBTYPE=1 558 : SEGINI NOTYPE 559 : MOTYPE=NOTYPE 560 : TYPE(1)='REAL*8' 560 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOVEC,MOTYPE, 561 : & 1,INFOS,3,IVAVEC) 562 : SEGSUP NOTYPE 563 : IF (IERR.NE.0) GOTO 9990 564 : * 565 : ENDIF 566 : * 567 : IF (ICAS.NE.1.AND.MFR.EQ.5) THEN 568 : * 569 : * Caracteristiques pour les coques epaisses 570 : * 571 : NBROBL = 1 572 : NBRFAC = 0 573 : SEGINI NOMID 574 : MOEP = NOMID 575 : LESOBL(1) = 'EPAI' 576 : NVEC = NBROBL + NBRFAC 577 : NBTYPE = 1 578 : SEGINI NOTYPE 579 : MOTYPE = NOTYPE 580 : TYPE(1) = 'REAL*8' 580 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOEP,MOTYPE, 581 : & 1,INFOS,3,IVAEP) 582 : SEGSUP NOTYPE 583 : IF (IERR.NE.0) GOTO 9990 584 : ENDIF 585 : * 586 : * MASSI COQUE COQEP POUT CIST THER TUYAU LISP 587 : * 588 : GOTO (10,66,30,66,50,66,66,66,90,66,66,66,66,66,66),MFR 589 : IF (MFR.EQ.31.or.MFR.EQ.63) GOTO 10 590 : * 591 : 66 CONTINUE 592 : MOTERR(1:8)=NOMFR(MFR) 592 : CALL ERREUR(194) 593 : GOTO 9990 594 : 10 CONTINUE 595 : * 596 : * Formulations massive et incompressible 597 : * 598 : IF (ICAS.EQ.4) THEN 599 : * 600 : * cas du champ de gradient 601 : * 601 : CALL RTENS6(IPCHE1,IFOMEM,MELEME,IVAVEC,IVACOM,IVARES, 602 : & IDEF,MINTE,MELE,NPINT,NVEC,KMOT) 603 : IF(IERR.NE.0) GO TO 9990 604 : ELSE 605 : * 606 : * autres cas 607 : * 607 : CALL RTENS1(IPCHE1,IFOMEM,IMOT,IPTV2,MELEME, 608 : & IVAVEC,IVACOM,IVARES,IDEF,MINTE,MELE,NPINT, 609 : & NVEC,V1,V2,W2,W3,CENTR1,CENTR2,AXEI1,IER1) 610 : IF (IER1.NE.0) GOTO 9990 611 : ENDIF 612 : GOTO 510 613 : 30 CONTINUE 614 : * 615 : * Formulation coque (COQ2, COQ3, DKT ...) 616 : * 617 : IF (IFOMEM.LT.2) THEN 617 : CALL ERREUR(339) 618 : GOTO 9990 619 : ENDIF 619 : CALL RTENS2(IPCHE1,IFOMEM,IMOT,IPTV2,MELEME,IVAVEC,IVACOM, 620 : & IVARES,IDEF,MINTE,MELE,NPINT,NVEC,V1,V2,W2,W3, 621 : & CENTR1,CENTR2,AXEI1,IER1) 622 : IF (IER1.NE.0) GOTO 9990 623 : GOTO 510 624 : 50 CONTINUE 625 : * 626 : * Formulation coque epaisse (COQ6, COQ8 ...) 627 : * 627 : CALL RTENS3(IPCHE1,IFOMEM,IMOT,IPTV2,MELEME,IVAVEC,IVACOM, 628 : & IVARES,IVAEP,IDEF,MINTE,MINTE1,MELE,NPINT,NVEC, 629 : & V1,V2,W2,W3,CENTR1,CENTR2,AXEI1,ICAS,IER1) 630 : IF (IER1.NE.0) GOTO 9990 631 : GOTO 510 632 : 90 CONTINUE 633 : * 634 : * Formulation coque avec cisaillement transverse 635 : * (COQ4, DST ...) 636 : * 637 : IF (IFOMEM.LT.2) THEN 637 : CALL ERREUR(339) 638 : GOTO 9990 639 : ENDIF 639 : CALL RTENS4(IPCHE1,IFOMEM,IMOT,IPTV2,MELEME,IVAVEC,IVACOM, 640 : & IVARES,IDEF,MINTE,MELE,NPINT,NVEC,V1,V2,W2,W3, 641 : & CENTR1,CENTR2,AXEI1,ICAS,IER1) 642 : IF (IER1.NE.0) GOTO 9990 643 : GOTO 510 644 : * 645 : * Desactivation des segments de la zone ISOUS 646 : * 647 : 510 CONTINUE 648 : SEGDES MELEME 649 : SEGDES IMODEL 650 : * 651 : IF (ISUP.EQ.1) THEN 651 : CALL DTMVAL(IVACOM,3) 652 : ELSE 652 : CALL DTMVAL(IVACOM,1) 653 : ENDIF 653 : CALL DTMVAL(IVARES,1) 653 : CALL DTMVAL(IVAVEC,1) 654 : * 655 : NOMID=MOCOMP 656 : if(lsupre)SEGSUP NOMID 657 : NOMID=MOVEC 658 : IF (NOMID.NE.0.and.lsupgd) SEGSUP NOMID 659 : NOMID = MOEP 660 : IF (NOMID.NE.0) SEGSUP NOMID 661 : SEGDES MINTE 662 : SEGDES MCHAML 663 : * 664 : * Fin de la boucle sur les zones du MCHAML 665 : * 666 : 500 CONTINUE 667 : SEGDES MMODEL 668 : SEGDES MCHELM 669 : RETURN 670 : * 671 : 9990 CONTINUE 672 : * 673 : * Erreur dans une zone : desactivation puis retour 674 : * 674 : CALL DTMVAL(IVACOM,1) 675 : IF (ISUP.EQ.1) THEN 675 : CALL DTMVAL(IVARES,3) 676 : ELSE 676 : CALL DTMVAL(IVARES,1) 677 : ENDIF 677 : CALL DTMVAL(IVAVEC,1) 678 : * 679 : NOMID=MOCOMP 680 : IF (NOMID.NE.0.and.lsupre) SEGSUP NOMID 681 : NOMID=MOVEC 682 : IF (NOMID.NE.0.and.lsupgd) SEGSUP NOMID 683 : NOMID = MOEP 684 : IF (NOMID.NE.0) SEGSUP NOMID 685 : * 686 : SEGDES MELEME 687 : SEGDES IMODEL 688 : IF (ISOUS.GT.1) SEGSUP MCHAML 689 : * 690 : SEGDES MMODEL 691 : SEGSUP MCHELM 692 : SEGDES MINTE 693 : * SEGSUP INFO 694 : RETURN 695 : END 696 : 697 : 698 : 699 : 700 : 701 :
© Cast3M 2003 - All rights reserved.
Disclaimer