Sources Esope | Cast3M

exachp
C EXACHP    SOURCE    OF166741  24/11/14    21:15:10     12078          
 
C----------------------------------------------------------------------
C  BUT:  REMPLIT LES PILES A PARTIR DE L EXAMEN DES CHPOINTS
C        SI IIICHA =1 ON  CHANGE  LES POINTEURS----
C
C     ENTREE ITLACC POINTEUR DE LA PILE EXAMINEE
C            ICOLAC POINTEUR SUR LE CHAPEAU DES PILES
C            M1     @REMIER INDICE D EXAMEN DANS LA PILE
C            M2     DERNIER INDICE
C            IIICHA =1 ON CHANGE LES POINTEURS
C----------------------------------------------------------------
C   APPELE PAR EXPIL
C   APPELLE AJOUN
C=======================================================================
C  TABLEAU KCOLA : VOIR TYPFIL
C=======================================================================
 
      SUBROUTINE EXACHP (ICOLAC,ITLACC,M1,M2,IIICHA)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMCOORD
-INC SMELEME
-INC SMCHPOI
 
-INC TMCOLAC
 
      LOGICAL ooovp1
 
      IF (M1.GT.M2) RETURN
 
      iun = 1
      ILISSE = icolac.ILISSG
      SEGACT,ILISSE*MOD
 
      ICO1 = icolac.KCOLA(1)
 
      DO 604 IEL = M1, M2
        MCHPOI = itlacc.ITLAC(IEL)
        IF (MCHPOI.EQ.0) GOTO 604
        if (.NOT.ooovp1(MCHPOI)) goto 610
 
        SEGACT,MCHPOI
        ijk = mchpoi.IPCHP(/1)
        IF (ijk.EQ.0) GOTO 606
        IF (ijk.GT.1000) GOTO 610
 
        DO 605 i = 1, ijk
          MSOUPO = mchpoi.IPCHP(i)
          IF (MSOUPO.EQ.0) GOTO 610
          if (.NOT.ooovp1(MSOUPO)) goto 610
          IF (IIICHA.EQ.1) THEN
            SEGACT,MSOUPO*MOD
          ELSE
            SEGACT,MSOUPO
          ENDIF
          iva = msoupo.IGEOC
          IF (IIICHA.EQ.1 .and. iva.le.0) goto 607
          if (.NOT.ooovp1(iva)) goto 610
          meleme = iva
          segact,meleme
          if (num(/1).ne.1.or.num(/2).gt.NBPTS) goto 610
* compression des meleme si possible
* trop couteux pour le gain s'il y a beaucoup de meleme donc uniquement dans la sauvegarde
          IF (IIICHA.EQ.1) then
            ivas = 0
            CALL chleha(0,iva,ivas,ICO1,ILISSE)
            if (ivas.ne.0) msoupo.IGEOC = ivas
          ENDIF
          iva = msoupo.IGEOC
          CALL AJOUN(ICO1,iva,ILISSE,iun)
          IF (IIICHA.EQ.1) msoupo.IGEOC = -iva
 607      continue
          SEGDES MSOUPO
 605    CONTINUE
 
 606    SEGDES MCHPOI
        GOTO 604
 
*  chpoint invalide. On le supprime de la pile
 610    continue
        moterr(1:8) = 'CHPOINT'
        interr(1) = mchpoi
        call erreur(861)
        itlac(iel)=0
 
C     ************
 604  CONTINUE
 
      RETURN
      END