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