C MASSE3 SOURCE BP208322 20/03/11 21:15:13 10550 SUBROUTINE MASSE3(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR, &NCARR,IVECT,ISOUS,NBPGAU,IPMINT,IPMIN2,NDDL,MATE,CMATE, &LHOOK,IPMATR,ILUMP,IIPDPG,IMOD) *---------------------------------------------------------------------* * _________________________________ * * | | * * | calcul de la matrice de masse | * * |________________________________| * * * * coq3/poutre,dkt,coq4,coq8,coq2,dst * * * *---------------------------------------------------------------------* * * * entrees : * * ________ * * * * ipmail pointeur sur un segment meleme * * lre nombre de ddl dans la matrice de masse * * lw dimension du tableau de travail de l'element * * mele numero de l'element fini * * ivamat pointeur sur un segment mptval pour le materiau * * nmatt nombre de composante de materiau (imat=1) * * ivacar pointeur sur un segment mptval pour les caracteri- * * stiques * * ncarr nombre de caracteristiques geometriques * * ivect flag indiquant si on a entree les axes locaux * * isous numero de la sous-zone * * nbpgau nombre de point d'integration pour la masse * * ipmint pointeur sur un segment minte * * ipmin1 pointeur sur un segment minte (aux noeuds) * * nddl nombre de degre de liberte /noeud * * mate numero du materiau * * cmate nom du materiau * * ilump =1 si l'opérateur lump est appelé * * * * sorties : * * ________ * * * * ipmatr pointeur sur la matrice de masse de la sous-zone * * * *---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC CCREEL *- -INC SMRIGID -INC SMCHAML -INC SMELEME -INC SMCOORD -INC SMINTE -INC SMMODEL C SEGMENT WRK1 REAL*8 REL(LRE,LRE),XE(3,NBBB) ENDSEGMENT C SEGMENT WRK2 REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE) ENDSEGMENT C C SEGMENT WRK3 REAL*8 DDHOOK(LHOOK,LHOOK) REAL*8 WORK(LW) ENDSEGMENT C SEGMENT WRK4 REAL*8 BPSS(3,3),XEL(3,NBBB) ENDSEGMENT C SEGMENT WRK6 REAL*8 RHOMAT(6,6) ENDSEGMENT C SEGMENT MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT C SEGMENT MPTVAL INTEGER IPOS(NS),NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * DIMENSION CRIGI(12),CMASS(12) CHARACTER*8 CMATE * MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) * NV1=NMATT SEGINI,MVELCH * xMATRI=IPMATR LVAL = (LRE*(LRE+1))/2 NLIGRP=LRE NLIGRD=LRE * * introduction du point autour duquel se fait le mouvement * de la section en defo plane generalisee * IF (IFOUR.EQ.-3)THEN IP=IIPDPG SEGACT MCOORD IREF=(IP-1)*(IDIM+1) XDPGE=XCOOR(IREF+1) YDPGE=XCOOR(IREF+2) ELSE XDPGE=0.D0 YDPGE=0.D0 ENDIF * NHRM=NIFOUR * MINTE=IPMINT MINTE2=IPMIN2 IMODEL = IMOD jmat = 0 DO imat = 1 , matmod(/2) if (matmod(imat).eq.'IMPEDANCE') then jmat = imat endif ENDDO C_______________________________________________________________________ C C NUMERO DES ETIQUETTES : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : C 5 CONTINUE C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... C 44 CONTINUE C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... C_______________________________________________________________________ C GOTO(99,2,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 199,99,99,99,99,99,2,28,2,99,99,99,99,99,99,99,99,99,99,99, 241,27,99,44,2,99,99,99,49,99,99,99,99,99,99,41,99,99,99,99, 399,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 499,99,99,27,99,99,99,99,99,99,99,99,93,99,99,99,27),MELE GOTO 99 C_______________________________________________________________________ C_______________________________________________________________________ C C IMPEDANCE C_______________________________________________________________________ C 2 CONTINUE IF (jmat.gt.0) THEN MPTVAL=IVAMAT MELVAL=IVAL(1) if (ival(/1).gt.1) then melva1 = ival(2) else melva1 = 0 endif jddl = LRE/NBPGAU DO IB = 1,NBELEM JDIAG = 0 IBMN=MIN(IB,VELCHE(/2)) do IG = 1, NBPGAU igmn = MIN(IG,VELCHE(/1)) XMASS=VELCHE(IGMN,IBMN) XINER = XMASS if (melva1.gt.0) then igmn = MIN(IG,melva1.VELCHE(/1)) XINER = melva1.VELCHE(IGMN,IBMN) endif do idl = 1,jddl JDIAG = JDIAG + 1 RE(JDIAG,JDIAG,ib) = XMASS if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINER if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINER enddo enddo ENDDO SEGDES XMATRI GOTO 510 ENDIF C_______________________________________________________________________ C C ELEMENTS COQ3 ET POUTRES C_______________________________________________________________________ C 27 CONTINUE IF (ILUMP .EQ. 1 ) THEN C LUMP NE FONCTIONNE PAS POUR L'éLéMENT LSE2 IF (MELE.EQ.97) GOTO 99 C LUMP NE FONCTIONNE PAS POUR L'éLéMENT TIMO SECTION IF (MELE .EQ. 84 .AND. CMATE.EQ.'SECTION') GOTO 99 ENDIF C C CAS DES COQUES - POUTRES - TUYAUX - ACOUSTIQUE PURE C NBBB=NBNN SEGINI WRK1,WRK3 * * cas du materiau section * NBGMAT = 0 NELMAT = 0 IF(CMATE.EQ.'SECTION') THEN MPTVAL=IVAMAT DO IM=1,NMATT IF(IVAL(IM).NE.0)THEN MELVAL=IVAL(IM) NBGMAT=MAX(NBGMAT,IELCHE(/1)) NELMAT=MAX(NELMAT,IELCHE(/2)) END IF END DO ENDIF C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3027 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C IF(MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.97. $ OR.MELE.EQ.84) GO TO 5029 C C CAS DU COQ3 C ----------- MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) RR=VELCHE(1,IBMN) MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) RR=RR*VELCHE(1,IBMN) C CALL COQ3MA(XE,RR,WORK,REL,ILUMP) GOTO 4027 C C CAS DES POUTRES ET DU TUYAU ACOUSTIQUE PURE C ------------------------------------------- C ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES ET MATERIELLES DANS WORK C 5029 CONTINUE C C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB ( GEOMETRIE ET MASSE C NCARR1=NCARR IF(IVECT.EQ.1) NCARR1=NCARR-1 CALL ZERO(WORK,NCARR1,1) DO 4029 IGAU=1,NBNN MPTVAL=IVACAR DO 6029 IC=1,NCARR1 MELVAL=IVAL(IC) IF (IVAL(IC).NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) ELSE WORK(IC)=0.D0 ENDIF IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 6029 CONTINUE 4029 CONTINUE C C CAS OU ON A LU LE MOT VECTEUR C IF (IVECT.EQ.1) THEN IF (IVAL(NCARR).NE.0) THEN MELVAL=IVAL(NCARR) IBMN=MIN(IB,IELCHE(/2)) IP=IELCHE(1,IBMN) IREF=(IP-1)*(IDIM+1) DO 6129 IC=1,IDIM WORK(NCARR+IC-1)=XCOOR(IREF+IC) 6129 CONTINUE ELSE DO 6229 IC=1,IDIM WORK(NCARR+IC-1)=0 6229 CONTINUE ENDIF ENDIF C MPTVAL=IVAMAT C C CAS DE L'ACOUSTIQUE PURE C IF (MELE.EQ.97) THEN DO 7029 IM=1,NMATT MELVAL=IVAL(IM) IBMN=MIN(IB,VELCHE(/2)) WORK(IM+9)=VELCHE(1,IBMN) 7029 CONTINUE C C CAS DES POUTRES ET TUYAU C ELSE MELVAL=IVAL(1) IF(CMATE.NE.'SECTION') THEN IBMN=MIN(IB,VELCHE(/2)) C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN WORK(4)=VELCHE(1,IBMN) ELSE WORK(10)=VELCHE(1,IBMN) ENDIF C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE C -------------- EQUIVALENTE C IF(MELE.EQ.42)THEN CISA=WORK(4) VX=WORK(5) VY=WORK(6) VZ=WORK(7) CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,1) ENDIF ELSE * * cas formulation section * IBMN=MIN(IB,IELCHE(/2)) IPMODL=IELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,IELCHE(/2)) IPMAT=IELCHE(1,IBMN) IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)THEN CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS) CALL DOHTIF(CMASS,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF ENDIF C C ON CALCULE LA MATRICE DE MASSE C IF (MELE.EQ.97) THEN CALL ACOMAS(REL,LRE,WORK,XE,KERRE) ELSE IF (MELE.EQ.84) THEN IF(CMATE.NE.'SECTION') THEN IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIMMA2(REL,LRE,WORK,XE,WORK(11),KERRE) ELSE CALL TIMMAS(REL,LRE,WORK,XE,WORK(11),KERRE) ENDIF ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIFMA2(REL,LRE,XE,WORK(11),LHOOK, & DDHOOK,KERRE) ELSE CALL TIFMAS(REL,LRE,WORK,XE,WORK(11),LHOOK, & DDHOOK,KERRE) ENDIF ENDIF ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL POUMA2(REL,LRE,WORK,XE,WORK(11),KERRE) ELSE CALL POUMAS(REL,LRE,WORK,XE,WORK(11),KERRE) ENDIF ENDIF C IF(KERRE.EQ.0) GO TO 4027 INTERR(1)=ISOUS INTERR(2)=IB SEGSUP WRK1,WRK3,MVELCH CALL ERREUR(128) SEGSUP xMATRI GO TO 510 C 4027 CONTINUE * SEGINI XMATRI * IMATTT(IB)=XMATRI IF (ILUMP.EQ. 1) THEN IF (MELE.EQ.27) THEN * call lump3(rel) CALL REMPMT(REL,LRE,RE(1,1,ib)) ELSE CALL LUMP6(REL,LRE,RE(1,1,ib)) C CALL LUMP3(REL) ENDIF ELSE CALL REMPMT(REL,LRE,RE(1,1,ib)) ENDIF * SEGDES XMATRI 3027 CONTINUE SEGDES xMATRI SEGSUP WRK1,WRK3,MVELCH GO TO 510 C_______________________________________________________________________ C C ELEMENT DKT C_______________________________________________________________________ C 28 CONTINUE NBNO=NBNN NBBB=NBNN NDDL=3 SEGINI WRK1,WRK2,WRK4 C C PLACE DE LA MASSE VOLUMIQUE DANS LE CHAMP DE MATERIAU: C C DO 3028 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL ZERO(REL,LRE,LRE) CALL VPAST(XE,BPSS) CALL VCORLC(XE,XEL,BPSS) C C ACQUISITION DES EPAISSEURS C EPAIST=0.D0 EXCEN=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) EPAIST=EPAIST+VELCHE(IGMN,IBMN) ENDDO ENDIF C MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) EXCEN=EXCEN+VELCHE(IGMN,IBMN) ENDDO ENDIF EPAIST=EPAIST/NBPGAU EXCEN=EXCEN/NBPGAU C C BOUCLE SUR LES POINTS DE GAUSS C MPTVAL=IVAMAT MELVAL=IVAL(1) DO 5028 IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) CALL NDKT (IGAU,XEL,EXCEN,SHPTOT,SHPWRK,BGENE,DJAC) DJAC=DJAC*POIGAU(IGAU)*EPAIST DJAC=DJAC*VELCHE(IGMN,IBMN) CALL NTNST(BGENE,DJAC,LRE,NDDL,REL) 5028 CONTINUE C C C DIAGONALISATION DANS LE CAS DE L'OPéRATEUR LUMP C C REL EST RANGé DANS L'ORDRE I NOEUD X(UX UY UZ RX RY RZ) .... C IF ( ILUMP .EQ. 1 ) THEN CALL LUMP3(REL) ENDIF C C C ICOM = 0 IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4.AND.ILUMP.EQ.0) & ICOM=1 CALL TRANSK(REL,BPSS,LRE,3,ICOM) * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,ib)) * SEGDES XMATRI 3028 CONTINUE SEGSUP WRK1,WRK2,WRK4,MVELCH segdes xmatri GOTO 510 C_______________________________________________________________________ C C ELEMENT COQ6 COQ8 C_______________________________________________________________________ C 41 CONTINUE NBBB=NBNN SEGINI WRK1,WRK3 C DO 3041 IB=1,NBELEM c coordonnees XE CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) cbp,2020 : COQ8MA attend des valeurs constantes par element (probablement c car le support du materiau n'est pas forcement celui de la masse) c ==> on prend la moyenne (et pas seulement le 1er point de Gauss!) c WORK n'est pas utilise ==> on ne le remplit pas ! c C MASSE VOLUMIQUE MPTVAL=IVAMAT MELVAL=IVAL(1) NGAU=VELCHE(/1) IBMN=MIN(IB,VELCHE(/2)) IF(NGAU.EQ.1) THEN RHO=VELCHE(1,IBMN) ELSE RHO=0.D0 DO IGAU=1,NGAU RHO=RHO+VELCHE(IGAU,IBMN) ENDDO RHO=RHO/NGAU ENDIF c VALMAT(1)=RHO C C EPAISSEUR ET EXCENREMENT MPTVAL=IVACAR IF (IVAL(1).NE.0) THEN MELVAL=IVAL(1) c DO IGAU=1,NBPGAU c IGMN=MIN(IGAU,VELCHE(/1)) c IBMN=MIN(IB ,VELCHE(/2)) c WORK(IGAU)=VELCHE(IGMN,IBMN) c ENDDO c RR=VALMAT(1)*VELCHE(1,IBMN) NGAU=VELCHE(/1) IF(NGAU.EQ.1) THEN EPAI=VELCHE(1,IBMN) ELSE EPAI=0.D0 DO IGAU=1,NGAU EPAI=EPAI+VELCHE(IGAU,IBMN) ENDDO EPAI=EPAI/NGAU ENDIF ELSE c on ne devrait pas passer par la c WORK(IGAU)=0 CALL ERREUR(5) ENDIF IF (IVAL(2).NE.0) THEN MELVAL=IVAL(2) c DO IGAU=1,NBPGAU c IGMN=MIN(IGAU,VELCHE(/1)) c IBMN=MIN(IB ,VELCHE(/2)) c WORK(IGAU+10)=VELCHE(IGMN,IBMN) c ENDDO NGAU=VELCHE(/1) IF(NGAU.EQ.1) THEN EXENT=VELCHE(1,IBMN) ELSE EXENT=0.D0 DO IGAU=1,NGAU EXENT=EXENT+VELCHE(IGAU,IBMN) ENDDO EXENT=EXENT/NGAU ENDIF ELSE c WORK(IGAU+10)=0 EXENT=0.D0 ENDIF C c RHO=VALMAT(1) c EPAI = WORK(1) c EXENT= WORK(11) cnewparadigm SEGDES WRK1,WRK3 cnewparadigm SEGDES MINTE CALL COQ8MA(NBNN,RHO,NBPGAU,EPAI,EXENT,WRK1,MINTE,MINTE2) cnewparadigm SEGACT WRK1,WRK3*MOD cnewparadigm SEGACT MINTE * SEGINI XMATRI * IMATTT(IB)=XMATRI IF (ILUMP .EQ. 1) THEN CALL LUMP7(REL,LRE,RE,NBNN) ELSE CALL REMPMT(REL,LRE,RE(1,1,ib)) ENDIF * SEGDES XMATRI 3041 CONTINUE SEGDES xMATRI SEGSUP WRK1,WRK3,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES COQ2 C_______________________________________________________________________ C 44 CONTINUE DIM3=1.D0 NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK3 I255=0 I256=0 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3044 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) EP=VELCHE(1,IBMN) IF(IFOUR.EQ.-2) THEN MELVAL=IVAL(3) IF(MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) DIM3=VELCHE(1,IBMN) ELSE DIM3=1.D0 ENDIF ENDIF C MPTVAL=IVAMAT DO 4044 IM=1,NMATT MELVAL=IVAL(IM) IBMN=MIN(IB,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) 4044 CONTINUE RHO=VALMAT(1) C C APPEL A LA SUBROUTINE CALCULANT LA MATRICE MASSE C CALL COQ2MA(XE,EP,DIM3,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR, + XDPGE,YDPGE) C C GESTION D'ERREUR C IF(IARR.EQ.1) I255=IB IF(IARR.EQ.2) I256=IB C C REMPLISSAGE C C * SEGINI XMATRI * IMATTT(IB)=XMATRI IF (ILUMP .EQ. 1) THEN CALL LUMP5(REL,LRE,RE(1,1,ib),IFOUR) ELSE CALL REMPMT(REL,LRE,RE(1,1,ib)) ENDIF * SEGDES XMATRI 3044 CONTINUE C C IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR... C IF(I255.NE.0) THEN INTERR(1)=I255 CALL ERREUR(255) ENDIF IF(I256.NE.0) THEN INTERR(1)=I256 CALL ERREUR(256) ENDIF C SEGDES xMATRI SEGSUP WRK1,WRK3,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES COQ4 C_______________________________________________________________________ C 49 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4,WRK6 IG1=0 IG2=0 IG3=0 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3049 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL ZERO (REL,LRE,LRE) C REPERE LOCAL DU COQ4 ON NE DEMANDE PAS DE VERIFIER LA PLANéITé CALL CQ4LOC(XE,XEL,BPSS,IERT,0) C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) EP=VELCHE(1,IBMN) IF (IVAL(2).NE.0) THEN MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) EXCEN =VELCHE(1,IBMN) ELSE EXCEN=0.D0 ENDIF C MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) VALMAT(1)=VELCHE(1,IBMN) RHO=VALMAT(1) C C CALCUL MATRICE MASSE C CALL ZERO(RHOMAT,6,6) RHOMAT( 1, 1)=RHO*EP RHOMAT( 1, 5)=RHO*EP*EXCEN RHOMAT( 5, 1)=RHOMAT(1,5) RHOMAT( 2, 2)=RHO*EP RHOMAT( 2, 4)=-RHO*EP*EXCEN RHOMAT( 4, 2)=RHOMAT(2,4) RHOMAT( 3, 3)=RHO*EP RHOMAT( 4, 4)=RHO*EP**3/12.D0 + RHO*EP*EXCEN**2 RHOMAT( 5, 5)=RHOMAT(4,4) NBPGAM=NBPGAU-1 DO 4049 IGAU=1,NBPGAM CALL NCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT) C IERT=1 JACOBIANO=<0 IF(IERT.EQ.1) IG3=IB DJAC=DJAC*POIGAU(IGAU) CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL) 4049 CONTINUE C C LA DIAGONALISATION éVENTUELLE A LIEU AVANT LE PASSAGE C EN COORDONNéES GLOBALES C IF ( ILUMP .EQ. 1) THEN CALL LUMP4(REL) ENDIF C CALL TRANSK(REL,BPSS,24,4,0) C C REMPLISSAGE C * SEGINI XMATRI * IMATTT(IB)=XMATRI CALL REMPMT(REL,LRE,RE(1,1,ib)) * SEGDES XMATRI 3049 CONTINUE C C IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR... C IF(IG1.NE.0) THEN INTERR(1)=IG1 CALL ERREUR(323) ENDIF IF(IG2.NE.0) THEN INTERR(1)=IG2 CALL ERREUR(322) ENDIF IF(IG3.NE.0) THEN INTERR(1)=IG3 CALL ERREUR(321) ENDIF C SEGDES xMATRI SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR L'ELEMENT DST C_______________________________________________________________________ C 93 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4,WRK6 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3093 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL ZERO (REL,LRE,LRE) CALL VPAST(XE,BPSS) CALL VCORLC(XE,XEL,BPSS) C C ACQUISITION DES EPAISSEURS C EP=0.D0 EXCEN=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) EP=EP+VELCHE(IGMN,IBMN) ENDDO ENDIF C MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) EXCEN=EXCEN+VELCHE(IGMN,IBMN) ENDDO ENDIF EP=EP/NBPGAU EXCEN=EXCEN/NBPGAU C C BOULE SUR LES POINTS DE GAUSS C DO 5093 IGAU=1,NBPGAU C MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) RHO=VELCHE(IGMN,IBMN) C C CALCUL MATRICE MASSE C CALL ZERO(RHOMAT,6,6) RHOMAT( 1, 1)=RHO*EP RHOMAT( 1, 5)=RHO*EP*EXCEN RHOMAT( 5, 1)=RHOMAT(1,5) RHOMAT( 2, 2)=RHO*EP RHOMAT( 2, 4)=-RHO*EP*EXCEN RHOMAT( 4, 2)=RHOMAT(2,4) RHOMAT( 3, 3)=RHO*EP RHOMAT( 4, 4)=RHO*EP**3/12.D0 + RHO*EP*EXCEN**2 RHOMAT( 5, 5)=RHOMAT(4,4) CALL NDST(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC) DJAC=DJAC*POIGAU(IGAU) CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL) 5093 CONTINUE C C DIAGONALISATION DANS LE CAS DE L'OPéRATEUR LUMP C C REL EST RANGé DANS L'ORDRE I NOEUD X(UX UY UZ RX RY RZ) .... C IF ( ILUMP .EQ. 1 ) THEN CALL LUMP3(REL) ENDIF C C C ICOM = 0 IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4.AND.ILUMP.EQ.0) & ICOM=1 CALL TRANSK(REL,BPSS,18,3,ICOM) C C REMPLISSAGE C * SEGINI XMATRI * IMATTT(IB)=XMATRI CALL REMPMT(REL,LRE,RE(1,1,ib)) * SEGDES XMATRI 3093 CONTINUE SEGDES xMATRI SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH GOTO 510 C_______________________________________________________________________ * 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='MASSE3' CALL ERREUR(86) * 510 CONTINUE RETURN END C