C AMOR4 SOURCE CB215821 23/01/25 21:15:04 11573 SUBROUTINE AMOR4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS, & IVAMAT,IVACAR,IVECT,CMATE,MFR,ICAS,NBGMAT,NELMAT, & LHOOK,NMATT,NCARR,ISOUS,LW,IPORE,IPMATR,IIPDPG,IMOD) *---------------------------------------------------------------------* * ________________________________________ * * | | * * | CALCUL DE L AMORTISSEMENT STRUCTUREL | * * |_______________________________________| * * * * poutre,tuyau,barre * * * * *---------------------------------------------------------------------* * * * * * ENTREES : * * ________ * * * * MATE Numero du materiau * * MELE Numero de l'element fini * * IPMAIL Pointeur sur un segment MELEME * * IPMINT Pointeur sur un segment MINTE * * 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 * * IVECT FLAG INDIQUANT SI ON A ENTRE UN VECTEUR LOCAL * * 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) * * NMATT Nombre de composantes de materiau (IMAT=1) * * NCARR Nombre de caracteristiques geometriques * * ISOUS NUMERO DE LA SOUS-ZONE * * LW Dimension du tableau de travail * * IPORE nombre de fonctions de forme * * ICAS 1 si amortissement * * 2 si rigidite antisymetrique * * * * * * 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 SMLMOTS * SEGMENT WRK1 REAL*8 DDHOOK(NSTRS,NSTRS) ,DDHOMU(NSTRS,NSTRS) REAL*8 REL(LRE,LRE) , XE(3,NBBB) ENDSEGMENT * SEGMENT WRK2 REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE) ENDSEGMENT * SEGMENT WRK3 REAL*8 WORK(LW) ENDSEGMENT * SEGMENT WRK4 REAL*8 BPSS(3,3),XEL(3,NBBB) ENDSEGMENT * SEGMENT WRK5 REAL*8 XGENE(NSTN,LRN) ENDSEGMENT * SEGMENT WRK6 REAL*8 PSS(3,3) ENDSEGMENT * SEGMENT,MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * CHARACTER*4 lesinc(7),lesdua(7) DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/ DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/ * DIMENSION CRIGI(12),CMASS(12) CHARACTER*4 CMOT CHARACTER*8 CMATE * SEGACT,MCOORD 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 * * PPJ IF (IFOUR.EQ.-3)THEN IF (IFOUR.EQ.-3.AND.MFR.NE.35)THEN IP=IIPDPG 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 IRTD=1 * IF (mfr.eq.28) THEN jgn = 4 if (ifour.eq.2) then jgm = 6 segini mlmots iinc = mlmots do igm = 1,jgm mots(igm) = lesinc(igm) enddo segini mlmots idua = mlmots do igm= 1,jgm mots(igm) = lesdua(igm) enddo else if (ifour.lt.0) then jgm = 4 segini mlmots iinc = mlmots mots(1) = lesinc(1) mots(2) = lesinc(2) mots(3) = lesinc(4) mots(4) = lesinc(5) segini mlmots idua = mlmots mots(1) = lesdua(1) mots(2) = lesdua(2) mots(3) = lesdua(4) mots(4) = lesdua(5) else if (ifour.eq.0) then jgm = 3 segini mlmots iinc = mlmots mots(1) = lesinc(7) mots(2) = lesinc(3) mots(3) = lesinc(6) segini mlmots idua = mlmots mots(1) = lesdua(7) mots(2) = lesdua(3) mots(3) = lesdua(6) else if (ifour.eq.1) then * a faire endif ENDIF IMODEL = IMOD jmat = 0 DO imat = 1 , matmod(/2) if (matmod(imat).eq.'IMPEDANCE') then jmat = imat * goto 29 endif ENDDO 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 * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9 GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6 & , 99, 99, 99, 99, 99, 99, 29, 99, 99, 99, 99 * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 & , 99, 99, 99, 99, 99, 99, 99, 99, 29, 99, 99 * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO & , 45, 46, 99, 99, 99, 99, 99, 99, 99, 99, 99 * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 & , 99, 99, 99, 99, 99, 99, 29, 99, 99, 99, 99 * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 & , 99, 99, 99, 99, 99, 99, 46, 99, 99, 99, 99 * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8 & , 99, 46, 124, 99, 99, 99, 99, 99, 99, 99, 99 * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * TE56 PY91 TRH6 & , 99, 99, 99),MELE C C GOTO(168,169,170,171,172),MELE-167 C GOTO 99 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)) XAMOR=VELCHE(IGMN,IBMN) XINAM = XAMOR if (melva1.gt.0) then igmn = MIN(IG,melva1.VELCHE(/1)) XINAM = melva1.VELCHE(IGMN,IBMN) endif do idl = 1,jddl JDIAG = JDIAG + 1 RE(JDIAG,JDIAG,ib) = XAMOR if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINAM if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINAM enddo enddo ENDDO GOTO 510 ENDIF C_______________________________________________________________________ C C ELEMENTS POUTRE TUYAU ET POUTRE TIMOSCHENKO C_______________________________________________________________________ C 29 CONTINUE NBBB=NBNN SEGINI WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C KERRE=0 DO 3029 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 CAS DE L'ELEMENT LITU OU LA MATRICE DE RIGIDITE EST NULLE C IF (MELE.EQ.98) THEN CALL ZERO(REL,LRE,LRE) GOTO 8029 ENDIF C C RANGEMENT DES CARACTERISTIQUES DANS WORK C SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION C NCARR1=NCARR IF(IVECT.EQ.1) NCARR1=NCARR-1 CALL ZERO(WORK,NCARR1,1) DO 4030 IGAU=1,NBNN 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 IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 6029 CONTINUE 4030 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.D0 6229 CONTINUE ENDIF ENDIF C MPTVAL=IVAMAT C C AUTRES CAS ...... C MELVAL=IVAL(1) * IF(CMATE.NE.'SECTION') THEN IBMN=MIN(IB,VELCHE(/2)) VALMAT(1)=VELCHE(1,IBMN) YOUNG=VALMAT(1) C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE C EQUIVALENTE IF(MELE.EQ.42) THEN IF (ICAS.EQ.2) WORK(10)=WORK(9) WORK(9)=WORK(8) WORK(8)=WORK(7) WORK(7)=WORK(6) EPAIS=WORK(1) REXT=WORK(2) RINT=REXT-EPAIS RACO=WORK(3) PRES=WORK(4) CISA=WORK(5) XIN=XPI*(REXT**4-RINT**4)*0.25D00 WORK(1)=2.D00*XIN WORK(2)=XIN WORK(3)=XIN WORK(4)=XPI*(REXT**2-RINT**2) WORK(5)=WORK(4)*0.5D0*CISA WORK(6)=WORK(5) 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 IF (ICAS.EQ.2) THEN WORK(11)=VALMAT(1) WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2)) ELSE WORK(10)=VALMAT(1) WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2)) ENDIF ENDIF ENDIF C C 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 C 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 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 CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) ENDIF ENDIF C------------- C PROVISOIRE 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 IF (ICAS.EQ.2) THEN WORK(11)=VALMAT(1) WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2)) ELSE WORK(10)=VALMAT(1) WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2)) ENDIF ENDIF C------------- C ENDIF C------------- * * CAS DE LA FORMULATION SECTION * ELSE * * ON REGARDE SI ON A LA COMPOSANTE MAHO * SI OUI, ON LA PREND * C IF(IVAL(3).NE.0) THEN C MELVAL=IVAL(3) C IBMN=MIN(IB,IELCHE(/2)) C MLREEL=IELCHE(1,IBMN) C SEGACT MLREEL C IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) C $ CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL * C ELSE IBMN=MIN(IB,IELCHE(/2)) IPMODL=IELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,IELCHE(/2)) IPMAT=IELCHE(1,IBMN) CALL FAMORE(IPMODL,IPMAT,CRIGI,CMASS) IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) $ CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) C ENDIF ENDIF C C C FIN TRAITEMENT DES DONNEES MATERIAUX C IF(MELE.EQ.97) THEN CALL ACORIG(REL,LRE,WORK,XE,KERRE) ELSE IF(MELE.EQ.84) THEN IF (ICAS.EQ.1) THEN C C Matrice d amortissement symetrique Timo C C IF(CMATE.NE.'SECTION') THEN C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),KERRE) ELSE CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),KERRE) ENDIF * ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK, $ DDHOOK,KERRE) ELSE CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK, $ DDHOOK,KERRE) ENDIF ENDIF C ELSE C C Matrice de raideur antisymetrique Timo (seulement en 3D) C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN KERRE = 1 ELSE C IF(CMATE.NE.'SECTION') THEN CALL TIMDH3(REL,WORK,XE,KERRE) ELSE C KERRE = 1 C ENDIF C CALL TIFDH3(REL,WORK,XE,LHOOK,DDHOOK,KERRE) ENDIF ENDIF ENDIF ELSE C IF (ICAS.EQ.1) THEN C C Matrice d amortissement symetrique Poutre IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL POURI2(REL,LRE,WORK,XE,WORK(12),KERRE) ELSE CALL POURIG(REL,LRE,WORK,XE,WORK(12),KERRE) ENDIF ELSE C C Matrice de raideur antisymetrique Poutre (seulement en 3D) C IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN KERRE = 1 ELSE CALL POUDH3(REL,WORK,XE,KERRE) ENDIF ENDIF ENDIF C IF(KERRE.NE.0) INTERR(1)=ISOUS IF(KERRE.NE.0) INTERR(2)=IB C 4029 CONTINUE 8029 CONTINUE * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C DO 4028 IIIA=1,LRE DO 4028 IIIB=1,LRE RE(IIIA,IIIB,IB)=REL(IIIA,IIIB) 4028 CONTINUE 3029 CONTINUE IF(KERRE.EQ.1) CALL ERREUR(128) IF(KERRE.EQ.2) CALL ERREUR(138) 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,WRK3,MVELCH GOTO 510 C_______________________________________________________________________ C C ELEMENT POI1 C_______________________________________________________________________ C 45 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 if (melval.gt.0) IBMN=MIN(IB,VELCHE(/2)) do IG = 1, NBPGAU if (melval.gt.0) igmn = MIN(IG,VELCHE(/1)) XAMOR = 0.D0 if (melval.gt.0) XAMOR=VELCHE(IGMN,IBMN) XINAM = XAMOR if (melva1.gt.0) then igmn = MIN(IG,melva1.VELCHE(/1)) XINAM = melva1.VELCHE(IGMN,IBMN) endif do idl = 1,jddl JDIAG = JDIAG + 1 RE(JDIAG,JDIAG,ib) = XAMOR if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINAM if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINAM enddo * enddo enddo ENDDO GOTO 510 ENDIF IF (MFR.EQ.26) THEN * MODAL DO IB = 1,NBELEM * SEGINI XMATRI * IMATTT(IB)=XMATRI MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) XFREQ=VELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) XMASS=VELCHE(1,IBMN) MELVAL=IVAL(4) if (melval.gt.0) then IBMN=MIN(IB,VELCHE(/2)) XAMOR=VELCHE(1,IBMN) else xamor = 0. endif OMEG = 2. * XPI * XFREQ RE(1,1,IB) = XMASS * OMEG * XAMOR ENDDO GOTO 510 * ELSE IF (MFR.EQ.28) THEN * STATIQUE DO IB = 1,NBELEM * SEGINI XMATRI * IMATTT(IB)=XMATRI MPTVAL=IVAMAT MELVAL=IVAL(4) IBMN=MIN(IB,VELCHE(/2)) if (melval.gt.0) then segact melval XAMOR=VELCHE(1,IBMN) else re(1,1,IB) = 0.d0 endif if (xamor.ne.0.d0) then MELVAL=IVAL(1) IBMN=MIN(IB,IELCHE(/2)) idepl=IELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,IELCHE(/2)) itreac=IELCHE(1,IBMN) CALL XTY1(idepl,itreac,iinc,idua,XR1) if (ierr.ne.0) then return endif MELVAL=IVAL(3) IBMN=MIN(IB,IELCHE(/2)) imade=IELCHE(1,IBMN) CALL XTY1(idepl,imade,iinc,idua,XM1) if (ierr.ne.0) then return endif x1 = xm1 * xr1 re(1,1,IB) = SQRT(ABS(x1))*xamor if (x1.lt.0.) re(1,1,IB) = re(1,1,IB) *(-1.d0) endif ENDDO GOTO 510 ENDIF * C_______________________________________________________________________ C C ELEMENTS BARRE ET CERCE C_______________________________________________________________________ C 46 CONTINUE * IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN GO TO 99 ENDIF NBBB=NBNN SEGINI WRK1,WRK3 IF(MELE.EQ.123) THEN NSTN=NBNN LRN =LRE SEGINI WRK5 ENDIF C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C KERRE=0 DO 3046 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C C ON RECUPERE LA SECTION DE L'ELEMENT C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) SECT=VELCHE(1,IBMN) C C ON CHERCHE LE COEFF DE LA MAT DE HOOKE C MPTVAL=IVAMAT * 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(1,1),IRTD) C IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE) IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE) IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB) IF(KERRE.NE.0) INTERR(1)=ISOUS IF(KERRE.NE.0) INTERR(2)=IB C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 3046 CONTINUE IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128) IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601) IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128) 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,WRK3,MVELCH IF(MELE.EQ.123) SEGSUP WRK5 GOTO 510 C C_______________________________________________________________________ C C ELEMENT BARRE 3D EXCENTRE (BAEX) C_______________________________________________________________________ C 124 CONTINUE NBBB=NBNN NBNO=NBNN NSTRS1=NSTRS NSTRS=NBNN SEGINI WRK1,WRK2,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C KERRE=0 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 ON CHERCHE LE COEFF DE LA MAT DE HOOKE C MPTVAL=IVAMAT DO 9108 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 9108 CONTINUE IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1 CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD) C C BGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE) IF(KERRE.NE.0) INTERR(1)=ISOUS IF(KERRE.NE.0) INTERR(2)=IB IF(KERRE.EQ.1) CALL ERREUR(128) CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE) C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 3108 CONTINUE NSTRS=NSTRS1 SEGSUP WRK1,WRK2,WRK3,MVELCH GOTO 510 C *_______________________________________________________________________ * 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='AMOR' CALL ERREUR(86) * 510 CONTINUE RETURN END