Sources Esope | Cast3M

enleve
C ENLEVE    SOURCE    CB215821  20/07/29    21:15:22     10668          
      SUBROUTINE ENLEVE
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C
C                             E N L E V E
C                             -----------
C
C            SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "ENLEVER"
C
C FONCTION:
C ---------
C
C     ENLEVER UN ELEMENT D'UN OBJET (QUAND CELA A UN SENS).
C
C
C PHRASE D'APPEL (EN GIBIANE):
C ----------------------------
C
C          OBJET2 = ENLEVER OBJET1 (MOT_CLE) INDIC1 ;
C
C
C OPERANDES ET RESULTATS:
C -----------------------
C
C  +----------------+----------------+----------------+----------------+
C  |    OBJET1      |    MOT_CLE     |    INDIC1      |    OBJET2      |
C  +================+================+================+================+
C  |    LISTREEL    |     AUCUN      |    ENTIER      |    LISTREEL    |
C  |    LISTREEL    |     AUCUN      |    LISTENTI    |    LISTREEL    |
C  +----------------+----------------+----------------+----------------+
C  |    LISTENTI    |     AUCUN      |    ENTIER      |    LISTENTI    |
C  |    LISTENTI    |     AUCUN      |    LISTENTI    |    LISTENTI    |
C  +----------------+----------------+----------------+----------------+
C  |    LISTMOTS    |     AUCUN      |    ENTIER      |    LISTMOTS    |
C  |    LISTMOTS    |     AUCUN      |    LISTENTI    |    LISTMOTS    |
C  +----------------+----------------+----------------+----------------+
C  |    LISTCHPO    |     AUCUN      |    ENTIER      |    LISTCHPO    |
C  |    LISTCHPO    |     AUCUN      |    LISTENTI    |    LISTCHPO    |
C  +----------------+----------------+----------------+----------------+
C  |    CHPOINT     |     AUCUN      |    MOT         |    CHPOINT     |
C  |    CHPOINT     |     AUCUN      |    LISTMOTS    |    CHPOINT     |
C  +----------------+----------------+----------------+----------------+
C  |    TABLE       |     AUCUN      |  (quelconque)  |    TABLE       |
C  +----------------+----------------+----------------+----------------+
C  |    CHARGEME    |     AUCUN      |    MOT         |    CHARGEMENT  |
C  +----------------+----------------+----------------+----------------+
C  |    MMODEL      |     'FORM'     |    MOT         |    MMODEL      |
C  |    MMODEL      |     'COMP'     |    MOT         |    MMODEL      |
C  +----------------+----------------+----------------+----------------+
C
C   Fonction non acceptee
C  +----------------+----------------+----------------+----------------+
C  |    MCHAML      |     AUCUN      |    MOT         |    MCHAML      |
C  |    MCHAML      |     AUCUN      |    LISTMOTS    |    MCHAML      |
C  +----------------+----------------+----------------+----------------+
C
C
C MODE DE FONCTIONNEMENT:
C -----------------------
C
C     APPEL D'UN SOUS-PROGRAMME DISTINCT SELON LE TYPE OBJET1 :
C       LISTREEL   => ENLEV1
C       LISTENTI   => ENLEV2
C       LISTMOTS   => ENLEV3
C       LISTCHPO   => ENLEV4
C       CHPOINT    => ENLEV5
C       TABLE      => ENLEV6
C       CHARGEMENT => traite en interne dans cette subroutine
C       MMODEL     => ENLEV7
C       MCHAML     => ENLEV8
C
C
C AUTEUR, DATE DE CREATION:
C -------------------------
C
C     PASCAL MANIGOT     5 DECEMBRE 1984
C     DATE DE MODIFICATION 22 JANVIER 88
C     P.M.  21/06/88 : REINTRODUCTION DES TABLES
C     JCARDO 9/12/14 : INDIC1 type LISTENTI pour OBJET1 type LISTxxxx
C     M.B.  xx/06/16 : INDIC1 type MOT pour OBJET1 type MMODEL
C     C.B.  30/05/17 : Prise en compte des MCHAML
C
C
C LANGAGE:
C --------
C
C     FORTRAN77
C
C***********************************************************************
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMLENTI
-INC SMLMOTS
-INC SMCHARG
C
      CHARACTER*(4) CMOMOT
      CHARACTER*8 CTYP
 
      PARAMETER (NBTYP=8)
      CHARACTER*8 TYPOK(NBTYP)
 
      DATA TYPOK /'TABLE   ','MMODEL  ','CHARGEME','CHPOINT ',
     &            'LISTREEL','LISTENTI','LISTMOTS','LISTCHPO'/
 
      CALL QUETYP(CTYP,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
        CALL ERREUR(533)
        RETURN
      ENDIF
 
C     Recherche de la position dans le DATA
      CALL PLACE(TYPOK,NBTYP,IPLACE,CTYP)
      IF (IERR .NE. 0) RETURN
 
      IF (IPLACE .EQ. 0) THEN
        CALL ERREUR(34)
        RETURN
      ENDIF
 
      GOTO(100,200,300,400,500,500,500,500),IPLACE
 
 
C     +---------------------------------------------------------------+
C     |            O B J E T 1   D E   T Y P E   T A B L E            |
C     +---------------------------------------------------------------+
C     (A LAISSER EN PREMIERE POSITION DANS CE SOUS-PROGRAMME)
 
 100  CONTINUE
      CALL LIROBJ ('TABLE',IPTABL,1,IRETOU)
      IF (IERR .NE. 0) RETURN
      CALL ENLEV6 (IPTABL,IPTAB2)
      IF (IERR .NE. 0) RETURN
      CALL ECROBJ ('TABLE',IPTAB2)
      RETURN
 
 
C     +---------------------------------------------------------------+
C     |            O B J E T 1   D E   T Y P E   M M O D E L          |
C     +---------------------------------------------------------------+
 200  CONTINUE
      CALL LIROBJ ('MMODEL  ',IPMOD1,1,IRETOU)
      IF (IERR .NE. 0) RETURN
      CALL ACTOBJ ('MMODEL  ',IPMOD1,1)
      CALL ENLEV7 (IPMOD1,IPMOD2)
      IF (IERR .NE. 0) RETURN
      CALL ACTOBJ ('MMODEL  ',IPMOD2,1)
      CALL ECROBJ ('MMODEL  ',IPMOD2)
      RETURN
 
 
C     +---------------------------------------------------------------+
C     |       O B J E T 1   D E   T Y P E   C H A R G E M E N T       |
C     +---------------------------------------------------------------+
 300  CONTINUE
      CALL LIROBJ('CHARGEME',MCHARG,1,IRETOU)
      IF (IERR .NE. 0) RETURN
      CALL ACTOBJ('CHARGEME',MCHARG,1)
      CALL LIRCHA(CMOMOT,1,IRETOU)
      IF (IERR .NE. 0) RETURN
      segini,MCHAR1=MCHARG
      N=0
      segact mcharg
      do IU=1,KCHARG(/1)
        if(CHANOM(iu).ne.CMOMOT) then
          n=n+1
          mchar1.kcharg(n)=kcharg(iu)
          mchar1.chanat(n)=chanat(iu)
          mchar1.chanom(n)=chanom(iu)
          mchar1.chamob(n)=chamob(iu)
          mchar1.chalie(n)=chalie(iu)
        endif
      enddo
      segadj mchar1
      call actobj('CHARGEME',mchar1,1)
      call ecrobj('CHARGEME',mchar1)
      return
 
 
C     +---------------------------------------------------------------+
C     |          O B J E T 1   D E   T Y P E   C H P O I N T          |
C     +---------------------------------------------------------------+
 400  CONTINUE
      CALL LIROBJ('CHPOINT ',IPCHP,1,IRETOU)
      IF (IERR .NE. 0) RETURN
      CALL ACTOBJ('CHPOINT ',IPCHP,1)
      CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
      IF (IERR .NE. 0) RETURN
 
      IF(IRETOU.NE.0) THEN
        CALL ACTOBJ('LISTMOTS',MLMOTS,1)
        CALL ENLEV5(IPCHP,MLMOTS,IPOIN2)
        IF (IERR .NE. 0) RETURN
 
      ELSE
        JGN    = 4
        JGM    = 10
        INCJGM = 10
        SEGINI,MLMOTS
        IB = 0
 401    CALL LIRCHA(CMOMOT,0,IRETOU)
        IF(IRETOU.EQ.0) GOTO 402
        IB=IB+1
        IF (IB .GT. JGM) THEN
          JGM    = JGM + INCJGM
          INCJGM = INCJGM * 2
          SEGADJ,MLMOTS
        ENDIF
        MLMOTS.MOTS(IB)=CMOMOT
        GOTO 401
 
 402    CONTINUE
        IF(IB .EQ. 0) THEN
          CALL ERREUR(6)
          RETURN
 
        ELSEIF(IB .NE. JGM)THEN
          JGM = IB
          SEGADJ,MLMOTS          
        ENDIF
 
        CALL ENLEV5(IPCHP,MLMOTS,IPOIN2)
        IF (IERR .NE. 0) RETURN
        SEGSUP MLMOTS
      ENDIF
 
      CALL ACTOBJ ('CHPOINT ',IPOIN2,1)
      CALL ECROBJ ('CHPOINT ',IPOIN2)
      RETURN
 
 
C     +---------------------------------------------------------------+
C     |         O B J E T 1   D E   T Y P E   L I S T x x x x         |
C     +---------------------------------------------------------------+
 500  CONTINUE
C     IPOS&lt;>0 => on autorise IPOIN2 à contenir un LISTENTI
      IPOS=1
      CALL LIRE01 (IPOIN1,IPOS,IPOIN2)
      IF (IERR.NE.0) RETURN
C
C     Si plusieurs indices sont donnes, on trie par ordre croissant
C     et on supprime les eventuels doublons
      IF (IPOS.LT.0) THEN
        MLENT2=IPOIN2
        SEGACT,MLENT2
        JG = MLENT2.LECT(/1)
        IF (JG.NE.0) THEN
            SEGINI,MLENT1=MLENT2
            IORDRE=0
            CALL ORDON2(MLENT1,.TRUE.,.FALSE.,IORDRE)
            SEGACT,MLENT1
            SEGINI,MLENTI
            LECT(1) = MLENT1.LECT(1)
            LL = 1
            IF (JG.GT.1) THEN
                M1 = LECT(1)
                DO JJ = 2, JG
                    M2 = MLENT1.LECT(JJ)
                    IF (M1.NE.M2) THEN
                        LL = LL+1
                        LECT(LL) = M2
                        M1 = M2
                    ENDIF
                ENDDO
            ENDIF
            JG = LL
            SEGADJ,MLENTI
            IPOIN2=MLENTI
            SEGSUP,MLENT1
        ELSE
          MLENTI = 0
        ENDIF
      ENDIF
 
C     ENLEVER DES INDICES D'UN LISTREEL
      IF     (ABS(IPOS).EQ.1) THEN
        CALL ENLEV1 (IPOIN1,IPOIN2,IPOIN3,IPOS)
        IF (IERR .NE. 0) RETURN
        CALL ACTOBJ ('LISTREEL',IPOIN3,1)
        CALL ECROBJ ('LISTREEL',IPOIN3)
 
C     ENLEVER DES INDICES D'UN LISTENTI
      ELSEIF (ABS(IPOS).EQ.2) THEN
        CALL ENLEV2 (IPOIN1,IPOIN2,IPOIN3,IPOS)
        IF (IERR .NE. 0) RETURN
        CALL ACTOBJ ('LISTENTI',IPOIN3,1)
        CALL ECROBJ ('LISTENTI',IPOIN3)
 
C     ENLEVER DES INDICES D'UN LISTMOTS
      ELSEIF (ABS(IPOS).EQ.3) THEN
        CALL ENLEV3 (IPOIN1,IPOIN2,IPOIN3,IPOS)
        IF (IERR .NE. 0) RETURN
        CALL ACTOBJ ('LISTMOTS',IPOIN3,1)
        CALL ECROBJ ('LISTMOTS',IPOIN3)
 
C     ENLEVER DES INDICES D'UN LISTCHPO
      ELSEIF (ABS(IPOS).EQ.4) THEN
        CALL ENLEV4 (IPOIN1,IPOIN2,IPOIN3,IPOS)
        IF (IERR .NE. 0) RETURN
        CALL ACTOBJ ('LISTCHPO',IPOIN3,1)
        CALL ECROBJ ('LISTCHPO',IPOIN3)
 
      ELSE
        MOTERR(1:8) = 'ENLEVER '
        CALL ERREUR(196)
        RETURN
      ENDIF
      IF (IPOS.LT.0 .AND. MLENTI.NE.0) SEGSUP,MLENTI
      RETURN
 
 
C     +---------------------------------------------------------------+
C     |         O B J E T 1   D E   T Y P E   MCHAML                  |
C     +---------------------------------------------------------------+
C 600  CONTINUE
C      CALL LIROBJ('MCHAML',IPMCH,1,IRETOU)
C      IF (IERR .NE. 0) RETURN
C      CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
C      IF (IERR .NE. 0) RETURN
C
C      IF(IRETOU.NE.0) THEN
C        CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
C        IF (IERR .NE. 0) RETURN
C
C      ELSE
C       JGN    = 4
C       JGM    = 10
C       INCJGM = 10
C        SEGINI,MLMOTS
C        IB = 0
C 601    CALL LIRCHA(CMOMOT,0,IRETOU)
C        IF(IRETOU.EQ.0) GOTO 602
C        IB=IB+1
C        IF (IB .GT. JGM) THEN
C         JGM    = JGM + INCJGM
C          INCJGM = INCJGM * 2
C          SEGADJ,MLMOTS
C        ENDIF
C        MLMOTS.MOTS(IB)=CMOMOT
C        GOTO 601
C
C 602    CONTINUE
C        IF(IB .EQ. 0) THEN
C          CALL ERREUR(6)
C          RETURN
C
C        ELSEIF(IB .NE. JGM)THEN
C          JGM = IB
C          SEGADJ,MLMOTS          
C        ENDIF
C
C        CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
C        IF (IERR .NE. 0) RETURN
C        SEGSUP MLMOTS
C      ENDIF
C
C      CALL ECROBJ ('MCHAML',IPOIN2)
C      RETURN
      END