Télécharger enlev5.eso

Retour à la liste

Numérotation des lignes :

  1. C ENLEV5 SOURCE PV 20/03/30 21:18:43 10567
  2. SUBROUTINE ENLEV5(IPOIN1,MSWMIL,IPOIN2)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC SMCHPOI
  9. -INC SMCOORD
  10. -INC SMELEME
  11. -INC TMTRAV
  12. SEGMENT MSWMIL
  13. CHARACTER*4 MOTDDL(IAAA)
  14. ENDSEGMENT
  15. SEGMENT/MTRA/(ICPR(nbpts))
  16. SEGMENT MTR1
  17. CHARACTER*4 IPCOM(0)
  18. ENDSEGMENT
  19. SEGMENT/MTR2/(IPHAR(0))
  20. C
  21. SEGACT MSWMIL
  22. IBDDL=MOTDDL(/2)
  23. IF(IBDDL.EQ.0) THEN
  24. IPOIN2=IPOIN1
  25. RETURN
  26. ENDIF
  27. IF(IBDDL.EQ.1) THEN
  28. MCHPOI=IPOIN1
  29. SEGACT MCHPOI
  30. NSOUPO=IPCHP(/1)
  31. ITOT=0
  32. ISOU=0
  33. DO 4 IA=1,NSOUPO
  34. MSOUPO=IPCHP(IA)
  35. SEGACT MSOUPO
  36. NCBBB=NOCOMP(/2)
  37. IEXT=0
  38. DO 5 IB=1,NCBBB
  39. IF(NOCOMP(IB).EQ.MOTDDL(1)) THEN
  40. IEXT=IA
  41. ITOT=ITOT+1
  42. ENDIF
  43. 5 CONTINUE
  44. 4 CONTINUE
  45. IF(ITOT.NE.1) GO TO 2876
  46. IF(IEXT.EQ.0) GO TO 2876
  47. MSOUPO=IPCHP(IEXT)
  48. IF(NOCOMP(/2).NE.1) GO TO 2876
  49. NSOUPO=NSOUPO-1
  50. NC=IBDDL
  51. NAT=MAX ( JATTRI(/1) , 1)
  52. SEGINI MCHPO1
  53. MCHPO1.MTYPOI=MTYPOI
  54. MCHPO1.MOCHDE=MOCHDE
  55. IF ( JATTRI(/1) .GE. 1 ) THEN
  56. MCHPO1.JATTRI(1) = JATTRI(1)
  57. ELSE
  58. MCHPO1.JATTRI(1) = 0
  59. ENDIF
  60. MCHPO1.IFOPOI=IFOPOI
  61. IBB=0
  62. DO 7 IA=1,IPCHP(/1)
  63. MSOUPO=IPCHP(IA)
  64. IF ( IEXT.NE.IA) THEN
  65. SEGINI,MSOUP1=MSOUPO
  66. IBB=IBB+1
  67. IPT1=IGEOC
  68. SEGACT IPT1
  69. ** SEGINI,MELEME=IPT1
  70. MELEME=IPT1
  71. MPOVAL=IPOVAL
  72. SEGACT MPOVAL
  73. SEGINI,MPOVA1=MPOVAL
  74. MSOUP1.IGEOC=MELEME
  75. MSOUP1.IPOVAL=MPOVA1
  76. MCHPO1.IPCHP(IBB)=MSOUP1
  77. ENDIF
  78. 7 CONTINUE
  79. IPOIN2 = MCHPO1
  80. RETURN
  81. ENDIF
  82. 2876 CONTINUE
  83. C
  84. SEGINI MTRA,MTR1,MTR2
  85. C
  86. NC=0
  87. IK=0
  88. MCHPOI=IPOIN1
  89. SEGACT MCHPOI
  90. NSOUPO=IPCHP(/1)
  91. C
  92. C BOUCLE SUR LES SOUS REFERENCES DU CHPOINT
  93. C
  94. DO 350 IA=1,NSOUPO
  95. MSOUPO=IPCHP(IA)
  96. SEGACT MSOUPO
  97. NCBBB=NOCOMP(/2)
  98. MILCO=0
  99. C
  100. DO 330 IB=1,NCBBB
  101. DO 344 MIK=1,IBDDL
  102. IF(NOCOMP(IB).EQ.MOTDDL(MIK)) GO TO 330
  103. 344 CONTINUE
  104. NC=IPCOM(/2)
  105. DO 320 IC=1,NC
  106. IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320
  107. IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 331
  108. 320 CONTINUE
  109. IPCOM(**)=NOCOMP(IB)
  110. IPHAR(**)=NOHARM(IB)
  111. NC=NC+1
  112. 331 MILCO=MILCO+1
  113. 330 CONTINUE
  114. C
  115. IF(MILCO.NE.0) THEN
  116. MELEME=IGEOC
  117. SEGACT MELEME
  118. NBELEM=NUM(/2)
  119. DO 310 IB=1,NBELEM
  120. K=NUM(1,IB)
  121. IF(ICPR(K).NE.0) GO TO 310
  122. IK=IK+1
  123. ICPR(K)=IK
  124. 310 CONTINUE
  125. ENDIF
  126. 350 CONTINUE
  127. C
  128. NNIN=NC
  129. NNNOE=IK
  130. SEGINI MTRAV
  131. C
  132. C REMPLISSAGE DES TABLEAUX DU SEGMENT MTRAV
  133. C
  134. DO 380 IA=1,NNIN
  135. INCO(IA)=IPCOM(IA)
  136. NHAR(IA)=IPHAR(IA)
  137. 380 CONTINUE
  138. C
  139. DO 430 IA=1,NSOUPO
  140. MSOUPO=IPCHP(IA)
  141. SEGACT MSOUPO
  142. MELEME=IGEOC
  143. SEGACT MELEME
  144. MPOVAL=IPOVAL
  145. SEGACT MPOVAL
  146. NBELEM=NUM(/2)
  147. C
  148. DO 420 IB=1,NOCOMP(/2)
  149. DO 390 IC=1,NNIN
  150. IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390
  151. IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400
  152. 390 CONTINUE
  153. GO TO 420
  154. 400 CONTINUE
  155. DO 410 ID=1,NBELEM
  156. KI=ICPR(NUM(1,ID))
  157. IF(KI.EQ.0) GO TO 410
  158. IGEO(KI)=NUM(1,ID)
  159. IBIN(IC,KI)=1
  160. BB(IC,KI)=VPOCHA(ID,IB)
  161. 410 CONTINUE
  162. 420 CONTINUE
  163. 430 CONTINUE
  164. C
  165. ITRAV=MTRAV
  166. C
  167. CALL CRECHP(ITRAV,IPOIN2)
  168. C ATTRIBUTION D'UNE NATURE A IPOIN2 IDENTIQUE AU CHPO IPOIN1
  169. MCHPO1 = IPOIN2
  170. SEGACT MCHPO1
  171. NAT = MAX ( MCHPO1.JATTRI(/1) , 1)
  172. NSOUPO = MCHPO1.IPCHP(/1)
  173. SEGADJ MCHPO1
  174. IF ( JATTRI(/1) .GE. 1 ) THEN
  175. MCHPO1.JATTRI(1) = JATTRI(1)
  176. ELSE
  177. MCHPO1.JATTRI(1) = 0
  178. ENDIF
  179. SEGSUP MTRAV,MTRA,MTR1,MTR2
  180. END
  181.  
  182.  
  183.  
  184.  

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