Télécharger exachp.eso

Retour à la liste

Numérotation des lignes :

  1. C EXACHP SOURCE PV 17/11/13 21:15:00 9609
  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. -INC CCOPTIO
  30. -INC TMCOLAC
  31. -INC SMCOORD
  32. -INC SMELEME
  33. ICO1=KCOLA(1)
  34. ILISSE=ILISSG
  35. SEGACT ILISSE*MOD
  36. DO 604 IEL=M1,m2
  37. MCHPOI=ITLAC(IEL)
  38. IF (MCHPOI.EQ.0) GO TO 604
  39. if (.NOT.ooovp1(mchpoi)) goto 610
  40. SEGACT MCHPOI
  41. IJK=IPCHP(/1)
  42. IF (IJK.EQ.0) GO TO 606
  43. if (ijk.gt.1000) GOTO 610
  44. DO 605 I=1,IJK
  45. MSOUPO=IPCHP(I)
  46. IF (MSOUPO.EQ.0) GO TO 610
  47. if (.NOT.ooovp1(msoupo)) goto 610
  48. SEGACT MSOUPO*MOD
  49. IVA=IGEOC
  50. if (.NOT.ooovp1(iva)) goto 610
  51. meleme=igeoc
  52. segact meleme
  53. if (num(/1).ne.1.or.num(/2).gt.xcoor(/1)/(idim+1)) goto 610
  54. * compression des meleme si possible
  55. if (iva.gt.0) then
  56. ivas=0
  57. ***trop couteux pour le gain si il y a beaucoup de meleme donc uniquement dans la sauvegarde
  58. if (iiicha.eq.1) call chleha(0,iva,ivas,ico1,ilisse)
  59. if (ivas.ne.0) then
  60. iva=ivas
  61. igeoc = iva
  62. endif
  63. endif
  64. IF (IVA.GT.0) THEN
  65. CALL AJOUN(ICO1,IVA,ILISSE,1)
  66. IF(IIICHA.EQ.1) IGEOC =-IVA
  67. ENDIF
  68. SEGDES MSOUPO
  69. 605 CONTINUE
  70. 606 SEGDES MCHPOI
  71. goto 604
  72. 610 continue
  73. * chpoint invalide. On le supprime de la pile
  74. moterr(1:8)='CHPOINT'
  75. interr(1)=itlac(iel)
  76. call erreur(861)
  77. itlac(iel)=0
  78. 604 CONTINUE
  79. RETURN
  80. C ************
  81. END
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  

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