Télécharger la plaquette Cast3M


fr en

Télécharger accro3.eso

Retour à la liste

Numérotation des lignes : 

accro3

  1. C ACCRO3    SOURCE    CB215821  24/04/12    21:15:02     11897          
  2.       SUBROUTINE ACCRO3
  3. C========================================================================
  4. C   Cree la matrice de liaison entre le champ u et w
  5. C   avec une formulation forte  => On utilise les fonctions de forme
  6. C   et on identifie le deplacement aux noeuds de la fissure
  7. c
  8. c   On prend en compte les enrichissements XFEM
  9. c
  10. C   Creation : BP, decembre 2012
  11. C   Modifications : ...
  12. C
  13. C========================================================================
  14.  
  15.       IMPLICIT INTEGER(I-N)
  16.       IMPLICIT REAL*8 (A-H,O-Z)
  17.  
  18. -INC CCREEL
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC SMCOORD
  23. -INC SMELEME
  24. -INC SMRIGID
  25. -INC SMLMOTS
  26. -INC CCHAMP
  27. -INC CCGEOME
  28. -INC SMMODEL
  29. -INC SMINTE
  30. -INC SMCHAML
  31. -INC SMLREEL
  32.  
  33.  
  34. C  Segment contenant les informations sur un element
  35.       SEGMENT INFO
  36.         INTEGER INFELL(JG)
  37.       ENDSEGMENT
  38.  
  39.       POINTEUR INFO1.INFO,INFO2.INFO
  40.       POINTEUR    MCHEX1.MCHELM
  41.       external shape
  42.       DATA EPSI/1.D-9/
  43.       DIMENSION ICOR(6),IMEL(6),imtt(10)
  44.       DIMENSION QSI(3),XPO(3)
  45.  
  46. C  INITIALISATION DES INCONNUES obligatoires et facultatives
  47.       PARAMETER (NOBL=3,NFAC=9)
  48.       CHARACTER*4 DDLOBL(NOBL),DDLFAC(NFAC),MODDL,MODDL2
  49.       CHARACTER*4 DUAOBL(NOBL),DUAFAC(NFAC)
  50.  
  51.       DATA DDLOBL/'UX  ','UY  ','UZ  '/
  52.       DATA DDLFAC/'AX  ','AY  ','AZ  ',
  53.      >'B1X ','B1Y ','B1Z ',
  54.      >'B2X ','B2Y ','B2Z '/
  55.       DATA DUAOBL/'FX  ','FY  ','FZ  '/
  56.       DATA DUAFAC/'FAX ','FAY ','FAZ ',
  57.      >'FB1X','FB1Y','FB1Z',
  58.      >'FB2X','FB2Y','FB2Z'/
  59.  
  60.  
  61. c-----------------------------------------------------
  62. c     Segment de travail
  63. c-----------------------------------------------------
  64.       SEGMENT MTRAV
  65.         REAL*8 XE2(3,NBNN2)
  66.         REAL*8 SHPP1(6,NBNN1)
  67.         REAL*8 XE1(3,NBNN1)
  68.         INTEGER IDEJVU(NBPTS)
  69.       ENDSEGMENT
  70.  
  71. c    tableaux comptant le nbre d EF de chaque ddl
  72.       PARAMETER(NDDLMAX=6)
  73.       INTEGER NELDDL(NDDLMAX)
  74.  
  75.       if(iimpi.ge.2) then
  76.       write(ioimp,*) '-----------------------------------------------'
  77.       write(ioimp,*) '               ENTREE dans ACCRO3'
  78.       write(ioimp,*) '-----------------------------------------------'
  79.       endif
  80.  
  81. c     Preliminaires
  82.       idim1 = idim + 1
  83.       SEGACT,MCOORD*mod
  84.  
  85. c-----------------------------------------------------
  86. c     RECUPERATION DU MAILLAGE MASSIF
  87. c-----------------------------------------------------
  88.       CALL LIROBJ('MMODEL  ',IPMODL,1,IRETOU)
  89.       CALL ACTOBJ('MMODEL  ',IPMODL,1)
  90.       IF(IERR.NE.0) RETURN
  91.       MMODE1=IPMODL
  92.       segact,MMODE1
  93. c  Récupération du nombre de zones du modèle
  94.       N1 = MMODE1.KMODEL(/1)
  95.       if(N1.gt.1) write(ioimp,*) 'attention 1 seule zone a ce jour!'
  96.       IMODE1 = MMODE1.KMODEL(1)
  97.       segdes,MMODE1
  98. C Récupération du maillage et du numéro d'élément du modèle
  99.       segact,IMODE1
  100.       nele1 = IMODE1.NEFMOD
  101.       IPT1 = IMODE1.IMAMOD
  102.       SEGACT IPT1
  103. C Récupération du numéro d'élément du maillage, du nombre de noeuds et d'éléments
  104.       iele1 = IPT1.itypel
  105.       nbnn1 = IPT1.num(/1)
  106.       nbel1 = IPT1.num(/2)
  107. c   récupération des caractéristique EF IPT1
  108.       call elquoi(nele1,0,3,IPTR1,IMODE1)
  109.       segdes,IMODE1
  110.       INFO = IPTR1
  111.       segact,INFO
  112.       mele1 =  INFELL(1)
  113.       MINTE1 = INFELL(11)
  114.       segdes,INFO
  115.  
  116. c-----------------------------------------------------
  117. c     RECUPERATION DU MAILLAGE INTERFACE
  118. c-----------------------------------------------------
  119.       IPMAI2 = 0
  120.       CALL LIROBJ('MMODEL  ',IPMODL,0,IRETOU)
  121.       IF(IERR.NE.0) RETURN
  122.       if (IRETOU.EQ.1)then
  123.         CALL ACTOBJ('MMODEL  ',IPMODL,1)
  124.          MMODE2=IPMODL
  125.          segact,MMODE2
  126.          N2 = MMODE2.KMODEL(/1)
  127.          if(N2.gt.1) write(ioimp,*) 'attention 1 seule zone a ce jour!'
  128.          IMODE2 = MMODE2.KMODEL(1)
  129.          segdes,MMODE2
  130.          segact,IMODE2
  131.          nele2 = IMODE2.NEFMOD
  132.          IPT2 = IMODE2.IMAMOD
  133.          SEGACT IPT2
  134. c pour l'instant on dit que nele = iele (marche pour iele entre 2 et 26, voir bdata.eso)
  135.          iele2 = IPT2.itypel
  136.          nbnn2 = IPT2.num(/1)
  137.          nbel2 = IPT2.num(/2)
  138.  
  139. c   recuperation des caracteritiques de l'element
  140. c         write(ioimp,*) 'appel elquoi',iele2,nele2
  141.          call elquoi(nele2,0,3,IPTR2,IMODE2)
  142.  1       segdes,IMODE2
  143.          INFO = IPTR2
  144.          segact,INFO
  145.          MINTE2 = INFELL(11)
  146.          ngau2 = INFELL(6)
  147.          segdes,INFO
  148.       else
  149. C Dans le cas où on a un maillage en entrée
  150.          CALL LIROBJ('MAILLAGE',IPMAI2,1,IRETOU)
  151.          IF(IERR.NE.0) RETURN
  152.          IPT2 = IPMAI2
  153.          SEGACT IPT2
  154. c pour l'instant on dit que nele = iele (marche pour iele entre 2 et 26, voir bdata.eso)
  155.          iele2 = IPT2.itypel
  156.          nele2 = iele2
  157.          if (nele2.lt.2.or.nele2.gt.26) then
  158.          write(ioimp,*)'element geometrique different de l element fini'
  159.             call erreur(16)
  160.          endif
  161.          nbnn2 = IPT2.num(/1)
  162.          nbel2 = IPT2.num(/2)
  163. c     SEG2
  164.          if (nele2.EQ.2) ngau2 = 2
  165. c     SEG3
  166.          if (nele2.EQ.3) ngau2 = 3
  167. c     TRI3
  168.          if (nele2.EQ.4) ngau2 = 1
  169. c     TRI6
  170.          if (nele2.EQ.6) ngau2 = 4
  171. c     QUA4
  172.          if (nele2.EQ.8) ngau2 = 4
  173. c     QUA8
  174.          if (nele2.EQ.10) ngau2 = 9
  175.       endif
  176.  
  177.       call RESHPT(ngau2,nbnn2,iele2,nele2,0,IPTR2,IRET)
  178.       MINTE2 = IPTR2
  179.       segact,MINTE1,MINTE2
  180.  
  181.  
  182. c-----------------------------------------------------
  183. c     RECHERCHE DU MCHAML ISSU MCHEX1 D ENRICHISSEMENT
  184. c-----------------------------------------------------
  185.       MCHAM1=0
  186.       NBENR2=0
  187.       segact,IMODE1
  188.       NOBMOD = IMODE1.IVAMOD(/1)
  189.       IF (NOBMOD.NE.0) THEN
  190.          DO 1002 iobmo1=1,NOBMOD
  191.             if((IMODE1.TYMODE(iobmo1)).ne.'MCHAML')   goto 1002
  192.             MCHEX1 = IMODE1.IVAMOD(iobmo1)
  193.             segact,MCHEX1
  194.             if((MCHEX1.TITCHE).ne.'ENRICHIS')  goto 1003
  195.             MCHAM1 = MCHEX1.ICHAML(1)
  196.             segact,MCHAM1
  197.             NBENR2 = MCHAM1.IELVAL(/1)
  198.             do ienr2=1,NBENR2
  199.                MELVA1=MCHAM1.IELVAL(IENR2)
  200.                if(MELVA1.ne.0) segact,MELVA1
  201.             enddo
  202.  1003       continue
  203.             segdes,MCHEX1
  204.  1002    CONTINUE
  205.       ENDIF
  206.  
  207. c-------------------------------------
  208. c     INITIALISATION DES OBJETS DE TRAVAIL : MTRAV et ITYMAT
  209. c-------------------------------------
  210.       segini,MTRAV
  211. *bp : NTYMAT = (U ou H ou HB1 ou HB1B2)
  212. *     nbre de types de matrices = NRIGEL = NTYMAT * idim
  213. c       NTYMAT = 4
  214.       NTYMAT = 1+NBENR2
  215.  
  216. c-------------------------------------
  217. c     INITIALISATION DU MCOORD
  218. c-------------------------------------
  219.       NBPTS0 = NBPTS
  220.       NBPTS = NBPTS0 + ((nbel2 + 1)*idim*3)
  221.       SEGADJ,MCOORD
  222.       NBPTS = NBPTS0
  223. *     on compte le vrai nombre de LX ajouté via NBPTS
  224.  
  225. c--------------------------------------------------------------------
  226. c     INITIALISATION DU SEGMENT MRIGID
  227. c--------------------------------------------------------------------
  228.       NRIGEL = NTYMAT*idim
  229.       segini,MRIGID
  230.       IFORIG = IFOUR
  231.       MTYMAT ='RIGIDITE'
  232. c    -on prepare le meleme
  233.       NBSOUS = 0
  234.       NBREF = 0
  235.  
  236.       ityty=0
  237. c on initialise la taille matrice en fonction du type de matrice
  238.       do ity=1,NTYMAT
  239.       do iidim=1,idim
  240.  
  241.          ityty=ityty+1
  242.          COERIG(ityty) = 1.D0
  243.  
  244. *     dim de la matrice RE elementaire
  245. *     = 1 (LX) + 1 (UX) +   nbnoeud (UX)
  246. *     = 1 (LX) + 1 (AX) +   nbnoeud (AX)
  247. *     = 1 (LX) + 1 (AX) + 2*nbnoeud (AX+B1X)
  248. *     = 1 (LX) + 1 (AX) + 3*nbnoeud (AX+B1X+B2X)
  249.          nbno1 = nbnn1
  250.          nenr1 = ity
  251.          if(nenr1.le.2) then
  252.            NLIGRP = 1 + 1 + nbno1
  253.          else
  254.            NLIGRP = 1 + 1 + ((nenr1-1)*nbno1)
  255.          endif
  256.          NLIGRD = NLIGRP
  257.  
  258. c       -creation du MELEME
  259.          NBNN = 2 + nbno1
  260.          NBELEM=0
  261.          SEGINI,MELEME
  262. c          ITYPEL=28
  263.          ITYPEL=22
  264.          IRIGEL(1,ityty) = MELEME
  265.  
  266. c       -remplissage du DESCR
  267.          SEGINI,DESCR
  268.          IRIGEL(3,ityty) = DESCR
  269.          iddl=0
  270. c        remplissage des ddl LX de la fissure
  271.          iddl=iddl+1
  272.          LISINC(iddl)='LX'
  273.          LISDUA(iddl)='FLX'
  274.          NOELEP(iddl)=1
  275.          NOELED(iddl)=1
  276. c        remplissage des ddl UX de la fissure (ici appelé WX) []*WX=TX
  277.          iddl=iddl+1
  278.          if (nenr1.eq.1) then
  279.            LISINC(iddl)=DDLOBL(iidim)
  280.            LISDUA(iddl)=DUAOBL(iidim)
  281.          else
  282.            LISINC(iddl)=DDLFAC(iidim)
  283.            LISDUA(iddl)=DUAFAC(iidim)
  284.          endif
  285.          NOELEP(iddl)=2
  286.          NOELED(iddl)=2
  287. c        remplissage des ddl de la structure
  288.          if (nenr1.eq.1) then
  289.            do ino1=1,nbno1
  290.                iddl=iddl+1
  291.                LISINC(iddl)=DDLOBL(iidim)
  292.                LISDUA(iddl)=DUAOBL(iidim)
  293.                NOELEP(iddl)=2+ino1
  294.                NOELED(iddl)=2+ino1
  295.            enddo
  296.          else
  297.            do ini1=1,(nenr1-1)
  298.            do ino1=1,nbno1
  299.                iddl=iddl+1
  300.                LISINC(iddl)=DDLFAC(iidim+(3*(ini1-1)))
  301.                LISDUA(iddl)=DUAFAC(iidim+(3*(ini1-1)))
  302.                NOELEP(iddl)=2+ino1
  303.                NOELED(iddl)=2+ino1
  304.            enddo
  305.            enddo
  306.          endif
  307.          if(iimpi.ge.3) write(ioimp,*) ityty,(LISINC(iou),iou=1,NLIGRP)
  308.          if(iimpi.ge.3) write(ioimp,*) ityty,(NOELEP(iou),iou=1,NLIGRP)
  309.          SEGDES,DESCR
  310.  
  311. c       -initialisation du XMATRI
  312.          NELRIG=0
  313.          SEGINI,XMATRI
  314.          IRIGEL(4,ityty) = XMATRI
  315.          IRIGEL(5,ityty) = NIFOUR
  316.          IRIGEL(6,ityty) = 0
  317.          IRIGEL(7,ityty) = 0
  318.          IRIGEL(8,ityty) = 0
  319.  
  320.       enddo
  321.       enddo
  322.  
  323.  
  324. c----------------------------------------------------------------------
  325. c     1. RECHERCHE DES ELEMENTS DE STRUCTURE CONTENANT DES POINTS DE GAUSS
  326. c        DES ELEMENTS DE LA FISSURE
  327. c     2. REMPLISSAGE DU MRIGID (XMATRI et MELEME)
  328. c----------------------------------------------------------------------
  329.       iaccro=0
  330.       NODES=0
  331. C
  332. c==== Boucle sur les elements de fissure ==============================
  333.       DO 1100 iem2=1,nbel2
  334.  
  335.          call doxe(xcoor,idim,nbnn2,ipt2.num,iem2,xe2)
  336.          nbenrj = 0
  337.  
  338. c======= Boucle sur les noeuds de fissure ============================
  339.          DO 1132 ino2=1,nbnn2
  340.  
  341. c   on n'attache qu'une seule fois chaque noeud
  342.             inode2 = IPT2.NUM(ino2,iem2)
  343.             if(IDEJVU(inode2).ne.0) goto 1132
  344.             IDEJVU(inode2)=1
  345.             NODES=NODES+1
  346.  
  347. c   récupération des coordonnees du point de gauss dans le repère global
  348.             XPO(1) = xe2(1,ino2)
  349.             XPO(2) = xe2(2,ino2)
  350.             XPO(3) = xe2(3,ino2)
  351.  
  352. c---------- Boucle sur les elements de structure ----------------------
  353.             DO 1131 iem1=1,nbel1
  354.  
  355. c   si pas d'enrichissement, on travaille sur tous les elements
  356.                if(MCHAM1.eq.0) goto 1133
  357. c   on saute les elements non enrichi car a priori ne contiennent pas la fissure
  358.                do ienr2=1,NBENR2
  359.                   MELVA1=MCHAM1.IELVAL(IENR2)
  360.                   if(MELVA1.ne.0) then
  361.                     do inode1=1,nbnn1
  362.                   if(MELVA1.IELCHE(inode1,iem1).ne.0) goto 1133
  363.                     enddo
  364.                   endif
  365.                enddo
  366.                goto 1131
  367.  1133          continue
  368.  
  369. c   recuperation des coordonnées des noeuds de IPT1 : xe1 (dans le repère x,y,z)
  370.                call doxe(xcoor,idim,nbnn1,ipt1.num,iem1,xe1)
  371.  
  372. c   calcul des fonctions de formes de IPT1 au pt de Gauss de IPT2
  373.                call QSIJS(xe1,iele1,nbnn1,idim,XPO,SHPP1,qsi,IRET)
  374.  
  375. c   test pour savoir si PG est dans EF de IPT1
  376.                DO 1130 ino1=1,NBNN1
  377.                   if (SHPP1(1,ino1).LT.-1.01D-7) then
  378.                      go to 1131
  379.                   endif
  380.  1130          continue
  381. c ON a trouvé : l'iem1 élément de structure contient ce noeud de fissure
  382.                IDEJVU(inode2)=10
  383.                iaccro=iaccro+1
  384.  
  385. c     DETECTION DU TYPE D'ENRICHISSEMENT MAX DE CET ELEMENT = nbenrj
  386.                DO 3001 IENR2=1,NBENR2
  387.                  MELVA1=MCHAM1.IELVAL(IENR2)
  388.                  IF(MELVA1.eq.0) GOTO 3001
  389.                  DO 3002 ino1=1,nbnn1
  390.                    MLREEL = MELVA1.IELCHE(ino1,iem1)
  391. c                  Test pour savoir si le noeud est enrichi
  392.                    IF(MLREEL.eq.0) GOTO 3002
  393.                    nbenrj=max(nbenrj,IENR2)
  394.  3002            continue
  395.  3001          continue
  396.  
  397.                if(iimpi.ge.3) write(ioimp,*) 'EF fissure ',iem2,
  398.      &         ' ptdeG ',ino2,' -> EF MASSIF ',iem1,' nbenrj=',nbenrj
  399.  
  400.  
  401. c Remplissage du MRIGID
  402.  
  403. c           ---Boucle sur la Partie standard et enrichie ---
  404.                do 6000 ity=1,min(2,NTYMAT)
  405. c           ---Boucle sur la dimension ---
  406. c              rem : utile uniquement pour le meleme
  407. c          (on pourrait garder le meme xmatri pour les differents iidim)
  408.                do 6000 iidim=1,idim
  409.  
  410.                  if(ity.eq.1) then
  411.                    ityty = iidim
  412.                  else
  413.                    ityty = (nbenrj*idim) + iidim
  414.                  endif
  415.                  MELEME = IRIGEL(1,ityty)
  416.                  XMATRI = IRIGEL(4,ityty)
  417.                  NBELEM = NUM(/2)+1
  418.                  NLIGRD = RE(/1)
  419.                  NLIGRP = RE(/2)
  420.                  NELRIG = RE(/3)+1
  421.                  segadj,MELEME
  422.                  segadj,XMATRI
  423.  
  424. c Remplissage du MELEME
  425. c                traitement du LX
  426.                  NBPTS = NBPTS + 1
  427.                  if(NBPTS.gt.(XCOOR(/1)/idim1)) then
  428.                    NBPTS0 = NBPTS
  429.                    NBPTS = NBPTS0 + (nbel2 + 1)
  430.                    SEGADJ,MCOORD
  431.                    NBPTS = NBPTS0
  432.                  endif
  433.                  NUM(1,NBELEM) = NBPTS
  434.                  XCOOR((NBPTS-1)*idim1 +1) = XCOOR((inode2-1)*idim1 +1)
  435.                  XCOOR((NBPTS-1)*idim1 +2) = XCOOR((inode2-1)*idim1 +2)
  436.                  if(idim.eq.3)
  437.      &           XCOOR((NBPTS-1)*idim1 +3) = XCOOR((inode2-1)*idim1 +3)
  438. c                traitement du noeud de la fissure
  439.                  NUM(2,NBELEM) = inode2
  440. c                traitement des noeuds de la structure
  441.                  inono=2
  442. cbp inutile      do j2=1,max(1,nbenrj)
  443. cbp inutile car noelep boucle deja sur les enrichissement
  444.                  do ino1=1,nbnn1
  445.                    inono=inono+1
  446.                    NUM(inono,NBELEM) = IPT1.NUM(ino1,iem1)
  447.                  enddo
  448. c                enddo
  449.  
  450. c Remplissage du XMATRI
  451. c                traitement du terme LX - ddl fissure
  452.                  RE(1,2,NELRIG)=1.d0
  453.                  RE(2,1,NELRIG)=1.d0
  454. c                traitement des terme LX - ddl structure
  455.                  inono=2
  456. c                UX = UX seulement
  457.                  if(ity.eq.1) then
  458.                    do ino1=1,nbnn1
  459.                      inono=inono+1
  460.                      RE(1,inono,NELRIG)=-1.d0*SHPP1(1,ino1)
  461.                      RE(inono,1,NELRIG)=-1.d0*SHPP1(1,ino1)
  462.                    enddo
  463.                  else
  464. c                  AX = AX ...
  465.                    if(nbenrj.ge.1) then
  466.                      MELVA1 = MCHAM1.IELVAL(1)
  467.                      do ino1=1,nbnn1
  468.                        MLREEL = MELVA1.IELCHE(ino1,iem1)
  469.                        inono=inono+1
  470.                        if(MLREEL.ne.0) then
  471.                          RE(1,inono,NELRIG)=-1.d0*SHPP1(1,ino1)
  472.                          RE(inono,1,NELRIG)=-1.d0*SHPP1(1,ino1)
  473.                        endif
  474.                      enddo
  475.                    endif
  476. c                  ... + B1X + B2X
  477.                    if(nbenrj.ge.2) then
  478.                      do jenrj=2,nbenrj
  479. c                      on ecrit B1X pour les nbnn1 noeuds, puis B2X ...
  480.                        MELVA1 = MCHAM1.IELVAL(jenrj)
  481.                        do ino1=1,nbnn1
  482.                          MLREEL = MELVA1.IELCHE(ino1,iem1)
  483.                          if(MLREEL.eq.0) then
  484. c                          pas d'enrichissement => on met 0
  485.                            RX05   = 0.d0
  486.                          else
  487.                            SEGACT,MLREEL
  488.                            PSIX = 0.d0
  489.                            do iii0 = 1,nbnn1
  490.                              PSIX = PSIX + (SHPP1(1,iii0) * PROG(iii0))
  491.                            enddo
  492.                            SEGDES,MLREEL
  493.                            RX05= -1.d0*SQRT(ABS(PSIX))
  494.                          endif
  495.                          inono=inono+1
  496.                          RE(1,inono,NELRIG)=RX05*SHPP1(1,ino1)
  497.                          RE(inono,1,NELRIG)=RX05*SHPP1(1,ino1)
  498.                        enddo
  499.                      enddo
  500.                    endif
  501.                  endif
  502.  
  503.  6000          continue
  504. c           ---fin de Boucle sur les XMATRI et MELEME
  505. c              des Partie standard et enrichie et sur les dimensions ---
  506.  
  507. c              on a trouvé le iem1 élément et on a fait le travail :
  508. c              on passe au point de gauss suivant
  509.                goto 1132
  510.  
  511.  1131       CONTINUE
  512. c---------- fin de la Boucle sur les elements de structure -------------
  513.             if(iimpi.ge.2) write(ioimp,*)
  514.      1      'Fin de la boucle sur les elements de structure'
  515.  
  516.             if(IDEJVU(inode2).ne.10) then
  517.          write(ioimp,*) 'Attention le noeud ',inode2,' est hors support'
  518.             endif
  519.  
  520.  1132    CONTINUE
  521. c======= fin de la Boucle sur les noeuds de fissure ===================
  522.  
  523.  
  524.  
  525.  1100 CONTINUE
  526. c==== fin de la Boucle sur les elements de fissure =====================
  527.  
  528. c MESSAGE : Nombre de points accrochés %i1  sur  %i2 proposés
  529.       INTERR(1)=iaccro
  530.       INTERR(2)=NODES
  531.       CALL ERREUR(-319)
  532.  
  533. c------------------------------------
  534. c     AJUSTEMENT AVANT DE QUITTER
  535. c------------------------------------
  536.  
  537.       if(iimpi.ge.2) write(ioimp,*) 'AJUSTEMENT AVANT DE QUITTER'
  538. c     NBPTS est deja le vrai nomber de noeuds
  539.       SEGADJ,MCOORD
  540.  
  541. C     BOUCLE SUR LES SOUS RIGIDITÉS
  542.       ityok = 0
  543.       DO 2000 ityty=1,(idim*NTYMAT)
  544.          MELEME = IRIGEL(1,ityty)
  545.          DESCR  = IRIGEL(3,ityty)
  546.          XMATRI = IRIGEL(4,ityty)
  547.          NBELEM = NUM(/2)
  548.          if(NBELEM.ne.0) then
  549.            ityok = ityok + 1
  550.            IRIGEL(1,ityok) = MELEME
  551.            IRIGEL(3,ityok) = DESCR
  552.            IRIGEL(4,ityok) = XMATRI
  553.            segdes,MELEME,XMATRI
  554.          else
  555.            segsup,MELEME,DESCR,XMATRI
  556.          endif
  557.  2000 continue
  558.       NRIGEL = ityok
  559.       segadj,MRIGID
  560.  
  561. c-------------------------------
  562. c     MENAGE AVANT DE QUITTER
  563. c-------------------------------
  564.  
  565.       segsup,MTRAV
  566.       segdes IPT1,IPT2
  567.       if(MCHAM1.ne.0) segdes,MCHAM1
  568.       SEGDES,MRIGID
  569.  
  570.       if(iimpi.ge.3) write(ioimp,*) 'ecriture du MRIGID',MRIGID
  571.       CALL ECROBJ('RIGIDITE',MRIGID)
  572.       END
  573.  
  574.  
  575.  
  576.  
  577.  

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