Télécharger reduir.eso

Retour à la liste

Numérotation des lignes :

  1. C REDUIR SOURCE JC220346 16/06/14 21:15:01 8965
  2. SUBROUTINE REDUIR(ICHP,IMEL,IRET)
  3. C ======================================================================
  4. C REDUIT LE CHPOINT ICHP AUX POINTS CONTENUS DANS LE MELEME IMEL.LE
  5. C RESULTAT IRET EST UN MELEME.
  6. C ATTENTION : ON A DUPLIQUE LA GEOMETRIE ET LE MPOVAL DANS TOUS LES CAS
  7. C=======================================================================
  8. IMPLICIT INTEGER(I-N)
  9. -INC CCOPTIO
  10. -INC SMCHPOI
  11. -INC SMELEME
  12. -INC SMCOORD
  13. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  14. SEGMENT/ITRAV/(ITRAV1(NNOE),ITRAV2(NSOUP))
  15. SEGINI ICPR
  16. IRET=0
  17. MELEME=IMEL
  18. SEGACT MELEME
  19. IKI=0
  20. NBSOUS=LISOUS(/1)
  21. IPT1=MELEME
  22. DO 4 ISOU=1,MAX(1,NBSOUS)
  23. IF (NBSOUS.NE.0) THEN
  24. IPT1=LISOUS(ISOU)
  25. SEGACT IPT1
  26. ENDIF
  27. NBNN=IPT1.NUM(/1)
  28. NBELEM=IPT1.NUM(/2)
  29. DO 6 I1=1,NBELEM
  30. DO 7 I2=1,NBNN
  31. IP1=IPT1.NUM(I2,I1)
  32. IF(ICPR(IP1).NE.0) GO TO 7
  33. IKI=IKI+1
  34. ICPR(IP1)=IKI
  35. 7 CONTINUE
  36. 6 CONTINUE
  37. IF(NBSOUS.NE.0) SEGDES IPT1
  38. 4 CONTINUE
  39. SEGDES MELEME
  40. NNOE=IKI
  41. C
  42. MCHPOI=ICHP
  43. SEGACT MCHPOI
  44. NSOUP=IPCHP(/1)
  45. NSOUPO=0
  46. NBNN=1
  47. NBSOUS=0
  48. NBREF=0
  49. SEGINI ITRAV
  50. DO 1 ISOU=1,NSOUP
  51. NBELEM=0
  52. MSOUPO=IPCHP(ISOU)
  53. SEGACT MSOUPO
  54. MELEME=IGEOC
  55. SEGACT MELEME
  56. N2=NUM(/2)
  57. DO 2 I=1,N2
  58. IF(ICPR(NUM(1,I)).EQ.0) GO TO 2
  59. NBELEM=NBELEM+1
  60. IF (NBELEM.GT.NNOE) CALL ERREUR(476)
  61. IF (IERR.NE.0) RETURN
  62. ITRAV1(NBELEM)=I
  63. 2 CONTINUE
  64. IF(NBELEM.EQ.0) GOTO 3
  65. MPOVAL=IPOVAL
  66. SEGACT MPOVAL
  67. NC=VPOCHA(/2)
  68. N=NBELEM
  69. SEGINI MPOVA1
  70. SEGINI IPT1
  71. IPT1.ITYPEL=1
  72. DO 17 I=1,NBELEM
  73. IP1=ITRAV1(I)
  74. IPT1.NUM(1,I)=NUM(1,IP1)
  75. DO 8 IC=1,NC
  76. MPOVA1.VPOCHA(I,IC)=VPOCHA(IP1,IC)
  77. 8 CONTINUE
  78. 17 CONTINUE
  79. IPT11=IPT1
  80. CALL CRECH1(IPT1,1)
  81. SEGDES IPT1
  82. SEGDES MPOVAL,MPOVA1
  83. SEGINI MSOUP1
  84. MSOUP1.IGEOC=IPT1
  85. MSOUP1.IPOVAL=MPOVA1
  86. IF (IPT11.NE.IPT1) THEN
  87. IPT1=IPT11
  88. SEGSUP,IPT1
  89. ENDIF
  90. DO 9 IC=1,NC
  91. MSOUP1.NOCOMP(IC)=NOCOMP(IC)
  92. MSOUP1.NOHARM(IC)=NOHARM(IC)
  93. 9 CONTINUE
  94. SEGDES MSOUP1
  95. NSOUPO=NSOUPO+1
  96. ITRAV2(NSOUPO)=MSOUP1
  97. 3 CONTINUE
  98. SEGDES MSOUPO,MELEME
  99. 1 CONTINUE
  100. SEGSUP ICPR
  101. NAT=JATTRI(/1)
  102. SEGINI MCHPO1
  103. DO 10 I=1,NAT
  104. MCHPO1.JATTRI(I)=JATTRI(I)
  105. 10 CONTINUE
  106. DO 11 I=1,NSOUPO
  107. MCHPO1.IPCHP(I)=ITRAV2(I)
  108. 11 CONTINUE
  109. MCHPO1.IFOPOI=IFOPOI
  110. MCHPO1.MTYPOI=MTYPOI
  111. MCHPO1.MOCHDE=MOCHDE
  112. SEGDES MCHPO1
  113. IRET=MCHPO1
  114. 5000 CONTINUE
  115. SEGDES MCHPOI
  116. SEGSUP ITRAV
  117. RETURN
  118. END
  119.  
  120.  
  121.  

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