Télécharger excham.eso

Retour à la liste

Numérotation des lignes :

  1. C EXCHAM SOURCE PV 17/10/03 21:15:25 9581
  2. SUBROUTINE EXCHAM(ICOLAC,ITLACC,M1,M2,IIICHA)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. *--------------------------------------------------------------------*
  6. * *
  7. * Sous-programme appel{ par EXPIL, traitant la pile des *
  8. * nouveaux CHAMELEMs. *
  9. * *
  10. * Param}tres: *
  11. * *
  12. * e ICOLAC pointeur sur le chapeau des piles *
  13. * es ITLACC pointeur de la pile examin{e *
  14. * e M1 premier indice d'examen dans la pile *
  15. * e M2 dernier indice d'examen dans la pile *
  16. * e IIICHA = 1 : on change les pointeurs *
  17. * *
  18. *--------------------------------------------------------------------*
  19. -INC CCOPTIO
  20. -INC SMCHAML
  21. -INC TMCOLAC
  22. *
  23. CHARACTER*8 MOTIP
  24. CHARACTER*16 MOTYP
  25. *
  26. IF (M1.GT.M2) RETURN
  27. *
  28. ICO1 = KCOLA( 1)
  29. ILISSE=ILISSG
  30. SEGACT ILISSE*MOD
  31. DO 10 IEL=M1,M2
  32. MCHELM = ITLAC(IEL)
  33. IF (MCHELM.EQ.0) GO TO 10
  34. SEGACT,MCHELM*MOD
  35. N3 = INFCHE(/2)
  36. if (ichaml(/1).lt.0.or.ichaml(/1).gt.10000000) then
  37. * chelm invalide. On le supprime de la pile
  38. moterr(1:8)='MCHELM '
  39. interr(1)=itlac(iel)
  40. call erreur(861)
  41. itlac(iel)=0
  42. goto 10
  43. endif
  44. DO 20 I=1,ICHAML(/1)
  45. MCHAML = ICHAML(I)
  46. SEGACT,MCHAML*MOD
  47. *
  48. IVA = IMACHE(I)
  49. IF(IVA.GT.0) THEN
  50. CALL AJOUN(ICO1,IVA,ILISSE,1)
  51. IF (IIICHA.EQ.1) IMACHE(I) =-IVA
  52. ENDIF
  53. *
  54. IF(N3.GE.4) THEN
  55. IVA = INFCHE(I,4)
  56. ICO2 = KCOLA(40)
  57. IF(IVA.GT.0) THEN
  58. CALL AJOUN(ICO2,IVA,ILISSE,1)
  59. IF (IIICHA.EQ.1) INFCHE(I,4) =-IVA
  60. ENDIF
  61. ENDIF
  62. *
  63. DO 30 J=1,TYPCHE(/2)
  64. MOTYP = TYPCHE(J)
  65. IF (MOTYP(1:6).NE.'REAL*8') THEN
  66. MOTIP(1:8)=MOTYP(9:16)
  67. CALL TYPFIL(MOTIP,ITYP)
  68. IF (ITYP.GT.0) THEN
  69. NUMLIS=1
  70. ilissd=ilissg
  71. IF(ITYP.EQ.24) NUMLIS=6
  72. C IF(ITYP.EQ.25) NUMLIS=4
  73. IF(ITYP.EQ.26) NUMLIS=2
  74. IF(ITYP.EQ.27) NUMLIS=5
  75. IF(ITYP.EQ.32) then
  76. NUMLIS=3
  77. ILISSD=ilissp
  78. ENDIF
  79. IF(ITYP.EQ.36) NUMLIS=7
  80. ICO2 = KCOLA(ITYP)
  81. MELVAL = IELVAL(J)
  82. SEGACT,MELVAL*MOD
  83. NAL1 = IELCHE(/1)
  84. NAL2 = IELCHE(/2)
  85. DO 40 I2=1,NAL2
  86. DO 50 I1=1,NAL1
  87. IVA = IELCHE(I1,I2)
  88. IF(IVA.GT.0) THEN
  89. CALL AJOUN(ICO2,IVA,ILISSD,NUMLIS)
  90. IF (IIICHA.EQ.1) IELCHE(I1,I2) =-IVA
  91. ENDIF
  92. 50 CONTINUE
  93. * END DO
  94. 40 CONTINUE
  95. * END DO
  96. SEGDES,MELVAL
  97.  
  98. ENDIF
  99. ELSE
  100. * segment de reel. Il a sa propre pile, IELVAL
  101. if (ionive.ge.20) then
  102. IVA=IELVAL(J)
  103. ICO2=KCOLA(48)
  104. ** write (6,*) ' ajout de ',iva,' dans ',ico2
  105. IF (IVA.GT.0) THEN
  106. CALL AJOUN(ICO2,IVA,ILISSE,1)
  107. IF (IIICHA.EQ.1) IELVAL(J)=-IVA
  108. ENDIF
  109. endif
  110. ENDIF
  111. 30 CONTINUE
  112. * END DO
  113. SEGDES,MCHAML
  114. 20 CONTINUE
  115. * END DO
  116. SEGDES,MCHELM
  117. 10 CONTINUE
  118. * END DO
  119. *
  120. * SEGDES ILISSE
  121. RETURN
  122. END
  123.  
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  

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