C PROG SOURCE PV 11/03/07 21:17:51 6885 C FABRIQUE UN OBJET DE TYPE LISTREEL (SUITE DE REELS) C SUBROUTINE PROG IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO -INC SMLREEL -INC CCREEL CHARACTER*4 MOTC(2),MOTD(5),MOTE(2),MOTF(1),MOTG(2) DATA MOTC/'PAS ','* '/ DATA MOTD/'SINU','EXPO','LOGA','LINE','PROG'/ DATA MOTE/'PHAS','AMPL'/ DATA MOTF/'NPAS'/ DATA MOTG/'A ','B '/ C XCONV=180.D0/XPI CALL LIRMOT(MOTD,4,IFONC,0) IF(IFONC.NE.0) GOTO (110,210,210,210) IFONC C C ***** ON FABRIQUE UNE SUITE DE REELS ***** C 1 CONTINUE IPRIM=0 X0=0. JG=0 SEGINI MLREEL 99 CONTINUE CALL LIRREE(X,IPRIM,IRETOU) IF(IRETOU.EQ.0) GO TO 30 C C LECTURE D'UN FLOTTANT C 100 CONTINUE X0=X JG=JG+1 SEGADJ MLREEL PROG(JG)=X GO TO 99 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 LIRREE(XPAS,1,IRETOU) IF(IERR.NE.0)RETURN C C LECTURE DE X1 C CALL LIRREE(X1,0,IRETOU) IF(IRETOU.EQ.1) GOTO 10 CALL LIRMOT(MOTF,1,INPA,1) IF(IERR.NE.0)RETURN C C LECTURE DE NPAS C CALL LIRENT(NP,1,IRETOU) IF(IERR.NE.0)RETURN NP=MAX(0,NP) VX0=X0 VXPAS=XPAS JG0=JG JG=JG+NP SEGADJ MLREEL DO 11 IJ=1,NP PROG(JG0+IJ)=DBLE(IJ)*VXPAS+VX0 11 CONTINUE C C ON DOIT LIRE UN FLOTTANT OU RIEN C CALL LIRREE(X,0,IRETOU) IF(IRETOU.EQ.1) GOTO 100 GOTO 20 C C PAS DE NOMBRE DE PAS; VOIR SI X1 EST SUIVI PAR * C 10 CONTINUE IRF=0 CALL LIRREE(X2,0,IRETX) IF (IRETX.EQ.1) GOTO 60 CALL LIRMOT(MOTC(2),1,IRF,0) IF (IRF.EQ.0) GOTO 60 NFOIS=nint(X1) CALL LIRREE(X1,1,IRETOU) IF (IERR.NE.0) RETURN 60 CONTINUE X=XPAS*(X1-X0) XNBELE=(X1-X0)/XPAS IQ=nint(XNBELE) IF(IQ.GE.0.AND.XNBELE.NE.0.)THEN IQ=MAX(1,IQ) IF (XNBELE/IQ.GT.(IQ+1)/XNBELE) IQ=IQ+1 ELSE IQ=1 ENDIF XPAS =(X1-X0)/REAL(IQ) X=X0+XPAS JG0=JG JG=JG+IQ SEGADJ MLREEL DO 8 IA=1,IQ PROG(JG0+IA)=X X=X+XPAS 8 CONTINUE prog (jg0+iq)= X1 X0=X1 X=X2 IF (IRF.EQ.1) GOTO 65 IF (IRETX.EQ.1) GOTO 100 GO TO 99 50 CONTINUE C C LECTURE DU MOT "* " C IMAX=PROG(/1) NFOIS=nint(PROG(IMAX)) CALL LIRREE(X0,1,IRETOU) IF (IERR.NE.0) RETURN PROG(IMAX)=X0 65 CONTINUE IF (NFOIS.LE.0) THEN CALL ERREUR(36) RETURN ENDIF NF=NFOIS-1 IF (NF.EQ.0) GOTO 99 JG0=JG JG=JG+NF SEGADJ MLREEL DO 52 I=1,NF PROG(JG0+I)=X0 52 CONTINUE GOTO 99 C 20 CONTINUE CALL ECROBJ('LISTREEL',MLREEL) SEGDES MLREEL IF(IFONC.EQ.0) GOTO 1000 GOTO 160 C C ***** ON LIT LES COEFFICIENT POUR LE SINUS ******** C 110 CONTINUE FREQ=0.D0 PHI=0.D0 AMPLI=1.D0 CALL LIRREE(Y1,1,IRETOU) IF(IERR.NE.0) RETURN IF(Y1) 120,120,121 C120 CALL ERREUR(36) 120 CONTINUE CALL ERREUR(36) RETURN 121 CONTINUE FREQ=Y1 CALL LIRMOT(MOTE,2,IREP,0) IF(IREP.EQ.0) GOTO 150 IF(IREP.EQ.2) GOTO 140 CALL LIRREE(Y2,1,IRETOU) IF(IERR.NE.0) RETURN PHI=Y2 CALL LIRMOT(MOTE(2),1,IREP,0) IF(IREP.EQ.0) GOTO 150 140 CONTINUE CALL LIRREE(Y3,1,IRETOU) IF(IERR.NE.0) RETURN IF(Y3) 120,122,122 122 CONTINUE AMPLI=Y3 GOTO 150 C C ***** ON LIT LES COEFFICIENTS POUR LES AUTRES FONCTIONS **** C 210 CONTINUE PENTE=1.D0 ORDOR=0.D0 CALL LIRMOT(MOTG,2,IRET,0) IF(IRET.EQ.0) GOTO 150 IF(IRET.EQ.0) GOTO 220 CALL LIRREE(PENTE,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIRMOT(MOTG(2),1,IRET,0) IF(IRET.EQ.0) GOTO 150 220 CONTINUE CALL LIRREE(ORDOR,1,IRETOU) IF(IERR.NE.0) RETURN C 150 CONTINUE CALL LIRMOT(MOTD(5),1,IRAP,0) IF(IRAP.EQ.1) GOTO 1 C 160 CONTINUE CALL LIROBJ('LISTREEL',KK,1,IRETOU) IF(IERR.NE.0) RETURN MLREEL=KK SEGACT MLREEL NN=PROG(/1) JG=NN SEGINI MLREE1 C C ***** FONCTION SINUS ******************** C IF(IFONC.NE.1) GOTO 260 DO 170 N=1,NN X=PROG(N) Y=2.D0*XPI*FREQ*X+PHI/XCONV Y=AMPLI*SIN(Y) MLREE1.PROG(N)=Y 170 CONTINUE GOTO 500 C C ***** FONCTION EXPONENTIELLE ************ C 260 CONTINUE IF(IFONC.NE.2) GOTO 360 DO 270 N=1,NN X=PROG(N) Y=PENTE*X+ORDOR Y=EXP(Y) MLREE1.PROG(N)=Y 270 CONTINUE GOTO 500 C C ***** FONCTION LOGARITHME *************** C 360 CONTINUE IF(IFONC.NE.3) GOTO 460 DO 370 N=1,NN X=PROG(N) Y=PENTE*X+ORDOR IF(Y.GT.0.D0) GOTO 365 CALL ERREUR (36) RETURN 365 CONTINUE Y=LOG(Y) MLREE1.PROG(N)=Y 370 CONTINUE GOTO 500 C C ***** FONCTION LINEAIRE****************** C 460 CONTINUE DO 470 N=1,NN X=PROG(N) Y=PENTE*X+ORDOR MLREE1.PROG(N)=Y 470 CONTINUE C 500 CONTINUE CALL ECROBJ('LISTREEL',MLREE1) SEGDES MLREE1,MLREEL C 1000 CONTINUE RETURN END