Télécharger la plaquette Cast3M


fr en

Télécharger isova6.eso

Retour à la liste

Numérotation des lignes : 

isova6

  1. C ISOVA6    SOURCE    PV        20/03/30    21:20:10     10567          
  2.       SUBROUTINE ISOVA6(ELEMS,ITYPL)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : ISOVA6
  7. C DESCRIPTION :
  8. * Les piles d'éléments peuvent contenir des informations redondantes :
  9. * - dans une pile d'éléments, plusieurs fois le même
  10. * - dans la pile des POI1, des noeuds déjà présents dans les piles
  11. *   de SEG2, TRI3, TET4, PYR5, PRI6, QUA4
  12. * - dans la pile des SEG2, des segments déjà présents dans les piles
  13. *   de TRI3, TET4, PYR5, PRI6, QUA4
  14. * - dans la pile des TRI3, des faces déjà présentes dans la pile des
  15. *   TET4
  16. * On réduit les piles de manière adéquate.
  17. C
  18. C
  19. C
  20. C LANGAGE     : ESOPE
  21. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  22. C               mél : gounand@semt2.smts.cea.fr
  23. C***********************************************************************
  24. C VERSION    : v1, 15/09/2014, version initiale
  25. C HISTORIQUE : v1, 15/09/2014, création
  26. C HISTORIQUE : v1.1, 16/03/2015, correction anomalie 8433
  27. C HISTORIQUE :
  28. C***********************************************************************
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC CCGEOME
  33. -INC SMLENTI
  34. -INC CCREEL
  35. -INC SMCOORD
  36. *
  37. * Segments ajustables 1D contenant les noeuds des éléments créés ainsi
  38. * que leur couleur
  39. * ELEM(1) contient des POI1
  40. * ELEM(2) contient des SEG2
  41. * ELEM(3) contient des TRI3
  42. * ELEM(4) contient des TET4
  43. * ELEM(5) contient des PYR5
  44. * ELEM(6) contient des PRI6
  45. * ELEM(7) contient des QUA4
  46. *
  47.       PARAMETER (NTYEL=7)
  48.       SEGMENT ELEMS
  49.       POINTEUR ELEM(NTYEL).MLENTI
  50.       ENDSEGMENT
  51. * Défini dans isova1
  52.       INTEGER ITYPL(NTYEL)
  53. *
  54.       SEGMENT ICPR(nbpts)
  55.       segment inode(ino)
  56.       segment jelnum(imaxel,ino)
  57.       segment kelnum(imaxel,ino)
  58.       segment xelnum(imaxel,ino)
  59.       integer locfac(3)
  60. *
  61.       LOGICAL LFOUND
  62. *
  63. * Executable statements
  64. *
  65. * Debuggage : ecriture des piles
  66. *dbg      do idpil=1,ntyel
  67. *dbg         mlenti=elem(idpil)
  68. *dbg         ndnode=nbnne(itypl(idpil))
  69. *dbg         jdg=lect(/1)
  70. *dbg         ndg=jdg/(ndnode+1)
  71. *dbg         write(ioimp,*) '*** Pile ',idpil,' : ',ndnode,' noeuds ',ndg,
  72. *dbg     $        ' elements'
  73. *dbg         do idg=1,ndg
  74. *dbg            iddx=(ndnode+1)*(idg-1)
  75. *dbg            write(ioimp,147) idg,lect(iddx+ndnode+1),
  76. *dbg     $           (lect(iddx+m),m=1,ndnode)
  77. *dbg         enddo
  78. *dbg      enddo
  79. *dbg 147  format ('  element',1X,I6,' coul',1X,I6,10(1X,I6))
  80.  
  81. *
  82. * Il y aurait peut-être eu moyen de faire plus efficace en "flaggant"
  83. * les cas particuliers par rapport au cas général dans isova2.eso
  84. * mais ce serait plus compliqué à coder
  85. *
  86. *dbg      write(ioimp,*) '****************************************'
  87. *dbg      write(ioimp,*) '      Traitement des points redondants  '
  88. *dbg      write(ioimp,*) '****************************************'
  89. **********************************************************************
  90. *             Traitement des points redondants
  91. **********************************************************************
  92. *
  93. * La pile des points peut contenir des noeuds en double
  94. * on la réduit si nécessaire.
  95. * Egalement, on supprime les noeuds qui sont dans les piles
  96. * ELEM(2-7) car s'ils sont référencés dedans, cela veut dire que
  97. * l'isovaleur s'est arrêtée au bord d'un élément
  98. *
  99.       MLENTI=ELEM(1)
  100.       JG=LECT(/1)
  101.       IF (JG.GT.0) THEN
  102. * Ici, un segment de logiques suffirait
  103.          SEGINI ICPR
  104.          do ipil=2,7
  105.             mlenti=elem(ipil)
  106.             nnode=nbnne(itypl(ipil))
  107.             jg=lect(/1)
  108.             ng=jg/(nnode+1)
  109.             do ig=1,ng
  110.                do iloc=1,nnode
  111.                   idx=(nnode+1)*(ig-1)+iloc
  112. *                  write(ioimp,*) 'nnode=',nnode,' ig=',ig,' iloc=',iloc
  113. *                  write(ioimp,*) '  idx=',idx
  114.                   inod=lect(idx)
  115. *                  write(ioimp,*) '   inod=',inod
  116.                   if (icpr(inod).eq.0) icpr(inod)=1
  117.                enddo
  118.             enddo
  119.          enddo
  120. * Dans la pile des points, on a des couples (noeud, couleur)
  121.          ipil=1
  122.          mlenti=elem(ipil)
  123.          nnode=nbnne(itypl(ipil))
  124.          jg=lect(/1)
  125.          ng=jg/(nnode+1)
  126.          ired=0
  127. *dbg         write(ioimp,*) 'nnode=',nnode,' ig=',ig,' jg=',jg
  128.          do ig=1,ng
  129.             idx=(nnode+1)*(ig-1)+1
  130.             inod=lect(idx)
  131.             if (icpr(inod).eq.0) then
  132.                icpr(inod)=1
  133.                if (ired.gt.0) then
  134.                   idxr=(nnode+1)*(ig-ired-1)
  135.                   idx =(nnode+1)*(ig-1)
  136.                   do iloc=1,nnode+1
  137.                      lect(idxr+iloc)=lect(idx+iloc)
  138.                   enddo
  139.                endif
  140.             else
  141.                ired=ired+1
  142.             endif
  143.          enddo
  144.          SEGSUP ICPR
  145. *dbg         write(ioimp,*) 'nb noeuds redondants ou deja dans elements ',
  146. *dbg     $        ' =',ired
  147.          jg=jg-((nnode+1)*ired)
  148.          segadj mlenti
  149.       ENDIF
  150.  
  151.  
  152. * Debuggage : ecriture des piles
  153. *dbg      do idpil=1,ntyel
  154. *dbg         mlenti=elem(idpil)
  155. *dbg         ndnode=nbnne(itypl(idpil))
  156. *dbg         jdg=lect(/1)
  157. *dbg         ndg=jdg/(ndnode+1)
  158. *dbg         write(ioimp,*) '*** Pile ',idpil,' : ',ndnode,' noeuds ',ndg,
  159. *dbg     $        ' elements'
  160. *dbg         do idg=1,ndg
  161. *dbg            iddx=(ndnode+1)*(idg-1)
  162. *dbg            write(ioimp,147) idg,lect(iddx+ndnode+1),
  163. *dbg     $           (lect(iddx+m),m=1,ndnode)
  164. *dbg         enddo
  165. *dbg      enddo
  166.  
  167.  
  168. *dbg      write(ioimp,*) '****************************************'
  169. *dbg      write(ioimp,*) '    Traitement des segments redondants 1'
  170. *dbg      write(ioimp,*) '****************************************'
  171. **********************************************************************
  172. *             Traitement des segments redondants
  173. **********************************************************************
  174. *
  175. * On supprime les segments déjà référencés dans les piles d'éléments
  176. * surfaciques... (repris de reduri et chanlg)
  177. *
  178.       ipil=2
  179.       mlenti=elem(ipil)
  180.       nnode=nbnne(itypl(ipil))
  181.       jg=lect(/1)
  182.       ng=jg/(nnode+1)
  183.       IF (JG.GT.0) THEN
  184. *dbg         WRITE(IOIMP,*) 'DIME MCOOR=',nbpts
  185.          SEGINI ICPR
  186. * Création d'une numérotation locale
  187.          ino=0
  188.          do ig=1,ng
  189.             idx=(nnode+1)*(ig-1)
  190.             inod1=lect(idx+1)
  191.             inod2=lect(idx+2)
  192.             ia=max(inod1,inod2)
  193. *            WRITE(IOIMP,*) 'ia=',ia
  194.             if(icpr(ia).eq.0) then
  195.                ino=ino+1
  196.                icpr(ia)=ino
  197.             endif
  198.          enddo
  199. *
  200. * on compte combien de segments touche un noeud
  201. * on réduit la pile des segments en même temps
  202. *
  203.          segini inode
  204.          do ig=1,ng
  205.             idx=(nnode+1)*(ig-1)
  206.             inod1=lect(idx+1)
  207.             inod2=lect(idx+2)
  208.             ia=max(inod1,inod2)
  209.             ib=icpr(ia)
  210.             inode(ib)=inode(ib)+1
  211.          enddo
  212.          imaxel=0
  213.          do i=1,ino
  214.             imaxel=max(imaxel,inode(i))
  215.             inode(i)=0
  216.          enddo
  217.          segini jelnum
  218.          ired=0
  219.          do 122 ig=1,ng
  220.             idx=(nnode+1)*(ig-1)
  221.             inod1=lect(idx+1)
  222.             inod2=lect(idx+2)
  223.             imax=max(inod1,inod2)
  224.             imin=min(inod1,inod2)
  225.             ib=icpr(imax)
  226.             lfound=.false.
  227.             do j=1,imaxel
  228.                if (jelnum(j,ib).eq.0) then
  229.                   jelnum(j,ib)=imin
  230. *                  jelnum(j,ib,2)=lect(idx+3)
  231.                   inode(ib)=inode(ib)+1
  232.                   goto 123
  233.                elseif (jelnum(j,ib).eq.imin) then
  234.                   lfound=.true.
  235.                   goto 123
  236.                endif
  237.             enddo
  238.  123        continue
  239.             if (lfound) then
  240.                ired=ired+1
  241.             else
  242.                if (ired.gt.0) then
  243.                   idxr=(nnode+1)*(ig-ired-1)
  244.                   idx =(nnode+1)*(ig-1)
  245.                   do iloc=1,nnode+1
  246.                      lect(idxr+iloc)=lect(idx+iloc)
  247.                   enddo
  248.                endif
  249.             endif
  250.  122     continue
  251. *dbg         write(ioimp,*) 'nb seg redondants pile segments=',ired
  252. *dbg         write(ioimp,*) '  nb segments*3=',jg
  253.          jg=jg-((nnode+1)*ired)
  254.          segadj mlenti
  255. *dbg         write(ioimp,*) '  nb segments*3 apres=',jg
  256.  
  257.  
  258. * Debuggage : ecriture des piles
  259. *dbg      do idpil=1,ntyel
  260. *dbg         mlenti=elem(idpil)
  261. *dbg         ndnode=nbnne(itypl(idpil))
  262. *dbg         jdg=lect(/1)
  263. *dbg         ndg=jdg/(ndnode+1)
  264. *dbg         write(ioimp,*) '*** Pile ',idpil,' : ',ndnode,' noeuds ',ndg,
  265. *dbg     $        ' elements'
  266. *dbg         do idg=1,ndg
  267. *dbg            iddx=(ndnode+1)*(idg-1)
  268. *dbg            write(ioimp,147) idg,lect(iddx+ndnode+1),
  269. *dbg     $           (lect(iddx+m),m=1,ndnode)
  270. *dbg         enddo
  271. *dbg      enddo
  272.  
  273.  
  274.  
  275.  
  276. *
  277. * Ici, on parcourt les segments des éléments
  278. * on met jelnum(j,ib) en négatif si on veut l'éliminer
  279. *
  280. *         write(ioimp,*) 'parcours des segments des éléments'
  281.          if (jg.gt.0) then
  282.             do ipil=3,7
  283. *               write(ioimp,*) '    ipil=',ipil
  284.                mlenti=elem(ipil)
  285.                nnode=nbnne(itypl(ipil))
  286. *               write(ioimp,*) '    nnode=',nnode
  287.                jg=lect(/1)
  288. *               write(ioimp,*) '    jg=',jg
  289.                ng=jg/(nnode+1)
  290. *               write(ioimp,*) '    ng=',ng
  291.                if (jg.gt.0) then
  292.                   ityp=itypl(ipil)
  293. *                  write(ioimp,*) 'ipil=',ipil,' ityp=',ityp
  294.                   nseg=LPL(ityp)
  295.                   idxseg=LPT(ityp)-1
  296. *     Parcours des éléments de la pile
  297.                   do ig=1,ng
  298.                      idx=(nnode+1)*(ig-1)
  299. *       Parcours des segments des éléments
  300.                      do iseg=1,nseg
  301.                         iloc1=KSEGM(idxseg+2*(iseg-1)+1)
  302.                         iloc2=KSEGM(idxseg+2*(iseg-1)+2)
  303.                         inod1=lect(idx+iloc1)
  304.                         inod2=lect(idx+iloc2)
  305. *                        write(ioimp,*) 'iseg=',iseg,' iloc1=',iloc1,
  306. *     $                       ' iloc2=',iloc2
  307. *                        write(ioimp,*) '              inod1=',inod1,
  308. *     $                       ' inod2=',inod2
  309.                         imax=max(inod1,inod2)
  310.                         imin=min(inod1,inod2)
  311.                         ib=icpr(imax)
  312.                         if (ib.ne.0) then
  313.                            do j=1,inode(ib)
  314.                               jmin=jelnum(j,ib)
  315.                               jamin=abs(jmin)
  316.                               if (jamin.eq.imin) then
  317.                                  if (jmin.gt.0) jelnum(j,ib)=-jmin
  318.                                  goto 125
  319.                               endif
  320.                            enddo
  321.                         endif
  322.  125                    continue
  323.                      enddo
  324.                   enddo
  325.                endif
  326.             enddo
  327. *
  328. * On réduit à nouveau la pile des segments. Le imin est négatif dans
  329. * jelnum pour les segments que l'on ne souhaite pas garder
  330. *
  331.             ipil=2
  332.             mlenti=elem(ipil)
  333.             nnode=nbnne(itypl(ipil))
  334.             jg=lect(/1)
  335.             ng=jg/(nnode+1)
  336.             ired=0
  337.             do 126 ig=1,ng
  338.                idx=(nnode+1)*(ig-1)
  339.                inod1=lect(idx+1)
  340.                inod2=lect(idx+2)
  341.                imax=max(inod1,inod2)
  342.                imin=min(inod1,inod2)
  343.                ib=icpr(imax)
  344.                lfound=.false.
  345.                do j=1,inode(ib)
  346.                   jmin=jelnum(j,ib)
  347.                   jamin=abs(jmin)
  348.                   if (jamin.eq.imin) then
  349.                      if (jmin.lt.0) then
  350.                         lfound=.true.
  351.                      endif
  352.                      goto 127
  353.                   endif
  354.                enddo
  355.  127           continue
  356.                if (lfound) then
  357.                   ired=ired+1
  358.                else
  359.                   if (ired.gt.0) then
  360.                      idxr=(nnode+1)*(ig-ired-1)
  361.                      idx =(nnode+1)*(ig-1)
  362.                      do iloc=1,nnode+1
  363.                         lect(idxr+iloc)=lect(idx+iloc)
  364.                      enddo
  365.                   endif
  366.                endif
  367. *               enddo
  368.  126        continue
  369. *dbg            write(ioimp,*) 'nb seg pile elts surf volu =',ired
  370.             jg=jg-((nnode+1)*ired)
  371.             segadj mlenti
  372.          endif
  373.          segsup jelnum
  374.          segsup inode
  375.          segsup icpr
  376.       ENDIF
  377.  
  378. *dbg      write(ioimp,*) '****************************************'
  379. *dbg      write(ioimp,*) '    Traitement des segments redondants 2'
  380. *dbg      write(ioimp,*) '****************************************'
  381.  
  382. * Debuggage : ecriture des piles
  383. *dbg      do idpil=1,ntyel
  384. *dbg         mlenti=elem(idpil)
  385. *dbg         ndnode=nbnne(itypl(idpil))
  386. *dbg         jdg=lect(/1)
  387. *dbg         ndg=jdg/(ndnode+1)
  388. *dbg         write(ioimp,*) '*** Pile ',idpil,' : ',ndnode,' noeuds ',ndg,
  389. *dbg     $        ' elements'
  390. *dbg         do idg=1,ndg
  391. *dbg            iddx=(ndnode+1)*(idg-1)
  392. *dbg            write(ioimp,147) idg,lect(iddx+ndnode+1),
  393. *dbg     $           (lect(iddx+m),m=1,ndnode)
  394. *dbg         enddo
  395. *dbg      enddo
  396.  
  397.  
  398.  
  399. *dbg      write(ioimp,*) '*****************************************'
  400. *dbg      write(ioimp,*) '    Traitement des triangles redondants 1'
  401. *dbg      write(ioimp,*) '*****************************************'
  402. **********************************************************************
  403. *             Traitement des faces (triangulaires) redondantes
  404. **********************************************************************
  405.       ipil=3
  406.       mlenti=elem(ipil)
  407.       nnode=nbnne(itypl(ipil))
  408.       jg=lect(/1)
  409.       ng=jg/(nnode+1)
  410.       IF (JG.GT.0) THEN
  411. *dbg         WRITE(IOIMP,*) 'DIME MCOOR=',nbpts
  412.          SEGINI ICPR
  413. * Création d'une numérotation locale
  414.          ino=0
  415.          do ig=1,ng
  416.             idx=(nnode+1)*(ig-1)
  417.             inod1=lect(idx+1)
  418.             inod2=lect(idx+2)
  419.             inod3=lect(idx+3)
  420.             ia=max(inod1,inod2,inod3)
  421. *            WRITE(IOIMP,*) 'ia=',ia
  422.             if(icpr(ia).eq.0) then
  423.                ino=ino+1
  424.                icpr(ia)=ino
  425.             endif
  426.          enddo
  427. *
  428. * on compte combien de faces triangulaires touche un noeud
  429. * on réduit la pile des faces triangulaires en même temps
  430. *
  431.          segini inode
  432.          do ig=1,ng
  433.             idx=(nnode+1)*(ig-1)
  434.             inod1=lect(idx+1)
  435.             inod2=lect(idx+2)
  436.             inod3=lect(idx+3)
  437.             ia=max(inod1,inod2,inod3)
  438.             ib=icpr(ia)
  439.             inode(ib)=inode(ib)+1
  440.          enddo
  441.          imaxel=0
  442.          do i=1,ino
  443.             imaxel=max(imaxel,inode(i))
  444.             inode(i)=0
  445.          enddo
  446.          segini jelnum
  447.          segini kelnum
  448.          ired=0
  449.          do 222 ig=1,ng
  450.             idx=(nnode+1)*(ig-1)
  451.             do inno=1,3
  452.                locfac(inno)=lect(idx+inno)
  453.             enddo
  454.             call knuta(3,locfac)
  455.             imin=locfac(1)
  456.             imoy=locfac(2)
  457.             imax=locfac(3)
  458.             ib=icpr(imax)
  459.             lfound=.false.
  460.             do j=1,imaxel
  461.                if (jelnum(j,ib).eq.0) then
  462.                   jelnum(j,ib)=imin
  463.                   kelnum(j,ib)=imoy
  464.                   inode(ib)=inode(ib)+1
  465.                   goto 223
  466.                elseif ((jelnum(j,ib).eq.imin).and.
  467.      $                 (kelnum(j,ib).eq.imoy)) then
  468.                   lfound=.true.
  469.                   goto 223
  470.                endif
  471.             enddo
  472.  223        continue
  473.             if (lfound) then
  474.                ired=ired+1
  475.             else
  476.                if (ired.gt.0) then
  477.                   idxr=(nnode+1)*(ig-ired-1)
  478.                   idx =(nnode+1)*(ig-1)
  479.                   do iloc=1,nnode+1
  480.                      lect(idxr+iloc)=lect(idx+iloc)
  481.                   enddo
  482.                endif
  483.             endif
  484.  222     continue
  485. *dbg         write(ioimp,*) 'nb fac redondants pile faces=',ired
  486. *         write(ioimp,*) '  nb segments*3=',jg
  487.          jg=jg-((nnode+1)*ired)
  488.          segadj mlenti
  489. *
  490. * Ici, on parcourt les faces des éléments tétraédriques
  491. * on met jelnum(j,ib) en négatif si on veut l'éliminer
  492. *
  493. *         write(ioimp,*) 'parcours des faces des éléments tétra'
  494.          if (jg.gt.0) then
  495.             ipil=4
  496. *               write(ioimp,*) '    ipil=',ipil
  497.             mlenti=elem(ipil)
  498.             nnode=nbnne(itypl(ipil))
  499. *               write(ioimp,*) '    nnode=',nnode
  500.             jg=lect(/1)
  501. *               write(ioimp,*) '    jg=',jg
  502.             ng=jg/(nnode+1)
  503. *               write(ioimp,*) '    ng=',ng
  504.             if (jg.gt.0) then
  505.                ityp=itypl(ipil)
  506. *                  write(ioimp,*) 'ipil=',ipil,' ityp=',ityp
  507.                nfac=LTEL(1,ityp)
  508.                idxdel=LTEL(2,ityp)
  509. *dbg               write(ioimp,*) 'nfac=',nfac
  510.                if (nfac.ne.4) then
  511.                   call erreur(5)
  512.                   return
  513.                endif
  514. *     Parcours des éléments de la pile
  515.                do ig=1,ng
  516.                   idx=(nnode+1)*(ig-1)
  517. *       Parcours des faces des éléments
  518.                   do ifac=1,nfac
  519. *dbg
  520.                      ityfac=LDEL(1,idxdel+ifac-1)
  521. *dbg                     write(ioimp,*) 'ityfac=',ityfac
  522.                      if (ityfac.ne.1) then
  523.                         call erreur(5)
  524.                         return
  525.                      endif
  526. *dbg
  527.                      idxfac=LDEL(2,idxdel+ifac-1)
  528.                      iloc1=LFAC(idxfac)
  529.                      iloc2=LFAC(idxfac+1)
  530.                      iloc3=LFAC(idxfac+2)
  531.                      locfac(1)=lect(idx+iloc1)
  532.                      locfac(2)=lect(idx+iloc2)
  533.                      locfac(3)=lect(idx+iloc3)
  534. *dbg                     write(ioimp,*) 'ifac=',ifac,' iloc1=',iloc1,
  535. *dbg     $                    ' iloc2=',iloc2,' iloc3=',iloc3
  536. *dbg                     write(ioimp,*) '              locfac(1)=',locfac(1)
  537. *dbg     $                    ,' locfac(2)=',locfac(2),' locfac(3)='
  538. *dbg     $                    ,locfac(3)
  539.                      call knuta(3,locfac)
  540.                      imin=locfac(1)
  541.                      imoy=locfac(2)
  542.                      imax=locfac(3)
  543.                      ib=icpr(imax)
  544.                      if (ib.ne.0) then
  545.                         do j=1,inode(ib)
  546.                            jmin=jelnum(j,ib)
  547.                            jmoy=kelnum(j,ib)
  548.                            jamin=abs(jmin)
  549.                            if (jamin.eq.imin.and.jmoy.eq.imoy) then
  550.                               if (jmin.gt.0) jelnum(j,ib)=-jmin
  551.                               goto 225
  552.                            endif
  553.                         enddo
  554.                      endif
  555.  225                 continue
  556.                   enddo
  557.                enddo
  558.             endif
  559. *
  560. * On réduit la pile des faces triangulaires. Le imin est négatif dans
  561. * jelnum pour les faces que l'on ne souhaite pas garder
  562. *
  563.             ipil=3
  564.             mlenti=elem(ipil)
  565.             nnode=nbnne(itypl(ipil))
  566.             jg=lect(/1)
  567.             ng=jg/(nnode+1)
  568.             ired=0
  569.             do 226 ig=1,ng
  570.                idx=(nnode+1)*(ig-1)
  571.                do inno=1,3
  572.                   locfac(inno)=lect(idx+inno)
  573.                enddo
  574.                call knuta(3,locfac)
  575.                imin=locfac(1)
  576.                imoy=locfac(2)
  577.                imax=locfac(3)
  578.                ib=icpr(imax)
  579.                lfound=.false.
  580.                do j=1,inode(ib)
  581.                   jmin=jelnum(j,ib)
  582.                   jmoy=kelnum(j,ib)
  583.                   jamin=abs(jmin)
  584.                   if (jamin.eq.imin.and.jmoy.eq.imoy) then
  585.                      if (jmin.lt.0) then
  586.                         lfound=.true.
  587.                      endif
  588.                      goto 227
  589.                   endif
  590.                enddo
  591.  227           continue
  592.                if (lfound) then
  593.                   ired=ired+1
  594.                else
  595.                   if (ired.gt.0) then
  596.                      idxr=(nnode+1)*(ig-ired-1)
  597.                      idx =(nnode+1)*(ig-1)
  598.                      do iloc=1,nnode+1
  599.                         lect(idxr+iloc)=lect(idx+iloc)
  600.                      enddo
  601.                   endif
  602.                endif
  603. *               enddo
  604.  226        continue
  605. *dbg            write(ioimp,*) 'nb fac pile elts volu =',ired
  606.             jg=jg-((nnode+1)*ired)
  607.             segadj mlenti
  608.          endif
  609.          segsup kelnum
  610.          segsup jelnum
  611.          segsup inode
  612.          segsup icpr
  613.       ENDIF
  614.  
  615. *dbg      write(ioimp,*) '*****************************************'
  616. *dbg      write(ioimp,*) '    Traitement des triangles redondants 2'
  617. *dbg      write(ioimp,*) '*****************************************'
  618.  
  619.  
  620. * Debuggage : ecriture des piles
  621. *dbg      do ipil=1,ntyel
  622. *dbg         mlenti=elem(ipil)
  623. *dbg         nnode=nbnne(itypl(ipil))
  624. *dbg         jg=lect(/1)
  625. *dbg         ng=jg/(nnode+1)
  626. *dbg         write(ioimp,*) '*** Pile ',ipil,' : ',nnode,' noeuds ',ng,
  627. *dbg     $        ' elements'
  628. *dbg         do ig=1,ng
  629. *dbg            idx=(nnode+1)*(ig-1)
  630. *dbg            write(ioimp,147) ig,lect(idx+nnode+1),
  631. *dbg     $           (lect(idx+m),m=1,nnode)
  632. *dbg         enddo
  633. *dbg      enddo
  634.  
  635.  
  636. *
  637. * End of subroutine ISOVA6
  638. *
  639.       END
  640.  
  641.  
  642.  
  643.  
  644.  
  645.  
  646.  
  647.  
  648.  

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