C POSI SOURCE GOUNAND 14/01/31 21:15:09 7927 ************************************************************************ * NOM : POSI * DESCRIPTION : Renvoie la position d'éléments dans une liste d'éléments ************************************************************************ * HISTORIQUE : 26/07/2012 : JCARDO : création de l'opérateur * HISTORIQUE : 14/12/2012 : JCARDO : ajout de l'option 'TOUS' * HISTORIQUE : 14/01/2014 : SG : trouver une sous-chaine dans une * chaine * 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 : pilot.eso ************************************************************************ * ENTRÉES :: aucune * SORTIES :: aucune ************************************************************************ * SYNTAXES (GIBIANE) : * * 1) CHERCHE LA PREMIÈRE OCCURRENCE D'UN ITEM DANS UNE LISTE : * ENTI1 = POSI ENTI2 'DANS' LENT1 ; * ENTI1 = POSI FLOT1 'DANS' LREE1 (DTOL1) ; * ENTI1 = POSI MOT1 'DANS' LMOT1 ('NOCA') ; * * 2) CHERCHE TOUTES LES OCCURRENCES D'UN ITEM DANS UNE LISTE : * LENT1 = POSI ENTI1 'DANS' LENT2 'TOUS' ; * LENT1 = POSI FLOT1 'DANS' LREE1 (DTOL1) 'TOUS' ; * LENT1 = POSI MOT1 'DANS' LMOT1 ('NOCA') 'TOUS' ; * * 3) CHERCHE LA PREMIÈRE OCCURRENCE DE PLUSIEURS ITEMS DANS UNE LISTE : * LENT1 = POSI LENT2 'DANS' LENT3 ; * LENT1 = POSI LREE1 'DANS' LREE2 (DTOL1) ; * LENT1 = POSI LMOT1 'DANS' LMOT2 ('NOCA') ; * * * ************************************************************************ SUBROUTINE POSI IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO -INC CCREEL -INC SMLENTI -INC SMLREEL -INC SMLMOTS EXTERNAL LONG PARAMETER (NCLE=2) CHARACTER*4 MCLE,LCLE(NCLE) CHARACTER*8 CHA8,MTYP2,MTYP3,MTYP4 PARAMETER (LMOT=4) CHARACTER*(LMOT) MVAL2,MVAL3 PARAMETER (LMOTL=512) CHARACTER*(LMOTL) MVAL2L,MVAL3L * LOGICAL ZLISTE,ZNOCA,ZTOUS DATA LCLE/'NOCA','TOUS'/ * * +---------------------------------------------------------------+ * | | * | L E C T U R E D E S A R G U M E N T S | * | | * +---------------------------------------------------------------+ * * NOTATIONS : * * +--------------------------------------------------------+ * | OBJET1 = POSI OBJET2 'DANS' OBJET3 (OBJET4) ('TOUS') | * +--------------------------------------------------------+ * * ===================================================== * LECTURE DE L'ITEM OU DE LA LISTE D'ITEMS A RECHERCHER => OBJET2 * ===================================================== CALL QUETYP(MTYP2,1,IRETOU) IF (IERR.NE.0) RETURN ZLISTE=.FALSE. IF (MTYP2.EQ.'ENTIER') THEN MTYP3='LISTENTI' CALL LIRENT(IVAL2,1,IRETOU) ELSEIF (MTYP2.EQ.'FLOTTANT') THEN MTYP3='LISTREEL' CALL LIRREE(XVAL2,1,IRETOU) ELSEIF (MTYP2.EQ.'MOT') THEN MTYP3='LISTMOTS' CALL LIRCHA(MVAL2L,1,IRETOU) ELSEIF (MTYP2.EQ.'LISTENTI'.OR. & MTYP2.EQ.'LISTREEL'.OR. & MTYP2.EQ.'LISTMOTS') THEN MTYP3=MTYP2 ZLISTE=.TRUE. CALL LIROBJ(MTYP2,IOBJ2,1,IRETOU) ELSE * ERREUR 39 (On ne veut pas d'objet de type %m1:8) MOTERR(1:8)=MTYP2 CALL ERREUR(39) RETURN ENDIF * ===================== * LECTURE DU MOT 'DANS' * ===================== CALL LIRCHA(MCLE,0,IRETOU) ITROUV=0 IF (IRETOU.GT.0) THEN IF (MCLE(1:4).EQ.'DANS') ITROUV=1 ENDIF IF (ITROUV.EQ.0) THEN * ERREUR 396 (Il manque le mot-clé %m1:4) MOTERR(1:4)='DANS' CALL ERREUR(396) RETURN ENDIF * ====================================================== * LECTURE DE LA LISTE DANS LAQUELLE ON FAIT LA RECHERCHE => OBJET3 * ====================================================== CALL LIROBJ(MTYP3,IOBJ3,0,IRETOU) IF (IRETOU.EQ.0) THEN *sg Dans le cas où MTYP2 est MOT, on peut aussi vouloir lire un deuxième *sg MOT IF (MTYP2.EQ.'MOT') THEN CALL LIRCHA(MVAL3L,1,IRETOU) IF (IERR.NE.0) RETURN MTYP3='MOT ' ELSE * ERREUR 166 (Le mot-clé %m1:4 n'est pas suivi de la donnée * correspondante) MOTERR(1:4)='DANS' CALL ERREUR(166) RETURN ENDIF * sg : dans le cas où MTYP2 est un mot mais pas MTYP3, il faut * le réduire à 4 caractères IF (MTYP2.EQ.'MOT'.AND.MTYP3.NE.'MOT') THEN MVAL2=MVAL2L(1:4) ENDIF ENDIF * ================================= * LECTURE DES PARAMETRES OPTIONNELS => OBJET4 * ================================= * On fait en sorte de pouvoir lire ces arguments dans n'importe * quel ordre, ce qui n'est pas trivial étant donné leurs types et * les combinaisons possibles ZNOCA=.FALSE. ZTOUS=.FALSE. * ICRIT=0 :: CRIT = Precision machine RELATIVE pour les REAL*8 * ICRIT=1 :: CRIT = Precision ABSOLUE choisie par l'utilisateur ICRIT=0 CRIT=10.D0*XZPREC * (Label 5 = boucle sur les arguments optionnels) 5 CALL QUETYP(MTYP4,0,IRETOU) IF (IRETOU.EQ.0) GOTO 6 * LECTURE D'UN CRITERE DE PRECISION * --------------------------------- IF (MTYP4.EQ.'FLOTTANT') THEN IF (MTYP3.NE.'LISTREEL') THEN * ERREUR 39 (On ne veut pas d'objet de type %m1:8) MOTERR(1:8)='FLOTTANT' CALL ERREUR(39) RETURN ENDIF CALL LIRREE(CRIT,1,IRETOU) ICRIT=1 * LECTURE D'UN MOT-CLE * -------------------- ELSEIF (MTYP4.EQ.'MOT') THEN CALL LIRMOT(LCLE,NCLE,ICLE,0) * => MOT-CLE 'NOCA' IF (ICLE.EQ.1) THEN IF (MTYP3.NE.'LISTMOTS'.AND.MTYP3.NE.'MOT') THEN * ERREUR 7 (On ne comprend pas le mot %m1:4) MOTERR(1:4)='NOCA' CALL ERREUR(7) RETURN ENDIF ZNOCA=.TRUE. * => MOT-CLE 'TOUS' ELSEIF (ICLE.EQ.2) THEN ZTOUS=.TRUE. * => MOT-CLE INVALIDE... ELSE * ERREUR 7 (On ne comprend pas le mot %m1:4) CALL LIRCHA(MCLE,1,IRETOU) MOTERR(1:4)=MCLE CALL ERREUR(7) RETURN ENDIF * LECTURE D'UN ARGUMENT INVALIDE... * --------------------------------- ELSE * ERREUR 11 (Il y a un résultat de type %m1:8 et de nom %m9:16 * en trop par rapport aux noms à affecter) CALL LIROBJ(MTYP4,IOBJ4,1,IRETOU) CALL QUENOM(CHA8) MOTERR(1:8)=MTYP4 MOTERR(9:16)=CHA8 CALL ERREUR(11) RETURN ENDIF GOTO 5 6 CONTINUE * +---------------------------------------------------------------+ * | | * | 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 | * | | * +---------------------------------------------------------------+ * ================================================ * CAS OU OBJET3 EST UNE LISTE D'ENTIERS (LISTENTI) * ================================================ IF (MTYP3.EQ.'LISTENTI') THEN MLENT3=IOBJ3 SEGACT,MLENT3 NN3=MLENT3.LECT(/1) * SYNTAXE 3 * ------------------------------------ IF (ZLISTE) THEN MLENT2=IOBJ2 SEGACT,MLENT2 NN2=MLENT2.LECT(/1) JG=NN2 SEGINI,MLENT1 c CALL INITI(MLENT1.LECT(1),JG,-1) DO 10 J=1,NN2 IVAL2=MLENT2.LECT(J) DO I=1,NN3 IVAL3=MLENT3.LECT(I) IF (IVAL2.EQ.IVAL3) THEN MLENT1.LECT(J)=I GOTO 10 ENDIF ENDDO 10 CONTINUE CALL ECROBJ('LISTENTI',MLENT1) SEGDES,MLENT1,MLENT2 * SYNTAXE 2 * ------------------------------------ ELSEIF (ZTOUS) THEN JG=NN3 SEGINI,MLENT1 c CALL INITI(MLENT1.LECT(1),JG,-1) JG=0 DO I=1,NN3 IVAL3=MLENT3.LECT(I) IF (IVAL2.EQ.IVAL3) THEN JG=JG+1 MLENT1.LECT(JG)=I ENDIF ENDDO SEGADJ,MLENT1 CALL ECROBJ('LISTENTI',MLENT1) SEGDES,MLENT1 * SYNTAXE 1 * ------------------------------------ ELSE IVAL1=0 c IVAL1=-1 DO I=1,NN3 IVAL3=MLENT3.LECT(I) IF (IVAL2.EQ.IVAL3) THEN IVAL1=I GOTO 11 ENDIF ENDDO 11 CALL ECRENT(IVAL1) ENDIF SEGDES,MLENT3 * =============================================== * CAS OU OBJET3 EST UNE LISTE DE REELS (LISTREEL) * =============================================== ELSEIF (MTYP3.EQ.'LISTREEL') THEN MLREE3=IOBJ3 SEGACT,MLREE3 NN3=MLREE3.PROG(/1) * SYNTAXE 3 * ------------------------------------ IF (ZLISTE) THEN MLREE2=IOBJ2 SEGACT,MLREE2 NN2=MLREE2.PROG(/1) JG=NN2 SEGINI,MLENT1 c CALL INITI(MLENT1.LECT(1),JG,-1) DO 20 J=1,NN2 XVAL2=MLREE2.PROG(J) DO I=1,NN3 XVAL3=MLREE3.PROG(I) XCRIT=CRIT IF (ICRIT.EQ.0) XCRIT=XCRIT*MAX(XVAL2,XVAL3) c IF (XVAL2.EQ.XVAL3) THEN IF (ABS(XVAL2-XVAL3).LT.ABS(XCRIT)) THEN MLENT1.LECT(J)=I GOTO 20 ENDIF ENDDO 20 CONTINUE CALL ECROBJ('LISTENTI',MLENT1) SEGDES,MLENT1,MLREE2 * SYNTAXE 2 * ------------------------------------ ELSEIF (ZTOUS) THEN JG=NN3 SEGINI,MLENT1 c CALL INITI(MLENT1.LECT(1),JG,-1) JG=0 DO I=1,NN3 XVAL3=MLREE3.PROG(I) XCRIT=CRIT IF (ICRIT.EQ.0) XCRIT=XCRIT*MAX(XVAL2,XVAL3) c IF (XVAL2.EQ.XVAL3) THEN IF (ABS(XVAL2-XVAL3).LT.ABS(XCRIT)) THEN JG=JG+1 MLENT1.LECT(JG)=I ENDIF ENDDO SEGADJ,MLENT1 CALL ECROBJ('LISTENTI',MLENT1) SEGDES,MLENT1 * SYNTAXE 1 * ------------------------------------ ELSE IVAL1=0 c IVAL1=-1 DO I=1,NN3 XVAL3=MLREE3.PROG(I) XCRIT=CRIT IF (ICRIT.EQ.0) XCRIT=XCRIT*MAX(XVAL2,XVAL3) c IF (XVAL2.EQ.XVAL3) THEN IF (ABS(XVAL2-XVAL3).LT.ABS(XCRIT)) THEN IVAL1=I GOTO 21 ENDIF ENDDO 21 CALL ECRENT(IVAL1) ENDIF SEGDES,MLREE3 * ============================================== * CAS OU OBJET3 EST UNE LISTE DE MOTS (LISTMOTS) * ============================================== ELSEIF (MTYP3.EQ.'LISTMOTS') THEN MLMOT3=IOBJ3 SEGACT,MLMOT3 NN3=MLMOT3.MOTS(/2) * SYNTAXE 3 * ------------------------------------ IF (ZLISTE) THEN MLMOT2=IOBJ2 SEGACT,MLMOT2 NN2=MLMOT2.MOTS(/2) JG=NN2 SEGINI,MLENT1 c CALL INITI(MLENT1.LECT(1),JG,-1) DO 30 J=1,NN2 MVAL2=MLMOT2.MOTS(J) DO I=1,NN3 MVAL3=MLMOT3.MOTS(I) * Si la recherche est insensible a la casse, on * passe tout en majuscules avant d'effectuer la * comparaison IF (ZNOCA) THEN CALL MINMAJ(MVAL2) CALL MINMAJ(MVAL3) ENDIF IF (MVAL2.EQ.MVAL3) THEN MLENT1.LECT(J)=I GOTO 30 ENDIF ENDDO 30 CONTINUE CALL ECROBJ('LISTENTI',MLENT1) SEGDES,MLENT1,MLMOT2 * SYNTAXE 2 * ------------------------------------ ELSEIF (ZTOUS) THEN JG=NN3 SEGINI,MLENT1 c CALL INITI(MLENT1.LECT(1),JG,-1) JG=0 DO I=1,NN3 MVAL3=MLMOT3.MOTS(I) * Si la recherche est insensible a la casse, on * passe tout en majuscules avant d'effectuer la * comparaison IF (ZNOCA) THEN CALL MINMAJ(MVAL2) CALL MINMAJ(MVAL3) ENDIF IF (MVAL2.EQ.MVAL3) THEN JG=JG+1 MLENT1.LECT(JG)=I ENDIF ENDDO SEGADJ,MLENT1 CALL ECROBJ('LISTENTI',MLENT1) SEGDES,MLENT1 * SYNTAXE 1 * ------------------------------------ ELSE IVAL1=0 c IVAL1=-1 DO I=1,NN3 MVAL3=MLMOT3.MOTS(I) * Si la recherche est insensible a la casse, on * passe tout en majuscules avant d'effectuer la * comparaison IF (ZNOCA) THEN CALL MINMAJ(MVAL2) CALL MINMAJ(MVAL3) ENDIF IF (MVAL2.EQ.MVAL3) THEN IVAL1=I GOTO 31 ENDIF ENDDO 31 CALL ECRENT(IVAL1) ENDIF SEGDES,MLMOT3 * ============================================== * CAS OU OBJET3 EST UN MOT * ============================================== ELSEIF (MTYP3.EQ.'MOT') THEN LONG3 = LONG(MVAL3L) LONG2 = LONG(MVAL2L) * WRITE(IOIMP,*) MVAL2L * WRITE(IOIMP,*) MVAL3L * Si la recherche est insensible a la casse, on * passe tout en majuscules avant d'effectuer la * comparaison IF (ZNOCA) THEN CALL MINMAJ(MVAL2L(1:LONG2)) CALL MINMAJ(MVAL3L(1:LONG3)) ENDIF * WRITE(IOIMP,*) MVAL2L * WRITE(IOIMP,*) MVAL3L * PAS DE SYNTAXE 3 * SYNTAXE 2 * ------------------------------------ IF (ZTOUS) THEN NREC=LONG3-LONG2+1 JG=NREC SEGINI,MLENT1 JG=0 ICOLD=1 * WRITE(IOIMP,*) 'NREC=',NREC DO I=1,NREC IC=INDEX(MVAL3L(ICOLD:LONG3),MVAL2L(1:LONG2)) * WRITE(IOIMP,*) 'IC=',IC IF (IC.EQ.0) GOTO 8 JG=JG+1 MLENT1.LECT(JG)=ICOLD+IC-1 ICOLD=ICOLD+IC ENDDO 8 CONTINUE SEGADJ,MLENT1 SEGDES,MLENT1 CALL ECROBJ('LISTENTI',MLENT1) * SYNTAXE 1 * ------------------------------------ ELSE IC=INDEX(MVAL3L(1:LONG3),MVAL2L(1:LONG2)) CALL ECRENT(IC) ENDIF ENDIF RETURN END