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

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