Télécharger refe.eso

Retour à la liste

Numérotation des lignes :

  1. C REFE SOURCE CHAT 05/01/13 02:47:59 5004
  2. SUBROUTINE REFE
  3. C***********************************************************************
  4. C
  5. C Opérateur REFE
  6. C ______________
  7. C
  8. C
  9. C OBJET : Lister les objets maillages inclus au sens des noeuds dans
  10. C ----- un autre ou indiquer si un objet maillage est inclus dans
  11. C un autre.
  12. C
  13. C SYNTAXE 1 : LOBI = REFE OBJ2 ;
  14. C -------
  15. C LOBI : objet LISTMOTS contenant la liste
  16. C
  17. C
  18. C SYNTAXE 2 : LOGI = OBJ1 REFE OBJ2 ;
  19. C -------
  20. C LOGI : objet de type LOGIQUE prenant les valeurs VRAI
  21. C ou FAUX suivant que OBJ1 est inclus ou non dans
  22. C OBJ2
  23. C
  24. C***********************************************************************
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8 (A-H,O-Z)
  27. C
  28. -INC CCOPTIO
  29. -INC SMELEME
  30. -INC SMLMOTS
  31. -INC SMCOORD
  32. -INC SMLENTI
  33. C
  34. SEGMENT IZTGN
  35. CHARACTER*8 NOML(0)
  36. ENDSEGMENT
  37. SEGMENT/IZTGP/(IPTL(0))
  38. SEGMENT TABOG
  39. CHARACTER*8 NOMOG(0)
  40. ENDSEGMENT
  41. SEGMENT TIBOG
  42. INTEGER NIMOG(0)
  43. ENDSEGMENT
  44. C
  45. C- Décodage des arguments et détermination de la syntaxe utilisée :
  46. C- CAS 1 : On fait la liste de tous les objets inclus dans obj1
  47. C- CAS 2 : On regarde si obj1 est inclus dans obj2
  48. C
  49. CALL LIROBJ('MAILLAGE',MELEM1,1,IRETOU)
  50. IF (IRETOU.NE.1) RETURN
  51. CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU)
  52. IF (IRETOU.EQ.0) THEN
  53. IKAS = 1
  54. MELEME = MELEM1
  55. ELSE
  56. IKAS = 2
  57. MELEME = MELEM2
  58. ENDIF
  59. MELEM0 = MELEME
  60. C
  61. C- Initialisation du LISTENTI de travail indiquant si le point
  62. C- numéro I est dans le maillage;
  63. C- LECT(I)<>0 : Le point numéro I est dans le MELEME
  64. C
  65. SEGACT MCOORD
  66. NBNOUV = XCOOR(/1)/(IDIM+1)
  67. JG = NBNOUV
  68. SEGINI MLENTI
  69. SEGACT MELEME
  70. NBSOUS = LISOUS(/1)
  71. IF (NBSOUS.EQ.0) NBSOUS=1
  72. NPTD = 0
  73. DO 20 KS=1,NBSOUS
  74. IF (NBSOUS.EQ.1) THEN
  75. IPT1 = MELEME
  76. ELSE
  77. IPT1 = LISOUS(KS)
  78. ENDIF
  79. SEGACT IPT1
  80. NP = IPT1.NUM(/1)
  81. NEL = IPT1.NUM(/2)
  82. DO 10 K=1,NEL
  83. DO 10 N=1,NP
  84. IF (LECT(IPT1.NUM(N,K)).EQ.0) THEN
  85. NPTD = NPTD + 1
  86. LECT(IPT1.NUM(N,K)) = NPTD
  87. ENDIF
  88. 10 CONTINUE
  89. IF (MELEME.NE.IPT1) SEGDES IPT1
  90. 20 CONTINUE
  91. SEGDES MELEME
  92. C
  93. C- Liste des objets maillage à comparer à MELEM0
  94. C
  95. IF (IKAS.EQ.1) THEN
  96. IZTGN = 0
  97. IZTGP = 0
  98. CALL LFILE(' ','MAILLAGE',IZTGN,IZTGP)
  99. IF (IERR.NE.0) THEN
  100. SEGSUP MLENTI
  101. RETURN
  102. ENDIF
  103. SEGACT IZTGN,IZTGP
  104. ELSE
  105. SEGINI IZTGN,IZTGP
  106. NOML(**) = 'INDEFINI'
  107. IPTL(**) = MELEM1
  108. ENDIF
  109. C
  110. C- Inclusion au sens des points des maillages de pointeur IPTL(L)
  111. C- et de nom NOML(L) dans le maillage de pointeur MELEM0.
  112. C
  113. SEGINI TABOG,TIBOG
  114. NL = IPTL(/1)
  115. DO 60 L=1,NL
  116. MELEME = IPTL(L)
  117. IPT1 = MELEME
  118. IF (MELEME.EQ.MELEM0) THEN
  119. NOMOG(**) = NOML(L)
  120. NIMOG(**) = IPTL(L)
  121. ELSE
  122. SEGACT MELEME
  123. NBSOUS = LISOUS(/1)
  124. IF (NBSOUS.EQ.0) NBSOUS=1
  125. DO 40 KS=1,NBSOUS
  126. IF (NBSOUS.EQ.1) THEN
  127. IPT1 = MELEME
  128. ELSE
  129. IPT1 = LISOUS(KS)
  130. ENDIF
  131. SEGACT IPT1
  132. NP = IPT1.NUM(/1)
  133. NEL = IPT1.NUM(/2)
  134. DO 30 K=1,NEL
  135. DO 30 I=1,NP
  136. NU = LECT(IPT1.NUM(I,K))
  137. IF (NU.EQ.0) GOTO 50
  138. 30 CONTINUE
  139. SEGDES IPT1
  140. 40 CONTINUE
  141. NOMOG(**) = NOML(L)
  142. NIMOG(**) = IPTL(L)
  143. 50 CONTINUE
  144. SEGDES IPT1
  145. SEGDES MELEME
  146. ENDIF
  147. 60 CONTINUE
  148. C
  149. C- Ecriture du résultat et ménage
  150. C
  151. NBO = NIMOG(/1)
  152. IF (IKAS.EQ.1) THEN
  153. JGM = NOMOG(/2)
  154. JGN = 8
  155. SEGINI MLMOTS
  156. IF (JGM.EQ.0) THEN
  157. CALL ERREUR(-313)
  158. ELSE
  159. DO 70 I=1,JGM
  160. MOTS(I) = NOMOG(I)
  161. 70 CONTINUE
  162. ENDIF
  163. SEGDES MLMOTS
  164. CALL ECROBJ('LISTMOTS',MLMOTS)
  165. ELSE
  166. IF (NBO.EQ.0) THEN
  167. CALL ECRLOG(.FALSE.)
  168. ELSE
  169. CALL ECRLOG(.TRUE.)
  170. ENDIF
  171. ENDIF
  172. SEGSUP IZTGN,IZTGP,TABOG,TIBOG,MLENTI
  173. RETURN
  174. END
  175.  
  176.  
  177.  

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