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

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