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

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