share/contrib/gentran/gentrandemo1.mac

   1
   2 /* Generation of FORTRAN Code
   3 Using Macsyma's GENTRAN Package
   4 Basic Demonstration  */
   5 box("Gentran Demo");
   6
   7 /*
   8 1. Translation of Basic Program Statements from Macsyma to FORTRAN */
   9 (genfloat : true, gentranlang : 'fortran)$
  10
  11 /* 1.1 Translate assignment statements. */
  12 gentran( p : a*x^2+b*x+c )$
  13
  14 /* C:\MACSYMA2\library2\gentran.fas being loaded.
  15       P=A*X**2+B*X+C */
  16
  17 /* 1.2 Translate matrix structures. */
  18 gentran( m : matrix([u,2*u^2],[-v^2,v]) )$
  19
  20 /*       M(1,1)=U
  21       M(1,2)=2.0d0*U**2
  22       M(2,1)=-V**2
  23       M(2,2)=V */
  24
  25 /* 1.3 Translate iteration loops.
  26
  27 Gentran keeps track of statement labels, to assure uniqueness. */
  28 gentran( for i step 2 thru 9 do
  29       p : p+a[i] )$
  30
  31 /*       DO 25001 I=1,9,2
  32           P=P+A(I)
  33 25001 CONTINUE */
  34
  35 /* Iteration loops with "next" */
  36 gentran( for n from 2 next n*2 thru 500 do
  37       s : s+n )$
  38
  39 /*       N=2.0d0
  40 25002 IF (N.GT.500.0d0) GOTO 25003
  41           S=S+N
  42           N=N*2.0d0
  43           GOTO 25002
  44 25003 CONTINUE */
  45
  46 /* Iteration loops with "while" */
  47 gentran( while f(x) >= 0 do x : x+0.25 )$
  48
  49 /* 25004 IF (.NOT.F(X).GE.0.0d0) GOTO 25005
  50           X=X+0.25
  51           GOTO 25004
  52 25005 CONTINUE */
  53
  54 /* Iteration loops with "unless" */
  55 gentran( unless f(x) >= 0 do x : x+0.25 )$
  56
  57 /* 25006 IF (F(X).GE.0.0d0) GOTO 25007
  58           X=X+0.25
  59           GOTO 25006
  60 25007 CONTINUE */
  61
  62 /* 1.4 Translate conditional branching "if-then" statements. */
  63 gentran( if x > 0 then y : x )$
  64
  65 /*       IF (.NOT.X.GT.0.0d0) GOTO 25008
  66           Y=X
  67 25008 CONTINUE */
  68
  69 /* "If-then-else" statements */
  70 gentran (if x > 0 then y : x else y : -x )$
  71
  72 /*       IF (.NOT.X.GT.0.0d0) GOTO 25009
  73           Y=X
  74           GOTO 25010
  75 25009 CONTINUE
  76           Y=-X
  77 25010 CONTINUE */
  78
  79 /* 1.5 Translate function calls. */
  80 gentran( calcv(v,x,y,z) )$
  81
  82 /*       CALL CALCV(V,X,Y,Z) */
  83
  84 /* 1.6 Translate Macsyma Programs.
  85
  86 Translate compound statements. */
  87 gentran( (u1 : x^2, u2 : x-y) )$
  88
  89 /*       U1=X**2
  90       U2=X-Y */
  91
  92 /* Translate Macsyma program blocks. */
  93 gentran( block(u1 : x^2,u2 : x-y) )$
  94
  95 /*       U1=X**2
  96       U2=X-Y */
  97
  98 /* Translate statement labels and explicit "go" statements. */
  99 gentran( block(f : 1, i : 1,
 100     loop,
 101     f : f*i, i : i+1,
 102     if i <= n then go(loop)) )$
 103
 104 /*       F=1.0d0
 105       I=1.0d0
 106 25011 CONTINUE
 107       F=F*I
 108       I=I+1.0d0
 109       IF (.NOT.I.LE.N) GOTO 25012
 110           GOTO 25011
 111 25012 CONTINUE */
 112
 113 /* Translate function definitions into function definitions. */
 114 gentran( f(a,b,c,x) := block(z : a*b*c+x, return(z)) )$
 115
 116 /*       FUNCTION F(A,B,C,X)
 117       Z=A*B*C+X
 118       F=Z
 119       RETURN
 120       END */
 121
 122 /* Translate function definitions into subroutine definitions. */
 123 gentran( f(a,b,c,x) := block(z : a*b*c+x, print("z = ",z)) )$
 124
 125 /*       SUBROUTINE F(A,B,C,X)
 126       Z=A*B*C+X
 127       WRITE(*,*) "z = ",Z
 128       RETURN
 129       END */
 130
 131 /* 1.7 Control evaluation during translation. */
 132
 133 /*
 134 (Use the expression F in the following examples.) */
 135 f : 3*x^2-8*x+4;
 136
 137 /* Control evaluation of symbols and operations. */
 138 gentran( q : eval(f)/eval(diff(f,x)) )$
 139
 140 /*       Q=(3.0d0*X**2-(8.0d0*X)+4.0d0)/(6.0d0*X-8.0d0) */
 141
 142 /* Tell Gentran to evaluate only the RHS of an assignment statement. */
 143 gentran( rsetq(deriv, diff(a*x^4-4*b*x^3+3*c*x^2/2,x)) )$
 144
 145 /*       DERIV=4.0d0*A*X**3-(12.0d0*B*X**2)+3.0d0*C*X */
 146
 147 /* Tell Gentran to evaluate only the LHS of an assignment statement. */
 148 for j thru 4 do
 149     gentran ( lsetq(m(j,j),0) )$
 150
 151 /*       M(1,1)=0.0d0
 152       M(2,2)=0.0d0
 153       M(3,3)=0.0d0
 154       M(4,4)=0.0d0 */
 155 m : matrix([a,0,-1], [a^2,b,a/b], [b^2,0,c]);
 156
 157 /* Tell Gentran to evaluate both the left and right sides of an assignment statement. */
 158 for j thru 3 do
 159   gentran( lrsetq(m[j,j], m[j,j]) )$
 160
 161 /*       M(1,1)=A
 162       M(2,2)=B
 163       M(3,3)=C */
 164
 165 /* 1.8 Translate comments and other literal strings. */
 166 gentran ( for i thru n do
 167       literal("C",tab,"THIS IS A FORTRAN COMMENT",cr,
 168       tab,"WRITE(6,10) (M(I,J),J=1,N)",cr,
 169       10,tab,"FORMAT(1X,10(I5,3X))",cr) )$
 170
 171 /*
 172       DO 25013 I=1,N
 173 C         THIS IS A FORTRAN COMMENT
 174           WRITE(6,10) (M(I,J),J=1,N)
 175 10        FORMAT(1X,10(I5,3X))
 176 25013 CONTINUE */
 177
 178 /* Clean up after the previous section. */
 179 remvalue(f, m)$
 180
 181 /*
 182 2. Automatic Expression Segmentation and Optimization */
 183
 184 /*
 185 2.1 Automatic Expression Segmentation */
 186
 187 /*
 188 First, translate with segmentation and optimization turned off. */
 189 (gentranseg : false, gentranopt : false)$
 190
 191 /* We shall use this rather large expression in our examples. */
 192 x : expand(a^6+(a+b)^6+(a+b+c)^6);
 193
 194 /* With segmentation turned off, Gentran reproduces large statements. */
 195 gentran(x : eval(x))$
 196
 197 /*       X=C**6+6.0d0*B*C**5+6.0d0*A*C**5+15.0d0*B**2*C**4+30.0d0*A*B*C**4+
 198      . 15.0d0*A**2*C**4+20.0d0*B**3*C**3+60.0d0*A*B**2*C**3+60.0d0*A**2*
 199      . B*C**3+20.0d0*A**3*C**3+15.0d0*B**4*C**2+60.0d0*A*B**3*C**2+
 200      . 90.0d0*A**2*B**2*C**2+60.0d0*A**3*B*C**2+15.0d0*A**4*C**2+6.0d0*B
 201      . **5*C+30.0d0*A*B**4*C+60.0d0*A**2*B**3*C+60.0d0*A**3*B**2*C+
 202      . 30.0d0*A**4*B*C+6.0d0*A**5*C+2.0d0*B**6+12.0d0*A*B**5+30.0d0*A**2
 203      . *B**4+40.0d0*A**3*B**3+30.0d0*A**4*B**2+12.0d0*A**5*B+3.0d0*A**6 */
 204
 205 /* Turn on segmentation, and set maximum expression length to 100 characters. */
 206 (gentranseg : true, maxexpprintlen : 100)$
 207
 208 /* With segmentation turned on, Gentran breaks up large expressions into several statements.  It introduces uniquely named
 209 dummy variables in this process. */
 210 gentran(x : eval(x))$
 211
 212 /*       T0=C**6+6.0d0*B*C**5+6.0d0*A*C**5+15.0d0*B**2*C**4+30.0d0*A*B*C**4
 213      . +15.0d0*A**2*C**4
 214       T0=T0+20.0d0*B**3*C**3+60.0d0*A*B**2*C**3+60.0d0*A**2*B*C**3+
 215      . 20.0d0*A**3*C**3
 216       T0=T0+15.0d0*B**4*C**2+60.0d0*A*B**3*C**2+90.0d0*A**2*B**2*C**2+
 217      . 60.0d0*A**3*B*C**2
 218       T0=T0+15.0d0*A**4*C**2+6.0d0*B**5*C+30.0d0*A*B**4*C+60.0d0*A**2*B
 219      . **3*C
 220       T0=T0+60.0d0*A**3*B**2*C+30.0d0*A**4*B*C+6.0d0*A**5*C+2.0d0*B**6+
 221      . 12.0d0*A*B**5
 222       X=T0+30.0d0*A**2*B**4+40.0d0*A**3*B**3+30.0d0*A**4*B**2+12.0d0*A**
 223      . 5*B+3.0d0*A**6 */
 224
 225 /* 2.2 Automatic Expression Optimization
 226
 227 Translate with segmentation turned of and automatic expression optimization on. */
 228 (gentranseg : false, gentranopt : true)$
 229
 230 /* When optimization is turned on, Gentran identifies common subexpressions and defines variables for them. */
 231 gentran( x : eval(x) )$
 232
 233 /* C:\MACSYMA2\library1\optim.fas being loaded.
 234       U0=A**5
 235       U1=A**4
 236       U2=B**2
 237       U3=A**3
 238       U4=B**3
 239       U5=A**2
 240       U6=B**4
 241       U7=B**5
 242       U8=C**2
 243       U9=C**3
 244       U10=C**4
 245       U11=C**5
 246       X=C**6+6.0d0*B*U11+6.0d0*A*U11+15.0d0*U2*U10+30.0d0*A*B*U10+15.0d0
 247      . *U5*U10+20.0d0*U4*U9+60.0d0*A*U2*U9+60.0d0*U5*B*U9+20.0d0*U3*U9+
 248      . 15.0d0*U6*U8+60.0d0*A*U4*U8+90.0d0*U5*U2*U8+60.0d0*U3*B*U8+15.0d0
 249      . *U1*U8+6.0d0*U7*C+30.0d0*A*U6*C+60.0d0*U5*U4*C+60.0d0*U3*U2*C+
 250      . 30.0d0*U1*B*C+6.0d0*U0*C+2.0d0*B**6+12.0d0*A*U7+30.0d0*U5*U6+
 251      . 40.0d0*U3*U4+30.0d0*U1*U2+12.0d0*U0*B+3.0d0*A**6 */
 252
 253 /* Clean up after previous section. */
 254 (remvalue(x), gentranopt : false, maxexpprintlen : 800)$
 255
 256 /*
 257 3. Type Declarations for Functions and Variables */
 258
 259 /*
 260 3.1 Explicit Type Declarations
 261
 262 Gentran translates this function into a FORTRAN integer-valued function with integer argument N.  Gentran figures out that
 263 the internal variables F and I must be type integer. */
 264 gentran( fac(n) :=
 265     block(type(function,fac),
 266       type(integer,fac,n),
 267       f : 1,
 268       for i thru n do
 269         f : f*i,type(integer,f,i),
 270       return(f)) )$
 271
 272 /*
 273       INTEGER FUNCTION FAC(N)
 274       INTEGER N,F,I
 275       F=1.0d0
 276       DO 25014 I=1,N
 277           F=F*I
 278 25014 CONTINUE
 279       FAC=F
 280       RETURN
 281       END */
 282
 283 /* 3.2 Implicit Type Declarations
 284
 285 Gentran will declare the types generated dummy variables when this can be determined from the context, or it will declare
 286 them to be the type you specify as the value of TEMPVARTYPE. */
 287 (gentranseg : true, maxexpprintlen : 15, tempvartype : 'real)$
 288 gentran( type(integer, i),
 289     type(real\*8, x, y),
 290     x : x1+x2+x3+x4+x5+x6,
 291     i : i1*i2*i3*i4*i5*i6,
 292     y : y1-y2+y3-y4+y5-y6,
 293     z : z1*z2*z3+z4*z5*z6 )$
 294
 295 /*
 296       INTEGER I,T1
 297       REAL*8 X,Y,T0
 298       REAL T2
 299       T0=X1+X2+X3+X4
 300       X=T0+X5+X6
 301       T1=I1*I2*I3*I4
 302       I=T1*I5*I6
 303       T0=Y1-Y2+Y3
 304       T0=T0-Y4+Y5
 305       Y=T0-Y6
 306       T2=Z1*Z2*Z3
 307       Z=T2+Z4*Z5*Z6 */
 308
 309 /*
 310 4. Generation and Marking of Temporary Variables.
 311  */
 312 (tempvartype : false, maxexpprintlen : 800, gentranseg : false)$
 313
 314 /* You can generate a numbered "temporary variable" using the command tempvar. */
 315 varname : tempvar(false);
 316
 317 /* Invoking tempvar again generates the same variable name. */
 318 tempvar(false);
 319
 320 /* You can mark a variable name as used with the command markvar . . . */
 321 markvar(varname);
 322
 323 /* . . . after which another invocation of tempvar returns a new variable name.  */
 324 tempvar(false);
 325
 326 /* You can unmark a variable name . . . */
 327 unmarkvar(varname)$
 328
 329 /* . . . and generate the name again. */
 330 tempvar(false);
 331 m : matrix([a*(b+c),0,a*c],[-a,a-b,0],[a*c,0,c^2]);
 332
 333 /* Here is an example using tempvar and markvar. */
 334 for i thru 3 do
 335   for j thru 3 do
 336     if m[i,j] # 0 then (
 337       var : tempvar(false),
 338       markvar(var),
 339       gentran( eval(var) : eval(m[i,j]) ),
 340       m[i,j] : var)$
 341
 342 /*
 343       T3=A*(C+B)
 344       T4=A*C
 345       T5=-(1.0d0*A)
 346       T6=-(1.0d0*B)+A
 347       T7=A*C
 348       T8=C**2 */
 349 m;
 350
 351 /* Clean up after previous section. */
 352 remvalue(m,varname)$
 353