Télécharger prog.eso

Retour à la liste

Numérotation des lignes :

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

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