Sources Esope | Cast3M

soucha
C SOUCHA    SOURCE    GOUNAND   14/01/29    21:15:16     7923
************************************************************************
* NOM         : soucha.eso
* DESCRIPTION : Extraction d'une sous-chaîne
************************************************************************
* HISTORIQUE :  13/03/2012 : JCARDO : création de la subroutine
* HISTORIQUE :
* HISTORIQUE :
************************************************************************
* Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
* en cas de modification de ce sous-programme afin de faciliter
* la maintenance !
************************************************************************
* APPELÉ PAR : extrai.eso
************************************************************************
* ENTRÉES :: CSTR = chaîne dont on veut extraire une sous-chaîne
*            LSTR = longueur de CSTR
*            CTYP = mode d'extraction ('ENTIER' ou 'LISTENTI')
* SORTIES :: aucune
************************************************************************
* SYNTAXE (GIBIANE) :
*
*        MOT2 = EXTR MOT1 | ENTI1 (ENTI2) |
*                         | LENTI1        |
*
************************************************************************
      SUBROUTINE SOUCHA(CSTR,LSTR,CTYP)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMLENTI
 
      CHARACTER*8  CTYP
      CHARACTER*512 CSTR,CSTR2
 
 
*     =====================================
*     EXTRACTION À PARTIR DE 1 OU 2 ENTIERS
*     =====================================
 
      IF (CTYP.EQ.'ENTIER') THEN
 
*         Lecture de la position du premier caractère à extraire
          CALL LIRENT(IPOS1,1,IRETOU)
          IF (IPOS1.LT.1.OR.IPOS1.GT.LSTR) THEN
              CALL ERREUR(21)
              WRITE (IOIMP,9001) 'le nombre ENTI1',1,LSTR
              RETURN
          ENDIF
 
*         Lecture de la position du dernier caractère à extraire
          IPOS2=LSTR
          CALL LIRENT(IPOS2,0,IRETOU)
          IF (IPOS2.LT.IPOS1.OR.IPOS2.GT.LSTR) THEN
              CALL ERREUR(21)
              WRITE (IOIMP,9001) 'le nombre ENTI2',IPOS1,LSTR
              RETURN
          ENDIF
 
*         Extraction et renvoi de la sous-chaîne
          CALL ECRCHA(CSTR(IPOS1:IPOS2))
          RETURN
 
 
 
 
*     =================================
*     EXTRACTION À PARTIR D'UN LISTENTI
*     =================================
 
      ELSEIF (CTYP.EQ.'LISTENTI') THEN
 
*         Lecture de l'objet LISTENTI
          CALL LIROBJ('LISTENTI',MLENTI,1,IRETOU)
          SEGACT MLENTI
 
*         Construction de la sous-chaîne
          NCAR=LECT(/1)
          IF (NCAR.EQ.0) THEN
              CALL ERREUR(21)
              WRITE (IOIMP,*) '(le LISTENTI ne contient aucun élément)'
              RETURN
          ENDIF
 
          CSTR2=' '
          DO IA=1,NCAR
              IB=LECT(IA)
              IF (IB.LT.1.OR.IB.GT.LSTR) THEN
                  CALL ERREUR(21)
                  WRITE (IOIMP,9001) 'chaque nombre du LISTENTI',1,LSTR
                  RETURN
              ENDIF
 
              CSTR2(IA:IA)=CSTR(IB:IB)
          ENDDO
 
*         Renvoi de la sous-chaîne
          SEGDES MLENTI
          CALL ECRCHA(CSTR2(1:NCAR))
          RETURN
 
      ENDIF
 
 
 
 
 
*     ERREUR 39 : On ne veut pas d'objet de type %m1:8
      MOTERR(1:8)=CTYP
      CALL ERREUR(39)
      RETURN
 
 
*     Format du message d'erreur en cas de données incompatibles
 9001 FORMAT('('A,' doit être compris entre ',I2,' et ',I2,')')
 
      END