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

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