C ELAS1 SOURCE AM 12/03/15 21:22:16 7321 SUBROUTINE ELAS1(IPMODL,IPCHE1,IPCHE2,IPCHE3,IPSTRS,IRET) *_______________________________________________________________________ * * operateur elasticite * * entrees : * --------- * * ipmodl pointeur sur un mmodel * ipche1 pointeur sur un mchaml de contraintes ou de deformations * ipche2 pointeur sur un mchaml de materiau * ipche3 pointeur sur un mchaml de variables internes(facultatif) * * sortie : * -------- * * ipstrs pointeur sur un mchaml de contraintes ou de deformations * iret =1 ou 0 suivant succes ou pas * * passage aux nouveaux chamelem par jm campenon le 01/91 *_______________________________________________________________________ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC CCREEL -INC CCOPTIO -INC CCHAMP -INC SMINTE -INC SMMODEL -INC SMELEME -INC SMCHAML -INC SMCOORD -INC SMLREEL * *_______________________________________________________________________ * la variable kerre regit les impressions d erreurs dans elas1 * * kerre=0 tout ok * =49 matrice de hooke singuliere *_______________________________________________________________________ * SEGMENT IWRK1 REAL*8 VALCAR(NCARRw),VALMAT(NMATT),VAR(NVART) REAL*8 SIGF(NSTRS),EPSI(NSTRS) REAL*8 DDHOOK(LHOOK,LHOOK),DDHOMU(LHOOK,LHOOK) REAL*8 COBMA(LHOOK) ENDSEGMENT * SEGMENT WPOUT REAL*8 SIG1(NSTRS),SIG2(NSTRS) ENDSEGMENT * SEGMENT IWRK2 REAL*8 XE(3,NBNN),TXR(IDIM,IDIM) REAL*8 XLOC(IDIM,IDIM),XGLOB(IDIM,IDIM) REAL*8 D1HOOK(LHOOK,LHOOK),ROTHOO(LHOOK,LHOOK) REAL*8 COBAUX(LHOOK) ENDSEGMENT * SEGMENT IWRK4 REAL*8 VECO1(LHOOK),VECO2(LHOOK) ENDSEGMENT * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * DIMENSION CRIGI(12),CMASS(12),S(20) CHARACTER*8 CMATE,PHAM CHARACTER*(NCONCH) CONM LOGICAL LSUPDE,LSUPCO,lsupma,lsupca,lsupre,lsupin,lsupva PARAMETER ( NINF=3 ) PARAMETER(DEUX=2.D0,UNDEMI=.5D0,SIX=6.D0) PARAMETER(X774=.774596669241483D0) INTEGER INFOS(NINF) * IRET=0 KERRE=0 * * Reduction des mchamls sur le modele * call reduaf(ipche1,ipmodl,ipch,0,ir,kerre) if (ir.ne.1) call erreur(kerre) if (ierr.ne.0) return ipche1=ipch * call reduaf(ipche2,ipmodl,ipch,0,ir,kerre) if (ir.ne.1) call erreur(kerre) if (ierr.ne.0) return ipche2=ipch * IF (IPCHE3.NE.0) THEN call reduaf(ipche3,ipmodl,ipch,0,ir,kerre) if (ir.ne.1) call erreur(kerre) if (ierr.ne.0) return ipche3=ipch ENDIF * * Verification du type de IPCHE1 ! * KCAS = 0 MCHELM=IPCHE1 SEGACT MCHELM IF (TITCHE.EQ.'CONTRAINTES') THEN KCAS=2 ELSE IF(TITCHE.EQ.'DEFORMATIONS') THEN KCAS=1 ENDIF IF (KCAS.EQ.0) THEN SEGDES,MCHELM MOTERR(1:8)='CONTRAIN' MOTERR(9:16)='DEFORMAT' CALL ERREUR(109) RETURN ENDIF * * Verification du lieu support des mchamls * CALL QUESUP(IPMODL,IPCHE1,5,0,ISUP1,IRET1) IF (ISUP1.GT.1) RETURN CALL QUESUP(IPMODL,IPCHE2,5,0,ISUP2,IRET2) IF (ISUP2.GT.1) RETURN IF (IPCHE3.NE.0) THEN CALL QUESUP(IPMODL,IPCHE3,5,0,ISUP3,IRET3) IF (ISUP3.GT.1) RETURN ENDIF * * activation du modele * MMODEL=IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) KEL22 = 0 DO ISOUS=1,NSOUS IMODEL=KMODEL(ISOUS) SEGACT,IMODEL IF (NEFMOD.EQ.22) KEL22 = KEL22 + 1 ENDDO * * creation du mchelm * N1=NSOUS - KEL22 N3=6 IF (KCAS.EQ.1) THEN L1=11 SEGINI MCHEL1 MCHEL1.TITCHE='CONTRAINTES' ELSE IF (KCAS.EQ.2) THEN L1=12 SEGINI MCHEL1 MCHEL1.TITCHE='DEFORMATIONS' ENDIF MCHEL1.IFOCHE=IFOUR IPSTRS=MCHEL1 * *_______________________________________________________________________ * * debut de la boucle sur les differentes sous zones *_______________________________________________________________________ * isouss=0 DO 500 ISOUS=1,NSOUS * lsupma=.true. NMATR=0 NMATF=0 NCARA=0 NCARF=0 NVART=0 MORES=0 NRES=0 IVAMAT=0 IVACAR=0 IVARI=0 MOMATR=0 MOCARA=0 * * on recupere l'information generale * IMODEL=KMODEL(ISOUS) C* SEGACT IMODEL MELE=NEFMOD if( mele.eq.22) go to 500 * * traitement du modele * isouss=isouss+1 IPMAIL=IMAMOD CONM =CONMOD PHAM = conmod(17:24) MCHEL1.IMACHE(ISOUSs)=IPMAIL MCHEL1.CONCHE(ISOUSs)=CONMOD * MELEME=IPMAIL SEGACT MELEME NBNN=NUM(/1) NBELEM=NUM(/2) * * creation du tableau infos * CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD) IF (IRTD.EQ.0) THEN SEGSUP MCHEL1 GOTO 9992 ENDIF * * coque integree ou pas * IF(INFMOD(/1).NE.0) THEN NPINT=INFMOD(1) ELSE NPINT=0 ENDIF * * information sur l'element fini * * CALL ELQUOI(MELE,0,5,IPINF,IMODEL) * IF (IERR.NE.0) THEN * SEGSUP MCHEL1 * GOTO 9992 * ENDIF MFR =INFELE(13) NBPGAU=INFELE(6) IF ((MELE.EQ.29.OR.MFR.EQ.13). 1 AND.NBPGAU.NE.1.AND.NBPGAU.NE.2) THEN CALL ERREUR(712) GOTO 9992 ENDIF NSTRS=INFELE(16) LHOOK=INFELE(10) IPORE=INFELE(8) IPPORE=0 NBNO=NBNN IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN IPPORE=NBNN NBNO=IPORE ENDIF * * cas des dkt integres * IF (MFR.EQ.3.AND.NPINT.NE.0) LHOOK=4 * LHOO2=LHOOK*LHOOK * MINTE=INFELE(11) minte=infmod(7) IPMINT=MINTE SEGACT,MINTE * * nature du materiau * C* NFOR=FORMOD(/2) C* NMAT=MATMOD(/2) C* CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) CMATE = CMATEE MATE = IMATEE INAT = INATUU C* IF (CMATE.EQ.' ') THEN C* CALL ERREUR(251) C* SEGSUP MCHEL1 C* GOTO 9992 C* ENDIF * MCHEL1.INFCHE(ISOUSs,1)=0 MCHEL1.INFCHE(ISOUSs,2)=0 MCHEL1.INFCHE(ISOUSs,3)=NIFOUR MCHEL1.INFCHE(ISOUSs,4)=MINTE MCHEL1.INFCHE(ISOUSs,5)=0 MCHEL1.INFCHE(ISOUSs,6)=5 * * recherche du nom des composantes * lsupre=.false. lsupin=.false. IF(lnomid(5).ne.0) then nomid=lnomid(5) segact nomid nstdef=lesobl(/2) lsupde=.false. mosdef=nomid else CALL IDDEFO(IMODEL,IFOUR,MOSDEF,NSTDEF,NFADEF) lsupde=.true. endif if(lnomid(4).ne.0) then nomid=lnomid(4) segact nomid mostr=nomid nst=lesobl(/2) nfac=lesfac(/2) lsupco=.false. else lsupco=.true. CALL IDCONT(IMODEL,IFOUR,MOstr,Nst,NFAC) endif IF (KCAS.EQ.1) THEN MOSTRS=MOSDEF NSTR=NSTDEF lsupin=lsupde mores = mostr nres=nst lsupre=lsupco ELSE IF (KCAS.EQ.2) THEN lsupin=lsupco MOSTRS=MOSTR NSTR=NST MORES=MOSDEF NRES=NSTDEF lsupre=lsupde ENDIF * * verification de leur presence * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR) SEGSUP NOTYPE IF (IERR.NE.0) THEN NRES=0 GOTO 9990 ENDIF * IF(ISUP1.EQ.1)CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE) * * recherche de la taille des melval a allouer * N1PTEL=NBPGAU N1EL =NBELEM NBPTEL=N1PTEL N2PTEL=0 N2EL =0 * * creation du mchaml de la sous zone * N2=NRES SEGINI MCHAM1 MCHEL1.ICHAML(ISOUSs)=MCHAM1 NS=1 NCOSOU=NRES SEGINI MPTVAL IVARES=MPTVAL NOMID=MORES * write(6,*) ' KCAS ' , kcas, ' nomid ' , nomid SEGACT NOMID DO 1000 ICOMP=1,NRES MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP) MCHAM1.TYPCHE(ICOMP)='REAL*8' SEGINI MELVA1 MCHAM1.IELVAL(ICOMP)=MELVA1 IVAL(ICOMP)=MELVA1 1000 CONTINUE SEGDES NOMID SEGDES MCHAM1 * * traitement des champs de materiau * NOMID=0 NBROBL=0 NBRFAC=0 IF (FORMOD(1).EQ.'MECANIQUE') THEN C* IF (CMATE.EQ.'ISOTROPE') THEN IF (MATE.EQ.1) THEN IF(INAT.EQ.26.AND.IPCHE3.NE.0) THEN NBROBL=3 NBRFAC=0 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' LESOBL(3)='DC ' ELSEIF(INAT.EQ.62) THEN NBROBL=4 NBRFAC=0 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' LESOBL(3)='F' LESOBL(4)='FC' ELSE NBROBL=2 NBRFAC=0 SEGINI NOMID IF (MFR.EQ.35) THEN LESOBL(1)='KS ' LESOBL(2)='KN ' ELSE LESOBL(1)='YOUN' LESOBL(2)='NU ' ENDIF ENDIF C* ELSEIF (CMATE.EQ.'ORTHOTRO') THEN ELSEIF (MATE.EQ.2) THEN IF (MFR.EQ.75) THEN * * JOINT UNIDIMENSIONNEL JOI1 * IF(IDIM.EQ.3)THEN NBROBL=12 NBRFAC=0 SEGINI NOMID LESOBL(1)='V1X ' LESOBL(2)='V1Y ' LESOBL(3)='V1Z ' LESOBL(4)='V2X ' LESOBL(5)='V2Y ' LESOBL(6)='V2Z ' LESOBL(7)='KN ' LESOBL(8)='KS1 ' LESOBL(9)='KS2' LESOBL(10)='QN ' LESOBL(11)='QS1 ' LESOBL(12)='QS2 ' * ELSE IF(IDIM.EQ.2)THEN NBROBL=5 NBRFAC=0 SEGINI NOMID LESOBL(1)='V1X ' LESOBL(2)='V1Y ' LESOBL(3)='KN ' LESOBL(4)='KS ' LESOBL(5)='QS' ENDIF * ELSE IF (MFR.EQ.3) THEN * coques minces NBROBL=6 NBRFAC=0 SEGINI NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12' LESOBL(4)='G12 ' LESOBL(5)='V1X ' LESOBL(6)='V1Y ' ELSE IF (MFR.EQ.9.OR.MFR.EQ.5) THEN * coques avec cisaillement transverse NBROBL=8 NBRFAC=0 SEGINI NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12' LESOBL(4)='G12 ' LESOBL(5)='G23 ' LESOBL(6)='G13 ' LESOBL(7)='V1X ' LESOBL(8)='V1Y ' ELSE IF (MFR.EQ.1.OR.MFR.EQ.31) THEN * elements massifs IF(IDIM.EQ.3)THEN * elements 3d NBROBL=15 NBRFAC=0 SEGINI NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' LESOBL(7)='G12 ' LESOBL(8)='G23 ' LESOBL(9)='G13 ' LESOBL(10)='V1X ' LESOBL(11)='V1Y ' LESOBL(12)='V1Z ' LESOBL(13)='V2X ' LESOBL(14)='V2Y ' LESOBL(15)='V2Z ' ELSE IF (IDIM.EQ.2) THEN IF(IFOUR.EQ.-2) THEN * cont. plane NBROBL=9 NBRFAC=0 SEGINI NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12 ' LESOBL(4)='G12' LESOBL(5)='V1X ' LESOBL(6)='V1Y ' LESOBL(7)='YG3 ' LESOBL(8)='NU23' LESOBL(9)='NU13' ELSE IF (IFOUR.EQ.-1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.-3) $ THEN * deformation plane ,axisymetrie NBROBL=9 NBRFAC=0 SEGINI NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' LESOBL(7)='G12 ' LESOBL(8)='V1X ' LESOBL(9)='V1Y ' ELSE IF (IFOUR.EQ.1) THEN * axisymetrie de fourier NBROBL=11 NBRFAC=0 SEGINI NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' LESOBL(7)='G12 ' LESOBL(8)='G23 ' LESOBL(9)='G13 ' LESOBL(10)='V1X ' LESOBL(11)='V1Y ' ENDIF ELSE IF (IDIM.EQ.1) THEN NBROBL=6 NBRFAC=0 SEGINI,NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' ENDIF ELSE IF (MFR.EQ.35) THEN * elements joints IF (IFOUR.EQ.2) THEN NBROBL=5 NBRFAC=0 SEGINI NOMID LESOBL(1)='KS1 ' LESOBL(2)='KS2 ' LESOBL(3)='KN ' LESOBL(4)='V1X ' LESOBL(5)='V1Y ' ENDIF ENDIF C* ELSEIF (CMATE.EQ.'ANISOTRO') THEN ELSEIF (MATE.EQ.3) THEN * IF(MFR.EQ.75)THEN * * JOINT UNIDIMESIONNEL JOI1 * IF(IDIM.EQ.3)THEN NBROBL=27 NBRFAC=0 SEGINI NOMID LESOBL(1)='V1X ' LESOBL(2)='V1Y ' LESOBL(3)='V1Z ' LESOBL(4)='V2X ' LESOBL(5)='V2Y ' LESOBL(6)='V2Z ' LESOBL(7)='D11 ' LESOBL(8)='D22 ' LESOBL(9)='D33 ' LESOBL(10)='D44 ' LESOBL(11)='D55 ' LESOBL(12)='D66 ' LESOBL(13)='D21 ' LESOBL(14)='D31 ' LESOBL(15)='D32 ' LESOBL(16)='D41 ' LESOBL(17)='D42 ' LESOBL(18)='D43 ' LESOBL(19)='D51 ' LESOBL(20)='D52 ' LESOBL(21)='D53 ' LESOBL(22)='D54 ' LESOBL(23)='D61 ' LESOBL(24)='D62 ' LESOBL(25)='D63 ' LESOBL(26)='D64 ' LESOBL(27)='D65 ' ELSE IF(IDIM.EQ.2)THEN NBROBL=8 NBRFAC=0 SEGINI NOMID LESOBL(1)='V1X ' LESOBL(2)='V1Y ' LESOBL(3)='D11 ' LESOBL(4)='D22 ' LESOBL(5)='D33 ' LESOBL(6)='D21 ' LESOBL(7)='D31 ' LESOBL(8)='D32 ' ENDIF * ELSE IF (MFR.EQ.1.OR.MFR.EQ.31) THEN * elements massifs IF(IDIM.EQ.3)THEN * elements 3d IF (IFOUR.EQ.2) THEN NBROBL=27 NBRFAC=0 SEGINI NOMID LESOBL(1)='D11 ' LESOBL(2)='D21 ' LESOBL(3)='D22 ' LESOBL(4)='D31 ' LESOBL(5)='D32 ' LESOBL(6)='D33 ' LESOBL(7)='D41 ' LESOBL(8)='D42 ' LESOBL(9)='D43 ' LESOBL(10)='D44 ' LESOBL(11)='D51 ' LESOBL(12)='D52 ' LESOBL(13)='D53 ' LESOBL(14)='D54 ' LESOBL(15)='D55 ' LESOBL(16)='D61 ' LESOBL(17)='D62 ' LESOBL(18)='D63 ' LESOBL(19)='D64 ' LESOBL(20)='D65 ' LESOBL(21)='D66 ' LESOBL(22)='V1X ' LESOBL(23)='V1Y ' LESOBL(24)='V1Z ' LESOBL(25)='V2X ' LESOBL(26)='V2Y ' LESOBL(27)='V2Z ' ENDIF ELSE IF (IDIM.EQ.2) THEN IF (IFOUR.EQ.-2) THEN * contrainte plane NBROBL=8 NBRFAC=4 SEGINI NOMID LESOBL(1)='D11 ' LESOBL(2)='D21 ' LESOBL(3)='D22 ' LESOBL(4)='D41 ' LESOBL(5)='D42 ' LESOBL(6)='D44 ' LESOBL(7)='V1X ' LESOBL(8)='V1Y ' LESOBL(9)='D31 ' LESOBL(10)='D32 ' LESOBL(11)='D33 ' LESOBL(12)='D43 ' ELSE IF (IFOUR.EQ.-1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.-3) $ THEN * deformation plane ,axisymetrie NBROBL=12 NBRFAC=0 SEGINI NOMID LESOBL(1)='D11 ' LESOBL(2)='D21 ' LESOBL(3)='D22 ' LESOBL(4)='D31 ' LESOBL(5)='D32 ' LESOBL(6)='D33 ' LESOBL(7)='D41 ' LESOBL(8)='D42 ' LESOBL(9)='D43 ' LESOBL(10)='D44 ' LESOBL(11)='V1X ' LESOBL(12)='V1Y ' ELSE IF (IFOUR.EQ.1) THEN * axisymetrie de fourier NBROBL=15 NBRFAC=0 SEGINI NOMID LESOBL(1)='D11 ' LESOBL(2)='D21 ' LESOBL(3)='D22 ' LESOBL(4)='D31 ' LESOBL(5)='D32 ' LESOBL(6)='D33 ' LESOBL(7)='D41 ' LESOBL(8)='D42 ' LESOBL(9)='D43 ' LESOBL(10)='D44 ' LESOBL(11)='D55 ' LESOBL(12)='D65 ' LESOBL(13)='D66 ' LESOBL(14)='V1X ' LESOBL(15)='V1Y ' ENDIF ENDIF ENDIF C* ELSEIF (CMATE.EQ.'UNIDIREC') THEN ELSEIF (MATE.EQ.4) THEN IF ((MFR.EQ.1.OR.MFR.EQ.31).AND.IDIM.EQ.3) THEN NBROBL=7 NBRFAC=0 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='V1X ' LESOBL(3)='V1Y ' LESOBL(4)='V1Z ' LESOBL(5)='V2X ' LESOBL(6)='V2Y ' LESOBL(7)='V2Z ' ELSE NBROBL=3 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YOUN' LESOBL(2)='V1X ' LESOBL(3)='V1Y ' ENDIF C* ELSEIF (CMATE.EQ.'ZONE_COH') THEN ELSEIF (MATE.EQ.12) THEN NBROBL=0 NBRFAC=0 IF (MFR.EQ.77) THEN NBROBL=2 SEGINI NOMID MOMATR=NOMID LESOBL(1)='KS ' LESOBL(2)='KN ' ENDIF * ELSE if(lnomid(6).ne.0) then nomid=lnomid(6) segact nomid nbrobl=lesobl(/2) nbrfac=lesfac(/2) lsupma=.false. else CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC) nomid=momatr endif ENDIF ELSE if(lnomid(6).ne.0) then nomid=lnomid(6) segact nomid nbrobl=lesobl(/2) nbrfac=lesfac(/2) lsupma=.false. else CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC) nomid=momatr endif ENDIF MOMATR=NOMID NMATR=NBROBL NMATF=NBRFAC NMATT=NMATR+NMATF * IF (MOMATR.EQ.0) THEN CALL ERREUR(5) GOTO 9990 ENDIF C* IF (CMATE.EQ.'SECTION') THEN IF (MATE.EQ.11) THEN NBTYPE=3 SEGINI NOTYPE TYPE(1)='POINTEURMMODEL' TYPE(2)='POINTEURMCHAML' TYPE(3)='POINTEURLISTREEL' ELSE NBTYPE=1 SEGINI NOTYPE TYPE(1)='REAL*8' ENDIF MOTYPE=NOTYPE * CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 * IF(ISUP2.EQ.1)THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE) ENDIF * * traitement des champs caracteristiques * NOMID =0 NBROBL=0 NBRFAC=0 * * epaisseur et excentrement dans le cas des coques * IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN NBROBL=1 NBRFAC=1 SEGINI NOMID LESOBL(1)='EPAI' LESFAC(1)='EXCE' * * section pour les barres * ELSE IF (MFR.EQ.27) THEN NBROBL=1 SEGINI NOMID LESOBL(1)='SECT' * * section, excentrements et orientation pour les barres excentrees * ELSE IF (MFR.EQ.49) THEN NBROBL=6 SEGINI NOMID LESOBL(1)='SECT' LESOBL(2)='EXCZ' LESOBL(3)='EXCY' LESOBL(4)='VX ' LESOBL(5)='VY ' LESOBL(6)='VZ ' * * raideurs locales et orientation pour l'element LIA2 * de liaison a 2 noeuds * ELSE IF (MFR.EQ.51) THEN NBROBL=9 SEGINI NOMID LESOBL(1)='RLUX' LESOBL(2)='RLUY' LESOBL(3)='RLUZ' LESOBL(4)='RLRX' LESOBL(5)='RLRY' LESOBL(6)='RLRZ' LESOBL(7)='VX ' LESOBL(8)='VY ' LESOBL(9)='VZ ' * * caracteristiques pour les poutres * ELSE IF (MFR.EQ.7 ) THEN C* IF (CMATE.NE.'SECTION') THEN IF (MATE.NE.11) THEN * * CAS 2D * IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN NBRFAC=1 NBROBL=2 SEGINI NOMID LESOBL(1)= 'SECT' LESOBL(2)= 'INRZ' LESFAC(1)= 'SECY' * ELSE NBROBL=4 NBRFAC=2 SEGINI NOMID LESOBL(1)='TORS' LESOBL(2)='INRY' LESOBL(3)='INRZ' LESOBL(4)='SECT' LESFAC(1)='SECY' LESFAC(2)='SECZ' ENDIF ENDIF * * caracteristiques pour les tuyaux * ELSE IF (MFR.EQ.13) THEN NBROBL=2 NBRFAC=3 SEGINI NOMID LESOBL(1)='EPAI' LESOBL(2)='RAYO' LESFAC(1)='RACO' LESFAC(2)='PRES' LESFAC(3)='CISA' * * caracteristiques pour les linespring * ELSE IF (MFR.EQ.15) THEN NBROBL=5 SEGINI NOMID LESOBL(1)='EPAI' LESOBL(2)='FISS' LESOBL(3)='VX ' LESOBL(4)='VY ' LESOBL(5)='VZ ' * * caracteristiques pour les tuyaux fissures * ELSE IF (MFR.EQ.17) THEN NBROBL=9 SEGINI NOMID LESOBL(1)='RAYO' LESOBL(2)='EPAI' LESOBL(3)='VX ' LESOBL(4)='VY ' LESOBL(5)='VZ ' LESOBL(6)='VXF ' LESOBL(7)='VYF ' LESOBL(8)='VZF ' LESOBL(9)='ANGL' * * caracteristiques des elements homogeneises * ELSE IF (MFR.EQ.37) THEN IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN NBROBL=4 SEGINI NOMID LESOBL(1)='SCEL' LESOBL(2)='SFLU' LESOBL(3)='EPS ' LESOBL(4)='XINE' ELSE NBROBL=3 SEGINI NOMID LESOBL(1)='SCEL' LESOBL(2)='SFLU' LESOBL(3)='EPS ' ENDIF ENDIF MOCARA=NOMID NCARA=NBROBL NCARF=NBRFAC ncarr= NCARA+NCARF NCARRw=NCARA+NCARF if( MFR.EQ.13) ncarrw=ncarrw + 10 IF (MOCARA.NE.0) THEN NBTYPE=1 SEGINI NOTYPE TYPE(1)='REAL*8' MOTYPE=NOTYPE CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3 $ ,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 IF (ISUP2.EQ.1) THEN CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE) ENDIF ENDIF * c____________________________________________________________________ c * traitement des champs de variables internes * c____________________________________________________________________ c lsupva=.true. IF(INAT.EQ.62.AND .IPCHE3.EQ.0) NVART = 3 IF (IPCHE3.NE.0) THEN if(lnomid(10).ne.0) then nomid=lnomid(10) segact nomid movari=nomid nvari=lesobl(/2) nvarf=lesfac(/2) lsupva=.false. else CALL IDVARI(MFR,IMODEL,MOVARI,NVARI,NVARF) endif IF (MOVARI.EQ.0) THEN MOTERR(1:4)='VARI' MOTERR(5:8)=NOMTP(MELE) CALL ERREUR(76) GOTO 9990 ENDIF NVART=NVARI+NVARF * NBTYPE=1 SEGINI NOTYPE TYPE(1)='REAL*8' MOTYPE=NOTYPE CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOVARI,MOTYPE,1, 1 INFOS,3,IVARI) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 * IF (ISUP3.EQ.1) THEN CALL VALCHE(IVARI,NVART,IPMIN1,IPPORE) ENDIF ENDIF c____________________________________________________________________ * * recherche des dimensions qui correspondraient * à un MELVAL de HOOKE c____________________________________________________________________ N2PTEL=0 N2EL=0 MPTVAL=IVAMAT DO 1500 IO=1,NMATT IF(IVAL(IO).NE.0)THEN MELVAL=IVAL(IO) C* IF (CMATE.EQ.'SECTION') THEN IF (MATE.EQ.11) THEN N2PTEL=MAX(N2PTEL,IELCHE(/1)) N2EL =MAX(N2EL ,IELCHE(/2)) ELSE N2PTEL=MAX(N2PTEL,VELCHE(/1)) N2EL =MAX(N2EL ,VELCHE(/2)) ENDIF ENDIF 1500 CONTINUE MPTVAL=IVACAR DO 41 IO=1,NCARR IF(IVAL(IO).NE.0)THEN MELVAL=IVAL(IO) C* IF (CMATE.EQ.'SECTION') THEN IF (MATE.EQ.11) THEN N2PTEL=MAX(N2PTEL,IELCHE(/1)) N2EL =MAX(N2EL ,IELCHE(/2)) ELSE N2PTEL=MAX(N2PTEL,VELCHE(/1)) N2EL =MAX(N2EL ,VELCHE(/2)) ENDIF ENDIF 41 CONTINUE IF (IPCHE3.NE.0) THEN MPTVAL=IVARI DO 42 IO=1,NVART IF(IVAL(IO).NE.0)THEN MELVAL=IVAL(IO) C* IF (CMATE.EQ.'SECTION') THEN IF (MATE.EQ.11) THEN N2PTEL=MAX(N2PTEL,IELCHE(/1)) N2EL =MAX(N2EL ,IELCHE(/2)) ELSE N2PTEL=MAX(N2PTEL,VELCHE(/1)) N2EL =MAX(N2EL ,VELCHE(/2)) ENDIF ENDIF 42 CONTINUE ENDIF IF (N2PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN N2PTEL=1 ELSE N2PTEL=NBPGAU ENDIF * * INITIALISATION DES TABLEAUX DE TRAVAIL * NMAT1=NMATT * cette sequence est presente car la troisieme composante * (eventuellement) obligatoire est la septieme composante du materiau IF(INAT.EQ.26) NMATT=NMATT+4 SEGINI IWRK1 IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) SEGINI IWRK4 * IF(MFR.EQ.15) THEN IF(NBPGAU.EQ.1) THEN S(1)= 0.D0 ELSE IF(NBPGAU.EQ.3) THEN S(1)=-X774 S(2)= 0.D0 S(3)= X774 ENDIF ENDIF * IWRK2 = 0 C* IF ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. C* & CMATE.EQ.'UNIDIREC') .OR. IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .OR. & ((MELE.EQ.29.OR.MFR.EQ.13).AND.NBPGAU.EQ.2)) THEN SEGINI IWRK2 ENDIF * * traitement special pour milieu non isotrope * IPMIN2 = 0 IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33) THEN C* IF (CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. C* & CMATE.EQ.'UNIDIREC') THEN IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN IELE=NUMGEO(MELE) CALL RESHPT(1,NBNO,IELE,MELE,NPINT,IPMIN2,IRT1) MINTE2=IPMIN2 SEGACT MINTE2 ENDIF ENDIF * * boucle sur les elements * DO 2000 IB=1,NBELEM * * IF (IWRK2.NE.0) THEN C* IF ( ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. C* & CMATE.EQ.'UNIDIREC').AND. C** IF ( ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .OR. C* & (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33)) .OR. C* & ((MELE.EQ.29.OR.MFR.EQ.13).AND.NBPGAU.EQ.2) ) THEN CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) * IF (IPMIN2.NE.0) THEN C* IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33) THEN * * traitement special pour milieu non isotrope * NBSH=MINTE2.SHPTOT(/2) CALL RLOCAL(XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) if (nbsh.eq.-1) then call erreur(525) return endif ENDIF ENDIF * * boucle sur les points de gauss * DO 3000 IGAU=1,NBPTEL IRECAL=1 * * si N2PTEL et N2EL sont égaux à 1 => champ uniforme dans le maillage * => on ne calcule qu'une fois la matrice de HOOKE * IF(N2PTEL.EQ.1.AND.N2EL.EQ.1) THEN IF(IB.GT.1.OR.IGAU.GT.1) THEN IRECAL=0 ENDIF ENDIF * * si N2PTEL est égal à 1 mais pas N2EL => champ uniforme dans l'élément * => on ne calcule qu'une fois la matrice de HOOKE par élément * IF(N2PTEL.EQ.1.AND.N2EL.NE.1) THEN IF(IGAU.GT.1) THEN IRECAL=0 ENDIF ENDIF c c sinon on RECALCULE ( EXTRAIT DE HOOK2D ) c IF(IRECAL.EQ.1) THEN C MPTVAL=IVAMAT DO 1005 IM=1,NMAT1 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 1005 CONTINUE * * cette sequence est presente car la troisieme composante * (eventuellement) obligatoire est la septieme composante du materiau IF(INAT.EQ.26) THEN VALMAT(7)=VALMAT(3) DO 1006 ICOMP=3,6 VALMAT(ICOMP)=0.D0 1006 CONTINUE ENDIF C IF(INAT.EQ.26.OR.INAT.EQ.29.OR. . INAT.EQ.62.OR.INAT.EQ.64.OR.INAT.EQ.65) THEN MPTVAL=IVARI DO 1007 IM=1,NVART IF (MPTVAL.NE.0) THEN MELVAL=IVAL(IM) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VAR(IM)=VELCHE(IGMN,IBMN) ELSE VAR(IM)=0.D0 ENDIF 1007 CONTINUE ENDIF C IF(MFR.EQ.7.OR.MFR.EQ.13.OR.MFR.EQ.15. 1 OR.MFR.EQ.17) THEN C C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB C C* IF(CMATE.EQ.'SECTION') THEN IF(MATE.EQ.11) THEN C MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) IPMODL=IELCHE(IGMN,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) IPCAR=IELCHE(IGMN,IBMN) CALL FRIGIE(IPMODL,IPCAR,CRIGI,CMASS) C ELSEIF (MFR.EQ.15) THEN 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)) VALCAR(IE)=VELCHE(IGMN,IBMN) ELSE VALCAR(IE)=0.D0 ENDIF IE=IE+1 7030 CONTINUE C ELSE C DO 1010 ICOMP=1,NCARR MPTVAL=IVACAR MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALCAR(ICOMP)=VELCHE(IGMN,IBMN) ELSE VALCAR(ICOMP)=0.D0 ENDIF 1010 CONTINUE ENDIF ENDIF C IF(MFR.EQ.27.OR.MFR.EQ.49) THEN C C ON CHERCHE LA SECTION DE L'ELEMENT IB C MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) SECT=VELCHE(IGMN,IBMN) ELSE SECT=0.D0 ENDIF ENDIF C C Prise en compte de l'epaisseur et de l'excentrement C dans le cas des coques minces avec ou sans cisaillement C transverse C IF (MFR.EQ.3.OR.MFR.EQ.9) THEN C* IF (CMATE.EQ.'ISOTROPE'.OR.CMATE.EQ.'ORTHOTRO'.OR. C* 1 CMATE.EQ.'UNIDIREC') THEN IF (MATE.EQ.1.OR.MATE.EQ.2.OR.MATE.EQ.4) THEN MPTVAL=IVACAR MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) EPAIST=VELCHE(IGMN,IBMN) ELSE CALL ERREUR(527) GOTO 9990 ENDIF C LASURF=0 EXCEN = 0.D0 ENDIF ENDIF C ______________________________________________________________________ C C TRAITEMENT SUIVANT TYPE DE MATERIAU C_______________________________________________________________________ IRETOU = 1 C* IF (CMATE.EQ.'ISOTROPE'.OR.CMATE.EQ.'ZONE_COH') THEN IF (MATE.EQ.1.OR.MATE.EQ.12) THEN CALL HOOKIS(VALMAT,VALCAR,VAR,MFR,IB,IGAU,EXCEN,EPAIST, + INAT,MELE,NPINT,IFOUR,KCAS,N2PTEL,N2EL, + S,SECT,LHOOK,DDHOMU,DDHOOK, + COBMA,XMOB,IRETOU) C C* ELSE IF (CMATE.EQ.'ORTHOTRO') THEN ELSE IF (MATE.EQ.2) THEN CALL HOOKOR(VALMAT,IB,IGAU,MFR,EXCEN,EPAIST, + MELE,NPINT,IFOUR,KCAS,N2PTEL,N2EL,SECT,LHOOK, + TXR,XLOC,XGLOB,D1HOOK,ROTHOO,DDHOMU,DDHOOK, + COBMA,XMOB,IRETOU) C C* ELSE IF (CMATE.EQ.'ANISOTRO') THEN ELSE IF (MATE.EQ.3) THEN CALL HOOKAN(VALMAT,IB,IGAU,MFR,IFOUR,KCAS,N2PTEL,N2EL, + SECT,LHOOK,TXR,XLOC,XGLOB,D1HOOK,ROTHOO,DDHOOK, + MELE,COBMA,XMOB,IRETOU) C C* ELSE IF (CMATE.EQ.'UNIDIREC') THEN ELSE IF (MATE.EQ.4) THEN CALL HOOKUN(VALMAT,IB,IGAU,MFR,EXCEN,EPAIST, + MELE,NPINT,IFOUR,KCAS,N2PTEL,N2EL,SECT,LHOOK, + TXR,XLOC,XGLOB,D1HOOK,ROTHOO,DDHOMU,DDHOOK, + COBMA,XMOB,IRETOU) C ELSE IF (CMATE.EQ.'HOMOGENE') THEN C* ELSE IF (MATE.EQ.9) THEN CALL HOOKHO(VALMAT,IB,IGAU,MFR,N2PTEL,N2EL,SECT, + LHOOK,DDHOOK,IRETOU) C C* ELSE IF (CMATE.EQ.'SECTION') THEN ELSE IF (MATE.EQ.11) THEN CALL HOOKSE(VALMAT,IB,IGAU,MFR,CRIGI,IFOUR, + N2PTEL,N2EL,SECT,LHOOK,DDHOOK,IRETOU) C ENDIF C IF (IRETOU.EQ.0) THEN IF (MFR.EQ.3.AND.NPINT.NE.0) THEN CALL ERREUR(251) ELSE MOTERR(1:8)=NOMFR(MFR/2+1) CALL ERREUR(193) ENDIF GOTO 2000 ENDIF * * inversion si besoin * IF(KCAS.EQ.2.AND.INAT.NE.26.AND.INAT.NE.29. & AND.INAT.NE.65) THEN CALL INVALM(DDHOOK,LHOOK,LHOOK,KERRE,0.D0) IF(KERRE.NE.0) THEN CALL ERREUR(713) GO TO 9992 ENDIF ENDIF * * fin du test irecal ENDIF * * ------ fin de détermination de la matrice de hooke * * * on remplit ici les differentes quantites necessaires * * deformations * MPTVAL=IVASTR IF (KCAS.EQ.2) THEN DO 4000 ICOMP=1,NSTR MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) SIGF(ICOMP)=VELCHE(IGMN,IBMN) 4000 CONTINUE ELSE IF(KCAS.EQ.1) THEN DO 4001 ICOMP=1,NSTR MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) EPSI(ICOMP)=VELCHE(IGMN,IBMN) 4001 CONTINUE ENDIF * * cas des milieux poreux * IF(MFR.EQ.33) THEN * IF(XMOB.EQ.0.D0) THEN ***** INTERR(1)=IB ***** CALL ERREUR(537) UNSURM=0.D0 ELSE UNSURM=1.D0/XMOB ENDIF * * calcul des contraintes ou des deformations * IF(KCAS.EQ.1) THEN * DO 4500 I=1,LHOOK SIGF(I)=-COBMA(I)*EPSI(NSTRS) DO 45001 J=1,LHOOK SIGF(I)=SIGF(I)+DDHOOK(I,J)*EPSI(J) 45001 CONTINUE 4500 CONTINUE * SIGF(NSTRS)=EPSI(NSTRS)*UNSURM DO 4502 I=1,LHOOK SIGF(NSTRS)=SIGF(NSTRS)+COBMA(I)*EPSI(I) 4502 CONTINUE * * ELSE IF (KCAS.EQ.2) THEN * CALL ZERO(VECO1,LHOOK,1) CALL ZERO(VECO2,LHOOK,1) FAC1 = 0.D0 FAC2 = 0.D0 DO 5003 I=1,LHOOK DO 5004 J=1,LHOOK VECO1(I)=VECO1(I)+DDHOOK(I,J)*SIGF(J) VECO2(I)=VECO2(I)+DDHOOK(I,J)*COBMA(J) 5004 CONTINUE FAC1 = FAC1 + COBMA(I)*VECO1(I) FAC2 = FAC2 + COBMA(I)*VECO2(I) 5003 CONTINUE EPSI(NSTRS)=(SIGF(NSTRS)-FAC1)/(UNSURM+FAC2) DO 5000 I=1,LHOOK EPSI(I)=0.D0 DO 50001 J=1,LHOOK EPSI(I)=EPSI(I)+DDHOOK(I,J)* . (SIGF(J)+ COBMA(J)*EPSI(NSTRS)) 50001 CONTINUE 5000 CONTINUE ENDIF * * autres cas * ELSE * IF(KCAS.EQ.1) THEN DO 5500 I=1,LHOOK SIGF(I)=0.D0 DO 55001 J=1,LHOOK SIGF(I)=SIGF(I)+DDHOOK(I,J)*EPSI(J) 55001 CONTINUE 5500 CONTINUE ELSE IF (KCAS.EQ.2) THEN DO 6000 I=1,LHOOK EPSI(I)=0.D0 DO 60001 J=1,LHOOK EPSI(I)=EPSI(I)+DDHOOK(I,J)*SIGF(J) 60001 CONTINUE 6000 CONTINUE ENDIF * * cas des tuyaux fissures * IF (MFR.EQ.17.AND.KCAS.EQ.1) THEN * MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) YOU=VELCHE(IGMN,IBMN) * RAYO=VALCAR(1) EPAI=VALCAR(2) TETA1=VALCAR(9)*UNDEMI c conversion de teta1 en radian TETA = (TETA1 * XPI)/180.D0 TESPI = TETA/XPI c on met dans 'raymo' le rayon moyen du tuyau. RAYMO =RAYO - (EPAI/DEUX) c calcul de a coefiicient zahor RSURT=RAYMO / EPAI IF(RSURT.LE.10.D0.AND.RSURT.GE.4.9D0) THEN AXX = ( .125D0*RSURT - .25D0 ) **.25D0 ELSE IF(RSURT.GT.10.D0.AND.RSURT.LE.35.D0) THEN AXX = ( .4D0*RSURT - 3.D0 ) **.25D0 ELSE KERRE=4 ENDIF CALL TUFIFP(TESPI,AXX,FP,FM,FMP,FOP,FOM) c c facteur d intensite des contraintes c IF(TETA1.LE.(0.5D0))THEN SIGF(7)=0.D0 SIGF(8)=0.D0 GOTO 6500 ENDIF SQQ= XPI * RAYMO * TETA SQQ= SQRT(SQQ) XEX= SQQ * FOP/(DEUX * XPI * RAYMO *EPAI) XFL= SQQ * FOM/(XPI * RAYMO * RAYMO *EPAI) SIGF(7)=XEX * SIGF(1) - XFL * SIGF(6) c c calcul des aires de breche note technique dre/stre/lma 85/695 c SIGM=SIGF(1)/( DEUX * XPI * RAYMO * EPAI ) SIG=SIGF(6)/( XPI * RAYMO * RAYMO * EPAI ) XIM= XPI * RAYMO * RAYMO * DEUX * TETA * TETA * FP $ /YOU XIF= XIM * ( .75D0 +(.25D0 * COS ( TETA ))) SIGF(8)=XIM * SIGM - XIF * SIG * ELSEIF (MFR.EQ.17.AND.KCAS.EQ.2) THEN EPSI(7)=0.D0 EPSI(8)=0.D0 * ENDIF * * cas des lisp et lism * IF (MFR.EQ.15.AND.KCAS.EQ.1) THEN EPA1=VALCAR(1) EPA2=VALCAR(6) FISS1=VALCAR(2) FISS2=VALCAR(7) FISS1 = (FISS1*(UNDEMI +UNDEMI/X774))+ + (FISS2*(UNDEMI-UNDEMI/X774)) FISS2 = (FISS1*(UNDEMI -UNDEMI/X774))+ + (FISS2*(UNDEMI+UNDEMI/X774)) W=(EPA1+EPA2)*UNDEMI H1=UNDEMI-UNDEMI*S(IGAU) H2=UNDEMI+UNDEMI*S(IGAU) A= H1*FISS1+H2*FISS2 ASURW=(H1*FISS1+H2*FISS2)/W CALL LISPFI(ASURW,FM,FF) X1=SIGF(1)/W X4=SIGF(4)*SIX/(W*W) XXX=XPI*A XXX=SQRT(XXX) XKIE=(X1*FM+X4*FF)*XXX SIGF(6)= XKIE * ENDIF ENDIF * 6500 CONTINUE IF(KERRE.EQ.0) THEN c c remplissage du segment contenant les contraintes a la fin c MPTVAL=IVARES IF (KCAS.EQ.2) THEN DO 7000 ICOMP=1,NRES MELVA1=IVAL(ICOMP) MELVA1.VELCHE(IGAU,IB)=EPSI(ICOMP) 7000 CONTINUE ELSE IF (KCAS.EQ.1) THEN DO 7001 ICOMP=1,NRES MELVA1=IVAL(ICOMP) MELVA1.VELCHE(IGAU,IB)=SIGF(ICOMP) 7001 CONTINUE ENDIF ELSE * * impression de quelques messages d erreurs * INTERR(1)=IB INTERR(2)=IGAU MOTERR(1:4)=NOMTP(MELE) IF(KERRE.EQ.1) THEN CALL ERREUR(301) ELSE IF(KERRE.EQ.2) THEN CALL ERREUR(300) ELSE IF(KERRE.EQ.3) THEN MOTERR(1:8)='ELASTI' CALL ERREUR(146) ELSE IF(KERRE.EQ.4) THEN CALL ERREUR(266) ELSE IF(KERRE.EQ.49) THEN CALL ERREUR(359) ENDIF SEGSUP IWRK1 IF (IWRK2.NE.0) SEGSUP IWRK2 IF(MFR.EQ.33) SEGSUP IWRK4 GOTO 9990 ENDIF * 3000 CONTINUE c c cas des elements pout : calcul des efforts tranchants c IF ((MELE.EQ.29.OR.MFR.EQ.13).AND.NBPGAU.EQ.2) THEN MPTVAL=IVARES SEGINI WPOUT IGAU=1 IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN r_x = XE(1,2) - XE(1,1) r_y = XE(2,2) - XE(2,1) XL=SQRT(r_x*r_x + r_y*r_y) XL=1.D00/XL DO 3200 ICOMP=1,NRES MELVA1=IVAL(ICOMP) SIG1(ICOMP)=MELVA1.VELCHE(IGAU,IB) SIG2(ICOMP)=MELVA1.VELCHE(IGAU+1,IB) 3200 CONTINUE r_z = (SIG1(1)+SIG2(1))*0.5D0 MELVA1=IVAL(1) MELVA1.VELCHE(IGAU,IB)=r_z MELVA1.VELCHE(IGAU+1,IB)=r_z r_z = (SIG1(3)-SIG2(3))*XL MELVA1=IVAL(2) MELVA1.VELCHE(IGAU,IB)=r_z MELVA1.VELCHE(IGAU+1,IB)=r_z ELSE r_x = XE(1,2) - XE(1,1) r_y = XE(2,2) - XE(2,1) r_z = XE(3,2) - XE(3,1) XL=SQRT(r_x*r_x + r_y*r_y + r_z*r_z) XL=1.D0/XL DO 3202 ICOMP=1,NRES MELVA1=IVAL(ICOMP) SIG1(ICOMP)=MELVA1.VELCHE(IGAU,IB) SIG2(ICOMP)=MELVA1.VELCHE(IGAU+1,IB) 3202 CONTINUE r_z = (SIG1(1)+SIG2(1))*0.5D0 MELVA1=IVAL(1) MELVA1.VELCHE(IGAU,IB)=r_z MELVA1.VELCHE(IGAU+1,IB)=r_z r_z = (SIG1(6)-SIG2(6))*XL MELVA1=IVAL(2) MELVA1.VELCHE(IGAU,IB)=r_z MELVA1.VELCHE(IGAU+1,IB)=r_z r_z = (SIG2(5)-SIG1(5))*XL MELVA1=IVAL(3) MELVA1.VELCHE(IGAU,IB)=r_z MELVA1.VELCHE(IGAU+1,IB)=r_z ENDIF SEGSUP WPOUT ENDIF c 2000 CONTINUE * SEGSUP IWRK1 IF (IWRK2.NE.0) SEGSUP IWRK2 IF (IPMIN2.NE.0) SEGDES MINTE2 IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) SEGSUP IWRK4 SEGDES MELEME SEGDES,MINTE * IF (ISUP2.EQ.1) THEN CALL DTMVAL(IVAMAT,3) CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVAMAT,1) CALL DTMVAL(IVACAR,1) ENDIF * IF(IPCHE3.NE.0) THEN IF (ISUP3.EQ.1) THEN CALL DTMVAL(IVARI,3) ELSE CALL DTMVAL(IVARI,1) ENDIF NOMID=MOVARI if(lsupva)SEGSUP NOMID ENDIF * IF (ISUP1.EQ.1) THEN CALL DTMVAL(IVASTR,3) ELSE CALL DTMVAL(IVASTR,1) ENDIF * CALL DTMVAL(IVARES,1) * NOMID=MOMATR if(lsupma)SEGSUP NOMID NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID NOMID=MOSTRS if(lsupin)SEGSUP NOMID NOMID=MORES if(lsupre)SEGSUP NOMID IF (IERR.NE.0) GOTO 9992 * 500 CONTINUE SEGDES MCHEL1 IRET = 1 GOTO 9992 * 9990 CONTINUE * * erreur dans une sous zone, desactivation et retour * IF (ISUP1.EQ.1) THEN CALL DTMVAL(IVASTR,3) ELSE CALL DTMVAL(IVASTR,1) ENDIF NOMID=MOSTRS if(lsupin)SEGSUP NOMID * CALL DTMVAL(IVARES,3) NOMID=MORES if(lsupre)SEGSUP NOMID * IF (ISUP2.EQ.1) THEN CALL DTMVAL(IVAMAT,3) CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVAMAT,1) CALL DTMVAL(IVACAR,1) ENDIF IF (MOMATR.NE.0) THEN NOMID=MOMATR if(lsupma)SEGSUP NOMID ENDIF IF (MOCARA.NE.0) THEN NOMID=MOCARA SEGSUP NOMID ENDIF * IF(IPCHE3.NE.0) THEN IF (ISUP3.EQ.1) THEN CALL DTMVAL(IVARI,3) ELSE CALL DTMVAL(IVARI,1) ENDIF NOMID=MOVARI if(lsupva)SEGSUP NOMID ENDIF * SEGSUP MCHAM1 SEGSUP MCHEL1 IRET=0 9992 CONTINUE DO ISOUS=1,NSOUS IMODEL=KMODEL(ISOUS) SEGDES,IMODEL ENDDO SEGDES,MMODEL RETURN END