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

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