Numérotation des lignes :

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***********************************************************************CC                             E N L E V EC                             -----------CC            SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "ENLEVER"CC FONCTION:C ---------CC     ENLEVER UN ELEMENT D'UN OBJET (QUAND CELA A UN SENS).CCC PHRASE D'APPEL (EN GIBIANE):C ----------------------------CC          OBJET2 = ENLEVER OBJET1 (MOT_CLE) INDIC1 ;CCC OPERANDES ET RESULTATS:C -----------------------CC  +----------------+----------------+----------------+----------------+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  +----------------+----------------+----------------+----------------+CC   Fonction non accepteeC  +----------------+----------------+----------------+----------------+C  |    MCHAML      |     AUCUN      |    MOT         |    MCHAML      |C  |    MCHAML      |     AUCUN      |    LISTMOTS    |    MCHAML      |C  +----------------+----------------+----------------+----------------+CCC MODE DE FONCTIONNEMENT:C -----------------------CC     APPEL D'UN SOUS-PROGRAMME DISTINCT SELON LE TYPE OBJET1 :C       LISTREEL   => ENLEV1C       LISTENTI   => ENLEV2C       LISTMOTS   => ENLEV3C       LISTCHPO   => ENLEV4C       CHPOINT    => ENLEV5C       TABLE      => ENLEV6C       CHARGEMENT => traite en interne dans cette subroutineC       MMODEL     => ENLEV7C       MCHAML     => ENLEV8CCC AUTEUR, DATE DE CREATION:C -------------------------CC     PASCAL MANIGOT     5 DECEMBRE 1984C     DATE DE MODIFICATION 22 JANVIER 88C     P.M.  21/06/88 : REINTRODUCTION DES TABLESC     JCARDO 9/12/14 : INDIC1 type LISTENTI pour OBJET1 type LISTxxxxC     M.B.  xx/06/16 : INDIC1 type MOT pour OBJET1 type MMODELC     C.B.  30/05/17 : Prise en compte des MCHAMLCCC LANGAGE:C --------CC     FORTRAN77CC***********************************************************************C -INC PPARAM-INC CCOPTIO-INC SMLENTI-INC SMLMOTS-INC SMCHARGC      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  CONTINUEC     IPOS&lt;>0 => on autorise IPOIN2 à contenir un LISTENTI      IPOS=1      CALL LIRE01 (IPOIN1,IPOS,IPOIN2)      IF (IERR.NE.0) RETURNCC     Si plusieurs indices sont donnes, on trie par ordre croissantC     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  CONTINUEC      CALL LIROBJ('MCHAML',IPMCH,1,IRETOU)C      IF (IERR .NE. 0) RETURNC      CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)C      IF (IERR .NE. 0) RETURNCC      IF(IRETOU.NE.0) THENC        CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)C        IF (IERR .NE. 0) RETURNCC      ELSEC       JGN    = 4C       JGM    = 10C       INCJGM = 10C        SEGINI,MLMOTSC        IB = 0C 601    CALL LIRCHA(CMOMOT,0,IRETOU)C        IF(IRETOU.EQ.0) GOTO 602C        IB=IB+1C        IF (IB .GT. JGM) THENC         JGM    = JGM + INCJGMC          INCJGM = INCJGM * 2C          SEGADJ,MLMOTSC        ENDIFC        MLMOTS.MOTS(IB)=CMOMOTC        GOTO 601CC 602    CONTINUEC        IF(IB .EQ. 0) THENC          CALL ERREUR(6)C          RETURNCC        ELSEIF(IB .NE. JGM)THENC          JGM = IBC          SEGADJ,MLMOTS          C        ENDIFCC        CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)C        IF (IERR .NE. 0) RETURNC        SEGSUP MLMOTSC      ENDIFCC      CALL ECROBJ ('MCHAML',IPOIN2)C      RETURN      END     

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