Télécharger exachp.eso

Retour à la liste

Numérotation des lignes :

exachp
  1. C EXACHP SOURCE PV 21/01/21 21:15:16 10862
  2. SUBROUTINE EXACHP (ICOLAC,ITLACC,M1,M2,IIICHA)
  3. C----------------------------------------------------------------------
  4. C
  5. C BUT: REMPLIT LES PILES A PARTIR DE L EXAMEN DES CHPOINTS
  6. C SI IIICHA =1 ON CHANGE LES POINTEURS----
  7. C
  8. C ENTREE ITLACC POINTEUR DE LA PILE EXAMINEE
  9. C ICOLAC POINTEUR SUR LE CHAPEAU DES PILES
  10. C M1 @REMIER INDICE D EXAMEN DANS LA PILE
  11. C M2 DERNIER INDICE
  12. C IIICHA =1 ON CHANGE LES POINTEURS
  13. C----------------------------------------------------------------
  14. C APPELE PAR EXPIL
  15. C APPELLE AJOUN
  16. C
  17. C=======================================================================
  18. C TABLEAU KCOLA :
  19. C 1 MELEME 2 CHPOIN 3 MRIGID 4 MCHAFF 5 MCHELM 6
  20. C 7 8 MSOLUT 9 MSTRUC 10 11 MAFFEC 12 MSOSTU
  21. C 13 IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL
  22. C 19 MLENTI 20 MCHARG 21 MODELE 22 MEVOLL 23 MSUPER
  23. C=======================================================================
  24. C
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8(A-H,O-Z)
  27. logical ooovp1
  28. -INC SMCHPOI
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC TMCOLAC
  33. -INC SMCOORD
  34. -INC SMELEME
  35. iun=1
  36. ICO1=KCOLA(1)
  37. ILISSE=ILISSG
  38. SEGACT ILISSE*MOD
  39. DO 604 IEL=M1,m2
  40. MCHPOI=ITLAC(IEL)
  41. IF (MCHPOI.EQ.0) GO TO 604
  42. if (.NOT.ooovp1(mchpoi)) goto 610
  43. SEGACT MCHPOI
  44. IJK=IPCHP(/1)
  45. IF (IJK.EQ.0) GO TO 606
  46. if (ijk.gt.1000) GOTO 610
  47. DO 605 I=1,IJK
  48. MSOUPO=IPCHP(I)
  49. IF (MSOUPO.EQ.0) GO TO 610
  50. if (.NOT.ooovp1(msoupo)) goto 610
  51. SEGACT MSOUPO*MOD
  52. IVA=IGEOC
  53. if (.NOT.ooovp1(iva)) goto 610
  54. meleme=igeoc
  55. segact meleme
  56. if (num(/1).ne.1.or.num(/2).gt.nbpts) goto 610
  57. * compression des meleme si possible
  58. if (iva.gt.0) then
  59. ivas=0
  60. ***trop couteux pour le gain si il y a beaucoup de meleme donc uniquement dans la sauvegarde
  61. if (iiicha.eq.1) call chleha(0,iva,ivas,ico1,ilisse)
  62. if (ivas.ne.0) then
  63. iva=ivas
  64. igeoc = iva
  65. endif
  66. endif
  67. IF (IVA.GT.0) THEN
  68. CALL AJOUN(ICO1,IVA,ILISSE,iun)
  69. IF(IIICHA.EQ.1) IGEOC =-IVA
  70. ENDIF
  71. SEGDES MSOUPO
  72. 605 CONTINUE
  73. 606 SEGDES MCHPOI
  74. goto 604
  75. 610 continue
  76. * chpoint invalide. On le supprime de la pile
  77. moterr(1:8)='CHPOINT'
  78. interr(1)=itlac(iel)
  79. call erreur(861)
  80. itlac(iel)=0
  81. 604 CONTINUE
  82. RETURN
  83. C ************
  84. END
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  

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