Télécharger la plaquette Cast3M


fr en

Télécharger rigi1.eso

Retour à la liste

Numérotation des lignes : 

rigi1

  1. C RIGI1     SOURCE    OF166741  26/02/23    21:15:28     12480          
  2.  
  3. C---------------------------------------------------------------------*
  4. C                                                                     *
  5. C                      OPERATEUR RIGIDITE                             *
  6. C                                                                     *
  7. C---------------------------------------------------------------------*
  8. C                                                                     *
  9. C       CE SOUS-PROGRAMME SERT A TRAITER ET A METTRE EN FORME         *
  10. C         LES INFORMATIONS NECESSAIRES POUR LES CALCULS               *
  11. C                                                                     *
  12. C---------------------------------------------------------------------*
  13. C                                                                     *
  14. C   ENTREES :                                                         *
  15. C   ________                                                          *
  16. C                                                                     *
  17. C        MODORI   Pointeur sur le modele                              *
  18. C        IPCHE1   Pointeur sur le chamelem de carateristiques         *
  19. C        IPCHE2   Pointeur sur le chamelem de matrice de HOOKE        *
  20. C        IMAT     (2 il y a une matrice de HOOKE,1 non  )             *
  21. C                                                                     *
  22. C   SORTIES :                                                         *
  23. C   ________                                                          *
  24. C                                                                     *
  25. C        IPOI6    pointeur sur la rigidite construite                 *
  26. C        IRET     (1 OK , 0 erreur  )                                 *
  27. C                                                                     *
  28. C---------------------------------------------------------------------*
  29.       SUBROUTINE RIGI1(MODORI,IPCHE1,IPCHE2,IMAT, IPOI6,IRET,noer)
  30.  
  31.       IMPLICIT INTEGER(I-N)
  32.       IMPLICIT REAL*8(A-H,O-Z)
  33.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC CCHAMP
  37. -INC CCGEOME
  38. -INC CCREEL
  39. C==DEB= FORMULATION HHO == Include specifique ==========================
  40. -INC CCHHOPA
  41. C==FIN= FORMULATION HHO ================================================
  42.  
  43. -INC SMCOORD
  44. -INC SMCHAML
  45. -INC SMINTE
  46. -INC SMELEME
  47. -INC SMRIGID
  48. -INC SMMODEL
  49.       POINTEUR IMOREF.IMODEL
  50.       POINTEUR NOMID1.NOMID
  51. -INC SMLREEL
  52. -INC SMLENTI
  53.       POINTEUR MLPHAS.MLENTI
  54.  
  55. -INC TMPTVAL
  56.  
  57.       SEGMENT NOTYPE
  58.         CHARACTER*16 TYPE(NBTYPE)
  59.       ENDSEGMENT
  60.  
  61.       segment modsta
  62.         integer pimoda(nmoda),pistat(nstat)
  63.         integer ivmoda(nmoda),ivstat(nstat)
  64.       endsegment
  65.  
  66.       integer oooval
  67.  
  68.       CHARACTER*8 CMATE
  69.       CHARACTER*(NCONCH) CONM
  70.  
  71.       PARAMETER ( INTTYP=3 )
  72. C                 INTTYP DEFINIT LE TYPE DE POINTS D'INTEGRATION
  73. C                                UTILISE PAR RIGI
  74.       PARAMETER ( NINF=3 )
  75.       INTEGER INFOS(NINF),nrnlin
  76.       LOGICAL LDPGE,lsupma,dcmate,dcmat2
  77.  
  78. C Petit tableau des "couleurs" des relations de conformite (goto 31)
  79.       DIMENSION LCOLOR(6)
  80.       DATA LCOLOR / 1, 3, 6, 10, 16, 24 /
  81.       DATA NRNLIN / 4 /
  82.  
  83.       IRET = 0
  84.       IPOI6 = 0
  85.  
  86. C    VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
  87. C    ZZZZZZZZ  PEUT ETRE A FAIRE PLUTOT SUR LES SOUS-ZONES
  88.  
  89.       ISUP=0
  90.       IF (IPCHE1.NE.0) THEN
  91.         call reduaf(ipche1,MODORI,ipche10,0,iretca,kerr)
  92.         if (iretca.ne.1) call erreur(kerr)
  93.         if (ierr.ne.0) goto 889
  94.         ipche1=ipche10
  95.         CALL QUESUP(MODORI,IPCHE1,INTTYP,0,ISUP,IRETCA)
  96.         IF (ISUP.GT.1) GOTO 889
  97.       ENDIF
  98. C
  99. C    VERIFICATION DU LIEU SUPPORT DU MCHAML DE HOOKE
  100. C
  101.       ISUP1 = 0
  102.       IPCHOO = 0
  103.       IF (IMAT.EQ.2) THEN
  104.         IPCHOO = IPCHE1
  105.         IF (IPCHE2.NE.0) THEN
  106.           IPCHOO = IPCHE2
  107.           call reduaf(IPCHOO,MODORI,IPCHE2,0,iretca,kerr)
  108.           if (iretca.ne.1) call erreur(kerr)
  109.           if (ierr  .ne.0) goto 889
  110.           IPCHOO = IPCHE2
  111.           CALL QUESUP(MODORI,IPCHE2,INTTYP,1,ISUP1,IRETHO)
  112.           IF (ISUP1.NE.0) GOTO 889
  113.         ENDIF
  114.       ENDIF
  115. **      call zpchel(ipche1,0)
  116.  
  117. C               ACTIVATION DU MODELE
  118. C               --------------------
  119. C  MODORI = Modele initial complet
  120. C  IPMODL = Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX")
  121. C et "MELANGE PARALLELE".
  122.       CALL PIMODL(MODORI,IPMODL,MAILDG,1)
  123.       if (ierr.ne.0) return
  124.       IF (IPMODL.EQ.0) then
  125.         call erreur(21)
  126.         goto 889
  127.       ENDIF
  128.  
  129. C  IPMODL est ACTIF en retour :
  130.       MMODEL = IPMODL
  131.       NSOUS  = mmodel.KMODEL(/1)
  132.  
  133. C      INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE
  134. C      ---------------------------------------------
  135.       NRIGEL=0
  136.       SEGINI,MRIGID
  137.       mrigid.MTYMAT = 'RIGIDITE'
  138.       mrigid.IFORIG = IFOUR
  139.       mrigid.ICHOLE = 0
  140.       mrigid.IMGEO1 = 0
  141.       mrigid.IMGEO2 = 0
  142.       mrigid.ISUPEQ = 0
  143.  
  144.       mlphas = 0
  145. c jk148537 en cas de besoin / NLIN
  146.       L1 = 8
  147.       n1 = 1
  148.       segini mmode1
  149.  
  150.       noerjk = noer
  151.       if (noer.gt.1) noer = 0
  152.  
  153.       mchel1 = 0
  154.       mchelm = ipche1
  155.       if (mchelm.ne.0) then
  156.         n3 = infche(/2)
  157.         segini mchel1
  158.         mchel1.ifoche = ifoche
  159.         n2 = 2
  160.         segini mcham1
  161.         mchel1.ichaml(1) = mcham1
  162.       endif
  163.  
  164. C termes croises STATIQUE et/ou MODAL
  165.       nstat = 100
  166.       kstat = 0
  167.       nmoda = 100
  168.       kmoda = 0
  169.       segini modsta
  170.  
  171. C Un petit segment toujours utile
  172.       nbtype = 1
  173.       SEGINI,notype
  174.       notype.TYPE(1) = 'REAL*8'
  175.       MOTYR8 = notype
  176.  
  177. C--------------------------------------------------------------------*
  178. C
  179. C       BOUCLE SUR LES ZONES ELEMENTAIRES ( MEME TYPE D'EF )
  180. C
  181. C--------------------------------------------------------------------*
  182. C
  183.       ISOU=0
  184.       DO 500 ISOUS=1,NSOUS
  185.  
  186.         IMODEL = mmodel.KMODEL(ISOUS)
  187.  
  188. C    INITIALISATIONS
  189.  
  190.         MELE   = imodel.NEFMOD
  191.         IPMAIL = imodel.IMAMOD
  192.         CONM   = imodel.CONMOD
  193.  
  194.         CMATE = CMATEE
  195.         MATE  = IMATEE
  196.         INAT  = INATUU
  197.  
  198.         IF (MELE.EQ.259) GOTO 500
  199.         if (noerjk.eq.2 .and. cmate.ne.'NLIN') goto 500
  200.  
  201.         IPT1   = IPMAIL
  202.         NBNOE1 = IPT1.NUM(/1)
  203.         NBELE1 = IPT1.NUM(/2)
  204.  
  205.         NMATR = 0
  206.         NMATF = 0
  207.         MOMATR = 0
  208.         MOTYMA = MOTYR8
  209.         IVAMAT = 0
  210.         lsupma = .true.
  211.  
  212.         NCARA = 0
  213.         NCARF = 0
  214.         MOCARA = 0
  215.         MOTYCA = MOTYR8
  216.         IVACAR = 0
  217.  
  218.         IVAPHA = 0
  219.         MELPHA = 0
  220.  
  221.         xMATRI = 0
  222.         IPMINT = 0
  223. C
  224. C   CREATION DU TABLEAU INFOS
  225. C
  226.         irtd = 1
  227.         CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,irtd)
  228.         IF (irtd.EQ.0) GOTO 518
  229.  
  230.         dcmate = .false.
  231.         dcmat2 = .false.
  232.         DO im = 1, matmod(/2)
  233.           if (matmod(im).eq.'IMPEDANCE') then
  234.             dcmate =.true.
  235.             if (tymode(/2).gt.0) then
  236.               if (tymode(1).eq.'LISTMOTS') dcmat2 = .true.
  237.             endif
  238.           endif
  239.         ENDDO
  240.  
  241.         MELE = imodel.NEFMOD
  242. C Cas particulier : POI1/SEG2 et IMPEDANCE
  243.         IF (dcmate) THEN
  244.           meleme = IPMAIL
  245.           if (meleme.itypel.eq.1) MELE = 45
  246.           if (meleme.itypel.eq.2) MELE = 2
  247.         ENDIF
  248.  
  249.         IF (MELE.EQ.22) GOTO 310
  250. C
  251. C-----------------------------------------------------------------------
  252. C                        P H A S E   1
  253. C
  254. C         INFOS. ELEMENT FINI ET COMPOSANTES NECESSAIRES
  255. C    DANS LES CHAMPS EN ENTREE ET EVENTUELLEMENT EN SORTIE
  256. C
  257. C    ON POURRAIT REGROUPER LA PLUS GROSSE PARTIE DE CETTE PHASE DANS
  258. C           UN SOUS-PROGRAMME COMMUN A BEAUCOUP D'OPERATEURS
  259. C
  260. C-----------------------------------------------------------------------
  261.         if (infmod(/1).lt.2+inttyp) then
  262.           write(ioimp,*) 'RIGI1 : ERREUR 5 - INFMOD(/1) ?',infmod(/1)
  263.           call erreur(5)
  264.         endif
  265.  
  266.         NSTRS = INFELE(16)
  267.         MFR   = INFELE(13)
  268.         LW    = INFELE( 7)
  269.         NDDL  = INFELE(15)
  270.         IELE  = INFELE(14)
  271.         LRE   = INFELE( 9)
  272.         IPORE = INFELE( 8)
  273.         LHOOK = INFELE(10)
  274.         NBPGAU= INFELE( 6)
  275. C   COQUE INTEGREE OU PAS ?
  276.         NPINT = INFMOD(1)
  277.         IPMINT = INFMOD(2+INTTYP)
  278.         IPMIN1 = INFMOD(3)
  279.  
  280.  310    continue
  281.         if (mele.EQ.22)
  282.      &    write(ioimp,*) '(WARNING) RIGI1 : MELE = 22 - MFR = ',MFR
  283.  
  284.         IIPDPG = imodel.IPDPGE
  285.         IIPDPG = IPTPOI(IIPDPG)
  286.  
  287. C- Cas particulier en DEFO PLAN GENE
  288.         CALL INFDPG(MFR,IFOUR,LDPGE,NDPGE)
  289.         IF (LDPGE) THEN
  290.           IF (IIPDPG.LE.0) THEN
  291.             CALL ERREUR(925)
  292.             CALL ERREUR(5)
  293.             RETURN
  294.           ENDIF
  295.           if (maildg.eq.0) then
  296.             CALL ERREUR(925)
  297.             CALL ERREUR(5)
  298.           ENDIF
  299.           ipt2 = MAILDG
  300.           IPMAIG = ipt2.lisous(isous)
  301.           meleme = IPMAIG
  302.           NBNOEG = meleme.num(/1)
  303.           NBELEG = meleme.num(/2)
  304.         ELSE
  305.           IPMAIG = IPMAIL
  306.         ENDIF
  307.  
  308. C        RECHERCHE DES NOMS D'INCONNUES ET DES DUAUX
  309. C
  310.         MODEPL = imodel.lnomid(1)
  311.         IF (MODEPL.EQ.0) THEN
  312.           write(ioimp,*) 'RIGI1 : MODELE sans LNOMID(1) ?'
  313.           call erreur(5)
  314.         ENDIF
  315.         nomid = MODEPL
  316.         NDEPL = nomid.lesobl(/2)
  317.         MOFORC = imodel.lnomid(2)
  318.         IF (MOFORC.EQ.0) THEN
  319.           write(ioimp,*) 'RIGI1 : MODELE sans LNOMID(2) ?'
  320.           call erreur(5)
  321.         ENDIF
  322.         nomid = MOFORC
  323.         NFORC = nomid.lesobl(/2)
  324.         if (ndepl.eq.0 .or. nforc.eq.0 .or. ndepl.ne.nforc) then
  325.           moterr = 'pas d inconnue duale ou primale '
  326.           call erreur(-385)
  327.           interr(1) = imodel
  328.           moterr(1:16) = conmod
  329.           moterr(17:24) = '        '
  330.           call erreur(-386)
  331.           call erreur(5)
  332.         endif
  333.  
  334.         if (formod(1).eq.'MELANGE'.and.CMATE.EQ.'PARALLEL') then
  335.           mophas = lnomid(12)
  336.           nomid = mophas
  337.           nmpha = lesobl(/2)
  338.           nmphf = lesfac(/2)
  339.           NPHAT = nmpha + nmphf
  340.           JG = NPHAT
  341.           if (mlphas.gt.0) then
  342. * verifie que le precedent melange a ete totalement traite
  343.             do iph = 1,mlphas.lect(/1)
  344.               if (mlphas.lect(iph).gt.0) then
  345.                 moterr(1:50) = 'melange incompletement traite'
  346.                 call erreur(-385)
  347.                 interr(1) = imodel
  348.                 moterr(1:16) = conm
  349.                 moterr(17:24) = '        '
  350.                 call erreur(-386)
  351.                 call erreur(5)
  352.                 return
  353.               endif
  354.             enddo
  355.             segadj mlphas
  356.           else if (mlphas.eq.0) then
  357.             segini mlphas
  358.           endif
  359.           IVAPHA = 0
  360.           imoref = 0
  361.           imosou = imodel
  362. * associe phase et coefficient de phase
  363.           IF (IVAMOD(/1).LT.1) THEN
  364.             call erreur(21)
  365.             return
  366.           ENDIF
  367.           DO j = 1, IVAMOD(/1)
  368.             IF (TYMODE(j).EQ.'IMODEL  ') THEN
  369.               IMODE1 = IVAMOD(j)
  370.               IF (IMODE1.FORMOD(1)(1:10).EQ.'MECANIQUE ' .OR.
  371.      &            IMODE1.FORMOD(1)(1:10).EQ.'POREUX    ' .OR.
  372.      &            IMODE1.FORMOD(1)(1:16).EQ.'ELECTROSTATIQUE ' .OR.
  373.      &            IMODE1.FORMOD(1)(1:10).EQ.'LIQUIDE   ' ) THEN
  374.                 do iph = 1,nmpha
  375.                   if (imode1.conmod(17:24).eq.lesobl(iph)) then
  376.                     mlphas.lect(iph) = imode1
  377.                     if (iph.eq.1) imoref = imode1
  378.                   endif
  379.                 enddo
  380.               ENDIF
  381.             ENDIF
  382.           ENDDO
  383.           CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOPHAS,MOTYR8,0,INFOS,3,IVAPHA)
  384.           IF (IERR.NE.0) GOTO 888
  385.           mptval = IVAPHA
  386.           if (IVAPHA.gt.0) then
  387.             if (ival(/1).eq.0) then
  388. * massif / pas de proportions phases / imite imoref / conserve CONM
  389.               imodel = imoref
  390.               MELE = nefmod
  391.             elseif (ival(/1).ge.nmpha) then
  392.               goto 500
  393.             else
  394.               call erreur(21)
  395.               return
  396.             endif
  397.           else
  398. * massif / pas de proportions phases / imite imoref / conserve CONM
  399.             imodel = imoref
  400.             MELE = nefmod
  401.           endif
  402.  
  403.           IF (ISUP.EQ.1) THEN
  404.             CALL VALCHE(IVAPHA,NPHAT,IPMINT,IPPORE,MOPHAS,MELE)
  405.             IF (IERR.NE.0) THEN
  406.               ISUP=0
  407.               GOTO 888
  408.             ENDIF
  409.           ENDIF
  410.           IF (IERR.NE.0) GOTO 888
  411.  
  412.           if (mlphas.gt.0.and.ivapha.gt.0) then
  413.             do iph = 1, NPHAT
  414.               if (imodel.eq.mlphas.lect(iph)) MELPHA = ival(iph)
  415.             enddo
  416.           endif
  417.  
  418.         endif
  419.  
  420. C     RECHERCHE DES COMPOSANTES UTILES DES CHAMPS EN ENTREE
  421. C     -----------------------------------------------------
  422.         NBROBL = 0
  423.         NBRFAC = 0
  424.         NOMID  = 0
  425. C Sauf cas particuliers, toutes les composantes de type REAL*8
  426.         NBTYPE = 0
  427.         NOTYPE = MOTYR8
  428.  
  429. C  >>>     CHAMP DE MATRICES DE HOOKE
  430.         IF (IMAT.EQ.2) THEN
  431. C
  432.           IF (MELE.EQ.93 .AND. CMATE.NE.'ISOTROPE') THEN
  433.             NBROBL = 3
  434.             SEGINI,NOMID
  435.             LESOBL(1)='MAHO'
  436.             LESOBL(2)='V1X '
  437.             LESOBL(3)='V1Y '
  438.             NBTYPE=3
  439.             SEGINI NOTYPE
  440.             TYPE(1)='POINTEURLISTREEL'
  441.             TYPE(2)='REAL*8'
  442.             TYPE(3)='REAL*8'
  443.           ELSE
  444.             NBROBL = 1
  445.             SEGINI NOMID
  446.             LESOBL(1)='MAHO'
  447.             NBTYPE = 1
  448.             SEGINI NOTYPE
  449.             TYPE(1)  ='POINTEURLISTREEL'
  450.           ENDIF
  451.  
  452.           NMATR  = NBROBL
  453.           NMATF  = NBRFAC
  454.           NMATT  = NMATR+NMATF
  455.  
  456.           MOMATR = NOMID
  457.  
  458.           MOTYMA = NOTYPE
  459.  
  460. C   >>>  CHAMP DE MATERIAU
  461.         ELSE
  462. C
  463.           IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
  464.             IF (MFR.EQ.35.or.mfr.eq.78) THEN
  465.               NBROBL = 2
  466.               SEGINI NOMID
  467.               LESOBL(1)='KS  '
  468.               LESOBL(2)='KN  '
  469.             ELSE IF(MFR.EQ.53) THEN
  470.               NBROBL = 1
  471.               SEGINI,NOMID
  472.               LESOBL(1)='KS  '
  473.             ELSE
  474.               NBROBL = 2
  475.               SEGINI NOMID
  476.               LESOBL(1)='YOUN'
  477.               LESOBL(2)='NU  '
  478. C=DEB==== FORMULATION HHO ==== Traitement particulier du modele ========
  479.               CALL HHOIDC(imodel,nomid)
  480.               NBROBL=nomid.lesobl(/2)
  481. **              NBRFAC=nomid.lesfac(/2)
  482. C=FIN==== FORMULATION HHO ==============================================
  483.             ENDIF
  484.           ELSE IF
  485.      &      (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'UNIDIREC') THEN
  486.             IF (MFR.EQ.1.AND.IDIM.EQ.3) THEN
  487.               NBROBL=7
  488.               SEGINI NOMID
  489.               LESOBL(1)='YOUN'
  490.               LESOBL(2)='V1X '
  491.               LESOBL(3)='V1Y '
  492.               LESOBL(4)='V1Z '
  493.               LESOBL(5)='V2X '
  494.               LESOBL(6)='V2Y '
  495.               LESOBL(7)='V2Z '
  496.             ELSE
  497.               NBROBL=3
  498.               SEGINI NOMID
  499.               LESOBL(1)='YOUN'
  500.               LESOBL(2)='V1X '
  501.               LESOBL(3)='V1Y '
  502.             ENDIF
  503.           ELSE IF
  504.      &      (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ZONE_COHESIVE') THEN
  505.             IF (MFR.EQ.77) THEN
  506.               NBROBL=2
  507.               SEGINI NOMID
  508.               LESOBL(1)='KS  '
  509.               LESOBL(2)='KN  '
  510.             ENDIF
  511.           ELSE IF
  512.      &      (FORMOD(1).EQ.'POREUX   '.AND.CMATE.EQ.'ISOTROPE') THEN
  513.             IF (MELE.GE.79.AND.MELE.LE.83) THEN
  514.               NBROBL=4
  515.               SEGINI NOMID
  516.               LESOBL(1)='YOUN'
  517.               LESOBL(2)='NU  '
  518.               LESOBL(3)='COB '
  519.               LESOBL(4)='MOB '
  520.             ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN
  521.               NBROBL=4
  522.               SEGINI NOMID
  523.               LESOBL(1)='KS  '
  524.               LESOBL(2)='KN  '
  525.               LESOBL(3)='COB '
  526.               LESOBL(4)='MOB '
  527.             ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN
  528.               NBROBL=10
  529.               SEGINI NOMID
  530.               LESOBL( 1)='YOUN'
  531.               LESOBL( 2)='NU  '
  532.               LESOBL( 3)='COP1'
  533.               LESOBL( 4)='COP2'
  534.               LESOBL( 5)='CPP1'
  535.               LESOBL( 6)='CPP2'
  536.               LESOBL( 7)='KK11'
  537.               LESOBL( 8)='KK12'
  538.               LESOBL( 9)='KK21'
  539.               LESOBL(10)='KK22'
  540.             ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  541.               NBROBL=17
  542.               SEGINI NOMID
  543.               LESOBL( 1)='YOUN'
  544.               LESOBL( 2)='NU  '
  545.               LESOBL( 3)='COP1'
  546.               LESOBL( 4)='COP2'
  547.               LESOBL( 5)='COP3'
  548.               LESOBL( 6)='CPP1'
  549.               LESOBL( 7)='CPP2'
  550.               LESOBL( 8)='CPP3'
  551.               LESOBL( 9)='KK11'
  552.               LESOBL(10)='KK12'
  553.               LESOBL(11)='KK13'
  554.               LESOBL(12)='KK21'
  555.               LESOBL(13)='KK22'
  556.               LESOBL(14)='KK23'
  557.               LESOBL(15)='KK31'
  558.               LESOBL(16)='KK32'
  559.               LESOBL(17)='KK33'
  560.             ELSE IF (MELE.GE.185.AND.MELE.LE.187) THEN
  561.               NBROBL=10
  562.               SEGINI NOMID
  563.               LESOBL( 1)='KS  '
  564.               LESOBL( 2)='KN  '
  565.               LESOBL( 3)='COP1'
  566.               LESOBL( 4)='COP2'
  567.               LESOBL( 5)='CPP1'
  568.               LESOBL( 6)='CPP2'
  569.               LESOBL( 7)='KK11'
  570.               LESOBL( 8)='KK12'
  571.               LESOBL( 9)='KK21'
  572.               LESOBL(10)='KK22'
  573.             ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  574.               NBROBL=17
  575.               SEGINI NOMID
  576.               LESOBL( 1)='KS  '
  577.               LESOBL( 2)='KN  '
  578.               LESOBL( 3)='COP1'
  579.               LESOBL( 4)='COP2'
  580.               LESOBL( 5)='COP3'
  581.               LESOBL( 6)='CPP1'
  582.               LESOBL( 7)='CPP2'
  583.               LESOBL( 8)='CPP3'
  584.               LESOBL( 9)='KK11'
  585.               LESOBL(10)='KK12'
  586.               LESOBL(11)='KK13'
  587.               LESOBL(12)='KK21'
  588.               LESOBL(13)='KK22'
  589.               LESOBL(14)='KK23'
  590.               LESOBL(15)='KK31'
  591.               LESOBL(16)='KK32'
  592.               LESOBL(17)='KK33'
  593.             ENDIF
  594.  
  595.           ELSE IF (INAT.EQ.67.AND.CMATE.EQ.'ORTHOTRO') THEN
  596.             NBROBL=6
  597.             SEGINI NOMID
  598.             LESOBL(1)='YG1 '
  599.             LESOBL(2)='YG2 '
  600.             LESOBL(3)='NU12'
  601.             LESOBL(4)='G12 '
  602.             LESOBL(5)='V1X '
  603.             LESOBL(6)='V1Y '
  604.  
  605. C          ELSE IF (FORMOD(1).EQ.'ELECTROSTATIQUE') THEN
  606. C             Pour l'instant, lnomid(6) ou appel a IDMATR suffisent.
  607. C
  608.           ELSE IF (FORMOD(1).EQ.'DIFFUSION') THEN
  609. C             CB215821 : Desormais il faut utiliser COND
  610.             MOTERR(1:8)='DIFFUSIO'
  611.             CALL ERREUR(193)
  612.             RETURN
  613. C            CALL IDDILI(MATE,1,nomid,nbrobl,nbrfac)
  614.  
  615. C poi1 -- MODAL
  616.           ELSE IF (CMATE.EQ.'MODAL') THEN
  617.             NBROBL=3
  618.             SEGINI NOMID
  619.             LESOBL(1)='FREQ'
  620.             LESOBL(2)='MASS'
  621.             LESOBL(3)='DEFO'
  622. C poi1 -- STATIQUE
  623.           ELSE IF (CMATE.EQ.'STATIQUE') THEN
  624.             NBROBL=3
  625.             SEGINI NOMID
  626.             LESOBL(1)='DEFO'
  627.             LESOBL(2)='RIDE'
  628.             LESOBL(3)='MADE'
  629. C IMPEDANCE COMPLEXE
  630.           ELSE IF (CMATE.EQ.'IMPCOMPL') THEN
  631.             NBROBL=1
  632.             SEGINI NOMID
  633.             LESOBL(1)='RAID'
  634. C
  635. C Autres cas :
  636.           ELSE
  637.             nomid = lnomid(6)
  638.             IF (nomid.ne.0) then
  639.               lsupma = .false.
  640.               nbrobl = lesobl(/2)
  641.               nbrfac = lesfac(/2)
  642.             else
  643.       write(ioimp,*) '(WARNING) RIGI1 : lnomid(6) non defini !'
  644.               CALL IDMATR(MFR,IMODEL,nomid,nbrobl,nbrfac)
  645.             endif
  646.           ENDIF
  647.  
  648.           NMATR = NBROBL
  649.           NMATF = NBRFAC
  650.           NMATT = NMATR+NMATF
  651.  
  652.           MOMATR = NOMID
  653.  
  654.           IF (CMATE.EQ.'SECTION') THEN
  655.             NBTYPE=3
  656.             SEGINI NOTYPE
  657.             TYPE(1)='POINTEURMMODEL'
  658.             TYPE(2)='POINTEURMCHAML'
  659.             TYPE(3)='POINTEURLISTREEL'
  660. c mistral :
  661.           ELSE IF (INAT.EQ.94) THEN
  662.             NBTYPE=NMATT
  663.             SEGINI NOTYPE
  664.             DO ITYP = 1, NBTYPE
  665.               TYPE(ITYP)='REAL*8'
  666.             ENDDO
  667. C=DEB==== FORMULATION HHO ==== Traitement particulier du modele ========
  668.             IDECAL = 0
  669.             IF (MFR.EQ.HHO_MFR_ELEMENT) IDECAL = 4
  670. C=FIN==== FORMULATION HHO ==============================================
  671. C pour le modele mistral il y a 10 composantes non lineaires qui sont des listes de reels
  672.             NLDEB=NMATR-9-IDECAL
  673.             NLFIN=NMATR-IDECAL
  674.             DO ITYP = NLDEB, NLFIN
  675.               TYPE(ITYP)='POINTEURLISTREEL'
  676.             ENDDO
  677. C mistral.
  678. C poi1 -- MODAL
  679.           ELSE IF (CMATE.EQ.'MODAL') THEN
  680.             NBTYPE=3
  681.             SEGINI NOTYPE
  682.             TYPE(1)='REAL*8  '
  683.             TYPE(2)='REAL*8  '
  684.             TYPE(3)='POINTEURCHPOINT'
  685. C poi1 -- STATIQUE
  686.           ELSE IF (CMATE.EQ.'STATIQUE') THEN
  687.             NBTYPE=1
  688.             SEGINI NOTYPE
  689.             TYPE(1)='POINTEURCHPOINT'
  690.           ENDIF
  691. C=DEB==== FORMULATION HHO ==== Traitement particulier du modele ========
  692.           IF (MFR .EQ. HHO_MFR_ELEMENT) THEN
  693.             IF (NOTYPE .EQ. MOTYR8) THEN
  694.               NBTYPE = 1
  695.               SEGINI,NOTYPE
  696.               TYPE(1)='REAL*8  '
  697.             ENDIF
  698.             IF (NBTYPE.EQ.1) THEN
  699.               NBTYPE = NMATT
  700.               SEGADJ,NOTYPE
  701.               DO ITYP = 2, NBTYPE
  702.                 TYPE(ITYP) = TYPE(1)
  703.               END DO
  704.             END IF
  705.             TYPE(NMATR-1) = 'POINTEURLISTREEL'
  706.             TYPE(NMATR  ) = 'POINTEURLISTREEL'
  707.           END IF
  708. C=FIN==== FORMULATION HHO ==============================================
  709.  
  710.           MOTYMA = NOTYPE
  711.  
  712.         ENDIF
  713. C
  714. C   >>>     COMPOSANTES DE CARACTERISTIQUES UTILES
  715. C
  716.         NBROBL = 0
  717.         NBRFAC = 0
  718.         NOMID  = 0
  719. C Sauf cas particuliers, toutes les composantes de type REAL*8
  720.         NBTYPE = 0
  721.         NOTYPE = MOTYR8
  722. C
  723. C EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
  724. C
  725.         IF ( (MFR.EQ.1 .OR. MFR.EQ.31 .OR.
  726. C=DEB==== FORMULATION HHO ==============================================
  727.      &        (MFR.EQ.HHO_MFR_ELEMENT).OR.
  728. C=FIN==== FORMULATION HHO ==============================================
  729.      &       ((MELE.GE.79.AND.MELE.LE.83).OR.
  730.      &        (MELE.GE.173.AND.MELE.LE.182)) )
  731.      &      .AND. IFOUR.EQ.-2) THEN
  732.           NBRFAC=1
  733.           SEGINI,NOMID
  734.           LESFAC(1)='DIM3'
  735. C
  736. C EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  737. C
  738.         ELSE IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  739.           NBROBL=1
  740.           IF (MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  741.             NBRFAC=2
  742.           ELSE
  743.             NBRFAC=1
  744.           ENDIF
  745.           SEGINI,NOMID
  746.           LESOBL(1)='EPAI'
  747.           LESFAC(1)='EXCE'
  748.           IF (MFR.EQ.3.AND.IFOUR.EQ.-2)  LESFAC(2)='DIM3'
  749. C
  750. C SECTION POUR LES BARRES ET LES CERCES
  751. C
  752.         ELSE IF (MFR.EQ.27.OR.MFR.EQ.78) THEN
  753.           IF (.NOT.dcmate) THEN
  754.             NBROBL=1
  755.             SEGINI,NOMID
  756.             LESOBL(1)='SECT'
  757.           ENDIF
  758. C
  759. C section, excentrements et orientation pour les barres excentrees
  760. C
  761.         ELSE IF (MFR.EQ.49) THEN
  762.           NBROBL=6
  763.           SEGINI,NOMID
  764.           LESOBL(1)='SECT'
  765.           LESOBL(2)='EXCZ'
  766.           LESOBL(3)='EXCY'
  767.           LESOBL(4)='VX  '
  768.           LESOBL(5)='VY  '
  769.           LESOBL(6)='VZ  '
  770. C
  771. C raideurs locales et orientation pour l'element LIA2
  772. C              de liaison a 2 noeuds
  773. C
  774.         ELSE IF (MFR.EQ.51) THEN
  775.           NBROBL=9
  776.           SEGINI,NOMID
  777.           LESOBL(1)='RLUX'
  778.           LESOBL(2)='RLUY'
  779.           LESOBL(3)='RLUZ'
  780.           LESOBL(4)='RLRX'
  781.           LESOBL(5)='RLRY'
  782.           LESOBL(6)='RLRZ'
  783.           LESOBL(7)='VX  '
  784.           LESOBL(8)='VY  '
  785.           LESOBL(9)='VZ  '
  786. C
  787. C CARACTERISTIQUES POUR LES POUTRES
  788. C
  789.         ELSE IF (MFR.EQ.7 ) THEN
  790.           if (dcmate) then
  791.             NBRFAC=6
  792.             SEGINI NOMID
  793.             LESFAC(1)='TORS'
  794.             LESFAC(2)='INRY'
  795.             LESFAC(3)='INRZ'
  796.             LESFAC(4)='VX  '
  797.             LESFAC(5)='VY  '
  798.             LESFAC(6)='VZ  '
  799.             IVECT=1
  800.           else
  801.             IF (CMATE.EQ.'SECTION') THEN
  802.               NBRFAC=3
  803.               SEGINI NOMID
  804.               LESFAC(1)='VX  '
  805.               LESFAC(2)='VY  '
  806.               LESFAC(3)='VZ  '
  807.               IVECT=1
  808. C CAS 2D
  809.             ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  810.               NBRFAC=1
  811.               NBROBL=2
  812.               SEGINI NOMID
  813.               LESOBL(1)= 'SECT'
  814.               LESOBL(2)= 'INRZ'
  815.               LESFAC(1)= 'SECY'
  816.             ELSE
  817.               NBROBL=4
  818.               NBRFAC=5
  819.               SEGINI NOMID
  820.               LESOBL(1)='TORS'
  821.               LESOBL(2)='INRY'
  822.               LESOBL(3)='INRZ'
  823.               LESOBL(4)='SECT'
  824.               LESFAC(1)='SECY'
  825.               LESFAC(2)='SECZ'
  826.               LESFAC(3)='VX  '
  827.               LESFAC(4)='VY  '
  828.               LESFAC(5)='VZ  '
  829.               IVECT=1
  830.             ENDIF
  831.           endif
  832. C
  833. C CARACTERISTIQUES POUR LES TUYAUX
  834. C
  835.         ELSE IF (MFR.EQ.13) THEN
  836.           NBROBL=2
  837.           NBRFAC=6
  838.           SEGINI NOMID
  839.           LESOBL(1)='EPAI'
  840.           LESOBL(2)='RAYO'
  841.           LESFAC(1)='RACO'
  842.           LESFAC(2)='PRES'
  843.           LESFAC(3)='CISA'
  844.           LESFAC(4)='VX  '
  845.           LESFAC(5)='VY  '
  846.           LESFAC(6)='VZ  '
  847.           IVECT=1
  848. C
  849.         ELSE IF (MFR.EQ.39) THEN
  850.           NBROBL=2
  851.           NBRFAC=5
  852.           SEGINI NOMID
  853.           LESOBL(1)='EPAI'
  854.           LESOBL(2)='RAYO'
  855.           LESFAC(1)='RACO'
  856.           LESFAC(2)='PRES'
  857.           LESFAC(3)='VX  '
  858.           LESFAC(4)='VY  '
  859.           LESFAC(5)='VZ  '
  860.           IVECT=1
  861. C
  862. C CARACTERISTIQUES POUR LES LINESPRING
  863. C
  864.         ELSE IF (MFR.EQ.15) THEN
  865.           NBROBL=5
  866.           SEGINI NOMID
  867.           LESOBL(1)='EPAI'
  868.           LESOBL(2)='FISS'
  869.           LESOBL(3)='VX  '
  870.           LESOBL(4)='VY  '
  871.           LESOBL(5)='VZ  '
  872. C
  873. C CARACTERISTIQUES POUR LES TUYAUX FISSURES
  874. C
  875.         ELSE IF (MFR.EQ.17) THEN
  876.           NBROBL=9
  877.           SEGINI NOMID
  878.           LESOBL(1)='RAYO'
  879.           LESOBL(2)='EPAI'
  880.           LESOBL(3)='VX  '
  881.           LESOBL(4)='VY  '
  882.           LESOBL(5)='VZ  '
  883.           LESOBL(6)='VXF '
  884.           LESOBL(7)='VYF '
  885.           LESOBL(8)='VZF '
  886.           LESOBL(9)='ANGL'
  887. C
  888. C CARACTERISTIQUES DES ELEMENTS HOMOGENEISES
  889. C
  890.         ELSE IF (MFR.EQ.37) THEN
  891.           IF (IFOUR.EQ.1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.2) THEN
  892.             NBROBL=5
  893.             SEGINI NOMID
  894.             LESOBL(1)='SCEL'
  895.             LESOBL(2)='SFLU'
  896.             LESOBL(3)='EPS '
  897.             LESOBL(4)='SECT'
  898.             LESOBL(5)='INRZ '
  899.           ELSE
  900.             NBROBL=3
  901.             SEGINI NOMID
  902.             LESOBL(1)='SCEL'
  903.             LESOBL(2)='SFLU'
  904.             LESOBL(3)='EPS '
  905.           ENDIF
  906. C
  907. C CARACTERISTIQUES DE L'ELEMENT TUYAU ACOUSTIQUE
  908. C
  909.         ELSE IF (MFR.EQ.41) THEN
  910.            NBROBL=1
  911.            NBRFAC=1
  912.            SEGINI NOMID
  913.            LESOBL(1)='RAYO'
  914.            LESFAC(1)='RACO'
  915. C
  916. C     CARACTERISTIQUE POUR LES JOINTS GENE
  917. C
  918.         ELSE IF (MFR.EQ.55) THEN
  919.           NBRFAC=1
  920.           SEGINI NOMID
  921.           LESFAC(1)='EPAI'
  922. C
  923. C CARACTERISTIQUE MACRO_EL (element CIFL)
  924. C
  925.         ELSE IF (MFR.EQ.61)THEN
  926.           NBROBL=2
  927.           SEGINI NOMID
  928.           LESOBL(1)= 'SECT'
  929.           LESOBL(2)= 'INRZ'
  930. C
  931. C  CARACTERISTIQUES POUR LE JOI1 SI IMAT = 2
  932. C
  933.         ELSE IF (MFR.EQ.75.AND.IMAT.EQ.2) THEN
  934.           IF (IDIM.EQ.2) THEN
  935.             NBROBL=2
  936.             SEGINI NOMID
  937.             LESOBL(1)='V1X '
  938.             LESOBL(2)='V1Y '
  939.           ELSE IF(IDIM.EQ.3) THEN
  940.             NBROBL=6
  941.             SEGINI NOMID
  942.             LESOBL(1)='V1X '
  943.             LESOBL(2)='V1Y '
  944.             LESOBL(3)='V1Z '
  945.             LESOBL(4)='V2X '
  946.             LESOBL(5)='V2Y '
  947.             LESOBL(6)='V2Z '
  948.           ENDIF
  949.  
  950.         ENDIF
  951.  
  952.         NCARA = NBROBL
  953.         NCARF = NBRFAC
  954.         NCARR = NCARA+NCARF
  955.         MOCARA = NOMID
  956.  
  957. C rendement kich 09/01
  958.         NCAR1 = NCARR + 1
  959.         ifac = NBRFAC
  960.         NBRFAC = NBRFAC + 10
  961.         if (mocara.le.0) then
  962.           segini,nomid
  963.           mocara = nomid
  964.         else
  965.           segadj,nomid
  966.         endif
  967.         lesfac(ifac + 1) = 'REND'
  968.         lesfac(ifac + 2) = 'W1X '
  969.         lesfac(ifac + 3) = 'W1Y '
  970.         lesfac(ifac + 4) = 'W1Z '
  971.         lesfac(ifac + 5) = 'W2X '
  972.         lesfac(ifac + 6) = 'W2Y '
  973.         lesfac(ifac + 7) = 'W2Z '
  974.         lesfac(ifac + 8) = 'REN1'
  975.         lesfac(ifac + 9) = 'REN2'
  976.         lesfac(ifac +10) = 'REN3'
  977.  
  978.         motype = notype
  979.         if (motype.ne.motyr8) then
  980.           nbtype = notype.type(/2) + 1
  981.           segadj,notype
  982.           notype.type(nbtype) = 'REAL*8'
  983.         endif
  984.  
  985.         MOTYCA = notype
  986.  
  987. C-DEB---- DESCRIPTEUR --------------------------------------------------
  988. C- Faire de ce bloc une subroutine commune avec MASS et autres ?
  989.  
  990. C=DEB==== FORMULATION HHO ==== Cas particulier de la formulation =======
  991.         IF (MFR.EQ.HHO_MFR_ELEMENT) THEN
  992.           CALL DSCMAT(imodel, IPDSCR, LRE, iret)
  993.           IF (iret.NE.0) THEN
  994.             CALL ERREUR(iret)
  995.             RETURN
  996.           END IF
  997.           GOTO 1089
  998.         ENDIF
  999. C=FIN==== FORMULATION HHO ==============================================
  1000.  
  1001.         nbnn1  = NBNOE1
  1002.  
  1003. c lre : nb de noeuds par mult
  1004.         if (nefmod.eq. 22) lre=nbnn1
  1005. c lre : nb de noeuds par sure
  1006.         if (nefmod.eq.259) lre=nbnn1
  1007. C
  1008. C   traitement particulier pour milieu poreux
  1009.         IPPORE=0
  1010.         IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59)  THEN
  1011.           IPPORE=NBNNE(NUMGEO(MELE))
  1012.         ENDIF
  1013.  
  1014.         IDECAP=0
  1015.         IF (MELE.GE.79.AND.MELE.LE.83) THEN
  1016.           IDECAP=1
  1017.           LRE = LRE + 2*NBNN1 - IPORE
  1018.         ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN
  1019.           IDECAP=1
  1020.           LRE = LRE + (3*NBNN1 - IPORE)/2 - NBSOM(IELE)
  1021.         ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN
  1022.           IDECAP=2
  1023.           LRE = LRE + (2*NBNN1 - IPORE)*IDECAP
  1024.           LHOOK=4
  1025.           IF(IFOUR.EQ.1) LHOOK=6
  1026.         ELSE IF (MELE.GE.185.AND.MELE.LE.187) THEN
  1027.           IDECAP=2
  1028.           LRE = LRE + ((3*NBNN1 - IPORE)/2 - NBSOM(IELE))*IDECAP
  1029.           LHOOK=2
  1030.           IF(IFOUR.EQ.1) LHOOK=3
  1031.         ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  1032.           IDECAP=3
  1033.           LRE = LRE + (2*NBNN1 - IPORE)*IDECAP
  1034.           LHOOK=4
  1035.           IF(IFOUR.EQ.1) LHOOK=6
  1036.         ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  1037.           IDECAP=3
  1038.           LRE = LRE + ((3*NBNN1 - IPORE)/2 - NBSOM(IELE))*IDECAP
  1039.           LHOOK=2
  1040.           IF(IFOUR.EQ.1) LHOOK=3
  1041.         ENDIF
  1042. C
  1043. C          REMPLISSAGE DU SEGMENT DESCRIPTEUR
  1044. C
  1045.         NCOMP = NDEPL
  1046.         NBNNS = NBNOE1
  1047.         NBNN  = NBNOE1
  1048.         IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN
  1049.           NCOMP=NDEPL-IDECAP
  1050.         ENDIF
  1051.         IF (LDPGE) THEN
  1052.           NCOMP = NDEPL - NDPGE
  1053.           NBNN = NBNOE1 + 1
  1054.         ENDIF
  1055.         IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2
  1056.         if (dcmat2) NCOMP = NDEPL/2
  1057.  
  1058.         NLIGRP = LRE
  1059.         NLIGRD = LRE
  1060.         IF ((MFR.NE.61) .AND. (NBNNS*NCOMP .GT. NLIGRD)) THEN
  1061. C          erreur dans les dimensions de DESCR
  1062. C          le mode de calcul n'est pas correct
  1063.           CALL ERREUR(717)
  1064.           RETURN
  1065.         ENDIF
  1066.  
  1067.         SEGINI,DESCR
  1068.  
  1069.         IDDL = 1
  1070.  
  1071.         NOMID  = MODEPL
  1072.         NOMID1 = MOFORC
  1073.  
  1074.         IF (MFR.EQ.61) THEN
  1075.           NOELEP(1)=1
  1076.           NOELEP(2)=1
  1077.           NOELEP(3)=1
  1078.           NOELEP(4)=3
  1079.           NOELEP(5)=3
  1080.           NOELEP(6)=3
  1081.           NOELEP(7)=2
  1082.           NOELEP(8)=2
  1083.  
  1084.           DO IE1=1,LRE
  1085.             NOELED(IE1)=NOELEP(IE1)
  1086.           ENDDO
  1087.  
  1088.           DO IE1=1,3
  1089.             LISINC(IE1)=nomid.LESOBL(IE1)
  1090.             LISINC(IE1+3)=nomid.LESOBL(IE1)
  1091.           ENDDO
  1092.           LISINC(7)=nomid.LESOBL(4)
  1093.           LISINC(8)=nomid.LESOBL(5)
  1094.  
  1095.           DO IE1=1,3
  1096.             LISDUA(IE1)  =nomid1.LESOBL(IE1)
  1097.             LISDUA(IE1+3)=nomid1.LESOBL(IE1)
  1098.           ENDDO
  1099.           LISDUA(7)=nomid1.LESOBL(4)
  1100.           LISDUA(8)=nomid1.LESOBL(5)
  1101.  
  1102.           IDDL = 9
  1103.  
  1104.         ELSE
  1105.           NFAC=(3*NBNN-IPORE)/2
  1106.  
  1107.           DO INOEUD = 1, NBNNS
  1108.             IF ((MELE.GE.108.AND.MELE.LE.110.AND.INOEUD.GT.NFAC)
  1109.      &       .OR.(MELE.GE.185.AND.MELE.LE.187.AND.INOEUD.GT.NFAC)
  1110.      &       .OR.(MELE.GE.188.AND.MELE.LE.190.AND.INOEUD.GT.NFAC))
  1111.      &           GO TO 1004
  1112.             DO ICOMP=1,NCOMP
  1113.               NOMID=MODEPL
  1114.               LISINC(IDDL)=nomid.LESOBL(ICOMP)
  1115.               LISDUA(IDDL)=nomid1.LESOBL(ICOMP)
  1116.               if (dcmat2) THEN
  1117.                 LISINC(IDDL)=nomid.LESOBL(IDDL)
  1118.                 LISDUA(IDDL)=nomid1.LESOBL(IDDL)
  1119.               endif
  1120.               NOELEP(IDDL)=INOEUD
  1121.               NOELED(IDDL)=INOEUD
  1122.               IDDL=IDDL+1
  1123.             ENDDO
  1124.  1004       CONTINUE
  1125.           ENDDO
  1126.  
  1127.         ENDIF
  1128.  
  1129. C   CAS DE LA DEFORMATION PLANE GENERALISEE
  1130.         IF (LDPGE) THEN
  1131.           DO ICOMP=(NDPGE-1),0,-1
  1132.             LISINC(IDDL)=nomid.LESOBL(NDEPL-ICOMP)
  1133.             LISDUA(IDDL)=nomid1.LESOBL(NFORC-ICOMP)
  1134.             NOELEP(IDDL)=NBNN
  1135.             NOELED(IDDL)=NBNN
  1136.             IDDL=IDDL+1
  1137.           ENDDO
  1138.         ENDIF
  1139.  
  1140. C   CAS DES MILIEUX POREUX
  1141. C   POUR LA PRESSION ON MET D'ABORD LES SOMMETS
  1142.         IF (MFR.EQ.33) THEN
  1143.           DO INOEUD=1,NBSOM(IELE)
  1144.             LISINC(IDDL)=nomid.LESOBL(NDEPL)
  1145.             LISDUA(IDDL)=nomid1.LESOBL(NDEPL)
  1146.             NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  1147.             NOELED(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  1148.             IDDL=IDDL+1
  1149.           ENDDO
  1150.  
  1151.           IF (MELE.GE.79.AND.MELE.LE.83) THEN
  1152.  
  1153.             DO INOEUD=1,NBNN
  1154.               DO INSOM=1,NBSOM(IELE)
  1155.                 IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 1105
  1156.               ENDDO
  1157.               LISINC(IDDL)=nomid.LESOBL(NDEPL)
  1158.               LISDUA(IDDL)=nomid1.LESOBL(NDEPL)
  1159.               NOELEP(IDDL)=INOEUD
  1160.               NOELED(IDDL)=INOEUD
  1161.               IDDL=IDDL+1
  1162.  1105         CONTINUE
  1163.             ENDDO
  1164.  
  1165.           ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN
  1166.  
  1167.             DO INOEUD=NFAC+1,NBNN
  1168.               LISINC(IDDL)=nomid.LESOBL(NDEPL)
  1169.               LISDUA(IDDL)=nomid1.LESOBL(NDEPL)
  1170.               NOELEP(IDDL)=INOEUD
  1171.               NOELED(IDDL)=INOEUD
  1172.               IDDL=IDDL+1
  1173.             ENDDO
  1174.  
  1175.             DO INOEUD=1,NFAC
  1176.               DO INSOM=1,NBSOM(IELE)
  1177.                 IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 1110
  1178.               ENDDO
  1179.               LISINC(IDDL)=nomid.LESOBL(NDEPL)
  1180.               LISDUA(IDDL)=nomid1.LESOBL(NDEPL)
  1181.               NOELEP(IDDL)=INOEUD
  1182.               NOELED(IDDL)=INOEUD
  1183.               IDDL=IDDL+1
  1184.  1110         CONTINUE
  1185.             ENDDO
  1186.  
  1187.           ENDIF
  1188.  
  1189.         ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN
  1190.  
  1191.           DO IPR=1,IDECAP
  1192.             NDECAP = NDEPL-IDECAP+IPR
  1193.  
  1194.             DO INOEUD=1,NBSOM(IELE)
  1195.               LISINC(IDDL)=nomid.LESOBL(NDECAP)
  1196.               LISDUA(IDDL)=nomid1.LESOBL(NDECAP)
  1197.               NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  1198.               NOELED(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  1199.               IDDL=IDDL+1
  1200.             ENDDO
  1201.  
  1202.             IF (MELE.GE.173.AND.MELE.LE.182) THEN
  1203.  
  1204.               DO INOEUD=1,NBNN
  1205.                 DO INSOM=1,NBSOM(IELE)
  1206.                   IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 1205
  1207.                 ENDDO
  1208.                 LISINC(IDDL)=nomid.LESOBL(NDECAP)
  1209.                 LISDUA(IDDL)=nomid1.LESOBL(NDECAP)
  1210.                 NOELEP(IDDL)=INOEUD
  1211.                 NOELED(IDDL)=INOEUD
  1212.                 IDDL=IDDL+1
  1213.  1205           CONTINUE
  1214.               ENDDO
  1215.  
  1216.             ELSE IF (MELE.GE.185.AND.MELE.LE.190) THEN
  1217.  
  1218.               DO INOEUD=NFAC+1,NBNN
  1219.                 LISINC(IDDL)=nomid.LESOBL(NDECAP)
  1220.                 LISDUA(IDDL)=nomid1.LESOBL(NDECAP)
  1221.                 NOELEP(IDDL)=INOEUD
  1222.                 NOELED(IDDL)=INOEUD
  1223.                 IDDL=IDDL+1
  1224.               ENDDO
  1225.  
  1226.               DO INOEUD=1,NFAC
  1227.                 DO INSOM=1,NBSOM(IELE)
  1228.                   IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 1710
  1229.                 ENDDO
  1230.                 LISINC(IDDL)=nomid.LESOBL(NDECAP)
  1231.                 LISDUA(IDDL)=nomid1.LESOBL(NDECAP)
  1232.                 NOELEP(IDDL)=INOEUD
  1233.                 NOELED(IDDL)=INOEUD
  1234.                 IDDL=IDDL+1
  1235.  1710           CONTINUE
  1236.               ENDDO
  1237. C
  1238.             ENDIF
  1239.  
  1240.           ENDDO
  1241.  
  1242. C    CAS DES ELEMENT RACCORD
  1243.         ELSE IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  1244.           CALL IDPRIM(IMODEL,MFR+1000,MODPL,NDEPL,NDUM)
  1245.           CALL IDDUAL(IMODEL,MFR+1000,MOFRC,NFORC,NDUM)
  1246.           nomid  = MODPL
  1247.           nomid1 = MOFRC
  1248.           DO INOEUD=NBNNS+1,NBNN
  1249.             DO ICOMP=1,NDEPL
  1250.               LISINC(IDDL) = nomid.LESOBL(ICOMP)
  1251.               LISDUA(IDDL) = nomid1.LESOBL(ICOMP)
  1252.               NOELEP(IDDL)=INOEUD
  1253.               NOELED(IDDL)=INOEUD
  1254.               IDDL=IDDL+1
  1255.             ENDDO
  1256.           ENDDO
  1257.           SEGSUP,nomid,nomid1
  1258.  
  1259.         ENDIF
  1260.  
  1261.         SEGDES,DESCR
  1262.         IPDSCR = DESCR
  1263.  
  1264. 1089    CONTINUE
  1265. C-FIN---- DESCRIPTEUR --------------------------------------------------
  1266.  
  1267. C Si necessaire partitionnement du xmatri
  1268.         LTRK = oooval(1,4)
  1269.         if (LTRK.eq.0) LTRK = oooval(1,1)
  1270.         LTRK = MAX(LTRK,2**24)
  1271.  
  1272. C Ajout a la taille en mots de la matrice des infos du segment
  1273.         lseg   =  lre*lre*nbele1 + 16
  1274.         nblprt = (lseg-1)/ltrk+1
  1275. **      if (nblprt.eq.1 .and. nbele1.gt.20) nblprt = 2
  1276.         nblmax = (nbele1-1)/nblprt+1
  1277.         nblprt = (nbele1-1)/nblmax+1
  1278.  
  1279. c**        if (nblprt.gt.1) then
  1280. c**          write(ioimp,*) 'RIGI1 : IMODEL = ',imodel,isous
  1281. c**          write(ioimp,*) 'RIGI1 : nblprt nblmax = ',nblprt,nblmax,nbele1
  1282. c**        endif
  1283.  
  1284.         NRIGE0 = mrigid.IRIGEL(/2)
  1285.         nrigel = NRIGE0 + NBLPRT
  1286.         if (cmate.eq.'NLIN') nrigel = nrige0 + nrnlin*nblprt
  1287.         SEGADJ,MRIGID
  1288.         IPOI6 = MRIGID
  1289.  
  1290.         meleme = IPT1
  1291.         ipt3   = IPMAIG
  1292.         nbnn   = NBNOE1
  1293.         nbelem = NBELE1
  1294.         nbsous = 0
  1295.         nbref  = 0
  1296.  
  1297.         DO 505 iprt = 1, nblprt
  1298.  
  1299.           isou = isou+1
  1300.  
  1301.           if (nblprt.gt.1) then
  1302.             inelem = (iprt-1) * nblmax
  1303.             nbnn   = NBNOE1
  1304.             nbelem = MIN(nblmax,nbele1-inelem)
  1305. C            write(ioimp,*) ' creation segment ',nbnn,nbelem
  1306.             SEGINI,meleme
  1307.             meleme.itypel = ipt1.itypel
  1308.             do ielt = 1, nbelem
  1309.               jelt = ielt + inelem
  1310.               do inoe = 1, nbnn
  1311.                 num(inoe,ielt) = ipt1.num(inoe,jelt)
  1312.               enddo
  1313.               icolor(ielt) = ipt1.icolor(jelt)
  1314.             enddo
  1315.             IF (LDPGE) THEN
  1316.               ipt2   = IPMAIG
  1317.               nbnn   = NBNOEG
  1318. cc              nbelem = MIN(NBLMAX,NBELEG-inelem)
  1319.               SEGINI,ipt3
  1320.               ipt3.itypel = 28
  1321.               DO ielt = 1, nbelem
  1322.                 jelt = ielt + inelem
  1323.                 DO inoe = 1, nbnn
  1324.                   ipt3.num(inoe,ielt) = IPT2.NUM(inoe,jelt)
  1325.                 ENDDO
  1326.                 ipt3.icolor(ielt) = IPT2.ICOLOR(jelt)
  1327.               ENDDO
  1328.               SEGDES,IPT3
  1329.             ELSE
  1330.               ipt3 = meleme
  1331.             ENDIF
  1332.           endif
  1333.  
  1334.           nbnn   = NBNOE1
  1335.           ipmail = meleme
  1336.           ipmadg = ipt3
  1337.  
  1338. C* Tests faits avant normalement :
  1339.           IF (MELE.EQ.22)  GOTO 9991
  1340.           IF (MELE.EQ.259) GOTO 9991
  1341. C* Cas particulier des elements XFEM en cas de partition :
  1342. C* Il faut aussi partitionner le modele (nomme imoxfem)
  1343.           IF (MFR.EQ.63) THEN
  1344.             IF (nblprt.GT.1) THEN
  1345.               imoxfem = 0
  1346.               CALL PARTXR(IMODEL,ipmail,imoxfem)
  1347.             ELSE
  1348.               imoxfem = IMODEL
  1349.             ENDIF
  1350.           ENDIF
  1351. C=DEB==== FORMULATION HHO ==== Traitement particulier du modele ========
  1352.           IF (MFR.EQ.HHO_MFR_ELEMENT) THEN
  1353.             IF (nblprt.GT.1) THEN
  1354.               SEGINI,imode1=imodel
  1355.               imode1.imamod=ipmail
  1356.               imohho = imode1
  1357.               CALL HHOPAR(imohho,iret)
  1358.               if (iret.ne.0) return
  1359.             ELSE
  1360.               imohho = IMODEL
  1361.             ENDIF
  1362.           ENDIF
  1363. C=FIN==== FORMULATION HHO ==============================================
  1364.  
  1365. C       TRAITEMENT DES CHAMPS EN ENTREE
  1366. C       -------------------------------
  1367. C  >>>     CHAMP DE MATRICES DE HOOKE
  1368. C
  1369.         IF (IMAT.EQ.2) THEN
  1370.  
  1371.           CALL KOMCHA(IPCHOO,IPMAIL,CONM,MOMATR,MOTYMA,1,INFOS,3,IVAMAT)
  1372.           IF (IERR.NE.0) GOTO 9991
  1373.  
  1374.           MPTVAL=IVAMAT
  1375.           MELVAL=IVAL(1)
  1376.           NBGMAT=IELCHE(/1)
  1377.           NELMAT=IELCHE(/2)
  1378.  
  1379.           IF(IPCHE2.EQ.0.AND.ISUP.EQ.1)THEN
  1380.             CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  1381.             IF(IERR.NE.0)THEN
  1382.               ISUP=0
  1383.               GOTO 9991
  1384.             ENDIF
  1385.           ENDIF
  1386. C
  1387. C   >>>  CHAMP DE MATERIAU
  1388. C
  1389.         ELSE
  1390.  
  1391.           CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYMA,1,INFOS,3,IVAMAT)
  1392.           IF (IERR.NE.0) GOTO 9991
  1393.  
  1394.           IF (ISUP.EQ.1)THEN
  1395.             CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  1396.             IF(IERR.NE.0)THEN
  1397.               ISUP=0
  1398.               GOTO 9991
  1399.             ENDIF
  1400.           ENDIF
  1401. C
  1402.           MPTVAL=IVAMAT
  1403. C
  1404.           if (cmate.eq.'STATIQUE'.or.cmate.eq.'MODAL') then
  1405. c*NU        Test inutile car KOMCHA sort en erreur s'il ne trouve pas les composantes demandees
  1406.             if (ival(/1).lt.3) then
  1407.               moterr(1:50) = ' erreur modal ou statique '
  1408.               call erreur(-385)
  1409.               call erreur(5)
  1410.               return
  1411.             endif
  1412.             if (cmate.eq.'STATIQUE') then
  1413.               kstat = kstat + 1
  1414.               ivstat(kstat) = ivamat
  1415.               pistat(kstat) = imodel
  1416.               if (kstat.eq.nstat) then
  1417.                 nstat = nstat + 100
  1418.                 segadj modsta
  1419.               endif
  1420.             else if (cmate.eq.'MODAL') then
  1421.               kmoda = kmoda + 1
  1422.               ivmoda(kmoda) = ivamat
  1423.               pimoda(kmoda) = imodel
  1424.               if (kmoda.eq.nmoda) then
  1425.                 nmoda = nmoda + 100
  1426.                 segadj modsta
  1427.               endif
  1428.             endif
  1429.           endif
  1430.  
  1431.           NBGMAT = 0
  1432.           NELMAT = 0
  1433.           IF (CMATE.EQ.'SECTION') THEN
  1434.             DO IM = 1,ival(/1)
  1435.               MELVAL = IVAL(IM)
  1436.               IF (MELVAL.NE.0) THEN
  1437.                 NBGMAT=MAX(NBGMAT,IELCHE(/1))
  1438.                 NELMAT=MAX(NELMAT,IELCHE(/2))
  1439.               ENDIF
  1440.             ENDDO
  1441.           ELSE
  1442.             DO IM=1,ival(/1)
  1443.               MELVAL = IVAL(IM)
  1444.               IF (MELVAL.NE.0) THEN
  1445.                 NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1446.                 NELMAT=MAX(NELMAT,VELCHE(/2))
  1447.               ENDIF
  1448.             ENDDO
  1449.           ENDIF
  1450.         ENDIF
  1451. C
  1452. C   >>>     CHAMPS DE CARACTERISTIQUES
  1453. C
  1454.         IF (IPCHE1.NE.0.AND.MOCARA.NE.0)  THEN
  1455.           CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYCA,1,INFOS,3,IVACAR)
  1456.           IF (IERR.NE.0) GOTO 9991
  1457. C
  1458.           IF (ISUP.EQ.1) THEN
  1459.             CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  1460.             IF(IERR.NE.0)THEN
  1461.               ISUP=0
  1462.               GOTO 9991
  1463.             ENDIF
  1464.           ENDIF
  1465.         ENDIF
  1466.  
  1467. C* Voir si cette partie de tests ne pourrait etre mise lors de la 
  1468. C* construction de MOCARA (composante facultative/obligatoire) !
  1469.         IF (IVACAR.EQ.0) THEN
  1470. *
  1471. *  AM  11/06/16  VERIFICATION DE LA PRESENCE DES CARACTERTISTIQUES
  1472. *                POUR LES ELEMENTS TYPE POUTRE ET ASSIMILES
  1473. *                NECESSAIRE AUSSI EN CAS DE MATRICE DE HOOKE
  1474.  
  1475.            IF(MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.84
  1476.      &       .OR.MELE.EQ.97) THEN
  1477.                 CALL ERREUR (404)
  1478.                 GO TO 9991
  1479.            ENDIF
  1480.  
  1481.            IF(MFR.EQ.75.AND.IMAT.EQ.2) THEN
  1482.               CALL ERREUR (404)
  1483.               GO TO 9991
  1484.            ENDIF
  1485.         ENDIF
  1486.         MPTVAL = IVACAR
  1487.  
  1488. C cas particuliers des XFEM
  1489.         IF (MFR.EQ.63) GOTO 63
  1490.  
  1491. C=DEB==== FORMULATION HHO ==== Cas particulier de la formulation =======
  1492.         IF (MFR.EQ.HHO_MFR_ELEMENT) GOTO 89
  1493. C=FIN==== FORMULATION HHO ==============================================
  1494.  
  1495. C NAVIER_STOKES NLIN
  1496.         if (cmate.eq.'NLIN') then
  1497.           segact mmode1*mod
  1498.           mmode1.kmodel(1) = imodel
  1499.           mchel1.conche(1) = conm
  1500.           mchel1.imache(1) = ipmail
  1501.           mptval = ivamat
  1502.           nomid = momatr
  1503.           do jj = 1,n2
  1504.             mcham1.nomche(jj) = lesobl(jj)
  1505.             mcham1.typche(jj) = tyval(jj)
  1506.             mcham1.ielval(jj) = ival(jj)
  1507.           enddo
  1508.  
  1509.           ipmons = mmode1
  1510.           ipchns = mchel1
  1511.           if (noerjk.eq.2) then
  1512.             call go2nli(ipmons,ipchns,iprins,3)
  1513.           else
  1514.             call go2nli(ipmons,ipchns,iprins,1)
  1515.           endif
  1516.           if (ierr.ne.0) return
  1517.  
  1518.           goto 2999
  1519.         endif
  1520.  
  1521. C-----------------------------------------------------------------------
  1522. C                          P H A S E   2
  1523. C
  1524. C                 PREPARATION DES OBJETS RESULTATS
  1525. C
  1526. C-----------------------------------------------------------------------
  1527. C
  1528.  2999  if (cmate.eq.'NLIN') then
  1529.            RI3 = iprins
  1530.            segact ri3
  1531.            if (ri3.coerig(/1).ne.nrnlin) then
  1532. c             write(6,*) 'ri3',ri3.coerig(/1),nrnlin
  1533.              call erreur(5)
  1534.              return
  1535.            endif
  1536.            isou = isou - 1
  1537.            do kige = 1,nrnlin
  1538.              ipdesc = ri3.IRIGEL(3,kige)
  1539.              ipmatr = ri3.IRIGEL(4,kige)
  1540.              isymm = ri3.irigel(7,kige)
  1541.  
  1542.           isou = isou + 1
  1543.           jrige = isou
  1544.           COERIG(jrige)   = ri3.coerig(kige)
  1545.           IRIGEL(1,jrige) = ipmail
  1546.           IRIGEL(2,jrige) = 0
  1547.           IRIGEL(3,jrige) = ipdesc
  1548.           IRIGEL(4,jrige) = ipmatr
  1549.           IRIGEL(5,jrige) = NIFOUR
  1550.           IRIGEL(6,jrige) = 0
  1551.           IRIGEL(7,jrige) = ri3.irigel(7,kige)
  1552.           IRIGEL(8,jrige) = 0
  1553.            enddo
  1554.         else
  1555. C
  1556. C    INITIALISATION DU SEGMENT  XMATRI
  1557. C
  1558.          NELRIG = NBELEM
  1559.          SEGINI XMATRI
  1560.          IPMATR=XMATRI
  1561.  
  1562.          IRIGEL(1,ISOU)=IPMADG
  1563.          IRIGEL(2,ISOU)=0
  1564.          IRIGEL(3,ISOU)=IPDSCR
  1565.          IRIGEL(4,ISOU)=IPMATR
  1566.          IRIGEL(5,ISOU)=NIFOUR
  1567.          IRIGEL(6,ISOU)=0
  1568.          IRIGEL(7,ISOU)=0
  1569.          xmatri.symre=0
  1570.          IF(MFR.EQ.57.OR.MFR.EQ.59) THEN
  1571.            IRIGEL(7,ISOU)=2
  1572.          ENDIF
  1573.          COERIG(ISOU)=1.D0
  1574. C         SEGDES XMATRI
  1575.        endif
  1576. C
  1577. C rendement anisotrope kich
  1578.          if(ivacar.ne.0) then
  1579.          mptval = ivacar
  1580.          if(ival(/1).ge.NCAR1+9) then
  1581.          if (ival(NCAR1+7).gt.0.or.ival(NCAR1+8).gt.0.or.
  1582.      & ival(NCAR1+9).gt.0) then
  1583.             irigel(7,isou)=2
  1584.             xmatri.symre=2
  1585.          endif
  1586.          endif
  1587.          endif
  1588.  
  1589.          if (dcmate) goto 29
  1590. C
  1591. C-----------------------------------------------------------------------
  1592. C                        P H A S E   3
  1593. C
  1594. C              CALCUL DES RIGIDITES ELEMENTAIRES
  1595. C
  1596. C-----------------------------------------------------------------------
  1597. C
  1598. C     NUMERO DES ETIQUETTES      :
  1599. C     Les elements sont groupes comme suit :
  1600. C      - massif,liquide 'surface libre' poreux ----------------------> r
  1601. C      - coq3,dkt,coq4,coq8,coq2,dst --------------------------------> r
  1602. C      - poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,jot3> r
  1603. C      - joi4,joi2,poutre de timoschenko,joi3
  1604. C
  1605.       IF(MELE.GE.1.AND.MELE.LE.100) THEN
  1606. C            CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8
  1607.       GOTO (   99,  99,  99,   4,  99,   4,  99,   4,  99,   4
  1608. C            QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6
  1609.      .      ,  99,  12,  99,   4,   4,   4,   4,  12,  12,  99
  1610. C            LIA8 MULT TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP
  1611.      .      ,  99,  99,   4,   4,   4,   4,  27,  27,  29,  29
  1612. C            FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5
  1613.      .      ,  99,  99,  99,  99,   4,   4,   4,   4,   4,   4
  1614. C            COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM
  1615.      .      ,  27,  29,  29,  27,  29,  29,  12,   4,  27,  29
  1616. C            COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6
  1617.      .      ,  99,  99,   4,   4,  12,  27,  99,  99,  99,  99
  1618. C            CVQ4 CVQ8 THP5 TH13 THP6 TH15 THC8 TH20 ICT3 ICQ4
  1619.      .      ,  99,  99,  99,  99,  99,  99,  99,  99,   4,   4
  1620. C            ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 IC15 TRIP QUAP
  1621.      .      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  1622. C            CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8
  1623.      .      ,   4,   4,   4,  29,  29,  29,  29,  29,  99,  99
  1624. C            LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4
  1625.      .      ,  99,  29,  27,  12,  29,  29,  29,  29,  99,  99)
  1626. c cccccc
  1627.      .      ,MELE
  1628.       ELSEIF(MELE.GE.101.AND.MELE.LE.200) THEN
  1629. C           HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  1630.       GOTO (   99,  99,  99,  99,  99,  99,  99,   4,   4,   4
  1631. C            POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12
  1632.      .      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  1633. C            PO13 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3
  1634.      .      ,   4,   4,  29,  29,  29,  29,  29,  99,  99,  99
  1635. C            QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18
  1636.      .      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  1637. C            MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6
  1638.      .      ,  99,  99,  99, 505, 505,  99,  99,  99,  99,  99
  1639. C            TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5
  1640.      .      ,  99,  99,  99,  99,  99,  99,  29,  51,  51,  51
  1641. C            BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2
  1642.      .      ,  51,  51,  51,  51,  51,  51,  51,  29,  29,  29
  1643. C            JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR
  1644.      .      ,  29,  29,   4,   4,   4,   4,   4,   4,   4,   4
  1645. C            TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8
  1646.      .      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  1647. C            T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15
  1648.      .      ,  51,  51,   4,   4,  51,  51,  51,  51,  51,  51)
  1649. c cccccc
  1650.      .      ,MELE-100
  1651.       ELSEIF(MELE.GE.201.AND.MELE.LE.300) THEN
  1652. C            LC19 LS03 LS07 LS09 LS27 LS21 LS15 LS19 BS03 BS07
  1653.       GOTO (   51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  1654. C            BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21
  1655.      .      ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  1656. C            MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03
  1657.      .      ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  1658. C            MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27
  1659.      .      ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  1660. C            QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119
  1661.      .      ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  1662. C            QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8
  1663.      .      ,  51,  51,  51,  51,  51,  51,  51,  29,  51,  29
  1664. C            CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3
  1665.      .      ,  51,  51,  63,  63,  29,  29,  29,  29,  51,  51
  1666. C            COS2 COA2           CU27 PR21 TE15 PY19 C20R P15R
  1667.      .      ,  29,  29,   4,   4,   4,   4,   4,   4,   4,   4)
  1668. c cccccc
  1669.      .      ,MELE-200
  1670.       ENDIF
  1671. C cccccc
  1672. C
  1673.  51   CONTINUE
  1674.  99   CONTINUE
  1675.       MOTERR(1:4)=NOMTP(MELE)
  1676.       MOTERR(9:12)='RIGI1'
  1677.       CALL ERREUR(86)
  1678.       GOTO 9990
  1679. C_______________________________________________________________________
  1680. C
  1681. C     massif, liquide, 'surface libre', poreux
  1682. C_______________________________________________________________________
  1683. C
  1684.    4  CONTINUE
  1685.       IF (MFR .EQ. 71) THEN
  1686.         CALL RIGELE (MATE,MELE,NBPGAU,NSTRS,LRE,IPMAIL,IPMINT,IVAMAT,
  1687.      &               NMATT, IPMATR)
  1688.       ELSE IF (MFR .EQ. 73) THEN
  1689.         CALL RIGDIF (MATE,MELE,NBPGAU,NSTRS,LRE,IPMAIL,IPMINT,IVAMAT,
  1690.      &               NMATT, IPMATR)
  1691.       ELSE
  1692.         CALL RIGI2 (MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,IVAMAT,
  1693.      &              IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT,
  1694.      &              IPORE,NDDL,IPMATR,IIPDPG,NCAR1,MELPHA,noer)
  1695.       ENDIF
  1696.       GOTO 9990
  1697. C_______________________________________________________________________
  1698. C
  1699. C     ELTS DE RACCORD LIQUIDE SOLIDE  RAC2 RACO LIA3 LIA4 LICO LIC4
  1700. C          PAS DE RIGIDITE
  1701. C_______________________________________________________________________
  1702. C
  1703.   12  CONTINUE
  1704. C
  1705.       GOTO 9990
  1706. C_______________________________________________________________________
  1707. C
  1708. C     coq2,coq3,coq4,coq6,coq8,dst,dkt
  1709. C_______________________________________________________________________
  1710. C
  1711.   27  CONTINUE
  1712.       CALL RIGI3(MATE,MELE,IPMAIL,IPMINT,IPMIN1,NBPGAU,LRE,NSTRS,
  1713.      &          IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,
  1714.      &           NMATT,LW,NPINT,IPMATR,IIPDPG)
  1715.       GOTO 9990
  1716. C_______________________________________________________________________
  1717. C
  1718. C poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,joints 2-3D
  1719. C poutre de Timoschenko,point,joi1,zco2,zco3,zco4
  1720. C_______________________________________________________________________
  1721. C
  1722.   29  CONTINUE
  1723.       CALL RIGI4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
  1724.      &       IVAMAT,IVACAR,IVECT,CMATE,MFR,NBGMAT,NELMAT,IMAT,
  1725.      &       LHOOK,NMATT,(NCAR1 - 1),ISOUS,LW,IPORE,IPMATR,IIPDPG)
  1726.       GOTO 9990
  1727. C_______________________________________________________________________
  1728. C
  1729. C     Elements de type XFEM (MFR=63)
  1730. C_______________________________________________________________________
  1731. C Le sous programme RIGIXR gere les appels aux elements de type XFEM
  1732. C (imoxfem est le modele complet ou partitionne si necessaire)
  1733. C as 2009/11/30 : ajout de IMAT,NBGMAT,NELMAT en entree de RIGIXR
  1734. C Attention : ISOU peut etre modifie suite a appel a RIGIXR, ainsi que
  1735. C             la dimension de MRIGID en parallele !
  1736. C
  1737.  63   CONTINUE
  1738.       CALL RIGIXR (ISOU ,IPOI6,imoxfem,IPINF,
  1739.      $       IVAMAT,IVACAR,NMATT,CMATE,NCAR1,NBGMAT,NELMAT,IMAT,IRETER)
  1740.       IF (IRETER.NE.0) RETURN
  1741.       GO TO 9991
  1742.  
  1743. C=DEB==== FORMULATION HHO ==== Calcul des matrices de RIGIDITE =========
  1744.  89   CONTINUE
  1745.       CALL HHORIG (imohho, IPOI6, ISOU, IPDSCR,
  1746.      &             MATE,IVAMAT,NMATR, IVACAR,NCAR1, iret)
  1747.       IF (iret.NE.0) THEN
  1748.         CALL ERREUR(iret)
  1749.         RETURN
  1750.       END IF
  1751.       GOTO 9991
  1752. C=FIN==== FORMULATION HHO ==============================================
  1753. C
  1754. C-----------------------------------------------------------------------
  1755. C                        P H A S E   4
  1756. C
  1757. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  1758. C
  1759. C-----------------------------------------------------------------------
  1760. C
  1761.  9990 CONTINUE
  1762.       if (noer.eq.195) return
  1763.       if (ierr.ne.0) return
  1764.  
  1765. C     Forcer la symetrie lorsque les matrices sont symetriques
  1766.       ID1=RE(/1)
  1767.       ID2=RE(/2)
  1768.       ID3=RE(/3)
  1769.       ISY=SYMRE
  1770.       CALL VERSYM(RE,ID1,ID2,ID3,ISY)
  1771.  
  1772.       SEGDES,XMATRI
  1773.  
  1774.  9991 CONTINUE
  1775.       IF (IERR.NE.0) GOTO 518
  1776.  505    CONTINUE
  1777. C
  1778.  518  CONTINUE
  1779.        IF(ISUP.EQ.1)THEN
  1780.          CALL DTMVAL(IVACAR,3)
  1781.        ELSE
  1782.          CALL DTMVAL(IVACAR,1)
  1783.        ENDIF
  1784. C
  1785.        if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') goto 519
  1786.        IF(ISUP.EQ.1.AND.IMAT.NE.2)THEN
  1787.          CALL DTMVAL(IVAMAT,3)
  1788.        ELSE
  1789.          CALL DTMVAL(IVAMAT,1)
  1790.        ENDIF
  1791.  519   continue
  1792.  
  1793.         IF (MOCARA.NE.0) THEN
  1794.           nomid=MOCARA
  1795.           SEGSUP,nomid
  1796.         ENDIF
  1797.         notype = MOTYCA
  1798.         IF (notype .NE. MOTYR8) SEGSUP,notype
  1799. C
  1800.         IF (MOMATR.NE.0)THEN
  1801.           nomid = MOMATR
  1802.           IF (lsupma) SEGSUP,nomid
  1803.         ENDIF
  1804.         notype = MOTYMA
  1805.         IF (notype .NE. MOTYR8) SEGSUP,notype
  1806. C
  1807. C     DANS LE CAS D'ERREUR
  1808. C
  1809.         IF (IERR.NE.0) THEN
  1810.           IF (IPDSCR.NE.0) THEN
  1811.             DESCR = IPDSCR
  1812.             SEGSUP,DESCR
  1813.           ENDIF
  1814.           IF (xMATRI.NE.0) SEGSUP xMATRI
  1815.           GOTO 888
  1816.         ENDIF
  1817.  
  1818.   500 CONTINUE
  1819.  
  1820.       if (isou.NE.irigel(/2)) then
  1821.         nrigel=isou
  1822.         segadj,MRIGID
  1823.       endif
  1824.  
  1825. Ctermes croises  'STATIQUE'/'MODAL'
  1826.       nstat = kstat
  1827.       nmoda = kmoda
  1828.       segadj modsta
  1829.       if (kstat.ne.0) then
  1830.        if (nstat.gt.0.and.nstat+nmoda.gt.0) call ricroi(modsta, ir2,2)
  1831.        if (nstat.gt.0) then
  1832.         do kstat=1,nstat
  1833.           mptval = ivstat(kstat)
  1834.           IF(ISUP.EQ.1)THEN
  1835.             CALL DTMVAL(mptval,3)
  1836.           ELSE
  1837.             CALL DTMVAL(mptval,1)
  1838.           ENDIF
  1839.         enddo
  1840.        endif
  1841.        if (nmoda.gt.0) then
  1842.         do kmoda=1,nmoda
  1843.           mptval = ivmoda(kmoda)
  1844.           IF(ISUP.EQ.1)THEN
  1845.             CALL DTMVAL(mptval,3)
  1846.           ELSE
  1847.             CALL DTMVAL(mptval,1)
  1848.           ENDIF
  1849.         enddo
  1850.        endif
  1851.       endif
  1852.       if (nstat.gt.0.and.nstat+nmoda.gt.1) then
  1853.         ir1 = mrigid
  1854.         call fusrig(ir1,ir2,ir3)
  1855.         if (ierr.ne.0) goto 888
  1856.         mrigid = ir3
  1857.         ipoi6 = mrigid
  1858.       endif
  1859.  
  1860.   888 CONTINUE
  1861.       MRIGID = IPOI6
  1862.       IF (IERR.NE.0) THEN
  1863.         SEGSUP,MRIGID
  1864.         IPOI6 = 0
  1865.         IRET = 0
  1866.       ELSE
  1867.         SEGDES,MRIGID
  1868.         IRET = 1
  1869.       ENDIF
  1870.       segsup modsta
  1871.       segsup mmode1
  1872.       if (mchel1.ne.0) then
  1873.         mcham1 = mchel1.ichaml(1)
  1874.         segsup mcham1
  1875.         segsup mchel1
  1876.       endif
  1877.  
  1878.       notype = MOTYR8
  1879.       SEGSUP,notype
  1880.  
  1881.  889  CONTINUE
  1882.  
  1883. c      return
  1884.       END
  1885.  
  1886.  
  1887.  

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