C RIGI1 SOURCE JK148537 26/06/23 21:15:06 12579 C---------------------------------------------------------------------* C * C OPERATEUR RIGIDITE * C * C---------------------------------------------------------------------* C * C CE SOUS-PROGRAMME SERT A TRAITER ET A METTRE EN FORME * C LES INFORMATIONS NECESSAIRES POUR LES CALCULS * C * C---------------------------------------------------------------------* C * C ENTREES : * C ________ * C * C MODORI Pointeur sur le modele * C IPCHE1 Pointeur sur le chamelem de carateristiques * C IPCHE2 Pointeur sur le chamelem de matrice de HOOKE * C IMAT (2 il y a une matrice de HOOKE,1 non ) * C * C SORTIES : * C ________ * C * C IPOI6 pointeur sur la rigidite construite * C IRET (1 OK , 0 erreur ) * C * C---------------------------------------------------------------------* SUBROUTINE RIGI1(MODORI,IPCHE1,IPCHE2,IMAT, IPOI6,IRET,noer) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC CCGEOME -INC CCREEL C==DEB= FORMULATION HHO == Include specifique ========================== -INC CCHHOPA C==FIN= FORMULATION HHO ================================================ -INC SMCOORD -INC SMCHAML -INC SMINTE -INC SMELEME -INC SMRIGID -INC SMMODEL POINTEUR IMOREF.IMODEL POINTEUR NOMID1.NOMID -INC SMLREEL -INC SMLENTI POINTEUR MLPHAS.MLENTI -INC TMPTVAL SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT segment modsta integer pimoda(nmoda),pistat(nstat) integer ivmoda(nmoda),ivstat(nstat) endsegment integer oooval CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM PARAMETER ( INTTYP=3 ) C INTTYP DEFINIT LE TYPE DE POINTS D'INTEGRATION C UTILISE PAR RIGI PARAMETER ( NINF=3 ) INTEGER INFOS(NINF),nrnlin LOGICAL LDPGE,lsupma,dcmate,dcmat2 C Petit tableau des "couleurs" des relations de conformite (goto 31) DIMENSION LCOLOR(6) DATA LCOLOR / 1, 3, 6, 10, 16, 24 / DATA NRNLIN / 4 / IRET = 0 IPOI6 = 0 C MODELE C -------------------- C CALL PIMODL(MODORI,IPMODL,MAILDG,1) if (ierr.ne.0) return IF (IPMODL.EQ.0) then call erreur(21) goto 889 ENDIF C IPMODL est ACTIF en retour : MMODEL = IPMODL NSOUS = mmodel.KMODEL(/1) C VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES C ZZZZZZZZ PEUT ETRE A FAIRE PLUTOT SUR LES SOUS-ZONES ISUP=0 IF (IPCHE1.NE.0) THEN call reduaf(ipche1,IPMODL,ipche10,0,iretca,kerr) if (iretca.ne.1) call erreur(kerr) if (ierr.ne.0) goto 889 ipche1=ipche10 CALL QUESUP(IPMODL,IPCHE1,INTTYP,0,ISUP,IRETCA) IF (ISUP.GT.1) GOTO 889 ENDIF C C VERIFICATION DU LIEU SUPPORT DU MCHAML DE HOOKE C ISUP1 = 0 IPCHOO = 0 IF (IMAT.EQ.2) THEN IPCHOO = IPCHE1 IF (IPCHE2.NE.0) THEN IPCHOO = IPCHE2 call reduaf(IPCHOO,IPMODL,IPCHE2,0,iretca,kerr) if (iretca.ne.1) call erreur(kerr) if (ierr .ne.0) goto 889 IPCHOO = IPCHE2 CALL QUESUP(IPMODL,IPCHE2,INTTYP,1,ISUP1,IRETHO) IF (ISUP1.NE.0) GOTO 889 ENDIF ENDIF ** call zpchel(ipche1,0) C INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE C --------------------------------------------- NRIGEL=0 SEGINI,MRIGID mrigid.MTYMAT = 'RIGIDITE' mrigid.IFORIG = IFOUR mrigid.ICHOLE = 0 mrigid.IMGEO1 = 0 mrigid.IMGEO2 = 0 mrigid.ISUPEQ = 0 mlphas = 0 c jk148537 en cas de besoin / NLIN L1 = 8 n1 = 1 segini mmode1 noerjk = noer if (noer.gt.1) noer = 0 mchel1 = 0 mchelm = ipche1 if (mchelm.ne.0) then n3 = infche(/2) segini mchel1 mchel1.ifoche = ifoche n2 = 2 segini mcham1 mchel1.ichaml(1) = mcham1 endif C termes croises STATIQUE et/ou MODAL nstat = 100 kstat = 0 nmoda = 100 kmoda = 0 segini modsta C Un petit segment toujours utile nbtype = 1 SEGINI,notype notype.TYPE(1) = 'REAL*8' MOTYR8 = notype C--------------------------------------------------------------------* C C BOUCLE SUR LES ZONES ELEMENTAIRES ( MEME TYPE D'EF ) C C--------------------------------------------------------------------* C ISOU=0 DO 500 ISOUS=1,NSOUS IMODEL = mmodel.KMODEL(ISOUS) C INITIALISATIONS MELE = imodel.NEFMOD IPMAIL = imodel.IMAMOD CONM = imodel.CONMOD CMATE = CMATEE MATE = IMATEE INAT = INATUU IF (MELE.EQ.259) GOTO 500 if (noerjk.eq.2 .and. cmate.ne.'NLIN') goto 500 IPT1 = IPMAIL NBNOE1 = IPT1.NUM(/1) NBELE1 = IPT1.NUM(/2) NMATR = 0 NMATF = 0 MOMATR = 0 MOTYMA = MOTYR8 IVAMAT = 0 lsupma = .true. NCARA = 0 NCARF = 0 MOCARA = 0 MOTYCA = MOTYR8 IVACAR = 0 IVAPHA = 0 MELPHA = 0 xMATRI = 0 IPMINT = 0 C C CREATION DU TABLEAU INFOS C irtd = 1 CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,irtd) IF (irtd.EQ.0) GOTO 518 dcmate = .false. dcmat2 = .false. 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 MELE = imodel.NEFMOD C Cas particulier : POI1/SEG2 et IMPEDANCE IF (dcmate) THEN meleme = IPMAIL if (meleme.itypel.eq.1) MELE = 45 if (meleme.itypel.eq.2) MELE = 2 ENDIF IF (MELE.EQ.22) GOTO 310 C C----------------------------------------------------------------------- C P H A S E 1 C C INFOS. ELEMENT FINI ET COMPOSANTES NECESSAIRES C DANS LES CHAMPS EN ENTREE ET EVENTUELLEMENT EN SORTIE C C ON POURRAIT REGROUPER LA PLUS GROSSE PARTIE DE CETTE PHASE DANS C UN SOUS-PROGRAMME COMMUN A BEAUCOUP D'OPERATEURS C C----------------------------------------------------------------------- if (infmod(/1).lt.2+inttyp) then write(ioimp,*) 'RIGI1 : ERREUR 5 - INFMOD(/1) ?',infmod(/1) call erreur(5) endif NSTRS = INFELE(16) MFR = INFELE(13) LW = INFELE( 7) NDDL = INFELE(15) IELE = INFELE(14) LRE = INFELE( 9) IPORE = INFELE( 8) LHOOK = INFELE(10) NBPGAU= INFELE( 6) C COQUE INTEGREE OU PAS ? NPINT = INFMOD(1) IPMINT = INFMOD(2+INTTYP) IPMIN1 = INFMOD(3) 310 continue if (mele.EQ.22) & write(ioimp,*) '(WARNING) RIGI1 : MELE = 22 - MFR = ',MFR IIPDPG = imodel.IPDPGE IIPDPG = IPTPOI(IIPDPG) C- Cas particulier en DEFO PLAN GENE CALL INFDPG(MFR,IFOUR,LDPGE,NDPGE) IF (LDPGE) THEN IF (IIPDPG.LE.0) THEN CALL ERREUR(925) CALL ERREUR(5) RETURN ENDIF if (maildg.eq.0) then CALL ERREUR(925) CALL ERREUR(5) ENDIF ipt2 = MAILDG IPMAIG = ipt2.lisous(isous) meleme = IPMAIG NBNOEG = meleme.num(/1) NBELEG = meleme.num(/2) ELSE IPMAIG = IPMAIL ENDIF C RECHERCHE DES NOMS D'INCONNUES ET DES DUAUX C MODEPL = imodel.lnomid(1) IF (MODEPL.EQ.0) THEN write(ioimp,*) 'RIGI1 : MODELE sans LNOMID(1) ?' call erreur(5) ENDIF nomid = MODEPL NDEPL = nomid.lesobl(/2) MOFORC = imodel.lnomid(2) IF (MOFORC.EQ.0) THEN write(ioimp,*) 'RIGI1 : MODELE sans LNOMID(2) ?' call erreur(5) ENDIF nomid = MOFORC NFORC = nomid.lesobl(/2) if (ndepl.eq.0 .or. nforc.eq.0 .or. ndepl.ne.nforc) then moterr = 'pas d inconnue duale ou primale ' call erreur(-385) interr(1) = imodel moterr(1:16) = conmod moterr(17:24) = ' ' call erreur(-386) call erreur(5) endif if (formod(1).eq.'MELANGE'.and.CMATE.EQ.'PARALLEL') then mophas = lnomid(12) nomid = mophas nmpha = lesobl(/2) nmphf = lesfac(/2) NPHAT = nmpha + nmphf JG = NPHAT if (mlphas.gt.0) then * verifie que le precedent melange a ete totalement traite do iph = 1,mlphas.lect(/1) if (mlphas.lect(iph).gt.0) then moterr(1:50) = 'melange incompletement traite' call erreur(-385) interr(1) = imodel moterr(1:16) = conm moterr(17:24) = ' ' call erreur(-386) call erreur(5) return endif enddo segadj mlphas else if (mlphas.eq.0) then segini mlphas endif IVAPHA = 0 imoref = 0 imosou = imodel * associe phase et coefficient de phase IF (IVAMOD(/1).LT.1) THEN call erreur(21) return ENDIF DO j = 1, IVAMOD(/1) IF (TYMODE(j).EQ.'IMODEL ') THEN IMODE1 = IVAMOD(j) IF (IMODE1.FORMOD(1)(1:10).EQ.'MECANIQUE ' .OR. & IMODE1.FORMOD(1)(1:10).EQ.'POREUX ' .OR. & IMODE1.FORMOD(1)(1:16).EQ.'ELECTROSTATIQUE ' .OR. & IMODE1.FORMOD(1)(1:10).EQ.'LIQUIDE ' ) THEN do iph = 1,nmpha if (imode1.conmod(17:24).eq.lesobl(iph)) then mlphas.lect(iph) = imode1 if (iph.eq.1) imoref = imode1 endif enddo ENDIF ENDIF ENDDO CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOPHAS,MOTYR8,0,INFOS,3,IVAPHA) IF (IERR.NE.0) GOTO 888 mptval = IVAPHA if (IVAPHA.gt.0) then if (ival(/1).eq.0) then * massif / pas de proportions phases / imite imoref / conserve CONM imodel = imoref MELE = nefmod elseif (ival(/1).ge.nmpha) then goto 500 else call erreur(21) return endif else * massif / pas de proportions phases / imite imoref / conserve CONM imodel = imoref MELE = nefmod endif IF (ISUP.EQ.1) THEN CALL VALCHE(IVAPHA,NPHAT,IPMINT,IPPORE,MOPHAS,MELE) IF (IERR.NE.0) THEN ISUP=0 GOTO 888 ENDIF ENDIF IF (IERR.NE.0) GOTO 888 if (mlphas.gt.0.and.ivapha.gt.0) then do iph = 1, NPHAT if (imodel.eq.mlphas.lect(iph)) MELPHA = ival(iph) enddo endif endif C RECHERCHE DES COMPOSANTES UTILES DES CHAMPS EN ENTREE C ----------------------------------------------------- NBROBL = 0 NBRFAC = 0 NOMID = 0 C Sauf cas particuliers, toutes les composantes de type REAL*8 NBTYPE = 0 NOTYPE = MOTYR8 C >>> CHAMP DE MATRICES DE HOOKE IF (IMAT.EQ.2) THEN C IF (MELE.EQ.93 .AND. CMATE.NE.'ISOTROPE') THEN NBROBL = 3 SEGINI,NOMID LESOBL(1)='MAHO' LESOBL(2)='V1X ' LESOBL(3)='V1Y ' NBTYPE=3 SEGINI NOTYPE TYPE(1)='POINTEURLISTREEL' TYPE(2)='REAL*8' TYPE(3)='REAL*8' ELSE NBROBL = 1 SEGINI NOMID LESOBL(1)='MAHO' NBTYPE = 1 SEGINI NOTYPE TYPE(1) ='POINTEURLISTREEL' ENDIF NMATR = NBROBL NMATF = NBRFAC NMATT = NMATR+NMATF MOMATR = NOMID MOTYMA = NOTYPE C >>> CHAMP DE MATERIAU ELSE C IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN IF (MFR.EQ.35.or.mfr.eq.78) THEN NBROBL = 2 SEGINI NOMID LESOBL(1)='KS ' LESOBL(2)='KN ' ELSE IF(MFR.EQ.53) THEN NBROBL = 1 SEGINI,NOMID LESOBL(1)='KS ' ELSE NBROBL = 2 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' C=DEB==== FORMULATION HHO ==== Traitement particulier du modele ======== CALL HHOIDC(imodel,nomid) NBROBL=nomid.lesobl(/2) ** NBRFAC=nomid.lesfac(/2) C=FIN==== FORMULATION HHO ============================================== ENDIF ELSE IF & (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'UNIDIREC') THEN IF (MFR.EQ.1.AND.IDIM.EQ.3) THEN NBROBL=7 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 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='V1X ' LESOBL(3)='V1Y ' ENDIF ELSE IF & (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ZONE_COHESIVE') THEN IF (MFR.EQ.77) THEN NBROBL=2 SEGINI NOMID LESOBL(1)='KS ' LESOBL(2)='KN ' ENDIF ELSE IF & (FORMOD(1).EQ.'POREUX '.AND.CMATE.EQ.'ISOTROPE') THEN IF (MELE.GE.79.AND.MELE.LE.83) THEN NBROBL=4 SEGINI NOMID LESOBL(1)='YOUN' LESOBL(2)='NU ' LESOBL(3)='COB ' LESOBL(4)='MOB ' ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN NBROBL=4 SEGINI NOMID LESOBL(1)='KS ' LESOBL(2)='KN ' LESOBL(3)='COB ' LESOBL(4)='MOB ' ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN NBROBL=10 SEGINI NOMID LESOBL( 1)='YOUN' LESOBL( 2)='NU ' LESOBL( 3)='COP1' LESOBL( 4)='COP2' LESOBL( 5)='CPP1' LESOBL( 6)='CPP2' LESOBL( 7)='KK11' LESOBL( 8)='KK12' LESOBL( 9)='KK21' LESOBL(10)='KK22' ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN NBROBL=17 SEGINI NOMID LESOBL( 1)='YOUN' LESOBL( 2)='NU ' LESOBL( 3)='COP1' LESOBL( 4)='COP2' LESOBL( 5)='COP3' LESOBL( 6)='CPP1' LESOBL( 7)='CPP2' LESOBL( 8)='CPP3' LESOBL( 9)='KK11' LESOBL(10)='KK12' LESOBL(11)='KK13' LESOBL(12)='KK21' LESOBL(13)='KK22' LESOBL(14)='KK23' LESOBL(15)='KK31' LESOBL(16)='KK32' LESOBL(17)='KK33' ELSE IF (MELE.GE.185.AND.MELE.LE.187) THEN NBROBL=10 SEGINI NOMID LESOBL( 1)='KS ' LESOBL( 2)='KN ' LESOBL( 3)='COP1' LESOBL( 4)='COP2' LESOBL( 5)='CPP1' LESOBL( 6)='CPP2' LESOBL( 7)='KK11' LESOBL( 8)='KK12' LESOBL( 9)='KK21' LESOBL(10)='KK22' ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN NBROBL=17 SEGINI NOMID LESOBL( 1)='KS ' LESOBL( 2)='KN ' LESOBL( 3)='COP1' LESOBL( 4)='COP2' LESOBL( 5)='COP3' LESOBL( 6)='CPP1' LESOBL( 7)='CPP2' LESOBL( 8)='CPP3' LESOBL( 9)='KK11' LESOBL(10)='KK12' LESOBL(11)='KK13' LESOBL(12)='KK21' LESOBL(13)='KK22' LESOBL(14)='KK23' LESOBL(15)='KK31' LESOBL(16)='KK32' LESOBL(17)='KK33' ENDIF ELSE IF (INAT.EQ.67.AND.CMATE.EQ.'ORTHOTRO') THEN NBROBL=6 SEGINI NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12' LESOBL(4)='G12 ' LESOBL(5)='V1X ' LESOBL(6)='V1Y ' C ELSE IF (FORMOD(1).EQ.'ELECTROSTATIQUE') THEN C Pour l'instant, lnomid(6) ou appel a IDMATR suffisent. C ELSE IF (FORMOD(1).EQ.'DIFFUSION') THEN C CB215821 : Desormais il faut utiliser COND MOTERR(1:8)='DIFFUSIO' CALL ERREUR(193) RETURN C CALL IDDILI(MATE,1,nomid,nbrobl,nbrfac) C poi1 -- MODAL ELSE IF (CMATE.EQ.'MODAL') THEN NBROBL=3 SEGINI NOMID LESOBL(1)='FREQ' LESOBL(2)='MASS' LESOBL(3)='DEFO' C poi1 -- STATIQUE ELSE IF (CMATE.EQ.'STATIQUE') THEN NBROBL=2 SEGINI NOMID LESOBL(1)='DEFO' LESOBL(2)='RIDE' C IMPEDANCE COMPLEXE ELSE IF (CMATE.EQ.'IMPCOMPL') THEN NBROBL=1 SEGINI NOMID LESOBL(1)='RAID' C C Autres cas : ELSE nomid = lnomid(6) IF (nomid.ne.0) then lsupma = .false. nbrobl = lesobl(/2) nbrfac = lesfac(/2) else write(ioimp,*) '(WARNING) RIGI1 : lnomid(6) non defini !' CALL IDMATR(MFR,IMODEL,nomid,nbrobl,nbrfac) endif ENDIF NMATR = NBROBL NMATF = NBRFAC NMATT = NMATR+NMATF MOMATR = NOMID IF (CMATE.EQ.'SECTION') THEN NBTYPE=3 SEGINI NOTYPE TYPE(1)='POINTEURMMODEL' TYPE(2)='POINTEURMCHAML' TYPE(3)='POINTEURLISTREEL' c mistral : ELSE IF (INAT.EQ.94) THEN NBTYPE=NMATT SEGINI NOTYPE DO ITYP = 1, NBTYPE TYPE(ITYP)='REAL*8' ENDDO C=DEB==== FORMULATION HHO ==== Traitement particulier du modele ======== IDECAL = 0 IF (MFR.EQ.HHO_MFR_ELEMENT) IDECAL = 4 C=FIN==== FORMULATION HHO ============================================== C pour le modele mistral il y a 10 composantes non lineaires qui sont des listes de reels NLDEB=NMATR-9-IDECAL NLFIN=NMATR-IDECAL DO ITYP = NLDEB, NLFIN TYPE(ITYP)='POINTEURLISTREEL' ENDDO C mistral. C poi1 -- MODAL ELSE IF (CMATE.EQ.'MODAL') THEN NBTYPE=3 SEGINI NOTYPE TYPE(1)='REAL*8 ' TYPE(2)='REAL*8 ' TYPE(3)='POINTEURCHPOINT' C poi1 -- STATIQUE ELSE IF (CMATE.EQ.'STATIQUE') THEN NBTYPE=1 SEGINI NOTYPE TYPE(1)='POINTEURCHPOINT' ENDIF C=DEB==== FORMULATION HHO ==== Traitement particulier du modele ======== IF (MFR .EQ. HHO_MFR_ELEMENT) THEN IF (NOTYPE .EQ. MOTYR8) THEN NBTYPE = 1 SEGINI,NOTYPE TYPE(1)='REAL*8 ' ENDIF IF (NBTYPE.EQ.1) THEN NBTYPE = NMATT SEGADJ,NOTYPE DO ITYP = 2, NBTYPE TYPE(ITYP) = TYPE(1) END DO END IF TYPE(NMATR-1) = 'POINTEURLISTREEL' TYPE(NMATR ) = 'POINTEURLISTREEL' END IF C=FIN==== FORMULATION HHO ============================================== MOTYMA = NOTYPE ENDIF C C >>> COMPOSANTES DE CARACTERISTIQUES UTILES C NBROBL = 0 NBRFAC = 0 NOMID = 0 C Sauf cas particuliers, toutes les composantes de type REAL*8 NBTYPE = 0 NOTYPE = MOTYR8 C C EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES C IF ( (MFR.EQ.1 .OR. MFR.EQ.31 .OR. C=DEB==== FORMULATION HHO ============================================== & (MFR.EQ.HHO_MFR_ELEMENT).OR. C=FIN==== FORMULATION HHO ============================================== & ((MELE.GE.79.AND.MELE.LE.83).OR. & (MELE.GE.173.AND.MELE.LE.182)) ) & .AND. IFOUR.EQ.-2) THEN NBRFAC=1 SEGINI,NOMID LESFAC(1)='DIM3' C C EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES C ELSE IF (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 LESOBL(1)='EPAI' LESFAC(1)='EXCE' IF (MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3' C C SECTION POUR LES BARRES ET LES CERCES C ELSE IF (MFR.EQ.27.OR.MFR.EQ.78) THEN IF (.NOT.dcmate) THEN NBROBL=1 SEGINI,NOMID LESOBL(1)='SECT' ENDIF C C section, excentrements et orientation pour les barres excentrees C 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 ' C C raideurs locales et orientation pour l'element LIA2 C de liaison a 2 noeuds C 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 ' C C CARACTERISTIQUES POUR LES POUTRES C ELSE IF (MFR.EQ.7 ) THEN if (dcmate) then NBRFAC=6 SEGINI NOMID LESFAC(1)='TORS' LESFAC(2)='INRY' LESFAC(3)='INRZ' LESFAC(4)='VX ' LESFAC(5)='VY ' LESFAC(6)='VZ ' IVECT=1 else IF (CMATE.EQ.'SECTION') THEN NBRFAC=3 SEGINI NOMID LESFAC(1)='VX ' LESFAC(2)='VY ' LESFAC(3)='VZ ' IVECT=1 C CAS 2D ELSE 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=5 SEGINI NOMID LESOBL(1)='TORS' LESOBL(2)='INRY' LESOBL(3)='INRZ' LESOBL(4)='SECT' LESFAC(1)='SECY' LESFAC(2)='SECZ' LESFAC(3)='VX ' LESFAC(4)='VY ' LESFAC(5)='VZ ' IVECT=1 ENDIF endif C C CARACTERISTIQUES POUR LES TUYAUX C ELSE IF (MFR.EQ.13) THEN NBROBL=2 NBRFAC=6 SEGINI NOMID LESOBL(1)='EPAI' LESOBL(2)='RAYO' LESFAC(1)='RACO' LESFAC(2)='PRES' LESFAC(3)='CISA' LESFAC(4)='VX ' LESFAC(5)='VY ' LESFAC(6)='VZ ' IVECT=1 C ELSE IF (MFR.EQ.39) THEN NBROBL=2 NBRFAC=5 SEGINI NOMID LESOBL(1)='EPAI' LESOBL(2)='RAYO' LESFAC(1)='RACO' LESFAC(2)='PRES' LESFAC(3)='VX ' LESFAC(4)='VY ' LESFAC(5)='VZ ' IVECT=1 C C CARACTERISTIQUES POUR LES LINESPRING C 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 ' C C CARACTERISTIQUES POUR LES TUYAUX FISSURES C 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' C C CARACTERISTIQUES DES ELEMENTS HOMOGENEISES C ELSE IF (MFR.EQ.37) THEN IF (IFOUR.EQ.1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.2) THEN NBROBL=5 SEGINI NOMID LESOBL(1)='SCEL' LESOBL(2)='SFLU' LESOBL(3)='EPS ' LESOBL(4)='SECT' LESOBL(5)='INRZ ' ELSE NBROBL=3 SEGINI NOMID LESOBL(1)='SCEL' LESOBL(2)='SFLU' LESOBL(3)='EPS ' ENDIF C C CARACTERISTIQUES DE L'ELEMENT TUYAU ACOUSTIQUE C ELSE IF (MFR.EQ.41) THEN NBROBL=1 NBRFAC=1 SEGINI NOMID LESOBL(1)='RAYO' LESFAC(1)='RACO' C C CARACTERISTIQUE POUR LES JOINTS GENE C ELSE IF (MFR.EQ.55) THEN NBRFAC=1 SEGINI NOMID LESFAC(1)='EPAI' C C CARACTERISTIQUE MACRO_EL (element CIFL) C ELSE IF (MFR.EQ.61)THEN NBROBL=2 SEGINI NOMID LESOBL(1)= 'SECT' LESOBL(2)= 'INRZ' C C CARACTERISTIQUES POUR LE JOI1 SI IMAT = 2 C ELSE IF (MFR.EQ.75.AND.IMAT.EQ.2) THEN IF (IDIM.EQ.2) THEN NBROBL=2 SEGINI NOMID LESOBL(1)='V1X ' LESOBL(2)='V1Y ' ELSE IF(IDIM.EQ.3) THEN NBROBL=6 SEGINI NOMID LESOBL(1)='V1X ' LESOBL(2)='V1Y ' LESOBL(3)='V1Z ' LESOBL(4)='V2X ' LESOBL(5)='V2Y ' LESOBL(6)='V2Z ' ENDIF ENDIF NCARA = NBROBL NCARF = NBRFAC NCARR = NCARA+NCARF MOCARA = NOMID C rendement kich 09/01 NCAR1 = NCARR + 1 ifac = NBRFAC NBRFAC = NBRFAC + 10 if (mocara.le.0) then segini,nomid mocara = nomid else segadj,nomid endif lesfac(ifac + 1) = 'REND' lesfac(ifac + 2) = 'W1X ' lesfac(ifac + 3) = 'W1Y ' lesfac(ifac + 4) = 'W1Z ' lesfac(ifac + 5) = 'W2X ' lesfac(ifac + 6) = 'W2Y ' lesfac(ifac + 7) = 'W2Z ' lesfac(ifac + 8) = 'REN1' lesfac(ifac + 9) = 'REN2' lesfac(ifac +10) = 'REN3' motype = notype if (motype.ne.motyr8) then nbtype = notype.type(/2) + 1 segadj,notype notype.type(nbtype) = 'REAL*8' endif MOTYCA = notype C-DEB---- DESCRIPTEUR -------------------------------------------------- C- Faire de ce bloc une subroutine commune avec MASS et autres ? C=DEB==== FORMULATION HHO ==== Cas particulier de la formulation ======= IF (MFR.EQ.HHO_MFR_ELEMENT) THEN CALL DSCMAT(imodel, IPDSCR, LRE, iret) IF (iret.NE.0) THEN CALL ERREUR(iret) RETURN END IF GOTO 1089 ENDIF C=FIN==== FORMULATION HHO ============================================== nbnn1 = NBNOE1 c lre : nb de noeuds par mult if (nefmod.eq. 22) lre=nbnn1 c lre : nb de noeuds par sure if (nefmod.eq.259) lre=nbnn1 C C traitement particulier pour milieu poreux IPPORE=0 IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN IPPORE=NBNNE(NUMGEO(MELE)) ENDIF IDECAP=0 IF (MELE.GE.79.AND.MELE.LE.83) THEN IDECAP=1 LRE = LRE + 2*NBNN1 - IPORE ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN IDECAP=1 LRE = LRE + (3*NBNN1 - IPORE)/2 - NBSOM(IELE) ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN IDECAP=2 LRE = LRE + (2*NBNN1 - IPORE)*IDECAP LHOOK=4 IF(IFOUR.EQ.1) LHOOK=6 ELSE IF (MELE.GE.185.AND.MELE.LE.187) THEN IDECAP=2 LRE = LRE + ((3*NBNN1 - IPORE)/2 - NBSOM(IELE))*IDECAP LHOOK=2 IF(IFOUR.EQ.1) LHOOK=3 ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN IDECAP=3 LRE = LRE + (2*NBNN1 - IPORE)*IDECAP LHOOK=4 IF(IFOUR.EQ.1) LHOOK=6 ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN IDECAP=3 LRE = LRE + ((3*NBNN1 - IPORE)/2 - NBSOM(IELE))*IDECAP LHOOK=2 IF(IFOUR.EQ.1) LHOOK=3 ENDIF C C REMPLISSAGE DU SEGMENT DESCRIPTEUR C NCOMP = NDEPL NBNNS = NBNOE1 NBNN = NBNOE1 IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN NCOMP=NDEPL-IDECAP ENDIF IF (LDPGE) THEN NCOMP = NDEPL - NDPGE NBNN = NBNOE1 + 1 ENDIF IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2 if (dcmat2) NCOMP = NDEPL/2 NLIGRP = LRE NLIGRD = LRE IF ((MFR.NE.61) .AND. (NBNNS*NCOMP .GT. NLIGRD)) THEN C erreur dans les dimensions de DESCR C le mode de calcul n'est pas correct CALL ERREUR(717) RETURN ENDIF SEGINI,DESCR IDDL = 1 NOMID = MODEPL NOMID1 = MOFORC IF (MFR.EQ.61) THEN NOELEP(1)=1 NOELEP(2)=1 NOELEP(3)=1 NOELEP(4)=3 NOELEP(5)=3 NOELEP(6)=3 NOELEP(7)=2 NOELEP(8)=2 DO IE1=1,LRE NOELED(IE1)=NOELEP(IE1) ENDDO DO IE1=1,3 LISINC(IE1)=nomid.LESOBL(IE1) LISINC(IE1+3)=nomid.LESOBL(IE1) ENDDO LISINC(7)=nomid.LESOBL(4) LISINC(8)=nomid.LESOBL(5) DO IE1=1,3 LISDUA(IE1) =nomid1.LESOBL(IE1) LISDUA(IE1+3)=nomid1.LESOBL(IE1) ENDDO LISDUA(7)=nomid1.LESOBL(4) LISDUA(8)=nomid1.LESOBL(5) IDDL = 9 ELSE NFAC=(3*NBNN-IPORE)/2 DO INOEUD = 1, NBNNS IF ((MELE.GE.108.AND.MELE.LE.110.AND.INOEUD.GT.NFAC) & .OR.(MELE.GE.185.AND.MELE.LE.187.AND.INOEUD.GT.NFAC) & .OR.(MELE.GE.188.AND.MELE.LE.190.AND.INOEUD.GT.NFAC)) & GO TO 1004 DO ICOMP=1,NCOMP NOMID=MODEPL LISINC(IDDL)=nomid.LESOBL(ICOMP) LISDUA(IDDL)=nomid1.LESOBL(ICOMP) if (dcmat2) THEN LISINC(IDDL)=nomid.LESOBL(IDDL) LISDUA(IDDL)=nomid1.LESOBL(IDDL) endif NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 ENDDO 1004 CONTINUE ENDDO ENDIF C CAS DE LA DEFORMATION PLANE GENERALISEE IF (LDPGE) THEN DO ICOMP=(NDPGE-1),0,-1 LISINC(IDDL)=nomid.LESOBL(NDEPL-ICOMP) LISDUA(IDDL)=nomid1.LESOBL(NFORC-ICOMP) NOELEP(IDDL)=NBNN NOELED(IDDL)=NBNN IDDL=IDDL+1 ENDDO ENDIF C CAS DES MILIEUX POREUX C POUR LA PRESSION ON MET D'ABORD LES SOMMETS IF (MFR.EQ.33) THEN DO INOEUD=1,NBSOM(IELE) LISINC(IDDL)=nomid.LESOBL(NDEPL) LISDUA(IDDL)=nomid1.LESOBL(NDEPL) NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1) NOELED(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1) IDDL=IDDL+1 ENDDO IF (MELE.GE.79.AND.MELE.LE.83) THEN DO INOEUD=1,NBNN DO INSOM=1,NBSOM(IELE) IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 1105 ENDDO LISINC(IDDL)=nomid.LESOBL(NDEPL) LISDUA(IDDL)=nomid1.LESOBL(NDEPL) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 1105 CONTINUE ENDDO ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN DO INOEUD=NFAC+1,NBNN LISINC(IDDL)=nomid.LESOBL(NDEPL) LISDUA(IDDL)=nomid1.LESOBL(NDEPL) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 ENDDO DO INOEUD=1,NFAC DO INSOM=1,NBSOM(IELE) IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 1110 ENDDO LISINC(IDDL)=nomid.LESOBL(NDEPL) LISDUA(IDDL)=nomid1.LESOBL(NDEPL) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 1110 CONTINUE ENDDO ENDIF ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN DO IPR=1,IDECAP NDECAP = NDEPL-IDECAP+IPR DO INOEUD=1,NBSOM(IELE) LISINC(IDDL)=nomid.LESOBL(NDECAP) LISDUA(IDDL)=nomid1.LESOBL(NDECAP) NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1) NOELED(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1) IDDL=IDDL+1 ENDDO IF (MELE.GE.173.AND.MELE.LE.182) THEN DO INOEUD=1,NBNN DO INSOM=1,NBSOM(IELE) IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 1205 ENDDO LISINC(IDDL)=nomid.LESOBL(NDECAP) LISDUA(IDDL)=nomid1.LESOBL(NDECAP) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 1205 CONTINUE ENDDO ELSE IF (MELE.GE.185.AND.MELE.LE.190) THEN DO INOEUD=NFAC+1,NBNN LISINC(IDDL)=nomid.LESOBL(NDECAP) LISDUA(IDDL)=nomid1.LESOBL(NDECAP) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 ENDDO DO INOEUD=1,NFAC DO INSOM=1,NBSOM(IELE) IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 1710 ENDDO LISINC(IDDL)=nomid.LESOBL(NDECAP) LISDUA(IDDL)=nomid1.LESOBL(NDECAP) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 1710 CONTINUE ENDDO C ENDIF ENDDO C CAS DES ELEMENT RACCORD ELSE IF (MFR.EQ.19.OR.MFR.EQ.21) THEN CALL IDPRIM(IMODEL,MFR+1000,MODPL,NDEPL,NDUM) CALL IDDUAL(IMODEL,MFR+1000,MOFRC,NFORC,NDUM) nomid = MODPL nomid1 = MOFRC DO INOEUD=NBNNS+1,NBNN DO ICOMP=1,NDEPL LISINC(IDDL) = nomid.LESOBL(ICOMP) LISDUA(IDDL) = nomid1.LESOBL(ICOMP) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 ENDDO ENDDO SEGSUP,nomid,nomid1 ENDIF SEGDES,DESCR IPDSCR = DESCR 1089 CONTINUE C-FIN---- DESCRIPTEUR -------------------------------------------------- C Si necessaire partitionnement du xmatri LTRK = oooval(1,4) if (LTRK.eq.0) LTRK = oooval(1,1) LTRK = MAX(LTRK,2**24) C Ajout a la taille en mots de la matrice des infos du segment lseg = lre*lre*nbele1 + 16 nblprt = (lseg-1)/ltrk+1 ** if (nblprt.eq.1 .and. nbele1.gt.20) nblprt = 2 nblmax = (nbele1-1)/nblprt+1 nblprt = (nbele1-1)/nblmax+1 c** if (nblprt.gt.1) then c** write(ioimp,*) 'RIGI1 : IMODEL = ',imodel,isous c** write(ioimp,*) 'RIGI1 : nblprt nblmax = ',nblprt,nblmax,nbele1 c** endif NRIGE0 = mrigid.IRIGEL(/2) nrigel = NRIGE0 + NBLPRT if (cmate.eq.'NLIN') nrigel = nrige0 + nrnlin*nblprt SEGADJ,MRIGID IPOI6 = MRIGID meleme = IPT1 ipt3 = IPMAIG nbnn = NBNOE1 nbelem = NBELE1 nbsous = 0 nbref = 0 DO 505 iprt = 1, nblprt isou = isou+1 if (nblprt.gt.1) then inelem = (iprt-1) * nblmax nbnn = NBNOE1 nbelem = MIN(nblmax,nbele1-inelem) C write(ioimp,*) ' creation segment ',nbnn,nbelem SEGINI,meleme meleme.itypel = ipt1.itypel do ielt = 1, nbelem jelt = ielt + inelem do inoe = 1, nbnn num(inoe,ielt) = ipt1.num(inoe,jelt) enddo icolor(ielt) = ipt1.icolor(jelt) enddo IF (LDPGE) THEN ipt2 = IPMAIG nbnn = NBNOEG cc nbelem = MIN(NBLMAX,NBELEG-inelem) SEGINI,ipt3 ipt3.itypel = 28 DO ielt = 1, nbelem jelt = ielt + inelem DO inoe = 1, nbnn ipt3.num(inoe,ielt) = IPT2.NUM(inoe,jelt) ENDDO ipt3.icolor(ielt) = IPT2.ICOLOR(jelt) ENDDO SEGDES,IPT3 ELSE ipt3 = meleme ENDIF endif nbnn = NBNOE1 ipmail = meleme ipmadg = ipt3 C* Tests faits avant normalement : IF (MELE.EQ.22) GOTO 9991 IF (MELE.EQ.259) GOTO 9991 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) ELSE imoxfem = IMODEL ENDIF ENDIF C=DEB==== FORMULATION HHO ==== Traitement particulier du modele ======== IF (MFR.EQ.HHO_MFR_ELEMENT) THEN IF (nblprt.GT.1) THEN SEGINI,imode1=imodel imode1.imamod=ipmail imohho = imode1 CALL HHOPAR(imohho,iret) if (iret.ne.0) return ELSE imohho = IMODEL ENDIF ENDIF C=FIN==== FORMULATION HHO ============================================== C TRAITEMENT DES CHAMPS EN ENTREE C ------------------------------- C >>> CHAMP DE MATRICES DE HOOKE C IF (IMAT.EQ.2) THEN CALL KOMCHA(IPCHOO,IPMAIL,CONM,MOMATR,MOTYMA,1,INFOS,3,IVAMAT) IF (IERR.NE.0) GOTO 9991 MPTVAL=IVAMAT MELVAL=IVAL(1) NBGMAT=IELCHE(/1) NELMAT=IELCHE(/2) IF(IPCHE2.EQ.0.AND.ISUP.EQ.1)THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE) IF(IERR.NE.0)THEN ISUP=0 GOTO 9991 ENDIF ENDIF C C >>> CHAMP DE MATERIAU C ELSE CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYMA,1,INFOS,3,IVAMAT) IF (IERR.NE.0) GOTO 9991 IF (ISUP.EQ.1)THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE) IF(IERR.NE.0)THEN ISUP=0 GOTO 9991 ENDIF ENDIF C MPTVAL=IVAMAT C if (cmate.eq.'STATIQUE'.or.cmate.eq.'MODAL') then 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 else 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 NBGMAT = 0 NELMAT = 0 IF (CMATE.EQ.'SECTION') THEN DO IM = 1,ival(/1) MELVAL = IVAL(IM) IF (MELVAL.NE.0) THEN NBGMAT=MAX(NBGMAT,IELCHE(/1)) NELMAT=MAX(NELMAT,IELCHE(/2)) ENDIF ENDDO ELSE DO IM=1,ival(/1) MELVAL = IVAL(IM) IF (MELVAL.NE.0) THEN NBGMAT=MAX(NBGMAT,VELCHE(/1)) NELMAT=MAX(NELMAT,VELCHE(/2)) ENDIF ENDDO ENDIF ENDIF C C >>> CHAMPS DE CARACTERISTIQUES C IF (IPCHE1.NE.0.AND.MOCARA.NE.0) THEN CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYCA,1,INFOS,3,IVACAR) IF (IERR.NE.0) GOTO 9991 C IF (ISUP.EQ.1) THEN CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE) IF(IERR.NE.0)THEN ISUP=0 GOTO 9991 ENDIF ENDIF ENDIF C* Voir si cette partie de tests ne pourrait etre mise lors de la C* construction de MOCARA (composante facultative/obligatoire) ! IF (IVACAR.EQ.0) THEN * * AM 11/06/16 VERIFICATION DE LA PRESENCE DES CARACTERTISTIQUES * POUR LES ELEMENTS TYPE POUTRE ET ASSIMILES * NECESSAIRE AUSSI EN CAS DE MATRICE DE HOOKE IF(MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.84 & .OR.MELE.EQ.97) THEN CALL ERREUR (404) GO TO 9991 ENDIF IF(MFR.EQ.75.AND.IMAT.EQ.2) THEN CALL ERREUR (404) GO TO 9991 ENDIF ENDIF MPTVAL = IVACAR C cas particuliers des XFEM IF (MFR.EQ.63) GOTO 63 C=DEB==== FORMULATION HHO ==== Cas particulier de la formulation ======= IF (MFR.EQ.HHO_MFR_ELEMENT) GOTO 89 C=FIN==== FORMULATION HHO ============================================== C NAVIER_STOKES NLIN if (cmate.eq.'NLIN') then segact mmode1*mod mmode1.kmodel(1) = imodel mchel1.conche(1) = conm mchel1.imache(1) = ipmail mptval = ivamat nomid = momatr do jj = 1,n2 mcham1.nomche(jj) = lesobl(jj) mcham1.typche(jj) = tyval(jj) mcham1.ielval(jj) = ival(jj) enddo ipmons = mmode1 ipchns = mchel1 if (noerjk.eq.2) then call go2nli(ipmons,ipchns,iprins,3) else call go2nli(ipmons,ipchns,iprins,1) endif if (ierr.ne.0) return goto 2999 endif C----------------------------------------------------------------------- C P H A S E 2 C C PREPARATION DES OBJETS RESULTATS C C----------------------------------------------------------------------- C 2999 if (cmate.eq.'NLIN') then RI3 = iprins segact ri3 if (ri3.coerig(/1).ne.nrnlin) then c write(6,*) 'ri3',ri3.coerig(/1),nrnlin call erreur(5) return endif isou = isou - 1 do kige = 1,nrnlin ipdesc = ri3.IRIGEL(3,kige) ipmatr = ri3.IRIGEL(4,kige) isymm = ri3.irigel(7,kige) isou = isou + 1 jrige = isou COERIG(jrige) = ri3.coerig(kige) IRIGEL(1,jrige) = ipmail IRIGEL(2,jrige) = 0 IRIGEL(3,jrige) = ipdesc IRIGEL(4,jrige) = ipmatr IRIGEL(5,jrige) = NIFOUR IRIGEL(6,jrige) = 0 IRIGEL(7,jrige) = ri3.irigel(7,kige) IRIGEL(8,jrige) = 0 enddo else C C INITIALISATION DU SEGMENT XMATRI C NELRIG = NBELEM rigrel=0 SEGINI XMATRI IPMATR=XMATRI IRIGEL(1,ISOU)=IPMADG IRIGEL(2,ISOU)=0 IRIGEL(3,ISOU)=IPDSCR IRIGEL(4,ISOU)=IPMATR IRIGEL(5,ISOU)=NIFOUR IRIGEL(6,ISOU)=0 IRIGEL(7,ISOU)=0 xmatri.symre=0 IF(MFR.EQ.57.OR.MFR.EQ.59) THEN IRIGEL(7,ISOU)=2 ENDIF COERIG(ISOU)=1.D0 C SEGDES XMATRI endif C C rendement anisotrope kich if(ivacar.ne.0) then mptval = ivacar if(ival(/1).ge.NCAR1+9) then if (ival(NCAR1+7).gt.0.or.ival(NCAR1+8).gt.0.or. & ival(NCAR1+9).gt.0) then irigel(7,isou)=2 xmatri.symre=2 endif endif endif if (dcmate) goto 29 C C----------------------------------------------------------------------- C P H A S E 3 C C CALCUL DES RIGIDITES ELEMENTAIRES C C----------------------------------------------------------------------- C C NUMERO DES ETIQUETTES : C Les elements sont groupes comme suit : C - massif,liquide 'surface libre' poreux ----------------------> r C - coq3,dkt,coq4,coq8,coq2,dst --------------------------------> r C - poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,jot3> r C - joi4,joi2,poutre de timoschenko,joi3 C IF(MELE.GE.1.AND.MELE.LE.100) THEN C CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 GOTO ( 99, 99, 99, 4, 99, 4, 99, 4, 99, 4 C QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 . , 99, 12, 99, 4, 4, 4, 4, 12, 12, 99 C LIA8 MULT TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP . , 99, 99, 4, 4, 4, 4, 27, 27, 29, 29 C FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 . , 99, 99, 99, 99, 4, 4, 4, 4, 4, 4 C COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM . , 27, 29, 29, 27, 29, 29, 12, 4, 27, 29 C COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6 . , 99, 99, 4, 4, 12, 27, 99, 99, 99, 99 C CVQ4 CVQ8 THP5 TH13 THP6 TH15 THC8 TH20 ICT3 ICQ4 . , 99, 99, 99, 99, 99, 99, 99, 99, 4, 4 C ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 IC15 TRIP QUAP . , 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 C CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8 . , 4, 4, 4, 29, 29, 29, 29, 29, 99, 99 C LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4 . , 99, 29, 27, 12, 29, 29, 29, 29, 99, 99) c cccccc . ,MELE ELSEIF(MELE.GE.101.AND.MELE.LE.200) THEN C HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 GOTO ( 99, 99, 99, 99, 99, 99, 99, 4, 4, 4 C POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 . , 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 C PO13 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 . , 4, 4, 29, 29, 29, 29, 29, 99, 99, 99 C QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 . , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 C MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 . , 99, 99, 99, 505, 505, 99, 99, 99, 99, 99 C TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5 . , 99, 99, 99, 99, 99, 99, 29, 51, 51, 51 C BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2 . , 51, 51, 51, 51, 51, 51, 51, 29, 29, 29 C JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR . , 29, 29, 4, 4, 4, 4, 4, 4, 4, 4 C TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8 . , 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 C T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15 . , 51, 51, 4, 4, 51, 51, 51, 51, 51, 51) c cccccc . ,MELE-100 ELSEIF(MELE.GE.201.AND.MELE.LE.300) THEN C LC19 LS03 LS07 LS09 LS27 LS21 LS15 LS19 BS03 BS07 GOTO ( 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 C BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21 . , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 C MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03 . , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 C MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27 . , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 C QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119 . , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 C QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8 . , 51, 51, 51, 51, 51, 51, 51, 29, 51, 29 C CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3 . , 51, 51, 63, 63, 29, 29, 29, 29, 51, 51 C COS2 COA2 CU27 PR21 TE15 PY19 C20R P15R . , 29, 29, 4, 4, 4, 4, 4, 4, 4, 4) c cccccc . ,MELE-200 ENDIF C cccccc C 51 CONTINUE 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(9:12)='RIGI1' CALL ERREUR(86) GOTO 9990 C_______________________________________________________________________ C C massif, liquide, 'surface libre', poreux C_______________________________________________________________________ C 4 CONTINUE IF (MFR .EQ. 71) THEN CALL RIGELE (MATE,MELE,NBPGAU,NSTRS,LRE,IPMAIL,IPMINT,IVAMAT, & NMATT, IPMATR) ELSE IF (MFR .EQ. 73) THEN CALL RIGDIF (MATE,MELE,NBPGAU,NSTRS,LRE,IPMAIL,IPMINT,IVAMAT, & NMATT, IPMATR) ELSE CALL RIGI2 (MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,IVAMAT, & IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT, & IPORE,NDDL,IPMATR,IIPDPG,NCAR1,MELPHA,noer) ENDIF GOTO 9990 C_______________________________________________________________________ C C ELTS DE RACCORD LIQUIDE SOLIDE RAC2 RACO LIA3 LIA4 LICO LIC4 C PAS DE RIGIDITE C_______________________________________________________________________ C 12 CONTINUE C GOTO 9990 C_______________________________________________________________________ C C coq2,coq3,coq4,coq6,coq8,dst,dkt C_______________________________________________________________________ C 27 CONTINUE CALL RIGI3(MATE,MELE,IPMAIL,IPMINT,IPMIN1,NBPGAU,LRE,NSTRS, & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK, & NMATT,LW,NPINT,IPMATR,IIPDPG) GOTO 9990 C_______________________________________________________________________ C C poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,joints 2-3D C poutre de Timoschenko,point,joi1,zco2,zco3,zco4 C_______________________________________________________________________ C 29 CONTINUE CALL RIGI4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS, & IVAMAT,IVACAR,IVECT,CMATE,MFR,NBGMAT,NELMAT,IMAT, & LHOOK,NMATT,(NCAR1 - 1),ISOUS,LW,IPORE,IPMATR,IIPDPG) GOTO 9990 C_______________________________________________________________________ C C Elements de type XFEM (MFR=63) C_______________________________________________________________________ C Le sous programme RIGIXR gere les appels aux elements de type XFEM C (imoxfem est le modele complet ou partitionne si necessaire) C as 2009/11/30 : ajout de IMAT,NBGMAT,NELMAT en entree de RIGIXR C Attention : ISOU peut etre modifie suite a appel a RIGIXR, ainsi que C la dimension de MRIGID en parallele ! C 63 CONTINUE CALL RIGIXR (ISOU ,IPOI6,imoxfem,IPINF, $ IVAMAT,IVACAR,NMATT,CMATE,NCAR1,NBGMAT,NELMAT,IMAT,IRETER) IF (IRETER.NE.0) RETURN GO TO 9991 C=DEB==== FORMULATION HHO ==== Calcul des matrices de RIGIDITE ========= 89 CONTINUE CALL HHORIG (imohho, IPOI6, ISOU, IPDSCR, & MATE,IVAMAT,NMATR, IVACAR,NCAR1, iret) IF (iret.NE.0) THEN CALL ERREUR(iret) RETURN END IF GOTO 9991 C=FIN==== FORMULATION HHO ============================================== C C----------------------------------------------------------------------- C P H A S E 4 C C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA C C----------------------------------------------------------------------- C 9990 CONTINUE if (noer.eq.195) return if (ierr.ne.0) return C Forcer la symetrie lorsque les matrices sont symetriques ID1=RE(/1) ID2=RE(/2) ID3=RE(/3) ISY=SYMRE CALL VERSYM(RE,ID1,ID2,ID3,ISY) SEGDES,XMATRI 9991 CONTINUE IF (IERR.NE.0) GOTO 518 505 CONTINUE C 518 CONTINUE IF(ISUP.EQ.1)THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF C if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') goto 519 IF(ISUP.EQ.1.AND.IMAT.NE.2)THEN CALL DTMVAL(IVAMAT,3) ELSE CALL DTMVAL(IVAMAT,1) ENDIF 519 continue IF (MOCARA.NE.0) THEN nomid=MOCARA SEGSUP,nomid ENDIF notype = MOTYCA IF (notype .NE. MOTYR8) SEGSUP,notype C IF (MOMATR.NE.0)THEN nomid = MOMATR IF (lsupma) SEGSUP,nomid ENDIF notype = MOTYMA IF (notype .NE. MOTYR8) SEGSUP,notype C C DANS LE CAS D'ERREUR C IF (IERR.NE.0) THEN IF (IPDSCR.NE.0) THEN DESCR = IPDSCR SEGSUP,DESCR ENDIF IF (xMATRI.NE.0) SEGSUP xMATRI GOTO 888 ENDIF 500 CONTINUE if (isou.NE.irigel(/2)) then nrigel=isou segadj,MRIGID endif Ctermes 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,2) if (nstat.gt.0) then do kstat=1,nstat mptval = ivstat(kstat) 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) IF(ISUP.EQ.1)THEN CALL DTMVAL(mptval,3) ELSE CALL DTMVAL(mptval,1) ENDIF enddo endif endif if (nstat.gt.0.and.nstat+nmoda.gt.1) then ir1 = mrigid call fusrig(ir1,ir2,ir3) if (ierr.ne.0) goto 888 mrigid = ir3 ipoi6 = mrigid endif 888 CONTINUE MRIGID = IPOI6 IF (IERR.NE.0) THEN SEGSUP,MRIGID IPOI6 = 0 IRET = 0 ELSE SEGDES,MRIGID IRET = 1 ENDIF segsup modsta segsup mmode1 if (mchel1.ne.0) then mcham1 = mchel1.ichaml(1) segsup mcham1 segsup mchel1 endif notype = MOTYR8 SEGSUP,notype 889 CONTINUE c return END