Télécharger la plaquette Cast3M


fr en

Télécharger vetopi.eso

Retour à la liste

Numérotation des lignes : 

vetopi

  1. C VETOPI    SOURCE    GOUNAND   21/04/06    21:15:43     10940          
  2.       SUBROUTINE VETOPI(TRAVJ,MMOT)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : VETOPI
  7. C DESCRIPTION : Vérifie la consistance entre une topologie et son
  8. C     inverse, les deux étant stockés dans un segment TRAVJ
  9. C      
  10. C      
  11. C
  12. C LANGAGE     : ESOPE
  13. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SEMT/LTA)
  14. C               mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C***********************************************************************
  17. C SYNTAXE GIBIANE    : 
  18. C ENTREES            : MELEME (Activé), NEL
  19. C ENTREES/SORTIES    : TOPINV (Activé *MOD)
  20. C SORTIES            :
  21. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  22. C***********************************************************************
  23. C VERSION    : v1, 02/10/2017, version initiale
  24. C HISTORIQUE : v1, 02/10/2017, création
  25. C HISTORIQUE :
  26. C HISTORIQUE :
  27. C***********************************************************************
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC SMCOORD
  31.       POINTEUR JCOORD.MCOORD
  32. -INC SMELEME
  33.       POINTEUR JTOPO.MELEME
  34. -INC TMATOP1
  35. *-INC STOPINV
  36.       POINTEUR TOPI2.TOPINV
  37. *-INC SMETRIQ
  38.       POINTEUR JCMETR.METRIQ
  39. -INC SMLENTI
  40.       POINTEUR JNBL.MLENTI
  41.       POINTEUR JNNO.MLENTI
  42. -INC TMATOP2
  43. *-INC STRAVJ
  44.       POINTEUR JVERI.TRAVJ
  45. -INC SMLMOTS
  46.       POINTEUR JNMETR.MLMOTS
  47.       logical lident
  48.       CHARACTER*(*) MMOT
  49. *
  50. *     
  51. * Executable statements
  52. *
  53.       if (impr.ge.5) WRITE(IOIMP,*) 'Entrée dans vetopi.eso'
  54.       IDIMP=IDIM+1
  55.       jpvirt=travj.pvirt
  56.       jcoord=travj.coord
  57.       jnmetr=travj.nmetr
  58.       jcmetr=travj.cmetr
  59.       jtopo=travj.topo
  60.       topinv=travj.topi
  61.       jnbl=travj.nbl
  62.       jnno=travj.nno
  63. *            write(ioimp,*) '5 travj,jnno=',travj,jnno
  64. *      write(ioimp,*) 'jg(jnno)=',jnno.lect(/1)
  65.  
  66. *     Petite vérification de consistance de dimension des objets
  67. *     (NVMAX,NPMAX)
  68.       if (jcoord.ne.0) then
  69.          nbpts=jcoord.xcoor(/1)/idimp
  70.          if (nbpts.ne.npmax) then
  71.             write(ioimp,185) 'jcoor : nbpts,npmax=',nbpts,npmax
  72.             goto 9999
  73.          endif
  74.       endif
  75.       if (jcmetr.ne.0) then
  76.          nnin=jcmetr.xin(/1)
  77.          nnnoe=jcmetr.xin(/2)
  78.          if (nnnoe.ne.npmax) then
  79.             write(ioimp,185) 'jcmetr : nnnoe,npmax=',nnnoe,npmax
  80.             goto 9999
  81.          endif
  82.          if (jnmetr.ne.0) then
  83.             nnin2=jnmetr.mots(/2)
  84.             if (nnin2.ne.nnin) then
  85.                write(ioimp,185) 'jnmetr : nnin2,nnin=',nnin2,nnin
  86.                goto 9999
  87.             endif
  88.          endif
  89.       endif
  90.       if (jtopo.ne.0) then
  91.          nbelem=jtopo.num(/2)
  92.          if (nbelem.ne.nvmax) then
  93.             write(ioimp,185) 'jtopo : nbelem,nvmax=',nbelem,nvmax
  94.             goto 9999
  95.          endif
  96.       endif
  97.       if (topinv.ne.0) then
  98.          if (ldgt.ne.nvcou*idimp) then
  99.             write(ioimp,185) 'topinv : ldgt,nvcou*idimp=',ldgt,nvcou
  100.      $           *idimp
  101.             goto 9999
  102.          endif
  103.          nbelem=tlc(/1)/idimp
  104.          if (nbelem.ne.nvmax) then
  105.             write(ioimp,185) 'topinv : nbelem,nvmax=',nbelem,nvmax
  106.             goto 9999
  107.          endif
  108.          nbpts=tic(/1)
  109.          if (nbpts.ne.npmax) then
  110.             write(ioimp,185) 'topinv : nbpts,npmax=',nbpts,npmax
  111.             goto 9999
  112.          endif
  113.          do i=1,nbpts
  114.             itic=tic(i)
  115.             if (itic.eq.0.or.itic.lt.-1.or.itic.gt.(tlc(/1))) then
  116.                write(ioimp,185) 'topinv : i,tic(i),tlc(/1)=',i,itic
  117.      $              ,tlc(/1)
  118.                goto 9999
  119.             endif
  120.             itdc=tdc(i)
  121.             if (itdc.lt.0.or.itdc.gt.(tlc(/1))) then
  122.                write(ioimp,185) 'topinv : i,tdc(i),tlc(/1)=',i,itdc
  123.      $              ,tlc(/1)
  124.                goto 9999
  125.             endif
  126.             if ((tic(i).eq.-1.and.tdc(i).ne.0).or.(tdc(i).eq.
  127.      $           0.and.tic(i).ne.-1)) then
  128.                write(ioimp,185) 'topinv : i,tic(i),tdc(i)=',i,itic
  129.      $              ,itdc
  130.                goto 9999
  131.             endif
  132.          enddo
  133.       endif
  134.       if (jnbl.ne.0) then
  135.          jg=jnbl.lect(/1)
  136.          if (jg.ne.nvmax) then
  137.             write(ioimp,185) 'jnbl : jg,nvmax=',jg,nvmax
  138.             goto 9999
  139.          endif
  140.          do i=1,nvmax
  141.             ijnbl=jnbl.lect(i)
  142.             if (ijnbl.ne.0) then
  143.                write(ioimp,185) 'jnbl : i,jnbl(i)=',i,ijnbl
  144.                goto 9999
  145.             endif
  146.          enddo
  147.       endif
  148.  
  149.       if (jnno.ne.0) then
  150.          jg=jnno.lect(/1)
  151.          if (jg.ne.npmax-npini) then
  152.             write(ioimp,*) 'jg=',jg
  153.             write(ioimp,185) 'jnno : jg,npmax,npini=',jg,npmax,npini
  154.             goto 9999
  155.          endif
  156.          do i=1,npmax-npini
  157.             ijnno=jnno.lect(i)
  158.             if (ijnno.ne.0) then
  159.                write(ioimp,185) 'jnno : i,jnno(i)=',i,ijnno
  160.                goto 9999
  161.             endif
  162.          enddo
  163.       endif
  164. *
  165. * Vérification de la topologie (numéros de noeud)
  166. *
  167.       if (jtopo.ne.0) then
  168.          do iel=1,nvmax
  169.             do ino=1,idimp
  170.                nnod=jtopo.num(ino,iel)
  171.                if (nnod.lt.0.or.nnod.gt.npcou) then
  172.                   write(ioimp,185) 'jtopo : ino,iel,nnod,npcou=',ino,iel
  173.      $                 ,nnod,npcou
  174.                   goto 9999
  175.                endif
  176.             enddo
  177.          enddo
  178.       endif
  179. *      
  180. *     Petite vérification de nvcou et de npcou
  181. *      
  182.       if (jcoord.ne.0) then
  183.          npco2=0
  184.          do icoo=npmax*idimp,1,-1
  185.             if (jcoord.xcoor(icoo).ne.0.d0) then
  186.                npco2=((icoo-1)/IDIMP)+1
  187.                goto 33
  188.             endif
  189.          enddo
  190.  33      continue
  191. *     le dernier noeud peut avoir comme coordonnées 0. 0.
  192. *     mais on considère qu'il n'y a pas plusieurs noeuds localisés en 0. 0.
  193. *     if (npcou.ne.npco2) then
  194.          if (npcou.ne.npco2.and.npcou.ne.npco2+1) then
  195. *         if (npcou.lt.npco2) then
  196.             write(ioimp,185) 'jcoord : npcou,npco2=',npcou,npco2
  197.             goto 9999
  198.          endif
  199.       endif
  200. *      
  201.       if (jcmetr.ne.0) then
  202.          npco3=0
  203.          do innoe=npmax,1,-1
  204. *            if (innoe.ne.jpvirt) then
  205.                do inin=1,jcmetr.xin(/1)
  206.                   if (jcmetr.xin(inin,innoe).ne.0.d0) then
  207.                      npco3=innoe
  208.                      goto 43
  209.                   endif
  210.                enddo
  211. *            endif
  212.          enddo
  213.  43      continue
  214. * if..endif suivant un peu inutile mais plus lisible ?        
  215.          if (jpvirt.ne.0) then
  216.             if (jpvirt.eq.npco3+1) npco3=npco3+1
  217.          endif
  218. *     le dernier noeud peut avoir comme coordonnées 0. 0.
  219. *     mais on considère qu'il n'y a pas plusieurs noeuds localisés en 0. 0.
  220.          if (npcou.ne.npco3) then
  221. *         if (npcou.ne.npco3.and.npcou.ne.npco3+1) then
  222. *         if (npcou.lt.npco3) then
  223.             write(ioimp,185) 'jcmetr : npcou,npco3=',npcou,npco3
  224.             goto 9999
  225.          endif
  226.       endif
  227.       if (jtopo.ne.0) then
  228.          nvco2=0
  229.          do iel=nvmax,1,-1
  230.             do ino=1,idimp
  231.                if (jtopo.num(ino,iel).ne.0) then
  232.                   nvco2=iel
  233.                   goto 44
  234.                endif
  235.             enddo
  236.          enddo
  237.  44      continue
  238. *         if (nvcou.ne.nvco2) then
  239.          if (nvcou.lt.nvco2) then
  240.             write(ioimp,185) 'jtopo : nvcou,nvco2=',nvcou,nvco2
  241.             goto 9999
  242.          endif
  243.       endif         
  244.       if (topinv.ne.0) then
  245.          do ilc=nvmax*idimp,1,-1
  246.             if (tlc(ilc).ne.0) then
  247.                nvco2=((ilc-1)/IDIMP)+1
  248.                goto 55
  249.             endif
  250.          enddo
  251.  55      continue
  252. *         if (nvcou.ne.nvco2) then
  253.          if (nvcou.lt.nvco2) then
  254.             write(ioimp,185) 'topinv : nvcou,nvco2=',nvcou,nvco2
  255.             goto 9999
  256.          endif
  257.       endif         
  258. *
  259.       if (topinv.ne.0) then
  260.          segini,jveri=travj
  261.          jveri.topi=-4
  262.          jveri.nbl=-4
  263.          call intop2(jveri,impr)
  264.          IF (IERR.NE.0) RETURN
  265.          call retop2(jveri,impr)
  266.          IF (IERR.NE.0) RETURN
  267. * Comparaison
  268.          topi2 =jveri.topi
  269.          lident=.true.
  270.          if (topi2.ldgt.ne.ldgt) lident=.false.
  271.          if (topi2.tlc(/1).eq.tlc(/1)) then
  272.             do i=1,tlc(/1)
  273.                if (topi2.tlc(i).ne.tlc(i)) lident=.false.
  274.             enddo
  275.          else
  276.             lident=.false.
  277.          endif
  278.          if (topi2.tic(/1).eq.tic(/1)) then
  279.             do i=1,tic(/1)
  280.                if (topi2.tic(i).ne.tic(i)) lident=.false.
  281.             enddo
  282.          else
  283.             lident=.false.
  284.          endif
  285.          if (topi2.tdc(/1).eq.tdc(/1)) then
  286.             do i=1,tdc(/1)
  287.                if (topi2.tdc(i).ne.tdc(i)) lident=.false.
  288.             enddo
  289.          else
  290.             lident=.false.
  291.          endif
  292.          if (.not.lident) then
  293.             write(ioimp,*)
  294.      $           'vetopi : Anomalie détectée',
  295.      $           ' dans les topologies inverses '
  296.             write(ioimp,*) 'JTOPO'
  297.             call ecmai1(jtopo,0)
  298.             write(ioimp,*) 'TOPINV'
  299.             call ectopi(TOPINV,1)
  300.             call ectopi(TOPINV,2)
  301.             write(ioimp,*) 'TOPI2'
  302.             call ectopi(TOPI2,1)
  303.             call ectopi(TOPI2,2)
  304.             goto 9999
  305.          endif
  306.          segsup,topi2
  307.          segsup,jveri
  308.       endif         
  309. *
  310. * Normal termination
  311. *
  312.       RETURN
  313. *
  314. * Format handling
  315. *
  316.  185  FORMAT (5X,A32,6I8)
  317.  187  FORMAT (5X,10I8)
  318.  188  FORMAT ('Apres point IELEM(',I2,',1)=',I6,' ; NBL=')
  319.  189  FORMAT ('Le noeud ',I2,'/',I2,' de IELEM de numero',I6
  320.      $     ,' a le plus petit nb de voisins :',I3)
  321. *     
  322. * Error handling     
  323. *     
  324.  9999 CONTINUE
  325.       write(ioimp,*) MMOT
  326.       MOTERR(1:8)='VETOPI  '
  327. * 349 2
  328. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  329.       CALL ERREUR(349)
  330.       RETURN
  331. *
  332. * End of subroutine VETOPI
  333. *
  334.       END
  335.  
  336.  
  337.  

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