C EPSI4 SOURCE CB215821 20/11/25 13:28:01 10792 SUBROUTINE EPSI4(IPMAIL,IVADEP,NDEP,IVAMAT,NMATT,IVACAR,NCARR, & IPMINT,IVECT,MELE,LHOOK,IREPS2,NBPTEL,NSTRS,MFR, & NBPGAU,LRE,LW,IVAEPS,UZDPG,RYDPG,RXDPG,ISOUS,IIPDPG,CMATE) C---------------------------------------------------------------------* C * C CALCUL DES DEFORMATIONS * C * C linespring,tuyau fissure,barre,cerce,tuyo,poi1 * C * C---------------------------------------------------------------------* C * C ENTREES : * C ________ * C * C IPMAIL Pointeur sur un segment MELEME * C IVADEP Pointeur sur le chamelem de deplacements * C NDEP Nombre de composantes de deplacements * C IVACAR Pointeur sur les chamelems de caracteristiques * C NCARR Nombre de caracteristiques geometriques * C IVECT Flag indiquant si on a entre les axes locaux * C MELE Numero de l'element fini * C LHOOK Dimension de la matrice de Hooke * C IRESP2 Flag pour indiquer si on veut les contraintes * C de Piola-Kirchhoff * C NBPTEL Nombre de points par element * C NSTRS Nombre de composante de contraintes/deformations * C MFR Numero de formulation de l'element fini * C pour une matrice de hooke * C NBPGAU Nombre de point d'integration pour la rigidite * C LRE Nombre de ddl dans la matrice de rigidite * C LW Dimension du tableau de travail de l'element * C * C SORTIES : * C ________ * C * C IVAEPS pointeur sur un segment MPTVAL contenant les * C les melvals de deformations * C * C---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE -INC SMLREEL C C SEGMENT WRK1 REAL*8 DDHOOK(NSTRS,NSTRS) ,XDDL(LRE) ,XSTRS(NSTRS) REAL*8 XE(3,NBBB),DDHOMU(NSTRS,NSTRS) ENDSEGMENT C SEGMENT WRK2 REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE) ENDSEGMENT C SEGMENT WRK4 REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE) ENDSEGMENT C SEGMENT WRK5 REAL*8 XGENE(NSTN,LRN) ENDSEGMENT C SEGMENT WRK3 REAL*8 WORK(LW) ENDSEGMENT C SEGMENT WRK6 REAL*8 YDDL(NYD2) ENDSEGMENT C SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT C SEGMENT MPTVAL INTEGER IPOS(NS),NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT POINTEUR MPTVA1.MPTVAL C CHARACTER*(NCONCH) CONM CHARACTER*8 CMATE C PARAMETER (NINF=3) C INTEGER INFOS(NINF) logical dcmat2 C C INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT C DE LA SECTION EN DEFO PLANE GENERALISEE C C <- Ici test equivalent a IF (IIPDPG.GT.0) THEN IF (IFOUR.EQ.-3)THEN C* SEGACT MCOORD IREF=(IIPDPG-1)*(IDIM+1) XDPGE=XCOOR(IREF+1) YDPGE=XCOOR(IREF+2) ELSE XDPGE=0.D0 YDPGE=0.D0 ENDIF C MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) C C NHRM=NIFOUR MINTE=IPMINT NBBB=NBNN dcmat2 = .false. 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,2,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,2,30,99,99,99,99,99,99,99,99,99,99, 2 99,99,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,99,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,34,34,34, 3 34,34,34,34,265,266,266,266,99,99,271,272),MELE-200 C 34 CONTINUE GOTO 99 C____________________________________________________________________ C C ELEMENT SEG2 (pour IMPEDANCE) C____________________________________________________________________ C 2 CONTINUE C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C C detecte une impedance hybridant des ddl MPTVAL=IVADEP if (ival(/1).eq.ndep*2) dcmat2 = .true. NYD2 = NBNN*NDEP segini wrk6 DO 310 IB=1,NBELEM C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO 410 IGAU=1,NBNN ico1 = 1 ico2 = ndep if (dcmat2) then if (igau.eq.2) then ico1 = ndep + 1 ico2 = ndep*2 endif endif DO 410 ICOMP=ico1,ico2 MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) YDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 410 CONTINUE C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS ID=1 DO 710 IGAU=1,NBPTEL DO 710 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) if (igau.lt.2) then VELCHE(IGAU,IBMN)= YDDL(ID) - YDDL(ID+NDEP) else VELCHE(IGAU,IBMN)= YDDL(ID) - YDDL(ID-NDEP) endif ID=ID+1 710 CONTINUE C 310 CONTINUE segsup wrk6 GOTO 510 C 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 WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3030 IB=1,NBELEM C C ON CHERCHE LES DEPLACEMENTS C IE=1 DO 4030 IGAU=1,NBNN MPTVAL=IVADEP DO 4030 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4030 CONTINUE C C ON CHERCHE LES COORDONNEES DES NOEUDS ET ON REACTUALISE C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME PT DE GAUSS C IE=1 DO 7030 IC=1,3,2 MPTVAL=IVACAR DO 7030 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 7030 CONTINUE C C CALCUL DES DEFORMATIONS C CALL LISPEP(XE,WORK,XDDL,WORK(11),WORK(20), 1 WORK(29),NBPGAU,WORK(53)) C IE=1 DO 8030 IGAU=1,NBPTEL MPTVAL=IVAEPS DO 8030 ICOMP=1,NSTR MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(52+IE) IE=IE+1 8030 CONTINUE 3030 CONTINUE SEGSUP WRK1,WRK3 GOTO 510 C_______________________________________________________________________ C C TUYAU FISSURE C_______________________________________________________________________ C 43 CONTINUE SEGINI WRK1,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 4043 IGAU=1,NBNN MPTVAL=IVADEP DO 4043 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4043 CONTINUE 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 ENDIF 7043 CONTINUE C C ON CALCULE LES DEFORMATIONS C CALL TUFEPS(XDDL,WORK,WORK(31),KERRE) IF(KERRE.NE.0) THEN INTERR(1)=IB IF(KERRE.EQ.1) CALL ERREUR(137) IF(KERRE.EQ.2) CALL ERREUR(123) IF(KERRE.EQ.3) CALL ERREUR(266) GOTO 5043 ENDIF C C ON REMPLIT LES DEFORMATIONS C MPTVAL=IVAEPS DO 6043 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB,VELCHE(/2)) VELCHE(1,IBMN)=WORK(30+ICOMP) 6043 CONTINUE C 3043 CONTINUE 5043 CONTINUE SEGSUP WRK1,WRK3 GOTO 510 C_______________________________________________________________________ C C ELEMENT POI1 / materiau IMPEDANCE C_______________________________________________________________________ C 45 CONTINUE IF ((CMATE.EQ.'IMPELAST').OR.(CMATE.EQ.'IMPVOIGT').OR. & (CMATE.eq.'IMPREUSS').OR.(CMATE.eq.'IMPCOMPL').OR. & (MFR.EQ.26.OR.MFR.EQ.28)) THEN mptva1 = ivadep mptval = ivaeps numstr = ival(/1) do iv = 1,ival(/1) melva1 = mptva1.ival(iv) melval = ival(iv) Ctc les lignes ci dessous sont pour le compilateur if( .not. dcmat2 ) then melva2=melva1 inmbid=0 ICC2=1 else inmbid=numstr icc2=2 endif C C ON CHERCHE LES DEPLACEMENTS C DO IB=1,NBELEM IGAU = 1 IGMN= 1 IBMN=MIN(IB ,MELVA1.VELCHE(/2)) valalf = MELVA1.VELCHE(IGMN,IBMN) VELCHE(IGMN,IBMN) = valalf ENDDO enddo GOTO 510 ENDIF IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN GO TO 99 ENDIF C SEGINI WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3045 IB=1,NBELEM KERRE=0 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 C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C ID=1 DO 7045 IGAU=1,NBPTEL MPTVAL=IVAEPS DO 7045 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(ID) ID=ID+1 7045 CONTINUE 3045 CONTINUE SEGSUP WRK1,WRK3 GOTO 510 C_______________________________________________________________________ C C BARRE ET CERCE C_______________________________________________________________________ C 46 CONTINUE C IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN GO TO 99 ENDIF C SEGINI WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3046 IB=1,NBELEM KERRE=0 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 NDDD=NDEP IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NDDD=NDEP-3 IE=1 DO 4046 IGAU=1,NBNN MPTVAL=IVADEP DO 4046 ICOMP=1,NDDD MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4046 CONTINUE 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.EQ.1) THEN CALL ERREUR(601) GO TO 3046 ENDIF C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C ID=1 DO 7046 IGAU=1,NBPTEL MPTVAL=IVAEPS DO 7046 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(ID) ID=ID+1 7046 CONTINUE C 3046 CONTINUE SEGSUP WRK1,WRK3 GOTO 510 C C element coaxial COS2 (3D pour liaison acier-beton) C 271 continue lW=20 SEGINI WRK1,WRK3,wrk4 DO 2711 IB=1,NBELEM KERRE=0 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 NDDD=NDEP IE=1 DO 2712 IGAU=1,NBNN MPTVAL=IVADEP DO 2712 ICOMP=1,NDDD MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2712 CONTINUE C call chloc ( xe,nbnn,BPSS,idim,kerre) CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM) ii = 0 do ia=1,4 xa=0.d0 xb=0.d0 xc=0.d0 do iu=1,idim ii = ii + 1 C write(6,*) 'xddl',ib,ii,xddl(ii) xa =xa+ xddl(ia*idim - idim +iu)* bpss( 1,iu) xb= xb+ xddl(ia*idim - idim +iu)* bpss( 2,iu) if(idim.eq.3) xc=xc+xddl(ia*idim - idim +iu)* bpss( 3,iu) enddo xddl(ia*idim - idim +1)=xa xddl(ia*idim - idim +2)=xb if(idim.eq.3) xddl(ia*idim - idim +3)=xc enddo g11 = xddl(1) - xddl(3*idim +1) g21 = xddl(idim+1 ) - xddl( 2*idim + 1 ) ag = 1.d0-0.5773502691896257645d0 g1 = g11 + (g21 - g11)*ag/2.d0 g2 = g21 + (g11 - g21)*ag/2.d0 g12 = xddl(3*idim + 2) - xddl(2) g22 = xddl(2*idim + 2) - xddl(idim+2 ) g3 =g12 + (g22 - g12)*ag/2.d0 g4 =g22 + (g12 - g22)*ag/2.d0 C if (idim.eq.3) then g13 =xddl(3) - xddl(3*idim +3) g23 =xddl(idim+3 ) - xddl( 2*idim + 3 ) g5 = g13 + (g23 - g13)*ag/2.d0 g6 = g23 + (g13 - g23)*ag/2.d0 endif C write(6,*) 'gliss 1',ib,g1,g3,g5 C write(6,*) 'gliss 2',ib,g2,g4,g6 C mptval= ivaeps melval=ival(1) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(1,IBMN)= g1 velche(2,ibmn)= g2 C melval=ival(2) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(1,IBMN)= g3 velche(2,ibmn)= g4 C melval=ival(3) IBMN=MIN(IB ,VELCHE(/2)) if (idim.eq.3) then VELCHE(1,IBMN)= g5 velche(2,ibmn)= g6 endif C 2711 continue segsup WRK1,WRK3,wrk4 GOTO 510 C_______________________________________________________________________ C C ELEMENT COAXIAL (COA2) C_______________________________________________________________________ C 272 continue NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C DO 2721 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 CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM) C C ON CHERCHE LES DEPLACEMENTS C MPTVAL=IVADEP IE=1 DO 2722 IGAU=1,NBNN DO 2722 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2722 CONTINUE C C BOUCLE SUR LES POINTS DE GAUSS C DO 2723 IGAU=1,NBPGAU C C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CALL BCO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, . BGENE,DJAC,IRRT,IDIM,NBNN,NSTRS,LRE) IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(764) GOTO 9985 ENDIF DO i=1,NSTRS cc=0.D0 DO j=1,LRE cc= cc + (XDDL(j) * BGENE(i,j)) C write(6,*) 'xddl b',ib,igau,i,j,xddl(j),bgene(i,j) ENDDO XSTRS(i) = cc C write(6,*) 'gliss',ib,igau,i,xstrs(i) ENDDO C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS DO 2724 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 2724 CONTINUE 2723 CONTINUE 2721 CONTINUE C 9985 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C____________________________________________________________________ C C ELEMENT BARRE 3D EXCENTRE (BAEX) C____________________________________________________________________ C 124 CONTINUE NBBB=NBNN NSTN=NBNN LRN =LRE NYD2=2 SEGINI WRK1,WRK3,WRK5,WRK6 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 C 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 MPTVAL=IVADEP DO 4108 IGAU=1,NBNN DO 4108 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4108 CONTINUE C C ON CALCULE LES DEFORMATIONS C CALL BAEPEX(XDDL,XGENE,AL,YDDL,LRE) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATION C ID=1 MPTVAL=IVAEPS DO 7108 IGAU=1,NBPTEL DO 7108 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=YDDL(ID) ID=ID+1 7108 CONTINUE C 3108 CONTINUE SEGSUP WRK1,WRK3,WRK5 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 4109 IGAU=1,NBNN MPTVAL=IVADEP DO 4109 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4109 CONTINUE C CALL ZERO(XSTRS,NSTRS,1) C C ON CALCULE LES DEFORMATIONS !!! a completer C pour le moment on ne met rien dans les deformations C CCC CALL DEFLIA(XGENE,XDDL,WORK,LRE,NBNN,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C ID=1 DO 7109 IGAU=1,NBPTEL MPTVAL=IVAEPS DO 7109 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XSTRS(ID) ID=ID+1 7109 CONTINUE C 3109 CONTINUE SEGSUP WRK1,WRK3,WRK5 GOTO 510 C_______________________________________________________________________ C C JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds) C_______________________________________________________________________ C 265 CONTINUE NBBB=NBNN NSTN=3 LRN =3 SEGINI WRK1,WRK3,WRK4 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 4110 IGAU=1,NBNN MPTVAL=IVADEP DO 4110 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4110 CONTINUE C C CALCUL DES DEPLACEMENTS LOCAUX C IAW1 = 101 IAW2 = IAW1 + LRE CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM) C CALL ZERO(XSTRS,NSTRS,1) C C ON CALCULE LES DEFORMATIONS C CALL DEFJOI(XDDL,LRE,XSTRS,NDEP) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C ID=1 DO 7110 IGAU=1,NBPTEL MPTVAL=IVAEPS DO 7110 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XSTRS(ID) ID=ID+1 7110 CONTINUE C 3110 CONTINUE SEGSUP WRK1,WRK3,WRK4 GOTO 510 C_______________________________________________________________________ C C ELEMENT TUYO C_______________________________________________________________________ C 96 CONTINUE SEGINI WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3096 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 IE=1 DO 4096 IGAU=1,NBNN MPTVAL=IVADEP DO 4096 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 4096 CONTINUE C C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB 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 ENDIF 6096 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 6196 IC=1,IDIM WORK(NCARR+IC-1)=XCOOR(IREF+IC) 6196 CONTINUE ELSE DO 6296 IC=1,IDIM WORK(NCARR+IC-1)=0. 6296 CONTINUE ENDIF ENDIF C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE C EQUIVALENTE 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,2) ENDIF C C ON CALCULE LES DEFORMATIONS C youbid=0.d0 xnubid=1. CALL POUEPS(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2,youbid, $ xnubid) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C ID=12 MPTVAL=IVAEPS DO 7096 IGAU=1,NBPTEL DO 7096 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=WORK(ID) ID=ID+1 7096 CONTINUE C 3096 CONTINUE SEGSUP WRK1,WRK3 GOTO 510 C_______________________________________________________________________ C C ELEMENTS ZONE_COHESIVE ZOC2,ZOC3,ZOC4 C_______________________________________________________________________ C 266 CONTINUE NBNO=NBNN SEGINI WRK1,WRK2,WRK4 C DO 3266 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 C ON CHERCHE LES DEPLACEMENTS C MPTVAL=IVADEP IE=1 DO 2266 IGAU=1,NBNN DO 2266 ICOMP=1,NDEP MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XDDL(IE)=VELCHE(IGMN,IBMN) IE=IE+1 2266 CONTINUE C C BOUCLE SUR LES POINTS DE GAUSS C DO 4266 IGAU=1,NBPGAU C CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS) C CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT, . NSTRS,NBNO,LRE,MELE,SHPWRK,BGENE,DJAC,IRRT) C IRRT.NE.0 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) GOTO 99266 ENDIF C CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) C C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS C MPTVAL=IVAEPS DO 9266 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 9266 CONTINUE 4266 CONTINUE 3266 CONTINUE C 99266 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 C____________________________________________________________________ 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='EPSI' CALL ERREUR(86) C 510 CONTINUE RETURN END