Télécharger la plaquette Cast3M


fr en

Télécharger amor1.eso

Retour à la liste

Numérotation des lignes : 

amor1

  1. C AMOR1     SOURCE    OF166741  25/02/21    21:15:06     12166          
  2.  
  3.       SUBROUTINE AMOR1(MODORI,IPCHE1,ICAS,IPRIG)
  4.  
  5. *---------------------------------------------------------------------*
  6. *                                                                     *
  7. *                      OPERATEUR AMORTISSEMENT VISQUEUX               *
  8. *                                                                     *
  9. *---------------------------------------------------------------------*
  10. *                                                                     *
  11. *       CE SOUS-PROGRAMME SERT A TRAITER ET A METTRE EN FORME         *
  12. *         LES INFORMATIONS NECESSAIRES POUR LES CALCULS               *
  13. *                                                                     *
  14. *---------------------------------------------------------------------*
  15. *                                                                     *
  16. *   ENTREES :                                                         *
  17. *   ________                                                          *
  18. *                                                                     *
  19. *        IPMODL   Pointeur sur le modele                              *
  20. *        IPCHE1   Pointeur sur le chamelem de carateristiques         *
  21. *        ICAS     1 si matrice d amortissement                        *
  22. *                 2 si matrice de rigidite antisymetrique             *
  23. *                 3 si matrice d amortissement en frequentiel         *
  24. *                   (amortissement corotatif)                         *
  25. *                                                                     *
  26. *   SORTIES :                                                         *
  27. *   ________                                                          *
  28. *                                                                     *
  29. *        IPRIG    pointeur sur la rigidite construite                 *
  30. *                 =0 en cas d'erreur (et IERR non nul)                *
  31. *                                                                     *
  32. *---------------------------------------------------------------------*
  33.  
  34.       IMPLICIT INTEGER(I-N)
  35.       IMPLICIT REAL*8(A-H,O-Z)
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC CCHAMP
  40. -INC CCGEOME
  41. -INC CCREEL
  42.  
  43. -INC SMCHAML
  44. -INC SMINTE
  45. -INC SMELEME
  46. -INC SMRIGID
  47. -INC SMMODEL
  48. -INC SMCOORD
  49. -INC SMLREEL
  50.  
  51. -INC TMPTVAL
  52.  
  53.       INTEGER oooval
  54.  
  55.       SEGMENT NOTYPE
  56.         CHARACTER*16 TYPE(NBTYPE)
  57.       ENDSEGMENT
  58.  
  59.       segment modsta
  60.         integer pimoda(nmoda),pistat(nstat)
  61.         integer ivmoda(nmoda),ivstat(nstat)
  62.       endsegment
  63.  
  64.       CHARACTER*8 CMATE
  65.       CHARACTER*(NCONCH) CONM
  66.  
  67.       PARAMETER ( INTTYP=3 )
  68. *                 INTTYP DEFINIT LE TYPE DE POINTS D'INTEGRATION
  69. *                                UTILISE PAR RIGI
  70.       PARAMETER ( NINF=3 )
  71.       INTEGER INFOS(NINF)
  72.  
  73.       LOGICAL BDPGE,brend,dcmate,dcmat2
  74.  
  75.       iimpi0 = IIMPI
  76.  
  77.       IPRIG = 0
  78.  
  79. *               ACTIVATION DU MODELE
  80. *               --------------------
  81. *  MODORI = Modele initial complet
  82. *  IPMODL = Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX")
  83.       CALL PIMODL(MODORI,IPMODL,MAILDG,0)
  84.       IF (IPMODL.EQ.0) RETURN
  85. *
  86. *    VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
  87. *    ZZZZZZZZ  PEUT ETRE A FAIRE PLUTOT SUR LES SOUS-ZONES
  88. *
  89.       ISUP1 = 0
  90.       CALL QUESUP(IPMODL,IPCHE1,INTTYP,0,ISUP1,IRET1)
  91.       IF (ISUP1.GT.1) RETURN
  92. *
  93.       ISUPM = ISUP1
  94.       ISUPC = ISUP1
  95.       IPCHE2 = 0
  96.  
  97. *  IPMODL est ACTIF en retour :
  98.       MMODEL = IPMODL
  99.       NSOUS  = mmodel.KMODEL(/1)
  100.  
  101. *      INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE
  102. *      ---------------------------------------------
  103.       JRIGE = 0
  104.       NRIGEL = 0
  105.       SEGINI MRIGID
  106.       mrigid.MTYMAT = 'AMORTISS'
  107.       mrigid.IFORIG = IFOUR
  108.       mrigid.ICHOLE = 0
  109.       mrigid.IMGEO1 = 0
  110.       mrigid.IMGEO2 = 0
  111.       mrigid.ISUPEQ = 0
  112.  
  113. * termes croises STATIQUE et/ou MODAL
  114.       nstat = 100
  115.       kstat = 0
  116.       nmoda = 100
  117.       kmoda = 0
  118.       segini modsta
  119.  
  120. c Un petit segment utile
  121.       NBTYPE = 1
  122.       SEGINI,NOTYPE
  123.       notype.TYPE(1) = 'REAL*8'
  124.       MOTYR8 = notype
  125.  
  126. *--------------------------------------------------------------------*
  127. *
  128. *       BOUCLE SUR LES ZONES ELEMENTAIRES ( MEME TYPE D'EF )
  129. *
  130. *--------------------------------------------------------------------*
  131. *
  132.       DO 500 ISOMO=1,NSOUS
  133.  
  134.         IMODEL = mmodel.KMODEL(ISOMO)
  135.  
  136. c* LIAISON : filtre par pimodl donc test inutile ?
  137.         IF (FORMOD(1).EQ.'LIAISON') then
  138.           write(ioimp,*) 'AMOR1.eso'
  139.           call erreur(5)
  140.         endif
  141. *
  142. *    INITIALISATIONS
  143. *
  144.         IPMINT = 0
  145.         IPMIN1 = 0
  146.  
  147.         MOMATR = 0
  148.         MOTYPM = MOTYR8
  149.  
  150.         MOCARA = 0
  151.         MOTYPC = MOTYR8
  152.  
  153.         MODEPL = 0
  154.         MOFORC = 0
  155.  
  156.         IDESCR = 0
  157.  
  158. C- Recuperation d'informations sur le maillage elementaire
  159.         IPMAIL = imodel.IMAMOD
  160.         CONM   = imodel.CONMOD
  161.  
  162.         IPT1   = IPMAIL
  163.         NBNOE1 = IPT1.NUM(/1)
  164.         NBELE1 = IPT1.NUM(/2)
  165.  
  166.         CMATE = CMATEE
  167.         MATE  = IMATEE
  168.         INAT  = INATUU
  169.  
  170.         dcmate = .false.
  171.         dcmat2 = .false.
  172.         do im = 1,matmod(/2)
  173.           if (matmod(im).eq.'IMPEDANCE') then
  174.             dcmate =.true.
  175.             if (tymode(/2).gt.0)then
  176.               if (tymode(1).eq.'LISTMOTS') dcmat2 = .true.
  177.             endif
  178.           endif
  179.         enddo
  180.  
  181.         IRTD = 1
  182.         CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2, INFOS,IRTD)
  183.         IF (IRTD.EQ.0) GOTO 5991
  184.  
  185. C- Recuperation d'informations sur l'element fini
  186.         MELE  = NEFMOD
  187. C Cas particulier : POI1/SEG2 et IMPEDANCE
  188.         IF (dcmate) THEN
  189.           IF (ipt1.itypel.EQ.1) MELE = 45
  190.           IF (ipt1.itypel.EQ.2) MELE = 2
  191.         ENDIF
  192.  
  193.         if (infmod(/1).lt.2+inttyp) then
  194.           write(ioimp,*) 'AMOR1 : infmod(/1) < ',2+inttyp,imodel
  195.           call erreur(5)
  196.         endif
  197. C   COQUE INTEGREE OU PAS ?
  198.         NPINT = INFMOD(1)
  199.         LHOOK = INFELE(10)
  200.         NSTRS = INFELE(16)
  201.         MFR   = INFELE(13)
  202.         LW    = INFELE( 7)
  203.         LRE   = INFELE( 9)
  204.         NDDL  = INFELE(15)
  205.         IELE  = INFELE(14)
  206.         IPORE = INFELE( 8)
  207.         IPMINT=INFMOD(2+INTTYP)
  208. c*        IPMIN1= INFMOD(8)
  209.         IPMIN1= INFELE(12)
  210.         NBPGAU= INFELE( 6)
  211.  
  212.         IIPDPG = imodel.IPDPGE
  213.         IIPDPG = IPTPOI(IIPDPG)
  214. C- Cas particulier en DEFO PLAN GENE
  215.         CALL INFDPG(MFR,IFOUR, BDPGE,NDPGE)
  216.         IF (BDPGE) THEN
  217.           IF (IIPDPG.LE.0) THEN
  218.             CALL ERREUR(925)
  219.             GOTO 5991
  220.           ENDIF
  221.           if (maildg.eq.0) then
  222.             write(ioimp,*) 'PRECO PIMODL maildg =0 !'
  223.             CALL ERREUR(925)
  224.             GOTO 5991
  225.           endif
  226.           ipt2 = maildg
  227.           ipmaig = ipt2.lisous(isomo)
  228.           meleme = ipmaig
  229.           NBNOEG = meleme.num(/1)
  230.           NBELEG = meleme.num(/2)
  231.         ELSE
  232.           ipmaig = IPMAIL
  233.         ENDIF
  234.  
  235.         IPPORE=0
  236.         IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59)  THEN
  237.           IPPORE=NBNNE(NUMGEO(MELE))
  238.         ENDIF
  239.  
  240.         MINTE = IPMINT
  241.  
  242. C- RECHERCHE DES NOMS D'INCONNUES ET DES DUAUX
  243.  
  244.         MODEPL = lnomid(1)
  245.         if (modepl.eq.0) then
  246.           write(ioimp,*) 'AMOR1 : modepl=lnomid(1)=0',imodel
  247.           call erreur(5)
  248.         endif
  249.         nomid = MODEPL
  250.         ndepl = lesobl(/2)
  251. c*        ndum  = lesfac(/2)
  252.  
  253.         MOFORC = lnomid(2)
  254.         if (moforc.eq.0) then
  255.           write(ioimp,*) 'AMOR1 : moforc=lnomid(2)=0',imodel
  256.           call erreur(5)
  257.         endif
  258.         nomid = MOFORC
  259.         nforc = lesobl(/2)
  260. c*        ndum  = lesfac(/2)
  261.  
  262.         IF (ndepl.EQ.0.OR.nforc.EQ.0.OR.ndepl.NE.nforc) THEN
  263.           CALL ERREUR(5)
  264.           GOTO 598
  265.         ENDIF
  266. *
  267. *  REMPLISSAGE DU SEGMENT DESCRIPTEUR
  268. *
  269.         NCOMP = NDEPL
  270.         NBNNS = NBNOE1
  271.         NBNN  = NBNOE1
  272. *PV idecap pas defini
  273. **        IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN
  274. **          NCOMP = NDEPL-IDECAP
  275. **        ENDIF
  276.         IF (BDPGE) THEN
  277.           NCOMP = NDEPL - NDPGE
  278.           NBNN  = NBNOE1 + 1
  279.         ENDIF
  280.         IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  281.           NBNNS = NBNN / 2
  282.         ENDIF
  283.  
  284.         NFAC = NBNNS
  285.         IF (MELE.GE.108.AND.MELE.LE.110)
  286.      &    NFAC = MIN(NFAC,(3*NBNN-IPORE)/2)
  287.  
  288.         NLIGRP = LRE
  289.         NLIGRD = LRE
  290. *         erreur dans les dimensions de DESCR
  291. *         le mode de calcul n'est pas correct
  292.         IF (NBNNS*NCOMP .GT. NLIGRD) THEN
  293.           CALL ERREUR(717)
  294.           GOTO 598
  295.         ENDIF
  296.  
  297.         SEGINI,DESCR
  298.  
  299.         IDDL = 1
  300.         DO INOEUD = 1, NFAC
  301.           DO ICOMP = 1, NCOMP
  302.             NOMID=MODEPL
  303.             LISINC(IDDL)=LESOBL(ICOMP)
  304.             if (dcmat2) then
  305.               if (inoeud.eq.2) then
  306.                 LISINC(IDDL)=LESFAC(ICOMP)
  307.               endif
  308.             endif
  309.             NOMID=MOFORC
  310.             LISDUA(IDDL)=LESOBL(ICOMP)
  311.             if (dcmat2) then
  312.               if (inoeud.eq.2) then
  313.                 LISDUA(IDDL)=LESFAC(ICOMP)
  314.               endif
  315.             endif
  316.             NOELEP(IDDL)=INOEUD
  317.             NOELED(IDDL)=INOEUD
  318.             IDDL=IDDL+1
  319.           ENDDO
  320.         ENDDO
  321. *          CAS DES ELEMENT RACCORD
  322.         IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  323.           CALL IDPRIM(IMODEL,MFR+1000,MODPL,NDEPL,NDUM)
  324.           CALL IDDUAL(IMODEL,MFR+1000,MOFRC,NFORC,NDUM)
  325.           DO INOEUD=NBNNS+1,NBNN
  326.             DO ICOMP=1,NDEPL
  327.               NOMID=MODPL
  328.               LISINC(IDDL)=LESOBL(ICOMP)
  329.               NOMID=MOFRC
  330.               LISDUA(IDDL)=LESOBL(ICOMP)
  331.               NOELEP(IDDL)=INOEUD
  332.               NOELED(IDDL)=INOEUD
  333.               IDDL=IDDL+1
  334.             ENDDO
  335.           ENDDO
  336.           NOMID=MODPL
  337.           SEGSUP,NOMID
  338.           NOMID=MOFRC
  339.           SEGSUP,NOMID
  340.         ENDIF
  341.  
  342.         SEGDES,DESCR
  343.         IDESCR = DESCR
  344. *
  345. *       TRAITEMENT DES CHAMPS EN ENTREE
  346. *       -------------------------------
  347. *
  348.         NBROBL = 0
  349.         NBRFAC = 0
  350.         NOMID  = 0
  351. c* Sauf cas particulier, les composantes sont de type 'REAL*8'
  352.         NOTYPE = MOTYR8
  353. *
  354. *   >>>  CHAMP DE MATERIAU
  355. *
  356. C*      IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
  357.         IF (FORMOD(1).EQ.'MECANIQUE'.AND.MATE.EQ.1.AND..NOT.dcmate) THEN
  358.           IF (MFR.EQ.35) THEN
  359.             NBROBL=2
  360.             SEGINI NOMID
  361.             LESOBL(1)='KS  '
  362.             LESOBL(2)='KN  '
  363.           ELSE IF(MFR.EQ.53) THEN
  364.             NBROBL=1
  365.             SEGINI,NOMID
  366.             LESOBL(1)='KS  '
  367.           ELSE
  368.             NBROBL=2
  369.             SEGINI NOMID
  370.             LESOBL(1)='VISQ'
  371.             LESOBL(2)='NU  '
  372.           ENDIF
  373. C*      ELSE IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'UNIDIREC') THEN
  374.         ELSE IF (FORMOD(1).EQ.'MECANIQUE'.AND.MATE.EQ.4) THEN
  375.           IF (MFR.EQ.1.AND.IDIM.EQ.3) THEN
  376.             NBROBL=7
  377.             SEGINI NOMID
  378.             LESOBL(1)='VISQ'
  379.             LESOBL(2)='V1X '
  380.             LESOBL(3)='V1Y '
  381.             LESOBL(4)='V1Z '
  382.             LESOBL(5)='V2X '
  383.             LESOBL(6)='V2Y '
  384.             LESOBL(7)='V2Z '
  385.           ELSE
  386.             NBROBL=3
  387.             SEGINI NOMID
  388.             LESOBL(1)='VISQ'
  389.             LESOBL(2)='V1X '
  390.             LESOBL(3)='V1Y '
  391.           ENDIF
  392. C*      ELSE IF (INAT.EQ.67.AND.CMATE.EQ.'ORTHOTRO') THEN
  393.         ELSEIF(INAT.EQ.67.AND. MATE.EQ.2) THEN
  394.           NBROBL=6
  395.           SEGINI NOMID
  396.           LESOBL(1)='YG1 '
  397.           LESOBL(2)='YG2 '
  398.           LESOBL(3)='NU12'
  399.           LESOBL(4)='G12 '
  400.           LESOBL(5)='V1X '
  401.           LESOBL(6)='V1Y '
  402. C
  403. C      MODELE ET MATERIAU DE LA SECTION DU MODELE A FIBRE
  404. C
  405. C*      ELSEIF (CMATE.EQ.'SECTION') THEN
  406.         ELSE IF (MATE.EQ.11) THEN
  407.           NBROBL=2
  408.           SEGINI NOMID
  409.           LESOBL(1)='MODS'
  410.           LESOBL(2)='MATS'
  411.           NBTYPE=2
  412.           SEGINI NOTYPE
  413.           TYPE(1)='POINTEURMMODEL'
  414.           TYPE(2)='POINTEURMCHAML'
  415. C
  416.         ELSEIF (CMATE.EQ.'MODAL') THEN
  417.           NBROBL=3
  418.           NBRFAC=1
  419.           SEGINI NOMID
  420.           LESOBL(1)='FREQ'
  421.           LESOBL(2)='MASS'
  422.           LESOBL(3)='DEFO'
  423.           LESFAC(1) ='AMOR'
  424.           NBTYPE=4
  425.           SEGINI NOTYPE
  426.           TYPE(1)='REAL*8'
  427.           TYPE(2)='REAL*8'
  428.           TYPE(3)='POINTEURCHPOINT'
  429.           TYPE(4)='REAL*8'
  430.  
  431.         ELSEIF (CMATE.EQ.'STATIQUE') THEN
  432.           NBROBL=3
  433.           NBRFAC=1
  434.           SEGINI NOMID
  435.           LESOBL(1)='DEFO'
  436.           LESOBL(2)='RIDE'
  437.           LESOBL(3)='MADE'
  438.           LESFAC(1) ='AMOR'
  439.           NBTYPE=4
  440.           SEGINI NOTYPE
  441.           TYPE(1)='POINTEURCHPOINT'
  442.           TYPE(2)='POINTEURCHPOINT'
  443.           TYPE(3)='POINTEURCHPOINT'
  444.           TYPE(4)='REAL*8'
  445.  
  446.         ELSE IF (dcmate) THEN
  447. *
  448. * IMPEDANCE COMPLEXE
  449.           IF (CMATE.EQ.'IMPCOMPL') THEN
  450.             NBRFAC=1
  451.             SEGINI NOMID
  452.             LESFAC(1)='VISC'
  453.           ELSE
  454.             NBRFAC=2
  455.             SEGINI NOMID
  456.             LESFAC(1) ='AMOR'
  457.             LESFAC(2) ='AROT'
  458.           ENDIF
  459.         ELSE
  460. C*          CALL IDMATR(MFR,IMODEL,NOMID,NBROBL,NBRFAC)
  461.         ENDIF
  462.  
  463.         NMATR = NBROBL
  464.         NMATF = NBRFAC
  465.         NMATT = NMATR+NMATF
  466.  
  467.         MOMATR = NOMID
  468.         MOTYPM = NOTYPE
  469. *
  470. *   >>>     CHAMPS DE CARACTERISTIQUES
  471. *
  472.         NBROBL = 0
  473.         NBRFAC = 0
  474.         NOMID  = 0
  475. c* Sauf cas particulier, les composantes sont de type 'REAL*8'
  476.         NOTYPE = MOTYR8
  477.         IVECT  = 0
  478. *
  479. * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
  480. *
  481.         IF ((MFR.EQ.1.OR.MFR.EQ.31.OR.
  482.      +      ((MELE.GE.79.AND.MELE.LE.83).OR.
  483.      +      (MELE.GE.173.AND.MELE.LE.182)))
  484.      +      .AND.IFOUR.EQ.-2)THEN
  485.            NBRFAC=1
  486.            SEGINI NOMID
  487.            LESFAC(1)='DIM3'
  488. *
  489. * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  490. *
  491.         ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  492.           NBROBL=1
  493.           IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  494.             NBRFAC=2
  495.           ELSE
  496.             NBRFAC=1
  497.           ENDIF
  498.           SEGINI NOMID
  499.           LESOBL(1)='EPAI'
  500.           LESFAC(1)='EXCE'
  501.           IF(MFR.EQ.3.AND.IFOUR.EQ.-2)  LESFAC(2)='DIM3'
  502. *
  503. * SECTION POUR LES BARRES ET LES CERCES
  504. *
  505.         ELSE IF (MFR.EQ.27) THEN
  506.           IF(.NOT.dcmate)  THEN
  507.             NBROBL=1
  508.             SEGINI NOMID
  509.             LESOBL(1)='SECT'
  510.           ENDIF
  511. *
  512. * section, excentrements et orientation pour les barres excentrees
  513. *
  514.         ELSE IF (MFR.EQ.49) THEN
  515.           NBROBL=6
  516.           SEGINI NOMID
  517.           LESOBL(1)='SECT'
  518.           LESOBL(2)='EXCZ'
  519.           LESOBL(3)='EXCY'
  520.           LESOBL(4)='VX  '
  521.           LESOBL(5)='VY  '
  522.           LESOBL(6)='VZ  '
  523.  
  524. * CARACTERISTIQUES POUR LES POUTRES
  525. *
  526.         ELSE IF (MFR.EQ.7 ) THEN
  527.           if (dcmate) then
  528.             NBROBL=0
  529.             NBRFAC=3
  530.             SEGINI NOMID
  531.             LESFAC(1)='VX'
  532.             LESFAC(2)='VY'
  533.             LESFAC(3)='VZ'
  534.             IVECT=1
  535.           else
  536. C MODELE A FIBRE
  537. C*        IF (CMATE.EQ.'SECTION') THEN
  538.           IF (MATE.EQ.11) THEN
  539.             IF (ICAS.EQ.2) THEN
  540.               NBRFAC=4
  541.               SEGINI NOMID
  542.               LESFAC(1)='OMEG'
  543.               LESFAC(2)='VX'
  544.               LESFAC(3)='VY'
  545.               LESFAC(4)='VZ'
  546.               IVECT=1
  547.             ELSE
  548.               NBRFAC=3
  549.               SEGINI NOMID
  550.               LESFAC(1)='VX'
  551.               LESFAC(2)='VY'
  552.               LESFAC(3)='VZ'
  553.               IVECT=1
  554.             ENDIF
  555. *
  556. * POUTRE STANDARD
  557. * CAS 2D
  558.           ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  559.             NBROBL=2
  560.             NBRFAC=1
  561.             SEGINI NOMID
  562.             LESOBL(1)= 'SECT'
  563.             LESOBL(2)= 'INRZ'
  564.             LESFAC(1)= 'SECY'
  565.  
  566. * CAS 3D
  567.           ELSE
  568. *
  569. * AMORTISSEMENT COROTATIF
  570. *
  571.             IF (ICAS.EQ.2) THEN
  572.               NBROBL=4
  573.               NBRFAC=6
  574.               SEGINI NOMID
  575.               LESOBL(1)='TORS'
  576.               LESOBL(2)='INRY'
  577.               LESOBL(3)='INRZ'
  578.               LESOBL(4)='SECT'
  579.               LESFAC(1)='SECY'
  580.               LESFAC(2)='SECZ'
  581.               LESFAC(3)='OMEG'
  582.               LESFAC(4)='VX'
  583.               LESFAC(5)='VY'
  584.               LESFAC(6)='VZ'
  585.               IVECT=1
  586.             ELSE
  587. *
  588. * AMORTISSEMENT STANDARD
  589. *
  590.               NBROBL=4
  591.               NBRFAC=5
  592.               SEGINI NOMID
  593.               LESOBL(1)='TORS'
  594.               LESOBL(2)='INRY'
  595.               LESOBL(3)='INRZ'
  596.               LESOBL(4)='SECT'
  597.               LESFAC(1)='SECY'
  598.               LESFAC(2)='SECZ'
  599.               LESFAC(3)='VX'
  600.               LESFAC(4)='VY'
  601.               LESFAC(5)='VZ'
  602.               IVECT=1
  603.             ENDIF
  604.           ENDIF
  605.           endif
  606. *
  607. * CARACTERISTIQUES POUR LES TUYAUX
  608. *
  609.         ELSE IF (MFR.EQ.13) THEN
  610.           IF (ICAS.EQ.2) THEN
  611.             NBROBL=2
  612.             NBRFAC=7
  613.             SEGINI NOMID
  614.             LESOBL(1)='EPAI'
  615.             LESOBL(2)='RAYO'
  616.             LESFAC(1)='RACO'
  617.             LESFAC(2)='PRES'
  618.             LESFAC(3)='CISA'
  619.             LESFAC(4)='OMEG'
  620.             LESFAC(5)='VX'
  621.             LESFAC(6)='VY'
  622.             LESFAC(7)='VZ'
  623.             IVECT=1
  624.           ELSE
  625.             NBROBL=2
  626.             NBRFAC=6
  627.             SEGINI NOMID
  628.             LESOBL(1)='EPAI'
  629.             LESOBL(2)='RAYO'
  630.             LESFAC(1)='RACO'
  631.             LESFAC(2)='PRES'
  632.             LESFAC(3)='CISA'
  633.             LESFAC(4)='VX'
  634.             LESFAC(5)='VY'
  635.             LESFAC(6)='VZ'
  636.             IVECT=1
  637.           ENDIF
  638. *
  639.         ELSE IF (MFR.EQ.39) THEN
  640.           IF (ICAS.EQ.2) THEN
  641.             NBROBL=2
  642.             NBRFAC=6
  643.             SEGINI NOMID
  644.             LESOBL(1)='EPAI'
  645.             LESOBL(2)='RAYO'
  646.             LESFAC(1)='RACO'
  647.             LESFAC(2)='PRES'
  648.             LESFAC(3)='OMEG'
  649.             LESFAC(4)='VX'
  650.             LESFAC(5)='VY'
  651.             LESFAC(6)='VZ'
  652.             IVECT=1
  653.           ELSE
  654.             NBROBL=2
  655.             NBRFAC=5
  656.             SEGINI NOMID
  657.             LESOBL(1)='EPAI'
  658.             LESOBL(2)='RAYO'
  659.             LESFAC(1)='RACO'
  660.             LESFAC(2)='PRES'
  661.             LESFAC(3)='VX'
  662.             LESFAC(4)='VY'
  663.             LESFAC(5)='VZ'
  664.             IVECT=1
  665.           ENDIF
  666.         ENDIF
  667.  
  668. * Rendement :
  669. * Notion non utilisee actuellement (mais conserver a titre historique !)
  670.         IF (NOMID.LE.0) THEN
  671.           NBROBL = 0
  672.           NBRFAC = 0
  673.           SEGINI,NOMID
  674.         ENDIF
  675.         ifac   = NBRFAC
  676.         ncar1  = NBROBL + NBRFAC + 1
  677.         NBRFAC = NBRFAC + 10
  678.         SEGADJ,NOMID
  679.         LESFAC(ifac +  1) = 'REND'
  680.         LESFAC(ifac +  2) = 'W1X '
  681.         LESFAC(ifac +  3) = 'W1Y '
  682.         LESFAC(ifac +  4) = 'W1Z '
  683.         LESFAC(ifac +  5) = 'W2X '
  684.         LESFAC(ifac +  6) = 'W2Y '
  685.         LESFAC(ifac +  7) = 'W2Z '
  686.         LESFAC(ifac +  8) = 'REN1'
  687.         LESFAC(ifac +  9) = 'REN2'
  688.         LESFAC(ifac + 10) = 'REN3'
  689.         IF (notype.ne.MOTYR8) THEN
  690.           NBTYPE = NBTYPE + 1
  691.           SEGADJ,NOTYPE
  692.           TYPE(NBTYPE) = 'REAL*8'
  693.         ENDIF
  694.  
  695.         NCARA = NBROBL
  696.         NCARF = NBRFAC
  697.         NCARR = NCARA+NCARF
  698.  
  699.         MOCARA = NOMID
  700.         MOTYPC = NOTYPE
  701.  
  702. C- Partionnement si necessaire de la matrice d'amortissement
  703. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  704.         LTRK = oooval(1,4)
  705.         IF (LTRK.EQ.0) LTRK = oooval(1,1)
  706.         LTRK=MAX(LTRK,2**24)
  707.  
  708. * Ajout a la taille en mots de la matrice des infos du segment
  709.         LSEG = LRE*LRE*NBELE1 + 16
  710.         NBLPRT = (LSEG-1)/LTRK + 1
  711.         NBLMAX = (NBELE1-1)/NBLPRT + 1
  712.         NBLPRT = (NBELE1-1)/NBLMAX + 1
  713.  
  714.         meleme = IPT1
  715.         ipt3   = ipmaig
  716.         nbnn   = NBNOE1
  717.         nbelem = NBELE1
  718.         nbsous = 0
  719.         nbref  = 0
  720. *
  721. ************************************************************************
  722. *                          P H A S E   2
  723. *
  724. * Boucle sur les PARTITIONS elementaires de la matrice
  725. *
  726. ************************************************************************
  727.         isous = 0
  728.         DO irige = 1, NBLPRT
  729.  
  730.           IF (NBLPRT.GT.1) THEN
  731. C- Partitionnement du maillage support de la matrice elementaire
  732.             ielem = (irige-1)*NBLMAX
  733.             nbnn   = NBNOE1
  734.             nbelem = MIN(NBLMAX,NBELE1-ielem)
  735. *          write(ioimp,*) ' creation segment ',nbnn,nbelem
  736.             SEGINI,meleme
  737.             itypel = IPT1.itypel
  738.             DO ielt = 1, nbelem
  739.               jelt = ielt + ielem
  740.               DO inoe = 1, nbnn
  741.                 num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  742.               ENDDO
  743.               icolor(ielt) = IPT1.ICOLOR(jelt)
  744.             ENDDO
  745.             IF (BDPGE) THEN
  746.               IPT2   = ipmaig
  747.               nbnn   = NBNOEG
  748. cc              nbelem = MIN(NBLMAX,NBELEG-ielem)
  749.               SEGINI,ipt3
  750.               ipt3.itypel = 28
  751.               DO ielt = 1, nbelem
  752.                 jelt = ielt + ielem
  753.                 DO inoe = 1, nbnn
  754.                   ipt3.num(inoe,ielt) = IPT2.NUM(inoe,jelt)
  755.                 ENDDO
  756.                 ipt3.icolor(ielt) = IPT2.ICOLOR(jelt)
  757.               ENDDO
  758.               SEGDES,IPT3
  759.               nbnn = NBNOE1
  760.             ELSE
  761.               ipt3 = meleme
  762.             ENDIF
  763.           ENDIF
  764.  
  765.           ipmail = meleme
  766.           ipdesc = IDESCR
  767.           ipmadg = ipt3
  768.  
  769. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  770.           NELRIG = nbelem
  771.           SEGINI,xmatri
  772.           ipmatr = xmatri
  773.  
  774. C- Recuperation des valeurs des proprietes materiau et geometriques
  775.           IVAMAT = 0
  776.           IVACAR = 0
  777.           brend = .FALSE.
  778.  
  779.           CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1,INFOS,3,IVAMAT)
  780.           IF (IERR.NE.0) GOTO 597
  781.           IF (ISUPM.EQ.1) THEN
  782.             CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  783.             IF (IERR.NE.0) THEN
  784.               ISUPM = 0
  785.               GOTO 597
  786.             ENDIF
  787.           ENDIF
  788.  
  789.           MPTVAL = IVAMAT
  790.  
  791.           if (cmate.eq.'STATIQUE'.or.cmate.eq.'MODAL') then
  792.             if (ival(/1).lt.3) call erreur(5)
  793.             if (cmate.eq.'STATIQUE') then
  794.               kstat = kstat + 1
  795.               ivstat(kstat) = ivamat
  796.               pistat(kstat) = imodel
  797.               if (kstat.eq.nstat) then
  798.                 nstat = nstat + 100
  799.                 segadj modsta
  800.               endif
  801.             endif
  802.             if (cmate.eq.'MODAL') then
  803.               kmoda = kmoda + 1
  804.               ivmoda(kmoda) = ivamat
  805.               pimoda(kmoda) = imodel
  806.               if (kmoda.eq.nmoda) then
  807.                 nmoda = nmoda + 100
  808.                 segadj modsta
  809.               endif
  810.             endif
  811.             if (ival(4).eq.0) goto 598
  812.           endif
  813.  
  814.           NBGMAT = 0
  815.           NELMAT = 0
  816. C*        IF (CMATE.EQ.'SECTION') THEN
  817.           IF (MATE.EQ.11) THEN
  818.             DO i = 1,NMATT
  819.               MELVAL = IVAL(i)
  820.               IF (MELVAL.NE.0) THEN
  821.                 NBGMAT = MAX(NBGMAT,IELCHE(/1))
  822.                 NELMAT = MAX(NELMAT,IELCHE(/2))
  823.               ENDIF
  824.             ENDDO
  825.           ELSE
  826.             DO i = 1,NMATT
  827.               MELVAL = IVAL(i)
  828.               IF (MELVAL.NE.0) THEN
  829.                 NBGMAT = MAX(NBGMAT,VELCHE(/1))
  830.                 NELMAT = MAX(NELMAT,VELCHE(/2))
  831.               ENDIF
  832.             ENDDO
  833.           ENDIF
  834.  
  835.           IF (MOCARA.NE.0)  THEN
  836.             CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1,
  837.      &                  INFOS,3,IVACAR)
  838.             IF (IERR.NE.0) GOTO 597
  839.             IF (ISUPC.EQ.1) THEN
  840.               CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  841.               IF (IERR.NE.0) THEN
  842.                 ISUPC = 0
  843.                 GOTO 597
  844.               ENDIF
  845.             ENDIF
  846. * Rendement :
  847.             mptval = IVACAR
  848.             IF (ival(/1).GE.ncar1+9) THEN
  849.               brend = ival(ncar1+7).GT.0 .OR. ival(ncar1+8).GT.0 .OR.
  850.      &                ival(ncar1+9).GT.0
  851.             ENDIF
  852.           ENDIF
  853.  
  854.           isous = isous + 1
  855.           imod = imodel
  856.           if (dcmate.and.mele.eq.2) goto 29
  857.  
  858. ************************************************************************
  859. *                        P H A S E   3
  860. *
  861. *              CALCUL DES RIGIDITES ELEMENTAIRES
  862. *
  863. ************************************************************************
  864. *
  865. *     NUMERO DES ETIQUETTES      :
  866. *     Les elements sont groupes comme suit :
  867. *      - massif,liquide 'surface libre' poreux ----------------------> r
  868. *      - coq3,dkt,coq4,coq8,coq2,dst --------------------------------> r
  869. *      - poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,jot3> r
  870. *      - joi4,joi2,poutre de timoschenko,joi3
  871. *
  872. *               CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  873.           GOTO (  99,  99,  99,   4,  99,   4,  99,   4,  99,   4,  99
  874. *               RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  875.      &         ,  99,  99,   4 ,  4,   4,   4,  99,  99,  99,  99,  99
  876. *               TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP FAC3 FAC4 FAC6
  877.      &         ,   4,   4,   4,   4,  27,  27,  29,  29,  99,  99,  99
  878. *               FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  879.      &         ,  99,   4,   4,   4,   4,   4,   4,  27,  29,  29,  27
  880. *               POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  881.      &         ,  29,  29,  99,   4,  27,  99,  99,  99,   4,   4,  99
  882. *               COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  883.      &         ,  27,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  884. *               THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  885.      &         ,  99,  99,   4,   4,   4,   4,  99,  99,  99,  99,  99
  886. *               IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  887.      &         ,  99,  99,  99,  99,  99,  99,  29,  29,  29,  29,  29
  888. *               JOI6 JOI8 LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3
  889.      &         ,  99,  99,  99,  29,  27,  99,  29,  29,  29,  29,  99
  890. *               HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  891.      &         ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  892. *               POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  893.      &         ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  894. *               PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  895.      &         ,  99,  29,  29,  29,  99,  99,  99,  99,  99,  99,  99
  896. *               PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  897.      &         ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  898. *               TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  899.      &         ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  900. *               TE56 PY91 TRH6
  901.      &         ,  99,  99,  99),MELE
  902. C
  903. C     CASE OF THE NEW JOINT ELEMENTS (JCT3 AND JCI4 IN 2D SHEAR)
  904. C                                    (JGI2 2D GENERALIZED)
  905. C                                    (JGT3 AND JGI4 GENERALIZED)
  906.           IF (MELE.GE.168.AND.MELE.LE.172)GOTO 29
  907.           IF (MELE.GE.173.OR.MELE.LE.184) GO TO 4
  908. C
  909.  99       CONTINUE
  910.           MOTERR(1:4) = NOMTP(MELE)
  911.           MOTERR(9:12)= 'AMOR1'
  912.           CALL ERREUR(86)
  913.           GOTO 510
  914. C_______________________________________________________________________
  915. C
  916. C     massif
  917. C_______________________________________________________________________
  918. C
  919.  4        CONTINUE
  920.           IF (ICAS.EQ.2) GOTO 99
  921.           CALL AMOR2 (MATE,MELE,ipmail,IPMINT,NBPGAU,LRE,NSTRS,IVAMAT,
  922.      &                IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK,NMATT,
  923.      &                IPORE,NDDL,IPMATR,IIPDPG,ncar1)
  924.           GOTO 510
  925. C_______________________________________________________________________
  926. C
  927. C     coq3,dkt,coq4,coq8,coq2,dst
  928. C_______________________________________________________________________
  929. C
  930.  27       CONTINUE
  931.           IF (ICAS.EQ.2) GOTO 99
  932.           CALL RIGI3(MATE,MELE,ipmail,IPMINT,IPMIN1,NBPGAU,LRE,NSTRS,
  933.      &               IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK,
  934.      &               NMATT,LW,NPINT,IPMATR,IIPDPG)
  935.           GOTO 510
  936. C_______________________________________________________________________
  937. C
  938. C poutre,tuyau,linespring,tuyau fissure,barre,joints 2-3D
  939. C poutre de Timoschenko,point
  940. C_______________________________________________________________________
  941. C
  942.  29       CONTINUE
  943.           n_z = ncar1 - 1
  944.           CALL AMOR4(MATE,MELE,ipmail,IPMINT,NBPGAU,LRE,NSTRS,
  945.      &               IVAMAT,IVACAR,IVECT,CMATE,MFR,ICAS,NBGMAT,NELMAT,
  946.      &      LHOOK,NMATT,n_z,ISOUS,LW,IPORE,IPMATR,IIPDPG,IMOD)
  947.           GOTO 510
  948. *
  949. ************************************************************************
  950. *                        P H A S E   4
  951. *
  952. *     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  953. *
  954. ***********************************************************************
  955.  510      CONTINUE
  956.  597      CONTINUE
  957.       if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') goto 518
  958.           IF (ISUPM.EQ.1 .OR. nblprt.GT.1) THEN
  959.             CALL DTMVAL(IVAMAT,3)
  960.           ELSE
  961.             CALL DTMVAL(IVAMAT,1)
  962.           ENDIF
  963.           IF (ISUPC.EQ.1 .OR. nblprt.GT.1) THEN
  964.             CALL DTMVAL(IVACAR,3)
  965.           ELSE
  966.             CALL DTMVAL(IVACAR,1)
  967.           ENDIF
  968. c*          xmatri = ipmatr
  969.  518   continue
  970.           IF (NBLPRT.GT.1) THEN
  971.             meleme = ipmail
  972.             SEGDES,meleme
  973.           ENDIF
  974.  
  975. C- Sortie prematuree en cas d'erreur
  976.           IF (IERR.NE.0) GOTO 598
  977. C Ajout de la matrice d'AMORTISSEMENT a la matrice globale
  978. C ========================================================
  979.         NRIGE0 = IRIGEL(/2)
  980. c        NRIGEL = NRIGE0 + NBLPRT
  981.         NRIGEL = NRIGE0 + 1
  982.         SEGADJ,MRIGID
  983.  
  984. C- Stockage de la matrice
  985. c          jrige = NRIGE0 + isous
  986.           jrige = NRIGE0 + 1
  987.           COERIG(jrige)   = 1.
  988.           IRIGEL(1,jrige) = ipmadg
  989.           IRIGEL(2,jrige) = 0
  990.           IRIGEL(3,jrige) = ipdesc
  991.           IRIGEL(4,jrige) = ipmatr
  992.           IRIGEL(5,jrige) = NIFOUR
  993.           IRIGEL(6,jrige) = 0
  994.           IF (ICAS.EQ.2) THEN
  995.             IRIGEL(7,jrige) = 2
  996.             xmatri.symre=2
  997.           ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN
  998.             IRIGEL(7,jrige) = 2
  999.             xmatri.symre=2
  1000.           ELSE IF (brend) THEN
  1001.             IRIGEL(7,jrige) = 2
  1002.             xmatri.symre=2
  1003.           ELSE
  1004.             IRIGEL(7,jrige) = 0
  1005.             xmatri.symre=0
  1006.           ENDIF
  1007.           segdes xmatri
  1008.           IRIGEL(8,jrige) = 0
  1009.  
  1010.         ENDDO
  1011. C- Fin de la boucle sur les partitions
  1012. *
  1013.  519    continue
  1014.  598    CONTINUE
  1015.         IF (MOMATR.NE.0) THEN
  1016.           nomid = MOMATR
  1017.           SEGSUP,nomid
  1018.         ENDIF
  1019.         IF (MOTYPM.NE.MOTYR8) THEN
  1020.           notype = MOTYPM
  1021.           SEGSUP,notype
  1022.         ENDIF
  1023.         IF (MOCARA.NE.0) THEN
  1024.           nomid = MOCARA
  1025.           SEGSUP,nomid
  1026.         ENDIF
  1027.         IF (MOTYPC.NE.MOTYR8) THEN
  1028.           notype = MOTYPC
  1029.           SEGSUP,notype
  1030.         ENDIF
  1031. *
  1032. *  Fin de la boucle (5000) de PARTITIONNEMENT du segment XMATRI
  1033.  5000 CONTINUE
  1034.  
  1035.  5991   CONTINUE
  1036. C EN CAS D'ERREUR
  1037.         IF (IERR.NE.0) GOTO 999
  1038.  
  1039.  500  CONTINUE
  1040. C* Fin de la boucle sur les modeles elementaires
  1041.  
  1042.       NRIGEL = jrige
  1043.       segadj mrigid
  1044.  
  1045. *termes croises  'STATIQUE'/'MODAL'
  1046.        nstat = kstat
  1047.        nmoda = kmoda
  1048.        segadj modsta
  1049.        ir2 = 0
  1050.       if (nstat.ne.0) then
  1051.        if (nstat.gt.0) call ricroi(modsta, ir2,3)
  1052.        if (nstat.gt.0) then
  1053.         do kstat=1,nstat
  1054.           mptval = ivstat(kstat)
  1055.           segact mptval
  1056.           IF (ISUPM.EQ.1) THEN
  1057.             CALL DTMVAL(mptval,3)
  1058.           ELSE
  1059.             CALL DTMVAL(mptval,1)
  1060.          ENDIF
  1061.         enddo
  1062.        endif
  1063.        if (nmoda.gt.0) then
  1064.         do kmoda=1,nmoda
  1065.           mptval = ivmoda(kmoda)
  1066.           segact mptval
  1067.           IF (ISUPM.EQ.1) THEN
  1068.             CALL DTMVAL(mptval,3)
  1069.           ELSE
  1070.             CALL DTMVAL(mptval,1)
  1071.          ENDIF
  1072.         enddo
  1073.        endif
  1074.       endif
  1075.  
  1076.       if (ierr.eq.0.and.ir2.gt.0) then
  1077.         ir1 = mrigid
  1078.         call fusrig(ir1,ir2,ir3)
  1079.         mrigid = ir3
  1080.       endif
  1081.  
  1082.  999  CONTINUE
  1083.       IF (IERR.NE.0) THEN
  1084.         SEGSUP,MRIGID
  1085.         IPRIG = 0
  1086.       ELSE
  1087.         SEGDES,MRIGID
  1088.         IPRIG = MRIGID
  1089.       ENDIF
  1090.  
  1091. c on desactive IPMODL et MAILDG
  1092.       mmodel = IPMODL
  1093. c*      SEGDES,mmodel
  1094.       meleme = MAILDG
  1095. c*      IF (meleme.NE.0) SEGDES,meleme
  1096.  
  1097. c on detruit les segments de travail
  1098.       notype = MOTYR8
  1099.       SEGSUP,notype
  1100.       SEGSUP,modsta
  1101.  
  1102. c      RETURN
  1103.       END
  1104.  
  1105.  
  1106.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales