archive/share/lisp/diffeq.lisp

   1 ;;; -*- Mode: Lisp; Package: Macsyma -*-
   2 ;;; Translated code for LMIVAX::MAX$DISK:[SHARE2]DIFFEQ.MC;4
   3 ;;; Written on 9/15/1984 01:39:05, from MACSYMA 302
   4 ;;; Translated for LPH
   5
   6 ;;; TRANSL-AUTOLOAD version NIL
   7 ;;; TRANSS version 87 TRANSL version 1157 TRUTIL version 27
   8 ;;; TRANS1 version 108 TRANS2 version 39 TRANS3 version 50
   9 ;;; TRANS4 version 29 TRANS5 version 26 TRANSF version NIL
  10 ;;; TROPER version 15 TRPRED version 6 MTAGS version NIL
  11 ;;; MDEFUN version 58 TRANSQ version 88 FCALL version 40
  12 ;;; ACALL version 70 TRDATA version 68 MCOMPI version 146
  13 ;;; TRMODE version 73 TRHOOK version NIL
  14 (eval-when (compile eval)
  15       (setq *infile-name-key*
  16                   (namestring (truename '#.standard-input))))
  17
  18 (eval-when (compile)
  19    (setq $tr_semicompile 'NIL)
  20    (setq forms-to-compile-queue ()))
  21
  22 (comment "MAX$DISK:[SHARE2]DIFFEQ.MC;4")
  23
  24 ;;; General declarations required for translated MACSYMA code.
  25
  26 (DECLARE (SPECIAL $LISTARITH $ARGL $DIFFEQ_RUNTIME $X_WE_ARE_CALCULATING))
  27
  28 (DEFMTRFUN-EXTERNAL ($FLOATCHECK $ANY MDEFINE NIL NIL))
  29
  30 (DECLARE (SPECIAL $X_WE_ARE_CALCULATING))
  31
  32 (DECLARE (SPECIAL $DIFFEQ_RUNTIME))
  33
  34 (DEFMTRFUN-EXTERNAL ($RUNGE1 $ANY MDEFINE NIL NIL))
  35
  36 (DEFMTRFUN-EXTERNAL ($RUNGE1_INTERNAL $ANY MDEFINE NIL NIL))
  37
  38 (DEFMTRFUN-EXTERNAL ($RUNGE2 $ANY MDEFINE NIL NIL))
  39
  40 (DEFMTRFUN-EXTERNAL ($RUNGE2_INTERNAL $ANY MDEFINE NIL NIL))
  41
  42 (PUTPROP 'MAPLIST_TR (OR (GET 'MARRAYREF 'AUTOLOAD) T) 'AUTOLOAD)
  43
  44 (DEFMTRFUN-EXTERNAL ($RUNGEN $ANY MDEFINE NIL NIL))
  45
  46 (DEF-MTRVAR $ARGL '((MLIST)) 1)
  47
  48 (DEFMTRFUN-EXTERNAL ($VAPPLY $ANY MDEFINE NIL NIL))
  49
  50 (DEFMTRFUN-EXTERNAL ($RUNGEN_INTERNAL $ANY MDEFINE NIL NIL))
  51
  52
  53 (DEFPROP $FLOATCHECK T TRANSLATED)
  54
  55 (ADD2LNC '$FLOATCHECK $PROPS)
  56
  57 (DEFMTRFUN
  58   ($FLOATCHECK $ANY MDEFINE NIL NIL) ($X) NIL
  59   (PROGN
  60     NIL (SETQ $X ($FLOAT $X))
  61     (COND
  62       ((NOT (MFUNCTION-CALL $NUMBERP $X))
  63          (SIMPLIFY
  64            (MFUNCTION-CALL $ERROR $X '|&not a floating point number.|))))
  65     $X))
  66
  67 (MEVAL* '(($MODEDECLARE) (($FUNCTION) $FLOATCHECK) $FLOAT))
  68
  69 (MEVAL* '(($MODEDECLARE) $X_WE_ARE_CALCULATING $ANY))
  70
  71 (MEVAL* '(($DECLARE) $X_WE_ARE_CALCULATING $SPECIAL))
  72
  73 (DEF-MTRVAR $X_WE_ARE_CALCULATING '|&WE ARE NOT CALCULATING|)
  74
  75 (MEVAL* '(($MODEDECLARE) $DIFFEQ_RUNTIME $ANY))
  76
  77 (MEVAL* '(($DECLARE) $DIFFEQ_RUNTIME $SPECIAL))
  78
  79 (DEF-MTRVAR
  80   $DIFFEQ_RUNTIME (SIMPLIFY (MAPPLY-TR '$STATUS '((MLIST) $RUNTIME))))
  81
  82 (DEFPROP $RUNGE1 T TRANSLATED)
  83
  84 (ADD2LNC '$RUNGE1 $PROPS)
  85
  86 (DEFMTRFUN
  87   ($RUNGE1 $ANY MDEFINE NIL NIL) ($F $X0 $X1 $H $Y0) NIL
  88   (PROGN NIL
  89          (PROGN (SETQ $X0 (MFUNCTION-CALL $FLOATCHECK $X0))
  90                 (SETQ $X1 (MFUNCTION-CALL $FLOATCHECK $X1))
  91                 (SETQ $H (MFUNCTION-CALL $FLOATCHECK $H))
  92                 (SETQ $Y0 (MFUNCTION-CALL $FLOATCHECK $Y0)))
  93          (SIMPLIFY (MFUNCTION-CALL $RUNGE1_INTERNAL $F $X0 $X1 $H $Y0))))
  94
  95 (DEFPROP $RUNGE1_INTERNAL T TRANSLATED)
  96
  97 (ADD2LNC '$RUNGE1_INTERNAL $PROPS)
  98
  99 (DEFMTRFUN
 100  ($RUNGE1_INTERNAL $ANY MDEFINE NIL NIL)
 101  ($F $X0 $X1 $H $Y0) (DECLARE (FLONUM $Y0 $H $X1 $X0))
 102  (PROGN
 103    NIL
 104    ((LAMBDA ($Y_LIST $X_LIST $YP_LIST $K1 $K2 $K3 $K4)
 105       (DECLARE (FLONUM $K4 $K3 $K2 $K1))
 106       NIL
 107       (DO (($X $X0 (+$ $H $X))) ((> $X $X1) '$DONE)
 108         (SETQ $X_WE_ARE_CALCULATING $X)
 109         (SETQ $Y_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $Y0 $Y_LIST)))
 110         (SETQ $X_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $X $X_LIST)))
 111         (SETQ $K1 (MFUNCALL $F $X $Y0))
 112         (SETQ $YP_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $K1 $YP_LIST)))
 113         (SETQ $K1 (*$ $H $K1))
 114         (SETQ
 115           $K2
 116           (*$ $H
 117               (MFUNCALL
 118                 $F (+$ $X (|//$| $H 2.0d+0)) (+$ $Y0 (|//$| $K1 2.0d+0)))))
 119         (SETQ
 120           $K3
 121           (*$ $H
 122               (MFUNCALL
 123                 $F (+$ $X (|//$| $H 2.0d+0)) (+$ $Y0 (|//$| $K2 2.0d+0)))))
 124         (SETQ $K4 (*$ $H (MFUNCALL $F (+$ $X $H) (+$ $Y0 $K3))))
 125         (SETQ
 126           $Y0
 127           (+$
 128             $Y0 (|//$| (+$ $K1 $K2) 6.0d+0) (|//$| (+$ $K2 $K3) 3.0d+0))))
 129       (SETQ $X_WE_ARE_CALCULATING '|&WE ARE NOT CALCULATING|)
 130       (LIST '(MLIST) (SIMPLIFY (MFUNCTION-CALL $REVERSE $X_LIST))
 131             (SIMPLIFY (MFUNCTION-CALL $REVERSE $Y_LIST))
 132             (SIMPLIFY (MFUNCTION-CALL $REVERSE $YP_LIST))))
 133     '((MLIST)) '((MLIST)) '((MLIST)) 0.0D+0 0.0D+0 0.0D+0 0.0D+0)))
 134
 135 (DEFPROP $RUNGE2 T TRANSLATED)
 136
 137 (ADD2LNC '$RUNGE2 $PROPS)
 138
 139 (DEFMTRFUN
 140   ($RUNGE2 $ANY MDEFINE NIL NIL) ($F $X0 $X1 $H $Y0 $YP0) NIL
 141   (PROGN
 142     NIL
 143     (PROGN (SETQ $X0 (MFUNCTION-CALL $FLOATCHECK $X0))
 144            (SETQ $X1 (MFUNCTION-CALL $FLOATCHECK $X1))
 145            (SETQ $H (MFUNCTION-CALL $FLOATCHECK $H))
 146            (SETQ $Y0 (MFUNCTION-CALL $FLOATCHECK $Y0))
 147            (SETQ $YP0 (MFUNCTION-CALL $FLOATCHECK $YP0)))
 148     (SIMPLIFY (MFUNCTION-CALL $RUNGE2_INTERNAL $F $X0 $X1 $H $Y0 $YP0))))
 149
 150 (DEFPROP $RUNGE2_INTERNAL T TRANSLATED)
 151
 152 (ADD2LNC '$RUNGE2_INTERNAL $PROPS)
 153
 154 (DEFMTRFUN
 155  ($RUNGE2_INTERNAL $ANY MDEFINE NIL NIL)
 156  ($F $X0 $X1 $H $Y0 $YP0) (DECLARE (FLONUM $YP0 $Y0 $H $X1 $X0))
 157  (PROGN
 158    NIL
 159    ((LAMBDA ($Y_LIST $X_LIST $YP_LIST $YPP_LIST $K1 $K2 $K3 $K4 $TEMP)
 160       (DECLARE (FLONUM $TEMP $K4 $K3 $K2 $K1))
 161       NIL
 162       (DO (($X $X0 (+$ $H $X))) ((> $X $X1) '$DONE)
 163         (SETQ $X_WE_ARE_CALCULATING $X)
 164         (SETQ $Y_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $Y0 $Y_LIST)))
 165         (SETQ $X_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $X $X_LIST)))
 166         (SETQ $YP_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $YP0 $YP_LIST)))
 167         (SETQ $K1 (MFUNCALL $F $X $Y0 $YP0))
 168         (SETQ $YPP_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $K1 $YPP_LIST)))
 169         (SETQ $K1 (*$ $H $K1))
 170         (SETQ
 171           $K2
 172           (*$
 173             $H
 174             (MFUNCALL
 175               $F (+$ $X (|//$| $H 2.0d+0))
 176               (+$ $Y0 (*$ (|//$| $H 2.0d+0) (+$ $YP0 (|//$| $K1 4.0d+0))))
 177               (+$ $YP0 (|//$| $K1 2.0d+0)))))
 178         (SETQ
 179           $K3
 180           (*$
 181             $H
 182             (MFUNCALL
 183               $F (+$ $X (|//$| $H 2.0d+0))
 184               (+$ $Y0 (*$ (|//$| $H 2.0d+0) (+$ $YP0 (|//$| $K2 4.0d+0))))
 185               (+$ $YP0 (|//$| $K2 2.0d+0)))))
 186         (SETQ
 187           $K4
 188           (*$ $H
 189               (MFUNCALL
 190                 $F (+$ $X $H) (+$ $Y0 (*$ $H (+$ $YP0 (|//$| $K3 2.0d+0))))
 191                 (+$ $YP0 $K3))))
 192         (SETQ
 193           $TEMP
 194           (+$ $YP0 (|//$| (+$ $K1 (*$ 2.0d+0 (+$ $K2 $K3)) $K4) 6.0d+0)))
 195         (SETQ
 196           $Y0 (+$ $Y0 (*$ $H (+$ $YP0 (|//$| (+$ $K1 $K2 $K3) 6.0d+0)))))
 197         (SETQ $YP0 $TEMP))
 198       (SETQ $X_WE_ARE_CALCULATING '|&WE ARE NOT CALCULATING|)
 199       (LIST '(MLIST) (SIMPLIFY (MFUNCTION-CALL $REVERSE $X_LIST))
 200             (SIMPLIFY (MFUNCTION-CALL $REVERSE $Y_LIST))
 201             (SIMPLIFY (MFUNCTION-CALL $REVERSE $YP_LIST))
 202             (SIMPLIFY (MFUNCTION-CALL $REVERSE $YPP_LIST))))
 203     '((MLIST)) '((MLIST)) '((MLIST)) '((MLIST))
 204     0.0D+0 0.0D+0 0.0D+0 0.0D+0 0.0D+0)))
 205
 206 (DEFPROP $RUNGEN T TRANSLATED)
 207
 208 (ADD2LNC '$RUNGEN $PROPS)
 209
 210 (DEFMTRFUN
 211   ($RUNGEN $ANY MDEFINE NIL NIL) ($FL $XA $XB $H $YAL) NIL
 212   (PROGN
 213     NIL
 214     ((LAMBDA ($ORDER)
 215        (DECLARE (FIXNUM $ORDER))
 216        NIL
 217        (COND ((NOT (= $ORDER (MFUNCTION-CALL $LENGTH $YAL)))
 218                 (SIMPLIFY
 219                   (MFUNCTION-CALL
 220                     $ERROR '|&Wrong number of initial values| $FL $YAL))))
 221        (PROGN (SETQ $XA (MFUNCTION-CALL $FLOATCHECK $XA))
 222               (SETQ $XB (MFUNCTION-CALL $FLOATCHECK $XB))
 223               (SETQ $H (MFUNCTION-CALL $FLOATCHECK $H)))
 224        (SETQ $YAL (MAPLIST_TR '$FLOATCHECK $YAL))
 225        (SIMPLIFY (MFUNCTION-CALL $RUNGEN_INTERNAL $FL $XA $XB $H $YAL)))
 226      (MFUNCTION-CALL $LENGTH $FL))))
 227
 228 (DEFPROP $VAPPLY T TRANSLATED)
 229
 230 (ADD2LNC '$VAPPLY $PROPS)
 231
 232 (DEFMTRFUN
 233   ($VAPPLY $ANY MDEFINE NIL NIL) ($FL $ARGL) NIL
 234   (PROGN
 235     NIL NIL
 236     (MAPLIST_TR
 237       (M-TLAMBDA ($F) NIL NIL
 238                  (SIMPLIFY (MAPPLY-TR $F (TRD-MSYMEVAL $ARGL '((MLIST))))))
 239       $FL)))
 240
 241 (MEVAL* '(($DECLARE) $LISTARITH $SPECIAL))
 242
 243 (DEFPROP $RUNGEN_INTERNAL T TRANSLATED)
 244
 245 (ADD2LNC '$RUNGEN_INTERNAL $PROPS)
 246
 247 (DEFMTRFUN
 248  ($RUNGEN_INTERNAL $ANY MDEFINE NIL NIL)
 249  ($F $XA $XB $H $YA) (DECLARE (FLONUM $H $XB $XA))
 250  (PROGN
 251    NIL
 252    ((LAMBDA ($Y_LIST $X_LIST $YP_LIST $K1 $K2 $K3 $K4 $LISTARITH)
 253       NIL
 254       NIL
 255       (DO (($X $XA (+$ $H $X))) ((> $X $XB) '$DONE)
 256         (SETQ $X_WE_ARE_CALCULATING $X)
 257         (SETQ $Y_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $YA $Y_LIST)))
 258         (SETQ $X_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $X $X_LIST)))
 259         (SETQ
 260           $K1 (SIMPLIFY
 261                 (MFUNCTION-CALL
 262                   $VAPPLY $F (SIMPLIFY (MFUNCTION-CALL $CONS $X $YA)))))
 263         (SETQ $YP_LIST (SIMPLIFY (MFUNCTION-CALL $CONS $K1 $YP_LIST)))
 264         (SETQ $K1 (MUL* $H $K1))
 265         (SETQ
 266           $K2
 267           (MUL*
 268             $H
 269             (SIMPLIFY
 270               (MFUNCTION-CALL
 271                 $VAPPLY $F
 272                 (SIMPLIFY (MFUNCTION-CALL $CONS (+$ $X (|//$| $H 2.0d+0))
 273                                           (ADD* $YA (DIV $K1 2.0d+0))))))))
 274         (SETQ
 275           $K3
 276           (MUL*
 277             $H
 278             (SIMPLIFY
 279               (MFUNCTION-CALL
 280                 $VAPPLY $F
 281                 (SIMPLIFY (MFUNCTION-CALL $CONS (+$ $X (|//$| $H 2.0d+0))
 282                                           (ADD* $YA (DIV $K2 2.0d+0))))))))
 283         (SETQ
 284           $K4
 285           (MUL*
 286             $H (SIMPLIFY
 287                  (MFUNCTION-CALL
 288                    $VAPPLY $F
 289                    (SIMPLIFY
 290                      (MFUNCTION-CALL $CONS (+$ $X $H) (ADD* $YA $K3)))))))
 291         (SETQ
 292           $YA
 293           (ADD*
 294             $YA (DIV (ADD* $K1 $K2) 6.0d+0) (DIV (ADD* $K2 $K3) 3.0d+0))))
 295       (SETQ $X_WE_ARE_CALCULATING '|&WE ARE NOT CALCULATING|)
 296       (LIST '(MLIST) (SIMPLIFY (MFUNCTION-CALL $REVERSE $X_LIST))
 297             (SIMPLIFY (MFUNCTION-CALL $REVERSE $Y_LIST))
 298             (SIMPLIFY (MFUNCTION-CALL $REVERSE $YP_LIST))))
 299     '((MLIST)) '((MLIST)) '((MLIST)) '((MLIST))
 300     '((MLIST)) '((MLIST)) '((MLIST)) T)))
 301
 302 (compile-forms-to-compile-queue)
 303