1 : C IDMAT2 SOURCE CHAT 12/06/07 21:15:24 7389 2 : SUBROUTINE IDMAT2(IPMODE,ICARA,NUDIR1,NUMP1,NUMP2, 3 : 1 NUDIR2,NUMP3,ANG,IPCARA,RFLAG) 4 : 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : 8 : *--------------------------------------------------------------------* 9 : * CREATION DU MCHAML CORRESPONDANT A UN MATERIAU ORTHOTROPE * 10 : * APPELE PAR MATCAR * 11 : *--------------------------------------------------------------------* 12 : * * 13 : * ENTREES: * 14 : * -------- * 15 : * * 16 : * IPMODE POINTEUR SUR UN MMODEL * 17 : * ICARA POINTEUR SUR UN MCHELM DE CARACTERISTIQUE (INCOMPLET) * 18 : * NUDIR1 NUMERO DE LA DIRECTIVE UTILISE:"DIRECTION"OU RADIAL" * 19 : * NUMP1 NUMERO DU POINT P1 ASSOCIE A LA DIRECTIVE NIDIR1 * 20 : * NUMP2 NUMERO DU POINT P2 ASSOCIE A LA DIRECTIVE NIDIR1 * 21 : * NUDIR2 NUMERO DE LA DIRECTIVE UTILISE "PARALLELE" "PERPENDIC"* 22 : * "INCLINE" * 23 : * NUMP3 NUMERO DU POINT P ASSOCIE A LA DIRECTIVE INCLINE * 24 : * ANG ANGLE UTILISE DANS LES DIRECTIONS D ORTHOTROPIE * 25 : * (EN RADIAN) * 26 : * * 27 : * * 28 : * SORTIES: * 29 : * -------- * 30 : * * 31 : * IPCARA POINTEUR SUR UN MCHELM MATERIAU * 32 : * * 33 : * * 34 : * AUTEUR JM CAMPENON LE 29 08 90 * 35 : * * 36 : * ANISOTROPIE DANS LES ELEMENTS MASSIFS, P. DOWLATYARI OCT. 90 * 37 : * * 38 : *--------------------------------------------------------------------* 39 : * 40 : -INC CCOPTIO 41 : -INC CCHAMP 42 : -INC SMCHAML 43 : -INC SMINTE 44 : -INC SMELEME 45 : -INC SMMODEL 46 : C 47 : SEGMENT INFO 48 : INTEGER INFELL(JG) 49 : ENDSEGMENT 50 : C 51 : SEGMENT XVAL 52 : REAL*8 CVAL(NPG2,NEL2),SVAL(NPG2,NEL2) 53 : ENDSEGMENT 54 : C 55 : SEGMENT YVAL 56 : REAL*8 VLOC1(IDIM,NPG2,NEL2),VLOC2(IDIM,NPG2,NEL2) 57 : ENDSEGMENT 58 : C 59 : INTEGER NUDIR1,NUMP1,NUMP2,NUDIR2,NUMP3 60 : LOGICAL RFLAG 61 : REAL*8 ANG 62 : INTEGER NPG2,IPVAL 63 : PARAMETER ( NINF=3 ) 64 : INTEGER INFOS(NINF) 65 : CHARACTER*8 CMATE,CHARIN 66 : CHARACTER*(NCONCH) CONM 67 : C 68 : IPINF=0 69 : IPINF2=0 70 : C 71 : C ACTIVATION DU MCHELM 72 : C 73 : MCHEL2=ICARA 74 : SEGACT MCHEL2 75 : C 76 : C CREATION DU MCHELM 77 : C 78 : N1=MCHEL2.ICHAML(/1) 79 : L1=16 80 : N3=6 81 : SEGINI MCHEL1 82 : IPCARA=MCHEL1 83 : MCHEL1.TITCHE=MCHEL2.TITCHE 84 : MCHEL1.IFOCHE=MCHEL2.IFOCHE 85 : C 86 : C BOUCLE SUR LES <> SOUS ZONES 87 : C 88 : MMODEL=IPMODE 89 : NSOUS=KMODEL(/1) 90 : C 91 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES 92 : C 93 : isous=0 94 : DO 10 kSOUS=1,NSOUS 95 : IMODEL=KMODEL(kSOUS) 96 : if (nefmod.eq.22) go to 10 97 : isous=isous+1 98 : * AM 4/5/93 99 : MINTE=0 100 : C 101 : MCHEL1.IMACHE(ISOUS)=MCHEL2.IMACHE(ISOUS) 102 : MCHEL1.CONCHE(ISOUS)=MCHEL2.CONCHE(ISOUS) 103 : DO 1 I=1,N3 104 : MCHEL1.INFCHE(ISOUS,I)=MCHEL2.INFCHE(ISOUS,I) 105 : 1 CONTINUE 106 : C 107 : IPMAIL=IMAMOD 108 : CONM =CONMOD 109 : NFOR=FORMOD(/2) 110 : NMAT=MATMOD(/2) 111 : C 112 : C DANS LE CAS DE CONVECTION ON NE REMPLIT PAS MATMOD, 113 : C ON SAUTE DONC CE CAS LA 114 : C 115 : iplc=0 116 : iplr=0 117 : 118 : IF(formod(1).eq.'THERMIQUE') then 118 : call place(matmod,nmat,iplc,'CONVECTION') 118 : call place(matmod,nmat,iplr,'RAYONNEMENT') 119 : endif 120 : MATE=1 121 : IF (FORMOD(1).NE.'CONVECTION'.and.iplr+iplc.eq.0) THEN 122 : 122 : * CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) 123 : MATE = IMATEE 124 : INAT = INATUU 125 : CMATE = CMATEE 126 : IF (CMATE.EQ.' ') THEN 126 : CALL ERREUR(251) 127 : RETURN 128 : ENDIF 129 : ENDIF 130 : C 131 : C COQUE INTEGREE OU PAS ? 132 : C 133 : IF(INFMOD(/1).NE.0)THEN 134 : NPINT=INFMOD(1) 135 : ELSE 136 : NPINT=0 137 : ENDIF 138 : 139 : C_______________________________________________________________________ 140 : C 141 : C TRAITEMENT PARTICULIER POUR LES MATERIAU ORTHOTROPE OU ANISOT. 142 : C_______________________________________________________________________ 143 : C 144 : IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4.OR.RFLAG)THEN 145 : MELE=NEFMOD 146 : MELEME=IPMAIL 147 : SEGACT MELEME 148 : NBELEM=NUM(/2) 149 : NBNN=NUM(/1) 149 : CALL IDENT (IPMAIL,CONM,ICARA,0,INFOS,IRTD) 150 : IF (IRTD.EQ.0) THEN 151 : SEGDES,MELEME,MCHEL2 152 : SEGSUP,MCHEL1,INFO 153 : RETURN 154 : ENDIF 155 : C 156 : ITHER=0 157 : IF(FORMOD(1).EQ.'THERMIQUE')ITHER=1 158 : C 159 : C INFORMATION SUR L ELEMENT FINI 160 : C 161 : MFR =NUMMFR(MELE) 162 : C 163 : IF (MFR.EQ.75) THEN 163 : CALL ELQUOI(MELE,0,2,IPINF,IMODEL) 164 : IF (IERR.NE.0) THEN 165 : SEGDES,MELEME,MCHEL2 166 : SEGSUP,MCHEL1 167 : RETURN 168 : ENDIF 169 : INFO=IPINF 170 : NBPGAU = INFELL(6) 171 : * 172 : ELSE IF (MFR.EQ.1.OR.MFR.EQ.31) THEN 173 : NBPGAU=1 174 : NLG=NUMGEO(MELE) 174 : CALL RESHPT (NBPGAU,NBNN,NLG,MELE,NPINT,IPT1,IRT1) 175 : MINTE=IPT1 176 : ELSEIF(MFR.EQ.45)THEN 177 : NBPGAU=1 178 : NLG=NUMGEO(MELE) 179 : SEGDES MELEME 180 : C on va récuperer le maillage des sommet pour le calcul 181 : C des fonctions de formes dans le cas DARCY 181 : CALL LEKMOD(MMODEL,IPTABL,INEFMD) 182 : CHARIN = 'MAILLAGE' 182 : CALL LEKTAB(IPTABL,CHARIN, IOBRE) 183 : IF (IERR.NE.0) RETURN 184 : IPT2 = IOBRE 185 : SEGACT IPT2 186 : MELEME=IPT2 187 : IF(IPT2.LISOUS(/1).NE.0)THEN 188 : MELEME= IPT2.LISOUS(ISOUS) 189 : SEGACT MELEME 190 : SEGDES IPT2 191 : ENDIF 192 : NBNN=NUM(/1) 192 : CALL RESHPT (NBPGAU,NBNN,NLG,NLG,NPINT,IPT1,IRT1) 193 : MINTE=IPT1 194 : ELSE IF(MFR.EQ.33)THEN 194 : * CALL ELQUOI(MELE,0,2,IPINF,IMODEL) 195 : IF (IERR.NE.0) THEN 196 : SEGDES,MELEME,MCHEL2 197 : SEGSUP,MCHEL1 198 : RETURN 199 : ENDIF 200 : * INFO=IPINF 201 : NBPGAU=1 202 : * MINTE=INFELE(11) 203 : MINTE=INFMOD(4) 204 : ELSEIF(MFR.EQ.3.OR.MFR.EQ.9.OR.MFR.EQ.5.OR.MFR.EQ.35) THEN 205 : IF(ITHER.EQ.0)THEN 206 : if(infmod(/1).lt.5)then 206 : CALL ELQUOI(MELE,0,3,IPINF,IMODEL) 207 : IF (IERR.NE.0) THEN 208 : SEGDES,MELEME,MCHEL2 209 : SEGSUP,MCHEL1 210 : RETURN 211 : ENDIF 212 : INFO=IPINF 213 : NBPGAU=INFELL(6) 214 : MINTE=INFELL(11) 215 : MINTE1=INFELL(12) 216 : segsup info 217 : else 218 : NBPGAU=INFELE(6) 219 : MINTE=INFMOD(5) 220 : MINTE1=INFMOD(8) 221 : endif 222 : ELSE 222 : CALL TSHAPE(MELE,'GAUSS',IPT1) 223 : MINTE=IPT1 224 : SEGACT,MINTE 225 : NBPGAU=POIGAU(/1) 226 : SEGDES MINTE 227 : IF(MFR.EQ.5)THEN 227 : CALL TSHAPE(MELE,'NOEUD',IPT2) 228 : MINTE1=IPT2 229 : ELSE 230 : MINTE1=0 231 : ENDIF 232 : ENDIF 233 : ENDIF 234 : * 235 : * CAS 'RADIAL' EN MASSIF 236 : * ON CHERCHE LES POINTS DE GAUSS 237 : * 238 : MINTE2=0 239 : IF(NUDIR1.EQ.2.AND. 240 : . (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33.OR.MFR.EQ.45)) THEN 241 : melele=mele 242 : IF (MFR.EQ.45)melele=nlg 243 : if(infmod(/1).lt.5) then 243 : CALL ELQUOI(melele,0,3,IPINF2,IMODEL) 244 : IF (IERR.NE.0) THEN 245 : SEGDES,MELEME,MCHEL2 246 : SEGSUP,MCHEL1 247 : RETURN 248 : ENDIF 249 : INFO=IPINF2 250 : MINTE2=INFELL(11) 251 : segsup info 252 : else 253 : minte2=infmod(5) 254 : endif 255 : SEGACT MINTE2 256 : NBPGA2=MINTE2.POIGAU(/1) 257 : SEGDES MINTE2 258 : ENDIF 259 : C 260 : C VERIFICATION DE LA COHERENCE DES INFORMATIONS 261 : C 262 : IF (MFR.EQ.3.AND.IDIM.NE.3) THEN 263 : IF (NUDIR1.NE.0.AND.NUDIR1.NE.1) THEN 263 : CALL ERREUR(21) 264 : GOTO 9990 265 : ENDIF 266 : NUDIR1=1 267 : IF (NUDIR2.EQ.3) THEN 267 : CALL ERREUR(21) 268 : GOTO 9990 269 : ENDIF 270 : ELSE 271 : * 272 : IF (NUDIR1.EQ.0) THEN 273 : C DIRECTIONS D ORTHOTROPIE NON FOURNIES 273 : CALL ERREUR(346) 274 : GOTO 9990 275 : ENDIF 276 : ENDIF 277 : IF (NUDIR2.EQ.0) THEN 278 : C OPTION PARALLELE PAR DEFAUT 279 : NUDIR2=1 280 : ENDIF 281 : IF(MFR.EQ.35)THEN 282 : IF(NUDIR1.EQ.2)THEN 283 : * CETTE DEFINITION DU REPERE D'ORTH. N'EST PAS VALABLE POUR 284 : * LES ELEMENTS JOINTS (CAR ILS SONT PLANS) 284 : CALL ERREUR (523) 285 : GO TO 9990 286 : ENDIF 287 : ENDIF 288 : C_______________________________________________________________________ 289 : C 290 : C_______________________________________________________________________ 291 : C 292 : MCHAM2=MCHEL2.ICHAML(ISOUS) 293 : SEGACT MCHAM2 294 : NCOMP=MCHAM2.NOMCHE(/2) 295 : N2=NCOMP 296 : C 297 : C CREATION DU MCHAML : ON PREVOIT ICI QUE L'ON DOIT CREER 2 OU 6 298 : C COMPOSANTES SUPPLEMENTAIRES 299 : C 300 : IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9.OR.MFR.EQ.35) THEN 301 : N2=NCOMP+2 302 : ELSE IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33 303 : & .OR.MFR.EQ.45.OR.MFR.EQ.75) THEN 304 : IF (IDIM.EQ.2) N2=NCOMP+2 305 : IF (IDIM.EQ.3) N2=NCOMP+6 306 : ENDIF 307 : SEGINI MCHAM1 308 : MCHEL1.ICHAML(ISOUS)=MCHAM1 309 : C 310 : C ON RECOPIE TOUS LES NOMS DE COMPOSANTE DE 1 A NCOMP 311 : C 312 : IPEPAI=0 313 : IPEXCE=0 314 : DO 100 ICOMP=1,NCOMP 315 : MCHAM1.NOMCHE(ICOMP)=MCHAM2.NOMCHE(ICOMP) 316 : MCHAM1.TYPCHE(ICOMP)=MCHAM2.TYPCHE(ICOMP) 317 : MELVA2=MCHAM2.IELVAL(ICOMP) 318 : IF(MFR.EQ.5)THEN 319 : IF(MCHAM2.NOMCHE(ICOMP).EQ.'EPAI')THEN 320 : IPEPAI=MELVA2 321 : ELSEIF(MCHAM2.NOMCHE(ICOMP).EQ.'EXCE')THEN 322 : IPEXCE=MELVA2 323 : ENDIF 324 : ENDIF 325 : SEGACT MELVA2 326 : IF (MCHAM2.TYPCHE(ICOMP).EQ.'REAL*8') THEN 327 : N1PTEL=MELVA2.VELCHE(/1) 328 : N1EL =MELVA2.VELCHE(/2) 329 : N2PTEL=0 330 : N2EL =0 331 : C 332 : SEGINI MELVA1 333 : MCHAM1.IELVAL(ICOMP)=MELVA1 334 : DO 13 J=1,N1PTEL 335 : DO 13 K=1,N1EL 336 : MELVA1.VELCHE(J,K)=MELVA2.VELCHE(J,K) 337 : 13 CONTINUE 338 : ELSE 339 : N2PTEL=MELVA2.IELCHE(/1) 340 : N2EL =MELVA2.IELCHE(/2) 341 : N1PTEL=0 342 : N1EL =0 343 : SEGINI MELVA1 344 : C 345 : MCHAM1.IELVAL(ICOMP)=MELVA1 346 : DO 14 J=1,N2PTEL 347 : DO 14 K=1,N2EL 348 : MELVA1.IELCHE(J,K)=MELVA2.IELCHE(J,K) 349 : 14 CONTINUE 350 : ENDIF 351 : 100 CONTINUE 352 : IF(MFR.EQ.5.AND.IPEPAI.EQ.0)THEN 353 : *DANS LE CAS DES ELEMENTS COQUES EPAISSES ORTHOTROPES IL FAUT DONNER 354 : *L'EPAISSEUR EN MEME TEMPS QUE LES PROPRIETES MATERIELLES 354 : CALL ERREUR (526 ) 355 : DO 311 ICOMP=1,NCOMP 356 : MELVA2=MCHAM2.IELVAL(ICOMP) 357 : MELVA1=MCHAM1.IELVAL(ICOMP) 358 : SEGDES,MELVA2 359 : SEGSUP,MELVA1 360 : 311 CONTINUE 361 : SEGDES MCHAM2 362 : SEGSUP MCHAM1 363 : GOTO 9990 364 : ENDIF 365 : C_______________________________________________________________________ 366 : C 367 : C ON TRAITE ICI LES COMPOSANTES 'V1X' ET 'V1Y'POUR LES ELEMENTS 368 : C COQUES ET 'V1X','V1Y','V1Z','V2X','V2Y','V2Z' POUR LES MASSIF 369 : C_______________________________________________________________________ 370 : C 371 : C_______________________________________________________________________ 372 : C 373 : C -- TRAITEMENT PARTICULIER SELON LE TYPE DES ELEMENTS -- 374 : C_______________________________________________________________________ 375 : C 376 : C 377 : IF(MFR.EQ.3.OR.MFR.EQ.9.OR.MFR.EQ.35)THEN 378 : IF (NUDIR1.EQ.1) THEN 379 : NPG2=1 380 : ENDIF 381 : IF (NUDIR1.EQ.2) THEN 382 : NPG2=NBPGAU 383 : ENDIF 384 : C 385 : IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.49.OR.MELE.EQ.93 386 : . .OR.MELE.EQ.87.OR.MELE.EQ.88.OR.MELE.EQ.128) THEN 387 : ICALC=0 388 : ELSE IF (MELE.EQ.44) THEN 389 : ICALC=1 390 : ENDIF 391 : C_______________________________________________________________________ 392 : C 393 : C LE FLAG ICALC SERT A INDIQUER L OPTION DE CALCUL A CHOISIR 394 : C DANS LA ROUTINE IDMAT3 (IDEM MATEO2 ET COBIOR POUR MATE) 395 : C_______________________________________________________________________ 396 : C 397 : IPVAL=0 397 : CALL IDMAT3 (NUDIR1,NUMP1,NUDIR2,NUMP3,ANG, 398 : 1 MELEME,MINTE,NPG2,ICALC,MFR,IPVAL) 399 : IF (IERR.NE.0) THEN 400 : DO 300 ICOMP=1,NCOMP 401 : MELVA2=MCHAM2.IELVAL(ICOMP) 402 : MELVA1=MCHAM1.IELVAL(ICOMP) 403 : SEGDES,MELVA2 404 : SEGSUP,MELVA1 405 : 300 CONTINUE 406 : SEGDES MCHAM2 407 : SEGSUP MCHAM1 408 : GOTO 9990 409 : ENDIF 410 : ELSEIF(MFR.EQ.5)THEN 411 : NPG2=NBPGAU 412 : IPVAL=0 412 : CALL IDMAT5(NUDIR1,NUMP1,NUDIR2,NUMP3,ANG, 413 : 1 MELEME,MINTE,MINTE1,IPEPAI,IPEXCE,NPG2,ITHER,IPVAL) 414 : IF (IERR.NE.0) THEN 415 : DO 312 ICOMP=1,NCOMP 416 : MELVA2=MCHAM2.IELVAL(ICOMP) 417 : MELVA1=MCHAM1.IELVAL(ICOMP) 418 : SEGDES,MELVA2 419 : SEGSUP,MELVA1 420 : 312 CONTINUE 421 : SEGDES MCHAM2 422 : SEGSUP MCHAM1 423 : GOTO 9990 424 : ENDIF 425 : ELSE IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33.OR.MFR.EQ.45)THEN 426 : IPVAL=0 427 : NPG2=1 428 : IF(NUDIR1.EQ.2) NPG2=NBPGA2 428 : CALL IDMAT4(NUMP1,NUMP2,NUDIR1,NUDIR2,ANG,MELEME,MINTE, 429 : . IPVAL,NPG2,MINTE2) 430 : IF (IERR.NE.0) THEN 431 : DO 310 ICOMP=1,NCOMP 432 : MELVA2=MCHAM2.IELVAL(ICOMP) 433 : MELVA1=MCHAM1.IELVAL(ICOMP) 434 : SEGDES,MELVA2 435 : SEGSUP,MELVA1 436 : 310 CONTINUE 437 : SEGDES MCHAM2 438 : SEGSUP MCHAM1 439 : GOTO 9990 440 : ENDIF 441 : ELSE IF (MFR.EQ.75)THEN 442 : IPVAL=0 443 : NPG2=NBPGAU 443 : CALL IDMAT6(NUMP1,NUMP2,NUDIR1,NUDIR2,ANG,MELEME, 444 : . IPVAL,NPG2) 445 : IF (IERR.NE.0) THEN 446 : DO 375 ICOMP=1,NCOMP 447 : MELVA2=MCHAM2.IELVAL(ICOMP) 448 : MELVA1=MCHAM1.IELVAL(ICOMP) 449 : SEGDES,MELVA2 450 : SEGSUP,MELVA1 451 : 375 CONTINUE 452 : SEGDES MCHAM2 453 : SEGSUP MCHAM1 454 : GOTO 9990 455 : ENDIF 456 : ELSE 457 : MOTERR(5:8) = NOMTP(MELE) 458 : MOTERR(1:4) = 'ORTH' 458 : CALL ERREUR (71) 459 : DO 320 ICOMP=1,NCOMP 460 : MELVA2=MCHAM2.IELVAL(ICOMP) 461 : MELVA1=MCHAM1.IELVAL(ICOMP) 462 : SEGDES,MELVA2 463 : SEGSUP,MELVA1 464 : 320 CONTINUE 465 : SEGDES MCHAM2 466 : SEGSUP MCHAM1 467 : GOTO 9990 468 : ENDIF 469 : C 470 : IF (MFR.EQ.3 .OR.MFR.EQ.9.OR.MFR.EQ.5.OR.MFR.EQ.35 )THEN 471 : C 472 : C ON CREE LES COMPOSANTES V1X ET V1Y 473 : C 474 : IF (RFLAG) THEN 475 : MCHAM1.NOMCHE(N2-1 )='W1X ' 476 : MCHAM1.NOMCHE(N2 )='W1Y ' 477 : ELSE 478 : MCHAM1.NOMCHE(N2-1 )='V1X ' 479 : MCHAM1.NOMCHE(N2 )='V1Y ' 480 : ENDIF 481 : MCHAM1.TYPCHE(N2-1 )='REAL*8' 482 : MCHAM1.TYPCHE(N2 )='REAL*8' 483 : C 484 : C REMPLISSAGE DU SEGMENT MELVA1 CONTENANT LES COMPOSANTES 485 : C 486 : N1PTEL=NPG2 487 : N1EL = NBELEM 488 : N2PTEL=0 489 : N2EL =0 490 : C 491 : XVAL=IPVAL 492 : SEGACT XVAL 493 : C 494 : SEGINI MELVA1 495 : MCHAM1.IELVAL(N2-1)=MELVA1 496 : DO 1110 IB=1,NBELEM 497 : DO 1110 IGAU=1,NPG2 498 : IGMN=MIN(IGAU,MELVA1.VELCHE(/1)) 499 : IBMN=MIN(IB ,MELVA1.VELCHE(/2)) 500 : MELVA1.VELCHE(IGMN,IBMN)=CVAL(IGAU,IB) 501 : 1110 CONTINUE 502 : C 503 : SEGINI MELVA1 504 : MCHAM1.IELVAL(N2)=MELVA1 505 : DO 2110 IB=1,NBELEM 506 : DO 2110 IGAU=1,NPG2 507 : IGMN=MIN(IGAU,MELVA1.VELCHE(/1)) 508 : IBMN=MIN(IB ,MELVA1.VELCHE(/2)) 509 : MELVA1.VELCHE(IGMN,IBMN)=SVAL(IGAU,IB) 510 : 2110 CONTINUE 511 : C 512 : SEGSUP XVAL 513 : ELSE IF(MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33 514 : & .OR.MFR.EQ.45.OR.MFR.EQ.75)THEN 515 : C 516 : C ON CREE LES COMPOSANTES V1X,V1Y,V1Z, . . . 517 : C 518 : IF(IDIM.EQ.2)THEN 519 : NCOMPV=2 520 : IF (RFLAG) THEN 521 : MCHAM1.NOMCHE(N2-1 )='W1X ' 522 : MCHAM1.NOMCHE(N2 )='W1Y ' 523 : ELSE 524 : MCHAM1.NOMCHE(N2-1 )='V1X ' 525 : MCHAM1.NOMCHE(N2 )='V1Y ' 526 : ENDIF 527 : C 528 : ELSEIF(IDIM.EQ.3)THEN 529 : NCOMPV=6 530 : C 531 : IF (RFLAG) THEN 532 : MCHAM1.NOMCHE(N2-5 )='W1X ' 533 : MCHAM1.NOMCHE(N2-4 )='W1Y ' 534 : MCHAM1.NOMCHE(N2-3 )='W1Z ' 535 : MCHAM1.NOMCHE(N2-2 )='W2X ' 536 : MCHAM1.NOMCHE(N2-1 )='W2Y ' 537 : MCHAM1.NOMCHE(N2 )='W2Z ' 538 : ELSE 539 : MCHAM1.NOMCHE(N2-5 )='V1X ' 540 : MCHAM1.NOMCHE(N2-4 )='V1Y ' 541 : MCHAM1.NOMCHE(N2-3 )='V1Z ' 542 : MCHAM1.NOMCHE(N2-2 )='V2X ' 543 : MCHAM1.NOMCHE(N2-1 )='V2Y ' 544 : MCHAM1.NOMCHE(N2 )='V2Z ' 545 : ENDIF 546 : C 547 : ENDIF 548 : DO 200 ICOMP =1,NCOMPV 549 : MCHAM1.TYPCHE(N2-(NCOMPV-ICOMP))='REAL*8' 550 : 200 CONTINUE 551 : C 552 : C REMPLISSAGE DU SEGMENT MELVA1 CONTENANT LES COMPOSANTES 553 : C 554 : N1PTEL=NPG2 555 : N1EL =NBELEM 556 : N2PTEL=0 557 : N2EL =0 558 : YVAL=IPVAL 559 : SEGACT YVAL 560 : C 561 : DO 210 ICOMP=1,NCOMPV 562 : SEGINI MELVA1 563 : MCHAM1.IELVAL(N2-(NCOMPV-ICOMP))=MELVA1 564 : DO 220 IB=1,NBELEM 565 : DO 230 IG=1,NPG2 566 : IF(ICOMP.LE.3)THEN 567 : MELVA1.VELCHE(IG,IB)=VLOC1(ICOMP,IG,IB) 568 : ELSE 569 : MELVA1.VELCHE(IG,IB)=VLOC2((ICOMP-3),IG,IB) 570 : ENDIF 571 : 230 CONTINUE 572 : 220 CONTINUE 573 : 210 CONTINUE 574 : SEGSUP YVAL 575 : * 576 : ENDIF 577 : SEGDES MELEME 578 : * IF (IPINF.NE.0) THEN 579 : * INFO=IPINF 580 : * SEGSUP INFO 581 : * ENDIF 582 : * IF (IPINF2.NE.0) THEN 583 : * INFO=IPINF2 584 : * SEGSUP INFO 585 : * ENDIF 586 : C 587 : C_______________________________________________________________________ 588 : C_______________________________________________________________________ 589 : C 590 : ELSE 591 : C 592 : C ON RECOPIE LE CHAMELEM ICARA DANS LE CHAMELEM IPCARA 593 : C 594 : DO 17 I=1,N3 595 : MCHEL1.INFCHE(ISOUS,I)=MCHEL2.INFCHE(ISOUS,I) 596 : 17 CONTINUE 597 : C 598 : C ACTIVATION DU MCHAML 599 : C 600 : MCHAM2=MCHEL2.ICHAML(ISOUS) 601 : SEGACT MCHAM2 602 : N2=MCHAM2.NOMCHE(/2) 603 : C 604 : SEGINI MCHAM1 605 : MCHEL1.ICHAML(ISOUS)=MCHAM1 606 : DO 2 ICOMP=1,N2 607 : MCHAM1.NOMCHE(ICOMP)=MCHAM2.NOMCHE(ICOMP) 608 : MCHAM1.TYPCHE(ICOMP)=MCHAM2.TYPCHE(ICOMP) 609 : C 610 : C ACTIVATION DU MELVAL 611 : C 612 : MELVA2=MCHAM2.IELVAL(ICOMP) 613 : SEGACT MELVA2 614 : IF (MCHAM2.TYPCHE(ICOMP).EQ.'REAL*8') THEN 615 : N1PTEL=MELVA2.VELCHE(/1) 616 : N1EL =MELVA2.VELCHE(/2) 617 : N2PTEL=0 618 : N2EL =0 619 : C 620 : SEGINI MELVA1 621 : MCHAM1.IELVAL(ICOMP)=MELVA1 622 : DO 5 J=1,N1PTEL 623 : DO 5 K=1,N1EL 624 : MELVA1.VELCHE(J,K)=MELVA2.VELCHE(J,K) 625 : 5 CONTINUE 626 : ELSE 627 : N2PTEL=MELVA2.IELCHE(/1) 628 : N2EL =MELVA2.IELCHE(/2) 629 : N1PTEL=0 630 : N1EL =0 631 : SEGINI MELVA1 632 : C 633 : MCHAM1.IELVAL(ICOMP)=MELVA1 634 : DO 4 J=1,N2PTEL 635 : DO 4 K=1,N2EL 636 : MELVA1.IELCHE(J,K)=MELVA2.IELCHE(J,K) 637 : 4 CONTINUE 638 : ENDIF 639 : 2 CONTINUE 640 : ENDIF 641 : C 642 : C DESACTIVATION DES SEGMENTS 643 : NCOMP2=MCHAM2.NOMCHE(/2) 644 : DO 330 ICOMP=1,NCOMP2 645 : MELVA2=MCHAM2.IELVAL(ICOMP) 646 : SEGDES,MELVA2 647 : 330 CONTINUE 648 : NCOMP1=MCHAM1.NOMCHE(/2) 649 : DO 340 ICOMP=1,NCOMP1 650 : MELVA1=MCHAM1.IELVAL(ICOMP) 651 : SEGDES,MELVA1 652 : 340 CONTINUE 653 : C 654 : SEGDES,MCHAM1,MCHAM2 655 : C 656 : 10 CONTINUE 657 : C 658 : SEGDES,MCHEL1,MCHEL2 659 : RETURN 660 : C 661 : C ERREUR DANS UNE SOUS ZONE DESACTIVATION ET RETOUR 662 : C 663 : 9990 CONTINUE 664 : SEGDES MELEME 665 : IF (MINTE.NE.0) SEGDES MINTE 666 : * IF (IPINF.NE.0) SEGSUP INFO 667 : SEGSUP MCHEL1 668 : SEGDES MCHEL2 669 : RETURN 670 : END 671 : 672 : 673 : 674 : 675 :
© Cast3M 2003 - All rights reserved.
Disclaimer