Télécharger excham.eso

Retour à la liste

Numérotation des lignes :

excham
  1. C EXCHAM SOURCE PV 21/01/21 21:15:22 10862
  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 PPARAM
  20. -INC CCOPTIO
  21. -INC SMCHAML
  22. -INC TMCOLAC
  23. *
  24. CHARACTER*8 MOTIP
  25. CHARACTER*16 MOTYP
  26. *
  27. IF (M1.GT.M2) RETURN
  28. *
  29. iun=1
  30. ICO1 = KCOLA( 1)
  31. ILISSE=ILISSG
  32. SEGACT ILISSE*MOD
  33. DO 10 IEL=M1,M2
  34. MCHELM = ITLAC(IEL)
  35. IF (MCHELM.EQ.0) GO TO 10
  36. SEGACT,MCHELM*MOD
  37. N3 = INFCHE(/2)
  38. if (ichaml(/1).lt.0.or.ichaml(/1).gt.10000000) then
  39. * chelm invalide. On le supprime de la pile
  40. moterr(1:8)='MCHELM '
  41. interr(1)=itlac(iel)
  42. call erreur(861)
  43. itlac(iel)=0
  44. goto 10
  45. endif
  46. DO 20 I=1,ICHAML(/1)
  47. MCHAML = ICHAML(I)
  48. SEGACT,MCHAML*MOD
  49. *
  50. IVA = IMACHE(I)
  51. IF(IVA.GT.0) THEN
  52. CALL AJOUN(ICO1,IVA,ILISSE,iun)
  53. IF (IIICHA.EQ.1) IMACHE(I) =-IVA
  54. ENDIF
  55. *
  56. IF(N3.GE.4) THEN
  57. IVA = INFCHE(I,4)
  58. ICO2 = KCOLA(40)
  59. IF(IVA.GT.0) THEN
  60. CALL AJOUN(ICO2,IVA,ILISSE,iun)
  61. IF (IIICHA.EQ.1) INFCHE(I,4) =-IVA
  62. ENDIF
  63. ENDIF
  64. *
  65. DO 30 J=1,TYPCHE(/2)
  66. MOTYP = TYPCHE(J)
  67. IF (MOTYP(1:6).NE.'REAL*8') THEN
  68. MOTIP(1:8)=MOTYP(9:16)
  69. CALL TYPFIL(MOTIP,ITYP)
  70. IF (ITYP.GT.0) THEN
  71. NUMLIS=1
  72. ilissd=ilissg
  73. IF(ITYP.EQ.24) NUMLIS=6
  74. C IF(ITYP.EQ.25) NUMLIS=4
  75. IF(ITYP.EQ.26) NUMLIS=2
  76. IF(ITYP.EQ.27) NUMLIS=5
  77. IF(ITYP.EQ.32) then
  78. NUMLIS=3
  79. ILISSD=ilissp
  80. ENDIF
  81. IF(ITYP.EQ.36) NUMLIS=7
  82. ICO2 = KCOLA(ITYP)
  83. MELVAL = IELVAL(J)
  84. SEGACT,MELVAL*MOD
  85. NAL1 = IELCHE(/1)
  86. NAL2 = IELCHE(/2)
  87. DO 40 I2=1,NAL2
  88. DO 50 I1=1,NAL1
  89. IVA = IELCHE(I1,I2)
  90. IF(IVA.GT.0) THEN
  91. CALL AJOUN(ICO2,IVA,ILISSD,NUMLIS)
  92. IF (IIICHA.EQ.1) IELCHE(I1,I2) =-IVA
  93. ENDIF
  94. 50 CONTINUE
  95. * END DO
  96. 40 CONTINUE
  97. * END DO
  98. SEGDES,MELVAL
  99.  
  100. ENDIF
  101. ELSE
  102. * segment de reel. Il a sa propre pile, IELVAL
  103. if (ionive.ge.20) then
  104. IVA=IELVAL(J)
  105. ICO2=KCOLA(48)
  106. ** write (6,*) ' ajout de ',iva,' dans ',ico2
  107. IF (IVA.GT.0) THEN
  108. CALL AJOUN(ICO2,IVA,ILISSE,iun)
  109. IF (IIICHA.EQ.1) IELVAL(J)=-IVA
  110. ENDIF
  111. endif
  112. ENDIF
  113. 30 CONTINUE
  114. * END DO
  115. SEGDES,MCHAML
  116. 20 CONTINUE
  117. * END DO
  118. SEGDES,MCHELM
  119. 10 CONTINUE
  120. * END DO
  121. *
  122. * SEGDES ILISSE
  123. RETURN
  124. END
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  

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