C RIGI4 SOURCE PV090527 26/04/30 21:16:20 12529 *---------------------------------------------------------------------* * ________________________ * * | | * * | CALCUL DE LA RIGIDITE | * * |________________________| * * * * poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,joint 3D, * * cerce, tuyo,joints 2D, litu,zone cohesives * * * *---------------------------------------------------------------------* * * * 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) * * IMAT (2 il y a une matrice de HOOKE,1 non ) * * 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 * * * * * SORTIES : * * ________ * * * * IPMATR pointeur sur la rigidite de la sous-zone * * * *---------------------------------------------------------------------* SUBROUTINE RIGI4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS, & IVAMAT,IVACAR,IVECT,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK, & NMATT,NCARR,ISOUS,LW,IPORE,IPMATR,IIPDPG) 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 -INC TMPTVAL 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 c cccccc REAL*8 BPSS(3,3),XEL(3,NBBB),rell(lre,lre),XPA(IDIM,IDIM) REAL*8 XPB(IDIM,IDIM) c cccccc ENDSEGMENT SEGMENT WRK5 REAL*8 XGENE(NSTN,LRN) ENDSEGMENT SEGMENT WRK6 REAL*8 PSS(3,3) ENDSEGMENT SEGMENT WRK7 REAL*8 PROPEL(14) REAL*8 OUT(5) REAL*8 WORK1(24*24) ENDSEGMENT SEGMENT,MVELCH REAL*8 VALMAT(NV1) 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'/ DATA X577/.577350269189626D0/ DIMENSION CRIGI(12),CMASS(12) CHARACTER*8 CMATE MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) NV1=NMATT SEGINI,MVELCH XMATRI=IPMATR * NLIGRP=LRE * NLIGRD=LRE C Introduction du point autour duquel se fait le mouvement C de la section en defo plane generalisee C IIPDPG = numero du noeud/point support si defini pour le modele C IIPDPG > 0 si prise en compte du point support C <- Ici test equivalent a IF (IFOUR.EQ.-3)THEN IF (IIPDPG.GT.0) THEN IREF=(IIPDPG-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 * cas cmate 'STATIQUE' 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 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) * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9 & GOTO ( 99, 2, 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, 30, 99, 99, 99 * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 & , 99, 99, 99, 99, 99, 99, 99, 99, 29, 43, 99 * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO & , 45, 46, 99, 99, 99, 30, 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, 85, 86, 87, 88 * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 & , 99, 99, 99, 92, 99, 99, 46, 96, 29, 29, 99 * HYQ4 & , 99),MELE IF (MELE.LE.200) * HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 & GOTO ( 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, 125, 126, 127, 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, 92, 51, 51, 51, 51, 51, 51, 51, 51 * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? & , 51, 168, 169, 170, 171, 172, 51, 51, 51, 51, 51 * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 * ???? ???? & , 51, 51),MELE-100 IF (MELE.LE.300) * ???? ???? ???? ???? ???? ???? ???? ???? ???? & GOTO ( 51, 51, 51, 51, 51, 51, 51, 51, 51 * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? & , 51, 51, 51, 51, 258, 51, 260, 51, 51, 51, 51 * JOI1 ZCO2 ZCO3 ZCO4 c cccccc & , 129, 266, 266, 266, 51,51,271,272),MELE-200 c cccccc 51 CONTINUE GOTO 99 2 CONTINUE if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or. &cmate.eq.'IMPREUSS'.or.cmate.eq.'IMPCOMPL') 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 * kich 1 pgau inutile IGAU = 1 JDIAG = 0 IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) if (cmate.eq.'IMPCOMPL') then MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL XRAID = prog(1) else XRAID = VELCHE(IGMN,IBMN) XTORS = XRAID if (melva1.gt.0) then XTORS = melva1.VELCHE(IGMN,IBMN) endif endif do j=1,jddl JDIAG = JDIAG + 1 if (j.le.3) then RE(JDIAG,JDIAG,IB) = XRAID RE(JDIAG,JDIAG+jddl,IB) = XRAID*(-1.D0) else RE(JDIAG,JDIAG,IB) = XTORS RE(JDIAG,JDIAG+jddl,IB) = XTORS*(-1.D0) endif enddo do j=jddl+1,LRE JDIAG = JDIAG + 1 if (j.le.jddl+3) then RE(JDIAG,JDIAG,IB) = XRAID RE(JDIAG,JDIAG-jddl,IB) = XRAID*(-1.D0) else RE(JDIAG,JDIAG,IB) = XTORS RE(JDIAG,JDIAG-jddl,IB) = XTORS*(-1.D0) endif enddo ENDDO C SEGDES XMATRI goto 510 endif if (mele.eq.2) goto 99 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-3 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 MPTVAL=IVAMAT C C CAS DE L'ACOUSTIQUE PURE C IF (MELE.EQ.97) THEN DO 7029 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB,VELCHE(/2)) WORK(IM+9)=VELCHE(1,IBMN) ELSE WORK(IM+9)=0.D0 ENDIF 7029 CONTINUE ELSE C C AUTRES CAS ...... C MELVAL=IVAL(1) * IF(CMATE.NE.'SECTION') THEN * ON RECUPERE LE MODULE D'YOUNG SI IMAT = 1 IF(IMAT.EQ.1) THEN IBMN=MIN(IB,VELCHE(/2)) VALMAT(1)=VELCHE(1,IBMN) YOUNG=VALMAT(1) C C ON CHERCHE LES COEFF DES MAT DE HOOKE SI IMAT = 2 C 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) C SEGDES MLREEL * IF(MELE.EQ.42) THEN EPAIS=WORK(1) REXT=WORK(2) RINT=REXT-EPAIS SD =XPI*(REXT**2-RINT**2) YOUNG = DDHOOK(1,1)/SD ENDIF ENDIF C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE C EQUIVALENTE IF(MELE.EQ.42) THEN PRES=WORK(4) CISA=WORK(5) ** write(6,*) 'tuykar ncarr',ncarr, ** > work(6),work(7),work(8),work(9),work(10) 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 PROVISOIRE C------------- IF(IMAT.EQ.2) THEN IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN WORK(4)=DDHOOK(1,1)/WORK(1) WORK(5)=DDHOOK(2,2)/(MAX(WORK(3),WORK(1))) ELSE * *ZZZZ ATTENTION A LA DIVISION PAR 0. * WORK(10)=DDHOOK(1,1)/WORK(4) * IF(ABS(WORK(5)).LT.XPETIT/XZPREC) THEN IF(ABS(DDHOOK(2,2)).GE.XPETIT/XZPREC) then MOTERR(1:4)='SECY' CALL ERREUR(46) RETURN ELSE work(11)=0.d0 ENDIF Else WORK(11)=DDHOOK(2,2)/WORK(5) ENDIF 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 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 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 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) C SEGDES MLREEL C 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) C 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 ENDIF 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(CMATE.NE.'SECTION') THEN 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 ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL POURH2(REL,LRE,WORK,XE,WORK(12),IMAT, & LHOOK, DDHOOK, KERRE) ELSE CALL POURHG(REL,LRE,WORK,XE,WORK(12),IMAT, & LHOOK, DDHOOK, KERRE) 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 CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 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) return ENDIF C SEGDES XMATRI SEGSUP WRK1,WRK3,MVELCH GOTO 510 C_______________________________________________________________________ C C ELEMENTS LINESPRING LISP ET LISM C_______________________________________________________________________ C 30 CONTINUE NBBB=NBNN NSTRS=2 SEGINI WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3030 IB=1,NBELEM C C ON CHRCHE LES COORDONNEES DES NOEUDS C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C ON CHERCHE LES COEFFS DE 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) C 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 POINT DEGAUS C IE=0 MPTVAL=IVACAR DO IC=1,3,2 DO ID=1,NCARR IE=IE+1 MELVAL=IVAL(ID) IGMN=MIN(IC,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) WORK(IE)=VELCHE(IGMN,IBMN) enddo enddo C C CALCUL DE LA RIGIDITE C CALL LISPRI(XE,WORK,DDHOOK,WORK(11),MELE,REL,I70,I343,I157,I158) C IF(I70.EQ.1) INTERR(1)=IB IF(I158.EQ.1) INTERR(1)=IB IF(I343.EQ.1) INTERR(1)=IB * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3030 CONTINUE C IF(I70.EQ.1) CALL ERREUR(70) IF(I158.EQ.1) CALL ERREUR(158) IF(I343.EQ.1) CALL ERREUR(343) IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF C SEGDES XMATRI SEGSUP WRK1,WRK3,MVELCH GOTO 510 C_______________________________________________________________________ C C ELEMENT TUYAU FISSURE C_______________________________________________________________________ C 43 CONTINUE NBBB=NBNN NSTRS=2 SEGINI WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3043 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 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) C 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 DOHFIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CHERCHER LES CARACTERISTIQUES C MPTVAL=IVACAR DO 4043 IC=1,NCARR MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) 4043 CONTINUE C C ON CALCULE SA RAIDEUR C CALL TUFIRI(REL,WORK(1),DDHOOK,I137) IF(I137.NE.0) INTERR(1)=ISOUS IF(I137.NE.0) INTERR(2)=IB C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 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) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF C SEGDES XMATRI SEGSUP WRK1,WRK3,MVELCH GOTO 510 C_______________________________________________________________________ C C ELEMENT POI1 C_______________________________________________________________________ C 45 CONTINUE if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or. &cmate.eq.'IMPREUSS'.or.cmate.eq.'IMPCOMPL') then MPTVAL=IVAMAT MELVAL=IVAL(1) if (ival(/1).gt.1) then melva1 = ival(2) else melva1 = 0 endif DO IB = 1,NBELEM JDIAG = 0 * SEGINI XMATRI * IMATTT(IB)=XMATRI IBMN=MIN(IB,VELCHE(/2)) do igau = 1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) XRAID = VELCHE(IGMN,IBMN) XTORS = XRAID if (melva1.gt.0) then XTORS = melva1.VELCHE(IGMN,IBMN) endif do j =1,LRE JDIAG = JDIAG + 1 if (j.le.3) then RE(JDIAG,JDIAG,IB) = XRAID else RE(JDIAG,JDIAG,IB) = XTORS endif enddo enddo * SEGDES XMATRI ENDDO C SEGDES XMATRI goto 510 endif IF (CMATE.EQ.'MODAL') THEN * MODAL DO IB = 1,NBELEM 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) OMEG = 2. * XPI * XFREQ RE(1,1,IB) = XMASS * OMEG * OMEG cbp-2017-10-02 if (xfreq.lt.0) RE(1,1,IB) = RE(1,1,IB) * (-1.) if (XFREQ.LT.0.D0) RE(1,1,IB) = 0.D0 ENDDO GOTO 510 * ELSE IF (CMATE.EQ.'STATIQUE') THEN * STATIQUE DO IB = 1,NBELEM MPTVAL=IVAMAT 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,X1) if (ierr.ne.0) return re(1,1,IB) = x1 ENDDO C SEGDES XMATRI GOTO 510 ENDIF * IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN GOTO 99 ENDIF NBBB=NBNN SEGINI WRK1,WRK3 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C KERRE=0 DO 3045 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 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) C 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(1,1),IRTD) ENDIF CALL PO1RIG(REL,LRE,DDHOOK(1,1),XE,KERRE,XDPGE,YDPGE) C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3045 CONTINUE IF(IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) ENDIF C SEGDES XMATRI SEGSUP WRK1,WRK3,MVELCH GOTO 510 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 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) C 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(1,1),IRTD) ENDIF 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)) * SEGDES XMATRI 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 C SEGDES XMATRI 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 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) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN 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) ENDIF 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)) * SEGDES XMATRI 3108 CONTINUE NSTRS=NSTRS1 C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK3,MVELCH GOTO 510 C_______________________________________________________________________ C C LIA2 : element de liaison a 2 noeuds (6 ddl par noeuds) C_______________________________________________________________________ C 125 CONTINUE NBBB=NBNN NBNO=NBNN SEGINI WRK1,WRK2,WRK3,WRK4 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C KERRE=0 DO 3109 IB=1,NBELEM 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,BPSS,KERRE) IF(KERRE.NE.0) INTERR(1)=ISOUS IF(KERRE.NE.0) INTERR(2)=IB IF(KERRE.EQ.1) CALL ERREUR(128) CALL RIGLI2(REL,LRE,BPSS,WORK) C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3109 CONTINUE C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK3,MVELCH GOTO 510 *------------------------------------------------------------- C_______________________________________________________________________ C C JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds) C_______________________________________________________________________ C 129 CONTINUE NBBB=NBNN NBNO=NBNN SEGINI WRK1,WRK2,WRK3,WRK4 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C KERRE=0 DO 3110 IB=1,NBELEM 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) C SEGDES MLREEL CALL RIGJOL(REL,LRE,DDHOOK,LHOOK,IDIM) IF(IDIM.EQ.2) THEN NCA=2 ELSE NCA=6 ENDIF * MPTVAL=IVACAR DO IC=1,NCA 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 CALL MAPALU(NCA,WORK,BPSS,IDIM) ELSE 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 c on calcule la matrice de rigidité locale c CALL RIGJOI(NMATT,REL,LRE,WORK,IDIM,CMATE) CALL MAPALU(NMATT,WORK,BPSS,IDIM) ENDIF c c on passe en repère global c IAW1=101 IAW2=IAW1+LRE*LRE IAW3=IAW2+LRE*LRE IAW4=IAW3+LRE*LRE CALL JOIGLO(REL,BPSS,WORK(IAW1),WORK(IAW2), & WORK(IAW3),WORK(IAW4),LRE,IDIM) * C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * * SEGDES XMATRI 3110 CONTINUE C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK3,MVELCH GOTO 510 *------------------------------------------------------------- c c element coaxial COS2 (3D pour liaison acier-beton) c 271 continue NBBB=NBNN lw=5 SEGINI WRK1,WRK4,wrk3 do 3271 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 CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM) MPTVAL=IVAmat if(imat.eq.1) then DO IC=1,2 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 ELSE MELVAL=IVAL(1) IBMN=MIN(IB,IELCHE(/2)) MLREEL=IELCHE(1,IBMN) SEGACT MLREEL if(idim.eq.3) then work(1)= prog(1) work(2) = prog(9) else if (idim.eq.1.or.idim.eq.2) then CALL ERREUR(81) endif C segdes mlreel endif C C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) xv1= xe(1,2)-xe(1,1) yv1= xe(2,2)-xe(2,1) zv1=0.d0 if( idim.eq.3) zv1 = xe(3,2)-xe(3,1) xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1) C C recuperation de la section et calcul du diamètre C MPTVAL=IVACAR DO 2712 ICOMP=1,NCARR MELVAL=IVAL(ICOMP) IGMN = VELCHE(/1) IBMN=MIN(IB,VELCHE(/2)) SECA =VELCHE(IGMN,IBMN) 2712 CONTINUE diam = sqrt(4.d0*SECA/xpi) C xls1 = (3.d0*xpi*diam*xl)/8.d0 xls2 = (1.d0*xpi*diam*xl)/8.d0 xks1 = xls1*work(1) xks2 = xls2*work(1) xln1 = (3.d0*diam*xl)/8.d0 xln2 = (1.d0*diam*xl)/8.d0 xkn1 = xln1*work(2) xkn2 = xln2*work(2) xks = work(1) xkn = work(2) if (idim.eq.2) then C cas de matrice elastique rel(1,1)= xks1 rel(1,3)= xks2 rel(1,5)= -xks2 rel(1,7)=-xks1 rel(7,7)= xks1 rel(7,1)=-xks1 rel(7,3)= -xks2 rel(7,5)= xks2 rel(3,3)=xks1 rel(3,5)=-xks1 rel(3,1)= xks2 rel(3,7)= -xks2 rel(5,5)=xks1 rel(5,3)=-xks1 rel(5,1)= -xks2 rel(5,7)= xks2 c --------------------------- rel(2,2)= xkn1 rel(2,4)= xkn2 rel(2,6)= -xkn2 rel(2,8)=-xkn1 rel(8,8)= xkn1 rel(8,2)=-xkn1 rel(8,4)= -xkn2 rel(8,6)= xkn2 rel(4,4)=xkn1 rel(4,6)=-xkn1 rel(4,2)= xkn2 rel(4,8)= -xkn2 rel(6,6)=xkn1 rel(6,4)=-xkn1 rel(6,2)= -xkn2 rel(6,8)= xkn2 else if (idim.eq.3) then C cas de matrice elastique rel(1,1)= xks1 rel(1,4)= xks2 rel(1,7)= -xks2 rel(1,10)=-xks1 rel(10,10)= xks1 rel(10,1)=-xks1 rel(10,4)= -xks2 rel(10,7)= xks2 rel(4,4)=xks1 rel(4,7)=-xks1 rel(4,1)= xks2 rel(4,10)= -xks2 rel(7,7)=xks1 rel(7,4)=-xks1 rel(7,1)= -xks2 rel(7,10)= xks2 C ------- remplissage de KN ------------ rel(2,2)= xkn1 rel(2,5)= xkn2 rel(2,8)= -xkn2 rel(2,11)=-xkn1 rel(11,11)= xkn1 rel(11,2)=-xkn1 rel(11,5)= -xkn2 rel(11,8)= xkn2 rel(5,5)=xkn1 rel(5,8)=-xkn1 rel(5,2)= xkn2 rel(5,11)= -xkn2 rel(8,8)=xkn1 rel(8,5)=-xkn1 rel(8,2)= -xkn2 rel(8,11)= xkn2 c------------ rel(3,3)= xkn1 rel(3,6)= xkn2 rel(3,9)= -xkn2 rel(3,12)=-xkn1 rel(12,12)= xkn1 rel(12,3)=-xkn1 rel(12,6)= -xkn2 rel(12,9)= xkn2 rel(6,6)=xkn1 rel(6,9)=-xkn1 rel(6,3)= xkn2 rel(6,12)= -xkn2 rel(9,9)=xkn1 rel(9,6)=-xkn1 rel(9,3)= -xkn2 rel(9,12)= xkn2 endif do ia = 1, 4 do ic = 1,4 do io=1,idim do iu=1,idim xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu) enddo enddo call prodt(xpb,xpa,bpss,idim,idim) do io=1,idim do iu=1,idim rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu) enddo enddo enddo enddo C C REMPLISSAGE DE XMATRI C CALL REMPMT(RELL,LRE,RE(1,1,IB)) 3271 continue C SEGDES XMATRI SEGSUP WRK1,WRK3,WRK4 GOTO 510 c cccccc C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE COA2 C C_______________________________________________________________________ C 272 continue NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 C C BOUCLE POUR TOUS LES ELEMENTS 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 ZERO (REL,LRE,LRE) C C CALCUL DES AXES LOCAUX C CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM) DO 2722 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 C C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) xv1= xe(1,2)-xe(1,1) yv1= xe(2,2)-xe(2,1) zv1=0.d0 if( idim.eq.3) zv1 = xe(3,2)-xe(3,1) xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1) C C recuperation de la section et calcul du diamètre C MPTVAL=IVACAR DO 2729 ICOMP=1,NCARR MELVAL=IVAL(ICOMP) IGMN = VELCHE(/1) IBMN=MIN(IB,VELCHE(/2)) SECA =VELCHE(IGMN,IBMN) 2729 CONTINUE diam = sqrt(4.d0*SECA/xpi) C DJAC=DJAC*POIGAU(IGAU) C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOCO(PROG,LHOOK,DDHOOK,XL,DIAM) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 2723 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 2723 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOUCO2(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD,XL,DIAM) END IF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 2722 CONTINUE C do ia = 1,4 do ic = 1,4 do io=1,idim do iu=1,idim xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu) enddo enddo call prodt(xpb,xpa,bpss,idim,idim) do io=1,idim do iu=1,idim rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu) enddo enddo enddo enddo C C REMPLISSAGE DE XMATRI C CALL REMPMT(RELL,LRE,RE(1,1,IB)) 2721 CONTINUE C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C c SEGDES XMATRI 9985 CONTINUE SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 *----------------------------------------------------------------------- C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE JOI2 C C_______________________________________________________________________ C 85 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 C C BOUCLE POUR TOUS LES ELEMENTS C DO 3085 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 CALCUL DES AXES LOCAUX C CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) C CCC IF (NOQUAL.EQ.1) THEN CCCC NOEUDS TROP VOISINS CCC INTERR(1)=IB CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS CCC CALL ERREUR(323) CCC ELSE IF ( NOQUAL.EQ.2 ) THEN CCCC JOINT NON PLAN CCC INTERR(1)=IB CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS CCC CALL ERREUR(323) CCC RETURN CCC ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO 4085 IGAU=1,NBPGAU C C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, + BGENE,DJAC,IRRT) DJAC=DJAC*POIGAU(IGAU) * IF (IFOUR.EQ.0) THEN C C EN AXISYMETRIE, ON MULTIPLIE PAR R C (R=RAYON DE COURBURE DU POINT DE GAUSS) C RAYON=0.0D0 NUMSUP=NBNO/2 * DO 5085 IRAY=1,NUMSUP RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) ) 5085 CONTINUE * modif TC * dr = XE(1,2)-xe(1,1) * ra= XE(1,1) * rb= XE(1,2) * rayona = rb*rb*rb/6.d0 - 0.5d0*ra*ra*rb +ra*ra*ra /3.d0 * rayona=rayona *2.d0 /dr / dr * rayonb= rb*rb*rb/3.d0 - 0.5d0*ra*rb*rb +ra*ra*ra /6.d0 * rayonb=rayonb *2.d0 / dr / dr * rayon= rayona * if(igau.eq.2) rayon=rayonb DJAC=DJAC*RAYON ENDIF C C IRRT=1 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) ENDIF C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9085 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 9085 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 4085 CONTINUE C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3085 CONTINUE C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE JGI2 C C_______________________________________________________________________ C 170 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 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 CALL ZERO (REL,LRE,LRE) C C CALCUL DES AXES LOCAUX C CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) C C BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C C ON CHERCHE L EPAISSEUR DU JOINT C EPAIST=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=VELCHE(IGMN,IBMN) ENDIF C C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CcPPj CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, CcPPj. EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT) CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK, . EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT) DJAC=DJAC*POIGAU(IGAU) C IF (IFOUR.EQ.0) THEN C C EN AXISYMETRIE, ON MULTIPLIE PAR R C (R=RAYON DE COURBURE DU POINT DE GAUSS) C RAYON=0.0D0 NUMSUP=NBNO/2 DO IRAY=1,NUMSUP RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) ) ENDDO DJAC=DJAC*RAYON ENDIF C C IRRT=1 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) ENDIF C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 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 ENDDO IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) ENDDO C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI ENDDO C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE JCT3 en 2D cisaillement C C_______________________________________________________________________ C 168 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 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 CALL ZERO (REL,LRE,LRE) C C CALCUL DES AXES LOCAUX C CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) C IF (NOQUAL.EQ.1) THEN INTERR(1)=IB MOTERR(1:4) = 'JGT3' CALL ERREUR(765) RETURN ELSE IF ( NOQUAL.EQ.2) THEN INTERR(1)=IB MOTERR(1:4) = 'JGT3' CALL ERREUR(766) RETURN ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C 4 C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, + BGENE,DJAC,IRRT) DJAC=DJAC*POIGAU(IGAU) C IRRT=1 JACOBIEN <= 0 IF(IRRT.NE.0) THEN CALL ERREUR(764) ENDIF C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 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 ENDDO IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) ENDDO C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI ENDDO C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE JGT3 GENERALISE C C_______________________________________________________________________ C 171 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 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 CALL ZERO (REL,LRE,LRE) C C CALCUL DES AXES LOCAUX C CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) C IF (NOQUAL.EQ.1) THEN INTERR(1)=IB MOTERR(1:4) = 'JGT3' CALL ERREUR(765) RETURN ELSE IF ( NOQUAL.EQ.2) THEN INTERR(1)=IB MOTERR(1:4) = 'JGT3' CALL ERREUR(766) RETURN ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C C ON CHERCHE L'EPAISSEUR DU JOINT C EPAIST=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=VELCHE(IGMN,IBMN) ENDIF C 4 C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CcPPj CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK, + EPAIST,BGENE,DJAC,IRRT) DJAC=DJAC*POIGAU(IGAU) C IRRT=1 JACOBIEN <= 0 IF(IRRT.NE.0) THEN CALL ERREUR(764) ENDIF C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 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 ENDDO IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) ENDDO C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI ENDDO C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE JCI4 en 2D cisaillement C C_______________________________________________________________________ C 169 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 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 CALL ZERO (REL,LRE,LRE) C C CALCUL DES AXES LOCAUX C CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) IF (NOQUAL.EQ.1) THEN INTERR(1)=IB MOTERR(1:4) = 'JCI4' CALL ERREUR(765) RETURN ELSE IF ( NOQUAL.EQ.2 ) THEN INTERR(1)=IB MOTERR(1:4) = 'JCI4' CALL ERREUR(766) RETURN ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) DJAC=DJAC*POIGAU(IGAU) C IRRT=1 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) ENDIF C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 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 ENDDO IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) ENDDO C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI ENDDO C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE JGI4 GENERALISE C C_______________________________________________________________________ C 172 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 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 CALL ZERO (REL,LRE,LRE) C C CALCUL DES AXES LOCAUX C CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) IF (NOQUAL.EQ.1) THEN INTERR(1)=IB MOTERR(1:4) = 'JGI4' CALL ERREUR(765) RETURN ELSE IF ( NOQUAL.EQ.2 ) THEN CbPPj INTERR(1)=IB CbPPj MOTERR(1:4) = 'JGI4' CbPPj CALL ERREUR(766) CbPPj RETURN WRITE(IOIMP,*)'RIGI4(WARNING): JGI4 element number',IB, . ' not planar' ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO IGAU=1,NBPGAU C C ON CHERCHE L'EPAISSEUR DU JOINT C EPAIST=0.D0 MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) EPAIST=VELCHE(IGMN,IBMN) ENDIF C C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CcPPj CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IRRT) CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC, . IRRT) DJAC=DJAC*POIGAU(IGAU) C IRRT=1 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) ENDIF C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 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 ENDDO IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) ENDDO C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI ENDDO C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 C C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE JOI3 SANS TEST DE PLANEITE C ET SANS REPERE LOCAL C C_______________________________________________________________________ C 86 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 C C BOUCLE POUR TOUS LES ELEMENTS C DO 3086 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 BOUCLE SUR LES POINTS DE GAUSS C DO 4086 IGAU=1,NBPGAU C C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CALL JO3LOC(XE,SHPTOT,IGAU,NBNO,BPSS) CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK, + BGENE,DJAC,IRRT) DJAC=DJAC*POIGAU(IGAU) * IF (IFOUR.EQ.0) THEN C C EN AXISYMETRIE, ON MULTIPLIE PAR R C (R=RAYON DE COURBURE DU POINT DE GAUSS) C RAYON=0.0D0 NUMSUP=NBNO/2 DO 5086 IRAY=1,NUMSUP RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) ) 5086 CONTINUE DJAC=DJAC*RAYON ENDIF C C IRRT=1 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) ENDIF C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9086 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 9086 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 4086 CONTINUE C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3086 CONTINUE C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE JOT3 C C_______________________________________________________________________ C 87 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 C C BOUCLE POUR TOUS LES ELEMENTS C DO 3087 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 CALCUL DES AXES LOCAUX C CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) C IF (NOQUAL.EQ.1) THEN INTERR(1)=IB MOTERR(1:4) = 'JOT3' CALL ERREUR(765) RETURN ELSE IF ( NOQUAL.EQ.2) THEN INTERR(1)=IB MOTERR(1:4) = 'JOT3' CALL ERREUR(766) RETURN ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO 4087 IGAU=1,NBPGAU C 4 C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, + BGENE,DJAC,IRRT) DJAC=DJAC*POIGAU(IGAU) C IRRT=1 JACOBIEN <= 0 IF(IRRT.NE.0) THEN CALL ERREUR(764) ENDIF C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9087 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 9087 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 4087 CONTINUE C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3087 CONTINUE C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LE JOI4 C C_______________________________________________________________________ C 88 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4 C C BOUCLE POUR TOUS LES ELEMENTS C DO 3088 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 CALCUL DES AXES LOCAUX C CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) IF (NOQUAL.EQ.1) THEN INTERR(1)=IB MOTERR(1:4) = 'JOI4' CALL ERREUR(765) RETURN ELSE IF ( NOQUAL.EQ.2 ) THEN INTERR(1)=IB MOTERR(1:4) = 'JOI4' CALL ERREUR(766) RETURN ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO 4088 IGAU=1,NBPGAU C C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU C CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) DJAC=DJAC*POIGAU(IGAU) C IRRT=1 JACOBIEN <= 0 IF(IRRT.NE.0) THEN INTERR(1)=IB CALL ERREUR(611) ENDIF C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9088 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 9088 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 4088 CONTINUE C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3088 CONTINUE C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISE TRIH C_______________________________________________________________________ C 92 CONTINUE NBNO=NBNN NBBB=NBNN LRN =NBNN NSTN=3 SEGINI WRK1,WRK2 ,WRK5 I195=0 DO 3092 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) * MPTVAL=IVAMAT DO 9092 IM=1,10 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 9092 CONTINUE C C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB C RHOF =VALMAT(4) E =VALMAT(6) C =VALMAT(7) RHOREF=VALMAT(8) CREF =VALMAT(9) RLCAR =VALMAT(10) C C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB C MPTVAL=IVACAR IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) SCEL =VELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) SFLU =VELCHE(1,IBMN) MELVAL=IVAL(3) IBMN=MIN(IB,VELCHE(/2)) EPS =VELCHE(1,IBMN) MELVAL=IVAL(4) IBMN=MIN(IB,VELCHE(/2)) XINERT=VELCHE(1,IBMN) EI = E*XINERT/(EPS*EPS) ELSE MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) SCEL =VELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) SFLU =VELCHE(1,IBMN) MELVAL=IVAL(3) IBMN=MIN(IB,VELCHE(/2)) EPS =VELCHE(1,IBMN) C E REPRESENTE LA RIGIDITE MODALE DE LA POUTRE EI = E /(EPS*EPS) ENDIF C C CALCUL DES COEFFICIENTS DE NORMALISATION C COEFPR=(RHOREF*CREF*CREF)/RLCAR VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL) VKL2 = EI/SCEL C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 4092 IGAU=1,NBPGAU CALL TRIHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT, # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT) IF(IRRT.NE.1) GOTO 5092 DJAC=DJAC*POIGAU(IGAU) CALL TRIHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL) 4092 CONTINUE IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3092 CONTINUE C C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR C 5092 CONTINUE IF(IRRT.EQ.0) THEN MOTERR(1:4)=NOMTP(MELE) CALL ERREUR(420) ELSE IF(IRRT.EQ.2) THEN INTERR(1)=IB CALL ERREUR(405) ENDIF ENDIF IF(I195.NE.0) INTERR(1)=I195 IF(I195.NE.0) CALL ERREUR(195) C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK5,MVELCH GOTO 510 *_______________________________________________________________________ * * ELEMENT TUYO *_______________________________________________________________________ * 96 CONTINUE NBNO=IPORE NBBB=NBNN SEGINI WRK1,WRK2,WRK3,WRK6 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3096 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) CALL ZERO (REL,LRE,LRE) * XL=(XE(1,2)-XE(1,1))**2+(XE(2,2)-XE(2,1))**2+ . (XE(3,2)-XE(3,1))**2 XL=SQRT(XL) IF(XL.EQ.0.D0) THEN KERRE=1 GO TO 3096 ENDIF C C RANGEMENT DES CARACTERISTIQUES DANS WORK C ON SUPPOSE QU'ELLES SONT CONSTANTES POUR L'ELEMENT C VX VY VZ sont supposes etre a la fin C ** write(6,*) 'rigi4 en 2695' 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 TRAITEMENT DU VECTEUR C ** 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.D0 *6296 CONTINUE ** ENDIF C C CALCUL DU REPERE LOCAL C CALL TUYPAS(XE,XL,WORK,PSS,KERRE) IF(KERRE.NE.0) THEN INTERR(1)=IB CALL ERREUR(5 ) RETURN ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C DO 4096 IGAU=1,NBPGAU C C TRAITEMENT DU MATERIAU C IL PEUT VARIER D'UN POINT DE GAUSS A L'AUTRE C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,IELCHE(/2)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) . CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL * ELSE IF (IMAT.EQ.1) THEN * DO 9096 IM=1,NMATT IF (IVAL(IM).NE.0) THEN MELVAL=IVAL(IM) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) VALMAT(IM)=VELCHE(IGMN,IBMN) ELSE VALMAT(IM)=0.D0 ENDIF 9096 CONTINUE CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) EPAIST=WORK(1) CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) ENDIF * * CALCUL DE LA MATRICE B ET DU JACOBIEN * CALL BTUYO(IGAU,MINTE,WRK1,WRK2,WRK3,XL,DJAC,KERRE) DJAC=DJAC*POIGAU(IGAU) * IF(KERRE.NE.0) THEN INTERR(1)=IB CALL ERREUR(5) ENDIF * * CALCUL ET INTEGRATION DE BTDB * CALL BDBST(BGENE,DJAC,DDHOMU,LRE,NSTRS,REL) 4096 CONTINUE * * CHANGEMENT DE BASE * CALL TUYROT(REL,LRE,PSS,1) * * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3096 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) return ENDIF C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK3,WRK6,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES QUAH C_______________________________________________________________________ C 126 CONTINUE C NBNO=NBNN NBBB=NBNN LRN =NBNN+NBNN NSTN=2 SEGINI WRK1,WRK2 ,WRK5 I195=0 DO 3126 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) * MPTVAL=IVAMAT DO 9126 IM=1,10 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 9126 CONTINUE C C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB C RHOF =VALMAT(4) E =VALMAT(6) C =VALMAT(7) RHOREF=VALMAT(8) CREF =VALMAT(9) RLCAR =VALMAT(10) C C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) SCEL =VELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) SFLU =VELCHE(1,IBMN) MELVAL=IVAL(3) IBMN=MIN(IB,VELCHE(/2)) EPS =VELCHE(1,IBMN) MELVAL=IVAL(5) IBMN=MIN(IB,VELCHE(/2)) XINERT=VELCHE(1,IBMN) EI = E*XINERT/(EPS*EPS) C C CALCUL DES COEFFICIENTS DE NORMALISATION C COEFPR=(RHOREF*CREF*CREF)/RLCAR VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL) VKL2 = EI/SCEL C C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 4126 IGAU=1,NBPGAU CALL QUAHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT, # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT) IF(IRRT.NE.1) GOTO 5126 DJAC=DJAC*POIGAU(IGAU) CALL QUAHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL) 4126 CONTINUE IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3126 CONTINUE C C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR C 5126 CONTINUE IF(IRRT.EQ.0) THEN MOTERR(1:4)=NOMTP(MELE) CALL ERREUR(420) ELSE IF(IRRT.EQ.2) THEN INTERR(1)=IB CALL ERREUR(405) ENDIF ENDIF IF(I195.NE.0) INTERR(1)=I195 IF(I195.NE.0) CALL ERREUR(195) C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK5,MVELCH GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES CUBH C_______________________________________________________________________ C 127 CONTINUE NBNO=NBNN NBBB=NBNN LRN =NBNN*2 NSTN=2 C SEGINI WRK1,WRK2 ,WRK5 I195=0 DO 3127 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) * MPTVAL=IVAMAT DO 9127 IM=1,10 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 9127 CONTINUE C C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB C RHOF =VALMAT(4) E =VALMAT(6) C =VALMAT(7) RHOREF=VALMAT(8) CREF =VALMAT(9) RLCAR =VALMAT(10) C C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) SCEL =VELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) SFLU =VELCHE(1,IBMN) MELVAL=IVAL(3) IBMN=MIN(IB,VELCHE(/2)) EPS =VELCHE(1,IBMN) MELVAL=IVAL(5) IBMN=MIN(IB,VELCHE(/2)) XINERT=VELCHE(1,IBMN) EI = E*XINERT/(EPS*EPS) C C CALCUL DES COEFFICIENTS DE NORMALISATION C COEFPR=(RHOREF*CREF*CREF)/RLCAR VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL) VKL2 = EI/SCEL C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 4127 IGAU=1,NBPGAU CALL CUBHR1(IGAU,MELE,MFR,NBNO,NIFOUR,XE,SHPTOT, # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT) IF(IRRT.NE.1) GOTO 5127 DJAC=DJAC*POIGAU(IGAU) C C CALL CUBHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL) 4127 CONTINUE IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI 3127 CONTINUE C C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR C 5127 CONTINUE IF(IRRT.EQ.0) THEN MOTERR(1:4)=NOMTP(MELE) CALL ERREUR(420) ELSE IF(IRRT.EQ.2) THEN INTERR(1)=IB CALL ERREUR(405) ENDIF ENDIF IF(I195.NE.0) INTERR(1)=I195 IF(I195.NE.0) CALL ERREUR(195) C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK5,MVELCH GOTO 510 C_______________________________________________________________________ C C ELEMENTS CIFL MACRO ELEMENT CISAILLEMENT FLEXION C C_______________________________________________________________________ C 258 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK3,WRK4 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 CALL ZERO (REL,LRE,LRE) C C PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX C CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE) C C CALCUL DE LA MATRICE DE HOOK C MPTVAL=IVAMAT IF(IMAT.EQ.2) THEN MELVAL=IVAL(1) IGMN=MIN(1,IELCHE(/1)) MLREEL=IELCHE(IGMN,IBMN) SEGACT MLREEL IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN 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 C CALCUL ET INTEGRATION DE BDB 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 BDBST(BGENE,1.D0,DDHOOK,LRE,NSTRS,REL) C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI ENDDO C C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK3,WRK4,MVELCH GOTO 510 C_______________________________________________________________________ C C ELEMENT DE COQUE VOLUMIQUE SHB8 C_______________________________________________________________________ C 260 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4,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 CALL ZERO (REL,LRE,LRE) MPTVAL=IVAMAT DO 9070 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)=XZERO ENDIF 9070 CONTINUE PROPEL(1)=VALMAT(1) PROPEL(2)=VALMAT(2) DO IM=3,12 PROPEL(IM)=VALMAT(1) ENDDO PROPEL(13)=XZERO PROPEL(14)=VALMAT(1) WORK1(1)=IB DO IM=1,5 REL(IM,1)=XZERO ENDDO cbp loi de comportement a utiliser = c 1 : improved plane-stress constitutive law c [Abed-Meiram & Combescure, IJNME, 2009] c 2 : plane-stress constitutive law c 3 : tridimensional constitutive law cbp OUT(1)=3 OUT(1)=1 C C CALCUL DE LA MATRICE DE RIGIDITE C call SHB8 (2,XE,DDHOOK,PROPEL,WORK1,REL,OUT) C * SEGINI XMATRI * IMATTT(IB)=XMATRI C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) * SEGDES XMATRI ENDDO C SEGDES XMATRI SEGSUP WRK1,WRK2,WRK4,WRK7,MVELCH GOTO 510 * C_______________________________________________________________________ C C ELEMENTS DE ZONE COHESIVE ZCO2, ZCO3, ZCO4 C_______________________________________________________________________ C 266 CONTINUE NDIM = 2 IF(IFOUR.GT.0) NDIM = 3 NBNO=NBNN NBBB=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 CALL ZERO (REL,LRE,LRE) C C BOUCLE SUR LES POINTS DE GAUSS C DO 6266 IGAU=1,NBPGAU C CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS) C CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT, . NSTRS,NBNN,LRE,MELE,SHPWRK,BGENE,DJAC,IERT) IF (IERT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) GOTO 99266 ENDIF C DJAC=DJAC*POIGAU(IGAU) C C CALCUL DE 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) C SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9266 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 9266 CONTINUE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOU266(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF C C CALCUL ET INTEGRATION DE BDB C CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 6266 CONTINUE C C REMPLISSAGE DE XMATRI C CALL REMPMT(REL,LRE,RE(1,1,IB)) 3266 CONTINUE C C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR C IF (IRTD.EQ.0) THEN MOTERR(1:8) = CMATE MOTERR(9:16) = NOMFR(MFR/2+1) INTERR(1) = IFOUR CALL ERREUR(81) ENDIF C 99266 CONTINUE SEGSUP WRK1,WRK2,WRK4,MVELCH GOTO 510 *_______________________________________________________________________ * 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='RIGI4' CALL ERREUR(86) 510 CONTINUE C SEGDES XMATRI IF (CMATE.eq.'STATIQUE') THEN mlmots = iinc if (iinc.gt.0) segsup mlmots mlmots = idua if (idua.gt.0) segsup mlmots ENDIF c RETURN END