Télécharger reduir.eso

Retour à la liste

Numérotation des lignes :

  1. C REDUIR SOURCE PV 20/03/30 21:23:41 10567
  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.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12. -INC SMCHPOI
  13. -INC SMELEME
  14. -INC SMCOORD
  15. SEGMENT ICPR(nbpts)
  16. SEGMENT/ITRAV/(ITRAV1(NNOE),ITRAV2(NSOUP))
  17. SEGINI ICPR
  18. IRET=0
  19. MELEME=IMEL
  20. SEGACT MELEME
  21. IKI=0
  22. NBSOUS=LISOUS(/1)
  23. IPT1=MELEME
  24. DO 4 ISOU=1,MAX(1,NBSOUS)
  25. IF (NBSOUS.NE.0) THEN
  26. IPT1=LISOUS(ISOU)
  27. SEGACT IPT1
  28. ENDIF
  29. NBNN=IPT1.NUM(/1)
  30. NBELEM=IPT1.NUM(/2)
  31. DO 6 I1=1,NBELEM
  32. DO 7 I2=1,NBNN
  33. IP1=IPT1.NUM(I2,I1)
  34. IF(ICPR(IP1).NE.0) GO TO 7
  35. IKI=IKI+1
  36. ICPR(IP1)=IKI
  37. 7 CONTINUE
  38. 6 CONTINUE
  39. 4 CONTINUE
  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. SEGINI MSOUP1
  82. MSOUP1.IGEOC=IPT1
  83. MSOUP1.IPOVAL=MPOVA1
  84. IF (IPT11.NE.IPT1) THEN
  85. IPT1=IPT11
  86. SEGSUP,IPT1
  87. ENDIF
  88. DO 9 IC=1,NC
  89. MSOUP1.NOCOMP(IC)=NOCOMP(IC)
  90. MSOUP1.NOHARM(IC)=NOHARM(IC)
  91. 9 CONTINUE
  92. NSOUPO=NSOUPO+1
  93. ITRAV2(NSOUPO)=MSOUP1
  94. 3 CONTINUE
  95. 1 CONTINUE
  96. SEGSUP ICPR
  97. NAT=JATTRI(/1)
  98. SEGINI MCHPO1
  99. DO 10 I=1,NAT
  100. MCHPO1.JATTRI(I)=JATTRI(I)
  101. 10 CONTINUE
  102. DO 11 I=1,NSOUPO
  103. MCHPO1.IPCHP(I)=ITRAV2(I)
  104. 11 CONTINUE
  105. MCHPO1.IFOPOI=IFOPOI
  106. MCHPO1.MTYPOI=MTYPOI
  107. MCHPO1.MOCHDE=MOCHDE
  108. IRET=MCHPO1
  109. 5000 CONTINUE
  110. SEGSUP ITRAV
  111. END
  112.  
  113.  
  114.  
  115.  

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