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

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