Télécharger genmct.eso

Retour à la liste

Numérotation des lignes :

genmct
  1. C GENMCT SOURCE CHAT 05/01/13 00:17:25 5004
  2. SUBROUTINE GENMCT(MCTP0,MCTD0,MCT)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. -INC SMELEME
  6. POINTEUR MCTP.MELEME,MCTD.MELEME,MCT.MELEME
  7. POINTEUR MCTP0.MELEME,MCTD0.MELEME
  8.  
  9.  
  10. SEGACT MCTP0,MCTD0
  11. NBSOUP=MCTP0.LISOUS(/1)
  12. NBSOUD=MCTD0.LISOUS(/1)
  13. IF(NBSOUP.EQ.0)NBSOUP=1
  14. IF(NBSOUD.EQ.0)NBSOUD=1
  15.  
  16. NBSOUS=0
  17. NBREF=0
  18. NBNN=0
  19. NBELEM=0
  20. SEGINI MELEME
  21. C write(6,*)' MELEME=',MELEME
  22.  
  23. IX1=0
  24. IX2=0
  25.  
  26. NBSOU0=0
  27. DO 40 L=1,NBSOUP
  28. IPT1=MCTP0
  29. IF(NBSOUP.NE.1)IPT1=MCTP0.LISOUS(L)
  30. SEGACT IPT1
  31. NP1=IPT1.NUM(/1)
  32. NBEL1=IPT1.NUM(/2)
  33. IF(IX1.EQ.0)THEN
  34. N1D=1
  35. N1A=NBEL1
  36. LG1=NBEL1
  37. K1=0
  38. ENDIF
  39.  
  40. DO 50 M=1,NBSOUD
  41. IPT2=MCTD0
  42. IF(NBSOUD.NE.1)IPT1=MCTD0.LISOUS(M)
  43. SEGACT IPT2
  44. NP2=IPT2.NUM(/1)
  45. NBEL2=IPT2.NUM(/2)
  46. IF(IX2.EQ.0)THEN
  47. N2D=1
  48. N2A=NBEL2
  49. LG2=NBEL2
  50. K2=0
  51. ENDIF
  52.  
  53. NBELEM=0
  54. NBNN=0
  55. NBREF=0
  56. NBSOU0=NBSOU0+1
  57. NBSOUS=NBSOU0
  58.  
  59. C write(6,*)' NBSOUS=',nbsous
  60. SEGADJ MELEME
  61.  
  62. NBELEM=MIN(LG1,LG2)
  63. NBNN=NP1+NP2
  64. NBREF=0
  65. NBSOUS=0
  66. SEGINI IPT3
  67. LISOUS(NBSOU0)=IPT3
  68. IPT3.ITYPEL=28
  69. C write(6,*)' NBELEM,NBNN,NP1,NP2,K1,K2=',
  70. C & NBELEM,NBNN,NP1,NP2,K1,K2
  71. DO 61 K=1,NBELEM
  72. K1=K1+1
  73. K2=K2+1
  74. DO 62 I=1,NP1
  75. IPT3.NUM(I,K)=IPT1.NUM(I,K1)
  76. 62 CONTINUE
  77. DO 63 I=1,NP2
  78. IPT3.NUM(I+NP1,K)=IPT2.NUM(I,K2)
  79. 63 CONTINUE
  80. 61 CONTINUE
  81.  
  82. IF(K1.EQ.NBEL1)THEN
  83. IX2=1
  84. GO TO 40
  85. ELSEIF(K2.EQ.NBEL2)THEN
  86. IX1=1
  87. GO TO 50
  88. ENDIF
  89.  
  90. 50 CONTINUE
  91. 40 CONTINUE
  92.  
  93.  
  94. IF(NBSOU0.EQ.1)THEN
  95. SEGSUP MELEME
  96. MELEME=IPT3
  97. ENDIF
  98. MCT=MELEME
  99. RETURN
  100. END
  101.  
  102.  
  103.  

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