1 : C MUCHSC SOURCE FANDEUR 12/04/11 21:15:18 7350 2 : SUBROUTINE MUCHSC(IPMODL,IPCHE1,IPCHE2,IPCHMU,LMOT1,LMOT2,LMOT3, 3 : & IPLREE,IINV) 4 : *________________________________________________________________ 5 : * 6 : * MULTIPLICATION DE DEUX CHAMELEM 7 : * -------------------------------- 8 : * 9 : * ENTREES : 10 : * --------- 11 : * 12 : * IPCHE1 POINTEUR SUR UN CHAMELEM 13 : * IPCHE2 POINTEUR SUR UN CHAMELEM 14 : * IPMODL POINTEUR SUR UN MMODEL ; UTILISE SEULEMENT DANS LES CAS 15 : * DES MULTIPLICATIONS : 16 : * - ( HOOKE ou HOOTAN ) * ( CONTRAINTES ou DEFORMATIONS) 17 : * - ( GRAD ou GRADFLEX ) * ( GRAD ou GRADFLEX ) 18 : * pour connaitre la formulation. 19 : * IINV +1 SI MULTIPLICATION , -1 SI DIVISION 20 : * IPLREE POINTEUR LISTREEL (PONDERATION COMPOSANTES RESULTATS) 21 : * 22 : * 23 : * SORTIE : 24 : * -------- 25 : * 26 : * IPCHMU POINTEUR SUR LE CHAMELEM CORRESPONDANT AU PRODUIT 27 : * DES DEUX PRECEDENTS. 28 : * =0 SI L'OPERATION EST IMPOSSIBLE. 29 : * 30 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 29 10 90 31 : * 32 : *________________________________________________________________ 33 : * 34 : IMPLICIT INTEGER(I-N) 35 : IMPLICIT REAL*8(A-H,O-Z) 36 : * 37 : -INC CCOPTIO 38 : * 39 : -INC SMCHAML 40 : -INC SMELEME 41 : -INC SMLREEL 42 : -INC SMCOORD 43 : -INC SMMODEL 44 : -INC SMLMOTS 45 : * 46 : SEGMENT MTRAA 47 : INTEGER ITRAA(LX) 48 : ENDSEGMENT 49 : * 50 : SEGMENT INFO 51 : INTEGER INFELL(JG) 52 : ENDSEGMENT 53 : * 54 : SEGMENT NOTYPE 55 : CHARACTER*16 TYPE(NBTYPE) 56 : ENDSEGMENT 57 : * 58 : SEGMENT MPTVAL 59 : INTEGER IPOS(NS) ,NSOF(NS) 60 : INTEGER IVAL(NCOSOU) 61 : CHARACTER*16 TYVAL(NCOSOU) 62 : ENDSEGMENT 63 : * 64 : PARAMETER ( NINF=3 ) 65 : INTEGER INFOS(NINF) 66 : * 67 : CHARACTER*(NCONCH) CONCH1,CONCH2,CONM 68 : CHARACTER*72 TIT1,TIT2,TITC 69 : CHARACTER*8 BID 70 : LOGICAL lsupde,lsupre,lsupin,lsupco,lsupg1,lsupg2 71 : * 72 : IPCHMU = 0 73 : MLREE3 = IPLREE 74 : * 75 : * si modele, on remet d'aplomb les chamelem 76 : * 77 : if (ipmodl.ne.0) then 78 : ker = 0 79 : ire = 0 79 : call reduaf(ipche1,ipmodl,ipche10,0,ire,ker) 79 : if(ire.ne.1) call erreur(ker) 80 : if (ierr.NE.0) return 81 : ipche1=ipche10 81 : call reduaf(ipche2,ipmodl,ipche20,0,ire,ker) 82 : if (ierr.NE.0) return 82 : if(ire.ne.1) call erreur(ker) 83 : ipche2=ipche20 84 : endif 85 : ipche10 = IPCHE1 86 : ipche20 = IPCHE2 87 : * 87 : CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,IRET) 88 : IF (IRET.EQ.0) RETURN 89 : 90 : * Dans le cas de la division on sort si l ordre a changé 91 : IF (IINV.eq.-1) THEN 92 : IF ((IPCHE1.ne.ipche10).or.(IPCHE2.ne.ipche20)) THEN 93 : write(ioimp,*) 'L ORDRE DES OPERANDES N A PAS PU ETRE CONSERVE' 94 : write(ioimp,*) 'VERIFIEZ LE TYPE DES CHAMELEM' 95 : MOTERR(1:8)=' / ' 95 : call ERREUR(196) 96 : RETURN 97 : ENDIF 98 : * CAS NON ADMIS POUR LA DIVISION 99 : IF (K.EQ.4.OR.K.EQ.5) THEN 99 : CALL ERREUR (21) 100 : RETURN 101 : ENDIF 102 : ENDIF 103 : * 104 : LCOMP=0 105 : * 106 : MCHEL1 =IPCHE1 107 : MCHEL2 =IPCHE2 108 : SEGACT MCHEL1,MCHEL2 109 : IFO1=MCHEL1.IFOCHE 110 : IFO2=MCHEL2.IFOCHE 111 : TIT1 = MCHEL1.TITCHE 112 : TIT2 = MCHEL2.TITCHE 113 : IF (IFO1.NE.IFO2) THEN 114 : MOTERR(1:8)=TIT1(1:8) 115 : MOTERR(9:16)=TIT2(1:8) 115 : CALL ERREUR (175) 116 : GOTO 666 117 : ENDIF 118 : NSOUS1=MCHEL1.ICHAML(/1) 119 : NSOUS2=MCHEL2.ICHAML(/1) 120 : IF(NSOUS1.NE.NSOUS2) GOTO 166 121 : * 122 : IF (K.EQ.4.OR.K.EQ.5) THEN 123 : 124 : * BESOIN DU MMODEL 125 : * 126 : IF (IPMODL.EQ.0) THEN 127 : MOTERR(1:8)='MMODEL ' 127 : CALL ERREUR (37) 128 : GOTO 666 129 : ENDIF 130 : * 131 : * ACTIVATION DU MMODEL 132 : * 133 : MMODEL=IPMODL 134 : SEGACT MMODEL 135 : NSOUMO=KMODEL(/1) 136 : * 137 : * ON CREE UN CHAMELEM DE CONTRAINTE OU DE DEFORMATION , 138 : * DE GRADIENT OU DE GRADIENT DE FLEXION. 139 : * 140 : L1=NUMCHA 141 : N1=NSOUMO 142 : N3=MCHEL1.INFCHE(/2) 143 : SEGINI MCHELM 144 : IPCHMU=MCHELM 145 : TITCHE=TITC 146 : IFOCHE=IFO1 147 : * 148 : * REMPLISSAGE DU CHAPEAU DU MCHAML 149 : * 150 : isouss=0 151 : DO 130 ISOUMO=1,NSOUMO 152 : IMODEL=KMODEL(ISOUMO) 153 : SEGACT IMODEL 154 : IPMAIL=IMAMOD 155 : CONM =CONMOD 156 : if(nefmod.eq.22) go to 134 157 : isouss=isouss+1 158 : DO 131 ISOUS1=1,NSOUS1 159 : IPMAI1=MCHEL1.IMACHE(ISOUS1) 160 : CONCH1=MCHEL1.CONCHE(ISOUS1) 161 : IF (IPMAIL.EQ.IPMAI1. AND.CONM.EQ.CONCH1) THEN 162 : DO 132 N33=1,N3 163 : INFCHE(ISOUMO,N33)=MCHEL1.INFCHE(ISOUS1,N33) 164 : 132 CONTINUE 165 : IMACHE(ISOUss)=IPMAI1 166 : CONCHE(ISOUss)=CONCH1 167 : GOTO 134 168 : ENDIF 169 : 131 CONTINUE 170 : * 171 : * ERREUR PAS DE CORRESPONDANCE 172 : * 173 : SEGDES IMODEL 174 : SEGDES MMODEL 175 : SEGSUP MCHELM 176 : GOTO 166 177 : 134 CONTINUE 178 : SEGDES IMODEL 179 : 130 CONTINUE 180 : if( nsoumo.ne.isouss) then 181 : n1=isouss 182 : segadj mchelm 183 : IPCHMU=mchelm 184 : endif 185 : nsous=isouss 186 : * 187 : ELSE 188 : * 189 : * QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2 190 : * 191 : LX=NSOUS1 192 : SEGINI MTRAA 193 : DO 110 ISOUS1=1,NSOUS1 194 : IPMAI1=MCHEL1.IMACHE(ISOUS1) 195 : ipt1=ipmai1 196 : CONCH1=MCHEL1.CONCHE(ISOUS1) 197 : DO 120 ISOUS2=1,NSOUS2 198 : IPMAI2=MCHEL2.IMACHE(ISOUS2) 199 : CONCH2=MCHEL2.CONCHE(ISOUS2) 200 : IF(IPMAI1.NE.IPMAI2) GOTO 120 201 : IF(CONCH1.NE.CONCH2) GOTO 120 201 : CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) 202 : IF (IRTD.EQ.0) GOTO 120 203 : IMINT1=0 204 : IMINT2=0 205 : IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) 206 : IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) 207 : IF (IMINT1.EQ.IMINT2) GOTO 121 208 : IMINT1=1 209 : IMINT2=1 210 : IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) 211 : IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6) 212 : IF (IMINT1.EQ.0) IMINT1=1 213 : IF (IMINT2.EQ.0) IMINT2=1 214 : IF (IMINT1.EQ.IMINT2) GOTO 121 215 : * 216 : * ERREUR PAS DE CORRESPONDANCE 2 A 2 217 : * 218 : SEGSUP MTRAA 219 : MOTERR(1:8)=TIT1(1:8) 220 : MOTERR(9:16)=TIT1(1:8) 220 : CALL ERREUR (175) 221 : GOTO 666 222 : 120 CONTINUE 223 : * 224 : * ERREUR PAS DE CORRESPONDANCE 2 A 2 225 : * 226 : * 227 : *on essaye betement de voir si maillage identique avec 2 pointeurs différents 228 : * 229 : segact ipt1 230 : nel1=ipt1.num(/2) 231 : DO 122 ISOUS2=1,NSOUS2 232 : IPMAI2=MCHEL2.IMACHE(ISOUS2) 233 : CONCH2=MCHEL2.CONCHE(ISOUS2) 234 : IF(CONCH1.NE.CONCH2) GOTO 122 235 : ipt2=ipmai2 236 : segact ipt2 237 : if(ipt1.itypel.ne.ipt2.itypel) then 238 : segdes ipt2 239 : go to 122 240 : endif 241 : nel2=ipt2.num(/2) 242 : if(nel1.ne.nel2) go to 122 243 : do 123 lo=1,nel1 244 : do 123 lp=1,ipt1.num(/1) 245 : if(ipt1.num(lp,lo).ne.ipt2.num(lp,lo) ) then 246 : segdes ipt2 247 : go to 122 248 : endif 249 : 123 continue 250 : IMINT1=0 251 : IMINT2=0 252 : IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) 253 : IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) 254 : IF (IMINT1.EQ.IMINT2) GOTO 121 255 : IMINT1=1 256 : IMINT2=1 257 : IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) 258 : IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6) 259 : IF (IMINT1.EQ.0) IMINT1=1 260 : IF (IMINT2.EQ.0) IMINT2=1 261 : IF (IMINT1.EQ.IMINT2) GOTO 121 262 : 122 continue 263 : 264 : SEGSUP MTRAA 265 : MOTERR(1:8)=TIT1(1:8) 266 : MOTERR(9:16)=TIT1(1:8) 266 : CALL ERREUR (175) 267 : GOTO 666 268 : * 269 : 121 CONTINUE 270 : ITRAA(ISOUS1)=ISOUS2 271 : segdes ipt1 272 : 110 CONTINUE 273 : * 274 : * CREATION DU MCHELM RESULTAT 275 : * 276 : NSOUS=NSOUS1 277 : SEGINI,MCHELM=MCHEL1 278 : IPCHMU=MCHELM 279 : ENDIF 280 : * 281 : *________________________________________________________________ 282 : * BOUCLE SUR LES SOUS PAQUETS DE MCHELM 283 : * 284 : DO 200 ISOUS=1,NSOUS 285 : 286 : * 287 : ******** MULTIPLICATION SCALAIRE * SCALAIRE ******************** 288 : * 289 : IF (K.EQ.1) THEN 290 : * 291 : ISOUS2=ITRAA(ISOUS) 292 : MCHAM1=MCHEL1.ICHAML(ISOUS) 293 : MCHAM2=MCHEL2.ICHAML(ISOUS2) 294 : SEGACT MCHAM1,MCHAM2 295 : IF (MCHAM1.TYPCHE(1).NE.'REAL*8'.OR. 296 : & MCHAM2.TYPCHE(1).NE.'REAL*8') THEN 297 : C MOTERR(1:4)=MCHAM1.NOMCHE(1) 298 : BID=MCHAM1.NOMCHE(1) 299 : MOTERR(1:4)=BID(1:4) 299 : CALL ERREUR (197) 300 : GOTO 9999 301 : ENDIF 302 : MELVA1=MCHAM1.IELVAL(1) 303 : MELVA2=MCHAM2.IELVAL(1) 304 : SEGACT MELVA1,MELVA2 305 : * 306 : * CREATION DU MCHAML DE LA SOUS ZONE 307 : * 308 : N2=1 309 : SEGINI MCHAML 310 : NOMCHE(1)=MCHAM1.NOMCHE(1) 311 : TYPCHE(1)='REAL*8' 312 : ICHAML(ISOUS)=MCHAML 313 : * 314 : N1GEL=MELVA1.VELCHE(/1) 315 : N1BEL=MELVA1.VELCHE(/2) 316 : N2GEL=MELVA2.VELCHE(/1) 317 : N2BEL=MELVA2.VELCHE(/2) 318 : * 319 : N1PTEL=MAX(N1GEL,N2GEL) 320 : N1EL =MAX(N1BEL,N2BEL) 321 : N2PTEL=0 322 : N2EL =0 323 : SEGINI MELVAL 324 : IELVAL(1)=MELVAL 325 : DO 1010 IGAU=1,N1PTEL 326 : IGMN1=MIN(IGAU,N1GEL) 327 : IGMN2=MIN(IGAU,N2GEL) 328 : DO 1010 IB=1,N1EL 329 : IBMN1=MIN(IB ,N1BEL) 330 : IBMN2=MIN(IB ,N2BEL) 331 : XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) 332 : XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) 333 : IF(IINV.EQ.1) VELCHE(IGAU,IB)=XTT1*XTT2 334 : IF(IINV.EQ.-1)VELCHE(IGAU,IB)=XTT1/XTT2 335 : 1010 CONTINUE 336 : SEGDES MELVAL,MCHAML 337 : SEGDES MELVA1,MELVA2,MCHAM1,MCHAM2 338 : GOTO 200 339 : * 340 : ******** MULTIPLICATION COMPOSANTES * SCALAIRE ******************* 341 : * 342 : ELSE IF (K.EQ.2) THEN 343 : * 344 : ISOUS2=ITRAA(ISOUS) 345 : MCHAM1=MCHEL1.ICHAML(ISOUS) 346 : MCHAM2=MCHEL2.ICHAML(ISOUS2) 347 : SEGACT MCHAM1,MCHAM2 348 : IF (MCHAM2.TYPCHE(1).NE.'REAL*8') THEN 349 : C MOTERR(1:4)=MCHAM2.NOMCHE(1)(1:4) 350 : BID=MCHAM2.NOMCHE(1) 351 : MOTERR(1:4)=BID(1:4) 351 : CALL ERREUR (197) 352 : GOTO 9999 353 : ENDIF 354 : MELVA2=MCHAM2.IELVAL(1) 355 : SEGACT MELVA2 356 : N2GEL=MELVA2.VELCHE(/1) 357 : N2BEL=MELVA2.VELCHE(/2) 358 : * 359 : * CREATION DU MCHAML DE LA SOUS ZONE 360 : * 361 : SEGINI,MCHAML=MCHAM1 362 : ICHAML(ISOUS)=MCHAML 363 : DO 2010 ICOMP=1,IELVAL(/1) 364 : MELVA1=IELVAL(ICOMP) 365 : SEGACT MELVA1 366 : N1GEL=MELVA1.VELCHE(/1) 367 : IF (N1GEL.EQ.0) THEN 368 : N1GEL=MELVA1.IELCHE(/1) 369 : N1BEL=MELVA1.IELCHE(/2) 370 : N1PTEL=0 371 : N1EL=0 372 : N2PTEL=MAX(N1GEL,N2GEL) 373 : N2EL =MAX(N1BEL,N2BEL) 374 : SEGINI MELVAL 375 : IELVAL(ICOMP)=MELVAL 376 : IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN 377 : DO 2020 IGAU=1,N2PTEL 378 : IGMN1=MIN(IGAU,N1GEL) 379 : IGMN2=MIN(IGAU,N2GEL) 380 : DO 2020 IB=1,N2EL 381 : IBMN1=MIN(IB ,N1BEL) 382 : ILREE1=MELVA1.IELCHE(IGMN1,IBMN1) 383 : IBMN2=MIN(IB ,N2BEL) 384 : XTT1=MELVA2.VELCHE(IGMN2,IBMN2) 384 : CALL MUFLIR (ILREE1,XTT1,ILREEL,IINV) 385 : IELCHE(IGAU,IB)=ILREEL 386 : 2020 CONTINUE 387 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN 388 : DO 2030 IGAU=1,N2PTEL 389 : IGMN1=MIN(IGAU,N1GEL) 390 : IGMN2=MIN(IGAU,N2GEL) 391 : DO 2030 IB=1,N2EL 392 : IBMN2=MIN(IB ,N2BEL) 393 : XTT1=MELVA2.VELCHE(IGMN2,IBMN2) 394 : IBMN1=MIN(IB ,N1BEL) 395 : IP=MELVA1.IELCHE(IGMN1,IBMN1) 396 : IREF=(IP-1)*(IDIM+1) 397 : * 398 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 399 : * 400 : SEGACT MCOORD 401 : NBNO=XCOOR(/1)/(IDIM+1) 402 : NBNOI=NBNO 403 : NBPTS=NBNO+1 404 : SEGADJ MCOORD 405 : * 406 : DO 2031 IC=1,IDIM 407 : IF(IINV.EQ.1) XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XTT1 408 : IF(IINV.EQ.-1)XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)/XTT1 409 : 2031 CONTINUE 410 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 411 : IELCHE(IGAU,IB)=NBPTS 412 : 2030 CONTINUE 413 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN 414 : DO 2040 IGAU=1,N2PTEL 415 : IGMN1=MIN(IGAU,N1GEL) 416 : IGMN2=MIN(IGAU,N2GEL) 417 : DO 2040 IB=1,N2EL 418 : IBMN1=MIN(IB ,N1BEL) 419 : IEVOL1=MELVA1.IELCHE(IGMN1,IBMN1) 420 : IBMN2=MIN(IB ,N2BEL) 421 : XTT1=MELVA2.VELCHE(IGMN2,IBMN2) 421 : CALL MUFLEV(IEVOL1,XTT1,IEVOL,IINV) 422 : IELCHE(IGAU,IB)=IEVOL 423 : 2040 CONTINUE 424 : ELSE 425 : * 426 : * NOM DE COMPOSANTE NON RECONNU 427 : * 428 : C MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)(1:4) 429 : BID=MCHAM1.NOMCHE(ICOMP) 430 : MOTERR(1:4)=BID(1:4) 430 : CALL ERREUR(197) 431 : SEGSUP MELVAL,MCHAML 432 : SEGSUP MCHELM,MTRAA,MCHAML 433 : SEGDES MCHAM2 434 : GOTO 666 435 : ENDIF 436 : ELSE 437 : N1BEL=MELVA1.VELCHE(/2) 438 : N1PTEL=MAX(N1GEL,N2GEL) 439 : N1EL =MAX(N1BEL,N2BEL) 440 : N2PTEL=0 441 : N2EL=0 442 : SEGINI MELVAL 443 : IELVAL(ICOMP)=MELVAL 444 : DO 2050 IGAU=1,N1PTEL 445 : IGMN1=MIN(IGAU,N1GEL) 446 : IGMN2=MIN(IGAU,N2GEL) 447 : DO 2050 IB=1,N1EL 448 : IBMN1=MIN(IB ,N1BEL) 449 : XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) 450 : IBMN2=MIN(IB ,N2BEL) 451 : XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) 452 : IF(IINV.EQ.1) VELCHE(IGAU,IB)=XTT1*XTT2 453 : IF(IINV.EQ.-1)VELCHE(IGAU,IB)=XTT1/XTT2 454 : 2050 CONTINUE 455 : ENDIF 456 : SEGDES MELVA1,MELVAL 457 : 2010 CONTINUE 458 : SEGDES MELVA2 459 : SEGDES MCHAM1,MCHAM2,MCHAML 460 : GOTO 200 461 : * 462 : ******** MULTIPLICATION COMPOSANTE * COMPOSANTE ***************** 463 : * 464 : ELSE IF (K.EQ.3) THEN 465 : * 466 : c noms de composante ? 467 : if (lmot1.gt.0) then 468 : mlmot1 = lmot1 469 : segact mlmot1 470 : jgm = mlmot1.mots(/2) 471 : if (lmot2.gt.0) then 472 : mlmot2 = lmot2 473 : segact mlmot2 474 : if (mlmot1.mots(/2).ne.mlmot2.mots(/2)) then 475 : MOTERR(1:8)='LISTMOTS' 476 : MOTERR(9:16)='mots ' 476 : call erreur(403) 477 : goto 666 478 : endif 479 : mlmot3 = lmot3 480 : segact mlmot3 481 : if (mlmot1.mots(/2).ne.mlmot3.mots(/2)) then 482 : MOTERR(1:8)='LISTMOTS' 483 : MOTERR(9:16)='mots ' 483 : call erreur(403) 484 : goto 666 485 : endif 486 : if (IPLREE.gt.0) then 487 : mlree3 = IPLREE 488 : segact mlree3 489 : if (mlmot1.mots(/2).ne.mlree3.prog(/1)) then 490 : MOTERR(1:8)='LIST****' 491 : MOTERR(9:16)='termes ' 491 : call erreur(403) 492 : goto 666 493 : endif 494 : endif 495 : endif 496 : endif 497 : ISOUS2=ITRAA(ISOUS) 498 : MCHAM1=MCHEL1.ICHAML(ISOUS) 499 : MCHAM2=MCHEL2.ICHAML(ISOUS2) 500 : SEGACT MCHAM1,MCHAM2 501 : NCOMP=MCHAM1.IELVAL(/1) 502 : * 503 : * CREATION DU MCHAML DE LA SOUS ZONE 504 : * 505 : SEGINI,MCHAML=MCHAM1 506 : if (lmot1.gt.0) then 507 : n2 = mlmot1.mots(/2) 508 : segadj mchaml 509 : endif 510 : ICHAML(ISOUS)=MCHAML 511 : * compteur des composantes des listmots 512 : lcomp = 1 513 : * 514 : DO 310 ICOMP=1,NCOMP 515 : c si le nombre de composantes final est atteint on sort 516 : C if (lmot1.gt.0.AND.lcomp.gt.mlmot1.mots(/2)) goto 200 517 : if (lmot1.gt.0) then 518 : if (lcomp.gt.mlmot1.mots(/2)) goto 200 518 : call place(mlmot1.mots,jgm,jplac,mcham1.nomche(icomp)) 519 : if (jplac.ne.0) then 519 : call place(mcham2.nomche,ncomp,iplac,mlmot2.mots(jplac)) 520 : else 521 : c nom de composante non reconnu 522 : goto 310 523 : c MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)(1:4) 524 : c MOTERR(5:8)='MCHAML' <<< 'CHAM' ! 524 : c CALL ERREUR(77) 525 : c SEGSUP MCHAML,MCHELM,MTRAA 526 : c SEGDES MCHAM2,MCHAM2 527 : c GOTO 666 528 : endif 529 : else 529 : CALL PLACE (MCHAM2.NOMCHE,NCOMP,IPLAC, 530 : & NOMCHE(ICOMP)) 531 : jplac = iplac 532 : endif 533 : IF (IPLAC.NE.0) THEN 534 : if (lmot1.gt.0) then 535 : nomche(jplac) = mlmot3.mots(jplac) 536 : endif 537 : MELVA1=MCHAM1.IELVAL(ICOMP) 538 : MELVA2=MCHAM2.IELVAL(IPLAC) 539 : SEGACT MELVA1,MELVA2 540 : IF (MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8' 541 : & .AND.MCHAM2.TYPCHE(IPLAC).EQ.'REAL*8') THEN 542 : N1GEL=MELVA1.VELCHE(/1) 543 : N1BEL=MELVA1.VELCHE(/2) 544 : N2GEL=MELVA2.VELCHE(/1) 545 : N2BEL=MELVA2.VELCHE(/2) 546 : N1PTEL=MAX(N1GEL,N2GEL) 547 : N1EL =MAX(N1BEL,N2BEL) 548 : N2PTEL=0 549 : N2EL=0 550 : SEGINI MELVAL 551 : IELVAL(jplac)=MELVAL 552 : lcomp = lcomp + 1 553 : * 554 : DO 320 IGAU=1,N1PTEL 555 : IGMN1=MIN(IGAU,N1GEL) 556 : IGMN2=MIN(IGAU,N2GEL) 557 : DO 320 IB=1,N1EL 558 : IBMN1=MIN(IB ,N1BEL) 559 : IBMN2=MIN(IB ,N2BEL) 560 : XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) 561 : XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) 562 : if (IPLREE.gt.0) then 563 : velche(igau,ib) = xtt1*xtt2*mlree3.prog(jplac) 564 : else 565 : IF(IINV.EQ.1) VELCHE(IGAU,IB)=XTT1*XTT2 566 : IF(IINV.EQ.-1) VELCHE(IGAU,IB)=XTT1/XTT2 567 : endif 568 : 320 CONTINUE 569 : GOTO 311 570 : ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8' 571 : & .AND.MCHAM2.TYPCHE(IPLAC).EQ.'POINTEURLISTREEL') THEN 572 : N1GEL=MELVA1.VELCHE(/1) 573 : N1BEL=MELVA1.VELCHE(/2) 574 : N2GEL=MELVA2.IELCHE(/1) 575 : N2BEL=MELVA2.IELCHE(/2) 576 : if (lmot1.gt.0) then 577 : typche(jplac) = 'POINTEURLISTREEL' 578 : else 579 : typche(icomp) = 'POINTEURLISTREEL' 580 : endif 581 : N1PTEL=0 582 : N1EL=0 583 : N2PTEL=MAX(N1GEL,N2GEL) 584 : N2EL =MAX(N1BEL,N2BEL) 585 : SEGINI MELVAL 586 : IELVAL(jplac)=MELVAL 587 : lcomp = lcomp + 1 588 : DO 331 IGAU=1,N2PTEL 589 : IGMN1=MIN(IGAU,N1GEL) 590 : IGMN2=MIN(IGAU,N2GEL) 591 : DO 331 IB=1,N2EL 592 : IBMN1=MIN(IB ,N1BEL) 593 : IBMN2=MIN(IB ,N2BEL) 594 : xtt1 = melva1.velche(igmn1,ibmn1) 595 : MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) 596 : SEGACT MLREE2 597 : IPROG2=MLREE2.PROG(/1) 598 : JG= IPROG2 599 : SEGINI MLREEL 600 : DO 341 IPROG=1,JG 601 : if (IPLREE.gt.0) then 602 : prog(iprog) = xtt1*mlree2.prog(iprog)*mlree3.prog(jplac) 603 : else 604 : IF(IINV.EQ.1) PROG(IPROG)=xtt1*MLREE2.PROG(IPROG) 605 : IF(IINV.EQ.-1) PROG(IPROG)=xtt1/MLREE2.PROG(IPROG) 606 : endif 607 : 341 CONTINUE 608 : SEGDES MLREEL,MLREE2 609 : IELCHE(IGAU,IB)=MLREEL 610 : 331 CONTINUE 611 : GOTO 311 612 : ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL' 613 : & .AND.MCHAM2.TYPCHE(IPLAC).EQ.'REAL*8') THEN 614 : N1GEL=MELVA1.IELCHE(/1) 615 : N1BEL=MELVA1.IELCHE(/2) 616 : N2GEL=MELVA2.VELCHE(/1) 617 : N2BEL=MELVA2.VELCHE(/2) 618 : if (lmot1.gt.0) then 619 : typche(jplac) = 'POINTEURLISTREEL' 620 : else 621 : typche(icomp) = 'POINTEURLISTREEL' 622 : endif 623 : N1PTEL=0 624 : N1EL=0 625 : N2PTEL=MAX(N1GEL,N2GEL) 626 : N2EL =MAX(N1BEL,N2BEL) 627 : SEGINI MELVAL 628 : IELVAL(jplac)=MELVAL 629 : lcomp = lcomp + 1 630 : DO 332 IGAU=1,N2PTEL 631 : IGMN1=MIN(IGAU,N1GEL) 632 : IGMN2=MIN(IGAU,N2GEL) 633 : DO 332 IB=1,N2EL 634 : IBMN1=MIN(IB ,N1BEL) 635 : IBMN2=MIN(IB ,N2BEL) 636 : xtt2 = melva2.velche(igmn2,ibmn2) 637 : MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) 638 : SEGACT MLREE1 639 : IPROG1=MLREE1.PROG(/1) 640 : JG= IPROG1 641 : SEGINI MLREEL 642 : DO 342 IPROG=1,JG 643 : if (IPLREE.gt.0) then 644 : prog(iprog) = xtt2*mlree1.prog(iprog)*mlree3.prog(jplac) 645 : else 646 : IF(IINV.EQ.1) PROG(IPROG)=xtt2*MLREE1.PROG(IPROG) 647 : IF(IINV.EQ.-1) PROG(IPROG)=xtt2/MLREE1.PROG(IPROG) 648 : endif 649 : 342 CONTINUE 650 : SEGDES MLREEL,MLREE1 651 : IELCHE(IGAU,IB)=MLREEL 652 : 332 CONTINUE 653 : GOTO 311 654 : ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL' 655 : & .AND.MCHAM2.TYPCHE(IPLAC).EQ.'POINTEURLISTREEL') THEN 656 : N1GEL=MELVA1.IELCHE(/1) 657 : N1BEL=MELVA1.IELCHE(/2) 658 : N2GEL=MELVA2.IELCHE(/1) 659 : N2BEL=MELVA2.IELCHE(/2) 660 : N1PTEL=0 661 : N1EL=0 662 : N2PTEL=MAX(N1GEL,N2GEL) 663 : N2EL =MAX(N1BEL,N2BEL) 664 : SEGINI MELVAL 665 : IELVAL(jplac)=MELVAL 666 : lcomp = lcomp + 1 667 : DO 330 IGAU=1,N2PTEL 668 : IGMN1=MIN(IGAU,N1GEL) 669 : IGMN2=MIN(IGAU,N2GEL) 670 : DO 330 IB=1,N2EL 671 : IBMN1=MIN(IB ,N1BEL) 672 : IBMN2=MIN(IB ,N2BEL) 673 : MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) 674 : MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) 675 : SEGACT MLREE1,MLREE2 676 : IPROG1=MLREE1.PROG(/1) 677 : IPROG2=MLREE2.PROG(/1) 678 : JG=MAX(IPROG1,IPROG2) 679 : SEGINI MLREEL 680 : DO 340 IPROG=1,JG 681 : IF ( (IPROG.GT.IPROG1).OR. 682 : & (IPROG.GT.IPROG2) ) THEN 683 : PROG(IPROG)=0.D0 684 : ELSE 685 : if (IPLREE.gt.0) then 686 : prog(iprog) = mlree1.prog(iprog) * mlree2.prog(iprog) 687 : & * mlree3.prog(jplac) 688 : else 689 : IF(IINV.EQ.1) PROG(IPROG)=MLREE1.PROG(IPROG)* 690 : & MLREE2.PROG(IPROG) 691 : IF(IINV.EQ.-1) PROG(IPROG)=MLREE1.PROG(IPROG)/ 692 : & MLREE2.PROG(IPROG) 693 : endif 694 : ENDIF 695 : 340 CONTINUE 696 : SEGDES MLREEL,MLREE1,MLREE2 697 : IELCHE(IGAU,IB)=MLREEL 698 : 330 CONTINUE 699 : ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO' 700 : & .AND.MCHAM2.TYPCHE(IPLAC).EQ.'POINTEUREVOLUTIO') THEN 701 : N1GEL=MELVA1.IELCHE(/1) 702 : N1BEL=MELVA1.IELCHE(/2) 703 : N2GEL=MELVA2.IELCHE(/1) 704 : N2BEL=MELVA2.IELCHE(/2) 705 : N1PTEL=0 706 : N1EL=0 707 : N2PTEL=MAX(N1GEL,N2GEL) 708 : N2EL =MAX(N1BEL,N2BEL) 709 : SEGINI MELVAL 710 : IELVAL(JPLAC)=MELVAL 711 : LCOMP=LCOMP+1 712 : DO 333 IGAU=1,N2PTEL 713 : IGMN1=MIN(IGAU,N1GEL) 714 : IGMN2=MIN(IGAU,N2GEL) 715 : DO 333 IB=1,N2EL 716 : IBMN1=MIN(IB,N1BEL) 717 : IBMN2=MIN(IB,N2BEL) 718 : MEVOL1=MELVA1.IELCHE(IGMN1,IBMN1) 719 : MEVOL2=MELVA2.IELCHE(IGMN2,IBMN2) 719 : CALL PUIS(MEVOL1,MEVOL2,MEVOL3,IINV) 720 : IF (IPLREE.GT.0) THEN 721 : XFLOT1=MLREE3.prog(JPLAC) 721 : CALL MUFLEV(MEVOL3,XFLOT1,MEVOL3,1) 722 : ENDIF 723 : IELCHE(IGAU,IB)=MEVOL3 724 : 333 CONTINUE 725 : GOTO 311 726 : ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8' 727 : & .AND.MCHAM2.TYPCHE(IPLAC).EQ.'POINTEUREVOLUTIO') THEN 728 : N1GEL=MELVA1.VELCHE(/1) 729 : N1BEL=MELVA1.VELCHE(/2) 730 : N2GEL=MELVA2.IELCHE(/1) 731 : N2BEL=MELVA2.IELCHE(/2) 732 : IF (LMOT1.GT.0) THEN 733 : TYPCHE(JPLAC) = 'POINTEUREVOLUTIO' 734 : ELSE 735 : TYPCHE(ICOMP) = 'POINTEUREVOLUTIO' 736 : ENDIF 737 : N1PTEL=0 738 : N1EL=0 739 : N2PTEL=MAX(N1GEL,N2GEL) 740 : N2EL =MAX(N1BEL,N2BEL) 741 : SEGINI MELVAL 742 : IELVAL(JPLAC)=MELVAL 743 : LCOMP=LCOMP+1 744 : DO 334 IGAU=1,N2PTEL 745 : IGMN1=MIN(IGAU,N1GEL) 746 : IGMN2=MIN(IGAU,N2GEL) 747 : DO 334 IB=1,N2EL 748 : IBMN1=MIN(IB,N1BEL) 749 : IBMN2=MIN(IB,N2BEL) 750 : XFLOT1=MELVA1.VELCHE(IGMN1,IBMN1) 751 : MEVOL2=MELVA2.IELCHE(IGMN2,IBMN2) 752 : IF (IPLREE.GT.0) THEN 753 : XFLOT1=XFLOT1*MLREE3.prog(JPLAC) 754 : ENDIF 754 : CALL MUFLEV(MEVOL2,XFLOT1,IRET,IINV) 755 : IELCHE(IGAU,IB)=IRET 756 : 334 CONTINUE 757 : GOTO 311 758 : ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO' 759 : & .AND.MCHAM2.TYPCHE(IPLAC).EQ.'REAL*8') THEN 760 : N1GEL=MELVA1.IELCHE(/1) 761 : N1BEL=MELVA1.IELCHE(/2) 762 : N2GEL=MELVA2.VELCHE(/1) 763 : N2BEL=MELVA2.VELCHE(/2) 764 : IF (LMOT1.GT.0) THEN 765 : TYPCHE(JPLAC) = 'POINTEUREVOLUTIO' 766 : ELSE 767 : TYPCHE(ICOMP) = 'POINTEUREVOLUTIO' 768 : ENDIF 769 : N1PTEL=0 770 : N1EL=0 771 : N2PTEL=MAX(N1GEL,N2GEL) 772 : N2EL =MAX(N1BEL,N2BEL) 773 : SEGINI MELVAL 774 : IELVAL(JPLAC)=MELVAL 775 : LCOMP=LCOMP+1 776 : DO 335 IGAU=1,N2PTEL 777 : IGMN1=MIN(IGAU,N1GEL) 778 : IGMN2=MIN(IGAU,N2GEL) 779 : DO 335 IB=1,N2EL 780 : IBMN1=MIN(IB,N1BEL) 781 : IBMN2=MIN(IB,N2BEL) 782 : MEVOL1=MELVA1.IELCHE(IGMN1,IBMN1) 783 : XFLOT1=MELVA2.VELCHE(IGMN2,IBMN2) 784 : IF (IPLREE.GT.0) THEN 785 : XFLOT1=XFLOT1*MLREE3.prog(JPLAC) 786 : ENDIF 786 : CALL MUFLEV(MEVOL1,XFLOT1,IRET,IINV) 787 : IELCHE(IGAU,IB)=IRET 788 : 335 CONTINUE 789 : GOTO 311 790 : ENDIF 791 : * 792 : * NOM DE COMPOSANTE NON RECONNU 793 : * 794 : MOTERR(1:4)='* ' 795 : C MOTERR(5:8)=NOMCHE(ICOMP)(1:4) 796 : BID=NOMCHE(ICOMP) 797 : MOTERR(5:8)=BID(1:4) 797 : CALL ERREUR(335) 798 : SEGSUP MCHAML,MCHELM,MTRAA 799 : SEGDES MELVA1,MELVA2,MCHAM2 800 : GOTO 666 801 : ELSE 802 : MOTERR(1:4)=NOMCHE(ICOMP) 803 : MOTERR(5:8)='CHAM' 803 : CALL ERREUR(77) 804 : SEGSUP MCHAML,MCHELM,MTRAA 805 : SEGDES MCHAM2 806 : GOTO 666 807 : ENDIF 808 : 311 CONTINUE 809 : SEGDES MELVAL,MELVA1,MELVA2 810 : 310 CONTINUE 811 : SEGDES MCHAML,MCHAM2,MCHAM1 812 : GOTO 200 813 : 814 : * 815 : ******** MULTIPLICATION MATRICE * COMPOSANTE ****************** 816 : * 817 : ELSE IF (K.EQ.4) THEN 818 : * 819 : IMODEL=KMODEL(ISOUS) 820 : SEGACT IMODEL 821 : IPMAIL=IMAMOD 822 : CONM =CONMOD 823 : MELE=NEFMOD 824 : C 825 : C COQUE INTEGREE OU PAS ? 826 : C 827 : IF(INFMOD(/1).NE.0)THEN 828 : NPINT=INFMOD(1) 829 : ELSE 830 : NPINT=0 831 : ENDIF 832 : IF (NPINT.NE.0)THEN 832 : CALL ERREUR(615) 833 : SEGDES IMODEL,MMODEL 834 : SEGSUP MCHELM 835 : GOTO 666 836 : ENDIF 837 : * 838 : * INFORMATION SUR L'ELEMENT FINI 839 : * 839 : CALL ELQUOI (MELE,0,6,IPINF,IMODEL) 840 : IF (IERR.NE.0) THEN 841 : SEGDES IMODEL,MMODEL 842 : SEGSUP MCHELM 843 : GOTO 666 844 : ENDIF 845 : INFO=IPINF 846 : MFR=INFELL(13) 847 : segsup info 848 : * 849 : * CREATION DU TABLEAU INFOS 850 : * 851 : lsupin=.true. 852 : lsupre=.true. 852 : CALL IDENT (IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD) 853 : if(lnomid(5).ne.0) then 854 : nomid=lnomid(5) 855 : segact nomid 856 : nobde=lesobl(/2) 857 : lsupde=.false. 858 : modef=nomid 859 : else 860 : lsupde=.true. 860 : CALL IDDEFO (IMODEL,IFO1,MOdef ,Nobde ,NFAC) 861 : endif 862 : if(lnomid(4).ne.0) then 863 : nomid=lnomid(4) 864 : segact nomid 865 : mocon=nomid 866 : nconn=lesobl(/2) 867 : nfac=lesfac(/2) 868 : lsupco=.false. 869 : else 870 : lsupco=.true. 870 : CALL IDCONT (IMODEL,IFO1,MOCOn,NCOnn ,NFAC) 871 : endif 872 : IF (NUMCHA.EQ.12) THEN 873 : mocomp=mocon 874 : ncom=nconn 875 : lsupin=lsupco 876 : mores=modef 877 : nres= nobde 878 : lsupre=lsupde 879 : ELSE 880 : mores=mocon 881 : nres=nconn 882 : lsupre=lsupco 883 : mocomp=modef 884 : ncom=nobde 885 : lsupin=lsupde 886 : ENDIF 887 : * 888 : * VERIFICATION DE LA PRESENCE DES COMPOSANTES 889 : * 890 : * 891 : NBTYPE=1 892 : SEGINI NOTYPE 893 : MOTYPE=NOTYPE 894 : TYPE(1)='REAL*8' 894 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP, 895 : 1 MOTYPE,1,INFOS,3,IVACOM) 896 : SEGSUP NOTYPE 897 : IF (IERR.NE.0) GOTO 4998 898 : * 899 : * VERIFICATION PRESENCE DE LA MATRICE DE HOOKE 900 : * 901 : NBROBL=1 902 : NBRFAC=0 903 : SEGINI NOMID 904 : MOHOOK=NOMID 905 : LESOBL(1)='MAHO' 906 : * 907 : * VERIFICATION DE LA PRESENCE DES COMPOSANTES 908 : * 909 : NBTYPE=1 910 : SEGINI NOTYPE 911 : MOTYPE=NOTYPE 912 : TYPE(1)='POINTEURLISTREEL' 912 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOHOOK, 913 : 1 MOTYPE,1,INFOS,3,IVAHOO) 914 : SEGSUP NOTYPE 915 : IF (IERR.NE.0) GOTO 4999 916 : * 917 : * RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER 918 : * 919 : MPTVAL=IVAHOO 920 : MELVAL=IVAL(1) 921 : N1PTEL=IELCHE(/1) 922 : N1EL =IELCHE(/2) 923 : MPTVAL=IVACOM 924 : DO 401 IO=1,NCOM 925 : MELVAL=IVAL(IO) 926 : N1PTEL=MAX(N1PTEL,VELCHE(/1)) 927 : N1EL =MAX(N1EL ,VELCHE(/2)) 928 : 401 CONTINUE 929 : * 930 : * CREATION DU MCHAML DE LA SOUS ZONE 931 : * 932 : N2=NRES 933 : SEGINI MCHAML 934 : ICHAML(ISOUS)=MCHAML 935 : NS=1 936 : NCOSOU=NRES 937 : SEGINI MPTVAL 938 : IVARES=MPTVAL 939 : NOMID=MORES 940 : SEGACT NOMID 941 : DO 402 ICOMP=1,NRES 942 : NOMCHE(ICOMP)=LESOBL(ICOMP) 943 : TYPCHE(ICOMP)='REAL*8' 944 : N2PTEL=0 945 : N2EL=0 946 : SEGINI MELVAL 947 : IELVAL(ICOMP)=MELVAL 948 : IVAL(ICOMP)=MELVAL 949 : 402 CONTINUE 950 : DO 403 IGAU=1,N1PTEL 951 : DO 403 IB=1,N1EL 952 : MPTVAL=IVAHOO 953 : MELVAL=IVAL(1) 954 : IBMN=MIN(IB ,IELCHE(/2)) 955 : IGMN=MIN(IGAU,IELCHE(/1)) 956 : MLREEL=IELCHE(IGMN,IBMN) 957 : SEGACT MLREEL 958 : * 959 : * traitement spécial pour poreux ( mfr=33 ) 960 : * 961 : NCOMM = NCOM 962 : IF(MFR.EQ.33) NCOMM=NCOM-1 963 : * 964 : DO 404 ID=1,NCOMM 965 : CC=0.D0 966 : JJ = ID 967 : MPTVAL=IVACOM 968 : DO 405 JA=1,NCOMM 969 : MELVAL=IVAL(JA) 970 : IGMN=MIN(IGAU,VELCHE(/1)) 971 : IBMN=MIN(IB ,VELCHE(/2)) 972 : XTT1 =VELCHE(IGMN,IBMN) 973 : IF (JJ.GT.PROG(/1)) THEN 974 : XTT2=0.D0 975 : ELSE 976 : XTT2 =PROG(JJ) 977 : ENDIF 978 : CC = CC + XTT1 * XTT2 979 : JJ = JJ + NCOMM 980 : 405 CONTINUE 981 : IF (ID.LE.NRES) THEN 982 : * 983 : * CAS MFR=17 984 : * 985 : MPTVAL=IVARES 986 : MELVAL=IVAL(ID) 987 : VELCHE(IGAU,IB)=CC 988 : ENDIF 989 : 404 CONTINUE 990 : IF(MFR.EQ.33) THEN 991 : MPTVAL=IVACOM 992 : MELVAL=IVAL(NCOM) 993 : IGMN=MIN(IGAU,VELCHE(/1)) 994 : IBMN=MIN(IB ,VELCHE(/2)) 995 : CC =VELCHE(IGMN,IBMN) 996 : MPTVAL=IVARES 997 : MELVAL=IVAL(NRES) 998 : VELCHE(IGAU,IB)=CC 999 : ENDIF 1000 : SEGDES MLREEL 1001 : 403 CONTINUE 1002 : * 1002 : CALL DTMVAL(IVACOM,1) 1003 : * 1003 : CALL DTMVAL(IVAHOO,1) 1004 : * 1004 : CALL DTMVAL(IVARES,1) 1005 : * 1006 : NOMID=MOCOMP 1007 : if(lsupin)SEGSUP NOMID 1008 : NOMID=MOHOOK 1009 : SEGSUP NOMID 1010 : NOMID=MORES 1011 : if(lsupre)SEGSUP NOMID 1012 : * 1013 : * SEGSUP INFO 1014 : SEGDES IMODEL 1015 : GOTO 200 1016 : * 1017 : * ERREUR DESACTIVATION ET RETOUR 1018 : * 1019 : 4999 CONTINUE 1020 : * 1020 : CALL DTMVAL(IVAHOO,1) 1021 : NOMID=MOHOOK 1022 : SEGSUP NOMID 1023 : * 1024 : 4998 CONTINUE 1024 : CALL DTMVAL(IVACOM,1) 1025 : NOMID=MOCOMP 1026 : if(lsupin)SEGSUP NOMID 1027 : NOMID=MORES 1028 : if(lsupre)SEGSUP NOMID 1029 : * 1030 : * SEGSUP INFO 1031 : SEGDES IMODEL,MMODEL 1032 : SEGSUP MCHELM 1033 : IPCHMU=0 1034 : RETURN 1035 : 1036 : * 1037 : ******** MULTIPLICATION GRADIENT * GRADIENT ******************** 1038 : * 1039 : ELSE IF (K.EQ.5) THEN 1040 : * 1041 : IMODEL=KMODEL(ISOUS) 1042 : SEGACT IMODEL 1043 : IPMAIL=IMAMOD 1044 : CONM =CONMOD 1045 : MELE=NEFMOD 1046 : * 1047 : * INFORMATION SUR L'ELEMENT FINI 1048 : * 1048 : CALL ELQUOI (MELE,0,6,IPINF,IMODEL) 1049 : IF (IERR.NE.0) THEN 1050 : SEGDES IMODEL,MMODEL 1051 : SEGSUP MCHELM 1052 : IPCHMU=0 1053 : RETURN 1054 : ENDIF 1055 : INFO=IPINF 1056 : MFR=INFELL(13) 1057 : segsup info 1058 : * 1059 : * CREATION DU TABLEAU INFOS 1060 : * 1060 : CALL IDENT (IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD) 1061 : * 1062 : lsupg1=.true. 1063 : IF (TIT1.EQ.'GRADIENT') THEN 1064 : if(lnomid(3).ne.0) then 1065 : nomid=lnomid(3) 1066 : segact nomid 1067 : mogra1=nomid 1068 : ngra1=lesobl(/2) 1069 : nfac=lesfac(/2) 1070 : lsupg1=.false. 1071 : else 1071 : CALL IDGRAD (MFR,IFO1,MOGRA1,NGRA1,NFAC) 1072 : endif 1073 : ELSE IF (TIT1.EQ.'GRADIENT DE FLEXION') THEN 1074 : if(lnomid(11).ne.0) then 1075 : nomid=lnomid(11) 1076 : segact nomid 1077 : mogra1=nomid 1078 : ngra1=lesobl(/2) 1079 : nfac=lesfac(/2) 1080 : lsupg1=.false. 1081 : else 1081 : CALL IDGRAF (MFR,IFO1,MOGRA1,NGRA1,NFAC) 1082 : endif 1083 : ELSE 1083 : CALL ERREUR (21) 1084 : SEGDES IMODEL,MMODEL 1085 : SEGSUP MCHELM 1086 : IPCHMU=0 1087 : RETURN 1088 : ENDIF 1089 : * 1090 : lsupg2=.true. 1091 : IF (TIT2.EQ.'GRADIENT DE FLEXION') THEN 1092 : if(lnomid(11).ne.0) then 1093 : nomid=lnomid(11) 1094 : segact nomid 1095 : mogra2=nomid 1096 : ngra2=lesobl(/2) 1097 : nfac=lesfac(/2) 1098 : lsupg2=.false. 1099 : else 1099 : CALL IDGRAF (MFR,IFO2,MOGRA2,NGRA2,NFAC) 1100 : endif 1101 : ELSE IF (TIT2.EQ.'GRADIENT') THEN 1102 : if(lnomid(3).ne.0) then 1103 : nomid=lnomid(3) 1104 : segact nomid 1105 : mogra2=nomid 1106 : ngra2=lesobl(/2) 1107 : nfac=lesfac(/2) 1108 : lsupg2=.false. 1109 : else 1109 : CALL IDGRAD (MFR,IFO2,MOGRA2,NGRA2,NFAC) 1110 : endif 1111 : ELSE 1111 : CALL ERREUR (21) 1112 : SEGDES IMODEL,MMODEL 1113 : SEGSUP MCHELM 1114 : NOMID=MOGRA1 1115 : if(lsupg1)SEGSUP NOMID 1116 : IPCHMU=0 1117 : RETURN 1118 : ENDIF 1119 : * 1120 : NBTYPE=1 1121 : SEGINI NOTYPE 1122 : MOTYPE=NOTYPE 1123 : TYPE(1)='REAL*8' 1123 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOGRA1,MOTYPE, 1124 : 1 1,INFOS,3,IVAGR1) 1125 : SEGSUP NOTYPE 1126 : IF (IERR.NE.0) GOTO 5998 1127 : * 1128 : NBTYPE=1 1129 : SEGINI NOTYPE 1130 : MOTYPE=NOTYPE 1131 : TYPE(1)='REAL*8' 1131 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOGRA2, 1132 : 1 MOTYPE,1,INFOS,3,IVAGR2) 1133 : SEGSUP NOTYPE 1134 : IF (IERR.NE.0) GOTO 5999 1135 : * 1136 : * RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER 1137 : * 1138 : N1PTEL=0 1139 : N1EL=0 1140 : MPTVAL=IVAGR1 1141 : DO 520 IO=1,NGRA1 1142 : MELVAL=IVAL(IO) 1143 : N1PTEL=MAX(N1PTEL,VELCHE(/1)) 1144 : N1EL =MAX(N1EL ,VELCHE(/2)) 1145 : 520 CONTINUE 1146 : * 1147 : * CREATION DU MCHAML DE LA SOUS ZONE 1148 : * 1149 : N2=NGRA1 1150 : SEGINI MCHAML 1151 : ICHAML(ISOUS)=MCHAML 1152 : NS=1 1153 : NCOSOU=NGRA1 1154 : SEGINI MPTVAL 1155 : IVARES=MPTVAL 1156 : NOMID=MOGRA1 1157 : SEGACT NOMID 1158 : DO 521 ICOMP=1,NGRA1 1159 : NOMCHE(ICOMP)=LESOBL(ICOMP) 1160 : TYPCHE(ICOMP)='REAL*8' 1161 : N2PTEL=0 1162 : N2EL=0 1163 : SEGINI MELVAL 1164 : IELVAL(ICOMP)=MELVAL 1165 : IVAL(ICOMP)=MELVAL 1166 : 521 CONTINUE 1167 : SEGDES NOMID 1168 : * 1169 : NBPTEL=N1PTEL 1170 : NEL =N1EL 1171 : * 1172 : DO 502 IGAU=1,NBPTEL 1173 : DO 502 IB=1,NEL 1174 : DO 503 ID=1,3 1175 : CC=0.D0 1176 : DO 504 JA=1,3 1177 : MPTVAL=IVAGR1 1178 : MELVAL=IVAL(JA) 1179 : IGMN1=MIN(IGAU,VELCHE(/1)) 1180 : IBMN1=MIN(IB ,VELCHE(/2)) 1181 : XTT1=VELCHE(IGMN1,IBMN1) 1182 : * 1183 : JB=3*(JA-1)+ID 1184 : * 1185 : MPTVAL=IVAGR2 1186 : MELVAL=IVAL(JB) 1187 : IGMN2=MIN(IGAU,VELCHE(/1)) 1188 : IBMN2=MIN(IB ,VELCHE(/2)) 1189 : XTT2=VELCHE(IGMN2,IBMN2) 1190 : * 1191 : CC = CC + XTT1 * XTT2 1192 : 504 CONTINUE 1193 : MPTVAL=IVARES 1194 : MELVAL=IVAL(ID) 1195 : VELCHE(IGAU,IB)=CC 1196 : 503 CONTINUE 1197 : * 1198 : DO 505 ID=4,6 1199 : CC=0.D0 1200 : DO 506 JA=4,6 1201 : MPTVAL=IVAGR1 1202 : MELVAL=IVAL(JA) 1203 : IGMN1=MIN(IGAU,VELCHE(/1)) 1204 : IBMN1=MIN(IB ,VELCHE(/2)) 1205 : XTT1=VELCHE(IGMN1,IBMN1) 1206 : * 1207 : JB=3*(JA-5)+ID 1208 : * 1209 : MPTVAL=IVAGR2 1210 : MELVAL=IVAL(JB) 1211 : IGMN2=MIN(IGAU,VELCHE(/1)) 1212 : IBMN2=MIN(IB ,VELCHE(/2)) 1213 : XTT2=VELCHE(IGMN2,IBMN2) 1214 : * 1215 : CC = CC + XTT1 * XTT2 1216 : 506 CONTINUE 1217 : MPTVAL=IVARES 1218 : MELVAL=IVAL(ID) 1219 : VELCHE(IGAU,IB)=CC 1220 : 505 CONTINUE 1221 : * 1222 : DO 507 ID=7,9 1223 : CC=0.D0 1224 : DO 508 JA=7,9 1225 : MPTVAL=IVAGR1 1226 : MELVAL=IVAL(JA) 1227 : IGMN1=MIN(IGAU,VELCHE(/1)) 1228 : IBMN1=MIN(IB ,VELCHE(/2)) 1229 : XTT1=VELCHE(IGMN1,IBMN1) 1230 : * 1231 : JB=3*(JA-9)+ID 1232 : * 1233 : MPTVAL=IVAGR2 1234 : MELVAL=IVAL(JB) 1235 : IGMN2=MIN(IGAU,VELCHE(/1)) 1236 : IBMN2=MIN(IB ,VELCHE(/2)) 1237 : XTT2=VELCHE(IGMN2,IBMN2) 1238 : * 1239 : CC = CC + XTT1 * XTT2 1240 : 508 CONTINUE 1241 : MPTVAL=IVARES 1242 : MELVAL=IVAL(ID) 1243 : VELCHE(IGAU,IB)=CC 1244 : 507 CONTINUE 1245 : 502 CONTINUE 1246 : * 1246 : CALL DTMVAL(IVAGR1,1) 1246 : CALL DTMVAL(IVAGR2,1) 1246 : CALL DTMVAL(IVARES,1) 1247 : * 1248 : NOMID=MOGRA1 1249 : if(lsupg1)SEGSUP NOMID 1250 : IF (MOGRA2.NE.MOGRA1) THEN 1251 : NOMID=MOGRA2 1252 : if(lsupg2)SEGSUP NOMID 1253 : ENDIF 1254 : * 1255 : * SEGSUP INFO 1256 : SEGDES IMODEL 1257 : GOTO 200 1258 : * 1259 : * ERREUR DESACTIVATION ET RETOUR 1260 : * 1261 : 5999 CONTINUE 1261 : CALL DTMVAL(IVAGR2,1) 1262 : * 1263 : 5998 CONTINUE 1263 : CALL DTMVAL(IVAGR2,1) 1264 : NOMID=MOGRA1 1265 : if(lsupg1)SEGSUP NOMID 1266 : IF (MOGRA1.NE.MOGRA2) THEN 1267 : NOMID=MOGRA2 1268 : if(lsupg2)SEGSUP NOMID 1269 : ENDIF 1270 : * SEGSUP INFO 1271 : SEGDES IMODEL,MMODEL 1272 : SEGSUP MCHELM 1273 : RETURN 1274 : ENDIF 1275 : * 1276 : 200 CONTINUE 1277 : * 1278 : * FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1 1279 : * DESACTIVATON DES SEGMENTS 1280 : * 1281 : C# A mon avis, ce test devrait etre dans la partie k=3 1282 : C dans les autres cas, je ne suis pas sur que lcomp=1 signifie ERREUR... 1283 : if (lcomp.eq.1) then 1284 : MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)(1:4) 1285 : MOTERR(5:8)='CHAM' 1285 : CALL ERREUR(77) 1286 : C SEGSUP MCHAML,MCHELM,MTRAA 1287 : C SEGDES MCHAM1,MCHAM2 1288 : C GOTO 666 1289 : endif 1290 : 1291 : IF (K.EQ.4.OR.K.EQ.5) THEN 1292 : SEGDES MMODEL 1293 : ELSE 1294 : SEGSUP MTRAA 1295 : ENDIF 1296 : SEGDES MCHELM 1297 : SEGDES MCHEL1,MCHEL2 1298 : RETURN 1299 : * 1300 : 9999 CONTINUE 1301 : SEGDES MCHAM1,MCHAM2 1302 : SEGSUP MCHELM 1303 : SEGSUP MTRAA 1304 : GOTO 666 1305 : * 1306 : 166 CONTINUE 1306 : CALL ERREUR(103) 1307 : 666 CONTINUE 1308 : SEGDES MCHEL1,MCHEL2 1309 : IPCHMU=0 1310 : 1311 : RETURN 1312 : END 1313 : 1314 :
© Cast3M 2003 - All rights reserved.
Disclaimer