C AMOR1 SOURCE PV090527 26/04/30 21:15:03 12529 SUBROUTINE AMOR1(MODORI,IPCHE1,ICAS,IPRIG) *---------------------------------------------------------------------* * * * OPERATEUR AMORTISSEMENT VISQUEUX * * * *---------------------------------------------------------------------* * * * CE SOUS-PROGRAMME SERT A TRAITER ET A METTRE EN FORME * * LES INFORMATIONS NECESSAIRES POUR LES CALCULS * * * *---------------------------------------------------------------------* * * * ENTREES : * * ________ * * * * IPMODL Pointeur sur le modele * * IPCHE1 Pointeur sur le chamelem de carateristiques * * ICAS 1 si matrice d amortissement * * 2 si matrice de rigidite antisymetrique * * 3 si matrice d amortissement en frequentiel * * (amortissement corotatif) * * * * SORTIES : * * ________ * * * * IPRIG pointeur sur la rigidite construite * * =0 en cas d'erreur (et IERR non nul) * * * *---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC CCGEOME -INC CCREEL -INC SMCHAML -INC SMINTE -INC SMELEME -INC SMRIGID -INC SMMODEL -INC SMCOORD -INC SMLREEL -INC TMPTVAL INTEGER oooval SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT segment modsta integer pimoda(nmoda),pistat(nstat) integer ivmoda(nmoda),ivstat(nstat) endsegment CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM PARAMETER ( INTTYP=3 ) * INTTYP DEFINIT LE TYPE DE POINTS D'INTEGRATION * UTILISE PAR RIGI PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) LOGICAL BDPGE,brend,dcmate,dcmat2 iimpi0 = IIMPI IPRIG = 0 * ACTIVATION DU MODELE * -------------------- * MODORI = Modele initial complet * IPMODL = Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX") CALL PIMODL(MODORI,IPMODL,MAILDG,0) IF (IPMODL.EQ.0) RETURN * * VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES * ZZZZZZZZ PEUT ETRE A FAIRE PLUTOT SUR LES SOUS-ZONES * ISUP1 = 0 CALL QUESUP(IPMODL,IPCHE1,INTTYP,0,ISUP1,IRET1) IF (ISUP1.GT.1) RETURN * ISUPM = ISUP1 ISUPC = ISUP1 IPCHE2 = 0 * IPMODL est ACTIF en retour : MMODEL = IPMODL NSOUS = mmodel.KMODEL(/1) * INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE * --------------------------------------------- JRIGE = 0 NRIGEL = 0 SEGINI MRIGID mrigid.MTYMAT = 'AMORTISS' mrigid.IFORIG = IFOUR mrigid.ICHOLE = 0 mrigid.IMGEO1 = 0 mrigid.IMGEO2 = 0 mrigid.ISUPEQ = 0 * termes croises STATIQUE et/ou MODAL nstat = 100 kstat = 0 nmoda = 100 kmoda = 0 segini modsta c Un petit segment utile NBTYPE = 1 SEGINI,NOTYPE notype.TYPE(1) = 'REAL*8' MOTYR8 = notype *--------------------------------------------------------------------* * * BOUCLE SUR LES ZONES ELEMENTAIRES ( MEME TYPE D'EF ) * *--------------------------------------------------------------------* * DO 500 ISOMO=1,NSOUS IMODEL = mmodel.KMODEL(ISOMO) c* LIAISON : filtre par pimodl donc test inutile ? IF (FORMOD(1).EQ.'LIAISON') then write(ioimp,*) 'AMOR1.eso' call erreur(5) endif * * INITIALISATIONS * IPMINT = 0 IPMIN1 = 0 MOMATR = 0 MOTYPM = MOTYR8 MOCARA = 0 MOTYPC = MOTYR8 MODEPL = 0 MOFORC = 0 IDESCR = 0 C- Recuperation d'informations sur le maillage elementaire IPMAIL = imodel.IMAMOD CONM = imodel.CONMOD IPT1 = IPMAIL NBNOE1 = IPT1.NUM(/1) NBELE1 = IPT1.NUM(/2) CMATE = CMATEE MATE = IMATEE INAT = INATUU 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 IRTD = 1 CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2, INFOS,IRTD) IF (IRTD.EQ.0) GOTO 5991 C- Recuperation d'informations sur l'element fini MELE = NEFMOD C Cas particulier : POI1/SEG2 et IMPEDANCE IF (dcmate) THEN IF (ipt1.itypel.EQ.1) MELE = 45 IF (ipt1.itypel.EQ.2) MELE = 2 ENDIF if (infmod(/1).lt.2+inttyp) then write(ioimp,*) 'AMOR1 : infmod(/1) < ',2+inttyp,imodel call erreur(5) endif C COQUE INTEGREE OU PAS ? NPINT = INFMOD(1) LHOOK = INFELE(10) NSTRS = INFELE(16) MFR = INFELE(13) LW = INFELE( 7) LRE = INFELE( 9) NDDL = INFELE(15) IELE = INFELE(14) IPORE = INFELE( 8) IPMINT= INFMOD(2+INTTYP) IPMIN1= INFMOD(3) NBPGAU= INFELE( 6) IIPDPG = imodel.IPDPGE IIPDPG = IPTPOI(IIPDPG) C- Cas particulier en DEFO PLAN GENE CALL INFDPG(MFR,IFOUR, BDPGE,NDPGE) IF (BDPGE) THEN IF (IIPDPG.LE.0) THEN CALL ERREUR(925) GOTO 5991 ENDIF if (maildg.eq.0) then write(ioimp,*) 'PRECO PIMODL maildg =0 !' CALL ERREUR(925) GOTO 5991 endif ipt2 = maildg ipmaig = ipt2.lisous(isomo) meleme = ipmaig NBNOEG = meleme.num(/1) NBELEG = meleme.num(/2) ELSE ipmaig = IPMAIL ENDIF IPPORE=0 IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN IPPORE=NBNNE(NUMGEO(MELE)) ENDIF MINTE = IPMINT C- RECHERCHE DES NOMS D'INCONNUES ET DES DUAUX MODEPL = lnomid(1) if (modepl.eq.0) then write(ioimp,*) 'AMOR1 : modepl=lnomid(1)=0',imodel call erreur(5) endif nomid = MODEPL ndepl = lesobl(/2) c* ndum = lesfac(/2) MOFORC = lnomid(2) if (moforc.eq.0) then write(ioimp,*) 'AMOR1 : moforc=lnomid(2)=0',imodel call erreur(5) endif nomid = MOFORC nforc = lesobl(/2) c* ndum = lesfac(/2) IF (ndepl.EQ.0.OR.nforc.EQ.0.OR.ndepl.NE.nforc) THEN CALL ERREUR(5) GOTO 598 ENDIF * * REMPLISSAGE DU SEGMENT DESCRIPTEUR * NCOMP = NDEPL NBNNS = NBNOE1 NBNN = NBNOE1 *PV idecap pas defini ** IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN ** NCOMP = NDEPL-IDECAP ** ENDIF IF (BDPGE) THEN NCOMP = NDEPL - NDPGE NBNN = NBNOE1 + 1 ENDIF IF (MFR.EQ.19.OR.MFR.EQ.21) THEN NBNNS = NBNN / 2 ENDIF NFAC = NBNNS IF (MELE.GE.108.AND.MELE.LE.110) & NFAC = MIN(NFAC,(3*NBNN-IPORE)/2) NLIGRP = LRE NLIGRD = LRE * erreur dans les dimensions de DESCR * le mode de calcul n'est pas correct IF (NBNNS*NCOMP .GT. NLIGRD) THEN CALL ERREUR(717) GOTO 598 ENDIF SEGINI,DESCR IDDL = 1 DO INOEUD = 1, NFAC DO ICOMP = 1, NCOMP NOMID=MODEPL LISINC(IDDL)=LESOBL(ICOMP) if (dcmat2) then if (inoeud.eq.2) then LISINC(IDDL)=LESFAC(ICOMP) endif endif NOMID=MOFORC LISDUA(IDDL)=LESOBL(ICOMP) if (dcmat2) then if (inoeud.eq.2) then LISDUA(IDDL)=LESFAC(ICOMP) endif endif NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 ENDDO ENDDO * CAS DES ELEMENT RACCORD 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) DO INOEUD=NBNNS+1,NBNN DO ICOMP=1,NDEPL NOMID=MODPL LISINC(IDDL)=LESOBL(ICOMP) NOMID=MOFRC LISDUA(IDDL)=LESOBL(ICOMP) NOELEP(IDDL)=INOEUD NOELED(IDDL)=INOEUD IDDL=IDDL+1 ENDDO ENDDO NOMID=MODPL SEGSUP,NOMID NOMID=MOFRC SEGSUP,NOMID ENDIF SEGDES,DESCR IDESCR = DESCR * * TRAITEMENT DES CHAMPS EN ENTREE * ------------------------------- * NBROBL = 0 NBRFAC = 0 NOMID = 0 c* Sauf cas particulier, les composantes sont de type 'REAL*8' NOTYPE = MOTYR8 * * >>> CHAMP DE MATERIAU * C* IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN IF (FORMOD(1).EQ.'MECANIQUE'.AND.MATE.EQ.1.AND..NOT.dcmate) THEN IF (MFR.EQ.35) 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)='VISQ' LESOBL(2)='NU ' ENDIF C* ELSE IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'UNIDIREC') THEN ELSE IF (FORMOD(1).EQ.'MECANIQUE'.AND.MATE.EQ.4) THEN IF (MFR.EQ.1.AND.IDIM.EQ.3) THEN NBROBL=7 SEGINI NOMID LESOBL(1)='VISQ' 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)='VISQ' LESOBL(2)='V1X ' LESOBL(3)='V1Y ' ENDIF C* ELSE IF (INAT.EQ.67.AND.CMATE.EQ.'ORTHOTRO') THEN ELSEIF(INAT.EQ.67.AND. MATE.EQ.2) THEN NBROBL=6 SEGINI NOMID LESOBL(1)='YG1 ' LESOBL(2)='YG2 ' LESOBL(3)='NU12' LESOBL(4)='G12 ' LESOBL(5)='V1X ' LESOBL(6)='V1Y ' C C MODELE ET MATERIAU DE LA SECTION DU MODELE A FIBRE C C* ELSEIF (CMATE.EQ.'SECTION') THEN ELSE IF (MATE.EQ.11) THEN NBROBL=2 SEGINI NOMID LESOBL(1)='MODS' LESOBL(2)='MATS' NBTYPE=2 SEGINI NOTYPE TYPE(1)='POINTEURMMODEL' TYPE(2)='POINTEURMCHAML' C ELSEIF (CMATE.EQ.'MODAL') THEN NBROBL=3 NBRFAC=1 SEGINI NOMID LESOBL(1)='FREQ' LESOBL(2)='MASS' LESOBL(3)='DEFO' LESFAC(1) ='AMOR' NBTYPE=4 SEGINI NOTYPE TYPE(1)='REAL*8' TYPE(2)='REAL*8' TYPE(3)='POINTEURCHPOINT' TYPE(4)='REAL*8' ELSEIF (CMATE.EQ.'STATIQUE') THEN NBROBL=3 NBRFAC=1 SEGINI NOMID LESOBL(1)='DEFO' LESOBL(2)='RIDE' LESOBL(3)='MADE' LESFAC(1) ='AMOR' NBTYPE=4 SEGINI NOTYPE TYPE(1)='POINTEURCHPOINT' TYPE(2)='POINTEURCHPOINT' TYPE(3)='POINTEURCHPOINT' TYPE(4)='REAL*8' ELSE IF (dcmate) THEN * * IMPEDANCE COMPLEXE IF (CMATE.EQ.'IMPCOMPL') THEN NBRFAC=1 SEGINI NOMID LESFAC(1)='VISC' ELSE NBRFAC=2 SEGINI NOMID LESFAC(1) ='AMOR' LESFAC(2) ='AROT' ENDIF ELSE C* CALL IDMATR(MFR,IMODEL,NOMID,NBROBL,NBRFAC) ENDIF NMATR = NBROBL NMATF = NBRFAC NMATT = NMATR+NMATF MOMATR = NOMID MOTYPM = NOTYPE * * >>> CHAMPS DE CARACTERISTIQUES * NBROBL = 0 NBRFAC = 0 NOMID = 0 c* Sauf cas particulier, les composantes sont de type 'REAL*8' NOTYPE = MOTYR8 IVECT = 0 * * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES * IF ((MFR.EQ.1.OR.MFR.EQ.31.OR. + ((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' * * 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 LESOBL(1)='EPAI' LESFAC(1)='EXCE' IF(MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3' * * SECTION POUR LES BARRES ET LES CERCES * ELSE IF (MFR.EQ.27) THEN IF(.NOT.dcmate) THEN NBROBL=1 SEGINI NOMID LESOBL(1)='SECT' ENDIF * * 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 ' * CARACTERISTIQUES POUR LES POUTRES * ELSE IF (MFR.EQ.7 ) THEN if (dcmate) then NBROBL=0 NBRFAC=3 SEGINI NOMID LESFAC(1)='VX' LESFAC(2)='VY' LESFAC(3)='VZ' IVECT=1 else C MODELE A FIBRE C* IF (CMATE.EQ.'SECTION') THEN IF (MATE.EQ.11) THEN IF (ICAS.EQ.2) THEN NBRFAC=4 SEGINI NOMID LESFAC(1)='OMEG' LESFAC(2)='VX' LESFAC(3)='VY' LESFAC(4)='VZ' IVECT=1 ELSE NBRFAC=3 SEGINI NOMID LESFAC(1)='VX' LESFAC(2)='VY' LESFAC(3)='VZ' IVECT=1 ENDIF * * POUTRE STANDARD * CAS 2D ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN NBROBL=2 NBRFAC=1 SEGINI NOMID LESOBL(1)= 'SECT' LESOBL(2)= 'INRZ' LESFAC(1)= 'SECY' * CAS 3D ELSE * * AMORTISSEMENT COROTATIF * IF (ICAS.EQ.2) THEN NBROBL=4 NBRFAC=6 SEGINI NOMID LESOBL(1)='TORS' LESOBL(2)='INRY' LESOBL(3)='INRZ' LESOBL(4)='SECT' LESFAC(1)='SECY' LESFAC(2)='SECZ' LESFAC(3)='OMEG' LESFAC(4)='VX' LESFAC(5)='VY' LESFAC(6)='VZ' IVECT=1 ELSE * * AMORTISSEMENT STANDARD * 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 endif * * CARACTERISTIQUES POUR LES TUYAUX * ELSE IF (MFR.EQ.13) THEN IF (ICAS.EQ.2) THEN NBROBL=2 NBRFAC=7 SEGINI NOMID LESOBL(1)='EPAI' LESOBL(2)='RAYO' LESFAC(1)='RACO' LESFAC(2)='PRES' LESFAC(3)='CISA' LESFAC(4)='OMEG' LESFAC(5)='VX' LESFAC(6)='VY' LESFAC(7)='VZ' IVECT=1 ELSE 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 ENDIF * ELSE IF (MFR.EQ.39) THEN IF (ICAS.EQ.2) THEN NBROBL=2 NBRFAC=6 SEGINI NOMID LESOBL(1)='EPAI' LESOBL(2)='RAYO' LESFAC(1)='RACO' LESFAC(2)='PRES' LESFAC(3)='OMEG' LESFAC(4)='VX' LESFAC(5)='VY' LESFAC(6)='VZ' IVECT=1 ELSE 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 ENDIF ENDIF * Rendement : * Notion non utilisee actuellement (mais conserver a titre historique !) IF (NOMID.LE.0) THEN NBROBL = 0 NBRFAC = 0 SEGINI,NOMID ENDIF ifac = NBRFAC ncar1 = NBROBL + NBRFAC + 1 NBRFAC = NBRFAC + 10 SEGADJ,NOMID 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' IF (notype.ne.MOTYR8) THEN NBTYPE = NBTYPE + 1 SEGADJ,NOTYPE TYPE(NBTYPE) = 'REAL*8' ENDIF NCARA = NBROBL NCARF = NBRFAC NCARR = NCARA+NCARF MOCARA = NOMID MOTYPC = NOTYPE C- Partionnement si necessaire de la matrice d'amortissement C- determinant ainsi le nombre d'objets elementaires de MRIGID LTRK = oooval(1,4) IF (LTRK.EQ.0) LTRK = oooval(1,1) LTRK=MAX(LTRK,2**24) * 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 meleme = IPT1 ipt3 = ipmaig nbnn = NBNOE1 nbelem = NBELE1 nbsous = 0 nbref = 0 * ************************************************************************ * P H A S E 2 * * Boucle sur les PARTITIONS elementaires de la matrice * ************************************************************************ isous = 0 DO irige = 1, NBLPRT IF (NBLPRT.GT.1) THEN C- Partitionnement du maillage support de la matrice elementaire ielem = (irige-1)*NBLMAX nbnn = NBNOE1 nbelem = MIN(NBLMAX,NBELE1-ielem) * write(ioimp,*) ' creation segment ',nbnn,nbelem SEGINI,meleme itypel = IPT1.itypel DO ielt = 1, nbelem jelt = ielt + ielem DO inoe = 1, nbnn num(inoe,ielt) = IPT1.NUM(inoe,jelt) ENDDO icolor(ielt) = IPT1.ICOLOR(jelt) ENDDO IF (BDPGE) THEN IPT2 = ipmaig nbnn = NBNOEG cc nbelem = MIN(NBLMAX,NBELEG-ielem) SEGINI,ipt3 ipt3.itypel = 28 DO ielt = 1, nbelem jelt = ielt + ielem DO inoe = 1, nbnn ipt3.num(inoe,ielt) = IPT2.NUM(inoe,jelt) ENDDO ipt3.icolor(ielt) = IPT2.ICOLOR(jelt) ENDDO SEGDES,IPT3 nbnn = NBNOE1 ELSE ipt3 = meleme ENDIF ENDIF ipmail = meleme ipdesc = IDESCR ipmadg = ipt3 C- Initialisation de la matrice de rigidite elementaire (xmatri) NELRIG = nbelem rigrel=0 SEGINI,xmatri ipmatr = xmatri C- Recuperation des valeurs des proprietes materiau et geometriques IVAMAT = 0 IVACAR = 0 brend = .FALSE. CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1,INFOS,3,IVAMAT) IF (IERR.NE.0) GOTO 597 IF (ISUPM.EQ.1) THEN CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE) IF (IERR.NE.0) THEN ISUPM = 0 GOTO 597 ENDIF ENDIF MPTVAL = IVAMAT if (cmate.eq.'STATIQUE'.or.cmate.eq.'MODAL') then if (ival(/1).lt.3) call erreur(5) 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 if (ival(4).eq.0) goto 598 endif NBGMAT = 0 NELMAT = 0 C* IF (CMATE.EQ.'SECTION') THEN IF (MATE.EQ.11) THEN DO i = 1,NMATT MELVAL = IVAL(i) IF (MELVAL.NE.0) THEN NBGMAT = MAX(NBGMAT,IELCHE(/1)) NELMAT = MAX(NELMAT,IELCHE(/2)) ENDIF ENDDO ELSE DO i = 1,NMATT MELVAL = IVAL(i) IF (MELVAL.NE.0) THEN NBGMAT = MAX(NBGMAT,VELCHE(/1)) NELMAT = MAX(NELMAT,VELCHE(/2)) ENDIF ENDDO ENDIF IF (MOCARA.NE.0) THEN CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1, & INFOS,3,IVACAR) IF (IERR.NE.0) GOTO 597 IF (ISUPC.EQ.1) THEN CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE) IF (IERR.NE.0) THEN ISUPC = 0 GOTO 597 ENDIF ENDIF * Rendement : mptval = IVACAR IF (ival(/1).GE.ncar1+9) THEN brend = ival(ncar1+7).GT.0 .OR. ival(ncar1+8).GT.0 .OR. & ival(ncar1+9).GT.0 ENDIF ENDIF isous = isous + 1 imod = imodel if (dcmate.and.mele.eq.2) goto 29 ************************************************************************ * P H A S E 3 * * CALCUL DES RIGIDITES ELEMENTAIRES * ************************************************************************ * * NUMERO DES ETIQUETTES : * Les elements sont groupes comme suit : * - massif,liquide 'surface libre' poreux ----------------------> r * - coq3,dkt,coq4,coq8,coq2,dst --------------------------------> r * - poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,jot3> r * - joi4,joi2,poutre de timoschenko,joi3 * * 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 & , 99, 99, 4 , 4, 4, 4, 99, 99, 99, 99, 99 * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6 & , 4, 4, 4, 4, 27, 27, 29, 29, 99, 99, 99 * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 & , 99, 4, 4, 4, 4, 4, 4, 27, 29, 29, 27 * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO & , 29, 29, 99, 4, 27, 99, 99, 99, 4, 4, 99 * 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, 29, 29, 29, 29, 29 * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 & , 99, 99, 99, 29, 27, 99, 29, 29, 29, 29, 99 * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8 & , 99, 29, 29, 29, 99, 99, 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, 99),MELE C C CASE OF THE NEW JOINT ELEMENTS (JCT3 AND JCI4 IN 2D SHEAR) C (JGI2 2D GENERALIZED) C (JGT3 AND JGI4 GENERALIZED) IF (MELE.GE.168.AND.MELE.LE.172)GOTO 29 IF (MELE.GE.173.OR.MELE.LE.184) GO TO 4 C 99 CONTINUE MOTERR(1:4) = NOMTP(MELE) MOTERR(9:12)= 'AMOR1' CALL ERREUR(86) GOTO 510 C_______________________________________________________________________ C C massif C_______________________________________________________________________ C 4 CONTINUE IF (ICAS.EQ.2) GOTO 99 CALL AMOR2 (MATE,MELE,ipmail,IPMINT,NBPGAU,LRE,NSTRS,IVAMAT, & IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK,NMATT, & IPORE,NDDL,IPMATR,IIPDPG,ncar1) GOTO 510 C_______________________________________________________________________ C C coq3,dkt,coq4,coq8,coq2,dst C_______________________________________________________________________ C 27 CONTINUE IF (ICAS.EQ.2) GOTO 99 CALL RIGI3(MATE,MELE,ipmail,IPMINT,IPMIN1,NBPGAU,LRE,NSTRS, & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK, & NMATT,LW,NPINT,IPMATR,IIPDPG) GOTO 510 C_______________________________________________________________________ C C poutre,tuyau,linespring,tuyau fissure,barre,joints 2-3D C poutre de Timoschenko,point C_______________________________________________________________________ C 29 CONTINUE n_z = ncar1 - 1 CALL AMOR4(MATE,MELE,ipmail,IPMINT,NBPGAU,LRE,NSTRS, & IVAMAT,IVACAR,IVECT,CMATE,MFR,ICAS,NBGMAT,NELMAT, & LHOOK,NMATT,n_z,ISOUS,LW,IPORE,IPMATR,IIPDPG,IMOD) GOTO 510 * ************************************************************************ * P H A S E 4 * * DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA * *********************************************************************** 510 CONTINUE 597 CONTINUE if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') goto 518 IF (ISUPM.EQ.1 .OR. nblprt.GT.1) THEN CALL DTMVAL(IVAMAT,3) ELSE CALL DTMVAL(IVAMAT,1) ENDIF IF (ISUPC.EQ.1 .OR. nblprt.GT.1) THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF c* xmatri = ipmatr 518 continue IF (NBLPRT.GT.1) THEN meleme = ipmail SEGDES,meleme ENDIF C- Sortie prematuree en cas d'erreur IF (IERR.NE.0) GOTO 598 C Ajout de la matrice d'AMORTISSEMENT a la matrice globale C ======================================================== NRIGE0 = IRIGEL(/2) c NRIGEL = NRIGE0 + NBLPRT NRIGEL = NRIGE0 + 1 SEGADJ,MRIGID C- Stockage de la matrice c jrige = NRIGE0 + isous jrige = NRIGE0 + 1 COERIG(jrige) = 1. IRIGEL(1,jrige) = ipmadg IRIGEL(2,jrige) = 0 IRIGEL(3,jrige) = ipdesc IRIGEL(4,jrige) = ipmatr IRIGEL(5,jrige) = NIFOUR IRIGEL(6,jrige) = 0 IF (ICAS.EQ.2) THEN IRIGEL(7,jrige) = 2 xmatri.symre=2 ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN IRIGEL(7,jrige) = 2 xmatri.symre=2 ELSE IF (brend) THEN IRIGEL(7,jrige) = 2 xmatri.symre=2 ELSE IRIGEL(7,jrige) = 0 xmatri.symre=0 ENDIF segdes xmatri IRIGEL(8,jrige) = 0 ENDDO C- Fin de la boucle sur les partitions * 519 continue 598 CONTINUE IF (MOMATR.NE.0) THEN nomid = MOMATR SEGSUP,nomid ENDIF IF (MOTYPM.NE.MOTYR8) THEN notype = MOTYPM SEGSUP,notype ENDIF IF (MOCARA.NE.0) THEN nomid = MOCARA SEGSUP,nomid ENDIF IF (MOTYPC.NE.MOTYR8) THEN notype = MOTYPC SEGSUP,notype ENDIF * * Fin de la boucle (5000) de PARTITIONNEMENT du segment XMATRI 5000 CONTINUE 5991 CONTINUE C EN CAS D'ERREUR IF (IERR.NE.0) GOTO 999 500 CONTINUE C* Fin de la boucle sur les modeles elementaires NRIGEL = jrige segadj mrigid *termes croises 'STATIQUE'/'MODAL' nstat = kstat nmoda = kmoda segadj modsta ir2 = 0 if (nstat.ne.0) then if (nstat.gt.0) call ricroi(modsta, ir2,3) if (nstat.gt.0) then do kstat=1,nstat mptval = ivstat(kstat) segact mptval IF (ISUPM.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 (ISUPM.EQ.1) THEN CALL DTMVAL(mptval,3) ELSE CALL DTMVAL(mptval,1) ENDIF enddo endif endif if (ierr.eq.0.and.ir2.gt.0) then ir1 = mrigid call fusrig(ir1,ir2,ir3) mrigid = ir3 endif 999 CONTINUE IF (IERR.NE.0) THEN SEGSUP,MRIGID IPRIG = 0 ELSE SEGDES,MRIGID IPRIG = MRIGID ENDIF c on desactive IPMODL et MAILDG mmodel = IPMODL c* SEGDES,mmodel meleme = MAILDG c* IF (meleme.NE.0) SEGDES,meleme c on detruit les segments de travail notype = MOTYR8 SEGSUP,notype SEGSUP,modsta c RETURN END