1 : C POSI SOURCE GOUNAND 14/01/31 21:15:09 7927
2 : ************************************************************************
3 : * NOM : POSI
4 : * DESCRIPTION : Renvoie la position d'éléments dans une liste d'éléments
5 : ************************************************************************
6 : * HISTORIQUE : 26/07/2012 : JCARDO : création de l'opérateur
7 : * HISTORIQUE : 14/12/2012 : JCARDO : ajout de l'option 'TOUS'
8 : * HISTORIQUE : 14/01/2014 : SG : trouver une sous-chaine dans une
9 : * chaine
10 : * HISTORIQUE :
11 : ************************************************************************
12 : * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
13 : * en cas de modification de ce sous-programme afin de faciliter
14 : * la maintenance !
15 : ************************************************************************
16 : * APPELÉ PAR : pilot.eso
17 : ************************************************************************
18 : * ENTRÉES :: aucune
19 : * SORTIES :: aucune
20 : ************************************************************************
21 : * SYNTAXES (GIBIANE) :
22 : *
23 : * 1) CHERCHE LA PREMIÈRE OCCURRENCE D'UN ITEM DANS UNE LISTE :
24 : * ENTI1 = POSI ENTI2 'DANS' LENT1 ;
25 : * ENTI1 = POSI FLOT1 'DANS' LREE1 (DTOL1) ;
26 : * ENTI1 = POSI MOT1 'DANS' LMOT1 ('NOCA') ;
27 : *
28 : * 2) CHERCHE TOUTES LES OCCURRENCES D'UN ITEM DANS UNE LISTE :
29 : * LENT1 = POSI ENTI1 'DANS' LENT2 'TOUS' ;
30 : * LENT1 = POSI FLOT1 'DANS' LREE1 (DTOL1) 'TOUS' ;
31 : * LENT1 = POSI MOT1 'DANS' LMOT1 ('NOCA') 'TOUS' ;
32 : *
33 : * 3) CHERCHE LA PREMIÈRE OCCURRENCE DE PLUSIEURS ITEMS DANS UNE LISTE :
34 : * LENT1 = POSI LENT2 'DANS' LENT3 ;
35 : * LENT1 = POSI LREE1 'DANS' LREE2 (DTOL1) ;
36 : * LENT1 = POSI LMOT1 'DANS' LMOT2 ('NOCA') ;
37 : *
38 : *
39 :
40 : *
41 : ************************************************************************
42 : SUBROUTINE POSI
43 :
44 : IMPLICIT INTEGER(I-N)
45 : IMPLICIT REAL*8(A-H,O-Z)
46 :
47 : -INC CCOPTIO
48 : -INC CCREEL
49 :
50 : -INC SMLENTI
51 : -INC SMLREEL
52 : -INC SMLMOTS
53 :
54 : EXTERNAL LONG
55 : PARAMETER (NCLE=2)
56 : CHARACTER*4 MCLE,LCLE(NCLE)
57 :
58 : CHARACTER*8 CHA8,MTYP2,MTYP3,MTYP4
59 :
60 : PARAMETER (LMOT=4)
61 : CHARACTER*(LMOT) MVAL2,MVAL3
62 : PARAMETER (LMOTL=512)
63 : CHARACTER*(LMOTL) MVAL2L,MVAL3L
64 : *
65 : LOGICAL ZLISTE,ZNOCA,ZTOUS
66 :
67 : DATA LCLE/'NOCA','TOUS'/
68 : *
69 : * +---------------------------------------------------------------+
70 : * | |
71 : * | L E C T U R E D E S A R G U M E N T S |
72 : * | |
73 : * +---------------------------------------------------------------+
74 : *
75 : * NOTATIONS :
76 : *
77 : * +--------------------------------------------------------+
78 : * | OBJET1 = POSI OBJET2 'DANS' OBJET3 (OBJET4) ('TOUS') |
79 : * +--------------------------------------------------------+
80 : *
81 : * =====================================================
82 : * LECTURE DE L'ITEM OU DE LA LISTE D'ITEMS A RECHERCHER => OBJET2
83 : * =====================================================
84 :
84 : CALL QUETYP(MTYP2,1,IRETOU)
85 : IF (IERR.NE.0) RETURN
86 :
87 : ZLISTE=.FALSE.
88 : IF (MTYP2.EQ.'ENTIER') THEN
89 : MTYP3='LISTENTI'
89 : CALL LIRENT(IVAL2,1,IRETOU)
90 : ELSEIF (MTYP2.EQ.'FLOTTANT') THEN
91 : MTYP3='LISTREEL'
91 : CALL LIRREE(XVAL2,1,IRETOU)
92 : ELSEIF (MTYP2.EQ.'MOT') THEN
93 : MTYP3='LISTMOTS'
93 : CALL LIRCHA(MVAL2L,1,IRETOU)
94 : ELSEIF (MTYP2.EQ.'LISTENTI'.OR.
95 : & MTYP2.EQ.'LISTREEL'.OR.
96 : & MTYP2.EQ.'LISTMOTS') THEN
97 : MTYP3=MTYP2
98 : ZLISTE=.TRUE.
98 : CALL LIROBJ(MTYP2,IOBJ2,1,IRETOU)
99 : ELSE
100 : * ERREUR 39 (On ne veut pas d'objet de type %m1:8)
101 : MOTERR(1:8)=MTYP2
101 : CALL ERREUR(39)
102 : RETURN
103 : ENDIF
104 :
105 : * =====================
106 : * LECTURE DU MOT 'DANS'
107 : * =====================
108 :
108 : CALL LIRCHA(MCLE,0,IRETOU)
109 : ITROUV=0
110 : IF (IRETOU.GT.0) THEN
111 : IF (MCLE(1:4).EQ.'DANS') ITROUV=1
112 : ENDIF
113 :
114 :
115 : IF (ITROUV.EQ.0) THEN
116 : * ERREUR 396 (Il manque le mot-clé %m1:4)
117 : MOTERR(1:4)='DANS'
117 : CALL ERREUR(396)
118 : RETURN
119 : ENDIF
120 :
121 : * ======================================================
122 : * LECTURE DE LA LISTE DANS LAQUELLE ON FAIT LA RECHERCHE => OBJET3
123 : * ======================================================
124 :
124 : CALL LIROBJ(MTYP3,IOBJ3,0,IRETOU)
125 : IF (IRETOU.EQ.0) THEN
126 : *sg Dans le cas où MTYP2 est MOT, on peut aussi vouloir lire un deuxième
127 : *sg MOT
128 : IF (MTYP2.EQ.'MOT') THEN
128 : CALL LIRCHA(MVAL3L,1,IRETOU)
129 : IF (IERR.NE.0) RETURN
130 : MTYP3='MOT '
131 : ELSE
132 : * ERREUR 166 (Le mot-clé %m1:4 n'est pas suivi de la donnée
133 : * correspondante)
134 : MOTERR(1:4)='DANS'
134 : CALL ERREUR(166)
135 : RETURN
136 : ENDIF
137 : * sg : dans le cas où MTYP2 est un mot mais pas MTYP3, il faut
138 : * le réduire à 4 caractères
139 : IF (MTYP2.EQ.'MOT'.AND.MTYP3.NE.'MOT') THEN
140 : MVAL2=MVAL2L(1:4)
141 : ENDIF
142 : ENDIF
143 :
144 :
145 : * =================================
146 : * LECTURE DES PARAMETRES OPTIONNELS => OBJET4
147 : * =================================
148 : * On fait en sorte de pouvoir lire ces arguments dans n'importe
149 : * quel ordre, ce qui n'est pas trivial étant donné leurs types et
150 : * les combinaisons possibles
151 :
152 : ZNOCA=.FALSE.
153 : ZTOUS=.FALSE.
154 : * ICRIT=0 :: CRIT = Precision machine RELATIVE pour les REAL*8
155 : * ICRIT=1 :: CRIT = Precision ABSOLUE choisie par l'utilisateur
156 : ICRIT=0
157 : CRIT=10.D0*XZPREC
158 :
159 : * (Label 5 = boucle sur les arguments optionnels)
159 : 5 CALL QUETYP(MTYP4,0,IRETOU)
160 : IF (IRETOU.EQ.0) GOTO 6
161 :
162 : * LECTURE D'UN CRITERE DE PRECISION
163 : * ---------------------------------
164 : IF (MTYP4.EQ.'FLOTTANT') THEN
165 : IF (MTYP3.NE.'LISTREEL') THEN
166 : * ERREUR 39 (On ne veut pas d'objet de type %m1:8)
167 : MOTERR(1:8)='FLOTTANT'
167 : CALL ERREUR(39)
168 : RETURN
169 : ENDIF
169 : CALL LIRREE(CRIT,1,IRETOU)
170 : ICRIT=1
171 :
172 : * LECTURE D'UN MOT-CLE
173 : * --------------------
174 : ELSEIF (MTYP4.EQ.'MOT') THEN
175 :
175 : CALL LIRMOT(LCLE,NCLE,ICLE,0)
176 :
177 : * => MOT-CLE 'NOCA'
178 : IF (ICLE.EQ.1) THEN
179 : IF (MTYP3.NE.'LISTMOTS'.AND.MTYP3.NE.'MOT') THEN
180 : * ERREUR 7 (On ne comprend pas le mot %m1:4)
181 : MOTERR(1:4)='NOCA'
181 : CALL ERREUR(7)
182 : RETURN
183 : ENDIF
184 : ZNOCA=.TRUE.
185 :
186 : * => MOT-CLE 'TOUS'
187 : ELSEIF (ICLE.EQ.2) THEN
188 : ZTOUS=.TRUE.
189 :
190 : * => MOT-CLE INVALIDE...
191 : ELSE
192 : * ERREUR 7 (On ne comprend pas le mot %m1:4)
192 : CALL LIRCHA(MCLE,1,IRETOU)
193 : MOTERR(1:4)=MCLE
193 : CALL ERREUR(7)
194 : RETURN
195 : ENDIF
196 :
197 :
198 : * LECTURE D'UN ARGUMENT INVALIDE...
199 : * ---------------------------------
200 : ELSE
201 : * ERREUR 11 (Il y a un résultat de type %m1:8 et de nom %m9:16
202 : * en trop par rapport aux noms à affecter)
202 : CALL LIROBJ(MTYP4,IOBJ4,1,IRETOU)
202 : CALL QUENOM(CHA8)
203 : MOTERR(1:8)=MTYP4
204 : MOTERR(9:16)=CHA8
204 : CALL ERREUR(11)
205 : RETURN
206 : ENDIF
207 :
208 : GOTO 5
209 : 6 CONTINUE
210 :
211 :
212 :
213 :
214 : * +---------------------------------------------------------------+
215 : * | |
216 : * | R E C H E R C H E D E O B J E T 2 D A N S O B J E T 3 |
217 : * | |
218 : * +---------------------------------------------------------------+
219 :
220 :
221 : * ================================================
222 : * CAS OU OBJET3 EST UNE LISTE D'ENTIERS (LISTENTI)
223 : * ================================================
224 :
225 : IF (MTYP3.EQ.'LISTENTI') THEN
226 : MLENT3=IOBJ3
227 : SEGACT,MLENT3
228 : NN3=MLENT3.LECT(/1)
229 :
230 : * SYNTAXE 3
231 : * ------------------------------------
232 : IF (ZLISTE) THEN
233 : MLENT2=IOBJ2
234 : SEGACT,MLENT2
235 : NN2=MLENT2.LECT(/1)
236 :
237 : JG=NN2
238 : SEGINI,MLENT1
238 : c CALL INITI(MLENT1.LECT(1),JG,-1)
239 :
240 : DO 10 J=1,NN2
241 : IVAL2=MLENT2.LECT(J)
242 : DO I=1,NN3
243 : IVAL3=MLENT3.LECT(I)
244 : IF (IVAL2.EQ.IVAL3) THEN
245 : MLENT1.LECT(J)=I
246 : GOTO 10
247 : ENDIF
248 : ENDDO
249 : 10 CONTINUE
250 :
250 : CALL ECROBJ('LISTENTI',MLENT1)
251 : SEGDES,MLENT1,MLENT2
252 :
253 : * SYNTAXE 2
254 : * ------------------------------------
255 : ELSEIF (ZTOUS) THEN
256 : JG=NN3
257 : SEGINI,MLENT1
257 : c CALL INITI(MLENT1.LECT(1),JG,-1)
258 :
259 : JG=0
260 : DO I=1,NN3
261 : IVAL3=MLENT3.LECT(I)
262 : IF (IVAL2.EQ.IVAL3) THEN
263 : JG=JG+1
264 : MLENT1.LECT(JG)=I
265 : ENDIF
266 : ENDDO
267 : SEGADJ,MLENT1
268 :
268 : CALL ECROBJ('LISTENTI',MLENT1)
269 : SEGDES,MLENT1
270 :
271 : * SYNTAXE 1
272 : * ------------------------------------
273 : ELSE
274 : IVAL1=0
275 : c IVAL1=-1
276 : DO I=1,NN3
277 : IVAL3=MLENT3.LECT(I)
278 : IF (IVAL2.EQ.IVAL3) THEN
279 : IVAL1=I
280 : GOTO 11
281 : ENDIF
282 : ENDDO
282 : 11 CALL ECRENT(IVAL1)
283 : ENDIF
284 :
285 : SEGDES,MLENT3
286 :
287 :
288 : * ===============================================
289 : * CAS OU OBJET3 EST UNE LISTE DE REELS (LISTREEL)
290 : * ===============================================
291 :
292 : ELSEIF (MTYP3.EQ.'LISTREEL') THEN
293 : MLREE3=IOBJ3
294 : SEGACT,MLREE3
295 : NN3=MLREE3.PROG(/1)
296 :
297 : * SYNTAXE 3
298 : * ------------------------------------
299 : IF (ZLISTE) THEN
300 : MLREE2=IOBJ2
301 : SEGACT,MLREE2
302 : NN2=MLREE2.PROG(/1)
303 :
304 : JG=NN2
305 : SEGINI,MLENT1
305 : c CALL INITI(MLENT1.LECT(1),JG,-1)
306 :
307 : DO 20 J=1,NN2
308 : XVAL2=MLREE2.PROG(J)
309 : DO I=1,NN3
310 : XVAL3=MLREE3.PROG(I)
311 :
312 : XCRIT=CRIT
313 : IF (ICRIT.EQ.0) XCRIT=XCRIT*MAX(XVAL2,XVAL3)
314 :
315 : c IF (XVAL2.EQ.XVAL3) THEN
316 : IF (ABS(XVAL2-XVAL3).LT.ABS(XCRIT)) THEN
317 : MLENT1.LECT(J)=I
318 : GOTO 20
319 : ENDIF
320 : ENDDO
321 : 20 CONTINUE
322 :
322 : CALL ECROBJ('LISTENTI',MLENT1)
323 : SEGDES,MLENT1,MLREE2
324 :
325 : * SYNTAXE 2
326 : * ------------------------------------
327 : ELSEIF (ZTOUS) THEN
328 : JG=NN3
329 : SEGINI,MLENT1
329 : c CALL INITI(MLENT1.LECT(1),JG,-1)
330 :
331 : JG=0
332 : DO I=1,NN3
333 : XVAL3=MLREE3.PROG(I)
334 :
335 : XCRIT=CRIT
336 : IF (ICRIT.EQ.0) XCRIT=XCRIT*MAX(XVAL2,XVAL3)
337 :
338 : c IF (XVAL2.EQ.XVAL3) THEN
339 : IF (ABS(XVAL2-XVAL3).LT.ABS(XCRIT)) THEN
340 : JG=JG+1
341 : MLENT1.LECT(JG)=I
342 : ENDIF
343 : ENDDO
344 : SEGADJ,MLENT1
345 :
345 : CALL ECROBJ('LISTENTI',MLENT1)
346 : SEGDES,MLENT1
347 :
348 : * SYNTAXE 1
349 : * ------------------------------------
350 : ELSE
351 : IVAL1=0
352 : c IVAL1=-1
353 : DO I=1,NN3
354 : XVAL3=MLREE3.PROG(I)
355 :
356 : XCRIT=CRIT
357 : IF (ICRIT.EQ.0) XCRIT=XCRIT*MAX(XVAL2,XVAL3)
358 :
359 : c IF (XVAL2.EQ.XVAL3) THEN
360 : IF (ABS(XVAL2-XVAL3).LT.ABS(XCRIT)) THEN
361 : IVAL1=I
362 : GOTO 21
363 : ENDIF
364 : ENDDO
364 : 21 CALL ECRENT(IVAL1)
365 : ENDIF
366 :
367 : SEGDES,MLREE3
368 :
369 :
370 : * ==============================================
371 : * CAS OU OBJET3 EST UNE LISTE DE MOTS (LISTMOTS)
372 : * ==============================================
373 :
374 : ELSEIF (MTYP3.EQ.'LISTMOTS') THEN
375 : MLMOT3=IOBJ3
376 : SEGACT,MLMOT3
377 : NN3=MLMOT3.MOTS(/2)
378 :
379 : * SYNTAXE 3
380 : * ------------------------------------
381 : IF (ZLISTE) THEN
382 : MLMOT2=IOBJ2
383 : SEGACT,MLMOT2
384 : NN2=MLMOT2.MOTS(/2)
385 :
386 : JG=NN2
387 : SEGINI,MLENT1
387 : c CALL INITI(MLENT1.LECT(1),JG,-1)
388 :
389 : DO 30 J=1,NN2
390 : MVAL2=MLMOT2.MOTS(J)
391 : DO I=1,NN3
392 : MVAL3=MLMOT3.MOTS(I)
393 :
394 : * Si la recherche est insensible a la casse, on
395 : * passe tout en majuscules avant d'effectuer la
396 : * comparaison
397 : IF (ZNOCA) THEN
397 : CALL MINMAJ(MVAL2)
397 : CALL MINMAJ(MVAL3)
398 : ENDIF
399 :
400 : IF (MVAL2.EQ.MVAL3) THEN
401 : MLENT1.LECT(J)=I
402 : GOTO 30
403 : ENDIF
404 : ENDDO
405 : 30 CONTINUE
406 :
406 : CALL ECROBJ('LISTENTI',MLENT1)
407 : SEGDES,MLENT1,MLMOT2
408 :
409 : * SYNTAXE 2
410 : * ------------------------------------
411 : ELSEIF (ZTOUS) THEN
412 : JG=NN3
413 : SEGINI,MLENT1
413 : c CALL INITI(MLENT1.LECT(1),JG,-1)
414 :
415 : JG=0
416 : DO I=1,NN3
417 : MVAL3=MLMOT3.MOTS(I)
418 :
419 : * Si la recherche est insensible a la casse, on
420 : * passe tout en majuscules avant d'effectuer la
421 : * comparaison
422 : IF (ZNOCA) THEN
422 : CALL MINMAJ(MVAL2)
422 : CALL MINMAJ(MVAL3)
423 : ENDIF
424 :
425 : IF (MVAL2.EQ.MVAL3) THEN
426 : JG=JG+1
427 : MLENT1.LECT(JG)=I
428 : ENDIF
429 : ENDDO
430 : SEGADJ,MLENT1
431 :
431 : CALL ECROBJ('LISTENTI',MLENT1)
432 : SEGDES,MLENT1
433 :
434 : * SYNTAXE 1
435 : * ------------------------------------
436 : ELSE
437 : IVAL1=0
438 : c IVAL1=-1
439 : DO I=1,NN3
440 : MVAL3=MLMOT3.MOTS(I)
441 :
442 : * Si la recherche est insensible a la casse, on
443 : * passe tout en majuscules avant d'effectuer la
444 : * comparaison
445 : IF (ZNOCA) THEN
445 : CALL MINMAJ(MVAL2)
445 : CALL MINMAJ(MVAL3)
446 : ENDIF
447 :
448 : IF (MVAL2.EQ.MVAL3) THEN
449 : IVAL1=I
450 : GOTO 31
451 : ENDIF
452 : ENDDO
452 : 31 CALL ECRENT(IVAL1)
453 : ENDIF
454 :
455 : SEGDES,MLMOT3
456 :
457 :
458 : * ==============================================
459 : * CAS OU OBJET3 EST UN MOT
460 : * ==============================================
461 :
462 : ELSEIF (MTYP3.EQ.'MOT') THEN
463 : LONG3 = LONG(MVAL3L)
464 : LONG2 = LONG(MVAL2L)
465 : * WRITE(IOIMP,*) MVAL2L
466 : * WRITE(IOIMP,*) MVAL3L
467 : * Si la recherche est insensible a la casse, on
468 : * passe tout en majuscules avant d'effectuer la
469 : * comparaison
470 : IF (ZNOCA) THEN
470 : CALL MINMAJ(MVAL2L(1:LONG2))
470 : CALL MINMAJ(MVAL3L(1:LONG3))
471 : ENDIF
472 : * WRITE(IOIMP,*) MVAL2L
473 : * WRITE(IOIMP,*) MVAL3L
474 : * PAS DE SYNTAXE 3
475 : * SYNTAXE 2
476 : * ------------------------------------
477 : IF (ZTOUS) THEN
478 : NREC=LONG3-LONG2+1
479 : JG=NREC
480 : SEGINI,MLENT1
481 : JG=0
482 : ICOLD=1
483 : * WRITE(IOIMP,*) 'NREC=',NREC
484 : DO I=1,NREC
485 : IC=INDEX(MVAL3L(ICOLD:LONG3),MVAL2L(1:LONG2))
486 : * WRITE(IOIMP,*) 'IC=',IC
487 : IF (IC.EQ.0) GOTO 8
488 : JG=JG+1
489 : MLENT1.LECT(JG)=ICOLD+IC-1
490 : ICOLD=ICOLD+IC
491 : ENDDO
492 : 8 CONTINUE
493 : SEGADJ,MLENT1
494 : SEGDES,MLENT1
494 : CALL ECROBJ('LISTENTI',MLENT1)
495 : * SYNTAXE 1
496 : * ------------------------------------
497 : ELSE
498 : IC=INDEX(MVAL3L(1:LONG3),MVAL2L(1:LONG2))
498 : CALL ECRENT(IC)
499 : ENDIF
500 : ENDIF
501 : RETURN
502 : END
503 :
504 :
505 :
506 :
507 :
508 :
© Cast3M 2003 - All rights reserved.
Disclaimer