Télécharger reduir.eso

Retour à la liste

Numérotation des lignes :

  1. C REDUIR SOURCE CB215821 20/11/25 13:38:52 10792
  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.  
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8 (a-h,o-z)
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC SMCHPOI
  15. -INC SMELEME
  16. -INC SMCOORD
  17.  
  18. SEGMENT ICPR(nbpts)
  19. SEGMENT/ITRAV/(ITRAV1(NNOE),ITRAV2(NSOUP))
  20.  
  21. SEGINI ICPR
  22. IRET=0
  23. MELEME=IMEL
  24. SEGACT MELEME
  25. IKI=0
  26. NBSOUS=LISOUS(/1)
  27. IPT1=MELEME
  28. DO 4 ISOU=1,MAX(1,NBSOUS)
  29. IF (NBSOUS.NE.0) THEN
  30. IPT1=LISOUS(ISOU)
  31. SEGACT IPT1
  32. ENDIF
  33. NBNN=IPT1.NUM(/1)
  34. NBELEM=IPT1.NUM(/2)
  35. DO 6 I1=1,NBELEM
  36. DO 7 I2=1,NBNN
  37. IP1=IPT1.NUM(I2,I1)
  38. IF(ICPR(IP1).NE.0) GO TO 7
  39. IKI=IKI+1
  40. ICPR(IP1)=IKI
  41. 7 CONTINUE
  42. 6 CONTINUE
  43. 4 CONTINUE
  44. NNOE=IKI
  45. C
  46. MCHPOI=ICHP
  47. SEGACT MCHPOI
  48. NSOUP=IPCHP(/1)
  49. NSOUPO=0
  50. NBNN=1
  51. NBSOUS=0
  52. NBREF=0
  53. SEGINI ITRAV
  54. DO 1 ISOU=1,NSOUP
  55. NBELEM=0
  56. MSOUPO=IPCHP(ISOU)
  57. SEGACT MSOUPO
  58. MELEME=IGEOC
  59. SEGACT MELEME
  60. N2=NUM(/2)
  61. DO 2 I=1,N2
  62. IF(ICPR(NUM(1,I)).EQ.0) GO TO 2
  63. NBELEM=NBELEM+1
  64. IF (NBELEM.GT.NNOE) CALL ERREUR(476)
  65. IF (IERR.NE.0) RETURN
  66. ITRAV1(NBELEM)=I
  67. 2 CONTINUE
  68. IF(NBELEM.EQ.0) GOTO 3
  69. MPOVAL=IPOVAL
  70. SEGACT MPOVAL
  71. NC=VPOCHA(/2)
  72. N=NBELEM
  73. SEGINI MPOVA1
  74. SEGINI IPT1
  75. IPT1.ITYPEL=1
  76. DO 17 I=1,NBELEM
  77. IP1=ITRAV1(I)
  78. IPT1.NUM(1,I)=NUM(1,IP1)
  79. DO 8 IC=1,NC
  80. MPOVA1.VPOCHA(I,IC)=VPOCHA(IP1,IC)
  81. 8 CONTINUE
  82. 17 CONTINUE
  83. IPT11=IPT1
  84. CALL CRECH1(IPT1,1)
  85. SEGINI MSOUP1
  86. MSOUP1.IGEOC=IPT1
  87. MSOUP1.IPOVAL=MPOVA1
  88. IF (IPT11.NE.IPT1) THEN
  89. IPT1=IPT11
  90. SEGSUP,IPT1
  91. ENDIF
  92. DO 9 IC=1,NC
  93. MSOUP1.NOCOMP(IC)=NOCOMP(IC)
  94. MSOUP1.NOHARM(IC)=NOHARM(IC)
  95. 9 CONTINUE
  96. NSOUPO=NSOUPO+1
  97. ITRAV2(NSOUPO)=MSOUP1
  98. 3 CONTINUE
  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. IRET=MCHPO1
  113. 5000 CONTINUE
  114. SEGSUP ITRAV
  115. END
  116.  
  117.  
  118.  
  119.  
  120.  

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