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    MB234859  25/09/08    21:15:05     12358          
  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= INFMOD(3)
  458.         MFR   = INFELE(13)
  459.         NSTRS = INFELE(16)
  460.         LHOOK = INFELE(10)
  461.         LW    = INFELE(7)
  462.         LRE   = INFELE(9)
  463.         IPORE = INFELE(8)
  464.         if (MFR.EQ.73) then
  465.           ISUPMO = 6
  466.           call tshape(mele,'GAUSS',minte)
  467.           minte1 = 0
  468.           nbpgau = minte.poigau(/1)
  469.         endif
  470.  
  471.         IPMINT= MINTE
  472.         IPMIN1= MINTE1
  473.         NHRM   = NIFOUR
  474.         IPPORE =0
  475.         IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) IPPORE = NBNN
  476.  
  477. C Informations en DPGE pour le (sous-)modele courant
  478. C Si ldpge est VRAI, alors ndpge = NFORDG, sinon ndpge = 0.
  479.         CALL INFDPG(MFR,IFOUR, ldpge,ndpge)
  480.  
  481.         IMACHE(ISOUS) = IPMAIL
  482.         INFCHE(ISOUS,1)=0
  483.         INFCHE(ISOUS,2)=0
  484.         INFCHE(ISOUS,3)=NIFOUR
  485.         INFCHE(ISOUS,4)=IPMINT
  486.         INFCHE(ISOUS,5)=0
  487.         INFCHE(ISOUS,6)=ISUPMO
  488. C__________________________________
  489. C
  490. C     NOMS DE COMPOSANTES NECESSAIRES  ( CONTRAINTES )
  491. C_______________________________________________________________________
  492. C
  493.         MOSTRS = lnomid(4)
  494.         if (mostrs.eq.0) then
  495.           write(ioimp,*) 'BSIGMP : MOSTRS=lnomid(4)=0 !',imodel
  496.           call erreur(5)
  497.         endif
  498.         nomid = mostrs
  499.         nstr  = nomid.lesobl(/2)
  500.         nfac  = nomid.lesfac(/2)
  501.  
  502.       if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  503. * recherche composante FMOD
  504.         if (llent2.eq.0) then
  505.            jg = NSOUS
  506.            jgl2 = jg
  507.            segini mlent2
  508.            llent2 = mlent2
  509.         endif
  510.         do im2 = 1, mchel1.imache(/1)
  511.           if (mchel1.imache(im2).eq.imamod.and.
  512.      &        mchel1.conche(im2).eq.conmod) then
  513.            mcham2 = mchel1.ichaml(im2)
  514.            do in2 = 1, mcham2.nomche(/2)
  515.              if (mcham2.nomche(in2)(1:4).eq.'FMOD') then
  516.                melva2 = mcham2.ielval(in2)
  517.                 if (klent2 + melva2.ielche(/2).gt.jgl2) then
  518.                  jgl2 = jgl2 + melva2.ielche(/2)
  519.                  jg = jgl2
  520.                  segadj mlent2
  521.                endif
  522.                do iel2 = 1,melva2.ielche(/2)
  523.                 klent2 = klent2 + 1
  524.                 mlent2.lect(klent2) = melva2.ielche(1,iel2)
  525.                enddo
  526.               goto 11
  527.              endif
  528.            enddo
  529.           endif
  530.         enddo
  531.  11     continue
  532. *JK truande le test komcha
  533.        IF(NSTRS.LT.1) THEN
  534.          CALL ERREUR(922)
  535.          GO TO 9990
  536.        ENDIF
  537.        mostrs0 = mostrs
  538.        if (ifomod.eq.6) then
  539.         nbrobl = 1
  540.         nbrfac = 1
  541.         segini nomid
  542.         lesobl(1) = 'EFFX'
  543.         lesfac(1) = 'IFFX'
  544.        else
  545.         nbrobl = 1
  546.         nbrfac = 0
  547.         segini nomid
  548.         lesobl(1) = 'EFFX'
  549.        endif
  550.        mostrs = nomid
  551.       else
  552.        IF(NSTR+NFAC.NE.NSTRS) THEN
  553.          CALL ERREUR(922)
  554.          GO TO 9990
  555.        ENDIF
  556.       endif
  557. C
  558. C     VERIFICATION DE LEUR PRESENCE
  559. C
  560.       MOTYPE = MOTYR8
  561.       icond = 0
  562.       if (melpha.gt.0) icond = 1
  563.       CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,icond,INFOS,3,IVASTR)
  564.       IF (IERR.NE.0) GOTO 9991
  565.  
  566.         if (melpha.eq.0) then
  567.           mptval = ivastr
  568.           nomid = mostrs
  569.            dcont1 = .false.
  570.            dcont2 = .false.
  571.           if (ival(/1).ge.lesobl(/2)) then
  572.            do ic = 1,lesobl(/2)
  573.             if (ival(ic).le.0) dcont1 = .true.  
  574.             if (ival(ic).gt.0) dcont2 = .true.  
  575.            enddo
  576.           else
  577.             dcont1 = .true.
  578.           endif
  579.           if (dcont1) then
  580.             if (dcont2) then
  581. c       write(6,*) ' composantes contraintes incompletes cons ',conmod
  582.               call erreur(21)
  583.               return
  584.             else
  585. * aucune composante de contrainte pour le constituant : au suivant
  586.               goto 200
  587.             endif
  588.           endif
  589.         endif
  590. C
  591.       if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  592.         mptval = ivastr
  593.         segact mptval*mod
  594.         nsr = ipos(/1)
  595.         ncosor = 0
  596.         jg = ival(/1)
  597.         segini mlenti
  598.         do ico = 1,ival(/1)
  599.          if (ival(ico).gt.0) then
  600.            ncosor = ncosor + 1
  601.            lect(ncosor) = ival(ico)
  602.          endif
  603.         enddo
  604.         segadj mptval
  605.         do ico = 1,ncosor
  606.           ival(ico) = lect(ico)
  607.         enddo
  608.         segsup mlenti
  609.         segsup nomid
  610.         mostrs = mostrs0
  611.       endif
  612. C
  613.         IF (ISUP1.EQ.1) THEN
  614.           ifai=1
  615.           if( mele.eq.260.and.iret1c.eq.5) ifai=0
  616.           IF (ifai.eq.1) CALL VALCHE(IVASTR,NSTRS,IPMINT,IPPORE,
  617.      &                               MOSTRS,MELE)
  618.         ENDIF
  619. C_______________________________________________________________________
  620. C
  621. C     NOMS DE COMPOSANTES NECESSAIRES ( FORCES )
  622. C_______________________________________________________________________
  623. C
  624.         MOFORC = lnomid(2)
  625.         if (MOFORC.eq.0) then
  626.           write(ioimp,*) 'BSIGMP : MOFORC=lnomid(2)=0 !',imodel
  627.           call erreur(5)
  628.         endif
  629.         nomid = MOFORC
  630.         NFORC = nomid.lesobl(/2)
  631.         nfacf = nomid.lesfac(/2)
  632. C
  633. C     CREATION DU MCHAML
  634. C
  635. C     CAS PARTICULIER DE LA DEFO PLANE GENE : RIEN SUR FZ MY MX
  636. C
  637. C*      NFOREF=NFORC
  638. C*      IF (ldpge) NFOREF = NFOREF - ndpge
  639.        NFOREF = NFORC - ndpge
  640. c      N2=NFOREF
  641. c bp: les composantes facultatives peuvent elles aussi exister !
  642. *  on ajustera apres bsigmx la taille reellement utilisee par la force
  643.       N2=NFOREF+NFACF
  644.       if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  645.        if (ncosor.lt.n2) then
  646. *jk : rustique
  647.          nfacf = 0
  648.          n2 = ncosor
  649.          nforef = ncosor
  650.        endif
  651.       endif
  652.  
  653. C==DEB= FORMULATION HHO ================================================
  654. C On va calculer directement le chpoint de forces pour chaque sous-zone.
  655. C On ne passe pas dans ce cas par un MCHAML de forces. On va le creer 
  656. C mais il sera vide dans les zones associees a la formulation HHO.
  657.       IF (MFR.EQ.HHO_MFR_ELEMENT .AND. MELE.EQ.HHO_NUM_ELEMENT) THEN
  658.         NFOREF = 0
  659.         NFAREF = 0
  660.         N2 = 0
  661.       END IF
  662. C==FIN= FORMULATION HHO ================================================
  663. C
  664. C      TAILLES DE MELVAL
  665. C
  666.       N1EL  =NBELEM
  667.       N1PTEL=NBNN
  668.       N2PTEL=0
  669.       N2EL  =0
  670.  
  671.       NBPTEL=NBPGAU
  672.       NEL   =N1EL
  673. C
  674. C     CREATION DU MELVAL DE FORCES
  675. C
  676.       NSR=1
  677.       NCOSOR=NFOREF+NFACF
  678.  
  679.       CALL oooprl(1)
  680.       SEGINI MCHAML
  681.       SEGINI MPTVAL
  682.       DO ICOMP=1,NCOSOR
  683.         SEGINI MELVAL
  684.         IELVAL(ICOMP)=MELVAL
  685.         IVAL(ICOMP)=MELVAL
  686.       ENDDO
  687.       CALL oooprl(0)
  688.  
  689.       ICHAML(ISOUS)=MCHAML
  690.       IVAFOR=MPTVAL
  691.  
  692.       DO ICOMP=1,NFOREF
  693.         NOMCHE(ICOMP)=LESOBL(ICOMP)
  694.         TYPCHE(ICOMP)='REAL*8'
  695.       ENDDO
  696.  
  697.       if(NFACF .ne. 0) then
  698.         IFAC = 0
  699.         DO ICOMP=(NFOREF+1),N2
  700.           IFAC = IFAC + 1
  701.           NOMCHE(ICOMP)=LESFAC(IFAC)
  702.           TYPCHE(ICOMP)='REAL*8'
  703.         ENDDO
  704.       endif
  705. C____________________________________________________________________
  706. C
  707. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES                   *
  708. C____________________________________________________________________
  709.          NBROBL=0
  710.          NBRFAC=0
  711.          NOMID=0
  712.          IVECT=0
  713.  
  714. * Sauf indication contraire, les composantes sont toutes de type REAL*8
  715.          NOTYPE = MOTYR8
  716. *
  717. * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
  718. *
  719.          IF((MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.63.OR.
  720.      +      (MELE.GE.79.AND.MELE.LE.83)).AND.
  721.      +              IFOUR.EQ.-2)THEN
  722. *
  723.            NBRFAC=1
  724.            SEGINI NOMID
  725.            LESFAC(1)='DIM3'
  726. *
  727. * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  728. *
  729.          ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  730.            NBROBL=1
  731.            IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  732.              NBRFAC=2
  733.            ELSE
  734.              NBRFAC=1
  735.            ENDIF
  736.            SEGINI NOMID
  737.            LESOBL(1)='EPAI'
  738.            LESFAC(1)='EXCE'
  739.            IF(MFR.EQ.3.AND.IFOUR.EQ.-2)  LESFAC(2)='DIM3'
  740. *
  741. * SECTION POUR LES BARRES
  742. *
  743.          ELSE IF (MFR.EQ.27) THEN
  744.           IF(.NOT.dcmate)  THEN
  745.            NBROBL=1
  746.            SEGINI NOMID
  747.            LESOBL(1)='SECT'
  748.           ENDIF
  749. *
  750. * section, excentrements et orientation pour les barres excentrees
  751. *
  752.          ELSE IF (MFR.EQ.49) THEN
  753.              NBROBL=6
  754.              SEGINI NOMID
  755.              LESOBL(1)='SECT'
  756.              LESOBL(2)='EXCZ'
  757.              LESOBL(3)='EXCY'
  758.              LESOBL(4)='VX  '
  759.              LESOBL(5)='VY  '
  760.              LESOBL(6)='VZ  '
  761. *
  762. * raideurs locales et orientation pour l'element LIA2
  763. *              de liaison a 2 noeuds
  764. *
  765.           ELSE IF (MFR.EQ.51) THEN
  766.              NBROBL=9
  767.              SEGINI NOMID
  768.              LESOBL(1)='RLUX'
  769.              LESOBL(2)='RLUY'
  770.              LESOBL(3)='RLUZ'
  771.              LESOBL(4)='RLRX'
  772.              LESOBL(5)='RLRY'
  773.              LESOBL(6)='RLRZ'
  774.              LESOBL(7)='VX  '
  775.              LESOBL(8)='VY  '
  776.              LESOBL(9)='VZ  '
  777. *
  778. * CARACTERISTIQUES POUR LES POUTRES
  779. *
  780.          ELSE IF (MFR.EQ.7 ) THEN
  781.            if (dcmate) then
  782.                NBRFAC=6
  783.                SEGINI NOMID
  784.                LESFAC(1)='TORS'
  785.                LESFAC(2)='INRY'
  786.                LESFAC(3)='INRZ'
  787.                LESFAC(4)='VX'
  788.                LESFAC(5)='VY'
  789.                LESFAC(6)='VZ'
  790.                IVECT=1
  791.            else
  792.            IF (CMATE.EQ.'SECTION') THEN
  793.              NBRFAC=3
  794.              SEGINI NOMID
  795.              LESFAC(1)='VX'
  796.              LESFAC(2)='VY'
  797.              LESFAC(3)='VZ'
  798.              IVECT=1
  799. *
  800.            ELSEIF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  801.              NBROBL=2
  802.              NBRFAC=1
  803.              SEGINI NOMID
  804.              LESOBL(1)='SECT'
  805.              LESOBL(2)='INRZ'
  806.              LESFAC(1)='SECY'
  807. *
  808.            ELSE
  809.              NBROBL=4
  810.              NBRFAC=5
  811.              SEGINI NOMID
  812.              LESOBL(1)='TORS'
  813.              LESOBL(2)='INRY'
  814.              LESOBL(3)='INRZ'
  815.              LESOBL(4)='SECT'
  816.              LESFAC(1)='SECY'
  817.              LESFAC(2)='SECZ'
  818.              LESFAC(3)='VX'
  819.              LESFAC(4)='VY'
  820.              LESFAC(5)='VZ'
  821.              IVECT=1
  822.            ENDIF
  823.            endif
  824. *
  825. * CARACTERISTIQUES POUR LES TUYAUX
  826. *
  827.          ELSE IF (MFR.EQ.13) THEN
  828.            NBROBL=2
  829.            NBRFAC=5
  830.            SEGINI NOMID
  831.            LESOBL(1)='EPAI'
  832.            LESOBL(2)='RAYO'
  833.            LESFAC(1)='RACO'
  834.            LESFAC(2)='CISA'
  835.            LESFAC(3)='VX'
  836.            LESFAC(4)='VY'
  837.            LESFAC(5)='VZ'
  838.            IVECT=1
  839. *
  840. * CARACTERISTIQUES POUR LES LINESPRING
  841. *
  842.          ELSE IF (MFR.EQ.15) THEN
  843.            NBROBL=5
  844.            SEGINI NOMID
  845.            LESOBL(1)='EPAI'
  846.            LESOBL(2)='FISS'
  847.            LESOBL(3)='VX  '
  848.            LESOBL(4)='VY  '
  849.            LESOBL(5)='VZ  '
  850. *
  851. * CARACTERISTIQUES POUR LES TUYAUX FISSURES
  852. *
  853.          ELSE IF (MFR.EQ.17) THEN
  854.            NBROBL=9
  855.            SEGINI NOMID
  856.            LESOBL(1)='RAYO'
  857.            LESOBL(2)='EPAI'
  858.            LESOBL(3)='VX  '
  859.            LESOBL(4)='VY  '
  860.            LESOBL(5)='VZ  '
  861.            LESOBL(6)='VXF '
  862.            LESOBL(7)='VYF '
  863.            LESOBL(8)='VZF '
  864.            LESOBL(9)='ANGL'
  865. *
  866. * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES
  867. *
  868.          ELSE IF (MFR.EQ.37) THEN
  869.            IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  870.              NBROBL=4
  871.              SEGINI NOMID
  872.              LESOBL(1)='SCEL'
  873.              LESOBL(2)='SFLU'
  874.              LESOBL(3)='EPS '
  875.              LESOBL(4)='XINE'
  876.            ELSE
  877.              NBROBL=3
  878.              SEGINI NOMID
  879.              LESOBL(1)='SCEL'
  880.              LESOBL(2)='SFLU'
  881.              LESOBL(3)='EPS '
  882.            ENDIF
  883. *
  884. C     CARACTERISTIQUE POUR LES JOINTS GENE
  885. C
  886.          ELSE IF (MFR.EQ.55) THEN
  887.            NBROBL=0
  888.            NBRFAC=1
  889.            SEGINI NOMID
  890.            LESFAC(1)='EPAI'
  891. c
  892. c    element coaxial COS2 (3D pour liaison acier-beton)
  893. c
  894.          ELSE IF( MFR.EQ.78) THEN
  895.             NBROBL=1
  896.             NBRFAC=0
  897.             SEGINI NOMID
  898.             LESOBL(1)='SECT'
  899.  
  900. C==DEB= FORMULATION HHO ================================================
  901.         ELSE IF (MFR.EQ.HHO_MFR_ELEMENT) THEN
  902.           IF (MELE.EQ.HHO_NUM_ELEMENT) THEN
  903.             nbrobl = 2
  904.             nbrfac = 0
  905.             SEGINI,nomid
  906.             nomid.LESOBL(1) = 'PIHO'
  907.             nomid.LESOBL(2) = 'BHHO'
  908.             MOCARA = nomid
  909.             nbtype = 2
  910.             SEGINI,NOTYPE
  911.             notype.TYPE(1) = 'REAL*8          '
  912.             notype.TYPE(2) = 'POINTEURLISTREEL'
  913.           END IF
  914. C==FIN= FORMULATION HHO ================================================
  915.  
  916.          ENDIF 
  917.  
  918.        MOCARA=NOMID
  919. * rendement kich 09/01 /// a remettre en cause avec phases (kich 04/09)
  920.        if (MOCARA.EQ.0) then
  921.          nbrobl = 0
  922.          nbrfac = 0
  923.          segini nomid
  924.          mocara = nomid
  925.        endif
  926.  
  927.        MOTYPE = NOTYPE
  928.  
  929.          ifac = nbrfac
  930.          NCAR1=NBROBL + NBRFAC + 1
  931.          NBRFAC= nbrfac + 10
  932.          segadj nomid
  933.          lesfac(ifac + 1) = 'REND'
  934.          lesfac(ifac + 2) = 'W1X '
  935.          lesfac(ifac + 3) = 'W1Y '
  936.          lesfac(ifac + 4) = 'W1Z '
  937.          lesfac(ifac + 5) = 'W2X '
  938.          lesfac(ifac + 6) = 'W2Y '
  939.          lesfac(ifac + 7) = 'W2Z '
  940.          lesfac(ifac + 8) = 'REN1'
  941.          lesfac(ifac + 9) = 'REN2'
  942.          lesfac(ifac + 10)= 'REN3'
  943.        if (motype.ne.MOTYR8) then
  944.          notype = motype
  945.          nbtype = notype.type(/2) + 1
  946.          segadj notype
  947.          type(nbtype) = 'REAL*8'
  948.        endif
  949. *
  950.          NCARA=NBROBL
  951.          NCARF=NBRFAC
  952.          NCARR=NCARA+NCARF
  953.  
  954. C*       IF (MOCARA.NE.0)  THEN
  955.             IF (IPCHE2.gt.0)  THEN
  956.               icond = 1
  957.               if (ncara.le.0) icond = 0
  958.                CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,icond,
  959.      $                     INFOS,3,IVACAR)
  960.                IF (IERR.NE.0) GOTO 9990
  961.                IF (ISUP2.EQ.1.and.mele.ne.260) THEN
  962.                  CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  963.                  IF (IERR.NE.0)THEN
  964.                    ISUP2=0
  965.                    GOTO 9990
  966.                  ENDIF
  967.                ENDIF
  968.             ELSE IF (NCARA.GT.0) THEN
  969.                MOTERR(1:8)='CARACTER'
  970.                MOTERR(9:12)=NOMTP(MELE)
  971.                MOTERR(13:20)='BSIGMA'
  972.                CALL ERREUR(145)
  973.                GOTO 9990
  974.             ENDIF
  975. C*       ENDIF
  976.          if (motype.ne.MOTYR8) then
  977.            notype = motype
  978.            segsup,notype
  979.          endif
  980.             mptval = ivacar
  981.             if (ivacar.gt.0) then
  982.               dphas = .true.
  983.               do iv = 1,ival(/1)
  984.                 if (ival(iv).gt.0) dphas = .false. 
  985.               enddo
  986.               if (dphas) ivacar = 0
  987.             endif
  988.  
  989. C____________________________________________________________________
  990. C
  991. *  RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE TRAVAIL *
  992. *  UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST
  993. C____________________________________________________________________
  994. *
  995.       NBGMAT = 0
  996.       NELMAT = 0
  997.       NMATR = 0
  998.       NMATF = 0
  999.       NMATT = 0
  1000.       IF(MELE.EQ.93.or.mele.eq.260)THEN
  1001.        IF (IMAT.EQ.2) THEN
  1002.          NBRFAC=0
  1003.          IF(CMATE.NE.'ISOTROPE')THEN
  1004.             NBROBL=3
  1005.             SEGINI NOMID
  1006.             LESOBL(1)='MAHO'
  1007.             LESOBL(2)='V1X '
  1008.             LESOBL(3)='V1Y '
  1009.             NBTYPE=3
  1010.             SEGINI NOTYPE
  1011.             TYPE(1)='POINTEURLISTREEL'
  1012.             TYPE(2)='REAL*8'
  1013.             TYPE(3)='REAL*8'
  1014.          ELSE
  1015.             NBROBL=1
  1016.             SEGINI NOMID
  1017.             LESOBL(1)='MAHO'
  1018.             NBTYPE=1
  1019.             SEGINI NOTYPE
  1020.             TYPE(1)='POINTEURLISTREEL'
  1021.          ENDIF
  1022.          MOMATR=NOMID
  1023.          MOTYPE=NOTYPE
  1024.          CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  1025.          SEGSUP NOTYPE
  1026.          IF (IERR.NE.0) GOTO 9990
  1027.          MPTVAL=IVAMAT
  1028.          MELVAL=IVAL(1)
  1029.          NBGMAT=IELCHE(/1)
  1030.          NELMAT=IELCHE(/2)
  1031.          NMATR=NBROBL
  1032.          NMATF=NBRFAC
  1033.          NMATT=NMATR+NMATF
  1034.        ELSE
  1035. C____________________________________________________________________
  1036. *
  1037. * SINON TRAITEMENT DES CHAMPS DE MATERIAU
  1038. C____________________________________________________________________
  1039. *
  1040.           NBROBL=0
  1041.           NBRFAC=0
  1042.           IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
  1043.              NBROBL=2
  1044.              SEGINI NOMID
  1045.              MOMATR=NOMID
  1046.              LESOBL(1)='YOUN'
  1047.              LESOBL(2)='NU  '
  1048.           ELSEIF(FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ORTHOTRO')THEN
  1049.             IF(INAT.EQ.67) THEN
  1050.                NBROBL=6
  1051.                SEGINI NOMID
  1052.                MOMATR=NOMID
  1053.                LESOBL(1)='YG1 '
  1054.                LESOBL(2)='YG2 '
  1055.                LESOBL(3)='NU12'
  1056.                LESOBL(4)='G12 '
  1057.                LESOBL(5)='V1X '
  1058.                LESOBL(6)='V1Y '
  1059.             ELSE
  1060.              if(lnomid(6).ne.0) then
  1061.                nomid=lnomid(6)
  1062.                momatr=nomid
  1063.                nbrobl=lesobl(/2)
  1064.                nbrfac=lesfac(/2)
  1065.                lsupma=.false.
  1066.              else
  1067.                CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC)
  1068.              endif
  1069.             ENDIF
  1070.           ENDIF
  1071.           NMATR=NBROBL
  1072.           NMATF=NBRFAC
  1073.          NMATT=NMATR+NMATF
  1074. *
  1075.         IF (MOMATR.NE.0) THEN
  1076.           MOTYPE = MOTYR8
  1077.          CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  1078.          IF (IERR.NE.0) GOTO 9990
  1079. *
  1080.          IF (ISUP2.EQ.1.and.mele.ne.260) THEN
  1081.               CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  1082.               IF (IERR.NE.0)THEN
  1083.                    ISUP2=0
  1084.                    GOTO 9990
  1085.               ENDIF
  1086.          ENDIF
  1087. *
  1088.         MPTVAL=IVAMAT
  1089.         NBGMAT = 0
  1090.         NELMAT = 0
  1091.         DO IM=1,NMATT
  1092.          IF(IVAL(IM).NE.0)THEN
  1093.             MELVAL=IVAL(IM)
  1094.             NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1095.             NELMAT=MAX(NELMAT,VELCHE(/2))
  1096.          ENDIF
  1097.         ENDDO
  1098.         ENDIF
  1099.        ENDIF
  1100.       ENDIF
  1101. C
  1102. C================================================
  1103. C
  1104. C      CAS D'UN JOINT UNIDIMENSIONNEL JOI1
  1105. C   Chargement des vecteurs situes dans les caracteristiques materiau
  1106. C
  1107. C================================================
  1108.        IF(MFR.EQ.75) THEN
  1109.          IF(IFOUR.EQ.2) THEN
  1110.              NBROBL=6
  1111.              NBRFAC=0
  1112.              SEGINI NOMID
  1113.              MOMATR=NOMID
  1114.              LESOBL(1)='V1X'
  1115.              LESOBL(2)='V1Y'
  1116.              LESOBL(3)='V1Z'
  1117.              LESOBL(4)='V2X'
  1118.              LESOBL(5)='V2Y'
  1119.              LESOBL(6)='V2Z'
  1120.              NMATR=NBROBL
  1121.              NMATF=NBRFAC
  1122.          ELSE IF(IFOUR.EQ.-2.OR.IFOUR.EQ.-1) THEN
  1123.              NBROBL=2
  1124.              NBRFAC=0
  1125.              SEGINI NOMID
  1126.              MOMATR=NOMID
  1127.              LESOBL(1)='V1X'
  1128.              LESOBL(2)='V1Y'
  1129.              NMATR=NBROBL
  1130.              NMATF=NBRFAC
  1131.          ENDIF
  1132.          MOTYPE=MOTYR8
  1133. *
  1134.          CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  1135.          IF (IERR.NE.0) GOTO 9990
  1136. *
  1137.           NMATT=NMATR+NMATF
  1138. *                                                                        C
  1139.           IF(ISUP1.EQ.1)THEN
  1140.             CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  1141.             IF(IERR.NE.0)THEN
  1142.                ISUP1=0
  1143.                GOTO 9990
  1144.             ENDIF
  1145.           ENDIF
  1146.           MPTVAL=IVAMAT
  1147.           NBGMAT = 0
  1148.           NELMAT = 0
  1149.           DO 11265 IM=1,NMATT
  1150.             IF(IVAL(IM).NE.0)THEN
  1151.               MELVAL=IVAL(IM)
  1152.               IF (CMATE.EQ.'SECTION') THEN
  1153.                 NBGMAT=MAX(NBGMAT,IELCHE(/1))
  1154.                 NELMAT=MAX(NELMAT,IELCHE(/2))
  1155.               ELSE
  1156.                 NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1157.                 NELMAT=MAX(NELMAT,VELCHE(/2))
  1158.               ENDIF
  1159.             ENDIF
  1160. 11265    CONTINUE
  1161.         nmattd=nmatt
  1162.         ivamtd= ivamat
  1163.        ENDIF
  1164.  
  1165. C_______________________________________________________________________
  1166. C
  1167. C     NUMERO DES ETIQUETTES      :
  1168. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  1169. C     Les elements sont groupes comme suit :
  1170. C      - massif, poreux, joints poreux,incompressibles --> BSIGM1
  1171. C      - coq3,dkt,coq4,coq8,coq2,jot3,joi4,joi2,joi3 ----> BSIGM2
  1172. C      - poutre,tuyau,linespring,tuyau fissure,barre ----> BSIGM3
  1173. c        et poutre Timoschenko, cos2, coa2
  1174. C_______________________________________________________________________
  1175. C
  1176.       IF(MELE.GE.1.AND.MELE.LE.100) THEN
  1177. C            CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8
  1178.       GOTO (   99,  29,  99,   4,  99,   4,  99,   4,  99,   4
  1179. C            QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6
  1180.      1      ,  99,  99,  99,   4,   4,   4,   4,  99,  99,  99
  1181. C            LIA8 MULT TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP
  1182.      2      ,  99,  99,   4,   4,   4,   4,  27,  27,  29,  29
  1183. C            FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5
  1184.      3      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  1185. C            COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM
  1186.      4      ,  27,  29,  29,  27,  29,  29,  99,  99,  27,  29
  1187. C            COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6
  1188.      5      ,  99,  99,  99,  99,  99,  27,  99,  99,  99,  99
  1189. C            CVQ4 CVQ8 THP5 TH13 THP6 TH15 THC8 TH20 ICT3 ICQ4
  1190.      6      ,  99,  99,  99,  99,  99,  99,  99,  99,   4,   4
  1191. C            ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 IC15 TRIP QUAP
  1192.      7      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  1193. C            CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8
  1194.      8      ,   4,   4,   4,  29,  27,  27,  27,  27,  99,  99
  1195. C            LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4
  1196.      9      ,  99,  99,  27,  99,  29,  29,  99,  99,  99,  99)
  1197. c cccccc
  1198.      .      ,MELE
  1199.       ELSEIF(MELE.GE.101.AND.MELE.LE.200) THEN
  1200. C            HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  1201.       GOTO (   99,  99,  99,  99,  99,  99,  99,   4,   4,   4
  1202. C            POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12
  1203.      1      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  1204. C            PO13 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3
  1205.      2      ,   4,   4,  29,  29,  29,  34,  34,  34,  34,  34
  1206. C            QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18
  1207.      3      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1208. C            MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6
  1209.      4      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1210. C            TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5
  1211.      5      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1212. C            BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2
  1213.      6      ,  34,  34,  34,  34,  34,  34,  34,  27,  27,  27
  1214. C            JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR
  1215.      7      ,  27,  27,   4,   4,   4,   4,   4,   4,   4,   4
  1216. C            TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8
  1217.      8      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  1218. C            T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15
  1219.      9      ,  34,  34,   4,   4,  34,  34,  34,  34,  34,  34)
  1220. c cccccc
  1221.      .      ,MELE-100
  1222.       ELSEIF(MELE.GE.201.AND.MELE.LE.300) THEN
  1223. C            LC19 LS03 LS07 LS09 LS27 LS21 LS15 LS19 BS03 BS07
  1224.       GOTO (   34,  34,  34,  34,  34,  34,  34,  34,  34,  34 
  1225. C            BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21
  1226.      1      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1227. C            MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03
  1228.      2      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1229. C            MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27
  1230.      3      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1231. C            QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119
  1232.      4      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1233. C            QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8
  1234.      5      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  29
  1235. C            CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3
  1236.      6      ,  34,  34,  34,  34,  29,  29,  29,  29,  99,  99
  1237. C            COS2 COA2 ICY5 IC13 CU27 PR21 TE15 PY19 C20R P15R
  1238.      7      ,  29,  29,   4,   4,   4,   4,   4,   4,   4,   4
  1239. C            HHO  .... .... .... .... .... .... .... .... ....
  1240.      8      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34
  1241. C            ...  .... .... .... .... .... .... .... .... ....
  1242.      9      ,  34,  34,  34,  34,  34,  34,  34,  34,  34,  34)
  1243. c cccccc
  1244.      .      ,MELE-200
  1245.       ENDIF
  1246. C
  1247.  34   CONTINUE
  1248. C Cas particulier de la Formulation DIFFUSION :
  1249.       IF (MFR.EQ.73) GOTO 4
  1250.  
  1251. C==DEB= FORMULATION HHO ================================================
  1252.       IF (MFR.EQ.HHO_MFR_ELEMENT) THEN
  1253.         IF (MELE.EQ.HHO_NUM_ELEMENT) THEN
  1254.           CALL HHOBSG(IMODEL, MOFORC, IVASTR,NSTRS,
  1255.      &                        IIPDPG, ADPG,BDPG,CDPG,
  1256.      &                        IVACAR,NCARA, IPMINT,NBPGAU,
  1257.      &                        IPCHPU, IVAFOR, iret)
  1258.           IF (iret.NE.0) THEN
  1259.             CALL ERREUR(iret)
  1260.             GOTO 9990
  1261.           END IF
  1262.           mleHHO.lect(ISOUS) = IVAFOR
  1263.           GOTO 510
  1264.         END IF
  1265.       END IF
  1266. C==FIN= FORMULATION HHO ================================================
  1267. C_______________________________________________________________________
  1268. C POUR les XFEM on fait un cas particuliers
  1269.         IF(MFR.EQ.63) THEN
  1270.  
  1271.           CALL BSIGMX (IMODEL,IVACAR,IVASTR,ncar1,NFORC,
  1272.      &         IVAFOR,ADPG,BDPG,CDPG,IIPDPG,IRETER)
  1273.           IF(IRETER.NE.0) RETURN
  1274.  
  1275.           MPTVAL = IVAFOR
  1276.           N1TOT = IPOS(/1)
  1277.           N1SUP = N1TOT - 1
  1278.           N2TOT = IVAL(/1)
  1279. * si le nombre de sous-zones fournies par BSIGMX doit augmenter...
  1280. c           write(6,*) N1TOT,N1SUP,N2TOT,N1,NFOREF,NFACF
  1281.           IF (N1SUP.ge.1) THEN
  1282.             N1 = N1 + N1SUP
  1283.             segadj,MCHELM
  1284.           ENDIF
  1285.  
  1286.           I2TOT = 0
  1287.           I1NN = 1
  1288.           DO I1=1,(1+N1SUP)
  1289.  
  1290. *          -cas ou la zone est vide
  1291.             if (IPOS(I1).eq.0) then
  1292.               N1 = N1 - 1
  1293.               segadj,MCHELM
  1294.               I2TOT = I2TOT + NSOF(I1)
  1295.               if(I1.eq.I1NN) I1NN=I1NN+1
  1296.  
  1297. *          -cas ou il faut remplir ICHAML avec MCHAM1 = copie du MCHAML pere
  1298.             else
  1299.               N2=NFOREF+NFACF
  1300.               segini,MCHAM1=MCHAML
  1301. *             la 1ere fois est reperee par I1NN
  1302.               if(I1.ne.I1NN)  ISOUS = ISOUS + 1
  1303.               ICHAML(ISOUS) = MCHAM1
  1304. c       write(6,*) 'bsigmp: creation de ICHAML(',ISOUS,')=',MCHAM1
  1305.               IMACHE(ISOUS) = IPOS(I1)
  1306.               N2 = NSOF(I1)
  1307.               segadj,MCHAM1
  1308.               do i2=1,N2
  1309.                  I2TOT = I2TOT + 1
  1310.                  MCHAM1.IELVAL(i2) = IVAL(I2TOT)
  1311.               enddo
  1312.             endif
  1313.           ENDDO
  1314.  
  1315. *         Quand on a fini avec cette zone on n oublie pas de supprimer
  1316. *         le MCHAML pere des MCHAM1.
  1317. c *         Dans le cas ou ils n ont pas ete utilises,
  1318. c *         les MELVAL du MCHAML pere peuvent etre supprimes aussi.
  1319. c           if (IPOS(1).eq.0) then
  1320. c             DO  IB=1,IELVAL(/1)
  1321. c               MELVAL=IELVAL(IB)
  1322. c               SEGSUP MELVAL
  1323. c             ENDDO
  1324. c           endif
  1325. *      -> cela semble etre une erreur car les melval sont utilises !!!
  1326.           SEGSUP MCHAML
  1327.  
  1328.           GO TO 510
  1329.         ENDIF
  1330. C fin des XFEM _________________________________________________________
  1331.  
  1332.    99 CONTINUE
  1333.       MOTERR(1:4)=NOMTP(MELE)
  1334.       MOTERR(5:12)='BSIGMA'
  1335.       CALL ERREUR(86)
  1336.       GOTO 9990
  1337. C_______________________________________________________________________
  1338. C
  1339. C     massifs, poreux, joints poreux, incompressibles
  1340. C_______________________________________________________________________
  1341. C
  1342.    4  CONTINUE
  1343.       IF (MFR.EQ.71) THEN
  1344.         CALL BSIGEL(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK,
  1345.      &              IVAFOR,NFORC)
  1346.       ELSE IF (MFR.EQ.73) THEN
  1347.         CALL BSIGDI(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK,
  1348.      &              IVAFOR,NFORC)
  1349.       ELSE
  1350.       CALL BSIGM1(IPMAIL,LRE,NSTRS,NBPGAU,MELE,MFR,IVASTR,IPMINT,
  1351.      &            IVACAR,IPORE,LHOOK,NFORC,IVAFOR,ADPG,BDPG,CDPG,
  1352.      &            IIPDPG,ncar1,melpha,noer)
  1353.       if (noer.eq.195) return
  1354.       ENDIF
  1355.       GOTO 510
  1356. C_______________________________________________________________________
  1357. C
  1358. C     coq3,dkt,coq4,coq8,coq2,dst,jot3,joi4,joi2,joi3
  1359. C_______________________________________________________________________
  1360. C
  1361.   27  CONTINUE
  1362.        if (dcmate) goto 29
  1363.       CALL BSIGM2(IPMAIL,LRE,NSTRS,IVASTR,LW,NBPGAU,IVACAR,CMATE,NBPTEL,
  1364.      & MELE,MFR,IPMINT,IPMIN1,IVAMAT,NMATT,NBGMAT,NELMAT,IMAT,NPINT,
  1365.      & NFORC,IVAFOR,ADPG,BDPG,CDPG,IIPDPG)
  1366.       GOTO 510
  1367. C_______________________________________________________________________
  1368. C
  1369. C     poutre,tuyau,linespring,tuyau fissure,barre,poutre Timoschenko
  1370. C     joi1, zone_cohesive, cos2, coa2
  1371. C_______________________________________________________________________
  1372. C
  1373.   29  CONTINUE
  1374.        ncaru = ncar1 - 1
  1375.       CALL BSIGM3(IPMAIL,LRE,NSTRS,LW,IVACAR,ncaru,IVECT,MELE,CMATE,
  1376.      &IVASTR,ISOUS,NBPGAU,NBPTEL,IPMINT,NFORC,IVAFOR,ADPG,BDPG,CDPG
  1377.      &,IIPDPG,ivamat,NMATT,MFR,dcmate)
  1378.       GOTO 510
  1379. C_______________________________________________________________________
  1380. C
  1381. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  1382. C_______________________________________________________________________
  1383. C
  1384.   510 CONTINUE
  1385. C
  1386. C  Cas des modes de calculs GENEralises :
  1387. C
  1388.       IF (ldpge) THEN
  1389.         K_DPGE = K_DPGE + 1
  1390.         mchpoi = ICHPGE
  1391.         msoupo = mchpoi.ipchp(1)
  1392.         ipt1   = msoupo.IGEOC
  1393.         DO im = 1, N_DPGE
  1394.           IF (iipdpg.EQ.ipt1.num(1,im)) GOTO 300
  1395.         ENDDO
  1396.         write(ioimp,*) 'BSIGMP - incoherence iipdpg / ipt1'
  1397.         CALL erreur(5)
  1398.  300    CONTINUE
  1399.         mpoval = msoupo.IPOVAL
  1400.         mpoval.vpocha(im,1) = mpoval.vpocha(im,1) + ADPG
  1401.         IF (NFORDG.GE.2) THEN
  1402.           mpoval.vpocha(im,2) = mpoval.vpocha(im,2) + BDPG
  1403.           IF (NFORDG.GE.3) THEN
  1404.             mpoval.vpocha(im,3) = mpoval.vpocha(im,3) + CDPG
  1405.           ENDIF
  1406.         ENDIF
  1407.       ENDIF
  1408.  
  1409.       IF(ISUP1.EQ.1)THEN
  1410.            CALL DTMVAL(IVASTR,3)
  1411.       ELSE
  1412.            CALL DTMVAL(IVASTR,1)
  1413.       ENDIF
  1414. *
  1415.       CALL DTMVAL(IVAFOR,1)
  1416. *
  1417.       IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN
  1418.            CALL DTMVAL(IVAMAT,3)
  1419.       ELSE
  1420.           CALL DTMVAL(IVAMAT,1)
  1421.       ENDIF
  1422. *
  1423.       IF(ISUP2.EQ.1)THEN
  1424.            CALL DTMVAL(IVACAR,3)
  1425.       ELSE
  1426.           CALL DTMVAL(IVACAR,1)
  1427.       ENDIF
  1428. *
  1429.       NOMID=MOCARA
  1430.       IF (MOCARA.NE.0) SEGSUP NOMID
  1431.       NOMID=MOMATR
  1432.       IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID
  1433. *
  1434.       IF (IERR.NE.0) GO TO 9991
  1435. C
  1436.   200 CONTINUE
  1437. C_______________________________________________________________________
  1438. C
  1439. C     TRANSFORMATION DU CHAMELEM EN CHPOINT
  1440. C_______________________________________________________________________
  1441. C
  1442.       IF (NSOUS.NE.kHHO) CALL CHAMPO(IPCHE5,0,IPCHP4,IRET)
  1443.       if (ierr.ne.0) return
  1444.  
  1445. C==DEB= FORMULATION HHO ================================================
  1446.       IF (kHHO.GT.0) THEN
  1447.         NBFUS = kHHO
  1448.         IF (NSOUS.NE.kHHO) NBFUS = NBFUS + 1
  1449.         IF (NBFUS.EQ.1) THEN
  1450.           ipchp6 = 0
  1451.           DO im = 1, NSOUS
  1452.             ip = mleHHO.lect(im)
  1453.             IF (ip.NE.0) THEN
  1454.               if (ipchp6.ne.0) then
  1455.                 write(ioimp,*) 'BSIGMP-NBFUS-ipchp6'
  1456.                 call erreur(5)
  1457.                 return
  1458.               end if
  1459.               ipchp6 = ip
  1460.             END IF
  1461.           END DO
  1462.         ELSE
  1463.           ic1 = 0
  1464.           SEGINI,sid
  1465.           sid.CTYPE1 = 'CHPOINT '
  1466.           sid.CREATE = 'BSIGMA  '
  1467.           i = 0
  1468.           IF (NSOUS.NE.kHHO) THEN
  1469.             i = i + 1
  1470.             sid.IPOINT(i) = IPCHP4
  1471.           END IF
  1472.           DO im = 1, NSOUS
  1473.             ip = mleHHO.lect(im)
  1474.             IF (ip.NE.0) THEN
  1475.               i = i + 1
  1476.               sid.IPOINT(i) = ip
  1477.             END IF
  1478.           END DO
  1479.       if (i.ne.khho) write(ioimp,*) 'ERREUR HHO BSIG SID !'
  1480.           r_z = 0.
  1481.           b_z = .TRUE.
  1482.           CALL FUNOBJ(sid,ipchp6,r_z,b_z)
  1483.           IF (NSOUS.NE.kHHO) CALL DTCHPO(IPCHP4)
  1484.           SEGSUP,sid
  1485.         END IF
  1486.         IPCHP4 = ipchp6
  1487.         SEGSUP,mleHHO
  1488.       END IF
  1489. C==FIN= FORMULATION HHO ================================================
  1490. C
  1491. C   CAS des modes de calculs GENERALISEs :
  1492. C   ON ADDITIONNE LE CHPOINT RESULTANT DE LA TRANSFORMATION DU CHAMELEM
  1493. C   ET LE PETIT CHPOINT DES FORCES INTERNES AUx NOEUDs supports
  1494. C
  1495.       IF (BDPGE) THEN
  1496.         IF (K_DPGE.NE.0) THEN
  1497.           CALL ADCHPO(ICHPGE,IPCHP4,IPCHP6,1D0,1D0)
  1498.           CALL DTCHPO(IPCHP4)
  1499.           IPCHP4 = IPCHP6
  1500.         ENDIF
  1501.         CALL DTCHPO(ICHPGE)
  1502.       ENDIF
  1503. C
  1504.       IF (llent2.gt.0) then
  1505.         ipc1 = ipchp4
  1506.         jg = klent2
  1507.         segadj mlent2
  1508.         do ipj= 1,jg
  1509.           ipcj = mlent2.lect(ipj)
  1510.           if (ipcj.gt.0) then
  1511.            call adchpo(ipc1,ipcj,ipc2,1.D0,1.D0)
  1512.            call dtchpo(ipc1)
  1513.            ipc1 = ipc2
  1514.           endif
  1515.         enddo
  1516.         ipchp4 = ipc1
  1517.         segsup mlent2
  1518.       ENDIF
  1519.  
  1520. C     IPCHE5 est maintenant inutile !
  1521.       MCHELM = IPCHE5
  1522.       DO im=1,ICHAML(/1)
  1523.         MCHAML=mchelm.ICHAML(im)
  1524.         IF (MCHAML.GT.0) THEN
  1525.           DO jm=1,IELVAL(/1)
  1526.             MELVAL=mchaml.IELVAL(jm)
  1527.             SEGSUP,MELVAL
  1528.           ENDDO
  1529.           SEGSUP,MCHAML
  1530.         ENDIF
  1531.       ENDDO
  1532.       SEGSUP,MCHELM
  1533.  
  1534. C* Fin normale
  1535.       IRET = 1
  1536.  
  1537.       GOTO 9000
  1538. *
  1539. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  1540. *
  1541.  9990 CONTINUE
  1542. *
  1543.       IF(ISUP1.EQ.1)THEN
  1544.            CALL DTMVAL(IVASTR,3)
  1545.       ELSE
  1546.            CALL DTMVAL(IVASTR,1)
  1547.       ENDIF
  1548. *
  1549.       CALL DTMVAL(IVAFOR,3)
  1550. *
  1551.       IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN
  1552.            CALL DTMVAL(IVAMAT,3)
  1553.       ELSE
  1554.           CALL DTMVAL(IVAMAT,1)
  1555.       ENDIF
  1556. *
  1557.       IF(ISUP2.EQ.1)THEN
  1558.            CALL DTMVAL(IVACAR,3)
  1559.       ELSE
  1560.           CALL DTMVAL(IVACAR,1)
  1561.       ENDIF
  1562. *
  1563.       NOMID=MOCARA
  1564.       IF (MOCARA.NE.0) SEGSUP NOMID
  1565.       NOMID=MOMATR
  1566.       IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID
  1567.  9991 CONTINUE
  1568.  9992 CONTINUE
  1569.       IRET = 0
  1570.  
  1571. C Dernieres desactivations avant de quitter :
  1572.  9000 CONTINUE
  1573.       mmodel = IPMODL
  1574.       SEGDES,mmodel
  1575.       meleme = MAILDG
  1576.       IF (meleme.NE.0) SEGDES,meleme
  1577.  
  1578.       notype = MOTYR8
  1579.       SEGSUP,notype
  1580.  
  1581. c      RETURN
  1582.       END
  1583.  
  1584.  
  1585.  
  1586.  

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