Télécharger enlev5.eso

Retour à la liste

Numérotation des lignes :

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

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