Télécharger refe.eso

Retour à la liste

Numérotation des lignes :

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

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