C SIGMA3 SOURCE OF166741 25/02/21 21:18:36 12166 SUBROUTINE SIGMA3(IPMAIL,IVADEP,NDEP,IVACAR,NCARR,IPMINT, & IVECT,IVAMAT,MELE,IMAT,NELMAT,NBGMAT,LHOOK,CMATE,IREPS2, & NBPTEL,NSTRS,MFR,NMATT,NBPGAU,ISOUS,LRE,LW,IVASTR,UZDPG, & RYDPG,RXDPG,IIPDPG,inoer) *---------------------------------------------------------------------* * __________________________ * * | | * * | CALCUL DES CONTRAINTES| * * |________________________| * * * * poutre,tuyau,linespring,tuyau fissure,barre,cerce,tuyo,shb8 * * * * * *---------------------------------------------------------------------* * * * ENTREES : * * ________ * * * * IPMAIL Pointeur sur un segment MELEME * * IVADEP Pointeur sur le chamelem de deplacements * * NDEP Nombre de composantes de deplacements * * IVACAR Pointeur sur les chamelems de caracteristiques * * NCARR Nombre de caracteristiques geometriques * * IVECT Flag indiquant si on a entree les axes locaux * * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou * * MELE Numero de l'element fini * * IMAT (2 il y a une matrice de HOOKE,1 non ) * * NELMAT Taille maxi des melval du materiau (No d'element) * * NBGMAT Taille maxi des melval du materiau (pt de gauss) * * LHOOK Dimension de la matrice de Hooke * * CMATE Nom du materiau * * IRESP2 Flag pour indiquer si on veut les contraintes * * de Piola-Kirchhoff * * NBPTEL Nombre de points par element * * NSTRS Nombre de composante de contraintes/deformations * * MFR Numero de formulation de l'element fini * * NMATT Nombre de composante de materiau (IMAT=1) * * pour une matrice de hooke * * NBPGAU Nombre de point d'integration pour la rigidite * * ISOUS NUMERO DE LA SOUS-ZONE * * LRE Nombre de ddl dans la matrice de rigidite * * LW Dimension du tableau de travail de l'element * * * * SORTIES : * * ________ * * * * IVASTR pointeur sur un segment MPTVAL contenant les * * les melvals de contraints * * * *---------------------------------------------------------------------* 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 SMCOORD -INC SMLREEL -INC TMPTVAL SEGMENT WRK1 REAL*8 DDHOOK(LHOOK,LHOOK) ,XDDL(LRE) ,XSTRS(NSTRS) REAL*8 XE(3,NBBB) ,DDHOMU(NSTRS,NSTRS) ENDSEGMENT * SEGMENT WRK2 REAL*8 BPSS(3,3) ,BGENE(LHOOK,LRE) ENDSEGMENT * SEGMENT WRK3 REAL*8 WORK(LW) ENDSEGMENT * SEGMENT WRK5 REAL*8 XGENE(NSTN,LRN) ENDSEGMENT * SEGMENT WRK7 REAL*8 PROPEL(45) REAL*8 OUT(30),rel(1,1),work1(24) ENDSEGMENT * SEGMENT,MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT DIMENSION CRIGI(12),CMASS(12) CHARACTER*4 CMOT CHARACTER*8 CMATE KERRE=0 * * INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT * EN DEFORMATION 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 * MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) * NV1=NMATT SEGINI,MVELCH * NHRM=NIFOUR MINTE=IPMINT * IRTD=1 NBBB=NBNN SEGINI WRK1 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 IF (MELE.LE.100) &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,99,99,29,30,99,99,99,99,99,99,99,99,99,99, 2 99,29,43,99,45,46,99,99,99,30,99,99,99,99,99,99,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,29,99,99,99,99,99,99,99,99,99,99,46,96,99,99,99,99 5 ),MELE IF (MELE.LE.200) &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 1 99,99,46,124,125,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 3 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 4 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 5 34),MELE-100 IF (MELE.LE.300) &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 1 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,258,34, 3 260,34,34,34,34,265),MELE-200 C 34 CONTINUE C GOTO 99 C_______________________________________________________________________ CC C____________________________________________________________________ C C ELEMENTS POUTRES TUYAUX C____________________________________________________________________ C 29 CONTINUE SEGINI WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3029 IB=1,NBELEM C C ON CHERCHE LES DEPLACEMENTS C IE=1 NCARR1=NCARR IF(IVECT.EQ.1) NCARR1=NCARR-3 CALL ZERO(WORK,NCARR1,1) DO 4029 IGAU=1,NBNN MPTVAL=IVADEP DO 4039 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4039 CONTINUE C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C RANGEMENT DES CARACTERISTIQUES DANS WORK C SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION C MPTVAL=IVACAR DO 6029 IC=1,NCARR1 IF (IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) ELSE WORK(IC)=0.D0 ENDIF C IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 6029 CONTINUE 4029 CONTINUE C C CAS OU ON A LU LE MOT VECTEUR C C IF ((IVECT.EQ.1).AND.(IFOUR.EQ.2)) THEN C DO 6129 IC=1,IDIM MELVAL=IVAL(NCARR+IC-3) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) WORK(NCARR+IC-3)=VELCHE(1,IBMN) ELSE WORK(NCARR+IC-3)=0.D0 ENDIF 6129 CONTINUE ENDIF C C TRAITEMENT DU MATERIAU C MPTVAL=IVAMAT MELVAL=IVAL(1) * IF(CMATE.NE.'SECTION') THEN IBMN=MIN(IB,VELCHE(/2)) YOUNG=VELCHE(1,IBMN) C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE EQUIVA C IF(MELE.EQ.42) THEN PRES=WORK(4) CISA=WORK(5) WORK(4)=WORK(6) WORK(5)=WORK(7) WORK(6)=WORK(8) WORK(7)=PRES WORK(8)=CISA CALL TUYKAR(WORK,KERRE,2,YOUNG) ENDIF IF (KERRE.EQ.77) THEN CALL ERREUR(77) GOTO 510 ENDIF C C ON CHERCHE LES COEFF DES MAT DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL C------------- C PROVISOIRE C------------- * C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN C WORK(4)=DDHOOK(1,1)/WORK(1) WORK(5)=DDHOOK(2,2)/(MAX(WORK(3),WORK(1))) ELSE WORK(10)=DDHOOK(1,1)/WORK(4) WORK(11)=DDHOOK(4,4)/WORK(1) ENDIF ELSE IF (IMAT.EQ.1) THEN * DO 9029 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 9029 CONTINUE IF(MELE.EQ.84) THEN C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) ELSE C CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) ENDIF ELSE C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) ELSE C CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) ENDIF ENDIF C------------- C PROVISOIRE C------------- C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN WORK(4)=VALMAT(1) AUX=VALMAT(2) WORK(5)=WORK(4)*0.5D0/(1.D0+AUX) ELSE C WORK(10)=VALMAT(1) AUX=VALMAT(2) WORK(11)=WORK(10)*0.5D0/(1.D0+AUX) ENDIF C------------- ENDIF * * CAS DE LA FORMULATION SECTION * ELSE IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) $ CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN * * ON REGARDE SI ON A LA COMPOSANTE MAHO * SI OUI, ON LA PREND * IF(IVAL(3).NE.0) THEN MELVAL=IVAL(3) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) $ CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ELSE IBMN=MIN(IB,IELCHE(/2)) IPMODL=IELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,IELCHE(/2)) IPMAT=IELCHE(1,IBMN) CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS) IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) $ CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF ENDIF C C ON CALCULE LES CONTRAINTES ( STOCKEES DANS WORK ET NON PAS DANS XSTRS C IF(MELE.EQ.84) THEN IF(CMATE.NE.'SECTION') THEN C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIMST2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) ELSE C CALL TIMSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) ENDIF ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIFST2(XE,XDDL,LHOOK,DDHOOK, $ WORK(12),WORK(25),IREPS2) ELSE CALL TIFSTR(XE,XDDL,LHOOK,DDHOOK,WORK, $ WORK(12),WORK(25),IREPS2) ENDIF ENDIF ELSE C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL POUST2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) ELSE C CALL POUSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) ENDIF ENDIF C C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES C ID=12 DO IGAU=1,NBPTEL MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(ID) ID=ID+1 enddo enddo C 3029 CONTINUE IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF SEGSUP MVELCH,WRK1,WRK3 GOTO 510 C____________________________________________________________________ C C ELEMENT LINESPRING LISP ET LISM C____________________________________________________________________ C 30 CONTINUE NSTR=NSTRS NSTRS=2 C ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1 C SEGINI WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELELEMTS C DO 3030 IB=1,NBELEM C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO IGAU=1,NBNN MPTVAL=IVADEP DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo C C ON CHERCHE LES COORDONNEES DES NOEUDS ET ON REACTUALISE C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LA MATRICE DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9030 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 9030 CONTINUE IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHLIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME PT DE GAUSS C IE=1 DO IC=1,3,2 MPTVAL=IVACAR DO ICOMP=1,NCARR MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) WORK(IE)=VELCHE(IGMN,IBMN) ELSE WORK(IE)=0.D0 ENDIF IE=IE+1 enddo enddo C C CALCUL DES CONTRAINTES C CALL LISPST(XE,WORK,DDHOOK,XDDL,WORK(11),NBPGAU,MELE,WORK(53), 1 I69,I70,I195,I157) C IF(I69.NE.0) THEN CALL ERREUR( 69) * RETURN ENDIF IF(I70.NE.0) THEN CALL ERREUR( 70) * RETURN ENDIF IF(I195.NE.0) THEN if (inoer.eq.0) then CALL ERREUR( 195) * RETURN else call soucis(195) endif ENDIF IF(I157.NE.0) THEN CALL ERREUR( 157) * RETURN ENDIF IE=1 DO IGAU=1,NBPTEL MPTVAL=IVASTR DO ICOMP=1,NSTR MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(52+IE) IE=IE+1 enddo enddo 3030 CONTINUE IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF SEGSUP MVELCH,WRK1,WRK3 GOTO 510 C____________________________________________________________________ C____________________________________________________________________ C C ELEMENT TUYAU FISSURE C____________________________________________________________________ C 43 CONTINUE C ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1 C SEGINI WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3043 IB=1,NBELEM C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO IGAU=1,NBNN MPTVAL=IVADEP DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo 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 CARACTERISTIQUES C MPTVAL=IVACAR DO 7043 IC=1,9 MELVAL=IVAL(IC) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF 7043 CONTINUE C C ON CHERCHE LES COEFF DES MAT DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9043 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 9043 CONTINUE IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHFIS1(VALMAT,WORK(1),CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C ON CALCULE LES CONTRAINTES C CALL TUFIST(VALMAT,XDDL,WORK(1),DDHOOK,WORK(10), 1 WORK(20),WORK(31),I137) IF(I137.NE.0) INTERR(1)=ISOUS IF(I137.NE.0) INTERR(2)=IB C MPTVAL=IVASTR DO 6043 ICOMP=1,8 MELVAL=IVAL(ICOMP) IBMN=MIN(IB,VELCHE(/2)) VELCHE(1,IBMN)=WORK(30+ICOMP) 6043 CONTINUE C 3043 CONTINUE IF(I137.EQ.1) CALL ERREUR(137) IF(I137.EQ.2) CALL ERREUR(123) IF(I137.EQ.3) CALL ERREUR(266) IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF SEGSUP MVELCH,WRK1,WRK3 GOTO 510 C____________________________________________________________________ C C ELEMENT POINT (POI1) C____________________________________________________________________ C 45 CONTINUE * IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN GO TO 99 ENDIF * SEGINI WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3045 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 CALCULE LES DEFORMATIONS C CALL PO1EPS(XE,UZDPG,RYDPG,RXDPG,XDPGE,YDPGE,WORK) C MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) SECT=VELCHE(1,IBMN) ELSE CALL ERREUR(5) GO TO 3045 ENDIF C C ON CHERCHE LE COEFF DE LA MAT DE HOOKE C MPTVAL=IVADEP MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9045 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 9045 CONTINUE CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD) ENDIF MPTVAL=IVADEP C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C ID=1 DO IGAU=1,NBPTEL MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(ID)*DDHOOK(1,1) ID=ID+1 enddo enddo MPTVAL=IVADEP C 3045 CONTINUE IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF SEGSUP MVELCH,WRK1,WRK3 GOTO 510 C____________________________________________________________________ C C BARRE ET CERCE C____________________________________________________________________ C 46 CONTINUE * IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN GO TO 99 ENDIF * SEGINI WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3046 IB=1,NBELEM KERRE=0 C C ON CHERCHE LES DEPLACEMENTS C NDDD=NDEP IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NDDD=NDEP-3 IE=1 DO IGAU=1,NBNN MPTVAL=IVADEP DO ICOMP=1,NDDD MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CALCULE LES DEFORMATIONS C IF(MELE.EQ.46) CALL BAREPS(XE,XDDL,WORK,IREPS2) IF(MELE.EQ.95) CALL CEREPS(XE,XDDL,WORK,IREPS2,KERRE) IF(MELE.EQ.123)CALL BAREP3(XE,XDDL,WORK,QSIGAU,POIGAU,NBPGAU,IB) IF(KERRE.NE.0) THEN CALL ERREUR(601) GO TO 3046 ENDIF MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) SECT=VELCHE(1,IBMN) ELSE CALL ERREUR(5) GO TO 3046 ENDIF C C ON CHERCHE LE COEFF DE LA MAT DE HOOKE C MPTVAL=IVADEP MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9046 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 9046 CONTINUE CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD) ENDIF MPTVAL=IVADEP C C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES C ID=1 DO IGAU=1,NBPTEL MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(ID)*DDHOOK(1,1) ID=ID+1 enddo enddo MPTVAL=IVADEP C 3046 CONTINUE IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601) SEGSUP MVELCH,WRK1,WRK3 GOTO 510 C C____________________________________________________________________ C C ELEMENT BARRE 3D EXCENTRE (BAEX) C____________________________________________________________________ C 124 CONTINUE NBBB=NBNN NSTN=NBNN LRN =LRE SEGINI WRK1,WRK3,WRK5 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3108 IB=1,NBELEM C C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ C MPTVAL=IVACAR DO IC=1,NCARR IF(IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF END DO SECT=WORK(1) C C XGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE) IF(KERRE.NE.0) INTERR(1)=ISOUS IF(KERRE.NE.0) INTERR(2)=IB IF(KERRE.EQ.1) CALL ERREUR(128) C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO IGAU=1,NBNN MPTVAL=IVADEP DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo C C ON CALCULE LES DEFORMATIONS C CALL BAEPEX(XDDL,XGENE,AL,XSTRS,LRE) C C ON CHERCHE LE COEFF DE LA MAT DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF(IB.LE.NELMAT.OR.NBGMAT.GT.1) CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9124 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 9124 CONTINUE CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD) ENDIF C C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES C ID=1 DO IGAU=1,NBPTEL MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XSTRS(ID)*DDHOOK(1,1) ID=ID+1 enddo enddo C 3108 CONTINUE SEGSUP WRK1,WRK3,WRK5,MVELCH GOTO 510 C_______________________________________________________________________ C C LIA2 : element de liaison a 2 noeuds (6 ddl par C noeuds) C_______________________________________________________________________ C 125 CONTINUE NBBB=NBNN NSTN=3 LRN =3 SEGINI WRK1,WRK3,WRK5 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3109 IB=1,NBELEM C C RANGEMENT DES CARACTERISTIQUES DANS WORK C MPTVAL=IVACAR DO IC=1,NCARR IF(IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF END DO C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE) IF(KERRE.NE.0) INTERR(1)=ISOUS IF(KERRE.NE.0) INTERR(2)=IB IF(KERRE.EQ.1) CALL ERREUR(128) C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO IGAU=1,NBNN MPTVAL=IVADEP DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo C C ON CALCULE LES CONTRAINTES (EFFORTS : F = K * U) C CALL SIGLIA(XGENE,XDDL,WORK,LRE,NBNN,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES C ID=1 DO IGAU=1,NBPTEL MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XSTRS(ID) ID=ID+1 enddo enddo C 3109 CONTINUE SEGSUP MVELCH,WRK1,WRK3,WRK5 GOTO 510 C_______________________________________________________________________ C C JOI1 : element de liaison a 2 noeuds (6 ddl par C noeuds) C_______________________________________________________________________ C 265 CONTINUE NBBB=NBNN NSTN=3 LRN =3 SEGINI WRK1,WRK3,WRK2 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3110 IB=1,NBELEM C C RANGEMENT DES CARACTERISTIQUES DANS WORK C MPTVAL=IVAMAT DO IC=1,NMATT IF(IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF END DO C CALL MAPALU(NMATT,WORK,BPSS,IDIM) C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO IGAU=1,NBNN MPTVAL=IVADEP DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo C C CALCUL DES DEPLACEMENTS LOCAUX C IAW1 = 101 IAW2 = IAW1 + LRE CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM) C C ON CALCULE LES CONTRAINTES (EFFORTS : F = K * U) C CALL ZERO(XSTRS,NSTRS,1) * CALL SIGJOI(NMATT,XDDL,WORK,LRE,XSTRS,IDIM,NSTRS,CMATE) C C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES C ID=1 DO IGAU=1,NBPTEL MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XSTRS(ID) ID=ID+1 enddo enddo C 3110 CONTINUE SEGSUP MVELCH,WRK1,WRK3,WRK2 GOTO 510 C____________________________________________________________________ C C ELEMENT TUYO C____________________________________________________________________ C 96 CONTINUE SEGINI WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3096 IB=1,NBELEM C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO IGAU=1,NBNN MPTVAL=IVADEP DO ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C RANGEMENT DES CARACTERISTIQUES DANS WORK C MPTVAL=IVACAR DO 6096 IC=1,NCARR IF (IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF 6096 CONTINUE C C CAS OU ON A LU LE MOT VECTEUR C C IF (IVECT.EQ.1) THEN DO 6196 IC=1,IDIM MELVAL=IVAL(NCARR+IC-3) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) WORK(NCARR+IC-3)=VELCHE(1,IBMN) ELSE WORK(NCARR+IC-3)=0.D0 ENDIF 6196 CONTINUE C C CAS DU CHAMELEM COMVERTI C ELSE IF (IVECT.EQ.2) THEN DO 6496 IC=1,IDIM MELVAL=IVAL(NCARR+IC-3) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) WORK(NCARR+IC-3)=VELCHE(1,IBMN) ELSE WORK(NCARR+IC-3)=0.D0 ENDIF 6496 CONTINUE ENDIF C MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) YOUNG=VELCHE(1,IBMN) C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE EQUIVA C IF(MELE.EQ.42) THEN PRES=WORK(4) WORK(4)=WORK(5) WORK(5)=WORK(6) WORK(6)=WORK(7) WORK(7)=PRES CALL TUYKAR(WORK,KERRE,2,YOUNG) ENDIF IF (KERRE.EQ.77) THEN CALL ERREUR(77) GOTO 510 ENDIF C C ON CHERCHE LES COEFF DES MAT DE HOOKE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL C------------- C PROVISOIRE C------------- WORK(10)=DDHOOK(1,1)/WORK(4) WORK(11)=DDHOOK(2,2)/WORK(5) ELSE IF (IMAT.EQ.1) THEN * DO 9096 IM=1,NMATT MELVAL=IVAL(IM) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9096 CONTINUE CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) C------------- C PROVISOIRE C------------- WORK(10)=VALMAT(1) AUX=VALMAT(2) WORK(11)=WORK(10)*0.5D0/(1.D0+AUX) C------------- ENDIF C C ON CALCULE LES CONTRAINTES ( STOCKEES DANS WORK ET NON PAS DANS XSTRS C CALL POUSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) C C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES C MPTVAL=IVASTR ID=12 DO IGAU=1,NBPTEL DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(ID) ID=ID+1 enddo enddo C 3096 CONTINUE IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF SEGSUP MVELCH,WRK1,WRK3 GOTO 510 c_______________________________________________________________________ c c ELEMENTS CIFL MACRO ELEMENT CISAILLEMENT FLEXION c____________________________________________________________________ c 258 CONTINUE NBNO=NBNN SEGINI WRK2,WRK3 c DO 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 DEPLACEMENTS (UX1,UY1,RZ1,UX2,UY2,RZ2,UM,RM) C MPTVAL=IVADEP MELVAL=IVAL(1) XDDL(1)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB ,VELCHE(/2))) XDDL(4)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB ,VELCHE(/2))) MELVAL=IVAL(2) XDDL(2)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB ,VELCHE(/2))) XDDL(5)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB ,VELCHE(/2))) MELVAL=IVAL(3) XDDL(3)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB ,VELCHE(/2))) XDDL(6)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB ,VELCHE(/2))) MELVAL=IVAL(4) XDDL(7)=VELCHE(MIN(2,VELCHE(/1)),MIN(IB ,VELCHE(/2))) MELVAL=IVAL(5) XDDL(8)=VELCHE(MIN(2,VELCHE(/1)),MIN(IB ,VELCHE(/2))) C C PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX C CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE) c c matrice de hooke c MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN C DO 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 ENDDO C MPTVAL=IVACAR DO IC=1,NCARR IF (IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF ENDDO C CALL DOHMUR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) ENDIF c DDHOOK(1,1)=DDHOOK(1,1)/(XH/2) DDHOOK(2,2)=DDHOOK(2,2)/(XH/2) DDHOOK(3,3)=DDHOOK(3,3)/ XH DDHOOK(4,4)=DDHOOK(4,4)/(XH/2) DDHOOK(5,5)=DDHOOK(5,5)/(XH/2) CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) c c c remplissage du segment contenant les contraintes c MPTVAL=IVASTR DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(1,IBMN)=XSTRS(ICOMP) ENDDO ENDDO C IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:12)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF SEGSUP MVELCH,WRK1,WRK2,WRK3 GOTO 510 C_______________________________________________________________________ C C ELEMENT DE COQUE VOLUMIQUE SHB8 C_______________________________________________________________________ C 260 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK7,MVELCH C C BOUCLE POUR TOUS LES ELEMENTS C DO 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 deplacements C MPTVAL=IVADEP IE=1 DO IGAU=1,NBNN DO ICOMP=1,3 MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) WORK1(IE)=VELCHE(IGMN,IBMN) IE=IE+1 enddo enddo MPTVAL=IVAMAT DO 9070 IM=1,NMATT MELVAL=IVAL(IM) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9070 CONTINUE PROPEL(1)=VALMAT(1) PROPEL(2)=VALMAT(2) DO IM=3,12 PROPEL(IM)=VALMAT(1) ENDDO PROPEL(3)=ireps2 PROPEL(14)=VALMAT(1) C C CALCUL DES CONTRAINTES C call SHB8 (7,XE,DDHOOK,PROPEL,WORK1,REL,OUT) MPTVAL=IVASTR IE=1 DO ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) DO IBG=1,5 IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IBG,IBMN)=out(ICOMP+ (IBG-1)*NSTRS) ENDDO ENDDO ENDDO SEGSUP WRK1,WRK7,MVELCH GO TO 510 *____________________________________________________________________ 99 CONTINUE SEGSUP MVELCH,WRK1 MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='SIGM' CALL ERREUR(86) * 510 CONTINUE RETURN END