Télécharger prex1d.eso

Retour à la liste

Numérotation des lignes :

  1. C PREX1D SOURCE BP208322 16/11/18 21:20:07 9177
  2.  
  3. C=======================================================================
  4. C= P R E X 1 D =
  5. C= ----------- =
  6. C= Ce sousprogramme determine les "extremites" d'un maillage 1D. =
  7. C= Il est l'image en 1D des sousprogrammes PRCONT (2D) et PRENVE (3D).=
  8. C= Il est appele par les operateurs FLUX et PRESSION. =
  9. C=======================================================================
  10.  
  11. SUBROUTINE PREX1D
  12.  
  13. IMPLICIT INTEGER(I-N)
  14. IMPLICIT REAL*8 (A-H,O-Z)
  15.  
  16. -INC CCOPTIO
  17. -INC CCGEOME
  18. -INC SMELEME
  19. -INC SMLENTI
  20.  
  21. C* IF (IDIM.NE.1) THEN
  22. C* CALL ERREUR(xx)
  23. C* RETURN
  24. C* ENDIF
  25.  
  26. C= Travail sur un maillage avec des SEG2 et/ou des POI
  27. C= C'est suffisant pour recuperer les points extremites
  28. CALL CHANLI
  29. IF (IERR.NE.0) RETURN
  30. CALL LIROBJ('MAILLAGE',ipmail,1,iOK)
  31. IF (IERR.NE.0) RETURN
  32.  
  33. C= On determine les composantes connexes du maillage
  34. C= CCON cree un nouveau maillage, meme si ipmail est elementaire.
  35. C= On peut donc detruire les maillages pointes dans ilect.
  36. CALL CCON1(ipmail,ilect)
  37. IF (IERR.NE.0) RETURN
  38.  
  39. C= On a alors au plus extremites = dimension de ilect * 2
  40. MLENT1=ilect
  41. SEGACT,MLENT1
  42. IG=MLENT1.LECT(/1)
  43. JG=2*IG
  44. SEGINI,MLENTI
  45. NBEXT=0
  46. C= Recuperation des points extremites
  47. C= On ordonne le maillage de SEG2.
  48. C= Dans le cas ou la composante connexe retournee par CCON contient
  49. C= plusieurs objets (normalement 2 de type POI1 et SEG2), les elements
  50. C= POI1 sont en fait des noeuds inclus dans le maillage SEG2, qui ne
  51. C= necessitent donc pas de traitement.
  52. DO i=1,IG
  53. IPT1=MLENT1.LECT(i)
  54. SEGACT,IPT1
  55. NSous=IPT1.LISOUS(/1)
  56. IF (NSous.NE.0) THEN
  57. C* MELEME=0
  58. DO j=1,NSous
  59. IPT2=IPT1.LISOUS(j)
  60. SEGACT,IPT2
  61. IF (IPT2.ITYPEL.EQ.2) MELEME=IPT2
  62. SEGDES,IPT2
  63. ENDDO
  64. C* IF (MELEME.EQ.0) --> ERREUR (a finir)
  65. SEGACT,MELEME
  66. ELSE
  67. MELEME=IPT1
  68. ENDIF
  69. IF (ITYPEL.EQ.1) THEN
  70. NBEXT=NBEXT+1
  71. LECT(NBEXT)=NUM(1,1)
  72. ELSE IF (ITYPEL.EQ.2) THEN
  73. CALL ORDON4(MELEME)
  74. SEGACT,MELEME
  75. NBEXT=NBEXT+1
  76. LECT(NBEXT)=NUM(1,1)
  77. NBEXT=NBEXT+1
  78. LECT(NBEXT)=NUM(2,NUM(/2))
  79. ENDIF
  80. SEGSUP,IPT1
  81. ENDDO
  82.  
  83. C= Initialisation du maillage de POI1 resultat
  84. NBNN=1
  85. NBELEM=NBEXT
  86. NBSOUS=0
  87. NBREF=0
  88. SEGINI,MELEME
  89. C= Remplissage du maillage
  90. ITYPEL=1
  91. DO i=1,NBEXT
  92. NUM(1,i)=LECT(i)
  93. ICOLOR(i)=IDCOUL
  94. ENDDO
  95. SEGDES,MELEME
  96. C= Ecriture du maillage resultat
  97. ipmail=MELEME
  98. CALL ECROBJ('MAILLAGE',ipmail)
  99.  
  100. C= Un peu de menage
  101. SEGSUP,MLENT1,MLENTI
  102.  
  103. RETURN
  104. END
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  

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