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

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