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

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