C MASSE1 SOURCE AM 13/12/16 21:15:58 7825 SUBROUTINE MASSE1 (MODORI,IPCHE1,IPMASS,IRET,ILUMP) *_______________________________________________________________________ * * appele par masse ( opérateur masse et lump ) * * entrees : * ======== * * modori pointeur sur un mmodel * ipche1 pointeur sur un mchaml de caracteristique * ilump si il s'agit de l'opérateur lump * * sorties : * ========= * * ipmass pointeur sur la masse construite * iret 1 si ok, 0 sinon * *_______________________________________________________________________ IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) INTEGER oooval -INC CCOPTIO -INC CCHAMP -INC CCGEOME -INC CCREEL -INC SMRIGID -INC SMCHAML -INC SMELEME -INC SMCOORD -INC SMINTE -INC SMMODEL C SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT C SEGMENT NOTYPE C CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT C SEGMENT MPTVAL INTEGER IPOS(NS),NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT C segment modsta integer pimoda(nmoda),pistat(nstat) integer ivmoda(nmoda),ivstat(nstat) endsegment C CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM PARAMETER (NINF=3) INTEGER INFOS(NINF) LOGICAL BDPGE,lsupfo,lsupdp,dcmate,dcmat2,dcmoda C NHRM=NIFOUR IRET = 0 * * verification du lieu support du mchaml de caracteristiques * * am 5/1/95 on remplace par un appel a quesup plus * loin pour ne tester que sur les composantes ad hoc * * call quesup(ipmodl,ipche1,4,0,isup) * if(isup.gt.1) return C C ACTIVATION DU MODELE C * MODORI = Modele initial complet * IPMODL = Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX") CALL PIMODL(MODORI,IPMODL) IF (IPMODL.EQ.0) RETURN * IPMODL est ACTIF en retour (nouveau pointeur pouvant etre detruit) MMODEL=IPMODL NSOUS=KMODEL(/1) C C CREATION DE L'OBJET MATRICE DE MASSE C NRIGEL=0 SEGINI,MRIGID IPMASS=MRIGID MTYMAT='MASSE' IFORIG=IFOUR ICHOLE=0 IMGEO1=0 IMGEO2=0 ISUPEQ=0 C Cas des modes de calculs en DEFORMATIONS GENERALISEES IF (IFOUR.EQ.-3) THEN NDPGE=3 NDDLGE=1 BDPGE=.TRUE. ELSE IF (IFOUR.EQ.11) THEN NDPGE=2 NDDLGE=2 BDPGE=.TRUE. ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ. 9.OR. . IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN NDPGE=1 NDDLGE=1 BDPGE=.TRUE. ELSE NDPGE=0 NDDLGE=0 BDPGE=.FALSE. ENDIF * termes croises STATIQUE et/ou MODAL nstat = 100 kstat = 0 nmoda = 100 kmoda = 0 segini modsta C_______________________________________________________________________ C C DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES C_______________________________________________________________________ C isouss=0 DO 500 ISOUS=1,NSOUS C C ON RECUPERE LINFORMATION GENERALES C IMODEL=KMODEL(ISOUS) SEGACT IMODEL IIPDPG=IPDPGE IPMAIL=IMAMOD CONM =CONMOD dcmate = .false. dcmat2 = .false. dcmoda = .false. C C TRAITEMENT DU MODELE C MELEME=IMAMOD MELE=NEFMOD * Cas particulier des relations de conformites : pas de masse IF (MELE.EQ.22) GOTO 500 * npint=1 if (infmod(/1).ne.0) npint = infmod(1) C C NATURE DU MATERIAU C * NFOR=FORMOD(/2) * NMAT=MATMOD(/2) * CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) CMATE = CMATEE MATE = IMATEE INAT = INATUU * IF (CMATE.EQ.' ') THEN * CALL ERREUR(251) * SEGDES IMODEL,MMODEL * SEGSUP MRIGID * RETURN * ENDIF do im = 1,matmod(/2) if (matmod(im).eq.'IMPEDANCE') then dcmate =.true. if(tymode(/2).gt.0)then if(tymode(1).eq.'LISTMOTS') dcmat2 = .true. endif endif enddo C C CREATION DU TABLEAU INFOS C IRTD=1 CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 9996 C_______________________________________________________________________ C C INFORMATION SUR L ELEMENT FINI C_______________________________________________________________________ C isupo=4 if (npint.eq.12345) isupo=1 * integration aux noeuds if(infmod(/1).lt.2+isupo)then CALL ELQUOI(MELE,0,isupo,IPINF,IMODEL) INFO=IPINF MINTE=INFELL(11) MINTE1=INFELL(12) MFR =INFELL(13) LRE =INFELL(9) LW =INFELL(7) LHOOK =INFELL(10) NDDL =INFELL(15) IELE=INFELL(14) ICARA=INFELL(5) NLIGRP = INFELL(9) NLIGRD = INFELL(9) segsup info if(mele.ne.260) segact minte * write(6,*) ' premier elquoi' * write(6,*) 'poigau',(poigau(iou),iou=1,poigau(/1)) * write(6,*) ((shptot(ir,it,1),ir=1,shptot(/1)),it=1,shptot(/2)) else MINTE=INFMOD(2+isupo) MINTE1=INFMOD(8) MFR =INFELE(13) LRE =INFELE(9) LW =INFELE(7) LHOOK =INFELE(10) NDDL =INFELE(15) IELE=INFELE(14) ICARA=INFELE(5) NLIGRP = INFELE(9) NLIGRD = INFELE(9) endif IPMINT=MINTE IPMIN1=MINTE1 * segact minte * write(6,*) ' deuxieme elquoi' * write(6,*) 'poigau',(poigau(iou),iou=1,poigau(/1)) * write(6,*) ((shptot(ir,it,1),ir=1,shptot(/1)),it=1,shptot(/2)) C C INITIALISATION DE MINTE C if(mele.ne.260) SEGACT MINTE NBPGAU=POIGAU(/1) C * Preparation du PARTITIONNEMENT du segment XMATRI LTRK=OOOVAL(1,4) IF (LTRK.EQ.0) LTRK=OOOVAL(1,1) IPT1=IPMAIL SEGACT,IPT1 NBNN1 =IPT1.NUM(/1) NBELE1=IPT1.NUM(/2) * Ajout a la taille en mots de la matrice des infos du segment LSEG=LRE*LRE*NBELE1 + 16 NBLPRT=(LSEG-1)/LTRK+1 NBLMAX=(NBELE1-1)/NBLPRT+1 NBLPRT=(NBELE1-1)/NBLMAX+1 * write (ioimp,*) ' masse1 nblprt nblmax ',NBLPRT,NBLMAX,NBELE1 NRIGEL = IRIGEL(/2) + NBLPRT SEGADJ,MRIGID IPMASS=MRIGID MELEME=IPT1 * Boucle (5000) de PARTITIONNEMENT du segment XMATRI DO 5000 IPRT = 1,NBLPRT isouss=isouss+1 IF (NBLPRT.GT.1) THEN JPRT=(IPRT-1)*NBLMAX SEGACT,IPT1 NBSOUS=0 NBREF=0 NBNN=NBNN1 NBELEM=MIN(NBLMAX,NBELE1-JPRT) * write (6,*) ' creation segment ',nbnn,nbelem SEGINI,MELEME ITYPEL=IPT1.ITYPEL DO I=1,NBELEM IB=I+JPRT DO J=1,NBNN NUM(J,I)=IPT1.NUM(J,IB) ENDDO ICOLOR(I)=IPT1.ICOLOR(IB) ENDDO ENDIF IPMAIL=MELEME C C ON RECUPERE LES MELVAL ET LES MELEME C MELEME=IPMAIL SEGACT MELEME * * modification du meleme pour le remplissage du segment descripteur * en deformations planes generalisees * IF (BDPGE.AND.MFR.NE.35.AND.MFR.NE.53) THEN IPT2=IPMAIL C* SEGACT IPT2 NBELEM=IPT2.NUM(/2) NBNN=IPT2.NUM(/1)+1 NBREF=0 NBSOUS=0 SEGINI MELEME DO 1007 I=1,NBELEM DO 1008 J=1,NBNN-1 NUM(J,I)=IPT2.NUM(J,I) 1008 CONTINUE NUM(NBNN,I)=IIPDPG ICOLOR(I)=IPT2.ICOLOR(I) 1007 CONTINUE ITYPEL=28 IPMADG=MELEME SEGDES IPT2 ELSE NBNN =NUM(/1) NBELEM=NUM(/2) ENDIF IPPORE=0 IF(MFR.EQ.33) IPPORE=NBNN C c cas Xfem: DESCR et IMATRI créé par massxr.eso C* Cas particulier des elements XFEM en cas de partition : C* Il faut aussi partitionner le modele (nomme imoxfem) IF (MFR.EQ.63) THEN IF (nblprt.GT.1) THEN imoxfem = 0 CALL PARTXR(IMODEL,ipmail,imoxfem) IF (IERR.NE.0) RETURN ELSE imoxfem = IMODEL ENDIF GOTO 1999 ENDIF c C ---------------------------------------------------------* C INITIALISATION DU SEGMENT DESCR, SEGMENT DESCRIPTEUR DES * C DES INCONNUES RELATIVES A LA MATRICE DE RIGIDITE * C ---------------------------------------------------------* SEGINI DESCR IPDSCR=DESCR if(lnomid(1).ne.0) then nomid=lnomid(1) segact nomid modepl=nomid ndepl=lesobl(/2) ndum=lesfac(/2) lsupdp=.false. else lsupdp=.true. CALL IDDEPL(MFR,IFOUR,MODEPL,NDEPL,NDUM) endif if(lnomid(2).ne.0) then nomid=lnomid(2) segact nomid moforc=nomid nforc=lesobl(/2) lsupfo=.false. else lsupfo=.true. CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NDUM) endif C IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN CALL ERREUR(5) SEGSUP DESCR,MRIGID SEGDES MMODEL,MELEME RETURN ENDIF C C REMPLISSAGE DU SEGMENT DESCRIPTEUR C IDDL=1 NCOMP=NDEPL NBNNS=NBNN IF (MFR.EQ.33) NCOMP=NDEPL-1 IF (BDPGE.AND.MFR.NE.35.AND.MFR.NE.53) THEN NCOMP=NDEPL-NDPGE NBNNS=NBNN-1 ENDIF IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2 if (dcmat2) NCOMP = NDEPL/2 NOMID=MODEPL SEGACT NOMID NOMID=MOFORC SEGACT NOMID DO 1004 INOEUD=1,NBNNS DO 1005 ICOMP=1,NCOMP NOMID=MODEPL LISINC(IDDL)=LESOBL(ICOMP) if (dcmat2) LISINC(IDDL)=LESOBL(IDDL) NOMID=MOFORC LISDUA(IDDL)=LESOBL(ICOMP) if (dcmat2) LISDUA(IDDL)=LESOBL(IDDL) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 1005 CONTINUE 1004 CONTINUE * * cas de la deformation plane generalisee * IF (BDPGE.AND.MFR.NE.35.AND.MFR.NE.53) THEN DO 1006 ICOMP=(NDPGE-1),0,-1 NOMID=MODEPL LISINC(IDDL)=LESOBL(NDEPL-ICOMP) NOMID=MOFORC LISDUA(IDDL)=LESOBL(NFORC-ICOMP) NOELEP(IDDL)=NBNN NOELED(IDDL)=NBNN IDDL=IDDL+1 1006 CONTINUE ENDIF C C CAS DES MILIEUX POREUX C IF (MFR.EQ.33) THEN DO 1104 INOEUD=1,NBSOM(IELE) NOMID=MODEPL LISINC(IDDL)=LESOBL(NDEPL) NOMID=MOFORC LISDUA(IDDL)=LESOBL(NDEPL) NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1) NOELED(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1) IDDL=IDDL+1 1104 CONTINUE ENDIF * * cas des element raccord * IF (MFR.EQ.19.OR.MFR.EQ.21) THEN CALL IDDEPL(MFR+1000,IFOUR,MODPL,NDEPL,NDUM) CALL IDFORC(MFR+1000,IFOUR,MOFRC,NFORC,NDUM) NOMID=MODPL SEGACT NOMID NOMID=MOFRC SEGACT NOMID DO 1106 INOEUD=NBNNS+1,NBNN DO 1107 ICOMP=1,NDEPL NOMID=MODPL LISINC(IDDL)=LESOBL(ICOMP) NOMID=MOFRC LISDUA(IDDL)=LESOBL(ICOMP) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 1107 CONTINUE 1106 CONTINUE NOMID=MODPL SEGsup NOMID NOMID=MOFRC SEGsup NOMID ENDIF NOMID=MODEPL SEGDES NOMID NOMID=MOFORC SEGDES NOMID SEGDES DESCR C C ------------------------------------------------------------* C INITIALISATION DU SEGMENT IMATRI, CHAPEAU SUR LES SEGMENTS * C CONTENANT LES MATRICES DE RIGIDITE ELEMENTAIRES * C ------------------------------------------------------------* C NBELEM: NB D'ELEMENTS DANS LA SOUS ZONE NLIGRP=LRE NLIGRD=LRE C NELRIG=NBELEM SEGINI xMATRI IPMATR=xMATRI C C------------------------------------------------------* C C TRAITEMENT DU CHAPEAU DES RIGIDITES, SEGMENT MRIGID * C------------------------------------------------------* C COERIG(isouss)=1.D0 IF (BDPGE.AND.MFR.NE.35.AND.MFR.NE.53) THEN IRIGEL(1,isouss)=IPMADG ELSE IRIGEL(1,isouss)=IPMAIL ENDIF IRIGEL(2,isouss)=0 IRIGEL(3,isouss)=IPDSCR IRIGEL(4,isouss)=xMATRI IRIGEL(5,isouss)=NHRM IRIGEL(6,isouss)=0 IRIGEL(7,isouss)=0 IRIGEL(8,isouss)=0 IF (BDPGE.AND.MFR.NE.35.AND.MFR.NE.53) THEN SEGDES MELEME MELEME=IPMAIL SEGACT MELEME NBNN=NUM(/1) ENDIF C C CAS DE L'OPERATEUR LUMP ON INDIQUE QUE LA MATRICE MASSE GENEREE EST DIAGONALE C * IF (ILUMP .EQ. 1) THEN * IRIGEL(7,isouss) = 3 * ENDIF c 1999 continue C_______________________________________________________________________ C C TRAITEMENT DES CHAMP MATERIAUX C_______________________________________________________________________ C NBROBL=0 NBRFAC=0 MOMATR=0 IVAMAT=0 IVACAR=0 LHOTRA=0 * * JOINT UNIDIMENSIONNEL JOI1 * IF (MFR.EQ.75) THEN IF (IDIM.EQ.3) THEN NBROBL=10 SEGINI NOMID LESOBL(1)='V1X' LESOBL(2)='V1Y' LESOBL(3)='V1Z' LESOBL(4)='V2X' LESOBL(5)='V2Y' LESOBL(6)='V2Z' LESOBL(7)='MASS' LESOBL(8)='JX' LESOBL(9)='JY' LESOBL(10)='JZ' ELSE IF (IDIM.EQ.2) THEN NBROBL=4 SEGINI NOMID LESOBL(1)='V1X' LESOBL(2)='V1Y' LESOBL(3)='MASS' LESOBL(4)='JZ' ENDIF * NBTYPE=1 SEGINI NOTYPE TYPE(1)='REAL*8' MOMATR=NOMID MOTYPE=NOTYPE * * rho dans les cas,massif,coq3,poutre,tuyau,coq8,coq2,barre,jot3,joi4,joi2,xfem * ELSE IF (MFR.EQ.1.OR.MFR.EQ.7.OR.MFR.EQ.13.OR.MFR.EQ.3. 1 OR.MFR.EQ.27.OR.MFR.EQ.9.OR.MFR.EQ.35.OR.MFR.EQ.31. 2 OR.MFR.EQ.49.OR.MFR.EQ.53.OR.MFR.EQ.63.OR.MFR.EQ.5) THEN * IF(CMATE.NE.'SECTION') THEN NBROBL=1 SEGINI NOMID LESOBL(1)='RHO ' NBTYPE=1 SEGINI NOTYPE TYPE(1)='REAL*8' ELSE LHOTRA=LHOOK NBROBL=2 SEGINI NOMID MOMATR=NOMID LESOBL(1)='MODS' LESOBL(2)='MATS' NBTYPE=2 SEGINI NOTYPE TYPE(1)='POINTEURMMODEL' TYPE(2)='POINTEURMCHAML' ENDIF MOMATR=NOMID MOTYPE=NOTYPE * * rhoref rlcar dans le cas des elements de raccord et surface libre * ELSE IF (MFR.EQ.19.OR.MFR.EQ.21.OR.MFR.EQ.23) THEN NBROBL=2 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='RORF' LESOBL(2)='LCAR' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * caracteristiques pour les elements liquides * ELSE IF (MFR.EQ.11) THEN NBROBL=5 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='RHO ' LESOBL(2)='CSON' LESOBL(3)='RORF' LESOBL(4)='CREF' LESOBL(5)='LCAR' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * caracteristiques pour les elements homogeneises * ELSE IF (MFR.EQ.37) THEN IF (MELE.EQ.157) THEN NBROBL=15 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='B11 ' LESOBL(2)='B22 ' LESOBL(3)='B12 ' LESOBL(4)='ROF ' LESOBL(5)='ROS ' LESOBL(6)='CSON' LESOBL(7)='RORF' LESOBL(8)='CREF' LESOBL(9)='LCAR' LESOBL(10)='E111' LESOBL(11)='E112' LESOBL(12)='E121' LESOBL(13)='E122' LESOBL(14)='E221' LESOBL(15)='E222' ELSE NBROBL=9 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='B11 ' LESOBL(2)='B22 ' LESOBL(3)='B12 ' LESOBL(4)='ROF ' LESOBL(5)='ROS ' LESOBL(6)='CSON' LESOBL(7)='RORF' LESOBL(8)='CREF' LESOBL(9)='LCAR' ENDIF * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * caracteristiques pour l'element acoustique pure * ELSE IF (MFR.EQ.41) THEN NBROBL=5 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='RHO ' LESOBL(2)='CSON' LESOBL(3)='RORF' LESOBL(4)='CREF' LESOBL(5)='LCAR' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * caracteristiques pour l'element raccord liquide tuyau * ELSE IF (MFR.EQ.43) THEN NBROBL=3 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='RHO ' LESOBL(3)='RORF' LESOBL(2)='LCAR' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * caracteristiques pour les joints generalises * ELSE IF (MFR.EQ.55) THEN CcPPj NBROBL=2 CcPPj NBRFAC=0 CcPPj SEGINI NOMID CcPPj MOMATR=NOMID CcPPj LESOBL(1)='RHO ' CcPPj LESOBL(2)='EPAI' NBROBL=1 NBRFAC=1 SEGINI NOMID MOMATR=NOMID LESOBL(1)='RHO ' LESFAC(1)='EPAI' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * poi1 -- MODAL * ELSE IF (CMATE.EQ.'MODAL') THEN NBROBL=3 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='FREQ' LESOBL(2)='MASS' LESOBL(3)='DEFO' * NBTYPE=3 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' TYPE(2)='REAL*8' TYPE(3)='POINTEURCHPOINT' * * poi1 -- STATIQUE * ELSE IF (CMATE.EQ.'STATIQUE') THEN NBROBL=3 NBRFAC=0 SEGINI NOMID MOMATR=NOMID LESOBL(1)='DEFO' LESOBL(2)='RIDE' LESOBL(3)='MADE' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='POINTEURCHPOINT' * ENDIF DO imat = 1 , matmod(/2) IF (matmod(imat).eq.'IMPEDANCE') THEN NBROBL=0 NBRFAC=2 SEGINI NOMID MOMATR=NOMID LESFAC(1)='MASS' LESFAC(2)='INER' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' ENDIF ENDDO C NMATR=NBROBL NMATF=NBRFAC NMATT=NMATR+NMATF IF (MOMATR.NE.0) THEN * * verification du support des composantes recherchees * CALL QUESUQ(IMODEL,IPCHE1,4,0,MOMATR,isupo,ISUP,IRET1) IF(ISUP.GT.1)THEN SEGSUP NOTYPE GO TO 9990 ENDIF * CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) SEGSUP NOTYPE IF (IERR.NE.0) THEN GOTO 9996 ENDIF IF(ISUP.EQ.1)THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE) IF(IERR.NE.0)THEN ISUP=0 GOTO 9990 ENDIF ENDIF if (cmate.eq.'STATIQUE'.or.cmate.eq.'MODAL') then mptval = ivamat segact mptval if (ival(/1).lt.3) call erreur(5) endif if (cmate.eq.'STATIQUE') then kstat = kstat + 1 ivstat(kstat) = ivamat pistat(kstat) = imodel if (kstat.eq.nstat) then nstat = nstat + 100 segadj modsta endif endif if (cmate.eq.'MODAL') then kmoda = kmoda + 1 ivmoda(kmoda) = ivamat pimoda(kmoda) = imodel if (kmoda.eq.nmoda) then nmoda = nmoda + 100 segadj modsta endif endif ENDIF C C____________________________________________________________________ C C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES C____________________________________________________________________ C NBROBL=0 NBRFAC=0 MOCARA=0 NCARA=0 NCARF=0 NCARR=0 IVECT=0 * * epaisseur dans le cas massif en contraintes planes * IF((MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.63.OR.MELE.EQ.35.OR. +MELE.EQ.36.OR.MELE.EQ.63).AND.IFOUR.EQ.-2)THEN NBROBL=0 NBRFAC=1 SEGINI NOMID MOCARA=NOMID LESFAC(1)='DIM3' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * epaisseur et excentrement dans le cas des coques * ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN NBROBL=1 IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN NBRFAC=2 ELSE NBRFAC=1 ENDIF SEGINI NOMID MOCARA=NOMID LESOBL(1)='EPAI' LESFAC(1)='EXCE' IF(MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * section pour les barres et les cerces * ELSE IF (MFR.EQ.27) THEN do im = 1,matmod(/2) if (matmod(im).eq.'MODAL') dcmoda =.true. enddo IF(.NOT.(dcmate.or.dcmoda)) THEN NBROBL=1 SEGINI NOMID MOCARA=NOMID LESOBL(1)='SECT' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' ENDIF * * 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 (dcmate) then NBROBL=0 NBRFAC=1 SEGINI NOMID MOCARA=NOMID LESFAC(1)='VECT' IVECT=1 * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='POINTEURPOINT ' else IF (CMATE.EQ.'SECTION') THEN NBROBL=0 NBRFAC=1 SEGINI NOMID MOCARA=NOMID LESFAC='VECT' IVECT=1 * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='POINTEURPOINT ' * * CAS 2D ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN NBRFAC=1 NBROBL=2 SEGINI NOMID MOCARA=NOMID LESOBL(1)= 'SECT' LESOBL(2)= 'INRZ' LESFAC(1)= 'SECY' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * ELSE NBROBL=4 NBRFAC=3 SEGINI NOMID MOCARA=NOMID LESOBL(1)='TORS' LESOBL(2)='INRY' LESOBL(3)='INRZ' LESOBL(4)='SECT' LESFAC(1)='SECY' LESFAC(2)='SECZ' LESFAC(3)='VECT' IVECT=1 * NBTYPE=7 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' TYPE(2)='REAL*8' TYPE(3)='REAL*8' TYPE(4)='REAL*8' TYPE(5)='REAL*8' TYPE(6)='REAL*8' TYPE(7)='POINTEURPOINT ' ENDIF 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 ' * * caracteristique pour les elements de raccord * ELSE IF (MFR.EQ.19.OR.MFR.EQ.21) THEN IF(IDIM.EQ.2)THEN NBROBL=2 SEGINI NOMID MOCARA=NOMID LESOBL(1)='VX ' LESOBL(2)='VY ' ELSEIF(IDIM.EQ.3)THEN NBROBL=3 SEGINI NOMID MOCARA=NOMID LESOBL(1)='VX ' LESOBL(2)='VY ' LESOBL(3)='VZ ' ENDIF * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * caracteristiques des elements homogeneises * ELSE IF (MFR.EQ.37) THEN IF(IFOUR.EQ.1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.2) THEN NBROBL=5 SEGINI NOMID MOCARA=NOMID LESOBL(1)='SCEL' LESOBL(2)='SFLU' LESOBL(3)='EPS ' LESOBL(4)='SECT' LESOBL(5)='INRZ ' ELSE NBROBL=5 SEGINI NOMID MOCARA=NOMID LESOBL(1)='SCEL' LESOBL(2)='SFLU' LESOBL(3)='EPS ' LESOBL(4)='NOF1' LESOBL(5)='NOF2' ENDIF * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * caracteristiques de l'element tuyau acoustique * ELSE IF (MFR.EQ.41) THEN NBROBL=1 NBRFAC=1 SEGINI NOMID MOCARA=NOMID LESOBL(1)='RAYO' LESFAC(1)='RACO' * NBTYPE=2 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' TYPE(2)='REAL*8' * * caracteristiques de l'element de raccord liquide tuyau * ELSE IF (MFR.EQ.43) THEN NBROBL=1 NBRFAC=2 SEGINI NOMID MOCARA=NOMID LESOBL(1)='RAYO' LESFAC(1)='RACO' LESFAC(2)='VECT' * NBTYPE=3 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' TYPE(2)='REAL*8' TYPE(3)='POINTEURPOINT ' IVECT=1 ENDIF NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF * IF (MOCARA.NE.0) THEN * * verification du support des composantes recherchees * CALL QUESUQ(IMODEL,IPCHE1,4,0,MOCARA,isupo,ISUP,IRET2) IF(ISUP.GT.1)THEN SEGSUP NOTYPE GO TO 9990 ENDIF * CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 MPTVAL=IVACAR IF(ISUP.EQ.1)THEN CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE) IF(IERR.NE.0)THEN ISUP=0 GOTO 9990 ENDIF ENDIF ENDIF C imod = imodel if (dcmat2.and.mele.eq.2) goto 27 C_______________________________________________________________________ C C NUMERO DES ETIQUETTES : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT C LES ELEMENTS SONT GROUPES COMME SUIT : C - MASSIF,LIQUIDE 'SURFACE LIBRE' ----------------------> MASSE2 C - COQ3/POUTRE,DKT,COQ4,COQ8,COQ2,DST ------------------> MASSE3 C ET POUTRE DE TIMOSCHENKO C - RACCORDS LIQUIDE/MASSIFS,RACCORDS LIQUIDE/COQUES, C BARRE,HOMOGENEISE,JOINTS --------------------------> MASSE4 C_______________________________________________________________________ IF (MELE.LE.100) * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9 & GOTO ( 99, 99, 99, 4, 99, 4, 99, 4, 99, 4, 99 * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT & , 12, 99, 4, 4, 4, 4, 12, 12, 99, 99, 99 * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6 & , 4, 4, 4, 4, 27, 27, 27, 30, 99, 99, 99 * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 & , 99, 4, 4, 4, 4, 4, 4, 27, 27, 43, 27 * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO & , 12, 12, 12, 4, 27, 99, 99, 99, 4, 4, 12 * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15 & , 27, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 & , 99, 99, 4, 4, 4, 4, 99, 99, 99, 99, 99 * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 & , 99, 99, 99, 99, 99, 99, 27, 12, 99, 12, 12 * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 & , 99, 99, 99, 12, 27, 12, 12, 27, 27, 12, 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 & , 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8 & , 4, 12, 12, 50, 12, 12, 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, 12, 51, 51, 51, 51, 51, 51, 51, 51 * ???? ???? JCT3 JCI4 JGI2 JGT3 JGI4 ???? ???? ???? ???? & , 51, 51, 12, 12, 12, 12, 12, 51, 51, 51, 51 * ???? ???? ???? ???? ???? ???? E183 E184 ???? ???? ???? & , 51, 51, 51, 51, 51, 51, 4, 4, 51, 51, 51 * ???? ???? ???? ???? ???? M1D2 M1D3 ???? ???? ???? ???? & , 51, 51, 51, 51, 51, 4, 4, 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 * ???? ???? ???? ???? ???? ???? SHB8 ???? ???? XQ4R XC8R & , 51, 51, 51, 51, 51, 51, 4, 51, 51, 63, 63 * JOI1 & , 12),MELE-200 C 51 CONTINUE 99 CONTINUE SEGSUP xMATRI IRIGEL(4,isouss)=0 MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='MASSE' CALL ERREUR(86) GOTO 9990 C_______________________________________________________________________ C C MASSIF, LIQUIDE, 'SURFACE LIBRE' C_______________________________________________________________________ C 4 CONTINUE IF (BDPGE) NDDL=NDDL+NDDLGE CALL MASSE2 (IPMAIL,NDDL,LRE,NBPGAU,IPMINT,MELE,MFR,IVAMAT, &IVACAR,NMATT,IPMATR,ILUMP,IIPDPG) GOTO 510 C_______________________________________________________________________ C C RACCORDS LIQUIDE/MASSIF,RACCORD LIQUIDE/COQUE,BARRE,HOMOGENEISE,JOT3 C JOI4,JOI2,JOI1 C_______________________________________________________________________ C 12 CONTINUE CALL MASSE4(IPMAIL,LW,LRE,IVAMAT,NMATT,IVACAR,NCARR,IVECT,NBPGAU, &IPMINT,NDDL,MELE,MFR,IPMATR,ILUMP,isouss,IIPDPG,imod) GOTO 510 C_______________________________________________________________________ C C COQ3/POUTRE,DKT,COQ4,COQ8,COQ2 ,DST, POUTRE DE TIMOSCHENKO C_______________________________________________________________________ C 27 CONTINUE CALL MASSE3(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR,NCARR, &IVECT,isouss,NBPGAU,IPMINT,IPMIN1,NDDL,MATE, &CMATE,LHOTRA,IPMATR,ILUMP,IIPDPG,imod) GOTO 510 C_______________________________________________________________________ C C ELEMENT LINESPRING CA NE PESE RIEN C_______________________________________________________________________ C 30 CONTINUE * DO 3030 IB=1,NBELEM * SEGINI XMATRI * IMATTT(IB)=XMATRI * SEGDES XMATRI * 3030 CONTINUE GOTO 510 CC______________________________________________________________________ C C ELEMENT TUYAU FISSURE CA NE PESE RIEN C_______________________________________________________________________ C 43 CONTINUE * DO 3043 IB=1,NBELEM * SEGINI XMATRI * IMATTT(IB)=XMATRI * SEGDES XMATRI * 3043 CONTINUE GOTO 510 C_______________________________________________________________________ C C ELEMENT LIA2 (LIAISON A 2 NOEUDS) CA NE PESE RIEN C_______________________________________________________________________ C 50 CONTINUE * DO 3050 IB=1,NBELEM * SEGINI XMATRI * IMATTT(IB)=XMATRI * SEGDES XMATRI * 3050 CONTINUE GOTO 510 C_______________________________________________________________________ C C ELEMENT XFEM (MFR = 63) C_______________________________________________________________________ C Le sous-programme MASSXR gere les appels aux elements de type XFEM C (imoxfem est le modele complet ou partitionne si necessaire) 63 CONTINUE CALL MASSXR (isouss,imoxfem, $ IVAMAT,IVACAR,NMATT,CMATE, IIPDPG,IPMASS,IRETER) IF (IRETER.NE.0) RETURN if (nblprt.GT.1) THEN imode1 = imoxfem segsup,imode1 endif C il n'y aura plus que les desactivations a faire GOTO 510 C_______________________________________________________________________ C C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA C_______________________________________________________________________ C 510 CONTINUE SEGDES MELEME C IF (ISUP.EQ.1) THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') goto 519 IF (ISUP.EQ.1) THEN CALL DTMVAL(IVAMAT,3) ELSE CALL DTMVAL(IVAMAT,1) ENDIF 519 continue C NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID NOMID=MOMATR SEGSUP NOMID if(mfr.ne.63) then NOMID=MOFORC if(lsupfo)SEGSUP NOMID NOMID=MODEPL if(lsupdp)SEGSUP NOMID endif C * INFO=IPINF * SEGSUP INFO C C ERREUR DANS LES S-P MASSE2 ,MASSE3 ,MASSE4 C IF (IERR.NE.0) GOTO 888 * * Fin de la boucle (5000) de PARTITIONNEMENT du segment XMATRI 5000 CONTINUE * if(mele.ne.260) SEGDES MINTE SEGDES IMODEL * *----------------------------------------------------------------------- * Fin de la boucle sur les sous-zones du modele *----------------------------------------------------------------------- 500 CONTINUE IF (isouss.NE.IRIGEL(/2)) THEN NRIGEL = isouss SEGADJ,MRIGID ENDIF *termes croises 'STATIQUE'/'MODAL' nstat = kstat nmoda = kmoda segadj modsta if (kstat.ne.0) then if (nstat.gt.0.and.nstat+nmoda.gt.0) call ricroi(modsta, ir2,1) if (nstat.gt.0) then do kstat=1,nstat mptval = ivstat(kstat) segact mptval IF (ISUP.EQ.1) THEN CALL DTMVAL(mptval,3) ELSE CALL DTMVAL(mptval,1) ENDIF enddo endif if (nmoda.gt.0) then do kmoda=1,nmoda mptval = ivmoda(kmoda) segact mptval IF (ISUP.EQ.1) THEN CALL DTMVAL(mptval,3) ELSE CALL DTMVAL(mptval,1) ENDIF enddo endif endif IRET = 1 888 CONTINUE if (nstat.gt.0.and.nstat+nmoda.gt.1) then ir1 = mrigid call fusrig(ir1,ir2,ir3) mrigid = ir3 ipmass = mrigid endif segsup modsta SEGDES MRIGID GOTO 666 C C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR C 9990 CONTINUE IRET=0 C IF (ISUP.EQ.1) THEN CALL DTMVAL(IVAMAT,3) CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVAMAT,1) CALL DTMVAL(IVACAR,1) ENDIF C NOMID=MOMATR IF (MOMATR.NE.0) SEGSUP NOMID NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID if(mfr.ne.63) then NOMID=MOFORC if(lsupfo)SEGSUP NOMID NOMID=MODEPL if(lsupdp)SEGSUP NOMID endif if(mele.ne.260) SEGDES MINTE C 9996 CONTINUE SEGDES MELEME SEGDES IMODEL SEGSUP MRIGID C 666 CONTINUE MMODEL = IPMODL * SEGDES MMODEL SEGSUP,MMODEL RETURN END