C THETAP SOURCE AM 13/12/16 21:16:09 7825 SUBROUTINE THETAP(IPMODL,IPCHE1,IPCHE2,IPSTRS,IRET) *_______________________________________________________________________ * * OPERATEUR DE CALCUL DE CONTRAINTES DUES A UN CHAMP DE TEMPERATURE * APPELE PAR THETA * * ENTREES : * --------- * * IPMODL POINTEUR SUR UN MMODEL * IPCHE1 MCHAML DE SOUS TYPE CARACTERISTIQUE * IPCHE2 MCHAML DE SOUS TYPE TEMPERATURE * * SORTIES : * --------- * * IPSTRS MCHAML DE SOUS TYPE CONTRAINTE (DUE @ LA TEMP{RATURE) * IRET 1 OU 0 SUIVANT SUCCES OU PAS * * PASSAGE AUX NOUVEAUX CHAMELEMS PAR S.RAMAHANDRY LE 05/09/90 * * VARIATION PARABOLIQUE DE TEMPERATURE DANS LES COQUES,OPTION ORTHOTROPE * ET ANISOTROPE POUR LES MASSIFS PAR P.DOWLATYARI LE 15/03/91 *_______________________________________________________________________ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC CCOPTIO -INC SMCHAML -INC SMELEME -INC SMINTE -INC SMMODEL -INC CCHAMP -INC SMCOORD * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * SEGMENT WRK1 REAL*8 WORK(LW) ENDSEGMENT * SEGMENT WRK2 REAL*8 XE(3,NBNN),TXR(IDIM,IDIM) REAL*8 XLOC(IDIM,IDIM),XGLOB(IDIM,IDIM) REAL*8 ROTS(NSTRS,NSTRS),DHOOK(LHOOK,LHOOK) ENDSEGMENT * SEGMENT WRK3 REAL*8 RES(NSTRS) ENDSEGMENT * SEGMENT MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT * CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) DIMENSION CRIGI(12) LOGICAL lsupco,lsupma,lsupte * IRET = 0 IPSTRS = 0 * NHRM=NIFOUR THM = 0.D0 THIF = 0.D0 THSU = 0.D0 TEMP = 0.D0 * * VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES * CALL QUESUP(IPMODL,IPCHE1,5,0,ISUPMA,IRETMA) IF(ISUPMA.GT.1) RETURN * * VERIFICATION DU LIEU SUPPORT DU MCHAML DE TEMPERATURE * CALL QUESUP(IPMODL,IPCHE2,5,0,ISUPTE,IRETTE) IF(ISUPTE.GT.1) RETURN * * ACTIVATION DU MODELE * MMODEL=IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) C============================================= KNB22=0 DO IJKL=1,NSOUS IMODEL=KMODEL(IJKL) SEGACT IMODEL IF (NEFMOD.EQ.22) KNB22=KNB22+1 END DO N1=NSOUS-KNB22 C============================================= * * CREATION DU MCHELM * C N1=NSOUS L1=11 N3=6 SEGINI MCHELM TITCHE='CONTRAINTES' IFOCHE=IFOUR *____________________________________________________________________ * * DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES *____________________________________________________________________ * ISOUS=0 DO 500 KISOUS=1,NSOUS * * INITIALISATION * MOCARA=0 MOMATR=0 MOSTRS=0 MOTEMP=0 IVAMAT=0 IVACAR=0 IVATEM=0 IVASTR=0 NCARA=0 NCARF=0 NMATR=0 NMATF=0 * IMODEL=KMODEL(KISOUS) C* SEGACT IMODEL MELE=NEFMOD if(mele.eq.22) go to 999 ISOUS=ISOUS+1 * * TRAITEMENT DU MODELE * IPMAIL=IMAMOD CONM =CONMOD IMACHE(ISOUS)=IPMAIL CONCHE(ISOUS)=CONMOD * * CREATION DU TABLEAU INFOS * CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 999 * * 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 GOTO 999 C ENDIF C C COQUE INTEGREE OU PAS ? C 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) GOTO 999 * INFO=IPINF MELE =INFELE(1) ICARA=INFELE(5) IPORE=INFELE(8) MFR =INFELE(13) LHOOK=INFELE(10) NBGS =INFELE(4) NSTRS=INFELE(16) LW =INFELE(7) * MINTE=INFELE(11) MINTE=INFMOD(7) MINTE1=INFMOD(8) IPMINT=MINTE * SEGSUP INFO * INFCHE(ISOUS,1)=0 INFCHE(ISOUS,2)=0 INFCHE(ISOUS,3)=NHRM INFCHE(ISOUS,4)=MINTE INFCHE(ISOUS,5)=0 INFCHE(ISOUS,6)=5 * * INITIALISATION DE MINTE * SEGACT MINTE NBPGAU=POIGAU(/1) * * ACTIVATION DU MELEME * MELEME=IPMAIL SEGACT MELEME NBNN =NUM(/1) NBELEM=NUM(/2) NBNO=NBNN IF(MFR.EQ.33) NBNO=IPORE IELE = NUMGEO(MELE) IPPORE=0 IF(MFR.EQ.33) IPPORE=NBNN * * RECHERCHE DES NOMS DE COMPOSANTES * if(lnomid(4).ne.0) then nomid=lnomid(4) segact nomid mostrs=nomid nstr=lesobl(/2) nfac=lesfac(/2) lsupco=.false. else lsupco=.true. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC) endif if(lnomid(8).ne.0) then nomid=lnomid(8) segact nomid motemp=nomid ntem=lesobl(/2) nfac=lesfac(/2) lsupte=.false. else lsupte=.true. CALL IDTEMP(MFR,IFOUR,NPINT,MOTEMP,NTEM,NFAC) endif * * VERIFICATION DE LEUR PRESENCE * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOTEMP, 1 MOTYPE,1,INFOS,3,IVATEM) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 IF(ISUPTE.EQ.1)THEN CALL VALCHE(IVATEM,NTEM,IPMINT,IPPORE) IF(IERR.NE.0)THEN ISUPTE=0 GOTO 9990 ENDIF ENDIF * * RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER * N1PTEL=NBGS N1EL=NBELEM * * CREATION DU MCHAML DE LA SOUS ZONE * N2=NSTRS SEGINI MCHAML ICHAML(ISOUS)=MCHAML NS=1 NCOSOU=NSTRS SEGINI MPTVAL IVASTR=MPTVAL NOMID=MOSTRS SEGACT NOMID N2PTEL=0 N2EL=0 * IF(MELE.EQ.30.OR.MELE.EQ.43) THEN N1PTEL=1 N1EL=1 ENDIF DO 100 ICOMP=1,NSTRS NOMCHE(ICOMP)=LESOBL(ICOMP) TYPCHE(ICOMP)='REAL*8' SEGINI MELVAL IELVAL(ICOMP)=MELVAL IVAL(ICOMP)=MELVAL 100 CONTINUE SEGDES NOMID * * TRAITEMENT DES CHAMPS DE MATERIAU * NBROBL=0 NBRFAC=0 MOMATR=0 lsupma=.true. * IF (MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.45.OR.MELE.EQ.46 & .OR.MELE.EQ.95.OR.MELE.EQ.123.OR.MELE.EQ.124 & .OR.MELE.EQ.84) THEN NBROBL=2 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YOUN' LESOBL(2)='ALPH' * * materiau isotrope * ELSE IF (CMATE.EQ.'ISOTROPE') THEN IF (MFR.EQ.35) THEN NBROBL=3 SEGINI NOMID MOMATR=NOMID LESOBL(1)='KS ' LESOBL(2)='KN ' LESOBL(3)='ALPN' ELSE NBROBL=3 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' LESOBL(3)='ALPH' ENDIF * * materiau orthotrope * ELSE IF(CMATE.EQ.'ORTHOTRO') THEN IF(MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9)THEN NBROBL=7 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12' LESOBL(4)='ALP1' LESOBL(5)='ALP2' LESOBL(6)='V1X ' LESOBL(7)='V1Y ' ELSE IF (MFR.EQ.35) THEN NBROBL=6 SEGINI NOMID MOMATR=NOMID LESOBL(1)='KS1 ' LESOBL(2)='KS2 ' LESOBL(3)='KN ' LESOBL(4)='ALPN' LESOBL(5)='V1X' LESOBL(6)='V1Y ' ELSE IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33) THEN IF(IFOUR.EQ.-2) THEN NBROBL =10 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12' LESOBL(4)='ALP1' LESOBL(5)='ALP2' LESOBL(6)='V1X ' LESOBL(7)='V1Y ' LESOBL(8)='YG3 ' LESOBL(9)='NU23' LESOBL(10)='NU13' ELSE IF (IFOUR.EQ.-1.OR.IFOUR.EQ.0 1 .OR.IFOUR.EQ.1.OR.IFOUR.EQ.-3)THEN NBROBL = 11 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' LESOBL(7)='ALP1' LESOBL(8)='ALP2' LESOBL(9)='ALP3' LESOBL(10)='V1X ' LESOBL(11)='V1Y ' ELSEIF(IFOUR.EQ.2)THEN NBROBL = 15 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' LESOBL(7)='ALP1' LESOBL(8)='ALP2' LESOBL(9)='ALP3' LESOBL(10)='V1X ' LESOBL(11)='V1Y ' LESOBL(12)='V1Z ' LESOBL(13)='V2X ' LESOBL(14)='V2Y ' LESOBL(15)='V2Z ' C= Modes de calcul UNIDIMENSIONNELS (1D) ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN C= Mode 1D UNID PLAN CYCZ IF (IFOUR.EQ.6) THEN NBROBL=7 SEGINI,NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' LESOBL(7)='ALP1' C= Modes 1D UNID PLAN CYDZ et CYGZ ELSE IF (IFOUR.EQ.5.OR.IFOUR.EQ.10) THEN NBROBL=8 SEGINI,NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' LESOBL(7)='ALP1' LESOBL(8)='ALP3' ELSE IF (IFOUR.EQ.4.OR.IFOUR.EQ.8.OR.IFOUR.EQ.13) THEN C= Modes 1D UNID PLAN DYCZ et GYCZ, et mode 1D UNID AXIS AXCZ NBROBL=8 SEGINI,NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' LESOBL(7)='ALP1' LESOBL(8)='ALP2' ELSE C= Autres modes de calcul 1D UNID C= Mode 1D UNID SPHErique : on suppose que YG2=YG3 NU12=NU13 ALP2=ALP3 NBROBL=9 SEGINI,NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='YG3 ' LESOBL(4)='NU12' LESOBL(5)='NU23' LESOBL(6)='NU13' LESOBL(7)='ALP1' LESOBL(8)='ALP2' LESOBL(9)='ALP3' ENDIF MOMATR=NOMID ENDIF ENDIF * * materiau anisotrope * ELSE IF(CMATE.EQ.'ANISOTRO') THEN IF(MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33)THEN IF(IFOUR.EQ.-2) THEN NBROBL=15 SEGINI NOMID MOMATR=NOMID LESOBL(1)='D11 ' LESOBL(2)='D21 ' LESOBL(3)='D22 ' LESOBL(4)='D41 ' LESOBL(5)='D42 ' LESOBL(6)='D44 ' LESOBL(7)='ALP1' LESOBL(8)='ALP2' LESOBL(9)='AL12' LESOBL(10)='V1X ' LESOBL(11)='V1Y ' LESOBL(12)='D31 ' LESOBL(13)='D32 ' LESOBL(14)='D33 ' LESOBL(15)='D43 ' ELSE IF(IFOUR.EQ.-3.OR.IFOUR. 1 EQ.-1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.1)THEN NBROBL=16 SEGINI NOMID MOMATR=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)='ALP1' LESOBL(12)='ALP2' LESOBL(13)='AL12' LESOBL(14)='ALP3' LESOBL(15)='V1X ' LESOBL(16)='V1Y ' ELSEIF(IFOUR.EQ.2)THEN NBROBL=33 SEGINI NOMID MOMATR=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)='ALP1' LESOBL(23)='ALP2' LESOBL(24)='ALP3' LESOBL(25)='AL12' LESOBL(26)='AL13' LESOBL(27)='AL23' LESOBL(28)='V1X ' LESOBL(29)='V1Y ' LESOBL(30)='V1Z ' LESOBL(31)='V2X ' LESOBL(32)='V2Y ' LESOBL(33)='V2Z ' ENDIF ENDIF * * materiau unidirectionnel * ELSE IF(CMATE.EQ.'UNIDIREC') THEN * MLR 31/1/97 IF(IFOUR.EQ.2)THEN IF (MFR.EQ.1.AND.IDIM.EQ.3) THEN NBROBL=8 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YOUN' LESOBL(2)='ALPH' LESOBL(3)='V1X ' LESOBL(4)='V1Y ' LESOBL(5)='V1Z ' LESOBL(6)='V2X ' LESOBL(7)='V2Y ' LESOBL(8)='V2Z ' ELSE NBROBL=4 SEGINI NOMID MOMATR=NOMID LESOBL(1)='YOUN' LESOBL(2)='ALPH' LESOBL(3)='V1X ' LESOBL(4)='V1Y ' ENDIF C ENDIF ELSE if(lnomid(6).ne.0) then nomid=lnomid(6) segact nomid momatr=nomid nmatr=lesobl(/2) nmatf=lesfac(/2) lsupma=.false. else CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF) endif NBROBL=NMATR NBRFAC=NMATF ENDIF NMATR=NBROBL NMATF=NBRFAC NMATT=NMATR+NMATF * IF (MOMATR.NE.0) THEN IF (CMATE.EQ.'SECTION') THEN NBTYPE=3 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='POINTEURMMODEL' TYPE(2)='POINTEURMCHAML' TYPE(3)='POINTEURLISTREEL' ELSE NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' ENDIF * CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR, 1 MOTYPE,1,INFOS,3,IVAMAT) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 IF(ISUPMA.EQ.1)THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE) IF(IERR.NE.0)THEN ISUPMA=0 GOTO 9990 ENDIF ENDIF MPTVAL=IVAMAT MELVAL=IVAL(1) C NBGMAT=VELCHE(/1) C NELMAT=VELCHE(/2) NBGMAT = 0 NELMAT = 0 DO 1108 IM=1,NMATT IF(IVAL(IM).NE.0)THEN MELVAL=IVAL(IM) IF (CMATE.EQ.'SECTION') THEN NBGMAT=MAX(NBGMAT,IELCHE(/1)) NELMAT=MAX(NELMAT,IELCHE(/2)) ELSE NBGMAT=MAX(NBGMAT,VELCHE(/1)) NELMAT=MAX(NELMAT,VELCHE(/2)) ENDIF ENDIF 1108 CONTINUE ENDIF * * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES * NBROBL=0 NBRFAC=0 IVECT=0 * * EPAISSEUR DANS LE CAS DES COQUES * IF (MFR.EQ.3.OR.MFR.EQ.9) THEN NBROBL=1 SEGINI NOMID MOCARA=NOMID LESOBL(1)='EPAI' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * SECTION POUR LES BARRES ET LES CERCES * ELSE IF (MFR.EQ.27) THEN NBROBL=1 NBRFAC=0 SEGINI NOMID MOCARA=NOMID LESOBL(1)='SECT' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * section, excentrements et orientation pour les barres excentrees * ELSE IF (MFR.EQ.49) THEN NBROBL=6 SEGINI NOMID MOCARA=NOMID LESOBL(1)='SECT' LESOBL(2)='EXCZ' LESOBL(3)='EXCY' LESOBL(4)='VX ' LESOBL(5)='VY ' LESOBL(6)='VZ ' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * CARACTERISTIQUES POUR LES POUTRES * ELSE IF (MFR.EQ.7 ) THEN IF (CMATE.NE.'SECTION') THEN NBROBL=1 NBRFAC=0 SEGINI NOMID MOCARA=NOMID LESOBL(1)='SECT' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' ENDIF * * CARACTERISTIQUES POUR LES TUYAUX * ELSE IF (MFR.EQ.13) THEN NBROBL=2 NBRFAC=3 SEGINI NOMID MOCARA=NOMID LESOBL(1)='EPAI' LESOBL(2)='RAYO' LESFAC(1)='RACO' LESFAC(2)='CISA' LESFAC(3)='VECT' IVECT=1 * NBTYPE=5 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' TYPE(2)='REAL*8' TYPE(3)='REAL*8' TYPE(4)='REAL*8' TYPE(5)='POINTEURPOINT ' ENDIF * NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF IF (MOCARA.NE.0) THEN IF (IPCHE1.EQ.0) THEN SEGSUP NOTYPE MOTERR(1:4)='CARA' MOTERR(5:8)='CARA' MOTERR(9:12)=NOMTP(MELE) MOTERR(13:20)='THETA' CALL ERREUR(145) GOTO 9990 ENDIF CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE, 1 1,INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 IF (IVECT.EQ.1) THEN MPTVAL=IVACAR IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN * * MOT CLE VECT EN CAS DE CONVERSION * IVECT=2 NOMID=MOCARA SEGACT NOMID*MOD NBRFAC=NBRFAC+2 SEGADJ NOMID MOCARA=NOMID LESFAC(NBRFAC-2)='VX ' LESFAC(NBRFAC-1)='VY ' LESFAC(NBRFAC) ='VZ ' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF * CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA, 1 MOTYPE,1,INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 ENDIF ENDIF IF (ISUPMA.EQ.1) THEN CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE) IF (IERR.NE.0) THEN ISUPMA=0 GOTO 9990 ENDIF ENDIF ENDIF * NV1=NMATT SEGINI,MVELCH SEGINI, WRK3 * IF ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. 1 CMATE.EQ.'UNIDIREC')) THEN C RENSEIGNEMENTS SUR LE MAILLAGE MELEME=IPMAIL SEGACT MELEME NBNN=NUM(/1) SEGINI WRK2 * * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE * L'ELEMENT POUR LE CALCUL DES AXES LOCAUX IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33) THEN CALL RESHPT(1,NBNO,IELE,MELE,NPINT,IPT1,IRT1) IF (IERR.NE.0) THEN SEGSUP MVELCH SEGSUP WRK2,WRK3 SEGDES MELEME GOTO 9990 ENDIF MINTE2=IPT1 SEGACT MINTE2 ENDIF ENDIF * * BOUCLE SUR LES ELEMENTS * DO 1000 IB=1,NBELEM C IF ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. 1 CMATE.EQ.'UNIDIREC').AND. 2 (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33)) THEN 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 C NBSH=MINTE2.SHPTOT(/2) CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) if (nbsh.eq.-1) then call erreur(525) return endif ENDIF C IF(CMATE.EQ.'SECTION') THEN * * CAS DE LA POUTRE TIMO - MODELE SECTION * MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,IELCHE(/2)) IPMODL=IELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,IELCHE(/2)) IPMAT=IELCHE(1,IBMN) CALL FRIGTH(IPMODL,IPMAT,CRIGI,0,1) ENDIF C * BOUCLE SUR LES POINTS * DO 2000 IGAU=1,NBPGAU * * initialisations * EPAIST=0. SD=0.D0 TEMP=0.D0 THIF=0.D0 THM=0.D0 THSU=0.D0 E3=0.D0 * * remplissage du tableau des caracteristiques du materiau * IF(CMATE.NE.'SECTION') THEN MPTVAL=IVAMAT DO 1100 IO = 1,NMATT MELVAL = IVAL(IO) IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALMAT(IO) = VELCHE( IGMN,IBMN) 1100 CONTINUE ENDIF * 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 ((CMATE.EQ.'ISOTROPE'.OR.CMATE.EQ.'ORTHOTRO'. 1 OR.CMATE.EQ.'UNIDIREC').AND. 2 (MFR.EQ.3.OR.MFR.EQ.9)) 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 ENDIF * * remplissage du tableau des caracteristiques geometriques * IF (MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.45.OR.MELE.EQ.123 1 .OR.MELE.EQ.124.OR.MELE.EQ.46.OR.MELE.EQ.95 1 .OR.MELE.EQ.84) THEN SEGINI WRK1 IF(MELE.EQ.42) THEN MPTVAL=IVACAR DO 1200 IC=1,NCARR IF (IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) IF (IBMN.NE.0) THEN WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF ELSE WORK(IC)=0.D0 ENDIF 1200 CONTINUE * * CAS OU ON A LU LE MOT VECTEUR * IF (IVECT.EQ.1) THEN IF (IVAL(NCARR).NE.0) THEN MELVAL=IVAL(NCARR) IBMN=MIN(IB,IELCHE(/2)) IP=IELCHE(1,IBMN) IREF=(IP-1)*(IDIM+1) DO 1300 IC=1,IDIM WORK(NCARR+IC-1)=XCOOR(IREF+IC) 1300 CONTINUE ELSE DO 1400 IC=1,IDIM WORK(NCARR+IC-1)=0.D0 1400 CONTINUE ENDIF * * CAS DU CHAMELEM CONVERTI * ELSE IF (IVECT.EQ.2) THEN DO 1500 IC=1,IDIM MELVAL=IVAL(NCARR+IC-3) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) WORK(NCARR+IC-3)=VELCHE(1,IBMN) ELSE WORK(NCARR+IC-3)=0.D0 ENDIF 1500 CONTINUE ENDIF * * CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE EQUIVA * CISA=WORK(4) VX=WORK(5) VY=WORK(6) VZ=WORK(7) CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,1) SD=WORK(4) ELSE MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) SD=0.D0 DO 1201 IAUX=1,NBPGAU IGMN=MIN(IAUX,VELCHE(/1)) SD=SD+VELCHE(IGMN,IBMN) IF(IAUX.EQ.NBPGAU) SD=SD/NBPGAU 1201 CONTINUE ENDIF ENDIF IF(CMATE.EQ.'SECTION') SD=CRIGI(1) * IF (((MFR.EQ.3.OR.MFR.EQ.9).AND.(CMATE.EQ.'ISOTROPE'. + OR.CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'UNIDIREC')). + OR.(MFR.EQ.5.AND.(CMATE.EQ.'ISOTROPE'.OR.CMATE. + EQ.'ORTHOTRO'))) THEN * IF(NPINT.EQ.0) THEN MPTVAL=IVATEM MELVAL=IVAL(1) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) THIF=VELCHE(IGMN,IBMN) MELVAL=IVAL(2) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) THM=VELCHE(IGMN,IBMN) MELVAL=IVAL(3) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) THSU=VELCHE(IGMN,IBMN) ELSE MPTVAL=IVATEM MELVAL=IVAL(1) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) TEMP=VELCHE(IGMN,IBMN) ENDIF * E3 = DZEGAU(IGAU) * ELSEIF((MFR.EQ.7.OR.MFR.EQ.13.OR.MFR.EQ.27.OR.MELE.EQ.85.OR. + MELE.EQ.86.OR.MELE.EQ.87.OR.MELE.EQ.88.OR.MFR.EQ.49.OR. + MELE.EQ.84.OR.MFR.EQ.51).OR.((MFR.EQ.1.OR.MFR.EQ.33.OR. + MFR.EQ.31).AND.(CMATE.EQ.'ISOTROPE'.OR.CMATE.EQ.'ORTHOTRO' + .OR.CMATE.EQ.'ANISOTRO'.OR.CMATE.EQ.'UNIDIREC'))) THEN * MPTVAL=IVATEM MELVAL=IVAL(1) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) TEMP=VELCHE(IGMN,IBMN) ENDIF *-------------------------------------------------------------- * CAS ISOTROPE *-------------------------------------------------------------- * IF(CMATE.EQ.'ISOTROPE') THEN * CALL THETIS(MFR,MELE,VALMAT,NSTRS,NPINT,TEMP,THIF, 1 THM,THSU,E3,SD,EPAIST,RES,KERRE) * *-------------------------------------------------------------- * CAS ORTHOTROPE *-------------------------------------------------------------- ELSEIF(CMATE.EQ.'ORTHOTRO') THEN CALL THETOR(MFR,MELE,VALMAT,LHOOK,NSTRS,TEMP,THIF, 1 THM,THSU,E3,SD,EPAIST,TXR,XLOC,XGLOB, 2 ROTS,DHOOK,RES,KERRE) * *-------------------------------------------------------------- * CAS ANISOTROPE *-------------------------------------------------------------- ELSEIF(CMATE.EQ.'ANISOTRO') THEN CALL THETAN(MFR,MELE,VALMAT,LHOOK,NSTRS,TEMP, 1 SD,TXR,XLOC,XGLOB,ROTS,DHOOK,RES,KERRE) *-------------------------------------------------------------- * CAS UNIDIRECTIONNEL *-------------------------------------------------------------- ELSEIF(CMATE.EQ.'UNIDIREC') THEN CALL THETUN(MFR,MELE,VALMAT,LHOOK,NSTRS,TEMP,THIF, 1 THM,THSU,SD,EPAIST,TXR,XLOC,XGLOB, 2 ROTS,DHOOK,RES,KERRE) * *-------------------------------------------------------------- * CAS HOMOGENEISE ET SECTION *-------------------------------------------------------------- ELSEIF(CMATE.EQ.'HOMOGENE'.OR.CMATE.EQ.'SECTION') THEN CALL THETHS(MELE,VALMAT,NSTRS,TEMP,SD,RES,KERRE) * *-------------------------------------------------------------- * ELSE CALL ERREUR(19) GOTO 9900 ENDIF * IF (KERRE.EQ.19) THEN CALL ERREUR(19) GOTO 9900 ELSEIF (KERRE.EQ.86) THEN MOTERR(1:4) =NOMTP(MELE) MOTERR(5:12)='THET' CALL ERREUR(86) GO TO 9900 ENDIF * MPTVAL=IVASTR DO 1600 I=1,NSTRS MELVAL=IVAL(I) VELCHE(IGAU,IB)=RES(I) 1600 CONTINUE * 2000 CONTINUE 1000 CONTINUE * *____________________________________________________________________ * * DESACTIVATION DES SEGMENTS DE TRAVAIL *____________________________________________________________________ * 9900 CONTINUE * IF ((CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. 1 CMATE.EQ.'UNIDIREC')) THEN SEGSUP WRK2 IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33) & SEGDES MINTE2,MELEME ENDIF * IF (MELE.EQ.29.OR.MELE.EQ.42) SEGSUP WRK1 * SEGSUP MVELCH SEGSUP WRK3 * 9990 CONTINUE *____________________________________________________________________ * * DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA *____________________________________________________________________ * SEGDES MINTE IF(IERR.NE.0)THEN SEGSUP MCHAML ELSE SEGDES MCHAML ENDIF * IF(ISUPMA.EQ.1)THEN CALL DTMVAL(IVAMAT,3) ELSE CALL DTMVAL(IVAMAT,1) ENDIF IF(ISUPMA.EQ.1)THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF IF(IERR.NE.0)THEN CALL DTMVAL(IVASTR,3) ELSE CALL DTMVAL(IVASTR,1) ENDIF IF(ISUPTE.EQ.1)THEN CALL DTMVAL(IVATEM,3) ELSE CALL DTMVAL(IVATEM,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(MOSTRS.NE.0)THEN NOMID=MOSTRS if(lsupco)SEGSUP NOMID ENDIF IF(MOTEMP.NE.0)THEN NOMID=MOTEMP if(lsupte)SEGSUP NOMID ENDIF * 999 CONTINUE SEGDES IMODEL IF (IERR.NE.0) GO TO 888 * 500 CONTINUE * 888 CONTINUE SEGDES MMODEL IF(IERR.NE.0)THEN IRET = 0 SEGSUP MCHELM IPSTRS = 0 ELSE IRET = 1 SEGDES MCHELM IPSTRS = MCHELM ENDIF RETURN END