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