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   25/11/24    21:15:27     12406          
  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. * Menage pas forcement fait
  168.       if (iveri.ge.3) then
  169.          if (jtopo.ne.0) then
  170.             do iel=1,nvmax
  171.                do ino=1,idimp
  172.                   nnod=jtopo.num(ino,iel)
  173.                   if (nnod.lt.0.or.nnod.gt.npcou) then
  174.                      write(ioimp,185) 'jtopo : ino,iel,nnod,npcou=',ino
  175.      $                    ,iel,nnod,npcou
  176.                      goto 9999
  177.                   endif
  178.                enddo
  179.             enddo
  180.          endif
  181. *
  182. *     Petite vérification de nvcou et de npcou
  183. *
  184.          if (jcoord.ne.0) then
  185.             npco2=0
  186.             do icoo=npmax*idimp,1,-1
  187.                if (jcoord.xcoor(icoo).ne.0.d0) then
  188.                   npco2=((icoo-1)/IDIMP)+1
  189.                   goto 33
  190.                endif
  191.             enddo
  192.  33         continue
  193. *     le dernier noeud peut avoir comme coordonnées 0. 0.
  194. *     mais on considère qu'il n'y a pas plusieurs noeuds localisés en 0. 0.
  195. *     if (npcou.ne.npco2) then
  196.             if (npcou.ne.npco2.and.npcou.ne.npco2+1) then
  197. *         if (npcou.lt.npco2) then
  198.                write(ioimp,185) 'jcoord : npcou,npco2=',npcou,npco2
  199.                goto 9999
  200.             endif
  201.          endif
  202. *
  203.          if (jcmetr.ne.0) then
  204.             npco3=0
  205.             do innoe=npmax,1,-1
  206. *            if (innoe.ne.jpvirt) then
  207.                do inin=1,jcmetr.xin(/1)
  208.                   if (jcmetr.xin(inin,innoe).ne.0.d0) then
  209.                      npco3=innoe
  210.                      goto 43
  211.                   endif
  212.                enddo
  213. *            endif
  214.             enddo
  215.  43         continue
  216. * if..endif suivant un peu inutile mais plus lisible ?
  217.             if (jpvirt.ne.0) then
  218.                if (jpvirt.eq.npco3+1) npco3=npco3+1
  219.             endif
  220. *     le dernier noeud peut avoir comme coordonnées 0. 0.
  221. *     mais on considère qu'il n'y a pas plusieurs noeuds localisés en 0. 0.
  222.             if (npcou.ne.npco3) then
  223. *         if (npcou.ne.npco3.and.npcou.ne.npco3+1) then
  224. *         if (npcou.lt.npco3) then
  225.                write(ioimp,185) 'jcmetr : npcou,npco3=',npcou,npco3
  226.                goto 9999
  227.             endif
  228.          endif
  229.          if (jtopo.ne.0) then
  230.             nvco2=0
  231.             do iel=nvmax,1,-1
  232.                do ino=1,idimp
  233.                   if (jtopo.num(ino,iel).ne.0) then
  234.                      nvco2=iel
  235.                      goto 44
  236.                   endif
  237.                enddo
  238.             enddo
  239.  44         continue
  240. *     if (nvcou.ne.nvco2) then
  241.             if (nvcou.lt.nvco2) then
  242.                write(ioimp,185) 'jtopo : nvcou,nvco2=',nvcou,nvco2
  243.                goto 9999
  244.             endif
  245.          endif
  246.       endif
  247.       if (topinv.ne.0) then
  248.          do ilc=nvmax*idimp,1,-1
  249.             if (tlc(ilc).ne.0) then
  250.                nvco2=((ilc-1)/IDIMP)+1
  251.                goto 55
  252.             endif
  253.          enddo
  254.  55      continue
  255. *         if (nvcou.ne.nvco2) then
  256.          if (nvcou.lt.nvco2) then
  257.             write(ioimp,185) 'topinv : nvcou,nvco2=',nvcou,nvco2
  258.             goto 9999
  259.          endif
  260.       endif
  261. *
  262.       if (topinv.ne.0) then
  263.          segini,jveri=travj
  264.          jveri.topi=-4
  265.          jveri.nbl=-4
  266.          call intop2(jveri,impr)
  267.          IF (IERR.NE.0) RETURN
  268.          call retop2(jveri,impr)
  269.          IF (IERR.NE.0) RETURN
  270. * Comparaison
  271.          topi2 =jveri.topi
  272.          lident=.true.
  273.          if (topi2.ldgt.ne.ldgt) lident=.false.
  274.          if (topi2.tlc(/1).eq.tlc(/1)) then
  275.             do i=1,tlc(/1)
  276.                if (topi2.tlc(i).ne.tlc(i)) lident=.false.
  277.             enddo
  278.          else
  279.             lident=.false.
  280.          endif
  281.          if (topi2.tic(/1).eq.tic(/1)) then
  282.             do i=1,tic(/1)
  283.                if (topi2.tic(i).ne.tic(i)) lident=.false.
  284.             enddo
  285.          else
  286.             lident=.false.
  287.          endif
  288.          if (topi2.tdc(/1).eq.tdc(/1)) then
  289.             do i=1,tdc(/1)
  290.                if (topi2.tdc(i).ne.tdc(i)) lident=.false.
  291.             enddo
  292.          else
  293.             lident=.false.
  294.          endif
  295.          if (.not.lident) then
  296.             write(ioimp,*)
  297.      $           'vetopi : Anomalie détectée',
  298.      $           ' dans les topologies inverses '
  299.             write(ioimp,*) 'JTOPO'
  300.             call ecmai1(jtopo,0)
  301.             write(ioimp,*) 'TOPINV'
  302.             call ectopi(TOPINV,1)
  303.             call ectopi(TOPINV,2)
  304.             write(ioimp,*) 'TOPI2'
  305.             call ectopi(TOPI2,1)
  306.             call ectopi(TOPI2,2)
  307.             goto 9999
  308.          endif
  309.          segsup,topi2
  310.          segsup,jveri
  311.       endif
  312. *
  313. * Normal termination
  314. *
  315.       RETURN
  316. *
  317. * Format handling
  318. *
  319.  185  FORMAT (5X,A32,6I8)
  320.  187  FORMAT (5X,10I8)
  321.  188  FORMAT ('Apres point IELEM(',I2,',1)=',I6,' ; NBL=')
  322.  189  FORMAT ('Le noeud ',I2,'/',I2,' de IELEM de numero',I6
  323.      $     ,' a le plus petit nb de voisins :',I3)
  324. *
  325. * Error handling
  326. *
  327.  9999 CONTINUE
  328.       write(ioimp,*) MMOT
  329.       MOTERR(1:8)='VETOPI  '
  330. * 349 2
  331. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  332.       CALL ERREUR(349)
  333.       RETURN
  334. *
  335. * End of subroutine VETOPI
  336. *
  337.       END
  338.  
  339.  

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