1 : C RIGI2 SOURCE AM 14/02/06 21:15:02 7945 2 : SUBROUTINE RIGI2(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS, 3 : & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT, 4 : & IPORE,NDDL,IPMATR,IIPDPG,NCAR1) 5 : *---------------------------------------------------------------------* 6 : * __________________________ * 7 : * | | * 8 : * | CALCUL DE LA RIGIDITE | * 9 : * |________________________| * 10 : * * 11 : * massif, liquide, 'surface libre', poreux et joints poreux, * 12 : * incompressible * 13 : * * 14 : *---------------------------------------------------------------------* 15 : * * 16 : * ENTREES : * 17 : * ________ * 18 : * * 19 : * MATE Numero du materiau * 20 : * MELE Numero de l'element fini * 21 : * IPMAIL Pointeur sur un segment MELEME * 22 : * IPMINT Pointeur sur un segment MINTE * 23 : * NBPGAU Nombre de point d'integration pour la rigidite * 24 : * LRE Nombre de ddl dans la matrice de rigidite * 25 : * NSTRS Nombre de composante de contraintes/deformations * 26 : * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou * 27 : * pour une matrice de hooke * 28 : * IVACAR Pointeur sur un segment MPTVAL de caractéristiques * 29 : * CMATE Nom du materiau * 30 : * MFR Numero de la formulation element fini * 31 : * NBGMAT Taille maxi des melval du materiau (pt de gauss) * 32 : * NELMAT Taille maxi des melval du materiau (No d'element) * 33 : * IMAT (2 il y a une matrice de HOOKE,1 non ) * 34 : * NMATT Nombre de composante de materiau (IMAT=1) * 35 : * LHOOK Dimension de la matrice de Hooke * 36 : * IPORE Nombre de fonctions de forme * 37 : * NDDL Nombre de degre de liberte * 38 : * * 39 : * SORTIES : * 40 : * ________ * 41 : * * 42 : * IPMATR pointeur sur la rigidite de la sous-zone * 43 : * * 44 : *---------------------------------------------------------------------* 45 : IMPLICIT INTEGER(I-N) 46 : IMPLICIT REAL*8(A-H,O-Z) 47 : * 48 : -INC CCOPTIO 49 : -INC CCHAMP 50 : -INC CCREEL 51 : -INC SMCHAML 52 : -INC SMINTE 53 : -INC SMELEME 54 : -INC SMRIGID 55 : -INC SMCOORD 56 : -INC SMLREEL 57 : * 58 : SEGMENT WRK1 59 : REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK) 60 : REAL*8 REL(LRE,LRE) ,RINT(LRE,LRE) , XE(3,NBBB) 61 : ENDSEGMENT 62 : * 63 : SEGMENT WRK2 64 : REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE) 65 : ENDSEGMENT 66 : * 67 : SEGMENT WRK3 68 : REAL*8 BPSS(3,3),XEL(3,NBBB) 69 : REAL*8 XNTH(LRN,LRN),XNTB(LRN,LRN),XNTT(LRN) 70 : ENDSEGMENT 71 : * 72 : SEGMENT WRK5 73 : REAL*8 XGENE(NSTN,LRN) 74 : ENDSEGMENT 75 : * 76 : SEGMENT WRK55 77 : REAL*8 YGENE(NCOT,NBNN),COBMA(LHOOK) 78 : ENDSEGMENT 79 : * 80 : SEGMENT WRK555 81 : REAL*8 XREL(LRN,LRN),COBB(NSTN),CPBB(NSTN),KKBB(NSTN,NSTN) 82 : ENDSEGMENT 83 : * 84 : SEGMENT WRK8 85 : REAL*8 XLOC(IDIM,IDIM),XGLOB(IDIM,IDIM),TXR(IDIM,IDIM) 86 : REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK) 87 : ENDSEGMENT 88 : * 89 : * SEGMENT MWRKIC 90 : * REAL*8 A(4,60),BB(3,60) 91 : * ? REAL*8 A(4,3*NBNO),BB(3,3*NBNO) 92 : * ENDSEGMENT 93 : * 94 : SEGMENT,MVELCH 95 : REAL*8 VALMAT(NV1) 96 : ENDSEGMENT 97 : * 98 : segment mwrk67 99 : real*8 valcar(nca1), xatef1(3,3) 100 : endsegment 101 : * 102 : SEGMENT MPTVAL 103 : INTEGER IPOS(NS) ,NSOF(NS) 104 : INTEGER IVAL(NCOSOU) 105 : CHARACTER*16 TYVAL(NCOSOU) 106 : ENDSEGMENT 107 : * 108 : DIMENSION A(4,60),BB(3,60) 109 : CHARACTER*8 CMATE,CELEM 110 : logical drend,BDPGE 111 : * 112 : * WRITE (*,*) 'Entrée dans RIGI2.' 113 : * SEGACT MCOORD 114 : MELEME=IPMAIL 115 : NBNN=NUM(/1) 116 : NBELEM=NUM(/2) 117 : * 118 : NV1=NMATT 119 : SEGINI,MVELCH 120 : * 121 : XMATRI=IPMATR 122 : NLIGRD=LRE 123 : NLIGRP=LRE 124 : 125 : * INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT 126 : * DE LA SECTION EN DEFO PLANE GENERALISEE 127 : * En 1D : pas de rotation 128 : IF (IFOUR.EQ.-3) THEN 129 : BDPGE=.TRUE. 130 : IREF=(IIPDPG-1)*(IDIM+1) 131 : XDPGE=XCOOR(IREF+1) 132 : YDPGE=XCOOR(IREF+2) 133 : ELSE IF ((IFOUR.GE.7.AND.IFOUR.LE.11).OR.IFOUR.EQ.14) THEN 134 : BDPGE=.TRUE. 135 : XDPGE=XZero 136 : YDPGE=XZero 137 : ELSE 138 : BDPGE=.FALSE. 139 : XDPGE=0.D0 140 : YDPGE=0.D0 141 : ENDIF 142 : * 143 : NHRM=NIFOUR 144 : * 145 : MINTE=IPMINT 146 : IRTD=1 147 : IDECAP=0 148 : C_______________________________________________________________________ 149 : C 150 : C NUMERO DES ETIQUETTES : 151 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 152 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : 153 : C 5 CONTINUE 154 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... 155 : C 44 CONTINUE 156 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... 157 : C_______________________________________________________________________ 158 : C 159 : GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99, 160 : 1 99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,35,35,35,35,35,35, 161 : 2 99,99,99,99,99,99,99,48,99,99,99,99,48,48,99,99,99,99,99,99, 162 : 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99, 4,99,99,79,79, 163 : 4 79,79,79,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 164 : 5 99,99,99,99,99,99,99,80,80,80, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 165 : 6 4, 4),MELE 166 : * 167 : IF(MELE.GE.173.AND.MELE.LE.182) GO TO 173 168 : IF (MELE.EQ.183.OR.MELE.EQ.184.OR. 169 : . MELE.EQ.193.OR.MELE.EQ.194) GOTO 4 170 : 171 : GOTO 99 172 : C_______________________________________________________________________ 173 : C 174 : C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET INCOMPRESSIBLES 175 : C_______________________________________________________________________ 176 : C 177 : 4 CONTINUE 178 : DIM3=1.D0 179 : * 180 : * CAS ORTHOTROPE ( 2) ANISOTROPE ( 3) UNIDIRICTIONNEL (4) 181 : * 182 : * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE 183 : * L'ELEMENT POUR LE CALCUL DES AXES LOCAUX 184 : IPMIN2 = 0 185 : IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN 186 : NLG=NUMGEO(MELE) 186 : CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1) 187 : MINTE2=IPMIN2 188 : SEGACT MINTE2 189 : SEGINI WRK8 190 : ENDIF 191 : 192 : NBNO=NBNN 193 : NBBB=NBNN 194 : SEGINI WRK1,WRK2 195 : 196 : * MWRKIC = 0 197 : * IF (MFR.EQ.31) SEGINI,MWRKIC 198 : * Initialisation en cas de matrice d'efficacite 199 : MWRK67 = 0 200 : IF (IVACAR.GT.0) THEN 201 : MPTVAL=IVACAR 202 : SEGACT,MPTVAL 203 : IF (IVAL(NCAR1).GT.0 .OR. IVAL(NCAR1+1).GT.0) THEN 204 : nca1 = IVAL(/1) 205 : SEGINI,MWRK67 206 : celem = 'MASSIF ' 207 : nstep = 2 208 : if (ifour.eq.2) nstep = 3 209 : drend = .false. 210 : irend = 0 211 : if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then 212 : drend = .true. 213 : irend = 1 214 : endif 215 : if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then 216 : drend = .false. 217 : irend = 2 218 : endif 219 : ENDIF 220 : ENDIF 221 : 222 : DO 3004 IB=1,NBELEM 223 : C 224 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 225 : C 225 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 226 : C 227 : C CALCUL DES AXES LOCAUX DANS LE CAS DES MATERIAUX ORTHOTROPE , 228 : C ANISOTROPE ET UNIDIRECTIONNEL 229 : C 230 : C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1)THEN 231 : IF (IPMIN2.NE.0) THEN 232 : NBSH=MINTE2.SHPTOT(/2) 232 : CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) 233 : if (nbsh.eq.-1) then 233 : call erreur(525) 234 : goto 9904 235 : endif 236 : ENDIF 237 : C 237 : CALL ZERO (RINT,LRE,LRE) 238 : C 239 : C= EF InCompressibles : CALCUL DES COEFF UTILES A LA MATRICE B-BARRE 240 : IF (MFR.EQ.31) THEN 240 : CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU,POIGAU, 241 : 1 QSIGAU,ETAGAU,DZEGAU,NSTRS, 242 : 2 LRE,IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE) 243 : ENDIF 244 : C 245 : C BOUCLE SUR LES POINTS DE GAUSS 246 : C 247 : ISDJC=0 248 : DO 4004 IGAU=1,NBPGAU 249 : C 250 : C RECUPERATION DE L'EPAISSEUR 251 : C 252 : IF (IFOUR.EQ.-2)THEN 253 : MPTVAL=IVACAR 254 : IF (IVACAR.NE.0) THEN 255 : MELVAL=IVAL(1) 256 : IF (MELVAL.NE.0) THEN 257 : IGMN=MIN(IGAU,VELCHE(/1)) 258 : IBMN=MIN(IB,VELCHE(/2)) 259 : DIM3=VELCHE(IGMN,IBMN) 260 : ELSE 261 : DIM3=1.D0 262 : ENDIF 263 : ENDIF 264 : ENDIF 265 : * 265 : CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 266 : 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,XE, 267 : 2 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) 268 : 269 : IF (DJAC.EQ.0.D0) THEN 270 : INTERR(1)=IB 270 : CALL ERREUR(259) 271 : GOTO 9904 272 : ENDIF 273 : IF (DJAC.LT.0.D0) ISDJC=ISDJC+1 274 : DJAC=ABS(DJAC)*POIGAU(IGAU) 275 : 276 : C En cas d'elements incompressibles : BGENE selon la methode B-BARRE 277 : IF (MFR.EQ.31) THEN 277 : CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 278 : & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE) 279 : ENDIF 280 : C 281 : MPTVAL=IVAMAT 282 : IF(IMAT.EQ.2) THEN 283 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 284 : MELVAL=IVAL(1) 285 : IBMN=MIN(IB ,IELCHE(/2)) 286 : IGMN=MIN(IGAU,IELCHE(/1)) 287 : MLREEL=IELCHE(IGMN,IBMN) 288 : SEGACT MLREEL 288 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 289 : SEGDES MLREEL 290 : ENDIF 291 : ELSE IF (IMAT.EQ.1) THEN 292 : DO 9004 IM=1,NMATT 293 : IF (IVAL(IM).NE.0) THEN 294 : MELVAL=IVAL(IM) 295 : IBMN=MIN(IB ,VELCHE(/2)) 296 : IGMN=MIN(IGAU,VELCHE(/1)) 297 : if (ibmn.gt.0.and.igmn.gt.0) then 298 : VALMAT(IM)=VELCHE(IGMN,IBMN) 299 : else 300 : VALMAT(IM)=0.D0 301 : endif 302 : ELSE 303 : VALMAT(IM)=0.D0 304 : ENDIF 305 : 9004 CONTINUE 306 : IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)THEN 307 : IF(IGAU.LE.NBGMAT) 307 : 1 CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO, 308 : 2 ROTH,DDHOOK,LHOOK,1,IRTD) 309 : ELSE 310 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 310 : 1 CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD) 311 : ENDIF 312 : ENDIF 313 : C 314 : C CHOIX POUR BDB/DEFO PLANE GENE --- PRODUIT MATRICIEL NORMAL 315 : C /MASSIF ------------ PRODUIT PAR BLOC 316 : C 317 : * initialise 317 : CALL ZERO (REL,LRE,LRE) 318 : * calcul rigidite elementaire 319 : C** IF (IFOUR.EQ.-3) THEN 320 : IF (BDPGE) THEN 320 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 321 : ELSE 321 : CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE, 322 : 1 IGAU,IMAT,0.D0) 323 : ENDIF 324 : 325 : * matrice d'efficacite 326 : IF (MWRK67.NE.0) THEN 327 : MPTVAL=IVACAR 328 : DO 9008 IM= 1,IVAL(/1) 329 : IF (IVAL(IM).GT.0) THEN 330 : MELVAL=IVAL(IM) 331 : IF (TYVAL(IM).EQ.'REAL*8') THEN 332 : IBMN=MIN(IB ,VELCHE(/2)) 333 : IGMN=MIN(IGAU,VELCHE(/1)) 334 : VALCAR(IM)=VELCHE(IGMN,IBMN) 335 : ELSE 336 : IBMN=MIN(IB ,IELCHE(/2)) 337 : IGMN=MIN(IGAU,IELCHE(/1)) 338 : VALCAR(IM)=IELCHE(IGMN,IBMN) 339 : ENDIF 340 : ELSE 341 : VALCAR(IM)=0.D0 342 : ENDIF 343 : 9008 CONTINUE 344 : do i = 1,nstep 345 : do j = 1, nstep 346 : xatef1(i,j) = 0.d0 347 : enddo 348 : enddo 349 : if (irend.eq.1) then 350 : xatef1(1,1) = valcar(ncar1) 351 : xatef1(2,2) = valcar(ncar1) 352 : if (nstep.eq.3) xatef1(3,3) = valcar(ncar1) 353 : else if (irend.eq.2) then 354 : xatef1(1,1) = valcar(ncar1+7) 355 : xatef1(2,2) = valcar(ncar1+8) 356 : if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9) 357 : endif 357 : call effi2(valcar,tyval,nca1,ncar1,rel,lre,ib,igau,xatef1, 358 : & nstep,drend,celem) 359 : ENDIF 360 : * stocke 361 : do jj = 1,LRE 362 : do ii = 1,LRE 363 : rint(ii,jj) = rint(ii,jj) + rel(ii,jj) 364 : enddo 365 : enddo 366 : * 367 : 4004 CONTINUE 368 : * 369 : IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN 370 : INTERR(1)=IB 370 : CALL ERREUR(195) 371 : GOTO 9904 372 : ENDIF 373 : C 374 : C REMPLISSAGE DE XMATRI 375 : C 375 : c CALL REMPMT(RINT,LRE,RE) 376 : DO 4100 IBK=1,LRE 377 : DO 4100 IAK=1,LRE 378 : RE(IAK,IBK,IB)=RINT(IAK,IBK) 379 : 4100 CONTINUE 380 : * do i = 1,8 381 : * write(6,*) re(13,3*i-2),re(13,3*i-1),re(13,3*i) 382 : * enddo 383 : * 384 : 3004 CONTINUE 385 : c 386 : IF(IRTD.EQ.0) THEN 387 : MOTERR(1:8)=CMATE 388 : MOTERR(9:16)=NOMFR(MFR/2+1) 389 : INTERR(1)=IFOUR 389 : CALL ERREUR(81) 390 : ENDIF 391 : 9904 CONTINUE 392 : C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND.IMAT.EQ.1) THEN 393 : IF (IPMIN2.NE.0) THEN 394 : SEGDES MINTE2 395 : SEGSUP WRK8 396 : ENDIF 397 : SEGSUP WRK1,WRK2 398 : * IF (MWRKIC.NE.0) SEGSUP,MWRKIC 399 : IF (MWRK67.NE.0) SEGSUP,MWRK67 400 : GOTO 510 401 : C_______________________________________________________________________ 402 : C 403 : C SECTEUR DE CALCUL POUR LES ELEMENTS LIQUIDES 404 : C_______________________________________________________________________ 405 : C 406 : 35 CONTINUE 407 : NBNO=NBNN 408 : NBBB=NBNN 409 : NSTRS=NDDL 410 : SEGINI WRK1,WRK2 411 : c 412 : DO 3035 IB=1,NBELEM 413 : C 414 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 415 : C 415 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 415 : CALL ZERO (REL,LRE,LRE) 416 : C 417 : C BOUCLE SUR LES POINTS DE GAUSS 418 : C 419 : ISDJC=0 420 : DO 4035 IGAU=1,NBPGAU 421 : 422 : MPTVAL=IVAMAT 423 : DO 9035 IM=1,5 424 : IF (IVAL(IM).NE.0) THEN 425 : MELVAL=IVAL(IM) 426 : IGMN=MIN(IGAU,VELCHE(/1)) 427 : IBMN=MIN(IB,VELCHE(/2)) 428 : VALMAT(IM)=VELCHE(IGMN,IBMN) 429 : ELSE 430 : VALMAT(IM)=0.D0 431 : ENDIF 432 : 9035 CONTINUE 433 : C 434 : C CALCUL DES COEFFICIENTS DE NORMALISATION 435 : C 436 : RHO =VALMAT(1) 437 : C =VALMAT(2) 438 : RHOREF=VALMAT(3) 439 : CREF =VALMAT(4) 440 : RLCAR =VALMAT(5) 441 : C 442 : COEFPR=(RHOREF*CREF*CREF)/RLCAR 443 : VKL =(COEFPR*COEFPR)/(RHO*C*C) 444 : 444 : CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE, 445 : 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) 446 : IF(DJAC.LT.0.D0) ISDJC=ISDJC+1 447 : 448 : DJAC=ABS(DJAC)*POIGAU(IGAU) 448 : CALL NKLNST(BGENE,DJAC,VKL,LRE,NSTRS,REL) 449 : 4035 CONTINUE 450 : * 451 : IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN 452 : INTERR(1)=IB 452 : CALL ERREUR(195) 453 : GOTO 9935 454 : ENDIF 455 : C 456 : C REMPLISSAGE DE XMATRI 457 : C 457 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 458 : 3035 CONTINUE 459 : * 460 : 9935 CONTINUE 461 : SEGSUP WRK1,WRK2 462 : GOTO 510 463 : C_______________________________________________________________________ 464 : C 465 : C SECTEUR DE CALCUL POUR LES ELEMENTS DE SURFACE LIBRE 466 : C_______________________________________________________________________ 467 : C 468 : 48 CONTINUE 469 : NBNO=NBNN 470 : NBBB=NBNN 471 : NSTRS=NDDL 472 : SEGINI WRK1,WRK2 473 : c 474 : DO 3048 IB=1,NBELEM 475 : C 476 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 477 : C 477 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 477 : CALL ZERO (REL,LRE,LRE) 478 : C 479 : MPTVAL=IVAMAT 480 : DO 9048 IM=1,6 481 : IF (IVAL(IM).NE.0) THEN 482 : MELVAL=IVAL(IM) 483 : IBMN=MIN(IB ,VELCHE(/2)) 484 : VALMAT(IM)=VELCHE(1,IBMN) 485 : ELSE 486 : VALMAT(IM)=0.D0 487 : ENDIF 488 : 9048 CONTINUE 489 : C 490 : RHO =VALMAT(1) 491 : G =VALMAT(6) 492 : VKS =RHO*G 493 : C 494 : C BOUCLE SUR LES POINTS DE GAUSS 495 : C 496 : ISDJC=0 497 : DO 4048 IGAU=1,NBPGAU 497 : CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE, 498 : 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) 499 : IF(DJAC.LT.0.0) ISDJC=ISDJC+1 500 : 501 : DJAC=ABS(DJAC)*POIGAU(IGAU) 501 : CALL NKSNST(BGENE,DJAC,VKS,LRE,NSTRS,REL) 502 : 4048 CONTINUE 503 : IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN 504 : INTERR(1)=IB 504 : CALL ERREUR(195) 505 : GOTO 9948 506 : ENDIF 507 : C 508 : C REMPLISSAGE DE XMATRI 509 : C 509 : CALL REMPMT(REL,LRE,RE(1,1,ib)) 510 : 3048 CONTINUE 511 : C 512 : 9948 CONTINUE 513 : SEGSUP WRK1,WRK2 514 : GOTO 510 515 : C_______________________________________________________________________ 516 : C 517 : C MILIEUX POREUX 518 : C_______________________________________________________________________ 519 : C 520 : 79 CONTINUE 521 : C 522 : C* Cas non pevus actuellement 523 : IF (IMAT.EQ.1) THEN 524 : IF (MATE.LT.1.OR.MATE.GT.4) GOTO 99 525 : ELSE 526 : GOTO 99 527 : ENDIF 528 : C 529 : C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS 530 : C NBNO = NOMBRE DE FONCTIONS DE FORME 531 : C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES 532 : C 533 : DIM3=1.D0 534 : NCOT=0 535 : NBNO=IPORE 536 : NBBB=NBNN 537 : NSTN=1 538 : **************** AM 08/01/01 539 : ***** NSTMU=2 540 : ***** IF(IFOUR.GE.0) NSTMU=3 541 : NSTMU=3 542 : LRN = NBNO-NBBB 543 : LRB=LRE-NBNN 544 : 545 : IELE=NUMGEO(MELE) 546 : IF(IELE.EQ.6 ) NCOT=3 547 : IF(IELE.EQ.10) NCOT=4 548 : IF(IELE.EQ.15) NCOT=12 549 : IF(IELE.EQ.17) NCOT=9 550 : IF(IELE.EQ.24) NCOT=6 551 : IF(NCOT.EQ.0) THEN 551 : CALL ERREUR(5) 552 : GOTO 510 553 : ENDIF 554 : * 555 : * CAS NON ISOTROPES 556 : * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES 557 : * AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX 558 : * 559 : IPMIN2 = 0 560 : IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1 ) THEN 560 : CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1) 561 : MINTE2=IPMIN2 562 : SEGACT MINTE2 563 : SEGINI WRK8 564 : NSTMU=LHOOK 565 : ENDIF 566 : * 567 : SEGINI WRK1,WRK2,WRK5,WRK55 568 : * 569 : DO 3079 IB=1,NBELEM 570 : * 571 : * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 572 : * 572 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 573 : * 574 : * CALCUL DES AXES LOCAUX DANS LES CAS NON ISOTROPES 575 : * 576 : C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) 577 : C* . .AND.IMAT.EQ.1)THEN 578 : IF (IPMIN2.NE.0) THEN 579 : NBSH=MINTE2.SHPTOT(/2) 579 : CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) 580 : if (nbsh.eq.-1) then 580 : call erreur(525) 581 : goto 9979 582 : endif 583 : ENDIF 584 : * 584 : CALL ZERO (REL,LRE,LRE) 585 : * 586 : * TRAITEMENT POUR NOEUDS MILIEUX PRESSION 587 : * 588 : FREF = 1.D6 588 : CALL BNPOR2(YGENE,NCOT,IELE) 589 : IF(IERR.NE.0) GOTO 9979 590 : * 591 : * DO 27895 IOI=1,NCOT 592 : * WRITE(6,28927) IOI 593 : *28927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3) 594 : * WRITE(6,28928) (YGENE(IOI,J),J=1,NBNN) 595 : *28928 FORMAT(8(1X,1PE10.3)) 596 : *27895 CONTINUE 597 : C 598 : C BOUCLE SUR LES POINTS DE GAUSS 599 : C 600 : ISDJC=0 601 : DO 4079 IGAU=1,NBPGAU 602 : C 603 : C RECUPERATION DE L'EPAISSEUR 604 : C 605 : IF (IFOUR.EQ.-2)THEN 606 : MPTVAL=IVACAR 607 : IF (IVACAR.NE.0) THEN 608 : MELVAL=IVAL(1) 609 : IF (MELVAL.NE.0) THEN 610 : IGMN=MIN(IGAU,VELCHE(/1)) 611 : IBMN=MIN(IB,VELCHE(/2)) 612 : DIM3=VELCHE(IGMN,IBMN) 613 : ELSE 614 : DIM3=1.D0 615 : ENDIF 616 : ENDIF 617 : ENDIF 618 : C 618 : CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM, 619 : . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1) 620 : IF (DJAC.EQ.0.D0) THEN 621 : INTERR(1)=IB 621 : CALL ERREUR(259) 622 : GOTO 9979 623 : ENDIF 624 : IF (DJAC.LT.0.D0) ISDJC=ISDJC+1 625 : DJAC=ABS(DJAC)*POIGAU(IGAU) 626 : C 627 : * IF(IGAU.EQ.1) THEN 628 : * DO 27892 IOI=1,LHOOK 629 : * WRITE(6,28920) IOI 630 : *28920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3) 631 : * WRITE(6,28921) (BGENE(IOI,J),J=1,LRE) 632 : *28921 FORMAT(8(1X,1PE10.3)) 633 : *27892 CONTINUE 634 : * DO 27893 IOI=1,NSTN 635 : * WRITE(6,28922) IOI 636 : *28922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3) 637 : * WRITE(6,28923) (XGENE(IOI,J),J=1,LRN) 638 : *28923 FORMAT(8(1X,1PE10.3)) 639 : *27893 CONTINUE 640 : * ENDIF 641 : 642 : MPTVAL=IVAMAT 643 : C*D IF(IMAT.EQ.2) THEN 644 : C*D GO TO 99 645 : C*D ELSE IF (IMAT.EQ.1) THEN 646 : * 647 : DO 9079 IM=1,NMATT 648 : IF (IVAL(IM).NE.0) THEN 649 : MELVAL=IVAL(IM) 650 : IBMN=MIN(IB ,VELCHE(/2)) 651 : IGMN=MIN(IGAU,VELCHE(/1)) 652 : VALMAT(IM)=VELCHE(IGMN,IBMN) 653 : ELSE 654 : VALMAT(IM)=0.D0 655 : ENDIF 656 : 9079 CONTINUE 657 : * 658 : IF(MATE.EQ.1) THEN 659 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 659 : . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD) 660 : DO 4879 I=1,NSTMU 661 : COBMA(I) =VALMAT(3) 662 : 4879 CONTINUE 663 : XMOB =VALMAT(4) 664 : * 665 : ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN 666 : IF(IGAU.LE.NBGMAT) 666 : . CALL PORMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO, 667 : . ROTH,DDHOOK,LHOOK,COBMA,XMOB,1,IRTD) 668 : C*D ELSE 669 : C*D GO TO 99 670 : ENDIF 671 : * 672 : C*D ENDIF 673 : * 673 : CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE, 674 : . IGAU,IMAT,0.D0) 675 : EREF =1.D0 676 : DJACER=DJAC*EREF 677 : DO 4179 I=1,LRB 678 : DO 4179 J=1,LRN 679 : JJ=J+LRB 680 : r_z = DJACER*XGENE(1,J) 681 : DO 4179 K=1,NSTMU 682 : REL(JJ,I)=REL(JJ,I)-COBMA(K)*r_z*BGENE(K,I) 683 : 4179 CONTINUE 684 : * 685 : IF(XMOB.EQ.0.D0) THEN 686 : UNSURM=0.D0 687 : ELSE 688 : UNSURM=1.D0 / XMOB 689 : ENDIF 690 : COMJAC=UNSURM*DJAC*EREF*EREF 691 : DO 4279 I=1,LRN 692 : II=I+LRB 693 : r_z = COMJAC*XGENE(1,I) 694 : DO 4279 J=1,I 695 : JJ=J+LRB 696 : REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J) 697 : 4279 CONTINUE 698 : C 699 : COMJAC=UNSURM*DJAC*FREF 700 : DO 4379 I=1,NBNN 701 : II=I+LRB 702 : DO 4379 J=1,I 703 : JJ=J+LRB 704 : DO 4379 K=1,NCOT 705 : REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J) 706 : 4379 CONTINUE 707 : * 708 : 4079 CONTINUE 709 : IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN 710 : INTERR(1)=IB 710 : CALL ERREUR(195) 711 : GOTO 9979 712 : ENDIF 713 : C 714 : C REMPLISSAGE DE XMATRI 715 : C 715 : CALL REMPMT(REL,LRE,RE(1,1,ib)) 716 : * 717 : 3079 CONTINUE 718 : c 719 : IF(IRTD.EQ.0) THEN 720 : MOTERR(1:8)=CMATE 721 : MOTERR(9:16)=NOMFR(MFR/2+1) 722 : INTERR(1)=IFOUR 722 : CALL ERREUR(81) 723 : ENDIF 724 : 9979 CONTINUE 725 : SEGSUP WRK1,WRK2,WRK5,WRK55 726 : C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1) THEN 727 : IF (IPMIN2.NE.0) THEN 728 : SEGDES MINTE2 729 : SEGSUP WRK8 730 : ENDIF 731 : GOTO 510 732 : C_______________________________________________________________________ 733 : C 734 : C MILIEUX POREUX - SUITE 735 : C_______________________________________________________________________ 736 : C 737 : 173 CONTINUE 738 : C 739 : C CAS NON ISOTROPES NON PREVUS ACTUELLEMENT 740 : IF (IMAT.EQ.1) THEN 741 : IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN 741 : CALL ERREUR(251) 742 : GO TO 510 743 : ENDIF 744 : ELSE 745 : C* ELSE IF (IMAT.EQ.2) THEN 746 : GO TO 99 747 : ENDIF 748 : C 749 : C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS 750 : C NBNO = NOMBRE DE FONCTIONS DE FORME 751 : C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES 752 : C 753 : IF(MFR.EQ.57) IDECAP=2 754 : IF(MFR.EQ.59) IDECAP=3 755 : * 756 : DIM3=1.D0 757 : NCOT=0 758 : NBNO=IPORE 759 : NBBB=NBNN 760 : NSTN=IDECAP 761 : * 762 : **************** AM 08/01/01 763 : ***** NSTMU=2 764 : ***** IF(IFOUR.GE.0) NSTMU=3 765 : * 766 : NSTMU=3 767 : LPP=NBNO-NBBB 768 : LRN = IDECAP*LPP 769 : **** LRB=LRE-LRN 770 : LRB=LRE-(IDECAP*NBBB) 771 : IELE=NUMGEO(MELE) 772 : * 773 : IF(IELE.EQ.6 ) NCOT=3 774 : IF(IELE.EQ.10) NCOT=4 775 : IF(IELE.EQ.15) NCOT=12 776 : IF(IELE.EQ.17) NCOT=9 777 : IF(IELE.EQ.24) NCOT=6 778 : IF(NCOT.EQ.0) THEN 778 : CALL ERREUR(5) 779 : GO TO 510 780 : ENDIF 781 : * 782 : SEGINI WRK1,WRK2,WRK5,WRK55,WRK555 783 : 784 : DO 3173 IB=1,NBELEM 785 : * 786 : * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 787 : * 787 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 788 : * 788 : CALL ZERO (REL,LRE,LRE) 789 : * 790 : * TRAITEMENT POUR NOEUDS MILIEUX PRESSION 791 : * 792 : FREF = 1.D6 792 : CALL BNPOR2(YGENE,NCOT,IELE) 793 : IF(IERR.NE.0) GO TO 9973 794 : 795 : * DO 17895 IOI=1,NCOT 796 : * WRITE(6,78927) IOI 797 : *78927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3) 798 : * WRITE(6,78928) (YGENE(IOI,J),J=1,NBNN) 799 : *78928 FORMAT(8(1X,1PE10.3)) 800 : *17895 CONTINUE 801 : C 802 : C BOUCLE SUR LES POINTS DE GAUSS 803 : C 804 : ISDJC=0 805 : DO 4173 IGAU=1,NBPGAU 806 : C 807 : C RECUPERATION DE L'EPAISSEUR 808 : C 809 : IF (IFOUR.EQ.-2)THEN 810 : MPTVAL=IVACAR 811 : IF (IVACAR.NE.0) THEN 812 : MELVAL=IVAL(1) 813 : IF (MELVAL.NE.0) THEN 814 : IGMN=MIN(IGAU,VELCHE(/1)) 815 : IBMN=MIN(IB,VELCHE(/2)) 816 : DIM3=VELCHE(IGMN,IBMN) 817 : ELSE 818 : DIM3=1.D0 819 : ENDIF 820 : ENDIF 821 : ENDIF 822 : C 822 : CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM, 823 : . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,1) 824 : IF(DJAC.EQ.0.D0) THEN 825 : INTERR(1)=IB 825 : CALL ERREUR(259) 826 : GOTO 9973 827 : ENDIF 828 : IF(DJAC.LT.0.D0) ISDJC=ISDJC+1 829 : DJAC=ABS(DJAC)*POIGAU(IGAU) 830 : C 831 : * IF(IGAU.EQ.1) THEN 832 : * DO 17892 IOI=1,LHOOK 833 : * WRITE(6,78920) IOI 834 : *78920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3) 835 : * WRITE(6,78921) (BGENE(IOI,J),J=1,LRE) 836 : *78921 FORMAT(8(1X,1PE10.3)) 837 : *17892 CONTINUE 838 : * DO 17893 IOI=1,NSTN 839 : * WRITE(6,78922) IOI 840 : *78922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3) 841 : * WRITE(6,78923) (XGENE(IOI,J),J=1,LRN) 842 : *78923 FORMAT(8(1X,1PE10.3)) 843 : *17893 CONTINUE 844 : * ENDIF 845 : 846 : MPTVAL=IVAMAT 847 : C*D IF(IMAT.EQ.2) THEN 848 : C*D GO TO 99 849 : C*D ELSE IF (IMAT.EQ.1) THEN 850 : * 851 : DO 9173 IM=1,NMATT 852 : IF (IVAL(IM).NE.0) THEN 853 : MELVAL=IVAL(IM) 854 : IBMN=MIN(IB ,VELCHE(/2)) 855 : IGMN=MIN(IGAU,VELCHE(/1)) 856 : VALMAT(IM)=VELCHE(IGMN,IBMN) 857 : ELSE 858 : VALMAT(IM)=0.D0 859 : ENDIF 860 : 9173 CONTINUE 861 : * 862 : C*D IF(MATE.EQ.1) THEN 863 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 863 : . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD) 864 : * 865 : C*D ELSE 866 : C*D GO TO 99 867 : C*D ENDIF 868 : C*D ENDIF 869 : * 869 : CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL) 870 : EREF =1.D0 871 : * 872 : IF(MFR.EQ.57) THEN 873 : COBB(1) = VALMAT(3) 874 : COBB(2) = VALMAT(4) 875 : CPBB(1) = VALMAT(5) 876 : CPBB(2) = VALMAT(6) 877 : KKBB(1,1)= VALMAT(7) 878 : KKBB(1,2)= VALMAT(8) 879 : KKBB(2,1)= VALMAT(9) 880 : KKBB(2,2)= VALMAT(10) 881 : * 882 : ELSE IF(MFR.EQ.59) THEN 883 : COBB(1) = VALMAT(3) 884 : COBB(2) = VALMAT(4) 885 : COBB(3) = VALMAT(5) 886 : CPBB(1) = VALMAT(6) 887 : CPBB(2) = VALMAT(7) 888 : CPBB(3) = VALMAT(8) 889 : KKBB(1,1)= VALMAT(9) 890 : KKBB(1,2)= VALMAT(10) 891 : KKBB(1,3)= VALMAT(11) 892 : KKBB(2,1)= VALMAT(12) 893 : KKBB(2,2)= VALMAT(13) 894 : KKBB(2,3)= VALMAT(14) 895 : KKBB(3,1)= VALMAT(15) 896 : KKBB(3,2)= VALMAT(16) 897 : KKBB(3,3)= VALMAT(17) 898 : ENDIF 899 : * 900 : DJACER=DJAC*EREF 901 : 902 : DO 6673 IPR=1,IDECAP 903 : LRBDEC=LRB + (IPR-1)*NBBB 904 : LPPDEC= (IPR-1)*LPP 905 : COMJAC=COBB(IPR)*DJACER 906 : DO 4973 I=1,LRB 907 : DO 4973 J=1,LPP 908 : JJ=J+LRBDEC 909 : JX=J+LPPDEC 910 : r_z = COMJAC*XGENE(IPR,JX) 911 : DO 4973 K=1,NSTMU 912 : REL(I,JJ)=REL(I,JJ)-r_z*BGENE(K,I) 913 : 4973 CONTINUE 914 : 6673 CONTINUE 915 : * 916 : DO 6674 IPR=1,IDECAP 917 : LRBDEC=LRB + (IPR-1)*NBBB 918 : LPPDEC= (IPR-1)*LPP 919 : COMJAC=CPBB(IPR)*DJACER 920 : DO 4974 I=1,LRB 921 : DO 4974 J=1,LPP 922 : JJ=J+LRBDEC 923 : JX=J+LPPDEC 924 : r_z = COMJAC*XGENE(IPR,JX) 925 : DO 4974 K=1,NSTMU 926 : * ici - pour bsig 927 : REL(JJ,I)=REL(JJ,I)-r_z*BGENE(K,I) 928 : 4974 CONTINUE 929 : 6674 CONTINUE 930 : * 931 : COMJAC=DJAC*EREF*EREF 931 : CALL ZERO(XREL,LRN,LRN) 931 : CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL) 932 : 933 : DO 6873 IPR=1,IDECAP 934 : IRBDEC=LRB + (IPR-1)*NBBB 935 : IPPDEC= (IPR-1)*LPP 936 : DO 6873 JPR=1,IDECAP 937 : JRBDEC=LRB + (JPR-1)*NBBB 938 : JPPDEC= (JPR-1)*LPP 939 : DO 4273 I=1,LPP 940 : II=I+IRBDEC 941 : IX=I+IPPDEC 942 : DO 4273 J=1,LPP 943 : JJ=J+JRBDEC 944 : JX=J+JPPDEC 945 : 946 : * IF(IGAU.EQ.1) THEN 947 : * PRINT *,'I =',I,' IX=',IX,' II=',II 948 : * PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX) 949 : * ENDIF 950 : 951 : REL(II,JJ)=REL(II,JJ)-XREL(IX,JX) 952 : 4273 CONTINUE 953 : 6873 CONTINUE 954 : C 955 : DO 6973 IPR=1,IDECAP 956 : COMJAC=KKBB(IPR,IPR)*DJAC*FREF 957 : LRBDEC=LRB + (IPR-1)*NBBB 958 : DO 4373 I=1,NBNN 959 : II=I+LRBDEC 960 : DO 4373 J=1,NBNN 961 : JJ=J+LRBDEC 962 : DO 4374 K=1,NCOT 963 : REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J) 964 : 4374 CONTINUE 965 : 4373 CONTINUE 966 : 6973 CONTINUE 967 : * 968 : 4173 CONTINUE 969 : IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN 970 : INTERR(1)=IB 970 : CALL ERREUR(195) 971 : GOTO 9973 972 : ENDIF 973 : C 974 : C REMPLISSAGE DE XMATRI 975 : C 975 : CALL REMPMS(REL,LRE,RE(1,1,ib)) 976 : 3173 CONTINUE 977 : c 978 : IF(IRTD.EQ.0) THEN 979 : MOTERR(1:8)=CMATE 980 : MOTERR(9:16)=NOMFR(MFR/2+1) 981 : INTERR(1)=IFOUR 981 : CALL ERREUR(81) 982 : ENDIF 983 : 9973 CONTINUE 984 : SEGSUP WRK1,WRK2,WRK5,WRK55,WRK555 985 : GOTO 510 986 : C_______________________________________________________________________ 987 : C 988 : C JOINTS EN FORMULATION MILIEUX POREUX 989 : C_______________________________________________________________________ 990 : C 991 : 80 CONTINUE 992 : C 993 : * CAS NON PREVUS 994 : IF (IMAT.EQ.1) THEN 995 : IF (MATE.NE.1) GOTO 99 996 : ELSE IF (IMAT.EQ.2) THEN 997 : GOTO 99 998 : ENDIF 999 : C 1000 : C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS 1001 : C NBNO = NOMBRE DE FONCTIONS DE FORME 1002 : C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES 1003 : C 1004 : NCOT=0 1005 : NBNO=IPORE 1006 : NBBB=NBNN 1007 : NSTN=1 1008 : NSTMU=2 1009 : IF(IFOUR.EQ.2) NSTMU=3 1010 : LRN=(NBNO-NBBB)*3/2 1011 : LRB=LRE-NBNN 1012 : IELE=NUMGEO(MELE) 1013 : IF(IELE.EQ.29) NCOT=2 1014 : IF(IELE.EQ.30) NCOT=6 1015 : IF(IELE.EQ.31) NCOT=8 1016 : IF(NCOT.EQ.0) THEN 1016 : CALL ERREUR(5) 1017 : GO TO 510 1018 : ENDIF 1019 : * 1020 : SEGINI WRK1,WRK2,WRK3,WRK5,WRK55 1021 : * 1022 : DO 3080 IB=1,NBELEM 1023 : * 1024 : * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1025 : * 1025 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1026 : * 1027 : * CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES 1028 : * 1028 : CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS) 1029 : * 1029 : CALL ZERO (REL,LRE,LRE) 1030 : * 1030 : CALL INTDEL(XNTH,XNTB,XNTT,LRN,MELE) 1031 : * 1032 : * TRAITEMENT POUR NOEUDS MILIEUX PRESSION 1033 : * 1034 : FREF = 1.D6 1034 : CALL BNPOR2(YGENE,NCOT,IELE) 1035 : IF (IERR.NE.0) GOTO 9980 1036 : * 1037 : * BOUCLE SUR LES POINTS DE GAUSS 1038 : * 1039 : ISDJC=0 1040 : DO 4080 IGAU=1,NBPGAU 1041 : * 1041 : CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL, 1042 : . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1) 1043 : IF (DJAC.EQ.0.D0) THEN 1044 : INTERR(1)=IB 1044 : CALL ERREUR(259) 1045 : GOTO 9980 1046 : ENDIF 1047 : IF(DJAC.LT.0.D0) ISDJC=ISDJC+1 1048 : DJAC=ABS(DJAC)*POIGAU(IGAU) 1049 : * 1050 : MPTVAL=IVAMAT 1051 : C*D IF(IMAT.EQ.2) THEN 1052 : C*D GO TO 99 1053 : C*D ELSE IF (IMAT.EQ.1) THEN 1054 : * 1055 : DO 9080 IM=1,NMATT 1056 : IF (IVAL(IM).NE.0) THEN 1057 : MELVAL=IVAL(IM) 1058 : IBMN=MIN(IB ,VELCHE(/2)) 1059 : IGMN=MIN(IGAU,VELCHE(/1)) 1060 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1061 : ELSE 1062 : VALMAT(IM)=0.D0 1063 : ENDIF 1064 : 9080 CONTINUE 1065 : * 1066 : C*D IF(MATE.EQ.1) THEN 1067 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1067 : . CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1068 : C*D ELSE 1069 : C*D GO TO 99 1070 : C*D ENDIF 1071 : C*D ENDIF 1072 : * 1072 : CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE, 1073 : . IGAU,IMAT,0.D0) 1074 : EREF =1.D0 1075 : * 1076 : COBMA(NSTMU)=VALMAT(3) 1077 : XMOB=VALMAT(4) 1078 : * 1079 : IF(XMOB.EQ.0.D0) THEN 1080 : UNSURM=0.D0 1081 : ELSE 1082 : UNSURM=1.D0 / XMOB 1083 : ENDIF 1084 : * 1085 : DJACER=DJAC*EREF 1086 : DO 4180 I=1,LRB 1087 : DO 4180 J=1,LRN 1088 : JJ=J+LRB 1089 : r_z = DJACER*XGENE(1,J)*XNTT(J) 1090 : DO 4180 K=1,NSTMU 1091 : REL(JJ,I)=REL(JJ,I)-r_z*COBMA(K)*BGENE(K,I) 1092 : 4180 CONTINUE 1093 : * 1094 : COMJAC=UNSURM*DJAC*EREF*EREF 1095 : DO 4280 I=1,LRN 1096 : II=I+LRB 1097 : r_z = COMJAC*XGENE(1,I)*XNTT(I) 1098 : DO 4280 J=1,I 1099 : JJ=J+LRB 1100 : REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)*XNTT(J) 1101 : 4280 CONTINUE 1102 : * 1103 : COMJAC=UNSURM*DJAC*FREF 1104 : DO 4380 I=1,NBNN 1105 : II=I+LRB 1106 : DO 4380 J=1,I 1107 : JJ=J+LRB 1108 : DO 4380 K=1,NCOT 1109 : REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J) 1110 : 4380 CONTINUE 1111 : * 1112 : 4080 CONTINUE 1113 : IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN 1114 : INTERR(1)=IB 1114 : CALL ERREUR(195) 1115 : GOTO 9980 1116 : ENDIF 1117 : * 1118 : * REMPLISSAGE DE XMATRI 1119 : * 1119 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1120 : 3080 CONTINUE 1121 : 1122 : IF(IRTD.EQ.0) THEN 1123 : MOTERR(1:8)=CMATE 1124 : MOTERR(9:16)=NOMFR(MFR/2+1) 1125 : INTERR(1)=IFOUR 1125 : CALL ERREUR(81) 1126 : ENDIF 1127 : 9980 CONTINUE 1128 : SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55 1129 : GOTO 510 1130 : * 1131 : * ERREUR : CAS NON PREVU 1132 : * 1133 : 99 CONTINUE 1134 : MOTERR(1:4)=NOMTP(MELE) 1135 : MOTERR(5:12)='RIGI2 ' 1135 : CALL ERREUR(86) 1136 : * 1137 : 510 CONTINUE 1138 : * WRITE (*,*) 'Sortie de RIGI2.' 1139 : * SEGDES,XMATRI 1140 : SEGSUP,MVELCH 1141 : 1142 : RETURN 1143 : END 1144 : 1145 : 1146 : 1147 :
© Cast3M 2003 - All rights reserved.
Disclaimer