1 : C GRAD2 SOURCE CHAT 11/03/16 21:24:24 6902 2 : SUBROUTINE GRAD2(IPMODL,IPCHA1,IPCHE1,IPGRAD,IRET) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : *____________________________________________________________________* 6 : * * 7 : * Sous-programme de l'operateur GRADIENT * 8 : * * 9 : * Entree: * 10 : * * 11 : * IPMODL Pointeur sur un objet MMODEL * 12 : * IPCHA1 Pointeur sur un MCHAML de DEPLACEMENT * 13 : * IPCHE1 Pointeur sur un MCHAML de CARACTERISTIQUES * 14 : * * 15 : * Sortie: * 16 : * * 17 : * IPGRAD Pointeur sur un MCHAML de gradients * 18 : * IRET 1 si succes , 0 sinon * 19 : * * 20 : *____________________________________________________________________* 21 : * 22 : -INC CCOPTIO 23 : -INC CCHAMP 24 : -INC CCGEOME 25 : -INC SMCHAML 26 : -INC SMMODEL 27 : -INC SMELEME 28 : -INC SMINTE 29 : -INC SMCOORD 30 : * 31 : SEGMENT INFO 32 : INTEGER INFELL(JG) 33 : ENDSEGMENT 34 : * 35 : SEGMENT NOTYPE 36 : CHARACTER*16 TYPE(NBTYPE) 37 : ENDSEGMENT 38 : * 39 : SEGMENT MPTVAL 40 : INTEGER IPOS(NS) ,NSOF(NS) 41 : INTEGER IVAL(NCOSOU) 42 : CHARACTER*16 TYVAL(NCOSOU) 43 : ENDSEGMENT 44 : * 45 : SEGMENT WRK1 46 : REAL*8 XDDL(LRN),GRAD(NSTB),AUX(NSTB),XE(3,NBBB) 47 : ENDSEGMENT 48 : * 49 : SEGMENT WRK2 50 : REAL*8 SHPWRK(6,NBNO),BGENE(NSTB,LRE) 51 : ENDSEGMENT 52 : * 53 : SEGMENT WRK3 54 : REAL*8 XGENE(NSTN,LRN) 55 : ENDSEGMENT 56 : * 57 : SEGMENT WRK4 58 : REAL*8 XLOC(IDIM,IDIM),XGLOB(IDIM,IDIM),TXR(IDIM,IDIM) 59 : REAL*8 VALMAT(NMATT) 60 : REAL*8 PMAT(NSTB,NSTB),PMAT1(IDIM,IDIM),PMAT2(IDIM,IDIM) 61 : ENDSEGMENT 62 : * 63 : SEGMENT WRK5 64 : REAL*8 BPSS(3,3),XEL(3,NBBB) 65 : REAL*8 XNTH(LRN,LRN),XNTB(LRN,LRN),XNTT(LRN) 66 : ENDSEGMENT 67 : * 68 : SEGMENT WRK6 69 : REAL*8 PKK(NSTB,NSTB) 70 : ENDSEGMENT 71 : * 72 : CHARACTER*8 CMATE 73 : CHARACTER*(NCONCH) CONM 74 : PARAMETER ( NINF=3 ) 75 : INTEGER INFOS(NINF) 76 : * 77 : IRET = 0 78 : IPGRAD = 0 79 : 80 : NHRM=NIFOUR 81 : MCHAML=0 82 : C 83 : C VERIFICATION DU LIEU SUPPORT DU MCHAML DE MATERIAU 84 : C 85 : ISUP=0 85 : CALL QUESUP(IPMODL,IPCHE1,3,0,ISUP,IRETMA) 86 : IF (ISUP.GT.1) RETURN 87 : C 88 : C ACTIVATION DU MODELE 89 : C 90 : MMODEL=IPMODL 91 : SEGACT MMODEL 92 : NSOUS=KMODEL(/1) 93 : C 94 : KEL22 = 0 95 : DO ISOUS = 1,NSOUS 96 : IMODEL=KMODEL(ISOUS) 97 : SEGACT IMODEL 98 : IF (FORMOD(1).NE.'POREUX') THEN 98 : CALL ERREUR(19) 99 : GOTO 888 100 : ENDIF 101 : IF (NEFMOD.EQ.22) KEL22 = KEL22 + 1 102 : ENDDO 103 : C 104 : C INITIALISATION DU MCHAML RESULTAT 105 : C 106 : N1=NSOUS-KEL22 107 : N3=6 108 : L1=11 109 : SEGINI MCHELM 110 : TITCHE='GRADIENT' 111 : IFOCHE=IFOUR 112 : IPGRAD=MCHELM 113 : C____________________________________________________________________ 114 : C 115 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES 116 : C____________________________________________________________________ 117 : C 118 : isouss=0 119 : DO 500 ISOUS=1,NSOUS 120 : * 121 : * INITIALISATION 122 : * 123 : IVAMAT=0 124 : IVAGRA=0 125 : IVADEP=0 126 : IVACAR=0 127 : NMATR=0 128 : NMATF=0 129 : NGRAD=0 130 : NDEP=0 131 : MOMATR=0 132 : MOGRAD=0 133 : MODEPL=0 134 : C 135 : C ON RECUPERE L INFORMATION GENERALE 136 : C 137 : IMODEL=KMODEL(ISOUS) 138 : SEGACT IMODEL 139 : C 140 : C TRAITEMENT DU MODELE 141 : C 142 : MELE=NEFMOD 143 : if (mele.eq.22) go to 500 144 : C 145 : isouss=isouss+1 146 : MELEME=IMAMOD 147 : IPMAIL=IMAMOD 148 : CONM =CONMOD 149 : IMACHE(ISOUSs)=IPMAIL 150 : CONCHE(ISOUSs)=CONMOD 151 : C 152 : C NATURE DU MATERIAU 153 : C 154 : * NFOR=FORMOD(/2) 155 : * NMAT=MATMOD(/2) 155 : * CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) 156 : CMATE = CMATEE 157 : MATE = IMATEE 158 : MAPL = INATUU 159 : IF (CMATE.EQ.' ')THEN 159 : CALL ERREUR(251) 160 : SEGSUP MCHELM 161 : GOTO 888 162 : ENDIF 163 : C____________________________________________________________________ 164 : C 165 : C INFORMATION SUR L'ELEMENT FINI 166 : C____________________________________________________________________ 167 : C 168 : if(infmod(/1).lt.5) then 168 : CALL ELQUOI(MELE,0,3,IPINF,IMODEL) 169 : IF (IERR.NE.0) THEN 170 : SEGSUP MCHELM 171 : GOTO 888 172 : ENDIF 173 : INFO=IPINF 174 : MFR =INFELL(13) 175 : IELE =INFELL(14) 176 : IPORE=INFELL(8) 177 : MINTE=INFELL(11) 178 : segsup info 179 : else 180 : MFR =INFELE(13) 181 : IELE =INFELE(14) 182 : IPORE=INFELE(8) 183 : MINTE=INFMOD(5) 184 : endif 185 : IPMINT=MINTE 186 : C 187 : C CREATION DU TABLEAU INFOS 188 : C 188 : CALL IDENT(IPMAIL,CONM,IPCHA1,IPCHE1,INFOS,IRTD) 189 : IF (IRTD.EQ.0) GOTO 9990 190 : C 191 : INFCHE(ISOUSs,1)=0 192 : INFCHE(ISOUSs,2)=0 193 : INFCHE(ISOUSs,3)=NHRM 194 : INFCHE(ISOUSs,4)=MINTE 195 : INFCHE(ISOUSs,5)=0 196 : INFCHE(ISOUSs,6)=3 197 : C 198 : C ACTIVATIONS 199 : C 200 : SEGACT MINTE 201 : NBPGAU=POIGAU(/1) 202 : 203 : SEGACT MELEME 204 : NBNN =NUM(/1) 205 : NBELEM=NUM(/2) 206 : 207 : C____________________________________________________________________ 208 : C 209 : C RECHERCHE DES COMPOSANTES DE DEPLACEMENTS 210 : C____________________________________________________________________ 211 : C 212 : NBROBL=0 213 : NBRFAC=0 214 : IPPORE=0 215 : * 216 : IF(MFR.EQ.33) THEN 217 : IPPORE=NBNN 218 : NBROBL=1 219 : SEGINI NOMID 220 : LESOBL(1)='P ' 221 : ELSE IF(MFR.EQ.57) THEN 222 : IPPORE=NBNN 223 : NBROBL=2 224 : SEGINI NOMID 225 : LESOBL(1)='P ' 226 : LESOBL(2)='PQ ' 227 : ELSE IF(MFR.EQ.59) THEN 228 : IPPORE=NBNN 229 : NBROBL=3 230 : SEGINI NOMID 231 : LESOBL(1)='P ' 232 : LESOBL(2)='PQ ' 233 : LESOBL(3)='TP ' 234 : ENDIF 235 : IDECAP=NBROBL 236 : 237 : NDEP=NBROBL 238 : MODEPL = NOMID 239 : C 240 : NBTYPE=1 241 : SEGINI NOTYPE 242 : MOTYPE=NOTYPE 243 : TYPE(1)='REAL*8' 243 : CALL KOMCHA(IPCHA1,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP) 244 : SEGSUP NOTYPE 245 : IF (IERR.NE.0) GOTO 9990 246 : 247 : C____________________________________________________________________ 248 : C 249 : C RECHERCHE DES COMPOSANTES DE MATERIAU 250 : C____________________________________________________________________ 251 : C 252 : NBROBL=0 253 : NBRFAC=0 254 : * cas isotrope 255 : IF (MATE.EQ.1) THEN 256 : * 257 : IF (MELE.GE.79.AND.MELE.LE.83) THEN 258 : NBROBL=2 259 : SEGINI NOMID 260 : LESOBL(1)='PERM' 261 : LESOBL(2)='VISC' 262 : ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN 263 : NBROBL=4 264 : SEGINI NOMID 265 : LESOBL(1)='PERH' 266 : LESOBL(2)='PERB' 267 : LESOBL(3)='PERT' 268 : LESOBL(4)='VISC' 269 : ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN 270 : NBROBL=4 271 : SEGINI NOMID 272 : LESOBL(1)='PK11' 273 : LESOBL(2)='PK12' 274 : LESOBL(3)='PK21' 275 : LESOBL(4)='PK22' 276 : ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN 277 : NBROBL=9 278 : SEGINI NOMID 279 : LESOBL(1)='PK11' 280 : LESOBL(2)='PK12' 281 : LESOBL(3)='PK13' 282 : LESOBL(4)='PK21' 283 : LESOBL(5)='PK22' 284 : LESOBL(6)='PK23' 285 : LESOBL(7)='PK31' 286 : LESOBL(8)='PK32' 287 : LESOBL(9)='PK33' 288 : ENDIF 289 : * cas orthotrope 290 : ELSE IF (MATE.EQ.2) THEN 291 : IF (IDIM.EQ.3) THEN 292 : NBROBL=10 293 : SEGINI NOMID 294 : LESOBL(1)='PER1' 295 : LESOBL(2)='PER2' 296 : LESOBL(3)='PER3' 297 : LESOBL(4)='VISC' 298 : LESOBL(5)='V1X ' 299 : LESOBL(6)='V1Y ' 300 : LESOBL(7)='V1Z ' 301 : LESOBL(8)='V2X ' 302 : LESOBL(9)='V2Y ' 303 : LESOBL(10)='V2Z ' 304 : ELSE IF(IDIM.EQ.2) THEN 305 : IF (IFOUR.LE.0) THEN 306 : NBROBL=5 307 : SEGINI NOMID 308 : LESOBL(1)='PER1' 309 : LESOBL(2)='PER2' 310 : LESOBL(3)='VISC' 311 : LESOBL(4)='V1X ' 312 : LESOBL(5)='V1Y ' 313 : ELSE IF (IFOUR.EQ.1) THEN 314 : NBROBL=6 315 : SEGINI NOMID 316 : LESOBL(1)='PER1' 317 : LESOBL(2)='PER2' 318 : LESOBL(3)='PER3' 319 : LESOBL(4)='VISC' 320 : LESOBL(5)='V1X ' 321 : LESOBL(6)='V1Y ' 322 : ENDIF 323 : ENDIF 324 : * cas anisotrope 325 : ELSE IF (MATE.EQ.3)THEN 326 : IF(IDIM.EQ.3)THEN 327 : NBROBL=13 328 : SEGINI NOMID 329 : LESOBL(1)='PER1' 330 : LESOBL(2)='PER2' 331 : LESOBL(3)='PER3' 332 : LESOBL(4)='PE12' 333 : LESOBL(5)='PE13' 334 : LESOBL(6)='PE23' 335 : LESOBL(7)='VISC' 336 : LESOBL(8)='V1X ' 337 : LESOBL(9)='V1Y ' 338 : LESOBL(10)='V1Z ' 339 : LESOBL(11)='V2X ' 340 : LESOBL(12)='V2Y ' 341 : LESOBL(13)='V2Z ' 342 : ELSE IF (IDIM.EQ.2) THEN 343 : IF (IFOUR.LE.0) THEN 344 : NBROBL=6 345 : SEGINI NOMID 346 : LESOBL(1)='PER1' 347 : LESOBL(2)='PER2' 348 : LESOBL(3)='PE12' 349 : LESOBL(4)='VISC' 350 : LESOBL(5)='V1X ' 351 : LESOBL(6)='V1Y ' 352 : ELSE IF (IFOUR.EQ.1) THEN 353 : NBROBL=7 354 : SEGINI NOMID 355 : LESOBL(1)='PER1' 356 : LESOBL(2)='PER2' 357 : LESOBL(3)='PE12' 358 : LESOBL(4)='PER3' 359 : LESOBL(5)='VISC' 360 : LESOBL(6)='V1X ' 361 : LESOBL(7)='V1Y ' 362 : ENDIF 363 : ENDIF 364 : * cas unidirectionnel 365 : ELSE IF (MATE.EQ.4) THEN 366 : IF (IDIM.EQ.3) THEN 367 : NBROBL=8 368 : SEGINI NOMID 369 : LESOBL(1)='PERM' 370 : LESOBL(2)='VISC' 371 : LESOBL(3)='V1X ' 372 : LESOBL(4)='V1Y ' 373 : LESOBL(5)='V1Z ' 374 : LESOBL(6)='V2X ' 375 : LESOBL(7)='V2Y ' 376 : LESOBL(8)='V2Z ' 377 : ELSE 378 : NBROBL=4 379 : SEGINI NOMID 380 : LESOBL(1)='PERM' 381 : LESOBL(2)='VISC' 382 : LESOBL(3)='V1X ' 383 : LESOBL(4)='V1Y ' 384 : ENDIF 385 : ENDIF 386 : * 387 : NMATR=NBROBL 388 : NMATF=NBRFAC 389 : NMATT = NMATR+NMATF 390 : MOMATR=NOMID 391 : * 392 : NBTYPE=1 393 : SEGINI NOTYPE 394 : MOTYPE=NOTYPE 395 : TYPE(1)='REAL*8' 395 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) 396 : SEGSUP NOTYPE 397 : IF (IERR.NE.0) GOTO 9990 398 : IF (ISUP.EQ.1) THEN 398 : CALL VALCHE(IVAMAT,NMATR,IPMINT,IPPORE) 399 : ENDIF 400 : * 401 : *_______________________________________________________________________ 402 : * 403 : * COMPOSANTES EN SORTIE 404 : *_______________________________________________________________________ 405 : * 406 : * CAS JOINTS 407 : * 408 : IF((MELE.GE.108.AND.MELE.LE.110).OR. 409 : . (MELE.GE.185.AND.MELE.LE.190)) THEN 410 : 411 : IF(IFOUR.LE.0) THEN 412 : * CAS PLAN 413 : NCOVEC=3 414 : ELSE IF (IFOUR.EQ.2) THEN 415 : * 3D 416 : NCOVEC=4 417 : ENDIF 418 : ELSE 419 : 420 : IF(IFOUR.LE.0) THEN 421 : * CONTRAINTES PLANES - DEFORMATIONS PLANES 422 : * DEFO PLAN GENE 423 : * AXISYMETRIQUE 424 : NCOVEC=2 425 : 426 : ELSE IF (IFOUR.GT.0) THEN 427 : * FOURIER 428 : * 3D 429 : NCOVEC=3 430 : ENDIF 431 : 432 : ENDIF 433 : * 434 : NBROBL=NCOVEC*IDECAP 435 : NBRFAC=0 436 : NGRAD=NBROBL 437 : SEGINI NOMID 438 : MOGRAD=NOMID 439 : 440 : IF((MELE.GE.108.AND.MELE.LE.110).OR. 441 : . (MELE.GE.185.AND.MELE.LE.190)) THEN 442 : 443 : DO 121 IPR=1,IDECAP 444 : IPRDEC = (IPR-1)*NCOVEC 445 : IF(IPR.EQ.1) THEN 446 : LESOBL(IPRDEC+1)='VCPH' 447 : LESOBL(IPRDEC+2)='VCPB' 448 : LESOBL(IPRDEC+3)='VCP1' 449 : IF(NCOVEC.EQ.4) LESOBL(IPRDEC+4)='VCP2' 450 : ELSE IF(IPR.EQ.2) THEN 451 : LESOBL(IPRDEC+1)='VCQT' 452 : LESOBL(IPRDEC+2)='VCQB' 453 : LESOBL(IPRDEC+3)='VCQ1' 454 : IF(NCOVEC.EQ.4) LESOBL(IPRDEC+4)='VCQ2' 455 : ELSE IF(IPR.EQ.3) THEN 456 : LESOBL(IPRDEC+1)='VCTT' 457 : LESOBL(IPRDEC+2)='VCTB' 458 : LESOBL(IPRDEC+3)='VCT1' 459 : IF(NCOVEC.EQ.4) LESOBL(IPRDEC+4)='VCT2' 460 : ENDIF 461 : 121 CONTINUE 462 : 463 : ELSE 464 : DO 120 IPR=1,IDECAP 465 : IPRDEC = (IPR-1)*NCOVEC 466 : IF(IPR.EQ.1) THEN 467 : LESOBL(IPRDEC+1)='VCP1' 468 : LESOBL(IPRDEC+2)='VCP2' 469 : IF(NCOVEC.EQ.3) LESOBL(IPRDEC+3)='VCP3' 470 : ELSE IF(IPR.EQ.2) THEN 471 : LESOBL(IPRDEC+1)='VCQ1' 472 : LESOBL(IPRDEC+2)='VCQ2' 473 : IF(NCOVEC.EQ.3) LESOBL(IPRDEC+3)='VCQ3' 474 : ELSE IF(IPR.EQ.3) THEN 475 : LESOBL(IPRDEC+1)='VCT1' 476 : LESOBL(IPRDEC+2)='VCT2' 477 : IF(NCOVEC.EQ.3) LESOBL(IPRDEC+3)='VCT3' 478 : ENDIF 479 : 120 CONTINUE 480 : 481 : ENDIF 482 : * 483 : * SEGDES NOMID 484 : *_______________________________________________________________________ 485 : * 486 : * CREATION DU MCHAML DE LA SOUS ZONE 487 : *_______________________________________________________________________ 488 : * 489 : N1PTEL=NBPGAU 490 : N1EL=NBELEM 491 : NBPTEL=N1PTEL 492 : NEL=N1EL 493 : N2=NGRAD 494 : * 495 : SEGINI MCHAML 496 : ICHAML(ISOUSs)=MCHAML 497 : NS=1 498 : NCOSOU=NGRAD 499 : SEGINI MPTVAL 500 : IVAGRA=MPTVAL 501 : NOMID=MOGRAD 502 : SEGACT NOMID 503 : DO 100 ICOMP=1,NGRAD 504 : NOMCHE(ICOMP)=LESOBL(ICOMP) 505 : TYPCHE(ICOMP)='REAL*8' 506 : N2PTEL=0 507 : N2EL=0 508 : SEGINI MELVAL 509 : IELVAL(ICOMP)=MELVAL 510 : IVAL(ICOMP)=MELVAL 511 : 100 CONTINUE 512 : * 513 : IF(MELE.GE.79.AND.MELE.LE.83) GO TO 79 514 : IF(MELE.GE.173.AND.MELE.LE.182) GO TO 79 515 : IF(MELE.GE.108.AND.MELE.LE.110) GO TO 80 516 : * 517 : GOTO 99 518 : * 519 : C_______________________________________________________________________ 520 : C 521 : C MILIEUX POREUX 522 : C_______________________________________________________________________ 523 : C 524 : 79 CONTINUE 525 : C 526 : C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS 527 : C NBNO = NOMBRE DE FONCTIONS DE FORME 528 : C 529 : DIM3=1.D0 530 : NBNO=IPORE 531 : NBBB=NBNN 532 : 533 : LPP=NBNO-NBBB 534 : LRN =IDECAP*LPP 535 : LRE=NBNN*IDECAP 536 : NSTBE=2 537 : IF(IFOUR.GT.0) NSTBE=3 538 : NSTB=NSTBE*IDECAP 539 : NSTN=1 540 : 541 : * CAS NON ISOTROPES 542 : * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES 543 : * AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX 544 : * 545 : IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN 545 : CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1) 546 : MINTE2=IPMIN2 547 : SEGACT MINTE2 548 : SEGINI WRK4 549 : ENDIF 550 : * 551 : SEGINI WRK1,WRK2,WRK3,WRK6 552 : I195=0 553 : I259=0 554 : I367=0 555 : C 556 : DO 3079 IB=1,NBELEM 557 : C 558 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 559 : C 559 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 560 : C 561 : C ON RECUPERE LES DEPLACEMENTS 562 : C 563 : MPTVAL=IVADEP 564 : NCOSOU=IVAL(/1) 565 : IE=1 566 : DO 8079 I=1,NCOSOU 567 : MELVAL=IVAL(I) 568 : DO 8079 IGAU=1,LPP 569 : IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1) 570 : IGMN=MIN(IGAUSO,VELCHE(/1)) 571 : IBMN=MIN(IB ,VELCHE(/2)) 572 : XDDL(IE)=VELCHE(IGMN,IBMN) 573 : IE=IE+1 574 : 8079 CONTINUE 575 : 576 : * WRITE(6,44551) (XDDL(I),I=1,LRN) 577 : *44551 FORMAT(2X,'XDDL'/(4(1X,1PE12.5)/)) 578 : * 579 : * CALCUL DES AXES LOCAUX DANS LES CAS NON ISOTROPES 580 : * 581 : IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN 582 : NBSH=MINTE2.SHPTOT(/2) 582 : CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) 583 : IF (NBSH.EQ.-1) THEN 583 : CALL ERREUR(525) 584 : RETURN 585 : ENDIF 586 : ENDIF 587 : 588 : C 589 : C BOUCLE SUR LES POINTS DE GAUSS 590 : C 591 : ISDJC=0 592 : 593 : DO 5079 IGAU=1,NBPGAU 594 : C 595 : C RECUPERATION DE L'EPAISSEUR 596 : C 597 : IF (IFOUR.EQ.-2)THEN 598 : MPTVAL=IVACAR 599 : IF (IVACAR.NE.0) THEN 600 : MELVAL=IVAL(1) 601 : IF (MELVAL.NE.0) THEN 602 : IGMN=MIN(IGAU,VELCHE(/1)) 603 : IBMN=MIN(IB,VELCHE(/2)) 604 : DIM3=VELCHE(IGMN,IBMN) 605 : ELSE 606 : DIM3=1.D0 607 : ENDIF 608 : ENDIF 609 : ENDIF 610 : C 610 : CALL BNQORE(IGAU,NBNO,NBNN,LRE,IFOUR,NSTB,NSTN,NHRM,DIM3, 611 : . XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,2) 612 : 613 : * IF(IGAU.EQ.1) THEN 614 : * PRINT *,' MATRICE B LIGNE PAR LIGNE ' 615 : * DO 3367 IPZ = 1,NSTB 616 : * PRINT *,' LIGNE ',IPZ 617 : * WRITE(6,3368) (BGENE(IPZ,JPZ), JPZ=1,LRE) 618 : *3368 FORMAT(8(1X,1PE10.3)/) 619 : *3367 CONTINUE 620 : * ENDIF 621 : 622 : IF(DJAC.LT.0.D0) ISDJC=ISDJC+1 623 : IF(DJAC.EQ.0.D0) I259=IB 624 : C 625 : C ON RECUPERE LE MATERIAU 626 : C 627 : EREF=1.D0 628 : MPTVAL=IVAMAT 628 : CALL ZERO (PKK,NSTB,NSTB) 629 : * 630 : * le cas isotrope 631 : * 632 : IF (MATE.EQ.1) THEN 633 : 634 : IF(MFR.EQ.33) THEN 635 : 636 : MELVAL=IVAL(1) 637 : IGMN=MIN(IGAU,VELCHE(/1)) 638 : IBMN=MIN(IB ,VELCHE(/2)) 639 : XK =VELCHE(IGMN,IBMN) 640 : * 641 : MELVAL=IVAL(2) 642 : IGMN=MIN(IGAU,VELCHE(/1)) 643 : IBMN=MIN(IB ,VELCHE(/2)) 644 : XMU =VELCHE(IGMN,IBMN) 645 : IF(XMU.EQ.0.D0) THEN 646 : I367=IB 647 : GO TO 5079 648 : ENDIF 649 : COMJAC=EREF*EREF*XK/XMU 650 : DO 1729 I=1,NSTB 651 : PKK(I,I)=COMJAC 652 : 1729 CONTINUE 653 : 654 : ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN 655 : 656 : ICO=1 657 : IDECA2=IDECAP*IDECAP 658 : DO 1731 ICD = 1,IDECAP 659 : ICDA =(ICD -1) * NSTBE 660 : DO 1732 JCD = 1,IDECAP 661 : JCDA =(JCD -1) * NSTBE 662 : MELVAL=IVAL(ICO) 663 : IGMN=MIN(IGAU,VELCHE(/1)) 664 : IBMN=MIN(IB ,VELCHE(/2)) 665 : DO 1733 KCD = 1,NSTBE 666 : PKK(ICDA+KCD,JCDA+KCD) =VELCHE(IGMN,IBMN) 667 : 1733 CONTINUE 668 : ICO=ICO+1 669 : 1732 CONTINUE 670 : 1731 CONTINUE 671 : ENDIF 672 : * 673 : * IF(IGAU . EQ . 1 ) THEN 674 : * PRINT *,' MATRICE PKK' 675 : * 676 : * IF (IDECAP.EQ.1) THEN 677 : * WRITE (6,1341) ((PKK(I,J),J=1,NSTB),I=1,NSTB) 678 : *1341 FORMAT(2(1X,1PE12.5)/) 679 : * 680 : * ELSE IF (IDECAP.EQ.2) THEN 681 : * WRITE (6,1342) ((PKK(I,J),J=1,NSTB),I=1,NSTB) 682 : *1342 FORMAT(4(1X,1PE12.5)/) 683 : * 684 : * ELSE IF (IDECAP.EQ.3) THEN 685 : * WRITE (6,1343) ((PKK(I,J),J=1,NSTB),I=1,NSTB) 686 : *1343 FORMAT(6(1X,1PE12.5)/) 687 : * ENDIF 688 : * ENDIF 689 : * 690 : * les cas non isotropes 691 : * 692 : ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN 693 : * 694 : IF(MFR.EQ.33) THEN 695 : 696 : DO 4379 IM=1,NMATT 697 : IF (IVAL(IM).NE.0) THEN 698 : MELVAL=IVAL(IM) 699 : IBMN=MIN(IB ,VELCHE(/2)) 700 : IGMN=MIN(IGAU,VELCHE(/1)) 701 : VALMAT(IM)=VELCHE(IGMN,IBMN) 702 : ELSE 703 : VALMAT(IM)=0.D0 704 : ENDIF 705 : 4379 CONTINUE 706 : * 706 : CALL PERMAO(WRK4,IFOUR,MATE,EREF,KERRE) 707 : IF(KERRE.EQ.1) GO TO 99 708 : IF(KERRE.EQ.2) THEN 709 : I367=IB 710 : GO TO 5079 711 : ENDIF 712 : * 713 : * REMPLISSAGE POUR CAS MFR=33 UNIQUEMENT 714 : * 715 : DO 4479 I=1,NSTBE 716 : DO 4479 J=1,NSTBE 717 : PKK(I,J)=PMAT(I,J) 718 : 4479 CONTINUE 719 : 720 : * IF(IGAU . EQ . 1 ) THEN 721 : * 722 : * PRINT *,' MATRICE PKK' 723 : * IF(NSTBE.EQ.3) THEN 724 : * WRITE (6,1441) ((PKK(I,J),J=1,NSTB),I=1,NSTB) 725 : *1441 FORMAT(3(1X,1PE12.5)/) 726 : * ELSE 727 : * WRITE (6,1341) ((PKK(I,J),J=1,NSTB),I=1,NSTB) 728 : * ENDIF 729 : * ENDIF 730 : * 731 : ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN 732 : * 733 : * CAS NON PREVU 734 : GO TO 99 735 : ENDIF 736 : * 737 : * les cas non prévus 738 : * 739 : ELSE 740 : GO TO 99 741 : ENDIF 742 : * 743 : * CALCUL DES GRADIENTS 744 : * 745 : DO 9179 IPR=1,IDECAP 746 : LPPDEC=(IPR-1)*LPP 747 : NSTDEC=(IPR-1)*NSTBE 748 : NBBDEC=(IPR-1)*NBBB 749 : DO 9079 I=1,NSTBE 750 : AUX(I+NSTDEC)=0.D0 751 : DO 9079 J=1,LPP 752 : AUX(I+NSTDEC)= AUX(I+NSTDEC) + 753 : . BGENE(I+NSTDEC,J+NBBDEC)*XDDL(J+LPPDEC) 754 : 9079 CONTINUE 755 : 9179 CONTINUE 756 : 757 : * IF(IGAU.EQ.1) THEN 758 : * WRITE(6,44552) (AUX (I),I=1,NSTB) 759 : *44552 FORMAT(2X,'AUX '/(4(1X,1PE12.5)/)) 760 : * ENDIF 761 : * 762 : DO 9279 I=1,NSTB 763 : GRAD(I)=0.D0 764 : DO 9279 J=1,NSTB 765 : GRAD(I)=GRAD(I)+PKK(I,J)*AUX(J) 766 : 9279 CONTINUE 767 : 768 : * IF(IGAU.EQ.1) THEN 769 : * WRITE(6,44553) (GRAD (I),I=1,NSTB) 770 : *44553 FORMAT(2X,'GRAD '/(4(1X,1PE12.5)/)) 771 : * ENDIF 772 : C 773 : C REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS 774 : C 775 : MPTVAL=IVAGRA 776 : DO 4179 I=1,NSTB 777 : MELVAL=IVAL(I) 778 : VELCHE(IGAU,IB)=GRAD(I) 779 : 4179 CONTINUE 780 : 781 : 5079 CONTINUE 782 : * 783 : IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB 784 : C 785 : 3079 CONTINUE 786 : 787 : SEGSUP WRK1,WRK2,WRK3 788 : IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN 789 : SEGDES MINTE2 790 : SEGSUP WRK4 791 : ENDIF 792 : * 793 : IF(I195.NE.0) THEN 794 : INTERR(1)=I195 794 : CALL ERREUR(195) 795 : GOTO 9990 796 : ELSE IF(I259.NE.0) THEN 797 : INTERR(1)=I259 797 : CALL ERREUR(259) 798 : GOTO 9990 799 : ELSE IF(I367.NE.0) THEN 800 : INTERR(1)=I367 800 : CALL ERREUR(367) 801 : GOTO 9990 802 : ENDIF 803 : * 804 : GOTO 9990 805 : C 806 : C_______________________________________________________________________ 807 : C 808 : C JOINTS POREUX 809 : C_______________________________________________________________________ 810 : C 811 : 80 CONTINUE 812 : C 813 : C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS 814 : C NBNO = NOMBRE DE FONCTIONS DE FORME 815 : C 816 : C ON GARDE LE IDECAP MAIS IL VAUT 1 ( AUTRES VALEURS : A VOIR ) 817 : C 818 : DIM3=1.D0 819 : NBNO=IPORE 820 : NBBB=NBNN 821 : LPP=(NBNO-NBBB)*3/2 822 : LRN =LPP*IDECAP 823 : LRE=LRN 824 : NSTBE=3 825 : IF(IFOUR.EQ.2) NSTBE=4 826 : NSTB=NSTBE*IDECAP 827 : NSTN=1 828 : NMIL=LRN-NBSOM(IELE) 829 : 830 : * PRINT *,'NSTBE=',NSTBE 831 : * PRINT *,'NSTB=',NSTB 832 : * PRINT *,'IDECAP=',IDECAP 833 : * PRINT *,'LPP =',LPP 834 : * PRINT *,'LRN =',LRN 835 : * PRINT *,'LRE =',LRE 836 : * PRINT *,'NBNO =',NBNO 837 : * PRINT *,'NBBB =',NBBB 838 : * PRINT *,'NSTN =',NSTN 839 : * PRINT *,'IFOUR =',IFOUR 840 : * PRINT *,'NMIL =',NMIL 841 : 842 : SEGINI WRK1,WRK2,WRK3,WRK5,WRK6 843 : I195=0 844 : I259=0 845 : I367=0 846 : C 847 : DO 3080 IB=1,NBELEM 848 : C 849 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 850 : C 850 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 851 : C 852 : C ON RECUPERE LES DEPLACEMENTS 853 : C 854 : MPTVAL=IVADEP 855 : NCOSOU=IVAL(/1) 856 : IE=1 857 : 858 : * PRINT *,' NBSOM(IELE) =', NBSOM(IELE) 859 : * PRINT *,' LPP = ', LPP 860 : * PRINT *,' NCOSOU = ', NCOSOU 861 : 862 : IE=0 863 : DO 8080 I=1,NCOSOU 864 : MELVAL=IVAL(I) 865 : DO 8180 IGAU=1,NBSOM(IELE) 866 : IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1) 867 : IGMN=MIN(IGAUSO,VELCHE(/1)) 868 : IBMN=MIN(IB ,VELCHE(/2)) 869 : IE=IE+1 870 : XDDL(IE)=VELCHE(IGMN,IBMN) 871 : 8180 CONTINUE 872 : * 873 : DO 8280 IGAU=1,NMIL 874 : IE=IE+1 875 : IGAUSO=NBBB - NMIL + IGAU 876 : IGMN=MIN(IGAUSO,VELCHE(/1)) 877 : IBMN=MIN(IB ,VELCHE(/2)) 878 : XDDL(IE)=VELCHE(IGMN,IBMN) 879 : 8280 CONTINUE 880 : 8080 CONTINUE 881 : 882 : * WRITE(6,48551) (XDDL(I),I=1,LRN) 883 : *48551 FORMAT(2X,'XDDL'/(4(1X,1PE12.5)/)) 884 : 885 : C 886 : C CALCUL DES AXES LOCAUX ET DES COORDONNEES LOCALES 887 : C 887 : CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS) 888 : 889 : * PRINT *, 'MATRICE BPSS ' 890 : * WRITE(6,67564) ((BPSS(I,J),J=1,3),I=1,3) 891 : *67564 FORMAT(2X,3(1X,1PE12.5)/) 892 : 893 : C 894 : C BOUCLE SUR LES POINTS DE GAUSS 895 : C 896 : ISDJC=0 897 : DO 5080 IGAU=1,NBPGAU 898 : C 899 : C RECUPERATION DE L'EPAISSEUR 900 : C 901 : * IF (IFOUR.EQ.-2)THEN 902 : * MPTVAL=IVACAR 903 : * IF (IVACAR.NE.0) THEN 904 : * MELVAL=IVAL(1) 905 : * IF (MELVAL.NE.0) THEN 906 : * IGMN=MIN(IGAU,VELCHE(/1)) 907 : * IBMN=MIN(IB,VELCHE(/2)) 908 : * DIM3=VELCHE(IGMN,IBMN) 909 : * ELSE 910 : * DIM3=1.D0 911 : * ENDIF 912 : * ENDIF 913 : * ENDIF 914 : C 914 : CALL BNQORJ(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,XE,XEL, 915 : . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1) 916 : 917 : * IF(IGAU.EQ.1) THEN 918 : * PRINT *,' MATRICE B LIGNE PAR LIGNE ' 919 : * DO 3867 IPZ = 1,NSTB 920 : * PRINT *,' LIGNE ',IPZ 921 : * WRITE(6,3868) (BGENE(IPZ,JPZ), JPZ=1,LRE) 922 : *3868 FORMAT(8(1X,1PE10.3)/) 923 : *3867 CONTINUE 924 : * ENDIF 925 : 926 : IF(DJAC.LT.0.D0) ISDJC=ISDJC+1 927 : IF(DJAC.EQ.0.D0) I259=IB 928 : C 929 : C ON RECUPERE LE MATERIAU 930 : C 931 : EREF=1.D0 932 : MPTVAL=IVAMAT 933 : * 934 : * le cas isotrope (le seul) 935 : * 936 : MELVAL=IVAL(4) 937 : IGMN=MIN(IGAU,VELCHE(/1)) 938 : IBMN=MIN(IB ,VELCHE(/2)) 939 : XMU =VELCHE(IGMN,IBMN) 940 : IF(XMU.EQ.0.D0) THEN 941 : I367=IB 942 : GO TO 5080 943 : ENDIF 944 : * 945 : FAC = EREF*EREF/XMU 946 : * H 947 : MELVAL=IVAL(1) 948 : IGMN=MIN(IGAU,VELCHE(/1)) 949 : IBMN=MIN(IB ,VELCHE(/2)) 950 : PKK(1,1)=VELCHE(IGMN,IBMN)*FAC 951 : * B 952 : MELVAL=IVAL(2) 953 : IGMN=MIN(IGAU,VELCHE(/1)) 954 : IBMN=MIN(IB ,VELCHE(/2)) 955 : PKK(2,2)=VELCHE(IGMN,IBMN)*FAC 956 : * T 957 : MELVAL=IVAL(3) 958 : IGMN=MIN(IGAU,VELCHE(/1)) 959 : IBMN=MIN(IB ,VELCHE(/2)) 960 : PKK(3,3)=VELCHE(IGMN,IBMN)*FAC 961 : IF(NSTBE.EQ.4) THEN 962 : PKK(4,4) = PKK(3,3) 963 : ENDIF 964 : * 965 : * CALCUL DES GRADIENTS 966 : * 967 : *ZZZZ A VOIR : REMPLISSAGE DE BGENE ET XDDL 968 : DO 9180 IPR=1,IDECAP 969 : LPPDEC=(IPR-1)*LPP 970 : NSTDEC=(IPR-1)*NSTBE 971 : NBBDEC=(IPR-1)*NBBB 972 : DO 9080 I=1,NSTBE 973 : r_z = 0.D0 974 : DO 9081 J=1,LPP 975 : r_z = r_z + BGENE(I+NSTDEC,J+NBBDEC)*XDDL(J+LPPDEC) 976 : 9081 CONTINUE 977 : AUX(I+NSTDEC)=r_z 978 : 9080 CONTINUE 979 : 9180 CONTINUE 980 : * 981 : * IF(IGAU.EQ.1) THEN 982 : * WRITE(6,48552) (AUX (I),I=1,NSTB) 983 : *48552 FORMAT(2X,'AUX '/(4(1X,1PE12.5)/)) 984 : * WRITE(6,48652) (PKK (I,I),I=1,NSTB) 985 : *48652 FORMAT(2X,'PKK '/(4(1X,1PE12.5)/)) 986 : * ENDIF 987 : * 988 : DO 9280 I=1,NSTB 989 : GRAD(I)=PKK(I,I)*AUX(I) 990 : 9280 CONTINUE 991 : 992 : * IF(IGAU.EQ.1) THEN 993 : * WRITE(6,48553) (GRAD (I),I=1,NSTB) 994 : *48553 FORMAT(2X,'GRAD '/(4(1X,1PE12.5)/)) 995 : * ENDIF 996 : C 997 : C REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS 998 : C 999 : MPTVAL=IVAGRA 1000 : DO 4180 I=1,NSTB 1001 : MELVAL=IVAL(I) 1002 : VELCHE(IGAU,IB)=GRAD(I) 1003 : 4180 CONTINUE 1004 : * 1005 : 5080 CONTINUE 1006 : * 1007 : IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB 1008 : * 1009 : 3080 CONTINUE 1010 : 1011 : SEGSUP WRK1,WRK2,WRK3,WRK5,WRK6 1012 : * 1013 : IF(I195.NE.0) THEN 1014 : INTERR(1)=I195 1014 : CALL ERREUR(195) 1015 : GOTO 9990 1016 : ELSE IF(I259.NE.0) THEN 1017 : INTERR(1)=I259 1017 : CALL ERREUR(259) 1018 : GOTO 9990 1019 : ELSE IF(I367.NE.0) THEN 1020 : INTERR(1)=I367 1020 : CALL ERREUR(367) 1021 : GOTO 9990 1022 : ENDIF 1023 : * 1024 : GOTO 9990 1025 : * 1026 : 99 CONTINUE 1027 : MOTERR(1:4)=NOMTP(MELE) 1028 : MOTERR(9:12)='GRAD' 1028 : CALL ERREUR(86) 1029 : C 1030 : C____________________________________________________________________ 1031 : C 1032 : C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS 1033 : C____________________________________________________________________ 1034 : C 1035 : 9990 CONTINUE 1036 : SEGDES MELEME 1037 : * 1037 : CALL DTMVAL(IVADEP,1) 1037 : CALL DTMVAL(IVAMAT,1) 1037 : CALL DTMVAL(IVAGRA,1) 1038 : * 1039 : IF(IERR.NE.0)THEN 1040 : IF (MCHAML.NE.0) SEGSUP MCHAML 1041 : ELSE 1042 : SEGDES MCHAML 1043 : ENDIF 1044 : * 1045 : IF(MOMATR.NE.0)THEN 1046 : NOMID=MOMATR 1047 : SEGSUP NOMID 1048 : ENDIF 1049 : * 1050 : IF(MOGRAD.NE.0)THEN 1051 : NOMID=MOGRAD 1052 : SEGSUP NOMID 1053 : ENDIF 1054 : * 1055 : IF(MODEPL.NE.0)THEN 1056 : NOMID=MODEPL 1057 : SEGSUP NOMID 1058 : ENDIF 1059 : * 1060 : SEGDES MINTE 1061 : C 1062 : C DANS LE CAS D'ERREUR 1063 : C 1064 : IF(IERR.NE.0) GOTO 888 1065 : * 1066 : 500 CONTINUE 1067 : * Fin normale 1068 : IRET = 1 1069 : * 1070 : if(n1.ne.isouss) then 1071 : n1=isouss 1072 : segadj mchelm 1073 : endif 1074 : SEGDES,MCHELM 1075 : 1076 : 888 CONTINUE 1077 : DO ISOUS = 1,NSOUS 1078 : IMODEL=KMODEL(ISOUS) 1079 : SEGDES,IMODEL 1080 : ENDDO 1081 : SEGDES,MMODEL 1082 : * 1083 : RETURN 1084 : END 1085 : 1086 : 1087 :
© Cast3M 2003 - All rights reserved.
Disclaimer