C RIGI3 SOURCE PV090527 26/04/30 21:16:19 12529 SUBROUTINE RIGI3(MATE,MELE,IPMAIL,IPMINT,IPMIN1,NBPGAU,LRE, & NSTRS,IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT, & LHOOK,NMATT,LW,NPINT,IPMATR,IIPDPG) *---------------------------------------------------------------------* * __________________________ * * | | * * | CALCUL DE LA RIGIDITE | * * |________________________| * * * * coq3,dkt,coq4,coq8,coq2,dst * * *---------------------------------------------------------------------* * * * ENTREES : * * ________ * * * * MATE Numero du materiau * * MELE Numero de l'element fini * * IPMAIL Pointeur sur un segment MELEME * * IPMINT Pointeur sur un segment MINTE aux points de Gauss * * IPMIN1 pointeur sur un segment MINTE aux noeuds * * NBPGAU Nombre de point d'integration pour la rigidite * * LRE Nombre de ddl dans la matrice de rigidite * * NSTRS Nombre de composante de contraintes/deformations * * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou * * pour une matrice de hooke * * IVACAR Pointeur sur un segment MPTVAL pour les caracteri- * * stiques * * CMATE Nom du materiau * * MFR Numero de la formulation element fini * * NBGMAT Taille maxi des melval du materiau (pt de gauss) * * NELMAT Taille maxi des melval du materiau (No d'element) * * IMAT (2 il y a une matrice de HOOKE,1 non ) * * NMATT Nombre de composante de materiau (IMAT=1) * * NPINT Nombre de points d'integration dans l'epaisseur * dans le cas des elements de coque integres * * * * SORTIES : * * ________ * * * * IPMATR pointeur sur la rigidite de la sous-zone * * * *---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC CCREEL -INC SMCHAML -INC SMINTE -INC SMELEME -INC SMRIGID -INC SMMODEL -INC SMCOORD -INC SMLREEL -INC TMPTVAL SEGMENT WRK1 REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK) REAL*8 REL(LRE,LRE) , XE(3,NBBB) ENDSEGMENT * SEGMENT WRK2 REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE) ENDSEGMENT * SEGMENT WRK3 REAL*8 WORK(LW) ENDSEGMENT * SEGMENT WRK4 REAL*8 BPSS(3,3) ,XEL(3,NBBB) ENDSEGMENT * SEGMENT WRK5 REAL*8 BGENE1(LHOOK,LRE),POIG(NBPGA1) ENDSEGMENT * SEGMENT,MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT * CHARACTER*8 CMATE * * write(6,*) 'entree dans rigi3 lhook',lhook * C INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT C DE LA SECTION EN DEFO PLANE GENERALISEE IF (IIPDPG.GT.0) THEN C <- test equivalent ici a IFOUR.EQ.-3 C SEGACT MCOORD IREF=(IIPDPG-1)*(IDIM+1) XDPGE=XCOOR(IREF+1) YDPGE=XCOOR(IREF+2) ELSE XDPGE=XZERO YDPGE=XZERO ENDIF * MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) * NV1=NMATT SEGINI,MVELCH * XMATRI=IPMATR C* NLIGRP=LRE C* NLIGRD=LRE * NHRM=NIFOUR * MINTE=IPMINT IRTD=1 C 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,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 1 99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99, 2 41,99,99,44,28,99,99,99,49,99,99,99,99,99,99,41,99,99,99,99, 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 4 99,99,99,99,99,99,99,99,99,99,99,99,93,99,99,99,99),MELE GOTO 99 C_______________________________________________________________________ C C ELEMENT COQ3 C_______________________________________________________________________ C 27 CONTINUE NBBB=NBNN SEGINI WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3027 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LES COEFF DES MAT DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN DO 9027 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9027 CONTINUE IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CHERCHER LES EPAISSEUR ET EXCENTREMENT C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) EPAIST=VELCHE(1,IBMN) IF (IVAL(2).NE.0) THEN MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) EXCEN =VELCHE(1,IBMN) IF (EXCEN.NE.0.D0) THEN CALL ERREUR(474) GO TO 9927 ENDIF ELSE EXCEN=0.D0 ENDIF C C ON CALCULE SA RAIDEUR C CALL COQ3RI(REL,XE,EPAIST,DDHOOK,WORK) C 4027 CONTINUE C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,ib)) 3027 CONTINUE IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9927 CONTINUE SEGSUP WRK1,WRK3 GOTO 510 C_______________________________________________________________________ C C ELEMENT DKT C_______________________________________________________________________ C 28 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 IF(NPINT.NE.0)THEN NBPGA1=NBPGAU/NPINT IF(NBGMAT.NE.1)THEN NBPGEP=NPINT ELSE NBPGEP=1 ENDIF SEGINI WRK5 DO 1028 IG=1,NBPGA1 POIG(IG)=POIGAU(IG) 1028 CONTINUE Ccccc CALL POIDNW(NPINT,NBPGA1,2,POIG) CALL SIMPSN(NPINT,NBPGA1,2,POIG) ENDIF 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) C CALL VPAST(XE,BPSS) C BPSS STOCKE LA MATRICE DE PASSAGE CALL VCORLC (XE,XEL,BPSS) CALL ZERO (REL,LRE,LRE) C C ON CHERCHE LES EPAISEURS ET ON LES MOYENNE, C LES EXCENTREMENTS ET ON LES MOYENNE. C MPTVAL=IVACAR MELVAL=IVAL(1) EPAIST=0.D0 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 EPAIST=EPAIST/NBPGAU ENDIF * MELVAL=IVAL(2) EXCEN=0.D0 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 EXCEN=EXCEN/NBPGAU ENDIF C IF(NPINT.EQ.0)THEN C C COQUE GLOBAL C C BOUCLE SUR LES POINTS DE GAUSS C DO 1128 IGAU=1,NBPGAU * CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, & MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,1.D0,XEL, & SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) DJAC=DJAC*POIGAU(IGAU) C C ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT C IF (EXCEN.NE.0.) THEN DO IJL=1,3 DO IJC=1,LRE BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC) enddo enddo ENDIF C C ON CHERCHE LES COEFFICIENTS DE LA MATRICE DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE, 1 IGAU,IMAT,EXCEN) ELSE IF (IMAT.EQ.1) THEN * DO 9028 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9028 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) CALL BDBS1(BGENE,DJAC,DDHOMU,LRE,NSTRS,REL,MFR,IFOUR,MATE, 1 IGAU,IMAT,EXCEN) ENDIF 1128 CONTINUE C ELSE C C COQUE INTEGREE C C BOUCLE SUR LES POINTS DE GAUSS DE LA SURFACE C DO 1101 IGAU=1,NBPGA1 * CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, & MELE,MFR,NBNO,LRE,IFOUR,LHOOK,0,1.D0,XEL, & SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) C C ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT C IF (EXCEN.NE.0.) THEN DO IJL=1,3 DO IJC=1,LRE BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC) enddo enddo ENDIF C C BOUCLE SUR LES NAPPES DANS L'EPAISSEUR C DO 1102 INAP=1,NBPGEP C IGAU1=(INAP-1)*NBPGA1+IGAU C C CALCUL DE LA MATRICE B CORRESPONDANT AUX DEFORMATIONS 3D C IF(NBGMAT.EQ.1.AND.NPINT.NE.1)THEN ZZZ2 = SQRT( (EPAIST**3.D0)/12.D0 ) ZZZ1 = SQRT( EPAIST ) DO IJL=1,3 DO IJC=1,LRE BGENE1(IJL,IJC) =ZZZ1*BGENE(IJL,IJC) BGENE1(IJL+3,IJC)=ZZZ2*BGENE(IJL+3,IJC) enddo enddo DJAC1=DJAC*POIG(IGAU1) ELSE ZZZ=DZEGAU(IGAU1)*(EPAIST/2.D0) DO IJL=1,3 DO IJC=1,LRE BGENE1(IJL,IJC)=BGENE(IJL,IJC) BGENE1(IJL+3,IJC)=ZZZ*BGENE(IJL+3,IJC) enddo enddo DJAC1=DJAC*POIGAU(IGAU1)*(EPAIST/2.D0) ENDIF C C ON CHERCHE LA MATRICE DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU1.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU1,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DHDKTI(PROG,LHOOK,DDHOOK) SEGDES MLREEL * write(6,*)((ddhook(IU,io),iu=1,6),io=1,6) ENDIF ELSE IF (IMAT.EQ.1) THEN DO 9001 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU1,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9001 CONTINUE IF (IGAU1.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) * write(6,*)((ddhook(IU,io),iu=1,6),io=1,6) ENDIF CALL BDBS1(BGENE1,DJAC1,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE, 1 IGAU,IMAT,EXCEN) 1102 CONTINUE 1101 CONTINUE ENDIF REL(6,6)=REL(5,5)*1.D-7 REL(12,12)=REL(6,6) REL(18,18)=REL(6,6) ICOM=0 IF(ABS(EXCEN).GT.XPETIT .OR. CMATE.EQ.'COMPOSIT' 1 .OR. IMAT.EQ.2) ICOM=1 CALL TRANSK(REL,BPSS,LRE,3,ICOM) C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 3028 CONTINUE IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF SEGSUP WRK1,WRK2,WRK4 IF(NPINT.NE.0)SEGSUP WRK5 GOTO 510 C_______________________________________________________________________ C C ELEMENT COQ8 C_______________________________________________________________________ C 41 CONTINUE NBBB=NBNN NBNO=NBNN SEGINI WRK1,WRK2,WRK3 MINTE1=IPMIN1 SEGACT MINTE1 NBPGA1=MINTE1.SHPTOT(/3) NBN1 =MINTE1.SHPTOT(/2) C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3041 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C CALL ZERO (REL,LRE,LRE) C C ON CHERCHE LES EPAISSEURS ET LES EXCENTREMENTS. C MPTVAL=IVACAR DO 4041 IGAU=1,NBPGAU MELVAL=IVAL(1) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) WORK(IGAU) =VELCHE(IGMN,IBMN) IF (IVAL(2).NE.0) THEN MELVAL=IVAL(2) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) WORK(10+IGAU)=VELCHE(IGMN,IBMN) ELSE WORK(10+IGAU)=0.D0 ENDIF 4041 CONTINUE C C DETERMINATION DES AXES LOCAUX AUX NOEUDS C CALL CQ8LOC(XE,NBNN,MINTE1.SHPTOT,WORK(21),IRR) C C BOUCLE SUR LES POINTS DE GAUSS C DO 3042 IGAU=1,NBPGAU E3=DZEGAU(IGAU) CALL BCOQ8E(IGAU,XE,NBNN,WORK(1),WORK(11),BGENE,DJAC, 1 E3,SHPTOT,WORK(21),IRR) C C GESTION D'ERREUR: IRR=0 CORRESPOND A UN VECTEUR NUL (CF. CROSS2) C IRR=-1 CORRESPOND A UN JACOBIEN NUL(CF. SHLJAC) C IF(IRR.EQ.0) THEN CALL ERREUR(241) GOTO 9941 ELSE IF(IRR.EQ.-1)THEN CALL ERREUR(240) GOTO 9941 ENDIF C DJAC=ABS(DJAC)*POIGAU(IGAU) C C ON CHERCHE LES COEFF DES MAT DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF ((IGAU.LE.NBGMAT).AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF ELSE IF (IMAT.EQ.1) THEN DO 9041 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9041 CONTINUE IF((IGAU.LE.NBGMAT).AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHCOE (VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C ON CALCULE SA RAIDEUR C CALL COQ8RI(BGENE,DJAC,DDHOOK,LRE,NBPGAU,IGAU,NBNN,REL) C 3042 CONTINUE C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 3041 CONTINUE c IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9941 CONTINUE SEGSUP WRK1,WRK2,WRK3 SEGDES MINTE1 GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE COQ2 C_______________________________________________________________________ C 44 CONTINUE DIM3=1.D0 NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 DO 3044 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) if (idim.eq.3.and.ifour.eq.1) then do ii = 1,NBNN jj=idimp1*(NUM(ii,IB)-1) xel(1,ii) = xe(1,ii) xel(2,ii) = xe(2,ii) xel(3,ii) = xe(3,ii) xe(2,ii) = xel(3,ii) xe(3,ii) = XZero enddo endif C CALL ZERO (REL,LRE,LRE) C C BOUCLE SUR LES POINTS DE GAUSS C DO 4044 IGAU=1,NBPGAU MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) EPAIST=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 IF (IFOUR.EQ.-2) THEN IF (IVAL(3).NE.0) THEN MELVAL=IVAL(3) IBMN=MIN(IB,VELCHE(/2)) DIM3 =VELCHE(1,IBMN) ELSE DIM3=1.D0 ENDIF ENDIF C C APPEL A BCOQ2 ... C CALL BCOQ2(BGENE,NSTRS,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU, . EXCEN,DIM3,IRRT,XDPGE,YDPGE) C C GESTION D'ERREUR C LES ERREURS PREVUES SONT LONGEUR DE L'ELEMENT =0 OU RAYON C AU POINT D'INTEGRATION =0 OU RAPPORT R/L TROP PETIT (INFERIEUR C A 1.E-3). C IF(IRRT.EQ.1) THEN INTERR(1)=IB CALL ERREUR(255) GOTO 9944 ELSE IF (IRRT.EQ.2) THEN INTERR(1)=IB CALL ERREUR(256) GOTO 9944 ENDIF C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) ELSE IF (IMAT.EQ.1) THEN * DO 9044 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9044 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) CALL BDBST(BGENE,DJAC,DDHOMU,LRE,NSTRS,REL) ENDIF 4044 CONTINUE C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 3044 CONTINUE C C IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR... IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9944 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE COQ4 C_______________________________________________________________________ C 49 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 c c ... Si le mat\E9riau n'est pas isotrope, dans le cas g\E9n\E9ral les c tensions et le cisaillement NE sont PAS d\E9coupl\E9es. Ce qui veut c dire qu'on n'a pas le droit de les int\E9grer diff\E9remment ... c DO 3049 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C CALL ZERO (REL,LRE,LRE) CALL CQ4LOC(XE,XEL,BPSS,IRRT,1) C IRRT=1 NODI TROPPO VICINI IF(IRRT.EQ.1) THEN INTERR(1)=IB CALL ERREUR(323) GOTO 9949 ELSE IF(IRRT.EQ.3) THEN IRRT = 0 NOPLAN = 1 ELSE NOPLAN = 0 ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) EPAIST=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 DO 4049 IGAU=1,NBPGAU C C APPEL A BCOQ4 C if(cmate.eq.'ISOTROPE') then CALL BCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IRRT, + 0) else CALL BCOQ4O(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IRRT, + 0) endif DJAC=DJAC*POIGAU(IGAU) C IRRT=1 JACOBIANO <= 0 IF(IRRT.EQ.1) THEN INTERR(1)=IB CALL ERREUR(321) GOTO 9949 ENDIF C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ENDIF CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) ELSE IF (IMAT.EQ.1) THEN * DO 9049 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9049 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHCIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) if(cmate.eq.'ISOTROPE') then CALL COQ4RI (IGAU,BGENE,DJAC,EXCEN,NOPLAN,DDHOMU,REL) else CALL COQ4RJ (IGAU,BGENE,DJAC,EXCEN,NOPLAN,DDHOMU,REL) endif ENDIF 4049 CONTINUE C REL(6,6)=REL(5,5)*1.D-7 REL(12,12)=REL(6,6) REL(18,18)=REL(6,6) REL(24,24)=REL(6,6) ICOM=0 IF(ABS(EXCEN).GT.XPETIT .OR.CMATE.EQ.'COMPOSIT' 1 .OR. IMAT.EQ.2) ICOM=1 CALL TRANSK(REL,BPSS,LRE,4,ICOM) C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 3049 CONTINUE C C IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR... IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF 9949 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT DST C_______________________________________________________________________ C 93 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK3,WRK4 IF(CMATE.NE.'ISOTROPE')THEN MPTVAL=IVAMAT IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN MELVAL=IVAL(7) ELSE MELVAL=IVAL(2) ENDIF NBGCOS=VELCHE(/1) ENDIF DO 3093 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C CALL VPAST(XE,BPSS) C BPSS STOCKE LA MATRICE DE PASSAGE CALL VCORLC (XE,XEL,BPSS) CALL ZERO (REL,LRE,LRE) C C BOUCLE SUR LES POINTS DE GAUSS C DO 1193 IGAU=1,NBPGAU MPTVAL=IVACAR MELVAL=IVAL(1) IBMN =MIN(IB,VELCHE(/2)) EPAIST=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 * * Dans le cas des mat\E9riaux orthotropes, les d\E9formations sont d'abord * calcul\E9es dans le rep\E8re d'orthotropie (les formules utilis\E9es par les * routines RCDST et BMFDST ne sont valables que dans ce rep\E8re); elles * sont ensuite exprim\E9es dans le rep\E8re local de l'\E9l\E9ment. * IF(CMATE.NE.'ISOTROPE')THEN IF(IGAU.LE.NBGCOS)THEN IF(IMAT.EQ.2)THEN MPTVAL=IVAMAT MELVAL=IVAL(2) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) COSA=VELCHE(IGMN,IBMN) MELVAL=IVAL(3) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) SINA=VELCHE(IGMN,IBMN) ENDIF ENDIF ENDIF C C ON CHERCHE LES COEFFICIENTS DE LA MATRICE DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT. + OR.NBGMAT.GT.1)) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL CALL DOHOOO(PROG,LHOOK,DDHOMU) SEGDES MLREEL IF(CMATE.EQ.'ORTHOTRO') + CALL CHGREP1(COSA,SINA,DDHOMU,LHOOK) ENDIF ELSE IF (IMAT.EQ.1) THEN * DO 9093 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9093 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD) CALL HOOKMU(EPAIST,0.D0,NSTRS,DDHOOK,DDHOMU) ENDIF * CALL ZERO(BGENE,NSTRS,LRE) IF(CMATE.NE.'ISOTROPE')THEN IF(IGAU.LE.NBGCOS)THEN IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN COSA=VALMAT(7) SINA=VALMAT(8) ENDIF DO 1393 INO=1,NBNN XX=COSA*XEL(1,INO)+SINA*XEL(2,INO) YY=(-SINA)*XEL(1,INO)+COSA*XEL(2,INO) XE(1,INO)=XX XE(2,INO)=YY 1393 CONTINUE ENDIF CC C TERMES DE LA MATRICE DE RIGIDITE RELATIFS C AUX CISAILLEMENTS TRANSVERSES C CALL RCDST(XE,NSTRS,LRE,DDHOMU, 1 WORK(1),WORK(10),WORK(19),REL,BGENE,1) C TERMES DE LA MATRICE B RELATIFS AUX EFFETS C DE MEMBRANE ET DE FLEXION C CALL BMFDST(IGAU,XE,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK, 1 WORK(1),WORK(10),WORK(19),BGENE,DUM) * DO 10 NPOI=1,3 SHPWRK(1,NPOI)=SHPTOT(1,NPOI,IGAU) SHPWRK(2,NPOI)=SHPTOT(2,NPOI,IGAU) SHPWRK(3,NPOI)=SHPTOT(3,NPOI,IGAU) 10 CONTINUE CALL JACOBI(XEL,SHPWRK,2,3,DJAC) CALL ROTB(BGENE,NSTRS,COSA,SINA) ELSE C C TERMES DE LA MATRICE DE RIGIDITE RELATIFS C AUX CISAILLEMENTS TRANSVERSES C CALL RCDST(XEL,NSTRS,LRE,DDHOMU, 1 WORK(1),WORK(10),WORK(19),REL,BGENE,1) C C TERMES DE LA MATRICE B RELATIFS AUX EFFETS C DE MEMBRANE ET DE FLEXION C CALL BMFDST(IGAU,XEL,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK, 1 WORK(1),WORK(10),WORK(19),BGENE,DJAC) ENDIF DJAC=DJAC*POIGAU(IGAU) C C ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT C IF (EXCEN.NE.0.) THEN DO IJL=1,3 DO IJC=1,LRE BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC) enddo enddo ENDIF C CALL BDBS1(BGENE,DJAC,DDHOMU,LRE,NSTRS,REL,MFR,IFOUR,MATE, 1 IGAU,IMAT,EXCEN) 1193 CONTINUE REL(6,6)=REL(5,5)*1.D-7 REL(12,12)=REL(6,6) REL(18,18)=REL(6,6) ICOM=0 IF(ABS(EXCEN).GT.XPETIT .OR. CMATE.EQ.'COMPOSIT' 1 .OR. IMAT.EQ.2) ICOM=1 CALL TRANSK(REL,BPSS,LRE,3,ICOM) C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 3093 CONTINUE C 9993 CONTINUE SEGSUP WRK1,WRK2,WRK3,WRK4 GOTO 510 * C======================================================================= C========= ERREUR : CAS NON PREVUS ===================================== C======================================================================= 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='RIGI3' CALL ERREUR(86) * 510 CONTINUE SEGSUP,MVELCH * SEGDES XMATRI RETURN END