Télécharger la plaquette Cast3M


fr en

Télécharger prog.eso

Retour à la liste

Numérotation des lignes : 

prog

  1. C PROG      SOURCE    SP204843  23/02/16    21:15:05     11600          
  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.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMLREEL
  11. -INC CCREEL
  12.       CHARACTER*4 MOTC(2),MOTD(6),MOTE(2),MOTF(2),MOTG(2)
  13.       DATA MOTC/'PAS ','*   '/
  14.       DATA MOTD/'SINU','EXPO','LOGA','LINE','TABL','PROG'/
  15.       DATA MOTE/'PHAS','AMPL'/
  16.       DATA MOTF/'NPAS','GEOM'/
  17.       DATA MOTG/'A   ','B   '/
  18. C
  19.       XCONV=180.D0/XPI
  20.       CALL LIRMOT(MOTD,5,IFONC,0)
  21.       IF(IFONC.NE.0) GOTO (110,210,210,210,600) IFONC
  22. C
  23. C ***** ON FABRIQUE UNE SUITE DE REELS *****
  24. C
  25.    1  CONTINUE
  26.       IPRIM=0
  27.       X0=0.
  28.       JG=0
  29.       SEGINI MLREEL
  30.   99  CONTINUE
  31.       CALL LIRREE(X,IPRIM,IRETOU)
  32.       IF(IRETOU.EQ.0) GOTO 30
  33. C
  34. C  LECTURE D'UN FLOTTANT
  35. C
  36.  100  CONTINUE
  37.       X0=X
  38.       JG=JG+1
  39.       SEGADJ,MLREEL
  40.       PROG(JG)=X
  41.       GOTO 99
  42.   30  CONTINUE
  43.       CALL LIRMOT(MOTC,2,IRET,0)
  44.       IF(IRET.EQ.0) GOTO 20
  45.       IF(IRET.EQ.2) GOTO 50
  46. C
  47. C  LECTURE DU MOT "PAS "
  48. C
  49.       CALL LIRREE(XPAS,1,IRETOU)
  50.       IF(IERR.NE.0)RETURN
  51.       if (abs(xpas).lt.xpetit) xpas=sign(xpetit,xpas)
  52. C
  53. C  LECTURE DE X1
  54. C
  55.       IGEOM = 0
  56.       CALL LIRREE(X1,0,IRETOU)
  57.       IF(IRETOU.EQ.1) GOTO 10
  58. C
  59. C  LECTURE DU MOT "NPAS" OU "GEOM"
  60. C
  61.       CALL LIRMOT(MOTF,2,INPA,1)
  62.       IF(IERR.NE.0)RETURN
  63.  
  64. C---- MOT-CLE "NPAS"
  65.       IF (INPA.EQ.1) THEN
  66. C
  67. C     LECTURE DU NOMBRE DE PAS
  68.         CALL LIRENT(NP,1,IRETOU)
  69.         IF(IERR.NE.0)RETURN
  70.         NP=MAX(0,NP)
  71.         VX0=X0
  72.         VXPAS=XPAS
  73.         JG0=JG
  74.         JG=JG+NP
  75.         SEGADJ,MLREEL
  76.         DO 11 IJ=1,NP
  77.           PROG(JG0+IJ)=DBLE(IJ)*VXPAS+VX0
  78.   11    CONTINUE
  79.  
  80. C     ON DOIT LIRE UN FLOTTANT OU RIEN
  81.         CALL LIRREE(X,0,IRETOU)
  82.         IF(IRETOU.EQ.1) GOTO 100
  83.         GOTO 20
  84.  
  85. C---- MOT-CLE "GEOM"
  86.       ELSEIF (INPA.EQ.2) THEN
  87.         IGEOM = 1
  88. C
  89. C     LECTURE DE LA RAISON GEOMETRIQUE
  90.         CALL LIRREE(R1,1,IRETOU)
  91.         IF (IERR.NE.0) RETURN
  92.  
  93.         IF (R1.LE.0.D0) THEN
  94.           REAERR(1) = R1
  95.           CALL ERREUR(1009)
  96.           RETURN
  97.         ENDIF
  98.         IF (R1.EQ.1.D0) IGEOM = 0 
  99.  
  100. C       LECTURE BORNE SUP DE L'INTERVALLE
  101.         CALL LIRREE(X1,0,IRETOU)
  102.         IF(IRETOU.EQ.1) GOTO 10
  103.  
  104. C     SINON, LECTURE DE "NPAS"
  105.         CALL LIRMOT(MOTF(1),1,INPA,1)
  106.         IF(IERR.NE.0)RETURN
  107.         CALL LIRENT(NP,1,IRETOU)
  108.         IF(IERR.NE.0)RETURN
  109.  
  110.         IF (NP.EQ.0) GOTO 13 
  111.  
  112.         NP=MAX(0,NP)
  113.         VX0=X0
  114.         JG0=JG
  115.         JG=JG+NP
  116.         SEGADJ,MLREEL
  117.         DO 12 IJ=1,NP
  118.           VXPAS=XPAS*(R1**(IJ-1))
  119.           VX0 = VX0 + VXPAS
  120.           PROG(JG0+IJ) = VX0
  121.   12    CONTINUE
  122.  
  123. C     ON DOIT LIRE UN FLOTTANT OU RIEN
  124.   13    CONTINUE
  125.         CALL LIRREE(X,0,IRETOU)
  126.         IF(IRETOU.EQ.1) GOTO 100
  127.         GOTO 20
  128.  
  129.       ELSE
  130.         MOTERR(5:12) = MOTF(1)(1:4)//MOTF(2)(1:4)
  131.         CALL ERREUR(1052)
  132.         RETURN
  133.       ENDIF
  134. C
  135. C  PAS DE NOMBRE DE PAS; VOIR SI X1 EST SUIVI PAR *
  136. C
  137.   10  CONTINUE
  138.       IRF=0
  139.       CALL LIRREE(X2,0,IRETX)
  140.       IF (IRETX.EQ.1) GOTO 60
  141.       CALL LIRMOT(MOTC(2),1,IRF,0)
  142.       IF (IRF.EQ.0) GOTO 60
  143.       NFOIS=nint(X1)
  144.       CALL LIRREE(X1,1,IRETOU)
  145.       IF (IERR.NE.0) RETURN
  146.  
  147. C
  148. C  DECOUPAGE DE L'INTEVRALLE [X0;X1]
  149. C
  150.   60  CONTINUE
  151.       X=XPAS*(X1-X0)
  152.  
  153. C     PAS DE MOT-CLE "GEOM"
  154.       IF (IGEOM.EQ.0) THEN
  155.         XNBELE=(X1-X0)/XPAS
  156.         IQ=nint(XNBELE)
  157.         IF(IQ.GE.0.AND.XNBELE.NE.0.)THEN
  158.           IQ=MAX(1,IQ)
  159.           IF (XNBELE/IQ.GT.(IQ+1)/XNBELE) IQ=IQ+1
  160.         ELSE
  161.           IQ=1
  162.         ENDIF
  163.         XPAS =(X1-X0)/REAL(IQ)
  164.  
  165. C     OPTION "GEOM"
  166.       ELSEIF (IGEOM.EQ.1) THEN
  167.  
  168.         XNBELE = (X1-X0)/XPAS
  169.         XNBELE = 1.D0 + ABS(XNBELE)*(R1-1.D0)
  170. C
  171. C     TEST CAS OU R1 < 1
  172.         IF (XNBELE.LE.XPETIT) THEN
  173.           REAERR(1) = R1
  174.           CALL ERREUR(1009)
  175.           RETURN
  176.         ENDIF
  177.         XNBELE = LOG(XNBELE) / LOG(R1)
  178.         IQ = INT(XNBELE)
  179.         IQ = MAX(1,IQ)
  180.         XS = (R1**IQ - 1.D0) / (R1 - 1.D0)
  181.         XPAS = (X1-X0) / XS
  182. C     write(6,*) 'IQ,XS,XPAS',IQ,XS,XPAS
  183.  
  184.       ELSE
  185.         CALL ERREUR(5)
  186.         RETURN
  187.       ENDIF
  188.  
  189.       X=X0
  190.       JG0=JG
  191.       JG=JG+IQ
  192.       SEGADJ,MLREEL
  193.       DO 8 IA=1,IQ
  194.         IF (IGEOM.EQ.1) THEN
  195.           VXPAS=XPAS*(R1**(IA-1))
  196.           X=X+VXPAS
  197.         ELSE
  198.           X=X+XPAS
  199.         ENDIF
  200.         PROG(JG0+IA)=X
  201.    8  CONTINUE
  202.       prog (jg0+iq)= X1
  203.       X0=X1
  204.       X=X2
  205.       IF (IRF.EQ.1) GOTO 65
  206.       IF (IRETX.EQ.1) GOTO 100
  207.       GO TO 99
  208.   50  CONTINUE
  209. C
  210. C  LECTURE DU MOT "*   "
  211. C
  212.       IMAX=PROG(/1)
  213.       NFOIS=nint(PROG(IMAX))
  214.       CALL LIRREE(X0,1,IRETOU)
  215.       IF (IERR.NE.0) RETURN
  216.       PROG(IMAX)=X0
  217.   65  CONTINUE
  218.       IF (NFOIS.LE.0) THEN
  219.         CALL ERREUR(36)
  220.         RETURN
  221.       ENDIF
  222.       NF=NFOIS-1
  223.       IF (NF.EQ.0) GOTO 99
  224.       JG0=JG
  225.       JG=JG+NF
  226.       SEGADJ,MLREEL
  227.       DO 52 I=1,NF
  228.         PROG(JG0+I)=X0
  229.   52  CONTINUE
  230.       GOTO 99
  231. C
  232.   20  CONTINUE
  233.       SEGACT,MLREEL*NOMOD
  234.       CALL ECROBJ('LISTREEL',MLREEL)
  235.       IF(IFONC.EQ.0) RETURN
  236.       GOTO 160
  237. C
  238. C ***** ON LIT LES COEFFICIENT POUR LE SINUS ********
  239. C
  240.  110  CONTINUE
  241.       FREQ=0.D0
  242.       PHI=0.D0
  243.       AMPLI=1.D0
  244.       CALL LIRREE(Y1,1,IRETOU)
  245.       IF(IERR.NE.0) RETURN
  246.       IF(Y1 .GT. 0.D0) GOTO 121
  247. C      IF(Y1) 120,120,121
  248.  120  CONTINUE
  249.       CALL ERREUR(36)
  250.       RETURN
  251.  
  252.  121  CONTINUE
  253.       FREQ=Y1
  254.       CALL LIRMOT(MOTE,2,IREP,0)
  255.       IF(IREP.EQ.0) GOTO 150
  256.       IF(IREP.EQ.2) GOTO 140
  257.       CALL LIRREE(Y2,1,IRETOU)
  258.       IF(IERR.NE.0) RETURN
  259.       PHI=Y2
  260.       CALL LIRMOT(MOTE(2),1,IREP,0)
  261.       IF(IREP.EQ.0) GOTO 150
  262.  140  CONTINUE
  263.       CALL LIRREE(Y3,1,IRETOU)
  264.       IF(IERR.NE.0) RETURN
  265.       IF(Y3 .GE. 0.D0) GOTO 122
  266. C      IF(Y3) 120,122,122
  267.       GOTO 120
  268.  
  269.  122  CONTINUE
  270.       AMPLI=Y3
  271.       GOTO 150
  272. C
  273. C ***** ON LIT LES COEFFICIENTS POUR LES AUTRES FONCTIONS ****
  274. C
  275.  210  CONTINUE
  276.       PENTE=1.D0
  277.       ORDOR=0.D0
  278.       CALL LIRMOT(MOTG,2,IRET,0)
  279.       IF(IRET.EQ.0) GOTO 150
  280.       IF(IRET.EQ.0) GOTO 220
  281.       CALL LIRREE(PENTE,1,IRETOU)
  282.       IF(IERR.NE.0) RETURN
  283.       CALL LIRMOT(MOTG(2),1,IRET,0)
  284.       IF(IRET.EQ.0) GOTO 150
  285.  220  CONTINUE
  286.       CALL LIRREE(ORDOR,1,IRETOU)
  287.       IF(IERR.NE.0) RETURN
  288. C
  289.  150  CONTINUE
  290.       CALL LIRMOT(MOTD(6),1,IRAP,0)
  291.       IF(IRAP.EQ.1) GOTO 1
  292. C
  293.  160  CONTINUE
  294.       CALL LIROBJ('LISTREEL',KK,1,IRETOU)
  295.       IF(IERR.NE.0) RETURN
  296.       MLREEL=KK
  297.       SEGACT,MLREEL
  298.       NN=PROG(/1)
  299.       JG=NN
  300.       SEGINI,MLREE1
  301. C
  302. C ***** FONCTION SINUS ********************
  303. C
  304.       IF(IFONC.NE.1) GOTO 260
  305.       DO 170 N=1,NN
  306.         X=PROG(N)
  307.         Y=2.D0*XPI*FREQ*X+PHI/XCONV
  308.         Y=AMPLI*SIN(Y)
  309.         MLREE1.PROG(N)=Y
  310.  170  CONTINUE
  311.       GOTO 500
  312. C
  313. C ***** FONCTION EXPONENTIELLE ************
  314. C
  315.  260  CONTINUE
  316.       IF(IFONC.NE.2) GOTO 360
  317.       DO 270 N=1,NN
  318.         X=PROG(N)
  319.         Y=PENTE*X+ORDOR
  320.         Y=EXP(Y)
  321.         MLREE1.PROG(N)=Y
  322.  270  CONTINUE
  323.       GOTO 500
  324. C
  325. C ***** FONCTION LOGARITHME ***************
  326. C
  327.  360  CONTINUE
  328.       IF(IFONC.NE.3) GOTO 460
  329.       DO 370 N=1,NN
  330.         X=PROG(N)
  331.         Y=PENTE*X+ORDOR
  332.         IF(Y.GT.0.D0) GOTO 365
  333.         CALL ERREUR (36)
  334.         RETURN
  335.  365    CONTINUE
  336.         Y=LOG(Y)
  337.         MLREE1.PROG(N)=Y
  338.  370  CONTINUE
  339.       GOTO 500
  340. C
  341. C ***** FONCTION LINEAIRE******************
  342. C
  343.  460  CONTINUE
  344.       DO 470 N=1,NN
  345.         X=PROG(N)
  346.         Y=PENTE*X+ORDOR
  347.         MLREE1.PROG(N)=Y
  348.  470  CONTINUE
  349. C
  350.  500  CONTINUE
  351.       SEGACT,MLREE1*NOMOD
  352.       CALL ECROBJ('LISTREEL',MLREE1)
  353.       RETURN
  354.  
  355. C
  356. C ***** OPTION TABLE **********************
  357. C
  358.  600  CONTINUE
  359.       CALL PRGTAB
  360.       RETURN
  361.  
  362.       END
  363.  
  364.  
  365.  
  366.  
  367.  

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