C LECTUR SOURCE CHAT 05/01/13 01:14:30 5004 C FABRIQUE UN OBJET DE TYPE LISTENTI (LISTE D'ENTIERS) C SUBROUTINE LECTUR C IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMLENTI CHARACTER*4 MOTC(2),MOTF(2) DATA MOTC/'PAS ','* '/ DATA MOTF/'NPAS',' '/ C JG=0 IP=0 IBEGIN=0 SEGINI MLENTI 999 CONTINUE CALL LIRENT(IPP,IBEGIN,IRETOU) IF(IRETOU.EQ.0) GO TO 30 C C LECTURE D'UN ENTIER C 1 CONTINUE IP=IPP JG=LECT(/1)+1 SEGADJ MLENTI LECT(JG)=IP GO TO 999 C 30 CONTINUE CALL LIRMOT(MOTC,2,IRET,0) IF(IRET.EQ.0) GO TO 20 IF (IRET.EQ.2) GOTO 50 C C LECTURE DU MOT "PAS " C CALL LIRENT(IPAS,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIRENT(IQ,0,IRETOU) IF(IRETOU.EQ.1)GOTO 10 CALL LIRMOT(MOTF(1),1,INPA,1) C C LECTURE DE NPAS C CALL LIRENT(NP,1,IRETOU) IF(IERR.NE.0)RETURN NP=MAX(0,NP) KIP=IP KIPAS=IPAS JG0=JG JG=JG+NP SEGADJ MLENTI DO 11 IJ=1,NP LECT(JG0+IJ)=IJ*KIPAS+KIP 11 CONTINUE C C ON DOIT LIRE UN ENTIER OU RIEN C CALL LIRENT(IPP,0,IRETOU) IF(IRETOU.EQ.1) GOTO 1 GOTO 20 C C VOIR SI IQ EST SUIVI PAR "* " C 10 CONTINUE CALL LIRENT(IQ2,0,IRETX) IF (IRETX.EQ.1) GOTO 60 CALL LIRMOT(MOTC(2),1,IRF,0) IF (IRF.EQ.0) GOTO 60 NFOIS=IQ CALL LIRENT(IQ,1,IRETOU) IF (IERR.NE.0) RETURN 60 CONTINUE IA=IQ-IP IF(IA*IPAS) 6,7,8 6 CONTINUE CALL ERREUR(36) C IQ ET IP SONT DE SIGNE CONTRAIRE RETURN 7 CONTINUE IF(IPAS.NE.0) THEN if( ipas.eq.1) go to 99 CALL ERREUR(21) C IQ ET IP SONT IDENTIQUES RETURN ENDIF 8 CONTINUE IF(IPAS.NE.0)IA=MOD(IA,IPAS) IF(IA.NE.0) THEN CALL ERREUR(21) C IQ-IP N EST PAS DIVISIBLE PAR IPAS RETURN ENDIF IF(IPAS.EQ.0)JQ=2 IF(IPAS.NE.0)JQ=ABS((IQ-IP)/IPAS)+1 JA=IP+IPAS JG1=LECT(/1)-1 JG=JG1+JQ SEGADJ MLENTI DO 9 IA=2,JQ LECT(JG1+IA)=JA JA=JA+IPAS 9 CONTINUE 99 continue IPP=IQ2 IP=IQ IF (IRF.EQ.1) GOTO 65 IF (IRETX.EQ.1) GOTO 1 GO TO 999 50 CONTINUE C C ON A LU "* " C IMAX=LECT(/1) NFOIS=LECT(IMAX) CALL LIRENT(IP,1,IRETOU) IF (IERR.NE.0) RETURN LECT(IMAX)=IP 65 CONTINUE IF (NFOIS.LE.0) GOTO 6 NF=NFOIS-1 IF (NF.EQ.0) GOTO 51 JG1=LECT(/1) JG=JG1+NF SEGADJ MLENTI DO 52 I=1,NF LECT(JG1+I)=IP 52 CONTINUE 51 CONTINUE GOTO 999 C 20 CONTINUE CALL ECROBJ('LISTENTI',MLENTI) SEGDES MLENTI RETURN END