Télécharger reducp.eso

Retour à la liste

Numérotation des lignes :

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

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