1 : C SOUCHA SOURCE GOUNAND 14/01/29 21:15:16 7923
2 : ************************************************************************
3 : * NOM : soucha.eso
4 : * DESCRIPTION : Extraction d'une sous-chaîne
5 : ************************************************************************
6 : * HISTORIQUE : 13/03/2012 : JCARDO : création de la subroutine
7 : * HISTORIQUE :
8 : * HISTORIQUE :
9 : ************************************************************************
10 : * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
11 : * en cas de modification de ce sous-programme afin de faciliter
12 : * la maintenance !
13 : ************************************************************************
14 : * APPELÉ PAR : extrai.eso
15 : ************************************************************************
16 : * ENTRÉES :: CSTR = chaîne dont on veut extraire une sous-chaîne
17 : * LSTR = longueur de CSTR
18 : * CTYP = mode d'extraction ('ENTIER' ou 'LISTENTI')
19 : * SORTIES :: aucune
20 : ************************************************************************
21 : * SYNTAXE (GIBIANE) :
22 : *
23 : * MOT2 = EXTR MOT1 | ENTI1 (ENTI2) |
24 : * | LENTI1 |
25 : *
26 : ************************************************************************
27 : SUBROUTINE SOUCHA(CSTR,LSTR,CTYP)
28 : IMPLICIT INTEGER(I-N)
29 : IMPLICIT REAL*8(A-H,O-Z)
30 :
31 : -INC CCOPTIO
32 : -INC SMLENTI
33 :
34 : CHARACTER*8 CTYP
35 : CHARACTER*512 CSTR,CSTR2
36 :
37 :
38 : * =====================================
39 : * EXTRACTION À PARTIR DE 1 OU 2 ENTIERS
40 : * =====================================
41 :
42 : IF (CTYP.EQ.'ENTIER') THEN
43 :
44 : * Lecture de la position du premier caractère à extraire
44 : CALL LIRENT(IPOS1,1,IRETOU)
45 : IF (IPOS1.LT.1.OR.IPOS1.GT.LSTR) THEN
45 : CALL ERREUR(21)
46 : WRITE (IOIMP,9001) 'le nombre ENTI1',1,LSTR
47 : RETURN
48 : ENDIF
49 :
50 : * Lecture de la position du dernier caractère à extraire
51 : IPOS2=LSTR
51 : CALL LIRENT(IPOS2,0,IRETOU)
52 : IF (IPOS2.LT.IPOS1.OR.IPOS2.GT.LSTR) THEN
52 : CALL ERREUR(21)
53 : WRITE (IOIMP,9001) 'le nombre ENTI2',IPOS1,LSTR
54 : RETURN
55 : ENDIF
56 :
57 : * Extraction et renvoi de la sous-chaîne
57 : CALL ECRCHA(CSTR(IPOS1:IPOS2))
58 : RETURN
59 :
60 :
61 :
62 :
63 : * =================================
64 : * EXTRACTION À PARTIR D'UN LISTENTI
65 : * =================================
66 :
67 : ELSEIF (CTYP.EQ.'LISTENTI') THEN
68 :
69 : * Lecture de l'objet LISTENTI
69 : CALL LIROBJ('LISTENTI',MLENTI,1,IRETOU)
70 : SEGACT MLENTI
71 :
72 : * Construction de la sous-chaîne
73 : NCAR=LECT(/1)
74 : IF (NCAR.EQ.0) THEN
74 : CALL ERREUR(21)
75 : WRITE (IOIMP,*) '(le LISTENTI ne contient aucun élément)'
76 : RETURN
77 : ENDIF
78 :
79 : CSTR2=' '
80 : DO IA=1,NCAR
81 : IB=LECT(IA)
82 : IF (IB.LT.1.OR.IB.GT.LSTR) THEN
82 : CALL ERREUR(21)
83 : WRITE (IOIMP,9001) 'chaque nombre du LISTENTI',1,LSTR
84 : RETURN
85 : ENDIF
86 :
87 : CSTR2(IA:IA)=CSTR(IB:IB)
88 : ENDDO
89 :
90 : * Renvoi de la sous-chaîne
91 : SEGDES MLENTI
91 : CALL ECRCHA(CSTR2(1:NCAR))
92 : RETURN
93 :
94 : ENDIF
95 :
96 :
97 :
98 :
99 :
100 : * ERREUR 39 : On ne veut pas d'objet de type %m1:8
101 : MOTERR(1:8)=CTYP
101 : CALL ERREUR(39)
102 : RETURN
103 :
104 :
105 : * Format du message d'erreur en cas de données incompatibles
106 : 9001 FORMAT('('A,' doit être compris entre ',I2,' et ',I2,')')
107 :
108 : END
109 :
110 :
111 :
© Cast3M 2003 - All rights reserved.
Disclaimer