%%HP: T(3)A(R)F(.);
DIR

DE
\<<                             
     IF -49 FC? -50 FC? AND     
     THEN 4                     
     ELSE 
       0 
       0 3 FOR I 
	  2 * -48 I + FS? +
       NEXT
     END 
     NEG ALOG                   
     RCLF                       
     \-> ydot step x0 y0 tol flags
     \<<
	IF x0 TYPE 12 ==       
	THEN x0 OBJ\-> SWAP     
	ELSE "x" x0            
	END
	IF y0 TYPE 12 ==      
	THEN y0 OBJ\-> SWAP
	ELSE "y" y0
	END 
	\-> xt x yt y
	\<< ydot tol step x y
	    IF y TYPE DUP 0 == SWAP 1 == OR
	    THEN DESTEP1        
	    ELSE NDESTEP        
	    END                 
	    yt \->TAG SWAP      
	    xt \->TAG SWAP      
	    4 ROLL DROP         
	    flags STOF         
	\>>
      \>>
   \>>                          

DESTEP1
\<< { } { } 0 
    \-> ydot tol step x y htab ytab iter
				
    \<< 20 CF                   
	WHILE 20 FC? iter 15 < AND 
	REPEAT                     
	  divisions 'iter' INCR GET 
	  DUP step SWAP /           
	  IF DUP x + x ==           
	  THEN                      
	    DROP2                
	    "Stepsize underflow"    
	    DOERR
	  END 
	  DUP x y ydot EVAL * y +    
	  y x 4 PICK + 3 ROLL 4 ROLL 
	  \-> h                      
	  \<< 4 ROLL 1 -             
	      1 SWAP FOR n          
		DUP2 ydot EVAL h *   
		2 * 4 PICK + 4 ROLL  
		DROP 3 ROLL h +      
		SWAP                 
				     
	      NEXT                   
	      DUP2 ydot EVAL h *     
	      + SWAP DROP + .5 *     
	      1 \->LIST 'ytab' STO+  
	      h SQ 1 \->LIST 'htab' STO+
				
	  \>>
	  IF iter 1 \=/         
	  THEN                 
	    htab 1 6 SUB       
	    ytab 1 6 SUB        
	    EXTRAP              
	    IF OVER ABS tol * < 
	    THEN 20 SF          
	    ELSE DROP           
	    END                 
	  END
	END
	IF 20 FS?               
	THEN                    
				
	  CASE iter 6 == THEN 1.2 END
	       iter 7 == THEN .95 END 16
	       divisions iter GET / END 
	  step * 
	  SWAP x step +         
	  SWAP tol 4 ROLLD      
	  ydot 5 ROLLD          
	ELSE                    
	   ydot tol step 250 / x y
	   DESTEP1
	END
    \>>
\>>

NDESTEP                         
\<< { } { } 0 
    \-> ydot tol step x y htab ytab iter
    \<< 20 CF
	WHILE 20 FC? iter 15 < AND
	REPEAT
	  divisions 'iter' INCR GET 
	  DUP step SWAP /
	  IF DUP x + x ==
	  THEN
	    DROP2
	    "Stepsize underflow"
	    DOERR
	  END 
	  DUP x y ydot EVAL * y +
	  y x 4 PICK + 3 ROLL 4 ROLL 
	  \-> h
	  \<< 4 ROLL 1 - 
	      1 SWAP FOR n
		DUP2 ydot EVAL h *
		2 * 4 PICK + 4 ROLL
		DROP 3 ROLL h +
		SWAP
	      NEXT
	      DUP2 ydot EVAL h *
	      + SWAP DROP + .5 *
	      1 \->LIST 'ytab' STO+
	      h SQ 1 \->LIST 'htab' STO+
	  \>>
	  IF iter 1 \=/
	  THEN 
	    htab 1 6 SUB ytab 1 6 SUB tol
	    IF lextrap
	    THEN 20 SF
	    END
	  END
	END
	IF 20 FS?
	THEN
	  CASE iter 6 == THEN 1.2 END
	       iter 7 == THEN .95 END 16
	       divisions iter GET / END 
	  step * 
	  SWAP x step +
	  SWAP tol 4 ROLLD
	  ydot 5 ROLLD
	ELSE 
	   ydot tol step 250 / x y
	   NDESTEP
	END
    \>>
\>>

EXTRAP                          
\<< DUP DUP2 SIZE DUP 3 PICK SWAP GET
    \-> X Y C D N RES           
    \<< 1 N 1 - FOR COL         
	  1 N COL - FOR I       
	    D I GET C I 1 + GET 
	    \-> DI CI1          
	    \<< X I GET         
		X I COL + GET / 
		DUP DI * CI1 -  
		CI1 DI - DUP    
		CI1 * SWAP DI * 
		4 ROLL * ROT    
		IF DUP 0 ==     
		THEN            
		  3 DROPN X Y
		  "Extrapolation failed"
		  DOERR
		END
		DUP ROT SWAP 
		/ 'C' I ROT PUT 
		/ 'D' I ROT PUT
	    \>>
	  NEXT
	  'RES'                 
	  D N COL - GET        
	  STO+                 
	NEXT 
	RES D 1 GET ABS         
    \>>                         
\>>


divisions                       
[ 2 4 6 8 12 16 24 32 48 64 96 128 192 256 384 ]

lextrap                         
\<< OVER DUP SIZE SWAP 
    1 GET SIZE 1 GET 0 
    \-> xl yl tol N n comp      
    \<< 21 SF                  
	WHILE 21 FS?            
	      comp n <          
	      AND
	REPEAT 
	      xl 'comp' INCR    
	      1 N FOR i         
		 yl i GET       
		 OVER GET SWAP  
	      NEXT              
	      DROP              
	      N \->LIST         
	      EXTRAP            
	      IF OVER ABS tol * >
	      THEN             
		comp DROPN     
		21 CF         
		0
	      END
	END
	IF 21 FS?               
	THEN n \->ARRY 1        
	END                     
    \>>                         
\>>

END
