home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / TPFORT17.ZIP / PSAMPLE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-11-28  |  2.3 KB  |  77 lines
  1. { This is a sample Pascal program that loads and calls some Fortran routines }
  2.  
  3. {$N+}
  4.  
  5. {$M 2048,0,655360}  { There's no need for a large stack, since this program
  6.                       spends most of its time in "Fortran Mode". }
  7. program PSample;
  8.  
  9. uses
  10.   FortLink,     { the fortran linking unit }
  11.   FSample;      { the unit with the dummy declarations }
  12.  
  13.  {$f+,s-}  { SumCube  is a far routine with no stack checking, because it'll 
  14.              be called by a Fortran routine }
  15.  
  16. function SumCube(var N:longint; var X:realarray; { Mimic the Fortran parameters
  17.                                                   first }
  18.         Value_ofs:word):double_ptr;     { Always add another parameter for the
  19.                                           return address, and return a pointer }
  20.  
  21. { This looks to Fortran like
  22.   REAL*8 FUNCTION SUMCUBE(N,X)
  23.   INTEGER N
  24.   REAL*8  X(N)
  25. }
  26. var
  27.   value : double_ptr;
  28.   i : integer;
  29. begin
  30.   Enter_Pascal;
  31.   value := ptr(sseg,Value_ofs);   { Always address it on the stack segment! }
  32.  
  33.   { calculate the value and store it in value^ }
  34.  
  35.   writeln('In sumcube, called from Fortran, and calling a Fortran routine');
  36.   value^ := 0.0;
  37.   for i := 1 to N do
  38.     value^ := value^ + Cube(X[i]);   { Note that Cube is a Fortran routine }
  39.  
  40.   { set the function value to the pointer, and return }
  41.  
  42.   sumcube := value;
  43.   Leave_Pascal;
  44. end;
  45. {$s+,f-}  { Put the options back to normal }
  46.  
  47. {$F+}            { MUST be a far call }
  48. procedure Main;  { the main routine of the TP program, which can
  49.                    safely call Fortran }
  50. var
  51.   n : longint;
  52.   x : ^realarray;  { Realarray is defined as a big array of doubles }
  53.   sumcube_address : extval;
  54.   i : integer;
  55.   value : double;
  56. begin
  57.   n := 10;
  58.   getmem(x,n*sizeof(double));
  59.   for i:=1 to n do
  60.     x^[i] := i;
  61.  
  62.   writeln('Passing TP routine to a Fortran subroutine...');
  63.  
  64.                                     { This pushes @sumcube onto the stack }
  65.   sumcube_address := Pas_External(@sumcube);
  66.   Eval(sumcube_address,n,x^,value);
  67.   writeln('The sum of cubes of 1 to ',n,' is ',value:10:1);
  68.   Clean_External;                { This call cleans @sumcube off the stack. }
  69. end;
  70. {$F-}
  71.  
  72. begin
  73.   if not LoadFort('fsample.ldr',@main) then
  74.     writeln('Load failed!');
  75. end.
  76. 
  77.