1 : C PROG SOURCE PV 11/03/07 21:17:51 6885 2 : C FABRIQUE UN OBJET DE TYPE LISTREEL (SUITE DE REELS) 3 : C 4 : SUBROUTINE PROG 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8(A-H,O-Z) 7 : -INC CCOPTIO 8 : -INC SMLREEL 9 : -INC CCREEL 10 : CHARACTER*4 MOTC(2),MOTD(5),MOTE(2),MOTF(1),MOTG(2) 11 : DATA MOTC/'PAS ','* '/ 12 : DATA MOTD/'SINU','EXPO','LOGA','LINE','PROG'/ 13 : DATA MOTE/'PHAS','AMPL'/ 14 : DATA MOTF/'NPAS'/ 15 : DATA MOTG/'A ','B '/ 16 : C 17 : XCONV=180.D0/XPI 17 : CALL LIRMOT(MOTD,4,IFONC,0) 18 : IF(IFONC.NE.0) GOTO (110,210,210,210) IFONC 19 : C 20 : C ***** ON FABRIQUE UNE SUITE DE REELS ***** 21 : C 22 : 1 CONTINUE 23 : IPRIM=0 24 : X0=0. 25 : JG=0 26 : SEGINI MLREEL 27 : 99 CONTINUE 27 : CALL LIRREE(X,IPRIM,IRETOU) 28 : IF(IRETOU.EQ.0) GO TO 30 29 : C 30 : C LECTURE D'UN FLOTTANT 31 : C 32 : 100 CONTINUE 33 : X0=X 34 : JG=JG+1 35 : SEGADJ MLREEL 36 : PROG(JG)=X 37 : GO TO 99 38 : 30 CONTINUE 38 : CALL LIRMOT(MOTC,2,IRET,0) 39 : IF(IRET.EQ.0) GO TO 20 40 : IF (IRET.EQ.2) GOTO 50 41 : C 42 : C LECTURE DU MOT "PAS " 43 : C 43 : CALL LIRREE(XPAS,1,IRETOU) 44 : IF(IERR.NE.0)RETURN 45 : C 46 : C LECTURE DE X1 47 : C 47 : CALL LIRREE(X1,0,IRETOU) 48 : IF(IRETOU.EQ.1) GOTO 10 48 : CALL LIRMOT(MOTF,1,INPA,1) 49 : IF(IERR.NE.0)RETURN 50 : C 51 : C LECTURE DE NPAS 52 : C 52 : CALL LIRENT(NP,1,IRETOU) 53 : IF(IERR.NE.0)RETURN 54 : NP=MAX(0,NP) 55 : VX0=X0 56 : VXPAS=XPAS 57 : JG0=JG 58 : JG=JG+NP 59 : SEGADJ MLREEL 60 : DO 11 IJ=1,NP 61 : PROG(JG0+IJ)=DBLE(IJ)*VXPAS+VX0 62 : 11 CONTINUE 63 : C 64 : C ON DOIT LIRE UN FLOTTANT OU RIEN 65 : C 65 : CALL LIRREE(X,0,IRETOU) 66 : IF(IRETOU.EQ.1) GOTO 100 67 : GOTO 20 68 : C 69 : C PAS DE NOMBRE DE PAS; VOIR SI X1 EST SUIVI PAR * 70 : C 71 : 10 CONTINUE 72 : IRF=0 72 : CALL LIRREE(X2,0,IRETX) 73 : IF (IRETX.EQ.1) GOTO 60 73 : CALL LIRMOT(MOTC(2),1,IRF,0) 74 : IF (IRF.EQ.0) GOTO 60 75 : NFOIS=nint(X1) 75 : CALL LIRREE(X1,1,IRETOU) 76 : IF (IERR.NE.0) RETURN 77 : 60 CONTINUE 78 : X=XPAS*(X1-X0) 79 : XNBELE=(X1-X0)/XPAS 80 : IQ=nint(XNBELE) 81 : IF(IQ.GE.0.AND.XNBELE.NE.0.)THEN 82 : IQ=MAX(1,IQ) 83 : IF (XNBELE/IQ.GT.(IQ+1)/XNBELE) IQ=IQ+1 84 : ELSE 85 : IQ=1 86 : ENDIF 87 : XPAS =(X1-X0)/REAL(IQ) 88 : X=X0+XPAS 89 : JG0=JG 90 : JG=JG+IQ 91 : SEGADJ MLREEL 92 : DO 8 IA=1,IQ 93 : PROG(JG0+IA)=X 94 : X=X+XPAS 95 : 8 CONTINUE 96 : prog (jg0+iq)= X1 97 : X0=X1 98 : X=X2 99 : IF (IRF.EQ.1) GOTO 65 100 : IF (IRETX.EQ.1) GOTO 100 101 : GO TO 99 102 : 50 CONTINUE 103 : C 104 : C LECTURE DU MOT "* " 105 : C 106 : IMAX=PROG(/1) 107 : NFOIS=nint(PROG(IMAX)) 107 : CALL LIRREE(X0,1,IRETOU) 108 : IF (IERR.NE.0) RETURN 109 : PROG(IMAX)=X0 110 : 65 CONTINUE 111 : IF (NFOIS.LE.0) THEN 111 : CALL ERREUR(36) 112 : RETURN 113 : ENDIF 114 : NF=NFOIS-1 115 : IF (NF.EQ.0) GOTO 99 116 : JG0=JG 117 : JG=JG+NF 118 : SEGADJ MLREEL 119 : DO 52 I=1,NF 120 : PROG(JG0+I)=X0 121 : 52 CONTINUE 122 : GOTO 99 123 : C 124 : 20 CONTINUE 124 : CALL ECROBJ('LISTREEL',MLREEL) 125 : SEGDES MLREEL 126 : IF(IFONC.EQ.0) GOTO 1000 127 : GOTO 160 128 : C 129 : C ***** ON LIT LES COEFFICIENT POUR LE SINUS ******** 130 : C 131 : 110 CONTINUE 132 : FREQ=0.D0 133 : PHI=0.D0 134 : AMPLI=1.D0 134 : CALL LIRREE(Y1,1,IRETOU) 135 : IF(IERR.NE.0) RETURN 136 : IF(Y1) 120,120,121 136 : C120 CALL ERREUR(36) 137 : 120 CONTINUE 137 : CALL ERREUR(36) 138 : RETURN 139 : 121 CONTINUE 140 : FREQ=Y1 140 : CALL LIRMOT(MOTE,2,IREP,0) 141 : IF(IREP.EQ.0) GOTO 150 142 : IF(IREP.EQ.2) GOTO 140 142 : CALL LIRREE(Y2,1,IRETOU) 143 : IF(IERR.NE.0) RETURN 144 : PHI=Y2 144 : CALL LIRMOT(MOTE(2),1,IREP,0) 145 : IF(IREP.EQ.0) GOTO 150 146 : 140 CONTINUE 146 : CALL LIRREE(Y3,1,IRETOU) 147 : IF(IERR.NE.0) RETURN 148 : IF(Y3) 120,122,122 149 : 122 CONTINUE 150 : AMPLI=Y3 151 : GOTO 150 152 : C 153 : C ***** ON LIT LES COEFFICIENTS POUR LES AUTRES FONCTIONS **** 154 : C 155 : 210 CONTINUE 156 : PENTE=1.D0 157 : ORDOR=0.D0 157 : CALL LIRMOT(MOTG,2,IRET,0) 158 : IF(IRET.EQ.0) GOTO 150 159 : IF(IRET.EQ.0) GOTO 220 159 : CALL LIRREE(PENTE,1,IRETOU) 160 : IF(IERR.NE.0) RETURN 160 : CALL LIRMOT(MOTG(2),1,IRET,0) 161 : IF(IRET.EQ.0) GOTO 150 162 : 220 CONTINUE 162 : CALL LIRREE(ORDOR,1,IRETOU) 163 : IF(IERR.NE.0) RETURN 164 : C 165 : 150 CONTINUE 165 : CALL LIRMOT(MOTD(5),1,IRAP,0) 166 : IF(IRAP.EQ.1) GOTO 1 167 : C 168 : 160 CONTINUE 168 : CALL LIROBJ('LISTREEL',KK,1,IRETOU) 169 : IF(IERR.NE.0) RETURN 170 : MLREEL=KK 171 : SEGACT MLREEL 172 : NN=PROG(/1) 173 : JG=NN 174 : SEGINI MLREE1 175 : C 176 : C ***** FONCTION SINUS ******************** 177 : C 178 : IF(IFONC.NE.1) GOTO 260 179 : DO 170 N=1,NN 180 : X=PROG(N) 181 : Y=2.D0*XPI*FREQ*X+PHI/XCONV 182 : Y=AMPLI*SIN(Y) 183 : MLREE1.PROG(N)=Y 184 : 170 CONTINUE 185 : GOTO 500 186 : C 187 : C ***** FONCTION EXPONENTIELLE ************ 188 : C 189 : 260 CONTINUE 190 : IF(IFONC.NE.2) GOTO 360 191 : DO 270 N=1,NN 192 : X=PROG(N) 193 : Y=PENTE*X+ORDOR 194 : Y=EXP(Y) 195 : MLREE1.PROG(N)=Y 196 : 270 CONTINUE 197 : GOTO 500 198 : C 199 : C ***** FONCTION LOGARITHME *************** 200 : C 201 : 360 CONTINUE 202 : IF(IFONC.NE.3) GOTO 460 203 : DO 370 N=1,NN 204 : X=PROG(N) 205 : Y=PENTE*X+ORDOR 206 : IF(Y.GT.0.D0) GOTO 365 206 : CALL ERREUR (36) 207 : RETURN 208 : 365 CONTINUE 209 : Y=LOG(Y) 210 : MLREE1.PROG(N)=Y 211 : 370 CONTINUE 212 : GOTO 500 213 : C 214 : C ***** FONCTION LINEAIRE****************** 215 : C 216 : 460 CONTINUE 217 : DO 470 N=1,NN 218 : X=PROG(N) 219 : Y=PENTE*X+ORDOR 220 : MLREE1.PROG(N)=Y 221 : 470 CONTINUE 222 : C 223 : 500 CONTINUE 223 : CALL ECROBJ('LISTREEL',MLREE1) 224 : SEGDES MLREE1,MLREEL 225 : C 226 : 1000 CONTINUE 227 : RETURN 228 : END 229 : 230 : 231 : 232 : 233 : 234 : 235 :
© Cast3M 2003 - All rights reserved.
Disclaimer