home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 15 / CD_ASCQ_15_070894.iso / news / 4569 / goodies8 / math / deq.src < prev    next >
Text File  |  1993-02-18  |  7KB  |  205 lines
  1. %%HP: T(3)A(D)F(.);
  2. DIR
  3.  
  4. ;*************************************************************************
  5.   
  6.   DEQ                                
  7.     
  8.     \<< RCLF \-> flags
  9.      \<<  -56 CF 
  10.           DEQINPUT 
  11.           CLLCD "  I'm searching ..." 3 DISP 
  12.           
  13.           initvalues DUP DUP 'xyvalues' STO DEQXYSTO 
  14.                      OBJ\-> 1 GET 1 + 1 \->LIST         ;add also value of
  15.                      functions degree GET \->NUM        ;highest derivative 
  16.                      SWAP \->ARRY CL\GS \GS+            ;of y(x) to ΣDAT
  17.           
  18.           IFERR DO    1 DEQRUNGE
  19.                 UNTIL xyvalues 1 GET xmax \>=
  20.                 END
  21.           
  22.                 initvalues DUP 'xyvalues' STO DEQXYSTO
  23.           
  24.                 DO    -1 DEQRUNGE
  25.                 UNTIL xyvalues 1 GET xmin \<=
  26.                 END 
  27.           THEN  ERRM "program killed" \->TAG
  28.           END
  29.  
  30.           'X' 'Y0'                                      ;     
  31.           degree 1 >                                    ;clear
  32.           \<< 1 degree 1 -                              ;memory
  33.               FOR n "'Y" n + "'" + STR\->               ;of    
  34.               NEXT                                      ;global 
  35.           \>> IFT                                       ;vari- 
  36.           degree 1 + \->LIST                            ;ables
  37.           'xyvalues' + 'kmatrix' + PURGE                ;       
  38.           
  39.           1 XCOL 2 YCOL 1000 .01 BEEP                   ;plot
  40.           SCATRPLOT DRAX GRAPH FUNCTION                 ;result  
  41.  
  42.           flags STOF
  43.       \>>
  44.     \>>
  45.  
  46.   
  47. ;**********************************************************************  
  48.   
  49.   DEQINPUT                                              ;enter values
  50.                                                         ;needed for DEQ
  51.     \<< ": degree of diff.eq  :" "" INPUT 
  52.         DUP IF "" SAME 
  53.             THEN DROP
  54.             ELSE OBJ\-> 'degree' STO
  55.             END 
  56.         
  57.         
  58.         { X Y0 Y1 Y2 Y3 Y4 } TMENU 
  59.         "" 
  60.         ":enter Y" degree + 
  61.         "(X;Y0;Y1;..) 
  62.         No discontin.! Edit
  63.         rest for deq-sys.  :
  64.         :\.dX(Y" + degree 1 - + ")=Y" + degree + ": ''" + 
  65.         degree 1 >
  66.         \<< 2 degree FOR n
  67.                      "        
  68.                       :\.dX(Y" + degree n - + 
  69.                      ")   : 'Y" + degree n - 1 + + 
  70.                      "'" +
  71.                      NEXT
  72.         \>> IFT 
  73.         { 4 14 } ALG 3 \->LIST INPUT
  74.         0 MENU 
  75.         IFERR DUP "\.d" POS 1 - 2 PICK SIZE SUB 
  76.               OBJ\-> 1 \->LIST
  77.               degree 1 >
  78.               \<< 2 degree START SWAP +
  79.                            NEXT
  80.               \>> IFT
  81.               'functions' STO
  82.         THEN  DROP
  83.         END 
  84.         
  85.         
  86.         ""
  87.         ": enter init. val.  :
  88.          :   xo :              
  89.          :Y0(xo):"
  90.         degree 1 >
  91.         \<< 1 degree 1 - FOR n
  92.                          "              
  93.                          :Y" + n + "(xo):" +
  94.                          NEXT
  95.         \>> IFT { 2 9 } 2 \->LIST INPUT
  96.         IFERR OBJ\-> 
  97.               1 degree 1 + 
  98.               START \->NUM degree 1 + ROLLD
  99.               NEXT 
  100.               degree 1 + \->ARRY 'initvalues' STO
  101.         THEN  DROP
  102.         END
  103.  
  104.         
  105.         ":      x-range       :
  106.           (should include xo)"
  107.         { ":xmin=:
  108.            :xmax=:" 8 } INPUT
  109.         IFERR OBJ\-> 
  110.               DUP2 MAX \->NUM 'xmax' STO 
  111.                    MIN \->NUM 'xmin' STO
  112.         THEN  DROP
  113.         END
  114.  
  115.         
  116.         ":      stepsize      :"
  117.         "" INPUT
  118.         IF   DUP "" SAME
  119.         THEN DROP
  120.         ELSE OBJ\-> ABS \->NUM 'h' STO
  121.         END
  122.     \>>
  123.   
  124.  
  125.  
  126. ;**************************************************************************
  127.   
  128.   DEQXYSTO
  129.     
  130.     \<< \-> vector
  131.       \<< vector 1 GETI 'X' STO GET 'Y0' STO 
  132.           degree 1 >
  133.           \<< 1 degree 1 -
  134.               FOR n vector n 2 + GET "'Y" n + "'" + STR\-> STO
  135.               NEXT
  136.           \>> IFT
  137.        \>>
  138.     \>>
  139.   
  140.   
  141. ;**************************************************************************  
  142.   
  143.   DEQRUNGE                                            
  144.  
  145.     \<< \-> direction
  146.       \<< 4 degree 2 \->LIST 0 CON 'kmatrix' STO    ;generate array for
  147.                                                     ;temporary needed k's
  148.                                                     ;       y0 y1 y2 ..
  149.                                                     ; k1 [[          .. ]
  150.                                                     ; k2  [          .. ]
  151.                                                     ; k3  [          .. ]
  152.                                                     ; k4  [          .. ]]
  153.           1 4
  154.           FOR k 
  155.               1 degree
  156.               FOR n functions n GET EVAL h * direction *     ;fill    
  157.                   kmatrix SWAP k n 2 \->LIST SWAP PUT        ;row of    
  158.                   'kmatrix' STO                              ;present k
  159.               NEXT                                           ;in 'kmatrix'
  160.               
  161.               k 3 \<=                                        ;calcul-  
  162.               \<< h direction * { 2 2 1 } k GET /            ;ate     
  163.                   1 degree                                   ;x-      
  164.                   FOR column kmatrix k column 2 \->LIST GET  ;y-    
  165.                       { 2 2 1 } k GET /                      ;values
  166.                   NEXT                                       ;for 
  167.                   degree 1 + \->ARRY xyvalues + DEQXYSTO     ;next
  168.               \>> IFT                                        ;k
  169.           NEXT 
  170.           
  171.           h direction *                                      ;dx-value
  172.           
  173.           1 degree                                           ;calcul- 
  174.           FOR n                                              ;ate         
  175.               1 4                                            ;dy-   
  176.               FOR k                                          ;values 
  177.                   kmatrix k n 2 \->LIST GET                  ;(result   
  178.                   { 6 3 3 6 } k GET /                        ;of  
  179.               NEXT                                           ;Runge-
  180.               + + +                                          ;Kutta-
  181.           NEXT                                               ;approx-
  182.           degree 1 + \->ARRY                                 ;imation )   
  183.           
  184.           xyvalues +
  185.           DUP DUP 'xyvalues' STO DEQXYSTO          ;store new x-y-values
  186.                   OBJ\-> 1 GET 1 + 1 \->LIST       ;in 'xyvalues' and in     
  187.                   functions degree GET EVAL        ;ΣDAT also highest    
  188.                   SWAP \->ARRY \GS+                ;derivative of y(x) 
  189.                   
  190.           CLLCD
  191.           "|\175\175\175\175\175\175\175\175\175\175\175\175\175\175\175\175\175\175\175\175|
  192.           "
  193.           "| x=                 |
  194.           " 5 xyvalues 1 GET \->STR REPL +
  195.           "| y=                 |
  196.           " 5 xyvalues 2 GET \->STR REPL +
  197.           "|____________________|
  198.  
  199.               is part of Y0(X)" + 2 DISP
  200.       \>>
  201.     \>>
  202.  
  203.  
  204. END
  205.