Télécharger posi.eso

Retour à la liste

Numérotation des lignes :

  1. C POSI SOURCE GOUNAND 14/03/07 21:15:02 7987
  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.  
  85. CALL QUETYP(MTYP2,1,IRETOU)
  86. IF (IERR.NE.0) RETURN
  87.  
  88. ZLISTE=.FALSE.
  89. IF (MTYP2.EQ.'ENTIER') THEN
  90. MTYP3='LISTENTI'
  91. CALL LIRENT(IVAL2,1,IRETOU)
  92. ELSEIF (MTYP2.EQ.'FLOTTANT') THEN
  93. MTYP3='LISTREEL'
  94. CALL LIRREE(XVAL2,1,IRETOU)
  95. ELSEIF (MTYP2.EQ.'MOT') THEN
  96. MTYP3='LISTMOTS'
  97. CALL LIRCHA(MVAL2L,1,IRETOU)
  98. ELSEIF (MTYP2.EQ.'LISTENTI'.OR.
  99. & MTYP2.EQ.'LISTREEL'.OR.
  100. & MTYP2.EQ.'LISTMOTS') THEN
  101. MTYP3=MTYP2
  102. ZLISTE=.TRUE.
  103. CALL LIROBJ(MTYP2,IOBJ2,1,IRETOU)
  104. ELSE
  105. * ERREUR 39 (On ne veut pas d'objet de type %m1:8)
  106. MOTERR(1:8)=MTYP2
  107. CALL ERREUR(39)
  108. RETURN
  109. ENDIF
  110.  
  111. * =====================
  112. * LECTURE DU MOT 'DANS'
  113. * =====================
  114.  
  115. CALL LIRCHA(MCLE,0,IRETOU)
  116. ITROUV=0
  117. IF (IRETOU.GT.0) THEN
  118. IF (MCLE(1:4).EQ.'DANS') ITROUV=1
  119. ENDIF
  120.  
  121.  
  122. IF (ITROUV.EQ.0) THEN
  123. * ERREUR 396 (Il manque le mot-clé %m1:4)
  124. MOTERR(1:4)='DANS'
  125. CALL ERREUR(396)
  126. RETURN
  127. ENDIF
  128.  
  129. * ======================================================
  130. * LECTURE DE LA LISTE DANS LAQUELLE ON FAIT LA RECHERCHE => OBJET3
  131. * ======================================================
  132.  
  133. CALL LIROBJ(MTYP3,IOBJ3,0,IRETOU)
  134. IF (IRETOU.EQ.0) THEN
  135. *sg Dans le cas où MTYP2 est MOT, on peut aussi vouloir lire un deuxième
  136. *sg MOT
  137. IF (MTYP2.EQ.'MOT') THEN
  138. CALL LIRCHA(MVAL3L,1,IRETOU)
  139. IF (IERR.NE.0) RETURN
  140. MTYP3='MOT '
  141. ELSE
  142. * ERREUR 166 (Le mot-clé %m1:4 n'est pas suivi de la donnée
  143. * correspondante)
  144. MOTERR(1:4)='DANS'
  145. CALL ERREUR(166)
  146. RETURN
  147. ENDIF
  148. ENDIF
  149. * sg : dans le cas où MTYP2 est un mot mais pas MTYP3, il faut
  150. * le réduire à 4 caractères
  151. IF (MTYP2.EQ.'MOT'.AND.MTYP3.NE.'MOT') THEN
  152. MVAL2=MVAL2L(1:4)
  153. ENDIF
  154. *
  155. * =================================
  156. * LECTURE DES PARAMETRES OPTIONNELS => OBJET4
  157. * =================================
  158. * On fait en sorte de pouvoir lire ces arguments dans n'importe
  159. * quel ordre, ce qui n'est pas trivial étant donné leurs types et
  160. * les combinaisons possibles
  161.  
  162. ZNOCA=.FALSE.
  163. ZTOUS=.FALSE.
  164. * ICRIT=0 :: CRIT = Precision machine RELATIVE pour les REAL*8
  165. * ICRIT=1 :: CRIT = Precision ABSOLUE choisie par l'utilisateur
  166. ICRIT=0
  167. CRIT=10.D0*XZPREC
  168.  
  169. * (Label 5 = boucle sur les arguments optionnels)
  170. 5 CALL QUETYP(MTYP4,0,IRETOU)
  171. IF (IRETOU.EQ.0) GOTO 6
  172.  
  173. * LECTURE D'UN CRITERE DE PRECISION
  174. * ---------------------------------
  175. IF (MTYP4.EQ.'FLOTTANT') THEN
  176. IF (MTYP3.NE.'LISTREEL') THEN
  177. * ERREUR 39 (On ne veut pas d'objet de type %m1:8)
  178. MOTERR(1:8)='FLOTTANT'
  179. CALL ERREUR(39)
  180. RETURN
  181. ENDIF
  182. CALL LIRREE(CRIT,1,IRETOU)
  183. ICRIT=1
  184.  
  185. * LECTURE D'UN MOT-CLE
  186. * --------------------
  187. ELSEIF (MTYP4.EQ.'MOT') THEN
  188.  
  189. CALL LIRMOT(LCLE,NCLE,ICLE,0)
  190.  
  191. * => MOT-CLE 'NOCA'
  192. IF (ICLE.EQ.1) THEN
  193. IF (MTYP3.NE.'LISTMOTS'.AND.MTYP3.NE.'MOT') THEN
  194. * ERREUR 7 (On ne comprend pas le mot %m1:4)
  195. MOTERR(1:4)='NOCA'
  196. CALL ERREUR(7)
  197. RETURN
  198. ENDIF
  199. ZNOCA=.TRUE.
  200.  
  201. * => MOT-CLE 'TOUS'
  202. ELSEIF (ICLE.EQ.2) THEN
  203. ZTOUS=.TRUE.
  204.  
  205. * => MOT-CLE INVALIDE...
  206. ELSE
  207. * ERREUR 7 (On ne comprend pas le mot %m1:4)
  208. CALL LIRCHA(MCLE,1,IRETOU)
  209. MOTERR(1:4)=MCLE
  210. CALL ERREUR(7)
  211. RETURN
  212. ENDIF
  213.  
  214.  
  215. * LECTURE D'UN ARGUMENT INVALIDE...
  216. * ---------------------------------
  217. ELSE
  218. * ERREUR 11 (Il y a un résultat de type %m1:8 et de nom %m9:16
  219. * en trop par rapport aux noms à affecter)
  220. CALL LIROBJ(MTYP4,IOBJ4,1,IRETOU)
  221. CALL QUENOM(CHA8)
  222. MOTERR(1:8)=MTYP4
  223. MOTERR(9:16)=CHA8
  224. CALL ERREUR(11)
  225. RETURN
  226. ENDIF
  227.  
  228. GOTO 5
  229. 6 CONTINUE
  230.  
  231.  
  232.  
  233.  
  234. * +---------------------------------------------------------------+
  235. * | |
  236. * | 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 |
  237. * | |
  238. * +---------------------------------------------------------------+
  239.  
  240.  
  241. * ================================================
  242. * CAS OU OBJET3 EST UNE LISTE D'ENTIERS (LISTENTI)
  243. * ================================================
  244.  
  245. IF (MTYP3.EQ.'LISTENTI') THEN
  246. MLENT3=IOBJ3
  247. SEGACT,MLENT3
  248. NN3=MLENT3.LECT(/1)
  249.  
  250. * SYNTAXE 3
  251. * ------------------------------------
  252. IF (ZLISTE) THEN
  253. MLENT2=IOBJ2
  254. SEGACT,MLENT2
  255. NN2=MLENT2.LECT(/1)
  256.  
  257. JG=NN2
  258. SEGINI,MLENT1
  259. c CALL INITI(MLENT1.LECT(1),JG,-1)
  260.  
  261. DO 10 J=1,NN2
  262. IVAL2=MLENT2.LECT(J)
  263. DO I=1,NN3
  264. IVAL3=MLENT3.LECT(I)
  265. IF (IVAL2.EQ.IVAL3) THEN
  266. MLENT1.LECT(J)=I
  267. GOTO 10
  268. ENDIF
  269. ENDDO
  270. 10 CONTINUE
  271.  
  272. CALL ECROBJ('LISTENTI',MLENT1)
  273. SEGDES,MLENT1,MLENT2
  274.  
  275. * SYNTAXE 2
  276. * ------------------------------------
  277. ELSEIF (ZTOUS) THEN
  278. JG=NN3
  279. SEGINI,MLENT1
  280. c CALL INITI(MLENT1.LECT(1),JG,-1)
  281.  
  282. JG=0
  283. DO I=1,NN3
  284. IVAL3=MLENT3.LECT(I)
  285. IF (IVAL2.EQ.IVAL3) THEN
  286. JG=JG+1
  287. MLENT1.LECT(JG)=I
  288. ENDIF
  289. ENDDO
  290. SEGADJ,MLENT1
  291.  
  292. CALL ECROBJ('LISTENTI',MLENT1)
  293. SEGDES,MLENT1
  294.  
  295. * SYNTAXE 1
  296. * ------------------------------------
  297. ELSE
  298. IVAL1=0
  299. c IVAL1=-1
  300. DO I=1,NN3
  301. IVAL3=MLENT3.LECT(I)
  302. IF (IVAL2.EQ.IVAL3) THEN
  303. IVAL1=I
  304. GOTO 11
  305. ENDIF
  306. ENDDO
  307. 11 CALL ECRENT(IVAL1)
  308. ENDIF
  309.  
  310. SEGDES,MLENT3
  311.  
  312.  
  313. * ===============================================
  314. * CAS OU OBJET3 EST UNE LISTE DE REELS (LISTREEL)
  315. * ===============================================
  316.  
  317. ELSEIF (MTYP3.EQ.'LISTREEL') THEN
  318. MLREE3=IOBJ3
  319. SEGACT,MLREE3
  320. NN3=MLREE3.PROG(/1)
  321.  
  322. * SYNTAXE 3
  323. * ------------------------------------
  324. IF (ZLISTE) THEN
  325. MLREE2=IOBJ2
  326. SEGACT,MLREE2
  327. NN2=MLREE2.PROG(/1)
  328.  
  329. JG=NN2
  330. SEGINI,MLENT1
  331. c CALL INITI(MLENT1.LECT(1),JG,-1)
  332.  
  333. DO 20 J=1,NN2
  334. XVAL2=MLREE2.PROG(J)
  335. DO I=1,NN3
  336. XVAL3=MLREE3.PROG(I)
  337.  
  338. XCRIT=CRIT
  339. IF (ICRIT.EQ.0) XCRIT=XCRIT*MAX(XVAL2,XVAL3)
  340.  
  341. c IF (XVAL2.EQ.XVAL3) THEN
  342. IF (ABS(XVAL2-XVAL3).LT.ABS(XCRIT)) THEN
  343. MLENT1.LECT(J)=I
  344. GOTO 20
  345. ENDIF
  346. ENDDO
  347. 20 CONTINUE
  348.  
  349. CALL ECROBJ('LISTENTI',MLENT1)
  350. SEGDES,MLENT1,MLREE2
  351.  
  352. * SYNTAXE 2
  353. * ------------------------------------
  354. ELSEIF (ZTOUS) THEN
  355. JG=NN3
  356. SEGINI,MLENT1
  357. c CALL INITI(MLENT1.LECT(1),JG,-1)
  358.  
  359. JG=0
  360. DO I=1,NN3
  361. XVAL3=MLREE3.PROG(I)
  362.  
  363. XCRIT=CRIT
  364. IF (ICRIT.EQ.0) XCRIT=XCRIT*MAX(XVAL2,XVAL3)
  365.  
  366. c IF (XVAL2.EQ.XVAL3) THEN
  367. IF (ABS(XVAL2-XVAL3).LT.ABS(XCRIT)) THEN
  368. JG=JG+1
  369. MLENT1.LECT(JG)=I
  370. ENDIF
  371. ENDDO
  372. SEGADJ,MLENT1
  373.  
  374. CALL ECROBJ('LISTENTI',MLENT1)
  375. SEGDES,MLENT1
  376.  
  377. * SYNTAXE 1
  378. * ------------------------------------
  379. ELSE
  380. IVAL1=0
  381. c IVAL1=-1
  382. DO I=1,NN3
  383. XVAL3=MLREE3.PROG(I)
  384.  
  385. XCRIT=CRIT
  386. IF (ICRIT.EQ.0) XCRIT=XCRIT*MAX(XVAL2,XVAL3)
  387.  
  388. c IF (XVAL2.EQ.XVAL3) THEN
  389. IF (ABS(XVAL2-XVAL3).LT.ABS(XCRIT)) THEN
  390. IVAL1=I
  391. GOTO 21
  392. ENDIF
  393. ENDDO
  394. 21 CALL ECRENT(IVAL1)
  395. ENDIF
  396.  
  397. SEGDES,MLREE3
  398.  
  399.  
  400. * ==============================================
  401. * CAS OU OBJET3 EST UNE LISTE DE MOTS (LISTMOTS)
  402. * ==============================================
  403.  
  404. ELSEIF (MTYP3.EQ.'LISTMOTS') THEN
  405. MLMOT3=IOBJ3
  406. SEGACT,MLMOT3
  407. NN3=MLMOT3.MOTS(/2)
  408.  
  409. * SYNTAXE 3
  410. * ------------------------------------
  411. IF (ZLISTE) THEN
  412. MLMOT2=IOBJ2
  413. SEGACT,MLMOT2
  414. NN2=MLMOT2.MOTS(/2)
  415.  
  416. JG=NN2
  417. SEGINI,MLENT1
  418. c CALL INITI(MLENT1.LECT(1),JG,-1)
  419.  
  420. DO 30 J=1,NN2
  421. MVAL2=MLMOT2.MOTS(J)
  422. DO I=1,NN3
  423. MVAL3=MLMOT3.MOTS(I)
  424.  
  425. * Si la recherche est insensible a la casse, on
  426. * passe tout en majuscules avant d'effectuer la
  427. * comparaison
  428. IF (ZNOCA) THEN
  429. CALL MINMAJ(MVAL2)
  430. CALL MINMAJ(MVAL3)
  431. ENDIF
  432.  
  433. IF (MVAL2.EQ.MVAL3) THEN
  434. MLENT1.LECT(J)=I
  435. GOTO 30
  436. ENDIF
  437. ENDDO
  438. 30 CONTINUE
  439.  
  440. CALL ECROBJ('LISTENTI',MLENT1)
  441. SEGDES,MLENT1,MLMOT2
  442.  
  443. * SYNTAXE 2
  444. * ------------------------------------
  445. ELSEIF (ZTOUS) THEN
  446. JG=NN3
  447. SEGINI,MLENT1
  448. c CALL INITI(MLENT1.LECT(1),JG,-1)
  449.  
  450. JG=0
  451. DO I=1,NN3
  452. MVAL3=MLMOT3.MOTS(I)
  453.  
  454. * Si la recherche est insensible a la casse, on
  455. * passe tout en majuscules avant d'effectuer la
  456. * comparaison
  457. IF (ZNOCA) THEN
  458. CALL MINMAJ(MVAL2)
  459. CALL MINMAJ(MVAL3)
  460. ENDIF
  461.  
  462. IF (MVAL2.EQ.MVAL3) THEN
  463. JG=JG+1
  464. MLENT1.LECT(JG)=I
  465. ENDIF
  466. ENDDO
  467. SEGADJ,MLENT1
  468.  
  469. CALL ECROBJ('LISTENTI',MLENT1)
  470. SEGDES,MLENT1
  471.  
  472. * SYNTAXE 1
  473. * ------------------------------------
  474. ELSE
  475. IVAL1=0
  476. c IVAL1=-1
  477. DO I=1,NN3
  478. MVAL3=MLMOT3.MOTS(I)
  479.  
  480. * Si la recherche est insensible a la casse, on
  481. * passe tout en majuscules avant d'effectuer la
  482. * comparaison
  483. IF (ZNOCA) THEN
  484. CALL MINMAJ(MVAL2)
  485. CALL MINMAJ(MVAL3)
  486. ENDIF
  487.  
  488. IF (MVAL2.EQ.MVAL3) THEN
  489. IVAL1=I
  490. GOTO 31
  491. ENDIF
  492. ENDDO
  493. 31 CALL ECRENT(IVAL1)
  494. ENDIF
  495.  
  496. SEGDES,MLMOT3
  497.  
  498.  
  499. * ==============================================
  500. * CAS OU OBJET3 EST UN MOT
  501. * ==============================================
  502.  
  503. ELSEIF (MTYP3.EQ.'MOT') THEN
  504. LONG3 = LONG(MVAL3L)
  505. LONG2 = LONG(MVAL2L)
  506. * WRITE(IOIMP,*) MVAL2L
  507. * WRITE(IOIMP,*) MVAL3L
  508. * Si la recherche est insensible a la casse, on
  509. * passe tout en majuscules avant d'effectuer la
  510. * comparaison
  511. IF (ZNOCA) THEN
  512. CALL MINMAJ(MVAL2L(1:LONG2))
  513. CALL MINMAJ(MVAL3L(1:LONG3))
  514. ENDIF
  515. * WRITE(IOIMP,*) MVAL2L
  516. * WRITE(IOIMP,*) MVAL3L
  517. * PAS DE SYNTAXE 3
  518. * SYNTAXE 2
  519. * ------------------------------------
  520. IF (ZTOUS) THEN
  521. NREC=LONG3-LONG2+1
  522. JG=NREC
  523. SEGINI,MLENT1
  524. JG=0
  525. ICOLD=1
  526. * WRITE(IOIMP,*) 'NREC=',NREC
  527. DO I=1,NREC
  528. IC=INDEX(MVAL3L(ICOLD:LONG3),MVAL2L(1:LONG2))
  529. * WRITE(IOIMP,*) 'IC=',IC
  530. IF (IC.EQ.0) GOTO 8
  531. JG=JG+1
  532. MLENT1.LECT(JG)=ICOLD+IC-1
  533. ICOLD=ICOLD+IC
  534. ENDDO
  535. 8 CONTINUE
  536. SEGADJ,MLENT1
  537. SEGDES,MLENT1
  538. CALL ECROBJ('LISTENTI',MLENT1)
  539. * SYNTAXE 1
  540. * ------------------------------------
  541. ELSE
  542. IC=INDEX(MVAL3L(1:LONG3),MVAL2L(1:LONG2))
  543. CALL ECRENT(IC)
  544. ENDIF
  545. ENDIF
  546. RETURN
  547. END
  548.  
  549.  
  550.  
  551.  
  552.  
  553.  
  554.  
  555.  

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