Télécharger la plaquette Cast3M


fr en

Télécharger bsigmp.eso

Retour à la liste

Numérotation des lignes : 

bsigmp

  1. C BSIGMP    SOURCE    OF166741  24/05/06    21:15:03     11082          
  2.  
  3.       SUBROUTINE BSIGMP(IPMOD0,IPCHE1,IPCHE2,IPCHE3,IMAT,
  4.      1                  IPCHP4,IRET,noer)
  5. C_______________________________________________________________________
  6. C
  7. C  Entrees:
  8. C  ________
  9. C
  10. C     IPMOD0  Pointeur sur un MMODEL
  11. C     IPCHE1  Pointeur sur un MCHAML de contraintes
  12. C     IPCHE2  Pointeur sur un MCHAML de caracteristiques (FACULTATIF)
  13. C     IPCHE3  POINTEUR SUR UN MCHAML DE HOOKE (FACULTATIF)
  14. C     IMAT    Flag de HOOKE      (2 si oui, 1 sinon)
  15. C     IPCHP4  = 0 ou POINTEUR sur un CHPOINT de deplacements (FACULTATIF)
  16. C
  17. C  SORTIES:
  18. C  ________
  19. C
  20. C     IPCHP4  Pointeur sur un CHPOINT de forces aux noeuds
  21. C     IRET =  1  OU  0   suivant succes ou pas (Message d'erreur
  22. C                                               imprime dans ce cas)
  23. C
  24. C    Passage aux nouveaux CHAMELEMs par I.Monnier le 13.06.90
  25. C_______________________________________________________________________
  26. C
  27.       IMPLICIT INTEGER(I-N)
  28.       IMPLICIT REAL*8(A-H,O-Z)
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC CCHAMP
  33.  
  34. C==DEB= FORMULATION HHO == Includes specifiques ========================
  35. -INC CCHHOPA
  36. -INC CCHHOPR
  37. C==FIN= FORMULATION HHO ================================================
  38.  
  39. -INC SMMODEL
  40. -INC SMCHAML
  41. -INC SMCHPOI
  42. -INC SMELEME
  43. -INC SMINTE
  44. -INC SMLENTI
  45.       POINTEUR MLPHAS.MLENTI
  46. -INC SMCOORD
  47.  
  48.       SEGMENT INFO
  49.        INTEGER INFELL(JG)
  50.       ENDSEGMENT
  51.  
  52.       SEGMENT NOTYPE
  53.         CHARACTER*16 TYPE(NBTYPE)
  54.       ENDSEGMENT
  55.  
  56.       SEGMENT MPTVAL
  57.         INTEGER IPOS(NS)    ,NSOF(NS)
  58.         INTEGER      IVAL(NCOSOU)
  59.         CHARACTER*16 TYVAL(NCOSOU)
  60.       ENDSEGMENT
  61.  
  62. C==DEB= FORMULATION HHO == Pour FUSION champs HHO ======================
  63. C SID : SEGMENT A REMPLIR POUR FUNOBJ (voir le sp pour son contenu)
  64.       SEGMENT SID
  65.         INTEGER     IPOINT(NBFUS)
  66.         LOGICAL     BVAL  (NBFUS)
  67.         REAL*8      XVAL  (NBFUS)
  68.         CHARACTER*(IC1) CVAL  (NBFUS)
  69.         CHARACTER*8     CTYPE1,CREATE
  70.       ENDSEGMENT
  71. C==FIN= FORMULATION HHO ================================================
  72.  
  73. C==DEB= FORMULATION HHO == Chpoint de forces a chaque zone HHO =========
  74.       POINTEUR mlehho.mlenti
  75. C==FIN= FORMULATION HHO ================================================
  76.  
  77.       PARAMETER ( NINF=3 )
  78.       INTEGER INFOS(NINF)
  79.       CHARACTER*8 CMATE
  80.       CHARACTER*(NCONCH) CONM
  81.       LOGICAL BDPGE,ldpge,lsupfo,lsupco,lsupma,dcmate,b_z
  82.       LOGICAL dphas,dcont1,dcont2
  83.  
  84. C     On a besoin du MCOORD dans DOXE plus loin
  85.       SEGACT,MCOORD
  86.  
  87. C==DEB= FORMULATION HHO == Chpoint de deplacement ======================
  88.       IPCHPU = IPCHP4
  89. C==FIN= FORMULATION HHO ================================================
  90.  
  91.       IRET   = 0
  92.       IPCHP4 = 0
  93.       noer   = 0
  94.  
  95.       isup1  = 0
  96.       isup2  = 0
  97.       isup3  = 0
  98.       IRET   = 0
  99.       IPCHP4 = 0
  100.       mchaml = 0
  101.  
  102.       llent2 = 0
  103.       klent2 = 0
  104.       mlphas = 0
  105. C_______________________________________________________________________
  106. C
  107. C     ACTIVATION DU MODELE
  108. C_______________________________________________________________________
  109.  
  110. * On deroule le modele initial IPMOD0 et on ne garde que les sous-
  111. * modeles d interet -> on cree un nouveau modele IPMODL
  112.       CALL PIMODL(IPMOD0,IPMODL,1)
  113. C  IPMODL est ACTIF en retour (nouveau pointeur pouvant etre detruit)
  114.       if (ierr.ne.0) return
  115.       IF (IPMODL.EQ.0) then
  116.         call erreur(21)
  117.         RETURN
  118.       ENDIF
  119.  
  120.       mmodel = IPMODL
  121.       NSOUS = mmodel.kmodel(/1)
  122.  
  123. C==DEB= FORMULATION HHO == Quelques verifications ======================
  124.       kHHO   = 0
  125.       DO im = 1, NSOUS
  126.         imodel = mmodel.kmodel(im)
  127.         IF (imodel.nefmod.EQ.HHO_NUM_ELEMENT) kHHO = kHHO + 1
  128.       END DO
  129.       mleHHO = 0
  130.       IF (kHHO.GT.0) THEN
  131.         IF (IPCHPU.EQ.0) THEN
  132.           write(ioimp,*) 'HHO - BSIG: displacement field is missing!'
  133.           call erreur(21)
  134.           RETURN
  135.         END IF
  136.         CALL ACTOBJ('MAILLAGE',MPCHHO,1)
  137.         CALL ACTOBJ('MAILLAGE',MPFHHO,1)
  138.         CALL ACTOBJ('CHPOINT ',IPCHPU,1)
  139.         jg = NSOUS
  140.         SEGINI,mleHHO
  141.       END IF
  142. C==FIN= FORMULATION HHO ================================================
  143.  
  144. * Suport recherche = STRESSES
  145.       ISUPMO = 3
  146. *
  147. * Verification du lieu support des MCHAML
  148. *
  149. * Contraintes :
  150.       CALL QUESUP(IPMODL,IPCHE1,ISUPMO,0,ISUP1,iret1C)
  151.       IF (ISUP1.GT.1) RETURN
  152. * Caracteristiques :
  153.       IF (IPCHE2.NE.0) THEN
  154.         CALL QUESUP(IPMODL,IPCHE2,ISUPMO,0,ISUP2,ir)
  155.         IF (ISUP2.GT.1) RETURN
  156.       ENDIF
  157. * Matrice.Hooke :
  158.       IF (IPCHE3.NE.0) THEN
  159.         CALL QUESUP(IPMODL,IPCHE3,ISUPMO,1,ISUP3,ir)
  160.         IF (ISUP3.NE.0) RETURN
  161.       ENDIF
  162. C
  163. C     MCHAML DES CONTRAINTES
  164. C
  165.       mchel1 = IPCHE1
  166. C
  167. C     INITIALISATION DU MCHELM DE FORCES
  168. C
  169.       N1 = NSOUS
  170.       L1 = 6
  171.       N3 = 6
  172.       CALL oooprl(1)
  173.       SEGINI,mchelm
  174.       IPCHE5 = mchelm
  175.       mchelm.IFOCHE = IFOUR
  176.       mchelm.TITCHE = 'FORCES'
  177. C
  178. C  Cas des modes de calcul GENERALISES (2D et 1D) pour la mecanique :
  179. C  On cree un CHPOINT local pour les forces sur les points supports :
  180.       ICHPGE = 0
  181.       IF (IFOUR.EQ.-3) THEN
  182.         BDPGE = .TRUE.
  183.         NFORDG = 3
  184.         NC = NFORDG
  185.         SEGINI,msoupo
  186.         msoupo.NOCOMP(1) = 'FZ  '
  187.         msoupo.NOCOMP(2) = 'MY  '
  188.         msoupo.NOCOMP(3) = 'MX  '
  189.       ELSE IF (IFOUR.EQ.11) THEN
  190.         BDPGE = .TRUE.
  191.         NFORDG = 2
  192.         NC = NFORDG
  193.         SEGINI,msoupo
  194.         msoupo.NOCOMP(1) = 'FZ  '
  195.         msoupo.NOCOMP(2) = 'FY  '
  196.       ELSE IF (IFOUR.EQ.9.OR.IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  197.         BDPGE = .TRUE.
  198.         NFORDG = 1
  199.         NC = NFORDG
  200.         SEGINI,msoupo
  201.         msoupo.NOCOMP(1) = 'FZ  '
  202.       ELSE IF (IFOUR.EQ.7.OR.IFOUR.EQ.8) THEN
  203.         BDPGE = .TRUE.
  204.         NFORDG = 1
  205.         NC = NFORDG
  206.         SEGINI,msoupo
  207.         msoupo.NOCOMP(1) = 'FY  '
  208.       ELSE
  209.         BDPGE = .FALSE.
  210.         NFORDG = 0
  211.       ENDIF
  212. C On finit de remplir le CHPOINT en cas de DPGE :
  213.       IF (BDPGE) THEN
  214.         NSOUPO = 1
  215.         NAT = 1
  216.         SEGINI,mchpoi
  217.         mchpoi.MTYPOI = '     '
  218.         mchpoi.MOCHDE = '     '
  219.         mchpoi.JATTRI(1) = 2
  220.         mchpoi.IPCHP(1) = msoupo
  221.         mchpoi.IFOPOI = IFOUR
  222. C On cree un maillage de POI1 avec les points supports (sans redondance)
  223.         nbnn   = 1
  224.         nbelem = NSOUS
  225.         nbref  = 0
  226.         nbsous = 0
  227.         SEGINI,meleme
  228.         meleme.itypel = 1
  229.         N_DPGE = 0
  230.         K_DPGE = 0
  231.         DO im = 1, NSOUS
  232.           imodel = mmodel.kmodel(im)
  233.           iipdpg = imodel.IPDPGE
  234.           iipdpg = IPTPOI(iipdpg)
  235.           IF (iipdpg.GT.0) THEN
  236.             N_DPGE = N_DPGE + 1
  237.             meleme.num(1,N_DPGE) = iipdpg
  238.             K_DPGE = im
  239.             GOTO 1180
  240.           ENDIF
  241.         ENDDO
  242.         K_DPGE = NSOUS+1
  243.  1180   CONTINUE
  244.         DO im = K_DPGE+1, NSOUS
  245.           imodel = mmodel.kmodel(im)
  246.           iipdpg = imodel.IPDPGE
  247.           iipdpg = IPTPOI(iipdpg)
  248.           IF (iipdpg.LE.0) GOTO 1190
  249.           DO jm = 1, N_DPGE
  250.             IF (iipdpg.EQ.meleme.num(1,jm)) GOTO 1190
  251.           ENDDO
  252.           N_DPGE = N_DPGE + 1
  253.           meleme.num(1,N_DPGE) = iipdpg
  254.  1190     CONTINUE
  255.         ENDDO
  256.         IF (N_DPGE.NE.NSOUS) THEN
  257.           nbelem = N_DPGE
  258.           SEGADJ,meleme
  259.         ENDIF
  260.         msoupo.IGEOC = meleme
  261. C On cree les valeurs de forces GENE nulles au depart :
  262.         N = N_DPGE
  263.         NC = NFORDG
  264.         SEGINI,mpoval
  265.         msoupo.IPOVAL = mpoval
  266.         ICHPGE = mchpoi
  267.       ENDIF
  268.       CALL oooprl(0)
  269.       K_DPGE = 0
  270.  
  271. C un petit segment toujours utile :
  272.       NBTYPE=1
  273.       SEGINI,NOTYPE
  274.       TYPE(1)='REAL*8'
  275.       MOTYR8 = NOTYPE
  276.  
  277. C_______________________________________________________________________
  278. C
  279. C     BOUCLE SUR LES SOUS ZONES
  280. C_______________________________________________________________________
  281. C
  282.       ISOUS = 0
  283. *
  284.       DO 200 KISOUS = 1, NSOUS
  285. *
  286. *   INITIALISATION
  287. *
  288.         IVAMAT=0
  289.         IVACAR=0
  290.         IVASTR=0
  291.         IVAFOR=0
  292.         MOMATR=0
  293.         MOCARA=0
  294.         MOSTRS=0
  295.         MOFORC=0
  296.         lsupfo=.false.
  297.         lsupco=.false.
  298.         lsupma=.true.
  299.         IPMINT=0
  300.         mophas = 0
  301. C
  302. C     TRAITEMENT DU MODELE
  303. C
  304.         imodel = mmodel.kmodel(KISOUS)
  305. c*        IF (imodel.formod(1).EQ.'LIAISON' .OR. nefmod.EQ.22) GOTO 200
  306. *
  307.         ISOUS  = ISOUS+1
  308.         MELE   = imodel.NEFMOD
  309. c pas de contribution
  310.         if (mele.eq.259) goto 200
  311.         IPMAIL = imodel.IMAMOD
  312.         CONM   = imodel.CONMOD
  313.         IIPDPG = imodel.IPDPGE
  314.         IIPDPG = IPTPOI(IIPDPG)
  315. C
  316. C     CREATION DU TABLEAU INFOS
  317. C
  318.         CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  319.         IF (IRTD.EQ.0) GOTO 9991
  320. C
  321.       if (formod(1).eq.'MELANGE'.and.CMATEE.EQ.'PARALLEL') then
  322.         mophas = lnomid(12)
  323.         nomid = mophas
  324.         nmpha = lesobl(/2)
  325.         nmphf = lesfac(/2)
  326.         jg = nmpha + nmphf
  327.         NPHAT=JG
  328.         if (mlphas.gt.0) then
  329. * verifie que le precedent melange a ete totalement traite
  330.           do iph = 1,mlphas.lect(/1)
  331.             if (mlphas.lect(iph).gt.0) then
  332. c       write(6,*) 'bsigmp-melange incompletement traite'           
  333.               call erreur(5)
  334.               return
  335.             endif
  336.           enddo
  337.           segadj mlphas
  338.         elseif (mlphas.eq.0) then
  339.           if (IPCHE2.gt.0) segini mlphas
  340.         endif
  341.           IVAPHA = 0
  342.           imoref = 0
  343.           imosou = imodel
  344. * associe phase et coefficient de phase
  345.           IF (IVAMOD(/1).GE.1) THEN
  346.             DO j = 1,IVAMOD(/1)
  347.               IF (TYMODE(j).EQ.'IMODEL  ') THEN
  348.                 IMODE1 = IVAMOD(j)
  349. *                SEGACT,IMODE1
  350.                 IF (IMODE1.FORMOD(1)(1:10).EQ.'MECANIQUE ' .OR.
  351.      &              IMODE1.FORMOD(1)(1:10).EQ.'POREUX    ' .OR.
  352.      &              IMODE1.FORMOD(1)(1:16).EQ.'ELECTROSTATIQUE ' .OR.
  353.      &              IMODE1.FORMOD(1)(1:10).EQ.'LIQUIDE   ' ) THEN
  354.                   do iph = 1,nmpha
  355.                     if (imode1.conmod(17:24).eq.lesobl(iph)) then
  356.                       if (mlphas.gt.0) mlphas.lect(iph) = imode1
  357.                       if (imoref.eq.0) imoref = imode1
  358.                     endif
  359.                   enddo
  360.                 ELSE
  361. C                  SEGDES,IMODE1
  362.                 ENDIF
  363.               ENDIF
  364.             ENDDO
  365.           ELSE
  366. c            write(6,*) 'traitement MELANGE - 1 '
  367.             call erreur(21)
  368.             return
  369.           ENDIF
  370.         if (imoref.eq.0) then
  371. c          write(6,*) 'traitement MELANGE - 2 '
  372.           call erreur(21)
  373.           return
  374.         endif
  375. C
  376.         if (IPCHE2.gt.0) then          
  377.           MOTYPE = MOTYR8
  378.           CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOPHAS,MOTYPE,0,INFOS,3,IVAPHA)
  379.           IF (IERR.NE.0) GOTO 9992
  380.           nomid = mophas
  381.           mptval = ivapha
  382.           dphas = .false.
  383.           do iph = 1,nmpha
  384.             if (ival(iph).eq.0) dphas = .true.
  385.           enddo
  386.         else
  387.           IVAPHA = 0
  388.         endif
  389.          if (ivapha.gt.0) then
  390.           mptval = IVAPHA
  391.           if (dphas) then
  392. * massif / manque proportions phases / imite imoref / conserve CONM
  393. *      write(6,*) 'attention pas trouve proportions de phases',conm
  394.         moterr(1:50) = 'attention pas trouve proportions de phases'
  395.         call erreur(-385)
  396.         interr(1) = imodel
  397.         moterr(1:16) = conm
  398.         moterr(17:24) = '        '
  399.         call erreur(-386) 
  400.  
  401.             imodel = imoref
  402.           elseif (ival(/1).ge.nmpha) then
  403.             goto 200
  404.           else
  405. c            write(6,*) 'traitement MELANGE - 3 '
  406.             call erreur(21)
  407.             return
  408.           endif
  409.          else
  410. * massif / pas de proportions phases / imite imoref / conserve CONM
  411.             imodel = imoref
  412.          endif
  413.           IF(ISUP.EQ.1)THEN
  414.             CALL VALCHE(IVAPHA,NPHAT,IPMINT,IPPORE,MOPHAS,MELE)
  415.             IF(IERR.NE.0)THEN
  416.               ISUP=0
  417.               GOTO 9991
  418.             ENDIF
  419.           ENDIF
  420.           IF (IERR.NE.0) GOTO 9992
  421.       endif
  422.  
  423.       iphas = 0
  424.       melpha = 0
  425.       if (mlphas.gt.0.and.ivapha.gt.0) then
  426.         mptval = ivapha
  427.         do iph =1,NPHAT
  428.           if (imodel.eq.mlphas.lect(iph)) then
  429.             iphas = iph
  430.             melpha = ival(iphas)
  431.             mlphas.lect(iph) = 0
  432.           endif
  433.         enddo
  434.       endif
  435. C
  436. C   COQUE INTEGREE OU PAS ?
  437. C
  438.         IF (INFMOD(/1).NE.0)THEN
  439.           NPINT = INFMOD(1)
  440.         ELSE
  441.           NPINT = 0
  442.         ENDIF
  443. C
  444. C     NATURE DU MATERIAU
  445. C
  446.         CMATE = CMATEE
  447.         MATE = IMATEE
  448.         INAT = INATUU
  449.         dcmate = .FALSE.
  450.         DO im = 1, imodel.matmod(/2)
  451.           IF (imodel.matmod(im).EQ.'IMPEDANCE') dcmate = .TRUE.
  452.         ENDDO
  453. C____________________________________________________________________
  454. C
  455. C     ACTIVATION DU MELEME
  456. C
  457.         MELEME = IPMAIL
  458.         if (dcmate) then
  459.           if (itypel.eq.1) mele = 45
  460.           if (itypel.eq.2) mele = 2
  461.         endif
  462.         NBNN   = meleme.NUM(/1)
  463.         NBELEM = meleme.NUM(/2)
  464. C_______________________________________________________________________
  465. C
  466. C     INFORMATIONS SUR L'ELEMENT FINI
  467. C_______________________________________________________________________
  468. C
  469. C Support : STRESSES = 3 sauf cas particulier(s)
  470.         ISUPMO = 3
  471.         IF (infmod(/1).lt.2+ISUPMO) then
  472.           CALL ELQUOI(MELE,0,ISUPMO,IPINF,IMODEL)
  473.           IF (IERR.NE.0) GOTO 9991
  474.           INFO=IPINF
  475.           NBPGAU= INFELL(4)
  476.           MINTE = INFELL(11)
  477.           MINTE1= INFELL(12)
  478.           MFR   = INFELL(13)
  479.           NSTRS = INFELL(16)
  480.           LHOOK = INFELL(10)
  481.           LW    = INFELL(7)
  482.           LRE   = INFELL(9)
  483.           IPORE = INFELL(8)
  484.           SEGSUP INFO
  485.         ELSE
  486.           NBPGAU= INFELE(4)
  487.           MINTE = infmod(5)
  488.           MINTE1= INFmod(8)
  489.           MFR   = INFELE(13)
  490.           NSTRS = INFELE(16)
  491.           LHOOK = INFELE(10)
  492.           LW    = INFELE(7)
  493.           LRE   = INFELE(9)
  494.           IPORE = INFELE(8)
  495.         ENDIF
  496.         if (MFR.EQ.73) then
  497.           ISUPMO = 6
  498.           call tshape(mele,'GAUSS',minte)
  499.           minte1 = 0
  500.           nbpgau = minte.poigau(/1) 
  501.         endif
  502.  
  503.         IPMINT= MINTE
  504.         IPMIN1= MINTE1
  505.         NHRM   = NIFOUR
  506.         IPPORE =0
  507.         IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) IPPORE = NBNN
  508.  
  509. C Informations en DPGE pour le (sous-)modele courant
  510. C Si ldpge est VRAI, alors ndpge = NFORDG, sinon ndpge = 0.
  511.         CALL INFDPG(MFR,IFOUR, ldpge,ndpge)
  512. C
  513. *        if(mele.ne.260) then
  514. *          NBNO=SHPTOT(/2)
  515. *        endif
  516. C
  517.         IMACHE(ISOUS) = IPMAIL
  518.         INFCHE(ISOUS,1)=0
  519.         INFCHE(ISOUS,2)=0
  520.         INFCHE(ISOUS,3)=NIFOUR
  521.         INFCHE(ISOUS,4)=IPMINT
  522.         INFCHE(ISOUS,5)=0
  523.         INFCHE(ISOUS,6)=ISUPMO
  524. C__________________________________
  525. C
  526. C     NOMS DE COMPOSANTES NECESSAIRES  ( CONTRAINTES )
  527. C_______________________________________________________________________
  528. C
  529.       if(lnomid(4).ne.0) then
  530.          mostrs=lnomid(4)
  531.          nomid=mostrs
  532.          nstr=lesobl(/2)
  533.          nfac=lesfac(/2)
  534.       else
  535.          lsupco=.true.
  536.         CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  537.          nomid=mostrs
  538.          segact nomid
  539.       endif
  540. C
  541.       if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  542. * recherche composante FMOD
  543.         if (llent2.eq.0) then
  544.            jg = NSOUS
  545.            jgl2 = jg
  546.            segini mlent2
  547.            llent2 = mlent2
  548.         endif
  549.         do im2 = 1, mchel1.imache(/1)
  550.           if (mchel1.imache(im2).eq.imamod.and.
  551.      &        mchel1.conche(im2).eq.conmod) then
  552.            mcham2 = mchel1.ichaml(im2)
  553.            do in2 = 1, mcham2.nomche(/2)
  554.              if (mcham2.nomche(in2)(1:4).eq.'FMOD') then
  555.                melva2 = mcham2.ielval(in2)
  556.                 if (klent2 + melva2.ielche(/2).gt.jgl2) then
  557.                  jgl2 = jgl2 + melva2.ielche(/2)
  558.                  jg = jgl2
  559.                  segadj mlent2
  560.                endif
  561.                do iel2 = 1,melva2.ielche(/2)
  562.                 klent2 = klent2 + 1
  563.                 mlent2.lect(klent2) = melva2.ielche(1,iel2)
  564.                enddo
  565.               goto 11
  566.              endif
  567.            enddo
  568.           endif
  569.         enddo
  570.  11     continue
  571. *JK truande le test komcha
  572.        IF(NSTRS.LT.1) THEN
  573.          CALL ERREUR(922)
  574.          GO TO 9990
  575.        ENDIF
  576.        mostrs0 = mostrs
  577.        if (ifomod.eq.6) then
  578.         nbrobl = 1
  579.         nbrfac = 1
  580.         segini nomid
  581.         lesobl(1) = 'EFFX'
  582.         lesfac(1) = 'IFFX'
  583.        else
  584.         nbrobl = 1
  585.         nbrfac = 0
  586.         segini nomid
  587.         lesobl(1) = 'EFFX'
  588.        endif
  589.        mostrs = nomid
  590.       else
  591.        IF(NSTR+NFAC.NE.NSTRS) THEN
  592.          CALL ERREUR(922)
  593.          GO TO 9990
  594.        ENDIF
  595.       endif
  596. C
  597. C     VERIFICATION DE LEUR PRESENCE
  598. C
  599.       MOTYPE = MOTYR8
  600.       icond = 0
  601.       if (melpha.gt.0) icond = 1
  602.       CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,icond,INFOS,3,IVASTR)
  603.       IF (IERR.NE.0) GOTO 9991
  604.  
  605.         if (melpha.eq.0) then
  606.           mptval = ivastr
  607.           nomid = mostrs
  608.            dcont1 = .false.
  609.            dcont2 = .false.
  610.           if (ival(/1).ge.lesobl(/2)) then
  611.            do ic = 1,lesobl(/2)
  612.             if (ival(ic).le.0) dcont1 = .true.  
  613.             if (ival(ic).gt.0) dcont2 = .true.  
  614.            enddo
  615.           else
  616.             dcont1 = .true.
  617.           endif
  618.           if (dcont1) then
  619.             if (dcont2) then
  620. c       write(6,*) ' composantes contraintes incompletes cons ',conmod
  621.               call erreur(21)
  622.               return
  623.             else
  624. * aucune composante de contrainte pour le constituant : au suivant
  625.               goto 200
  626.             endif
  627.           endif
  628.         endif
  629. C
  630.       if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  631.         mptval = ivastr
  632.         segact mptval*mod
  633.         ns = ipos(/1)
  634.         ncosou = 0
  635.         jg = ival(/1)
  636.         segini mlenti
  637.         do ico = 1,ival(/1)
  638.          if (ival(ico).gt.0) then
  639.            ncosou = ncosou + 1
  640.            lect(ncosou) = ival(ico)
  641.          endif
  642.         enddo
  643.         segadj mptval
  644.         do ico = 1,ncosou
  645.           ival(ico) = lect(ico)
  646.         enddo
  647.         segsup mlenti
  648.         segsup nomid
  649.         mostrs = mostrs0
  650.       endif
  651. C
  652.         IF (ISUP1.EQ.1) THEN
  653.           ifai=1
  654.           if( mele.eq.260.and.iret1c.eq.5) ifai=0
  655.           IF (ifai.eq.1) CALL VALCHE(IVASTR,NSTRS,IPMINT,IPPORE,
  656.      &                               MOSTRS,MELE)
  657.         ENDIF
  658. C_______________________________________________________________________
  659. C
  660. C     NOMS DE COMPOSANTES NECESSAIRES ( FORCES )
  661. C_______________________________________________________________________
  662. C
  663.       if(lnomid(2).ne.0) then
  664.         MOFORC = lnomid(2)
  665.         NOMID=MOFORC
  666.         nforc=lesobl(/2)
  667.         NFACF=LESFAC(/2)
  668.       else
  669.         lsupfo=.true.
  670.         CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NFACF)
  671.         NOMID=MOFORC
  672.         SEGACT NOMID
  673.       endif
  674. C
  675. C     CREATION DU MCHAML
  676. C
  677. C     CAS PARTICULIER DE LA DEFO PLANE GENE : RIEN SUR FZ MY MX
  678. C
  679. C*      NFOREF=NFORC
  680. C*      IF (ldpge) NFOREF = NFOREF - ndpge
  681.        NFOREF = NFORC - ndpge
  682. c      N2=NFOREF
  683. c bp: les composantes facultatives peuvent elles aussi exister !
  684. *  on ajustera apres bsigmx la taille reellement utilisee par la force
  685.       N2=NFOREF+NFACF
  686.       if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  687.        if (ncosou.lt.n2) then
  688. *jk : rustique
  689.          nfacf = 0
  690.          n2 = ncosou
  691.          nforef = ncosou
  692.        endif
  693.       endif
  694.  
  695. C==DEB= FORMULATION HHO ================================================
  696. C On va calculer directement le chpoint de forces pour chaque sous-zone.
  697. C On ne passe pas dans ce cas par un MCHAML de forces. On va le creer 
  698. C mais il sera vide dans les zones associees a la formulation HHO.
  699.       IF (MFR.EQ.HHO_MFR_ELEMENT .AND. MELE.EQ.HHO_NUM_ELEMENT) THEN
  700.         NFOREF = 0
  701.         NFAREF = 0
  702.         N2 = 0
  703.       END IF
  704. C==FIN= FORMULATION HHO ================================================
  705. C
  706. C      TAILLES DE MELVAL
  707. C
  708.       N1EL=NBELEM
  709.       N1PTEL=NBNN
  710.       NBPTEL=NBPGAU
  711.       NEL   =N1EL
  712. C
  713. C     CREATION DU MELVAL DE FORCES
  714. C
  715.       NS=1
  716. *      NCOSOU=NFOREF
  717.       NCOSOU=NFOREF+NFACF
  718.  
  719.       CALL oooprl(1)
  720.       SEGINI MCHAML
  721.       SEGINI MPTVAL
  722.       DO ICOMP=1,NCOSOU
  723.         N2PTEL=0
  724.         N2EL  =0
  725.         SEGINI MELVAL
  726.         IELVAL(ICOMP)=MELVAL
  727.         IVAL(ICOMP)=MELVAL
  728.       ENDDO
  729.       CALL oooprl(0)
  730.  
  731.       ICHAML(ISOUS)=MCHAML
  732.       IVAFOR=MPTVAL
  733.  
  734.       DO ICOMP=1,NFOREF
  735.         NOMCHE(ICOMP)=LESOBL(ICOMP)
  736.         TYPCHE(ICOMP)='REAL*8'
  737.       ENDDO
  738.  
  739.       if(NFACF .ne. 0) then
  740.         IFAC = 0
  741.         DO ICOMP=(NFOREF+1),N2
  742.           IFAC = IFAC + 1
  743.           NOMCHE(ICOMP)=LESFAC(IFAC)
  744.           TYPCHE(ICOMP)='REAL*8'
  745.         ENDDO
  746.       endif
  747. C____________________________________________________________________
  748. C
  749. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES                   *
  750. C____________________________________________________________________
  751.          NBROBL=0
  752.          NBRFAC=0
  753.          NOMID=0
  754.          IVECT=0
  755.  
  756. * Sauf indication contraire, les composantes sont toutes de type REAL*8
  757.          NOTYPE = MOTYR8
  758. *
  759. * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
  760. *
  761.          IF((MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.63.OR.
  762.      +      (MELE.GE.79.AND.MELE.LE.83)).AND.
  763.      +              IFOUR.EQ.-2)THEN
  764. *
  765.            NBRFAC=1
  766.            SEGINI NOMID
  767.            LESFAC(1)='DIM3'
  768. *
  769. * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  770. *
  771.          ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  772.            NBROBL=1
  773.            IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  774.              NBRFAC=2
  775.            ELSE
  776.              NBRFAC=1
  777.            ENDIF
  778.            SEGINI NOMID
  779.            LESOBL(1)='EPAI'
  780.            LESFAC(1)='EXCE'
  781.            IF(MFR.EQ.3.AND.IFOUR.EQ.-2)  LESFAC(2)='DIM3'
  782. *
  783. * SECTION POUR LES BARRES
  784. *
  785.          ELSE IF (MFR.EQ.27) THEN
  786.           IF(.NOT.dcmate)  THEN
  787.            NBROBL=1
  788.            SEGINI NOMID
  789.            LESOBL(1)='SECT'
  790.           ENDIF
  791. *
  792. * section, excentrements et orientation pour les barres excentrees
  793. *
  794.          ELSE IF (MFR.EQ.49) THEN
  795.              NBROBL=6
  796.              SEGINI NOMID
  797.              LESOBL(1)='SECT'
  798.              LESOBL(2)='EXCZ'
  799.              LESOBL(3)='EXCY'
  800.              LESOBL(4)='VX  '
  801.              LESOBL(5)='VY  '
  802.              LESOBL(6)='VZ  '
  803. *
  804. * raideurs locales et orientation pour l'element LIA2
  805. *              de liaison a 2 noeuds
  806. *
  807.           ELSE IF (MFR.EQ.51) THEN
  808.              NBROBL=9
  809.              SEGINI NOMID
  810.              LESOBL(1)='RLUX'
  811.              LESOBL(2)='RLUY'
  812.              LESOBL(3)='RLUZ'
  813.              LESOBL(4)='RLRX'
  814.              LESOBL(5)='RLRY'
  815.              LESOBL(6)='RLRZ'
  816.              LESOBL(7)='VX  '
  817.              LESOBL(8)='VY  '
  818.              LESOBL(9)='VZ  '
  819. *
  820. * CARACTERISTIQUES POUR LES POUTRES
  821. *
  822.          ELSE IF (MFR.EQ.7 ) THEN
  823.            if (dcmate) then
  824.                NBRFAC=6
  825.                SEGINI NOMID
  826.                LESFAC(1)='TORS'
  827.                LESFAC(2)='INRY'
  828.                LESFAC(3)='INRZ'
  829.                LESFAC(4)='VX'
  830.                LESFAC(5)='VY'
  831.                LESFAC(6)='VZ'
  832.                IVECT=1
  833.            else
  834.            IF (CMATE.EQ.'SECTION') THEN
  835.              NBRFAC=3
  836.              SEGINI NOMID
  837.              LESFAC(1)='VX'
  838.              LESFAC(2)='VY'
  839.              LESFAC(3)='VZ'
  840.              IVECT=1
  841. *
  842.            ELSEIF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  843.              NBROBL=2
  844.              NBRFAC=1
  845.              SEGINI NOMID
  846.              LESOBL(1)='SECT'
  847.              LESOBL(2)='INRZ'
  848.              LESFAC(1)='SECY'
  849. *
  850.            ELSE
  851.              NBROBL=4
  852.              NBRFAC=5
  853.              SEGINI NOMID
  854.              LESOBL(1)='TORS'
  855.              LESOBL(2)='INRY'
  856.              LESOBL(3)='INRZ'
  857.              LESOBL(4)='SECT'
  858.              LESFAC(1)='SECY'
  859.              LESFAC(2)='SECZ'
  860.              LESFAC(3)='VX'
  861.              LESFAC(4)='VY'
  862.              LESFAC(5)='VZ'
  863.              IVECT=1
  864.            ENDIF
  865.            endif
  866. *
  867. * CARACTERISTIQUES POUR LES TUYAUX
  868. *
  869.          ELSE IF (MFR.EQ.13) THEN
  870.            NBROBL=2
  871.            NBRFAC=5
  872.            SEGINI NOMID
  873.            LESOBL(1)='EPAI'
  874.            LESOBL(2)='RAYO'
  875.            LESFAC(1)='RACO'
  876.            LESFAC(2)='CISA'
  877.            LESFAC(3)='VX'
  878.            LESFAC(4)='VY'
  879.            LESFAC(5)='VZ'
  880.            IVECT=1
  881. *
  882. * CARACTERISTIQUES POUR LES LINESPRING
  883. *
  884.          ELSE IF (MFR.EQ.15) THEN
  885.            NBROBL=5
  886.            SEGINI NOMID
  887.            LESOBL(1)='EPAI'
  888.            LESOBL(2)='FISS'
  889.            LESOBL(3)='VX  '
  890.            LESOBL(4)='VY  '
  891.            LESOBL(5)='VZ  '
  892. *
  893. * CARACTERISTIQUES POUR LES TUYAUX FISSURES
  894. *
  895.          ELSE IF (MFR.EQ.17) THEN
  896.            NBROBL=9
  897.            SEGINI NOMID
  898.            LESOBL(1)='RAYO'
  899.            LESOBL(2)='EPAI'
  900.            LESOBL(3)='VX  '
  901.            LESOBL(4)='VY  '
  902.            LESOBL(5)='VZ  '
  903.            LESOBL(6)='VXF '
  904.            LESOBL(7)='VYF '
  905.            LESOBL(8)='VZF '
  906.            LESOBL(9)='ANGL'
  907. *
  908. * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES
  909. *
  910.          ELSE IF (MFR.EQ.37) THEN
  911.            IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  912.              NBROBL=4
  913.              SEGINI NOMID
  914.              LESOBL(1)='SCEL'
  915.              LESOBL(2)='SFLU'
  916.              LESOBL(3)='EPS '
  917.              LESOBL(4)='XINE'
  918.            ELSE
  919.              NBROBL=3
  920.              SEGINI NOMID
  921.              LESOBL(1)='SCEL'
  922.              LESOBL(2)='SFLU'
  923.              LESOBL(3)='EPS '
  924.            ENDIF
  925. *
  926. C     CARACTERISTIQUE POUR LES JOINTS GENE
  927. C
  928.          ELSE IF (MFR.EQ.55) THEN
  929.            NBROBL=0
  930.            NBRFAC=1
  931.            SEGINI NOMID
  932.            LESFAC(1)='EPAI'
  933. c
  934. c    element coaxial COS2 (3D pour liaison acier-beton)
  935. c
  936.          ELSE IF( MFR.EQ.78) THEN
  937.             NBROBL=1
  938.             NBRFAC=0
  939.             SEGINI NOMID
  940.             LESOBL(1)='SECT'
  941.  
  942. C==DEB= FORMULATION HHO ================================================
  943.         ELSE IF (MFR.EQ.HHO_MFR_ELEMENT) THEN
  944.           IF (MELE.EQ.HHO_NUM_ELEMENT) THEN
  945.             nbrobl = 2
  946.             nbrfac = 0
  947.             SEGINI,nomid
  948.             nomid.LESOBL(1) = 'PIHO'
  949.             nomid.LESOBL(2) = 'BHHO'
  950.             MOCARA = nomid
  951.             nbtype = 2
  952.             SEGINI,NOTYPE
  953.             notype.TYPE(1) = 'REAL*8          '
  954.             notype.TYPE(2) = 'POINTEURLISTREEL'
  955.           END IF
  956. C==FIN= FORMULATION HHO ================================================
  957.  
  958.          ENDIF 
  959.  
  960.        MOCARA=NOMID
  961. * rendement kich 09/01 /// a remettre en cause avec phases (kich 04/09)
  962.        if (MOCARA.EQ.0) then
  963.          nbrobl = 0
  964.          nbrfac = 0
  965.          segini nomid
  966.          mocara = nomid
  967.        endif
  968.  
  969.        MOTYPE = NOTYPE
  970.  
  971.          ifac = nbrfac
  972.          NCAR1=NBROBL + NBRFAC + 1
  973.          NBRFAC= nbrfac + 10
  974.          segadj nomid
  975.          lesfac(ifac + 1) = 'REND'
  976.          lesfac(ifac + 2) = 'W1X '
  977.          lesfac(ifac + 3) = 'W1Y '
  978.          lesfac(ifac + 4) = 'W1Z '
  979.          lesfac(ifac + 5) = 'W2X '
  980.          lesfac(ifac + 6) = 'W2Y '
  981.          lesfac(ifac + 7) = 'W2Z '
  982.          lesfac(ifac + 8) = 'REN1'
  983.          lesfac(ifac + 9) = 'REN2'
  984.          lesfac(ifac + 10)= 'REN3'
  985.        if (motype.ne.MOTYR8) then
  986.          notype = motype
  987.          nbtype = notype.type(/2) + 1
  988.          segadj notype
  989.          type(nbtype) = 'REAL*8'
  990.        endif
  991. *
  992.          NCARA=NBROBL
  993.          NCARF=NBRFAC
  994.          NCARR=NCARA+NCARF
  995.  
  996. C*       IF (MOCARA.NE.0)  THEN
  997.             IF (IPCHE2.gt.0)  THEN
  998.               icond = 1
  999.               if (ncara.le.0) icond = 0
  1000.                CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,icond,
  1001.      $                     INFOS,3,IVACAR)
  1002.                IF (IERR.NE.0) GOTO 9990
  1003.                IF (ISUP2.EQ.1.and.mele.ne.260) THEN
  1004.                  CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  1005.                  IF (IERR.NE.0)THEN
  1006.                    ISUP2=0
  1007.                    GOTO 9990
  1008.                  ENDIF
  1009.                ENDIF
  1010.             ELSE IF (NCARA.GT.0) THEN
  1011.                MOTERR(1:8)='CARACTER'
  1012.                MOTERR(9:12)=NOMTP(MELE)
  1013.                MOTERR(13:20)='BSIGMA'
  1014.                CALL ERREUR(145)
  1015.                GOTO 9990
  1016.             ENDIF
  1017.             if (motype.ne.MOTYR8) then
  1018.               notype = motype
  1019.               segsup,notype
  1020.             endif
  1021.             mptval = ivacar
  1022.             if (ivacar.gt.0) then
  1023.               dphas = .true.
  1024.               do iv = 1,ival(/1)
  1025.                 if (ival(iv).gt.0) dphas = .false. 
  1026.               enddo
  1027.               if (dphas) ivacar = 0
  1028.             endif
  1029.  
  1030. C____________________________________________________________________
  1031. C
  1032. *  RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE TRAVAIL *
  1033. *  UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST
  1034. C____________________________________________________________________
  1035. *
  1036.       NBGMAT = 0
  1037.       NELMAT = 0
  1038.       NMATR = 0
  1039.       NMATF = 0
  1040.       NMATT = 0
  1041.       IF(MELE.EQ.93.or.mele.eq.260)THEN
  1042.        IF (IMAT.EQ.2) THEN
  1043.          NBRFAC=0
  1044.          IF(CMATE.NE.'ISOTROPE')THEN
  1045.             NBROBL=3
  1046.             SEGINI NOMID
  1047.             LESOBL(1)='MAHO'
  1048.             LESOBL(2)='V1X '
  1049.             LESOBL(3)='V1Y '
  1050.             NBTYPE=3
  1051.             SEGINI NOTYPE
  1052.             TYPE(1)='POINTEURLISTREEL'
  1053.             TYPE(2)='REAL*8'
  1054.             TYPE(3)='REAL*8'
  1055.          ELSE
  1056.             NBROBL=1
  1057.             SEGINI NOMID
  1058.             LESOBL(1)='MAHO'
  1059.             NBTYPE=1
  1060.             SEGINI NOTYPE
  1061.             TYPE(1)='POINTEURLISTREEL'
  1062.          ENDIF
  1063.          MOMATR=NOMID
  1064.          MOTYPE=NOTYPE
  1065.          CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  1066.          SEGSUP NOTYPE
  1067.          IF (IERR.NE.0) GOTO 9990
  1068.          MPTVAL=IVAMAT
  1069.          MELVAL=IVAL(1)
  1070.          NBGMAT=IELCHE(/1)
  1071.          NELMAT=IELCHE(/2)
  1072.          NMATR=NBROBL
  1073.          NMATF=NBRFAC
  1074.          NMATT=NMATR+NMATF
  1075.        ELSE
  1076. C____________________________________________________________________
  1077. *
  1078. * SINON TRAITEMENT DES CHAMPS DE MATERIAU
  1079. C____________________________________________________________________
  1080. *
  1081.           NBROBL=0
  1082.           NBRFAC=0
  1083.           IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
  1084.              NBROBL=2
  1085.              SEGINI NOMID
  1086.              MOMATR=NOMID
  1087.              LESOBL(1)='YOUN'
  1088.              LESOBL(2)='NU  '
  1089.           ELSEIF(FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ORTHOTRO')THEN
  1090.             IF(INAT.EQ.67) THEN
  1091.                NBROBL=6
  1092.                SEGINI NOMID
  1093.                MOMATR=NOMID
  1094.                LESOBL(1)='YG1 '
  1095.                LESOBL(2)='YG2 '
  1096.                LESOBL(3)='NU12'
  1097.                LESOBL(4)='G12 '
  1098.                LESOBL(5)='V1X '
  1099.                LESOBL(6)='V1Y '
  1100.             ELSE
  1101.              if(lnomid(6).ne.0) then
  1102.                nomid=lnomid(6)
  1103.                momatr=nomid
  1104.                nbrobl=lesobl(/2)
  1105.                nbrfac=lesfac(/2)
  1106.                lsupma=.false.
  1107.              else
  1108.                CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC)
  1109.              endif
  1110.             ENDIF
  1111.           ENDIF
  1112.           NMATR=NBROBL
  1113.           NMATF=NBRFAC
  1114.          NMATT=NMATR+NMATF
  1115. *
  1116.         IF (MOMATR.NE.0) THEN
  1117.           MOTYPE = MOTYR8
  1118.          CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  1119.          IF (IERR.NE.0) GOTO 9990
  1120. *
  1121.          IF (ISUP2.EQ.1.and.mele.ne.260) THEN
  1122.               CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  1123.               IF (IERR.NE.0)THEN
  1124.                    ISUP2=0
  1125.                    GOTO 9990
  1126.               ENDIF
  1127.          ENDIF
  1128. *
  1129.         MPTVAL=IVAMAT
  1130.         NBGMAT = 0
  1131.         NELMAT = 0
  1132.         DO IM=1,NMATT
  1133.          IF(IVAL(IM).NE.0)THEN
  1134.             MELVAL=IVAL(IM)
  1135.             NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1136.             NELMAT=MAX(NELMAT,VELCHE(/2))
  1137.          ENDIF
  1138.         ENDDO
  1139.         ENDIF
  1140.        ENDIF
  1141.       ENDIF
  1142. C
  1143. C================================================
  1144. C
  1145. C      CAS D'UN JOINT UNIDIMENSIONNEL JOI1
  1146. C   Chargement des vecteurs situes dans les caracteristiques materiau
  1147. C
  1148. C================================================
  1149.        IF(MFR.EQ.75) THEN
  1150.          IF(IFOUR.EQ.2) THEN
  1151.              NBROBL=6
  1152.              NBRFAC=0
  1153.              SEGINI NOMID
  1154.              MOMATR=NOMID
  1155.              LESOBL(1)='V1X'
  1156.              LESOBL(2)='V1Y'
  1157.              LESOBL(3)='V1Z'
  1158.              LESOBL(4)='V2X'
  1159.              LESOBL(5)='V2Y'
  1160.              LESOBL(6)='V2Z'
  1161.              NMATR=NBROBL
  1162.              NMATF=NBRFAC
  1163.          ELSE IF(IFOUR.EQ.-2.OR.IFOUR.EQ.-1) THEN
  1164.              NBROBL=2
  1165.              NBRFAC=0
  1166.              SEGINI NOMID
  1167.              MOMATR=NOMID
  1168.              LESOBL(1)='V1X'
  1169.              LESOBL(2)='V1Y'
  1170.              NMATR=NBROBL
  1171.              NMATF=NBRFAC
  1172.          ENDIF
  1173.          MOTYPE=MOTYR8
  1174. *
  1175.          CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  1176.          IF (IERR.NE.0) GOTO 9990
  1177. *
  1178.           NMATT=NMATR+NMATF
  1179. *                                                                        C
  1180.           IF(ISUP1.EQ.1)THEN
  1181.             CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  1182.             IF(IERR.NE.0)THEN
  1183.                ISUP1=0
  1184.                GOTO 9990
  1185.             ENDIF
  1186.           ENDIF
  1187.           MPTVAL=IVAMAT
  1188.           NBGMAT = 0
  1189.           NELMAT = 0
  1190.           DO 11265 IM=1,NMATT
  1191.             IF(IVAL(IM).NE.0)THEN
  1192.               MELVAL=IVAL(IM)
  1193.               IF (CMATE.EQ.'SECTION') THEN
  1194.                 NBGMAT=MAX(NBGMAT,IELCHE(/1))
  1195.                 NELMAT=MAX(NELMAT,IELCHE(/2))
  1196.               ELSE
  1197.                 NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1198.                 NELMAT=MAX(NELMAT,VELCHE(/2))
  1199.               ENDIF
  1200.             ENDIF
  1201. 11265    CONTINUE
  1202.         nmattd=nmatt
  1203.         ivamtd= ivamat
  1204.        ENDIF
  1205.  
  1206. C_______________________________________________________________________
  1207. C
  1208. C     NUMERO DES ETIQUETTES      :
  1209. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  1210. C     Les elements sont groupes comme suit :
  1211. C      - massif, poreux, joints poreux,incompressibles --> BSIGM1
  1212. C      - coq3,dkt,coq4,coq8,coq2,jot3,joi4,joi2,joi3 ----> BSIGM2
  1213. C      - poutre,tuyau,linespring,tuyau fissure,barre ----> BSIGM3
  1214. c        et poutre Timoschenko, cos2, coa2
  1215. C_______________________________________________________________________
  1216. C
  1217.       IF(MELE.GE.1.AND.MELE.LE.100) THEN
  1218. C            CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8
  1219.       GOTO (   99,  29,  99,   4,  99,   4,  99,   4,  99,   4
  1220. C            QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6
  1221.      1      ,  99,  99,  99,   4,   4,   4,   4,  99,  99,  99
  1222. C            LIA8 MULT TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP
  1223.      2      ,  99,  99,   4,   4,   4,   4,  27,  27,  29,  29
  1224. C            FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5
  1225.      3      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  1226. C            COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM
  1227.      4      ,  27,  29,  29,  27,  29,  29,  99,  99,  27,  29
  1228. C            COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6
  1229.      5      ,  99,  99,  99,  99,  99,  27,  99,  99,  99,  99
  1230. C            CVQ4 CVQ8 THP5 TH13 THP6 TH15 THC8 TH20 ICT3 ICQ4
  1231.      6      ,  99,  99,  99,  99,  99,  99,  99,  99,   4,   4
  1232. C            ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 IC15 TRIP QUAP
  1233.      7      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  1234. C            CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8
  1235.      8      ,   4,   4,   4,  29,  27,  27,  27,  27,  99,  99
  1236. C            LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4
  1237.      9      ,  99,  99,  27,  99,  29,  29,  99,  99,  99,  99)
  1238. c cccccc
  1239.      .      ,MELE
  1240.       ELSEIF(MELE.GE.101.AND.MELE.LE.200) THEN
  1241. C            HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  1242.       GOTO (   99,  99,  99,  99,  99,  99,  99,   4,   4,   4
  1243. C            POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12
  1244.      1      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  1245. C            PO13 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3
  1246.      2      ,   4,   4,  29,  29,  29,  34,  34,  34,  34,  34
  1247. C            QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18
  1248.      3      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1249. C            MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6
  1250.      4      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1251. C            TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5
  1252.      5      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1253. C            BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2
  1254.      6      ,  34,  34,  34,  34,  34,  34,  34,  27,  27,  27
  1255. C            JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR
  1256.      7      ,  27,  27,   4,   4,   4,   4,   4,   4,   4,   4
  1257. C            TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8
  1258.      8      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  1259. C            T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15
  1260.      9      ,  34,  34,   4,   4,  34,  34,  34,  34,  34,  34)
  1261. c cccccc
  1262.      .      ,MELE-100
  1263.       ELSEIF(MELE.GE.201.AND.MELE.LE.300) THEN
  1264. C            LC19 LS03 LS07 LS09 LS27 LS21 LS15 LS19 BS03 BS07
  1265.       GOTO (   34,  34,  34,  34,  34,  34,  34,  34,  34,  34 
  1266. C            BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21
  1267.      1      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1268. C            MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03
  1269.      2      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1270. C            MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27
  1271.      3      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1272. C            QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119
  1273.      4      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1274. C            QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8
  1275.      5      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  29
  1276. C            CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3
  1277.      6      ,  34,  34,  34,  34,  29,  29,  29,  29,  99,  99
  1278. C            COS2 COA2 ICY5 IC13 CU27 PR21 TE15 PY19 C20R P15R
  1279.      7      ,  29,  29,   4,   4,   4,   4,   4,   4,   4,   4
  1280. C            HHO  .... .... .... .... .... .... .... .... ....
  1281.      8      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1282. C            ...  .... .... .... .... .... .... .... .... ....
  1283.      9      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34)
  1284. c cccccc
  1285.      .      ,MELE-200
  1286.       ENDIF
  1287. C
  1288.  34   CONTINUE
  1289. C Cas particulier de la DIFFUSION :
  1290.       IF (MFR.EQ.73) GOTO 4
  1291.  
  1292. C==DEB= FORMULATION HHO ================================================
  1293.       IF (MFR.EQ.HHO_MFR_ELEMENT) THEN
  1294.         IF (MELE.EQ.HHO_NUM_ELEMENT) THEN
  1295.           CALL HHOBSG(IMODEL, MOFORC, IVASTR,NSTRS,
  1296.      &                        IIPDPG, ADPG,BDPG,CDPG,
  1297.      &                        IVACAR,NCARA, IPMINT,NBPGAU,
  1298.      &                        IPCHPU, IVAFOR, iret)
  1299.           IF (iret.NE.0) THEN
  1300.             CALL ERREUR(iret)
  1301.             GOTO 9990
  1302.           END IF
  1303.           mleHHO.lect(ISOUS) = IVAFOR
  1304.           GOTO 510
  1305.         END IF
  1306.       END IF
  1307. C==FIN= FORMULATION HHO ================================================
  1308. C_______________________________________________________________________
  1309. C POUR les XFEM on fait un cas particuliers
  1310.         IF(MFR.EQ.63) THEN
  1311.  
  1312.           CALL BSIGMX (IMODEL,IVACAR,IVASTR,ncar1,NFORC,
  1313.      &         IVAFOR,ADPG,BDPG,CDPG,IIPDPG,IRETER)
  1314.           IF(IRETER.NE.0) RETURN
  1315.  
  1316.           MPTVAL = IVAFOR
  1317.           N1TOT = IPOS(/1)
  1318.           N1SUP = N1TOT - 1
  1319.           N2TOT = IVAL(/1)
  1320. * si le nombre de sous-zones fournies par BSIGMX doit augmenter...
  1321. c           write(6,*) N1TOT,N1SUP,N2TOT,N1,NFOREF,NFACF
  1322.           IF (N1SUP.ge.1) THEN
  1323.             N1 = N1 + N1SUP
  1324.             segadj,MCHELM
  1325.           ENDIF
  1326.  
  1327.           I2TOT = 0
  1328.           I1NN = 1
  1329.           DO I1=1,(1+N1SUP)
  1330.  
  1331. *          -cas ou la zone est vide
  1332.             if (IPOS(I1).eq.0) then
  1333.               N1 = N1 - 1
  1334.               segadj,MCHELM
  1335.               I2TOT = I2TOT + NSOF(I1)
  1336.               if(I1.eq.I1NN) I1NN=I1NN+1
  1337.  
  1338. *          -cas ou il faut remplir ICHAML avec MCHAM1 = copie du MCHAML pere
  1339.             else
  1340.               N2=NFOREF+NFACF
  1341.               segini,MCHAM1=MCHAML
  1342. *             la 1ere fois est reperee par I1NN
  1343.               if(I1.ne.I1NN)  ISOUS = ISOUS + 1
  1344.               ICHAML(ISOUS) = MCHAM1
  1345. c       write(6,*) 'bsigmp: creation de ICHAML(',ISOUS,')=',MCHAM1
  1346.               IMACHE(ISOUS) = IPOS(I1)
  1347.               N2 = NSOF(I1)
  1348.               segadj,MCHAM1
  1349.               do i2=1,N2
  1350.                  I2TOT = I2TOT + 1
  1351.                  MCHAM1.IELVAL(i2) = IVAL(I2TOT)
  1352.               enddo
  1353.             endif
  1354.           ENDDO
  1355.  
  1356. *         Quand on a fini avec cette zone on n oublie pas de supprimer
  1357. *         le MCHAML pere des MCHAM1.
  1358. c *         Dans le cas ou ils n ont pas ete utilises,
  1359. c *         les MELVAL du MCHAML pere peuvent etre supprimes aussi.
  1360. c           if (IPOS(1).eq.0) then
  1361. c             DO  IB=1,IELVAL(/1)
  1362. c               MELVAL=IELVAL(IB)
  1363. c               SEGSUP MELVAL
  1364. c             ENDDO
  1365. c           endif
  1366. *      -> cela semble etre une erreur car les melval sont utilises !!!
  1367.           SEGSUP MCHAML
  1368.  
  1369.           GO TO 510
  1370.         ENDIF
  1371. C fin des XFEM _________________________________________________________
  1372.  
  1373.    99 CONTINUE
  1374.       MOTERR(1:4)=NOMTP(MELE)
  1375.       MOTERR(5:12)='BSIGMA'
  1376.       CALL ERREUR(86)
  1377.       GOTO 9990
  1378. C_______________________________________________________________________
  1379. C
  1380. C     massifs, poreux, joints poreux, incompressibles
  1381. C_______________________________________________________________________
  1382. C
  1383.    4  CONTINUE
  1384.       IF (MFR.EQ.71) THEN
  1385.         CALL BSIGEL(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK,
  1386.      &              IVAFOR,NFORC)
  1387.       ELSE IF (MFR.EQ.73) THEN
  1388.         CALL BSIGDI(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK,
  1389.      &              IVAFOR,NFORC)
  1390.       ELSE
  1391.       CALL BSIGM1(IPMAIL,LRE,NSTRS,NBPGAU,MELE,MFR,IVASTR,IPMINT,
  1392.      &            IVACAR,IPORE,LHOOK,NFORC,IVAFOR,ADPG,BDPG,CDPG,
  1393.      &            IIPDPG,ncar1,melpha,noer)
  1394.       if (noer.eq.195) return
  1395.       ENDIF
  1396.       GOTO 510
  1397. C_______________________________________________________________________
  1398. C
  1399. C     coq3,dkt,coq4,coq8,coq2,dst,jot3,joi4,joi2,joi3
  1400. C_______________________________________________________________________
  1401. C
  1402.   27  CONTINUE
  1403.        if (dcmate) goto 29
  1404.       CALL BSIGM2(IPMAIL,LRE,NSTRS,IVASTR,LW,NBPGAU,IVACAR,CMATE,NBPTEL,
  1405.      & MELE,MFR,IPMINT,IPMIN1,IVAMAT,NMATT,NBGMAT,NELMAT,IMAT,NPINT,
  1406.      & NFORC,IVAFOR,ADPG,BDPG,CDPG,IIPDPG)
  1407.       GOTO 510
  1408. C_______________________________________________________________________
  1409. C
  1410. C     poutre,tuyau,linespring,tuyau fissure,barre,poutre Timoschenko
  1411. C     joi1, zone_cohesive, cos2, coa2
  1412. C_______________________________________________________________________
  1413. C
  1414.   29  CONTINUE
  1415.        ncaru = ncar1 - 1
  1416.       CALL BSIGM3(IPMAIL,LRE,NSTRS,LW,IVACAR,ncaru,IVECT,MELE,CMATE,
  1417.      &IVASTR,ISOUS,NBPGAU,NBPTEL,IPMINT,NFORC,IVAFOR,ADPG,BDPG,CDPG
  1418.      &,IIPDPG,ivamat,NMATT,MFR,dcmate)
  1419.       GOTO 510
  1420. C_______________________________________________________________________
  1421. C
  1422. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  1423. C_______________________________________________________________________
  1424. C
  1425.   510 CONTINUE
  1426. C
  1427. C  Cas des modes de calculs GENEralises :
  1428. C
  1429.       IF (ldpge) THEN
  1430.         K_DPGE = K_DPGE + 1
  1431.         mchpoi = ICHPGE
  1432.         msoupo = mchpoi.ipchp(1)
  1433.         ipt1   = msoupo.IGEOC
  1434.         DO im = 1, N_DPGE
  1435.           IF (iipdpg.EQ.ipt1.num(1,im)) GOTO 300
  1436.         ENDDO
  1437.         write(ioimp,*) 'BSIGMP - incoherence iipdpg / ipt1'
  1438.         CALL erreur(5)
  1439.  300    CONTINUE
  1440.         mpoval = msoupo.IPOVAL
  1441.         mpoval.vpocha(im,1) = mpoval.vpocha(im,1) + ADPG
  1442.         IF (NFORDG.GE.2) THEN
  1443.           mpoval.vpocha(im,2) = mpoval.vpocha(im,2) + BDPG
  1444.           IF (NFORDG.GE.3) THEN
  1445.             mpoval.vpocha(im,3) = mpoval.vpocha(im,3) + CDPG
  1446.           ENDIF
  1447.         ENDIF
  1448.       ENDIF
  1449.  
  1450.       IF(ISUP1.EQ.1)THEN
  1451.            CALL DTMVAL(IVASTR,3)
  1452.       ELSE
  1453.            CALL DTMVAL(IVASTR,1)
  1454.       ENDIF
  1455. *
  1456.       CALL DTMVAL(IVAFOR,1)
  1457. *
  1458.       IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN
  1459.            CALL DTMVAL(IVAMAT,3)
  1460.       ELSE
  1461.           CALL DTMVAL(IVAMAT,1)
  1462.       ENDIF
  1463. *
  1464.       IF(ISUP2.EQ.1)THEN
  1465.            CALL DTMVAL(IVACAR,3)
  1466.       ELSE
  1467.           CALL DTMVAL(IVACAR,1)
  1468.       ENDIF
  1469. *
  1470.       NOMID=MOSTRS
  1471.       if(MOSTRS.NE.0.AND.lsupco)SEGSUP NOMID
  1472.       NOMID=MOFORC
  1473.       if(MOFORC.NE.0.AND.lsupfo)SEGSUP NOMID
  1474.       NOMID=MOCARA
  1475.       IF (MOCARA.NE.0) SEGSUP NOMID
  1476.       NOMID=MOMATR
  1477.       IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID
  1478. *
  1479.       IF (IERR.NE.0) GO TO 9991
  1480. C
  1481.   200 CONTINUE
  1482. C_______________________________________________________________________
  1483. C
  1484. C     TRANSFORMATION DU CHAMELEM EN CHPOINT
  1485. C_______________________________________________________________________
  1486. C
  1487.       IF (NSOUS.NE.kHHO) CALL CHAMPO(IPCHE5,0,IPCHP4,IRET)
  1488.       if (ierr.ne.0) return
  1489.  
  1490. C==DEB= FORMULATION HHO ================================================
  1491.       IF (kHHO.GT.0) THEN
  1492.         NBFUS = kHHO
  1493.         IF (NSOUS.NE.kHHO) NBFUS = NBFUS + 1
  1494.         IF (NBFUS.EQ.1) THEN
  1495.           ipchp6 = 0
  1496.           DO im = 1, NSOUS
  1497.             ip = mleHHO.lect(im)
  1498.             IF (ip.NE.0) THEN
  1499.               if (ipchp6.ne.0) then
  1500.                 write(ioimp,*) 'BSIGMP-NBFUS-ipchp6'
  1501.                 call erreur(5)
  1502.                 return
  1503.               end if
  1504.               ipchp6 = ip
  1505.             END IF
  1506.           END DO
  1507.         ELSE
  1508.           ic1 = 0
  1509.           SEGINI,sid
  1510.           sid.CTYPE1 = 'CHPOINT '
  1511.           sid.CREATE = 'BSIGMA  '
  1512.           i = 0
  1513.           IF (NSOUS.NE.kHHO) THEN
  1514.             i = i + 1
  1515.             sid.IPOINT(i) = IPCHP4
  1516.           END IF
  1517.           DO im = 1, NSOUS
  1518.             ip = mleHHO.lect(im)
  1519.             IF (ip.NE.0) THEN
  1520.               i = i + 1
  1521.               sid.IPOINT(i) = ip
  1522.             END IF
  1523.           END DO
  1524.       if (i.ne.khho) write(ioimp,*) 'ERREUR HHO BSIG SID !'
  1525.           r_z = 0.
  1526.           b_z = .TRUE.
  1527.           CALL FUNOBJ(sid,ipchp6,r_z,b_z)
  1528.           IF (NSOUS.NE.kHHO) CALL DTCHPO(IPCHP4)
  1529.           SEGSUP,sid
  1530.         END IF
  1531.         IPCHP4 = ipchp6
  1532.         SEGSUP,mleHHO
  1533.       END IF
  1534. C==FIN= FORMULATION HHO ================================================
  1535. C
  1536. C   CAS des modes de calculs GENERALISEs :
  1537. C   ON ADDITIONNE LE CHPOINT RESULTANT DE LA TRANSFORMATION DU CHAMELEM
  1538. C   ET LE PETIT CHPOINT DES FORCES INTERNES AUx NOEUDs supports
  1539. C
  1540.       IF (BDPGE) THEN
  1541.         IF (K_DPGE.NE.0) THEN
  1542.           CALL ADCHPO(ICHPGE,IPCHP4,IPCHP6,1D0,1D0)
  1543.           CALL DTCHPO(IPCHP4)
  1544.           IPCHP4 = IPCHP6
  1545.         ENDIF
  1546.         CALL DTCHPO(ICHPGE)
  1547.       ENDIF
  1548. C
  1549.       IF (llent2.gt.0) then
  1550.         ipc1 = ipchp4
  1551.         jg = klent2
  1552.         segadj mlent2
  1553.         do ipj= 1,jg
  1554.           ipcj = mlent2.lect(ipj)
  1555.           if (ipcj.gt.0) then
  1556.            call adchpo(ipc1,ipcj,ipc2,1.D0,1.D0)
  1557.            call dtchpo(ipc1)
  1558.            ipc1 = ipc2
  1559.           endif
  1560.         enddo
  1561.         ipchp4 = ipc1
  1562.         segsup mlent2
  1563.       ENDIF
  1564.  
  1565. C     IPCHE5 est maintenant inutile !
  1566.       MCHELM = IPCHE5
  1567.       DO im=1,ICHAML(/1)
  1568.         MCHAML=mchelm.ICHAML(im)
  1569.         IF (MCHAML.GT.0) THEN
  1570.           DO jm=1,IELVAL(/1)
  1571.             MELVAL=mchaml.IELVAL(jm)
  1572.             SEGSUP,MELVAL
  1573.           ENDDO
  1574.           SEGSUP,MCHAML
  1575.         ENDIF
  1576.       ENDDO
  1577.       SEGSUP,MCHELM
  1578.  
  1579. C* Fin normale
  1580.       IRET = 1
  1581.       GOTO 9000
  1582. *
  1583. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  1584. *
  1585.  9990 CONTINUE
  1586. *
  1587.       IF(ISUP1.EQ.1)THEN
  1588.            CALL DTMVAL(IVASTR,3)
  1589.       ELSE
  1590.            CALL DTMVAL(IVASTR,1)
  1591.       ENDIF
  1592. *
  1593.       CALL DTMVAL(IVAFOR,3)
  1594. *
  1595.       IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN
  1596.            CALL DTMVAL(IVAMAT,3)
  1597.       ELSE
  1598.           CALL DTMVAL(IVAMAT,1)
  1599.       ENDIF
  1600. *
  1601.       IF(ISUP2.EQ.1)THEN
  1602.            CALL DTMVAL(IVACAR,3)
  1603.       ELSE
  1604.           CALL DTMVAL(IVACAR,1)
  1605.       ENDIF
  1606. *
  1607.       NOMID=MOSTRS
  1608.       if(MOSTRS.NE.0.AND.lsupco)SEGSUP NOMID
  1609.       NOMID=MOFORC
  1610.       if(MOFORC.NE.0.AND.lsupfo)SEGSUP NOMID
  1611.       NOMID=MOCARA
  1612.       IF (MOCARA.NE.0) SEGSUP NOMID
  1613.       NOMID=MOMATR
  1614.       IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID
  1615.  9991 CONTINUE
  1616.  9992 CONTINUE
  1617.       IRET = 0
  1618.  
  1619. C Dernieres desactivations avant de quitter :
  1620.  9000 CONTINUE
  1621.       mmodel = IPMODL
  1622.       SEGSUP,MMODEL
  1623.  
  1624.       NOTYPE = MOTYR8
  1625.       SEGSUP,NOTYPE
  1626.  
  1627. c      RETURN
  1628.       END
  1629.  
  1630.  
  1631.  

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