Télécharger reduir.eso

Retour à la liste

Numérotation des lignes :

  1. C REDUIR SOURCE CB215821 19/08/20 21:21:32 10287
  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. 4 CONTINUE
  38. NNOE=IKI
  39. C
  40. MCHPOI=ICHP
  41. SEGACT MCHPOI
  42. NSOUP=IPCHP(/1)
  43. NSOUPO=0
  44. NBNN=1
  45. NBSOUS=0
  46. NBREF=0
  47. SEGINI ITRAV
  48. DO 1 ISOU=1,NSOUP
  49. NBELEM=0
  50. MSOUPO=IPCHP(ISOU)
  51. SEGACT MSOUPO
  52. MELEME=IGEOC
  53. SEGACT MELEME
  54. N2=NUM(/2)
  55. DO 2 I=1,N2
  56. IF(ICPR(NUM(1,I)).EQ.0) GO TO 2
  57. NBELEM=NBELEM+1
  58. IF (NBELEM.GT.NNOE) CALL ERREUR(476)
  59. IF (IERR.NE.0) RETURN
  60. ITRAV1(NBELEM)=I
  61. 2 CONTINUE
  62. IF(NBELEM.EQ.0) GOTO 3
  63. MPOVAL=IPOVAL
  64. SEGACT MPOVAL
  65. NC=VPOCHA(/2)
  66. N=NBELEM
  67. SEGINI MPOVA1
  68. SEGINI IPT1
  69. IPT1.ITYPEL=1
  70. DO 17 I=1,NBELEM
  71. IP1=ITRAV1(I)
  72. IPT1.NUM(1,I)=NUM(1,IP1)
  73. DO 8 IC=1,NC
  74. MPOVA1.VPOCHA(I,IC)=VPOCHA(IP1,IC)
  75. 8 CONTINUE
  76. 17 CONTINUE
  77. IPT11=IPT1
  78. CALL CRECH1(IPT1,1)
  79. SEGINI MSOUP1
  80. MSOUP1.IGEOC=IPT1
  81. MSOUP1.IPOVAL=MPOVA1
  82. IF (IPT11.NE.IPT1) THEN
  83. IPT1=IPT11
  84. SEGSUP,IPT1
  85. ENDIF
  86. DO 9 IC=1,NC
  87. MSOUP1.NOCOMP(IC)=NOCOMP(IC)
  88. MSOUP1.NOHARM(IC)=NOHARM(IC)
  89. 9 CONTINUE
  90. NSOUPO=NSOUPO+1
  91. ITRAV2(NSOUPO)=MSOUP1
  92. 3 CONTINUE
  93. 1 CONTINUE
  94. SEGSUP ICPR
  95. NAT=JATTRI(/1)
  96. SEGINI MCHPO1
  97. DO 10 I=1,NAT
  98. MCHPO1.JATTRI(I)=JATTRI(I)
  99. 10 CONTINUE
  100. DO 11 I=1,NSOUPO
  101. MCHPO1.IPCHP(I)=ITRAV2(I)
  102. 11 CONTINUE
  103. MCHPO1.IFOPOI=IFOPOI
  104. MCHPO1.MTYPOI=MTYPOI
  105. MCHPO1.MOCHDE=MOCHDE
  106. IRET=MCHPO1
  107. 5000 CONTINUE
  108. SEGSUP ITRAV
  109. END
  110.  
  111.  
  112.  

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