1 : C INTGCA SOURCE AM 13/12/16 21:15:48 7825 2 : 3 : C======================================================================= 4 : C= I N T G C A = 5 : C= ----------- = 6 : C= = 7 : C= Fonction : = 8 : C= ---------- = 9 : C= Integration d'un champ scalaire sur un maillage ou par element. = 10 : C= Sous-programme appele par INTGRA (intgra.eso). = 11 : C= = 12 : C= Parametres : (E)=Entree (S)=Sortie = 13 : C= ------------ = 14 : C= IPMODL (E) Pointeur sur le segment MMODEL = 15 : C= IPCHE1 (E) Pointeur sur segment MCHELM a une seule composante = 16 : C= IPCHE2 (E) Pointeur sur le segment MCHELM de CARACTERISTIQUES = 17 : C= KOPELE (E) =0 si on ne veut pas un MCHAML resultat = 18 : C= IPINT (S) Pointeur sur le segment MCHELM resultat = 19 : C= XRET (S) Flottant resultant de l'integration si demande = 20 : C= IRET (S) Entier valant 1 en cas de succes, 0 sinon (et un = 21 : C= message d'erreur est imprime dans ce cas) = 22 : C= = 23 : C= Remarque : Autrefois, le champ resultat avait le meme support que = 24 : C= ---------- le champ IPCHE1,soit IPINT/MCHEL1.INFCHE(iSou,6)). = 25 : C= Maintenant, le champ resultat IPINT est donne au centre = 26 : C= de gravite quelque soit le support du champ integre, = 27 : C= soit IPINT.INFCHE(iSou,6)=2 . = 28 : C======================================================================= 29 : 30 : SUBROUTINE INTGCA (IPMODL,IPCHE1,IPCHE2,KOPELE,IRET,XRET,IPINT) 31 : 32 : IMPLICIT INTEGER(I-N) 33 : IMPLICIT REAL*8 (A-H,O-Z) 34 : 35 : -INC CCREEL 36 : -INC CCOPTIO 37 : -INC CCHAMP 38 : -INC SMMODEL 39 : -INC SMCHAML 40 : -INC SMELEME 41 : -INC SMCOORD 42 : -INC SMINTE 43 : 44 : SEGMENT MWRK1 45 : REAL*8 SHP(6,NBNO),XEL(3,NBNO),BPSS(3,3),XE(3,NBNO) 46 : ENDSEGMENT 47 : 48 : SEGMENT MWRK2 49 : REAL*8 TXR(3,3,NBNO),XJ(3,3) 50 : ENDSEGMENT 51 : 52 : SEGMENT MWRK3 53 : REAL*8 WORK(LW) 54 : ENDSEGMENT 55 : 56 : SEGMENT INFO 57 : INTEGER INFELL(JG) 58 : ENDSEGMENT 59 : 60 : SEGMENT NOTYPE 61 : CHARACTER*16 TYPE(NBTYPE) 62 : ENDSEGMENT 63 : 64 : SEGMENT MPTVAL 65 : INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU) 66 : CHARACTER*16 TYVAL(NCOSOU) 67 : ENDSEGMENT 68 : 69 : PARAMETER (NINF=3) 70 : INTEGER INFOS(NINF) 71 : CHARACTER*(NCONCH) CONM 72 : CHARACTER*8 CHARIN 73 : LOGICAL LOGCOQ 74 : 75 : C= Quelques constantes (2.Pi et 4.Pi) 76 : PARAMETER (X2Pi=6.283185307179586476925286766559D0) 77 : PARAMETER (X4Pi=12.566370614359172953850573533118D0) 78 : 79 : IRET=0 80 : 81 : C 1 - VERIFICATIONS DES DONNEES DE L'OPERATEUR 82 : C Verification du lieu support du MCHAML a integrer 83 : C ======================================================= 84 : MMODEL=IPMODL 85 : SEGACT,MMODEL 86 : IMODEL=KMODEL(1) 87 : SEGACT,IMODEL 87 : CALL PLACE(FORMOD,FORMOD(/2),ITHER,'THERMIQUE') 88 : IF (ITHER.EQ.0) THEN 89 : ** IS=3 90 : * On determine le support du champ d'entree 91 : IS=0 92 : ISup1=0 93 : iOK=0 93 : CALL QUESUP(IPMODL,IPCHE1,IS,0,ISup1,iOK) 93 : IF (iOK.EQ.9999) call erreur(609) 94 : if (ierr.ne.0) return 95 : IS=iOK 96 : * Dans le cas d'un champ constant, au centre de gravite ou aux noeuds, 97 : * on utilise les points de la rigidite. 98 : IF (IS.EQ.1 .OR. IS.EQ.2) IS=3 99 : ELSE 100 : IS=6 101 : ENDIF 102 : SEGDES,IMODEL,MMODEL 103 : ISup1=0 104 : iOK=0 104 : CALL QUESUP(IPMODL,IPCHE1,IS,0,ISup1,iOK) 104 : IF (ISup1.GT.1) call erreur(609) 105 : if (ierr.ne.0) return 106 : 107 : C 2 - QUELQUES INITIALISATIONS 108 : C ============================== 109 : C 2.1 - Activation du MMODEL 110 : C ===== 111 : MMODEL=IPMODL 112 : SEGACT,MMODEL 113 : NSOUS=KMODEL(/1) 114 : C ===== 115 : C 2.2 - Initialisation du MCHELM resultat si demande 116 : C ===== 117 : XRET=0. 118 : IPINT=0 119 : IF (KOPELE.NE.0) THEN 120 : L1=8 121 : N1=NSOUS 122 : N3=6 123 : SEGINI,MCHELM 124 : TITCHE='SCALAIRE' 125 : IFOCHE=IFOUR 126 : IPINT=MCHELM 127 : ENDIF 128 : C ===== 129 : C 2.3 - Recuperation du nom de la composante de IPCHE1 130 : C Traitement effectue ici car identique sur tout le modele 131 : C ===== 132 : MCHEL1=IPCHE1 133 : SEGACT,MCHEL1 134 : MCHAML=MCHEL1.ICHAML(1) 135 : SEGACT,MCHAML 136 : NBROBL=1 137 : NBRFAC=0 138 : SEGINI,NOMID 139 : LESOBL(1)=NOMCHE(1) 140 : SEGDES,MCHAML,MCHEL1 141 : NBTYPE=1 142 : SEGINI,NOTYPE 143 : TYPE(1)='REAL*8' 144 : MOCOMP=NOMID 145 : MOTYCO=NOTYPE 146 : 147 : C 3 - BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE (iSou) 148 : C ======================================================== 149 : isouss=0 150 : DO 2000 iSou=1,NSOUS 151 : C ===== 152 : C 3.1 - Quelques initialisations 153 : C ===== 154 : IVACOM=0 155 : MOCARA=0 156 : IVACAR=0 157 : MCHAML=0 158 : IPMEL1=0 159 : IPMEL2=0 160 : MWRK3 =0 161 : C ===== 162 : C 3.2 - Activation du sous-modele (iSou) 163 : C ===== 164 : IMODEL=KMODEL(iSou) 165 : SEGACT,IMODEL 166 : CONM=CONMOD 167 : MELE=NEFMOD 168 : if( mele.eq.22) then 169 : segdes imodel 170 : go to 2000 171 : endif 172 : isouss=isouss+1 173 : C ===== 174 : C 3.3 - Recuperation du maillage associe au sous-modele (iSou) 175 : C Traitement particulier dans le cas d'une formulation DARCY 176 : C ===== 177 : IPMAIL=IMAMOD 177 : CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY') 178 : IF (IDARC.NE.0) THEN 178 : CALL LEKMOD(MMODEL,IPTABL,INEFMD) 179 : CHARIN='MAILLAGE' 179 : CALL LEKTAB(IPTABL,CHARIN,IOBRE) 180 : IF (IERR.NE.0) GOTO 250 181 : IF (NSOUS.GT.1)THEN 182 : IPT1=IOBRE 183 : SEGACT,IPT1 184 : IPMAIL=IPT1.LISOUS(iSou) 185 : SEGDES,IPT1 186 : ELSE 187 : IPMAIL=IOBRE 188 : ENDIF 189 : ENDIF 190 : C ===== 191 : C 3.4 - Determination ... 192 : C ===== 192 : CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,iOK) 193 : IF (iOK.EQ.0) GOTO 250 194 : iOK=0 195 : C ===== 196 : C 3.5 - Recuperation d'informations sur l'element fini du sous-modele 197 : C ERREUR si la formulation n'est pas disponible 198 : C ERREUR si l'element est une element JOINT (non implante) 199 : C ===== 200 : LOGCOQ=.FALSE. 201 : IF (ITHER.EQ.0) THEN 202 : if(infmod(/1).lt.4) then 202 : CALL ELQUOI(MELE,0,2,IPINF,IMODEL) 203 : IF (IERR.NE.0) GOTO 240 204 : INFO=IPINF 205 : mincdg=INFELL(11) 206 : SEGSUP,INFO 207 : else 208 : mincdg=infmod(4) 209 : endif 210 : C* if(infmod(/1).lt.5) then 210 : C* CALL ELQUOI(MELE,0,3,IPINF,IMODEL) 211 : if(infmod(/1).lt.IS+2) then 211 : CALL ELQUOI(MELE,0,IS,IPINF,IMODEL) 212 : IF (IERR.NE.0) GOTO 240 213 : INFO=IPINF 214 : IPMINT=INFELL(11) 215 : MINTE1=INFELL(12) 216 : MFR=INFELL(13) 217 : LW=INFELL(7) 218 : NLG=INFELL(14) 219 : SEGSUP,INFO 220 : else 221 : C* IPMINT=infmod(5) 222 : IPMINT=infmod(IS+2) 223 : MINTE1=INFMOD(8) 224 : MFR=INFELE(13) 225 : LW=INFELE(7) 226 : NLG=INFELE(14) 227 : endif 228 : IF (MFR.EQ.5) LOGCOQ=.TRUE. 229 : ELSE 230 : mincdg=0 231 : LW=100 231 : CALL TSHAPE(MELE,'GAUSS',IPMINT) 232 : IF (MELE.EQ.41.OR.MELE.EQ.56.OR.MELE.EQ.49) THEN 233 : LOGCOQ=.TRUE. 233 : CALL TSHAPE(MELE,'NOEUD',IPMIN1) 234 : MINTE1=IPMIN1 235 : ENDIF 236 : MFR=NUMMFR(MELE) 237 : NLG=NUMGEO(MELE) 238 : ENDIF 239 : * write(6,*) 'MFR,IDIM=',MFR,IDIM 240 : IF (MFR.NE. 1.AND.MFR.NE. 3.AND.MFR.NE. 7.AND.MFR.NE.9.AND. 241 : . MFR.NE.11.AND.MFR.NE.13.AND.MFR.NE.33.AND.MFR.NE.5.AND. 242 : . MFR.NE.31.AND.MFR.NE.35.AND.MFR.NE.63.AND.MFR.NE.71.AND. 243 : & MFR.NE.73.AND.MFR.NE.57.AND.MFR.NE.59.AND.MFR.NE.77) THEN 244 : MOTERR(1:8)=NOMFR(MFR) 244 : CALL ERREUR(193) 245 : GOTO 240 246 : ENDIF 247 : IF (MFR.EQ.35.AND.IDIM.NE.2) THEN 248 : IF (MELE.NE.87.AND.MELE.NE.88) THEN 249 : MOTERR(1:4)=NOMTP(MELE) 250 : MOTERR(5:12)='INTG' 250 : CALL ERREUR(86) 251 : GOTO 240 252 : ENDIF 253 : ENDIF 253 : CALL QUEDIM(NLG,JDIM) 254 : MINTE=IPMINT 255 : SEGACT,MINTE 256 : C ===== 257 : C 3.6 - Recuperation de la composante a integrer 258 : C Verification de sa presence dans le MCHAML (IPCHE1) 259 : C Appel a KOMCHA : NINFO=0 pour le moment... 260 : C Recuperation du MELVAL associe a ce MCHAML sur IPMAIL 261 : C ===== 262 : NINFO=0 262 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYCO,1, 263 : . INFOS,NINFO,IVACOM) 264 : IF (IERR.NE.0) GOTO 230 265 : MPTVAL=IVACOM 266 : MELVA1=IVAL(1) 267 : SEGACT,MELVA1 268 : NBPTEL=MELVA1.VELCHE(/1) 269 : IPMEL1=MELVA1 270 : IF (ISup1.EQ.1) THEN 270 : CALL VALMEL(IPMEL1,IPMINT,IPMEL2) 271 : C*OF ? SEGSUP,MELVA1 272 : MELVA1=IPMEL2 273 : ENDIF 274 : IPMEL1=MELVA1 275 : C ===== 276 : C 3.7 - Recuperation des noms des caracteristiques geometriques 277 : C ===== 278 : CHARIN=' ' 278 : CALL CARAMK(MFR,IFOUR,MELE,CHARIN,IVECT,MOCARA,NBROBL,NBRFAC, 279 : . NBRTOT,MOTYPE,NBTYPE) 280 : NOMID=MOCARA 281 : NOTYPE=MOTYPE 282 : IF (NBRTOT.NE.0.AND.IPCHE2.NE.0) THEN 282 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3, 283 : . IVACAR) 284 : SEGSUP,NOTYPE 285 : IF (IERR.NE.0) GOTO 210 286 : IF (IVECT.EQ.1) THEN 287 : MPTVAL=IVACAR 288 : IF (IVAL(NBRTOT).EQ.0) THEN 289 : IVECT=2 290 : NOMID=MOCARA 291 : SEGACT,NOMID 292 : NBRFAC=NBRFAC+2 293 : SEGADJ,NOMID 294 : MOCARA=NOMID 295 : LESFAC(NBRFAC-2)='VX ' 296 : LESFAC(NBRFAC-1)='VY ' 297 : LESFAC(NBRFAC) ='VZ ' 298 : NBTYPE=1 299 : SEGINI,NOTYPE 300 : MOTYPE=NOTYPE 301 : TYPE(1)='REAL*8' 301 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3, 302 : . IVACAR) 303 : SEGSUP,NOTYPE 304 : IF (IERR.NE.0) GOTO 210 305 : ENDIF 306 : ENDIF 307 : ENDIF 308 : NCARA=NBROBL 309 : NCARF=NBRFAC 310 : NCARR=NCARA+NCARF 311 : IF (IVACAR.NE.0) THEN 312 : MPTVAL=IVACAR 313 : DO i=1,IVAL(/1) 314 : IPMELV=IVAL(i) 314 : CALL QUELCH(IPMELV,ICONS) 315 : IF (ICONS.NE.0) THEN 315 : CALL ERREUR(566) 316 : GOTO 210 317 : ENDIF 318 : ENDDO 319 : ENDIF 320 : C ===== 321 : C 3.8 - Activation du maillage elementaire MELEME 322 : C ===== 323 : MELEME=IPMAIL 324 : SEGACT,MELEME 325 : NBNN=NUM(/1) 326 : NBELEM=NUM(/2) 327 : C ===== 328 : C 3.9 - Initialisation du MCHAML resultat (MCHAML) associe au modele 329 : C elementaire iSou (de maillage IPMAIL) SI demande 330 : C Remplissage des donnees associees a MCHAML dans MCHELM (global) 331 : C ===== 332 : MCHEL1=IPCHE1 333 : SEGACT,MCHEL1 334 : IF (KOPELE.NE.0) THEN 335 : C= 3.9.1 - Initialisation de MCHAML 336 : N2=1 337 : SEGINI,MCHAML 338 : NOMCHE(N2)='SCAL' 339 : TYPCHE(N2)='REAL*8' 340 : C= 3.9.2 - Remplissage de MCHEML(iSou) 341 : CONCHE(iSouss)=CONM 342 : IMACHE(iSouss)=IPMAIL 343 : ICHAML(iSouss)=MCHAML 344 : INFCHE(iSouss,1)=0 345 : INFCHE(iSouss,2)=0 346 : INFCHE(iSouss,3)=NIFOUR 347 : INFCHE(iSouss,4)=MCHEL1.INFCHE(iSouss,4) 348 : IF (mincdg.NE.0) INFCHE(iSouss,4)=mincdg 349 : INFCHE(iSouss,5)=0 350 : INFCHE(iSouss,6)=2 351 : C= 3.9.3 - Initialisation du MELVAL associe a ce MCHAML 352 : N1PTEL=1 353 : N1EL=NBELEM 354 : N2PTEL=0 355 : N2EL=0 356 : SEGINI,MELVA2 357 : IELVAL(N2)=MELVA2 358 : IPMEL2=MELVA2 359 : ENDIF 360 : C ====== 361 : C 3.10 - Recuperation des donnees d'integration 362 : C Traitement particulier dans le cas du COQ4 (si le nombre de 363 : C points de Gauss vaut 5, seuls les 4 premiers sont traites, le 364 : C 5e servant uniquement au cisaillement) 365 : C ====== 366 : C* MINTE=IPMINT 367 : C* SEGACT,MINTE <- Deja ACTIF 368 : NBPGAU=POIGAU(/1) 369 : NBNO=NBNN 370 : IF (MELE.EQ.49) THEN 371 : IF (NBPGAU.EQ.5) NBPGAU=4 372 : IF (NBPTEL.EQ.5) NBPTEL=4 373 : ENDIF 374 : C ====== 375 : C 3.11 - Initialisation de quelques segments de travail 376 : C ====== 377 : SEGINI,MWRK1 378 : IF (LOGCOQ) THEN 379 : SEGINI,MWRK2 380 : SEGACT,MINTE1 381 : SEGINI,MWRK3 382 : ELSE IF (IPCHE2.NE.0) THEN 383 : SEGINI,MWRK3 384 : ENDIF 385 : C ====== 386 : C 3.12 - Boucle sur les elements du sous-modele elementaire 387 : C ====== 388 : DO IB=1,NBELEM 389 : C= 3.12.1 - Recuperation des coordonnees des noeuds de l element IB 389 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL) 390 : C= 3.12.2 - Determination des axes locaux aux noeuds (elements COQUES) 391 : IF (LOGCOQ) THEN 391 : CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR) 392 : IF (IRR.EQ.0) THEN 392 : CALL ERREUR(515) 393 : GOTO 200 394 : ENDIF 395 : IF (IVACAR.NE.0) THEN 396 : MPTVAL=IVACAR 397 : DO iGau=1,NBPGAU 398 : MELVAL=IVAL(1) 399 : IGMN=MIN(iGau,VELCHE(/1)) 400 : IBMN=MIN(IB,VELCHE(/2)) 401 : WORK(iGau)=VELCHE(IGMN,IBMN) 402 : IF (IVAL(2).NE.0) THEN 403 : MELVAL=IVAL(2) 404 : IGMN=MIN(iGau,VELCHE(/1)) 405 : IBMN=MIN(IB,VELCHE(/2)) 406 : WORK(20+iGau)=VELCHE(IGMN,IBMN) 407 : ELSE 408 : WORK(20+iGau)=0. 409 : ENDIF 410 : ENDDO 411 : ELSE 412 : C* Si pas de caracteristiques, on met les epaisseurs a 1 (et non a 0) 413 : DO iGau=1,NBPGAU 414 : WORK(iGau)=1. 415 : ENDDO 416 : ENDIF 417 : ENDIF 418 : C= 3.12.3 - Boucle sur les points d'integration 419 : ESTEL=XZero 420 : DO iGau=1,NBPGAU 421 : IBMN=MIN(IB,MELVA1.VELCHE(/2)) 422 : IGMN=MIN(iGau,MELVA1.VELCHE(/1)) 423 : FACSCA=MELVA1.VELCHE(IGMN,IBMN) 424 : C= 3.12.3.1 - Elements COQUES 425 : IF (LOGCOQ) THEN 426 : E3=DZEGAU(iGau) 426 : CALL CQ8JCE(iGau,NBNN,E3,XEL,WORK(1),WORK(21), 427 : . TXR,SHPTOT,XJ,DJAC,IRR) 428 : IF (IRR.LT.0) THEN 429 : INTERR(1)=IB 429 : CALL ERREUR(405) 430 : GOTO 200 431 : ENDIF 432 : DJAC=ABS(DJAC)*POIGAU(iGau) 433 : ESTEL=ESTEL+FACSCA*DJAC 434 : C= 3.12.3.2 - Elements JOINTS 2D 435 : ELSE IF (MFR.EQ.35.AND.IDIM.EQ.2) THEN 436 : DO i=1,NBNO 437 : SHP(1,i)=SHPTOT(1,i,iGau) 438 : SHP(2,i)=SHPTOT(2,i,iGau) 439 : ENDDO 440 : DXDKSI=0. 441 : DYDKSI=0. 442 : DO i=1,NBNO/2 443 : DXDKSI=DXDKSI+SHP(2,i)*XEL(1,i) 444 : DYDKSI=DYDKSI+SHP(2,i)*XEL(2,i) 445 : ENDDO 446 : DJAC=SQRT(DXDKSI*DXDKSI+DYDKSI*DYDKSI)*POIGAU(iGau) 447 : ESTEL=ESTEL+FACSCA*DJAC 448 : C= 3.12.3.3 - Elements JOINTS 3D (JOT3 et JOI4) 449 : ELSE IF (MFR.EQ.35.AND.IDIM.EQ.3) THEN 450 : DO i=1,NBNO 451 : SHP(1,i)=SHPTOT(1,i,iGau) 452 : SHP(2,i)=SHPTOT(2,i,iGau) 453 : SHP(3,i)=SHPTOT(3,i,iGau) 454 : ENDDO 455 : IF (MELE.EQ.87) THEN 455 : CALL JT3LOC(XEL,SHPTOT,NBNO,XE,BPSS,NOQUAL) 456 : IF (NOQUAL.EQ.1) THEN 457 : INTERR(1)=IB 458 : MOTERR(1:4)='JOT3' 458 : CALL ERREUR(765) 459 : GOTO 200 460 : ELSE IF (NOQUAL.EQ.2) THEN 461 : INTERR(1)=IB 462 : MOTERR(1:4)='JOT3' 462 : CALL ERREUR(766) 463 : GOTO 200 464 : ENDIF 465 : ELSE IF (MELE.EQ.88) THEN 465 : CALL JO4LOC(XEL,SHPTOT,NBNO,XE,BPSS,NOQUAL) 466 : IF (NOQUAL.EQ.1) THEN 467 : INTERR(1)=IB 468 : MOTERR(1:4)='JOI4' 468 : CALL ERREUR(765) 469 : GOTO 200 470 : ELSE IF (NOQUAL.EQ.2) THEN 471 : INTERR(1)=IB 472 : MOTERR(1:4)='JOI4' 472 : CALL ERREUR(766) 473 : GOTO 200 474 : ENDIF 475 : ENDIF 476 : NBNONN=NBNO/2 476 : CALL DEVOLU(XE,SHP,MFR,NBNONN,IFOUR,NIFOUR,2,1.D0,RR,DJAC) 477 : IRRT=0 478 : IF (DJAC.LT.0.) THEN 479 : IRRT=1 480 : ELSE IF (DJAC.EQ.0.) THEN 481 : IRRT=2 482 : ENDIF 483 : IF (IRRT.NE.0) THEN 483 : CALL ERREUR(764) 484 : GOTO 200 485 : ENDIF 486 : ESTEL=ESTEL+FACSCA*DJAC*POIGAU(iGau) 487 : C= 3.12.3.4 - Elements zone cohesive ZCO2 488 : ELSE IF (MFR.EQ.77.AND.IDIM.EQ.2) THEN 489 : DO i=1,NBNO 490 : SHP(1,i)=SHPTOT(1,i,iGau) 491 : SHP(2,i)=SHPTOT(2,i,iGau) 492 : ENDDO 493 : DXDKSI=0. 494 : DYDKSI=0. 495 : DO i=1,NBNO 496 : DXDKSI=DXDKSI+SHP(2,i)*XEL(1,i) 497 : DYDKSI=DYDKSI+SHP(2,i)*XEL(2,i) 498 : ENDDO 499 : DJAC=SQRT(DXDKSI*DXDKSI+DYDKSI*DYDKSI)*POIGAU(iGau) 500 : ESTEL=ESTEL+FACSCA*DJAC 501 : C= 3.12.3.3 - Elements zone cohesive ZCO3ou4 502 : ELSE IF (MFR.EQ.77.AND.IDIM.EQ.3) THEN 503 : DO i=1,NBNO 504 : SHP(1,i)=SHPTOT(1,i,iGau) 505 : SHP(2,i)=SHPTOT(2,i,iGau) 506 : SHP(3,i)=SHPTOT(3,i,iGau) 507 : ENDDO 508 : dXdQsi=0.D0 509 : dYdQsi=0.D0 510 : dZdQsi=0.D0 511 : dXdEta=0.D0 512 : dYdEta=0.D0 513 : dZdEta=0.D0 514 : DO i=1,NBNO 515 : dXdQsi=dXdQsi+SHP(2,i)*XEL(1,i) 516 : dXdEta=dXdEta+SHP(3,i)*XEL(1,i) 517 : dYdQsi=dYdQsi+SHP(2,i)*XEL(2,i) 518 : dYdEta=dYdEta+SHP(3,i)*XEL(2,i) 519 : dZdQsi=dZdQsi+SHP(2,i)*XEL(3,i) 520 : dZdEta=dZdEta+SHP(3,i)*XEL(3,i) 521 : ENDDO 522 : z = (dXdQsi*dYdEta-dXdEta*dYdQsi) 523 : x = (dYdQsi*dZdEta-dYdEta*dZdQsi) 524 : y = (dZdQsi*dXdEta-dZdEta*dXdQsi) 525 : DJAC = sqrt(x*x+y*y+z*z) 526 : IRRT=0 527 : IF (DJAC.LT.0.) THEN 528 : IRRT=1 529 : ELSE IF (DJAC.EQ.0.) THEN 530 : IRRT=2 531 : ENDIF 532 : IF (IRRT.NE.0) THEN 532 : CALL ERREUR(764) 533 : GOTO 200 534 : ENDIF 535 : ESTEL=ESTEL+FACSCA*DJAC*POIGAU(iGau) 536 : C= 3.12.3.4 - Autres elements 537 : ELSE 538 : IF (IFOMOD.EQ.2) THEN 539 : IDK=4 540 : ELSE IF (IFOMOD.GE.-1.AND.IFOMOD.LE.1) THEN 541 : IDK=3 542 : ELSE IF (IFOMOD.GE.3.AND.IFOMOD.LE.5) THEN 543 : IDK=2 544 : ENDIF 545 : DO j=1,NBNO 546 : DO i=1,IDK 547 : SHP(i,j)=SHPTOT(i,j,iGau) 548 : ENDDO 549 : ENDDO 549 : CALL GTEMRD(XEL,SHP,JDIM,NBNO,DJAC) 550 : IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1.OR. 551 : . IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN 551 : CALL DISTRR(XEL,SHP,NBNO,RR) 552 : IF (IFOMOD.EQ.5) THEN 553 : DJAC=X4Pi*RR*RR*DJAC 554 : ELSE IF (IFOMOD.EQ.1.AND.NIFOUR.NE.0) THEN 555 : DJAC=XPi*RR*DJAC 556 : ELSE 557 : DJAC=X2Pi*RR*DJAC 558 : ENDIF 559 : ENDIF 560 : C= 3.12.3.5 - Recuperation des caracteristiques selon l'element 561 : C= En dimension 1 (1D), pas de caracteristiques actuellement 562 : DIM3=1. 563 : FACAR=1. 564 : IF (IVACAR.EQ.0) GOTO 80 565 : MPTVAL=IVACAR 566 : GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 567 : . 4,99,99,99,99,99, 4, 4, 4, 4,27,27,29,99,99,99,99 568 : . ,99, 4, 4, 4, 4, 4, 4,27,29,99,27,99,27,99,99,27 569 : . ,99,99,99,99,99,99,27, 4, 4, 4, 4,4, 4, 4, 4, 4, 570 : . 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,4, 4, 571 : . 4,29,99,99,99,99,99,99,99,99,27,99,99,99,99,99,99 572 : . ,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99 573 : . ,99,99,99,99,99,99,99,99,27,27),MELE 574 : 99 MOTERR(1:4)=NOMTP(MELE) 575 : MOTERR(5:12)='INTGCA' 575 : CALL ERREUR(86) 576 : GOTO 200 577 : C= 3.12.3.6 - Caracteristiques pour les elements MASSIFS 578 : 4 MELVAL=IVAL(1) 579 : IF (MELVAL.NE.0) THEN 580 : IGMN=MIN(iGau,VELCHE(/1)) 581 : IBMN=MIN(IB,VELCHE(/2)) 582 : FACAR=VELCHE(IGMN,IBMN) 583 : ENDIF 584 : GOTO 80 585 : C= 3.12.3.7 - Caracteristiques pour les elements COQUES et BARRES 586 : 27 MELVAL=IVAL(1) 587 : IGMN=MIN(iGau,VELCHE(/1)) 588 : IBMN=MIN(IB, VELCHE(/2)) 589 : FACAR=VELCHE(IGMN,IBMN) 590 : IF (MFR.EQ.3.AND.IFOUR.EQ.-2) THEN 591 : MELVAL=IVAL(3) 592 : IF (MELVAL.NE.0) DIM3=VELCHE(IGMN,IBMN) 593 : ENDIF 594 : GOTO 80 595 : C= 3.12.3.8 - Caracteristiques pour les elements POUTRES et TUYAUX 596 : C= Traitement particulier pour les TUYAUX 597 : 29 DO i=1,NCARR 598 : IF (IVAL(i).NE.0) THEN 599 : MELVAL=IVAL(i) 600 : IGMN=MIN(iGau,VELCHE(/1)) 601 : IBMN=MIN(IB,VELCHE(/2)) 602 : WORK(i)=VELCHE(IGMN,IBMN) 603 : ENDIF 604 : ENDDO 605 : IF (IVECT.EQ.1) THEN 606 : IF (IVAL(NCARR).NE.0) THEN 607 : MELVAL=IVAL(NCARR) 608 : IBMN=MIN(IB,IELCHE(/2)) 609 : IREF=(IELCHE(1,IBMN)-1)*(IDIM+1) 610 : DO i=1,IDIM 611 : WORK(NCARR+i-1)=XCOOR(IREF+i) 612 : ENDDO 613 : ELSE 614 : DO i=0,IDIM-1 615 : WORK(NCARR+i)=0. 616 : ENDDO 617 : ENDIF 618 : ENDIF 619 : IF (MELE.EQ.42) THEN 620 : CISA=WORK(4) 621 : VX=WORK(5) 622 : VY=WORK(6) 623 : VZ=WORK(7) 623 : CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2) 624 : ENDIF 625 : FACAR=WORK(4) 626 : GOTO 80 627 : C= 3.12.3.9 - Calcul de la composante integree en ce point de Gauss 628 : 80 DJAC=ABS(DJAC)*POIGAU(iGau)*FACAR*DIM3 629 : ESTEL=ESTEL+FACSCA*DJAC 630 : ENDIF 631 : ENDDO 632 : C= 3.12.4 - Ajout de la contribution de cet element au resultat 633 : C= et le cas echeant au MCHAML au centre de gravite 634 : XRET=XRET+ESTEL 635 : IF (KOPELE.NE.0) THEN 636 : IBMN=MIN(IB,MELVA2.VELCHE(/2)) 637 : MELVA2.VELCHE(1,IBMN)=ESTEL 638 : ENDIF 639 : ENDDO 640 : C ====== 641 : C 3.13 - Desactivation/suppression de segments associes a iSou 642 : C Sortie prematuree en cas d'ERREUR (iOK=0) 643 : C ====== 644 : iOK=1 645 : 200 SEGSUP,MWRK1 646 : IF (LOGCOQ) THEN 647 : SEGSUP,MWRK2 648 : SEGDES,MINTE1 649 : SEGSUP,MWRK3 650 : ELSE IF (IPCHE2.NE.0) THEN 651 : SEGSUP,MWRK3 652 : ENDIF 653 : SEGDES,MELEME 653 : 210 CALL DTMVAL(IVACAR,1) 654 : 220 NOMID=MOCARA 655 : IF (MOCARA.NE.0) SEGSUP,NOMID 656 : IF (IPMEL1.NE.0) THEN 657 : IF (ISup1.EQ.1) THEN 658 : SEGSUP,MELVA1 659 : ELSE 660 : SEGDES,MELVA1 661 : ENDIF 662 : ENDIF 662 : 230 CALL DTMVAL(IVACOM,1) 663 : SEGDES,MINTE 664 : 240 CONTINUE 665 : 250 SEGDES,IMODEL 666 : IF (iOK.EQ.0) THEN 667 : IF (KOPELE.NE.0) THEN 668 : IF (IPMEL2.NE.0) SEGSUP,MELVA2 669 : IF (MCHAML.NE.0) SEGSUP,MCHAML 670 : SEGSUP,MCHELM 671 : ENDIF 672 : GOTO 300 673 : ENDIF 674 : IF (KOPELE.NE.0) SEGDES,MELVA2,MCHAML 675 : 2000 continue 676 : 677 : 678 : C 4 - MENAGE : DESACTIVATION/DESTRUCTION DE SEGMENTS 679 : C ==================================================== 680 : IRET=1 681 : IF (KOPELE.NE.0)then 682 : if( n1.ne.isouss) then 683 : n1=isouss 684 : segadj mchelm 685 : endif 686 : SEGDES,MCHELM 687 : ENDIF 688 : 300 NOMID=MOCOMP 689 : NOTYPE=MOTYCO 690 : SEGSUP,NOTYPE,NOMID 691 : SEGDES,MMODEL,MCHEL1 692 : 693 : RETURN 694 : END 695 : 696 : 697 : 698 : 699 : 700 : 701 : 702 :
© Cast3M 2003 - All rights reserved.
Disclaimer