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

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