Télécharger reducp.eso

Retour à la liste

Numérotation des lignes :

  1. C REDUCP SOURCE CHAT 05/01/13 02:47:17 5004
  2. SUBROUTINE REDUCP (MCHPOI,MCHPO1,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. -INC CCOPTIO
  5. -INC SMCHPOI
  6. -INC SMELEME
  7. -INC TMTRAV
  8. REAL*8 EPS
  9. SEGMENT NOINCO
  10. CHARACTER*4 INC(NMA)
  11. INTEGER NHA(NMA)
  12. ENDSEGMENT
  13. *
  14. * VERIFICATION QUE LES DEUX CHPOINTS ONT EXACTEMENT LA MEME STRUCTURE
  15. *
  16. SEGACT MCHPOI,MCHPO1
  17. IF (IPCHP(/1).NE.MCHPO1.IPCHP(/1)) THEN
  18. CALL ERREUR(21)
  19. SEGDES MCHPOI,MCHPO1
  20. RETURN
  21. ENDIF
  22. EPS=1.D-5
  23. NMA=0
  24. NNNOE=0
  25. DO 1 I = 1 , IPCHP(/1)
  26. MSOUPO=IPCHP(I)
  27. MSOUP1=MCHPO1.IPCHP(I)
  28. SEGACT MSOUPO,MSOUP1
  29. NMA=NMA+NOCOMP(/2)
  30. IF(NOCOMP(/2).NE.MSOUP1.NOCOMP(/2)) THEN
  31. SEGDES MCHPOI,MCHPO1,MSOUPO,MSOUP1
  32. CALL ERREUR(21)
  33. RETURN
  34. ENDIF
  35. DO 2 J=1,NOCOMP(/2)
  36. IF (NOCOMP(J).EQ.MSOUP1.NOCOMP(J)) THEN
  37. IF (NOHARM(J).NE.MSOUP1.NOHARM(J)) THEN
  38. SEGDES MCHPOI,MCHPO1,MSOUPO,MSOUP1
  39. CALL ERREUR (21)
  40. RETURN
  41. ENDIF
  42. ELSE
  43. SEGDES MCHPOI,MCHPO1,MSOUPO,MSOUP1
  44. CALL ERREUR (21)
  45. RETURN
  46. ENDIF
  47. 2 CONTINUE
  48. MELEME=IGEOC
  49. IPT1=MSOUP1.IGEOC
  50. SEGACT MELEME,IPT1
  51. NNNOE=NNNOE+NUM(/2)
  52. IF(NUM(/2).NE.IPT1.NUM(/2)) THEN
  53. CALL ERREUR(21)
  54. SEGDES MCHPOI,MCHPO1,MSOUPO,MSOUP1,MELEME,IPT1
  55. RETURN
  56. ENDIF
  57. 1 CONTINUE
  58. *
  59. * ON CHERCHE LA DIMENSION DE MTRAV
  60. *
  61. SEGINI NOINCO
  62. NNIN=0
  63. DO 3 I=1,IPCHP(/1)
  64. MSOUPO=IPCHP(I)
  65. DO 4 J=1,NOCOMP(/2)
  66. DO 5 K=1,NNIN
  67. IF (INC(K).NE.NOCOMP(J)) GO TO 5
  68. IF(NHA(K).EQ.NOHARM(J)) GO TO 4
  69. 5 CONTINUE
  70. NNIN=NNIN+1
  71. INC(NNIN)=NOCOMP(J)
  72. NHA(NNIN)=NOHARM(J)
  73. 4 CONTINUE
  74. 3 CONTINUE
  75. *
  76. * CREATION DE MTRAV ET REMPLISSAGE
  77. *
  78. SEGINI MTRAV
  79. DO 6 I=1,NNIN
  80. INCO(I)=INC(I)
  81. NHAR(I)=NHA(I)
  82. 6 CONTINUE
  83. NDEJ=0
  84. DO 7 I=1,IPCHP(/1)
  85. MSOUPO=IPCHP(I)
  86. MSOUP1=MCHPO1.IPCHP(I)
  87. MELEME=IGEOC
  88. DO 8 J=1,NUM(/2)
  89. IGEO(J+NDEJ)=NUM(1,J)
  90. 8 CONTINUE
  91. MPOVAL=IPOVAL
  92. MPOVA1=MSOUP1.IPOVAL
  93. SEGACT MPOVAL,MPOVA1
  94. DO 9 J=1,NOCOMP(/2)
  95. DO 10 K=1,NNIN
  96. IF(INCO(K).EQ.NOCOMP(J)) THEN
  97. IF(NHAR(K).EQ.NOHARM(J)) THEN
  98. NHA(J)=K
  99. GO TO 9
  100. ENDIF
  101. ENDIF
  102. 10 CONTINUE
  103. CALL ERREUR(5)
  104. RETURN
  105. 9 CONTINUE
  106. DO 11 J=1,NUM(/2)
  107. DO 12 K=1,NOCOMP(/2)
  108. NN=NHA(K)
  109. IF(ABS(MPOVA1.VPOCHA(J,K)).GT.EPS) THEN
  110. BB(NN,NDEJ+J)=VPOCHA(J,K)
  111. IBIN(NN,NDEJ+J)=1
  112. ENDIF
  113. 12 CONTINUE
  114. 11 CONTINUE
  115. NDEJ=NDEJ+NUM(/2)
  116. SEGDES MELEME,IPT1,MPOVAL,MPOVA1,MSOUPO,MSOUP1
  117. 7 CONTINUE
  118.  
  119. SEGDES MTRAV,MCHPOI,MCHPO1
  120. CALL CRECHP(MTRAV,IRET)
  121. *
  122. * on attribut les memes natures
  123. MCHPO2 = IRET
  124. SEGACT MCHPOI,MCHPO2
  125. NAT = MAX(1,JATTRI(/1))
  126. NSOUPO=MCHPO2.IPCHP(/1)
  127. SEGADJ MCHPO2
  128. IF ( JATTRI(/1) .NE. 0) THEN
  129. DO 13 I=1,NAT
  130. MCHPO2.JATTRI(I)=JATTRI(I)
  131. 13 CONTINUE
  132. ENDIF
  133. *
  134. SEGDES MCHPOI,MCHPO2
  135. SEGSUP MTRAV,NOINCO
  136. RETURN
  137. END
  138.  
  139.  

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