C AMOR2 SOURCE PV090527 26/04/30 21:15:04 12529 SUBROUTINE AMOR2(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS, & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT, & IPORE,NDDL,IPMATR,IIPDPG,NCAR1) *---------------------------------------------------------------------* * _________________________________________ * * | | * * | CALCUL DE LA MATRICE D AMORTISSEMENT | * * |_______________________________________| * * * * massif * * * *---------------------------------------------------------------------* * * * 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 de caractéristiques * * CMATE Nom du materiau * * MFR Numero de la formulation element fini * * NBGMAT Taille maxi des melval du materiau (pt de gauss) * * NELMAT Taille maxi des melval du materiau (No d'element) * * IMAT (2 il y a une matrice de HOOKE,1 non ) * * NMATT Nombre de composante de materiau (IMAT=1) * * LHOOK Dimension de la matrice de Hooke * * IPORE Nombre de fonctions de forme * * NDDL Nombre de degre de liberte * * * * 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 SMCOORD -INC SMLREEL -INC TMPTVAL SEGMENT,MWRK1 REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK) REAL*8 REL(LRE,LRE) ,RINT(LRE,LRE) , XE(3,NBBB) ENDSEGMENT * SEGMENT,MWRK2 REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE) ENDSEGMENT * SEGMENT,MWRK8 REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM) REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK) ENDSEGMENT * SEGMENT,MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT * segment,mwrk67 real*8 valcar(nca1) endsegment * CHARACTER*8 CMATE,CELEM DIMENSION A(4,60),BB(3,60),PP(4,4),xatef1(3,3) logical drend,BDPGE * * WRITE (*,*) 'Entrée dans AMOR2.' MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) * NV1=NMATT SEGINI,MVELCH * XMATRI=IPMATR NLIGRP=LRE NLIGRD=LRE SEGACT,MCOORD * INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT * DE LA SECTION EN DEFO PLANE GENERALISEE * En 1D : pas de rotation IF (IFOUR.EQ.-3) THEN BDPGE=.TRUE. IREF=(IIPDPG-1)*(IDIM+1) XDPGE=XCOOR(IREF+1) YDPGE=XCOOR(IREF+2) ELSE IF ((IFOUR.GE.7.AND.IFOUR.LE.11).OR.IFOUR.EQ.14) THEN BDPGE=.TRUE. XDPGE=XZero YDPGE=XZero ELSE BDPGE=.FALSE. XDPGE=0.D0 YDPGE=0.D0 ENDIF * NHRM=NIFOUR * MINTE=IPMINT C_______________________________________________________________________ C C NUMERO DES ETIQUETTES : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : C 5 CONTINUE C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... C 44 CONTINUE C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... C_______________________________________________________________________ C GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99, 1 99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99, 4,99,99,99,99, 4 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 5 99,99,99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 6 4, 4),MELE * IF (MELE.EQ.183.OR.MELE.EQ.184.OR. . MELE.EQ.193.OR.MELE.EQ.194) GOTO 4 GOTO 99 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET ELEMENTS INCOMPRESSIBLES C_______________________________________________________________________ C 4 CONTINUE DIM3=1.D0 IRTD=1 * * CAS ORTHOTROPE ( 2) ANISOTROPE ( 3) UNIDIRECTIONNEL (4) * IPMIN2=0 IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) 1 .AND.IMAT.EQ.1)THEN * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE * L'ELEMENT POUR LE CALCUL DES AXES LOCAUX NLG=NUMGEO(MELE) CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1) MINTE2=IPMIN2 SEGACT MINTE2 SEGINI,MWRK8 ENDIF NBNO=NBNN NBBB=NBNN SEGINI,MWRK1,MWRK2 DO 3004 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 CALCUL DES AXES LOCAUX DANS LE CAS DES MATERIAUX ORTHOTROPE , C ANISOTROPE ET UNIDIRECTIONNEL C C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) C* 1 .AND.IMAT.EQ.1)THEN IF (IPMIN2.NE.0) THEN NBSH=MINTE2.SHPTOT(/2) CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) if (nbsh.eq.-1) then call erreur(525) GOTO 4999 endif ENDIF C CALL ZERO (RINT,LRE,LRE) C C CALCUL DES COEFF DE MODIFICATION DE LA MATRICE B-BARRE C (Uniquement en cas d'elements incompressibles) IF (MFR.EQ.31) THEN * WRITE(ioimp,*) 'Appel de BBCALC - IFOUR = ',IFOUR CALL BBCALC(MELE,NBNN,MFR,IDIM,XE, & NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, & NSTRS,LRE,IFOUR,NHRM,A,BB,SHPTOT,SHPWRK, & BGENE,XDPGE,YDPGE,PP,NOER) IF (NOER.NE.0) THEN CALL ERREUR(noer) RETURN ENDIF ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 4004 IGAU=1,NBPGAU C C RECUPERATION DE L'EPAISSEUR C IF (IFOUR.EQ.-2)THEN MPTVAL=IVACAR IF (IVACAR.NE.0) THEN MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) DIM3=VELCHE(IGMN,IBMN) ELSE DIM3=1.D0 ENDIF ENDIF ENDIF * CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,XE, 2 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) IF (DJAC.EQ.0.D0) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 4999 ENDIF IF (DJAC.LT.0.D0) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) C En cas d'elements incompressibles : BGENE selon la methode B-BARRE IF (MFR.EQ.31) THEN CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE) ENDIF 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) SEGDES MLREEL ELSE IF (IMAT.EQ.1) THEN DO 9004 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 9004 CONTINUE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)THEN IF (IGAU.LE.NBGMAT) 1 CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO, 2 ROTH,DDHOOK,LHOOK,1,IRTD) ELSE IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1 CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD) ENDIF IF (IRTD.EQ.0) THEN MOTERR(1:8)=CMATE MOTERR(9:16)=NOMFR(MFR/2+1) INTERR(1)=IFOUR CALL ERREUR(81) GOTO 510 ENDIF ENDIF C C CHOIX POUR BDB/DEFO PLANE GENE --- PRODUIT MATRICIEL NORMAL C /MASSIF ------------ PRODUIT PAR BLOC C * initialise CALL ZERO (REL,LRE,LRE) * calcul rigidite elementaire C** IF (IFOUR.EQ.-3) THEN IF (BDPGE) THEN CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) ELSE CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE, 1 IGAU,IMAT,0.D0) ENDIF * matrice d'efficacite drend = .false. MPTVAL=IVACAR IF (IVACAR.GT.0) THEN segact mptval nca1 = ival(/1) segini,mwrk67 celem = 'MASSIF ' IF(IVAL(NCAR1).GT.0.OR.IVAL(NCAR1+1).GT.0) THEN DO 9008 IM= 1,IVAL(/1) IF (IVAL(IM).GT.0) THEN MELVAL=IVAL(IM) IF (TYVAL(IM).EQ.'REAL*8') THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALCAR(IM)=VELCHE(IGMN,IBMN) ELSE IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) VALCAR(IM)=IELCHE(IGMN,IBMN) ENDIF ELSE VALCAR(IM)=0.D0 ENDIF 9008 CONTINUE nstep = 2 if (ifour.eq.2) nstep = 3 if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then drend = .true. do i = 1,nstep do j = 1, nstep xatef1(i,j) = 0.d0 enddo xatef1(i,i) = valcar(ncar1) enddo endif if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then drend = .false. do i = 1,nstep do j = 1, nstep xatef1(i,j) = 0.d0 enddo xatef1(1,1) = valcar(ncar1+7) xatef1(2,2) = valcar(ncar1+8) if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9) enddo endif call effi2(valcar,tyval,nca1,ncar1,rel,lre,ib,igau,xatef1, & nstep,drend,celem) ENDIF ENDIF * stocke do ii = 1,LRE do jj = 1,LRE rint(ii,jj) = rint(ii,jj) + rel(ii,jj) enddo enddo * 4004 CONTINUE C IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1) = IB CALL ERREUR(195) GOTO 4999 ENDIF C C REMPLISSAGE DE XMATRI C c CALL REMPMT(RINT,LRE,RE) C+DC C IF (ICAS.NE.3) THEN DO IBK=1,LRE DO IAK=1,LRE RE(IAK,IBK,IB)=RINT(IAK,IBK) ENDDO ENDDO C DO 4110 IAK=1,LRE/2 C DO 4110 IBK=1,LRE/2 C RE(2*IAK-1,2*IBK-1)=RINT(IAK,IBK) C 4110 CONTINUE C ENDIF 3004 CONTINUE C Fin du traitement - Menage 4999 CONTINUE IF (IPMIN2.NE.0) THEN C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) C* 1 .AND.IMAT.EQ.1)THEN SEGDES MINTE2 SEGSUP,MWRK8 ENDIF SEGSUP,MWRK1,MWRK2 GOTO 510 * 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='AMOR2 ' CALL ERREUR(86) * 510 CONTINUE SEGSUP,MVELCH * SEGDES XMATRI * WRITE (*,*) 'Sortie de AMOR2.' RETURN END