1 c ******************************************************
   2 c *                                                    *
   3 c * Copyright, (C) Honeywell Limited, 1983             *
   4 c *                                                    *
   5 c * Copyright (c) 1972 by Massachusetts Institute of   *
   6 c * Technology and Honeywell Information Systems, Inc. *
   7 c *                                                    *
   8 c ******************************************************
   9 
  10 %global no_auto_zero;
  11 c     =======================================
  12 c     program for self-documentation
  13 c
  14 c     Written:  06/06/79 by Paul E. Smee
  15 c
  16 c     Modified:
  17 c     =======================================
  18 
  19       subroutine fort_parm_math
  20 
  21       external ioa_ (descriptors)
  22       external version
  23       character*4 version
  24 
  25       call ioa_ ("fort_parameter_math version^x^a", version (0))
  26 
  27       stop
  28       end
  29 c     ========================================
  30 c     version number function just for fun
  31 c
  32 c     Written:  06/06/79 by Paul E. Smee
  33 c
  34 c     Modified:
  35 c     ========================================
  36 
  37       character*4 function version (i)
  38 
  39       version = "1"
  40       return
  41       end
  42 %options ckmpy, round;
  43 c     ========================================
  44 c     function to perform compile-time FORTRAN math resulting in integer value,
  45 c     and rounded conversions to integer
  46 c
  47 c     Written:  06/06/79 by Paul E. Smee
  48 c
  49 c     Modified:
  50 c              Jan 1, 84: Return error code -3 if an overflow is encountered
  51 c                   when converting from real or dp to integer.
  52 c     ========================================
  53 
  54       function to_i_round (i_dum)
  55 
  56       integer to_i_round
  57       integer conv_r_to_i_round, conv_dp_to_i_round, conv_cp_to_i_round, binop_i_i_round
  58 
  59       integer i_dum, i1, i2
  60       real r0
  61       double precision d0
  62       complex c0
  63       integer op_id
  64       integer error_code_1, error_code_2
  65 
  66       entry conv_r_to_i_round (r0, error_code_1)
  67           if (r0 .ge. 34359738368d0) then
  68                error_code_1 = -3
  69                to_i_round = 34359738367
  70                goto 9999
  71           endif
  72           if (r0 .le. -34359738368d0) then
  73                error_code_1 = -3
  74                to_i_round = -34359738367
  75                goto 9999
  76           endif
  77           to_i_round = r0
  78           goto 9999
  79 
  80       entry conv_dp_to_i_round (d0, error_code_1)
  81           if (d0 .ge. 34359738368d0) then
  82                error_code_1 = -3
  83                to_i_round = 34359738367
  84                goto 9999
  85           endif
  86           if (d0 .le. -34359738368d0) then
  87                error_code_1 = -3
  88                to_i_round = -34359738367
  89                goto 9999
  90           endif
  91           to_i_round = d0
  92           goto 9999
  93 
  94       entry conv_cp_to_i_round (c0, error_code_1)
  95           to_i_round = c0
  96           goto 9999
  97 
  98       entry binop_i_i_round (op_id, i1, i2, error_code_2)
  99 
 100           goto (1010, 1020, 1030, 1040, 1050, 1060), op_id
 101 
 102 1010      to_i_round = i1 + i2
 103           goto 9999
 104 
 105 1020      to_i_round = i1 - i2
 106           goto 9999
 107 
 108 1030      to_i_round = i1 * i2
 109           goto 9999
 110 
 111 1040      to_i_round = i1 / i2
 112           goto 9999
 113 
 114 1050      to_i_round = i1 ** i2
 115           goto 9999
 116 
 117 1060      to_i_round = - i1
 118           goto 9999
 119 
 120 9999  continue
 121       return
 122       end
 123 %options ckmpy, truncate;
 124 c     ========================================
 125 c     function to perform compile-time FORTRAN math resulting in integer value,
 126 c     and truncd conversions to integer
 127 c
 128 c     Written:  06/27/79 by Paul E. Smee
 129 c
 130 c     Modified:
 131 c     ========================================
 132 
 133       function to_i_trunc (i_dum)
 134 
 135       integer to_i_trunc
 136       integer conv_r_to_i_trunc, conv_dp_to_i_trunc, conv_cp_to_i_trunc, binop_i_i_trunc
 137 
 138       integer i_dum, i1, i2
 139       real r0
 140       double precision d0
 141       complex c0
 142       integer op_id
 143       integer error_code_1, error_code_2
 144 
 145       entry conv_r_to_i_trunc (r0, error_code_1)
 146           to_i_trunc = r0
 147           goto 9999
 148 
 149       entry conv_dp_to_i_trunc (d0, error_code_1)
 150           to_i_trunc = d0
 151           goto 9999
 152 
 153       entry conv_cp_to_i_trunc (c0, error_code_1)
 154           to_i_trunc = c0
 155           goto 9999
 156 
 157       entry binop_i_i_trunc (op_id, i1, i2, error_code_2)
 158 
 159           goto (1010, 1020, 1030, 1040, 1050, 1060), op_id
 160 
 161 1010      to_i_trunc = i1 + i2
 162           goto 9999
 163 
 164 1020      to_i_trunc = i1 - i2
 165           goto 9999
 166 
 167 1030      to_i_trunc = i1 * i2
 168           goto 9999
 169 
 170 1040      to_i_trunc = i1 / i2
 171           goto 9999
 172 
 173 1050      to_i_trunc = i1 ** i2
 174           goto 9999
 175 
 176 1060      to_i_trunc = - i1
 177           goto 9999
 178 
 179 9999  continue
 180       return
 181       end
 182 %options round;
 183 c     ========================================
 184 c     function to perform compile-time FORTRAN math resulting in real values, rounded
 185 c
 186 c     Written:  06/06/79 by Paul E. Smee
 187 c
 188 c     Modified:
 189 c     ========================================
 190 
 191       function to_r_round (r_dum)
 192 
 193       real to_r_round
 194       real conv_i_to_r_round, conv_dp_to_r_round, conv_cp_to_r_round
 195       real binop_r_i_round, binop_r_r_round, binop_i_r_round
 196 
 197       integer i0, i1, i2
 198       real r_dum, r1, r2
 199       double precision d0
 200       complex c0
 201       integer op_id
 202       integer error_code_1, error_code_2
 203 
 204       entry conv_i_to_r_round (i0, error_code_1)
 205           to_r_round = i0
 206           goto 9999
 207 
 208       entry conv_dp_to_r_round (d0, error_code_1)
 209           to_r_round = d0
 210           goto 9999
 211 
 212       entry conv_cp_to_r_round (c0, error_code_1)
 213           to_r_round = c0
 214           goto 9999
 215 
 216       entry binop_r_i_round (op_id, r1, i2, error_code_2)
 217 
 218           goto (1010, 1020, 1030, 1040, 1050), op_id
 219 
 220 1010      to_r_round = r1 + i2
 221           goto 9999
 222 
 223 1020      to_r_round = r1 - i2
 224           goto 9999
 225 
 226 1030      to_r_round = r1 * i2
 227           goto 9999
 228 
 229 1040      to_r_round = r1 / i2
 230           goto 9999
 231 
 232 1050      to_r_round = r1 ** i2
 233           goto 9999
 234 
 235       entry binop_r_r_round (op_id, r1, r2, error_code_2)
 236 
 237           goto (2010, 2020, 2030, 2040, 2050, 2060), op_id
 238 
 239 2010      to_r_round = r1 + r2
 240           goto 9999
 241 
 242 2020      to_r_round = r1 - r2
 243           goto 9999
 244 
 245 2030      to_r_round = r1 * r2
 246           goto 9999
 247 
 248 2040      to_r_round = r1 / r2
 249           goto 9999
 250 
 251 2050      to_r_round = r1 ** r2
 252           goto 9999
 253 
 254 2060      to_r_round = - r1
 255           goto 9999
 256 
 257       entry binop_i_r_round (op_id, i1, r2, error_code_2)
 258 
 259           goto (3010, 3020, 3030, 3040, 3050), op_id
 260 
 261 3010      to_r_round = i1 + r2
 262           goto 9999
 263 
 264 3020      to_r_round = i1 - r2
 265           goto 9999
 266 
 267 3030      to_r_round = i1 * r2
 268           goto 9999
 269 
 270 3040      to_r_round = i1 / r2
 271           goto 9999
 272 
 273 3050      to_r_round = i1 ** r2
 274           goto 9999
 275 
 276 9999  continue
 277       return
 278       end
 279 %options truncate;
 280 c     ========================================
 281 c     function to perform compile-time FORTRAN math resulting in real values, truncd
 282 c
 283 c     Written:  06/06/79 by Paul E. Smee
 284 c
 285 c     Modified:
 286 c     ========================================
 287 
 288       function to_r_trunc (r_dum)
 289 
 290       real to_r_trunc
 291       real conv_i_to_r_trunc, conv_dp_to_r_trunc, conv_cp_to_r_trunc
 292       real binop_r_i_trunc, binop_r_r_trunc, binop_i_r_trunc
 293 
 294       integer i0, i1, i2
 295       real r_dum, r1, r2
 296       double precision d0
 297       complex c0
 298       integer op_id
 299       integer error_code_1, error_code_2
 300 
 301       entry conv_i_to_r_trunc (i0, error_code_1)
 302           to_r_trunc = i0
 303           goto 9999
 304 
 305       entry conv_dp_to_r_trunc (d0, error_code_1)
 306           to_r_trunc = d0
 307           goto 9999
 308 
 309       entry conv_cp_to_r_trunc (c0, error_code_1)
 310           to_r_trunc = c0
 311           goto 9999
 312 
 313       entry binop_r_i_trunc (op_id, r1, i2, error_code_2)
 314 
 315           goto (1010, 1020, 1030, 1040, 1050), op_id
 316 
 317 1010      to_r_trunc = r1 + i2
 318           goto 9999
 319 
 320 1020      to_r_trunc = r1 - i2
 321           goto 9999
 322 
 323 1030      to_r_trunc = r1 * i2
 324           goto 9999
 325 
 326 1040      to_r_trunc = r1 / i2
 327           goto 9999
 328 
 329 1050      to_r_trunc = r1 ** i2
 330           goto 9999
 331 
 332       entry binop_r_r_trunc (op_id, r1, r2, error_code_2)
 333 
 334           goto (2010, 2020, 2030, 2040, 2050, 2060), op_id
 335 
 336 2010      to_r_trunc = r1 + r2
 337           goto 9999
 338 
 339 2020      to_r_trunc = r1 - r2
 340           goto 9999
 341 
 342 2030      to_r_trunc = r1 * r2
 343           goto 9999
 344 
 345 2040      to_r_trunc = r1 / r2
 346           goto 9999
 347 
 348 2050      to_r_trunc = r1 ** r2
 349           goto 9999
 350 
 351 2060      to_r_trunc = - r1
 352           goto 9999
 353 
 354       entry binop_i_r_trunc (op_id, i1, r2, error_code_2)
 355 
 356           goto (3010, 3020, 3030, 3040, 3050), op_id
 357 
 358 3010      to_r_trunc = i1 + r2
 359           goto 9999
 360 
 361 3020      to_r_trunc = i1 - r2
 362           goto 9999
 363 
 364 3030      to_r_trunc = i1 * r2
 365           goto 9999
 366 
 367 3040      to_r_trunc = i1 / r2
 368           goto 9999
 369 
 370 3050      to_r_trunc = i1 ** r2
 371           goto 9999
 372 
 373 9999  continue
 374       return
 375       end
 376 %options round;
 377 c     ========================================
 378 c     function to perform compile-time FORTRAN math resulting in dp values, rounded
 379 c
 380 c     Written:  06/06/79 by Paul E. Smee
 381 c
 382 c     Modified:
 383 c     ========================================
 384 
 385       function to_dp_round (d_dum)
 386 
 387       double precision to_dp_round
 388       double precision conv_i_to_dp_round, conv_r_to_dp_round, conv_cp_to_dp_round
 389       double precision binop_dp_i_round, binop_dp_r_round, binop_dp_dp_round
 390       double precision binop_r_dp_round, binop_i_dp_round
 391 
 392       integer i0, i1, i2
 393       real r0, r1, r2
 394       double precision d_dum, d1, d2
 395       complex c0
 396       integer op_id
 397       integer error_code_1, error_code_2
 398 
 399       entry conv_i_to_dp_round (i0, error_code_1)
 400           to_dp_round = i0
 401           goto 9999
 402 
 403       entry conv_r_to_dp_round (r0, error_code_1)
 404           to_dp_round = r0
 405           goto 9999
 406 
 407       entry conv_cp_to_dp_round (c0, error_code_1)
 408           to_dp_round = c0
 409           goto 9999
 410 
 411       entry binop_dp_i_round (op_id, d1, i2, error_code_2)
 412 
 413           goto (1010, 1020, 1030, 1040, 1050), op_id
 414 
 415 1010      to_dp_round = d1 + i2
 416           goto 9999
 417 
 418 1020      to_dp_round = d1 - i2
 419           goto 9999
 420 
 421 1030      to_dp_round = d1 * i2
 422           goto 9999
 423 
 424 1040      to_dp_round = d1 / i2
 425           goto 9999
 426 
 427 1050      to_dp_round = d1 ** i2
 428           goto 9999
 429 
 430       entry binop_dp_r_round (op_id, d1, r2, error_code_2)
 431 
 432           goto (2010, 2020, 2030, 2040, 2050), op_id
 433 
 434 2010      to_dp_round = d1 + r2
 435           goto 9999
 436 
 437 2020      to_dp_round = d1 - r2
 438           goto 9999
 439 
 440 2030      to_dp_round = d1 * r2
 441           goto 9999
 442 
 443 2040      to_dp_round = d1 / r2
 444           goto 9999
 445 
 446 2050      to_dp_round = d1 ** r2
 447           goto 9999
 448 
 449       entry binop_dp_dp_round (op_id, d1, d2, error_code_2)
 450 
 451           goto (3010, 3020, 3030, 3040, 3050, 3060), op_id
 452 
 453 3010      to_dp_round = d1 + d2
 454           goto 9999
 455 
 456 3020      to_dp_round = d1 - d2
 457           goto 9999
 458 
 459 3030      to_dp_round = d1 * d2
 460           goto 9999
 461 
 462 3040      to_dp_round = d1 / d2
 463           goto 9999
 464 
 465 3050      to_dp_round = d1 ** d2
 466           goto 9999
 467 
 468 3060      to_dp_round = - d1
 469           goto 9999
 470 
 471       entry binop_r_dp_round (op_id, r1, d2, error_code_2)
 472 
 473           goto (4010, 4020, 4030, 4040, 4050), op_id
 474 
 475 4010      to_dp_round = r1 + d2
 476           goto 9999
 477 
 478 4020      to_dp_round = r1 - d2
 479           goto 9999
 480 
 481 4030      to_dp_round = r1 * d2
 482           goto 9999
 483 
 484 4040      to_dp_round = r1 / d2
 485           goto 9999
 486 
 487 4050      to_dp_round = r1 ** d2
 488           goto 9999
 489 
 490       entry binop_i_dp_round (op_id, i1, d2, error_code_2)
 491 
 492           goto (5010, 5020, 5030, 5040, 5050), op_id
 493 
 494 5010      to_dp_round = i1 + d2
 495           goto 9999
 496 
 497 5020      to_dp_round = i1 - d2
 498           goto 9999
 499 
 500 5030      to_dp_round = i1 * d2
 501           goto 9999
 502 
 503 5040      to_dp_round = i1 / d2
 504           goto 9999
 505 
 506 5050      to_dp_round = i1 ** d2
 507           goto 9999
 508 
 509 9999  continue
 510       return
 511       end
 512 %options truncate;
 513 c     ========================================
 514 c     function to perform compile-time FORTRAN math resulting in dp values, truncd
 515 c
 516 c     Written:  06/06/79 by Paul E. Smee
 517 c
 518 c     Modified:
 519 c     ========================================
 520 
 521       function to_dp_trunc (d_dum)
 522 
 523       double precision to_dp_trunc
 524       double precision conv_i_to_dp_trunc, conv_r_to_dp_trunc, conv_cp_to_dp_trunc
 525       double precision binop_dp_i_trunc, binop_dp_r_trunc, binop_dp_dp_trunc
 526       double precision binop_r_dp_trunc, binop_i_dp_trunc
 527 
 528       integer i0, i1, i2
 529       real r0, r1, r2
 530       double precision d_dum, d1, d2
 531       complex c0
 532       integer op_id
 533       integer error_code_1, error_code_2
 534 
 535       entry conv_i_to_dp_trunc (i0, error_code_1)
 536           to_dp_trunc = i0
 537           goto 9999
 538 
 539       entry conv_r_to_dp_trunc (r0, error_code_1)
 540           to_dp_trunc = r0
 541           goto 9999
 542 
 543       entry conv_cp_to_dp_trunc (c0, error_code_1)
 544           to_dp_trunc = c0
 545           goto 9999
 546 
 547       entry binop_dp_i_trunc (op_id, d1, i2, error_code_2)
 548 
 549           goto (1010, 1020, 1030, 1040, 1050), op_id
 550 
 551 1010      to_dp_trunc = d1 + i2
 552           goto 9999
 553 
 554 1020      to_dp_trunc = d1 - i2
 555           goto 9999
 556 
 557 1030      to_dp_trunc = d1 * i2
 558           goto 9999
 559 
 560 1040      to_dp_trunc = d1 / i2
 561           goto 9999
 562 
 563 1050      to_dp_trunc = d1 ** i2
 564           goto 9999
 565 
 566       entry binop_dp_r_trunc (op_id, d1, r2, error_code_2)
 567 
 568           goto (2010, 2020, 2030, 2040, 2050), op_id
 569 
 570 2010      to_dp_trunc = d1 + r2
 571           goto 9999
 572 
 573 2020      to_dp_trunc = d1 - r2
 574           goto 9999
 575 
 576 2030      to_dp_trunc = d1 * r2
 577           goto 9999
 578 
 579 2040      to_dp_trunc = d1 / r2
 580           goto 9999
 581 
 582 2050      to_dp_trunc = d1 ** r2
 583           goto 9999
 584 
 585       entry binop_dp_dp_trunc (op_id, d1, d2, error_code_2)
 586 
 587           goto (3010, 3020, 3030, 3040, 3050, 3060), op_id
 588 
 589 3010      to_dp_trunc = d1 + d2
 590           goto 9999
 591 
 592 3020      to_dp_trunc = d1 - d2
 593           goto 9999
 594 
 595 3030      to_dp_trunc = d1 * d2
 596           goto 9999
 597 
 598 3040      to_dp_trunc = d1 / d2
 599           goto 9999
 600 
 601 3050      to_dp_trunc = d1 ** d2
 602           goto 9999
 603 
 604 3060      to_dp_trunc = - d1
 605           goto 9999
 606 
 607       entry binop_r_dp_trunc (op_id, r1, d2, error_code_2)
 608 
 609           goto (4010, 4020, 4030, 4040, 4050), op_id
 610 
 611 4010      to_dp_trunc = r1 + d2
 612           goto 9999
 613 
 614 4020      to_dp_trunc = r1 - d2
 615           goto 9999
 616 
 617 4030      to_dp_trunc = r1 * d2
 618           goto 9999
 619 
 620 4040      to_dp_trunc = r1 / d2
 621           goto 9999
 622 
 623 4050      to_dp_trunc = r1 ** d2
 624           goto 9999
 625 
 626       entry binop_i_dp_trunc (op_id, i1, d2, error_code_2)
 627 
 628           goto (5010, 5020, 5030, 5040, 5050), op_id
 629 
 630 5010      to_dp_trunc = i1 + d2
 631           goto 9999
 632 
 633 5020      to_dp_trunc = i1 - d2
 634           goto 9999
 635 
 636 5030      to_dp_trunc = i1 * d2
 637           goto 9999
 638 
 639 5040      to_dp_trunc = i1 / d2
 640           goto 9999
 641 
 642 5050      to_dp_trunc = i1 ** d2
 643           goto 9999
 644 
 645 9999  continue
 646       return
 647       end
 648 %options round;
 649 c     ========================================
 650 c     function to perform compile-time FORTRAN math resulting in complex value, rounded
 651 c
 652 c     Written:  06/07/79 by Paul E. Smee
 653 c
 654 c     Modified:
 655 c     ========================================
 656 
 657       function to_cp_round (c_dum)
 658 
 659       complex to_cp_round
 660       complex conv_i_to_cp_round, conv_r_to_cp_round, conv_dp_to_cp_round
 661       complex binop_cp_i_round, binop_cp_r_round, binop_cp_dp_round
 662       complex binop_cp_cp_round, binop_dp_cp_round, binop_r_cp_round
 663       complex binop_i_cp_round
 664 
 665       integer i0, i1, i2
 666       real r0, r1, r2
 667       double precision d0, d1, d2
 668       complex c_dum, c1, c2
 669       integer op_id
 670       integer error_code_1, error_code_2
 671 
 672       entry conv_i_to_cp_round (i0, error_code_1)
 673           to_cp_round = i0
 674           goto 9999
 675 
 676       entry conv_r_to_cp_round (r0, error_code_1)
 677           to_cp_round = r0
 678           goto 9999
 679 
 680       entry conv_dp_to_cp_round (d0, error_code_1)
 681           to_cp_round = d0
 682           goto 9999
 683 
 684       entry binop_cp_i_round (op_id, c1, i2, error_code_2)
 685 
 686           goto (1010, 1020, 1030, 1040, 1050), op_id
 687 
 688 1010      to_cp_round = c1 + i2
 689           goto 9999
 690 
 691 1020      to_cp_round = c1 - i2
 692           goto 9999
 693 
 694 1030      to_cp_round = c1 * i2
 695           goto 9999
 696 
 697 1040      to_cp_round = c1 / i2
 698           goto 9999
 699 
 700 1050      to_cp_round = c1 ** i2
 701           goto 9999
 702 
 703       entry binop_cp_r_round (op_id, c1, r2, error_code_2)
 704 
 705           goto (2010, 2020, 2030, 2040, 2050), op_id
 706 
 707 2010      to_cp_round = c1 + r2
 708           goto 9999
 709 
 710 2020      to_cp_round = c1 - r2
 711           goto 9999
 712 
 713 2030      to_cp_round = c1 * r2
 714           goto 9999
 715 
 716 2040      to_cp_round = c1 / r2
 717           goto 9999
 718 
 719 2050      to_cp_round = c1 ** r2
 720           goto 9999
 721 
 722       entry binop_cp_dp_round (op_id, c1, d2, error_code_2)
 723 
 724           goto (3010, 3020, 3030, 3040, 3050), op_id
 725 
 726 3010      to_cp_round = c1 + d2
 727           goto 9999
 728 
 729 3020      to_cp_round = c1 - d2
 730           goto 9999
 731 
 732 3030      to_cp_round = c1 * d2
 733           goto 9999
 734 
 735 3040      to_cp_round = c1 / d2
 736           goto 9999
 737 
 738 3050      to_cp_round = c1 ** d2
 739           goto 9999
 740 
 741       entry binop_cp_cp_round (op_id, c1, c2, error_code_2)
 742 
 743           goto (4010, 4020, 4030, 4040, 4050, 4060), op_id
 744 
 745 4010      to_cp_round = c1 + c2
 746           goto 9999
 747 
 748 4020      to_cp_round = c1 - c2
 749           goto 9999
 750 
 751 4030      to_cp_round = c1 * c2
 752           goto 9999
 753 
 754 4040      to_cp_round = c1 / c2
 755           goto 9999
 756 
 757 4050      to_cp_round = c1 ** c2
 758           goto 9999
 759 
 760 4060      to_cp_round = - c1
 761           goto 9999
 762 
 763       entry binop_dp_cp_round (op_id, d1, c2, error_code_2)
 764 
 765           goto (5010, 5020, 5030, 5040, 5050), op_id
 766 
 767 5010      to_cp_round = d1 + c2
 768           goto 9999
 769 
 770 5020      to_cp_round = d1 - c2
 771           goto 9999
 772 
 773 5030      to_cp_round = d1 * c2
 774           goto 9999
 775 
 776 5040      to_cp_round = d1 / c2
 777           goto 9999
 778 
 779 5050      to_cp_round = d1 ** c2
 780           goto 9999
 781 
 782       entry binop_r_cp_round (op_id, r1, c2, error_code_2)
 783 
 784           goto (6010, 6020, 6030, 6040, 6050), op_id
 785 
 786 6010      to_cp_round = r1 + c2
 787           goto 9999
 788 
 789 6020      to_cp_round = r1 - c2
 790           goto 9999
 791 
 792 6030      to_cp_round = r1 * c2
 793           goto 9999
 794 
 795 6040      to_cp_round = r1 / c2
 796           goto 9999
 797 
 798 6050      to_cp_round = r1 ** c2
 799           goto 9999
 800 
 801       entry binop_i_cp_round (op_id, i1, c2, error_code_2)
 802 
 803           goto (7010, 7020, 7030, 7040, 7050), op_id
 804 
 805 7010      to_cp_round = i1 + c2
 806           goto 9999
 807 
 808 7020      to_cp_round = i1 - c2
 809           goto 9999
 810 
 811 7030      to_cp_round = i1 * c2
 812           goto 9999
 813 
 814 7040      to_cp_round = i1 / c2
 815           goto 9999
 816 
 817 7050      to_cp_round = i1 ** c2
 818           goto 9999
 819 
 820 9999  continue
 821       return
 822       end
 823 %options truncate;
 824 c     ========================================
 825 c     function to perform compile-time FORTRAN math resulting in complex value, truncd
 826 c
 827 c     Written:  06/07/79 by Paul E. Smee
 828 c
 829 c     Modified:
 830 c     ========================================
 831 
 832       function to_cp_trunc (c_dum)
 833 
 834       complex to_cp_trunc
 835       complex conv_i_to_cp_trunc, conv_r_to_cp_trunc, conv_dp_to_cp_trunc
 836       complex binop_cp_i_trunc, binop_cp_r_trunc, binop_cp_dp_trunc
 837       complex binop_cp_cp_trunc, binop_dp_cp_trunc, binop_r_cp_trunc
 838       complex binop_i_cp_trunc
 839 
 840       integer i0, i1, i2
 841       real r0, r1, r2
 842       double precision d0, d1, d2
 843       complex c_dum, c1, c2
 844       integer op_id
 845       integer error_code_1, error_code_2
 846 
 847       entry conv_i_to_cp_trunc (i0, error_code_1)
 848           to_cp_trunc = i0
 849           goto 9999
 850 
 851       entry conv_r_to_cp_trunc (r0, error_code_1)
 852           to_cp_trunc = r0
 853           goto 9999
 854 
 855       entry conv_dp_to_cp_trunc (d0, error_code_1)
 856           to_cp_trunc = d0
 857           goto 9999
 858 
 859       entry binop_cp_i_trunc (op_id, c1, i2, error_code_2)
 860 
 861           goto (1010, 1020, 1030, 1040, 1050), op_id
 862 
 863 1010      to_cp_trunc = c1 + i2
 864           goto 9999
 865 
 866 1020      to_cp_trunc = c1 - i2
 867           goto 9999
 868 
 869 1030      to_cp_trunc = c1 * i2
 870           goto 9999
 871 
 872 1040      to_cp_trunc = c1 / i2
 873           goto 9999
 874 
 875 1050      to_cp_trunc = c1 ** i2
 876           goto 9999
 877 
 878       entry binop_cp_r_trunc (op_id, c1, r2, error_code_2)
 879 
 880           goto (2010, 2020, 2030, 2040, 2050), op_id
 881 
 882 2010      to_cp_trunc = c1 + r2
 883           goto 9999
 884 
 885 2020      to_cp_trunc = c1 - r2
 886           goto 9999
 887 
 888 2030      to_cp_trunc = c1 * r2
 889           goto 9999
 890 
 891 2040      to_cp_trunc = c1 / r2
 892           goto 9999
 893 
 894 2050      to_cp_trunc = c1 ** r2
 895           goto 9999
 896 
 897       entry binop_cp_dp_trunc (op_id, c1, d2, error_code_2)
 898 
 899           goto (3010, 3020, 3030, 3040, 3050), op_id
 900 
 901 3010      to_cp_trunc = c1 + d2
 902           goto 9999
 903 
 904 3020      to_cp_trunc = c1 - d2
 905           goto 9999
 906 
 907 3030      to_cp_trunc = c1 * d2
 908           goto 9999
 909 
 910 3040      to_cp_trunc = c1 / d2
 911           goto 9999
 912 
 913 3050      to_cp_trunc = c1 ** d2
 914           goto 9999
 915 
 916       entry binop_cp_cp_trunc (op_id, c1, c2, error_code_2)
 917 
 918           goto (4010, 4020, 4030, 4040, 4050, 4060), op_id
 919 
 920 4010      to_cp_trunc = c1 + c2
 921           goto 9999
 922 
 923 4020      to_cp_trunc = c1 - c2
 924           goto 9999
 925 
 926 4030      to_cp_trunc = c1 * c2
 927           goto 9999
 928 
 929 4040      to_cp_trunc = c1 / c2
 930           goto 9999
 931 
 932 4050      to_cp_trunc = c1 ** c2
 933           goto 9999
 934 
 935 4060      to_cp_trunc = - c1
 936           goto 9999
 937 
 938       entry binop_dp_cp_trunc (op_id, d1, c2, error_code_2)
 939 
 940           goto (5010, 5020, 5030, 5040, 5050), op_id
 941 
 942 5010      to_cp_trunc = d1 + c2
 943           goto 9999
 944 
 945 5020      to_cp_trunc = d1 - c2
 946           goto 9999
 947 
 948 5030      to_cp_trunc = d1 * c2
 949           goto 9999
 950 
 951 5040      to_cp_trunc = d1 / c2
 952           goto 9999
 953 
 954 5050      to_cp_trunc = d1 ** c2
 955           goto 9999
 956 
 957       entry binop_r_cp_trunc (op_id, r1, c2, error_code_2)
 958 
 959           goto (6010, 6020, 6030, 6040, 6050), op_id
 960 
 961 6010      to_cp_trunc = r1 + c2
 962           goto 9999
 963 
 964 6020      to_cp_trunc = r1 - c2
 965           goto 9999
 966 
 967 6030      to_cp_trunc = r1 * c2
 968           goto 9999
 969 
 970 6040      to_cp_trunc = r1 / c2
 971           goto 9999
 972 
 973 6050      to_cp_trunc = r1 ** c2
 974           goto 9999
 975 
 976       entry binop_i_cp_trunc (op_id, i1, c2, error_code_2)
 977 
 978           goto (7010, 7020, 7030, 7040, 7050), op_id
 979 
 980 7010      to_cp_trunc = i1 + c2
 981           goto 9999
 982 
 983 7020      to_cp_trunc = i1 - c2
 984           goto 9999
 985 
 986 7030      to_cp_trunc = i1 * c2
 987           goto 9999
 988 
 989 7040      to_cp_trunc = i1 / c2
 990           goto 9999
 991 
 992 7050      to_cp_trunc = i1 ** c2
 993           goto 9999
 994 
 995 9999  continue
 996       return
 997       end
 998 %options round;
 999 c     ========================================
1000 c     function to perform compile-time FORTRAN comparisons
1001 c
1002 c     Written:  06/25/79 by Paul E. Smee
1003 c
1004 c     Modified:
1005 c     ========================================
1006 
1007       function to_log (l_dum)
1008 
1009       logical to_log
1010       logical comp_i_i, comp_i_r, comp_i_dp
1011       logical comp_r_i, comp_r_r, comp_r_dp
1012       logical comp_dp_i, comp_dp_r, comp_dp_dp
1013       logical comp_cp_cp, comp_lg_lg, comp_ch_ch
1014 
1015       integer i1, i2
1016       real r1, r2
1017       double precision d1, d2
1018       complex c1, c2
1019       logical l_dum, l1, l2
1020       character*8 ch1, ch2
1021       integer op_id
1022       integer error_code_1, error_code_2
1023 
1024       entry comp_i_i (op_id, i1, i2, error_code_2)
1025 
1026           goto (110, 120, 130, 140, 150, 160), op_id - 7
1027 
1028 110       to_log = i1 .lt. i2
1029           goto 9999
1030 
1031 120       to_log = i1 .le.i2
1032           goto 9999
1033 
1034 130       to_log = i1 .eq. i2
1035           goto 9999
1036 
1037 140       to_log = i1 .ne. i2
1038           goto 9999
1039 
1040 150       to_log = i1 .ge. i2
1041           goto 9999
1042 
1043 160       to_log = i1 .gt. i2
1044           goto 9999
1045 
1046       entry comp_i_r (op_id, i1, r2, error_code_2)
1047 
1048           goto (210, 220, 230, 240, 250, 260), op_id - 7
1049 
1050 210       to_log = i1 .lt. r2
1051           goto 9999
1052 
1053 220       to_log = i1 .le. r2
1054           goto 9999
1055 
1056 230       to_log = i1 .eq. r2
1057           goto 9999
1058 
1059 240       to_log = i1 .ne. r2
1060           goto 9999
1061 
1062 250       to_log = i1 .ge. r2
1063           goto 9999
1064 
1065 260       to_log = i1 .gt. r2
1066           goto 9999
1067 
1068       entry comp_i_dp (op_id, i1, d2, error_code_2)
1069 
1070           goto (310, 320, 330, 340, 350, 360), op_id - 7
1071 
1072 310       to_log = i1 .lt. d2
1073           goto 9999
1074 
1075 320       to_log = i1 .le. d2
1076           goto 9999
1077 
1078 330       to_log = i1 .eq. d2
1079           goto 9999
1080 
1081 340       to_log = i1 .ne. d2
1082           goto 9999
1083 
1084 350       to_log = i1 .ge. d2
1085           goto 9999
1086 
1087 360       to_log = i1 .gt. d2
1088           goto 9999
1089 
1090       entry comp_r_i (op_id, r1, i2, error_code_2)
1091 
1092           goto (510, 520, 530, 540, 550, 560), op_id - 7
1093 
1094 510       to_log = r1 .lt. i2
1095           goto 9999
1096 
1097 520       to_log = r1 .le. i2
1098           goto 9999
1099 
1100 530       to_log = r1 .eq. i2
1101           goto 9999
1102 
1103 540       to_log = r1 .ne. i2
1104           goto 9999
1105 
1106 550       to_log = r1 .ge. i2
1107           goto 9999
1108 
1109 560       to_log = r1 .gt. i2
1110           goto 9999
1111 
1112       entry comp_r_r (op_id, r1, r2, error_code_2)
1113 
1114           goto (610, 620, 630, 640, 650, 660), op_id - 7
1115 
1116 610       to_log = r1 .lt. r2
1117           goto 9999
1118 
1119 620       to_log = r1 .le. r2
1120           goto 9999
1121 
1122 630       to_log = r1 .eq. r2
1123           goto 9999
1124 
1125 640       to_log = r1 .ne. r2
1126           goto 9999
1127 
1128 650       to_log = r1 .ge. r2
1129           goto 9999
1130 
1131 660       to_log = r1 .gt. r2
1132           goto 9999
1133 
1134       entry comp_r_dp (op_id, r1, d2, error_code_2)
1135 
1136           goto (710, 720, 730, 740, 750, 760), op_id - 7
1137 
1138 710       to_log = r1 .lt. d2
1139           goto 9999
1140 
1141 720       to_log = r1 .le. d2
1142           goto 9999
1143 
1144 730       to_log = r1 .eq. d2
1145           goto 9999
1146 
1147 740       to_log = r1 .ne. d2
1148           goto 9999
1149 
1150 750       to_log = r1 .ge. d2
1151           goto 9999
1152 
1153 760       to_log = r1 .gt. d2
1154           goto 9999
1155 
1156       entry comp_dp_i (op_id, d1, i2, error_code_2)
1157 
1158           goto (910, 920, 930, 940, 950, 960), op_id - 7
1159 
1160 910       to_log = d1 .lt. i2
1161           goto 9999
1162 
1163 920       to_log = d1 .le. i2
1164           goto 9999
1165 
1166 930       to_log = d1 .eq. i2
1167           goto 9999
1168 
1169 940       to_log = d1 .ne. i2
1170           goto 9999
1171 
1172 950       to_log = d1 .ge. i2
1173           goto 9999
1174 
1175 960       to_log = d1 .gt. i2
1176           goto 9999
1177 
1178       entry comp_dp_r (op_id, d1, r2, error_code_2)
1179 
1180           goto (1010, 1020, 1030, 1040, 1050, 1060), op_id - 7
1181 
1182 1010      to_log = d1 .lt. r2
1183           goto 9999
1184 
1185 1020      to_log = d1 .le. r2
1186           goto 9999
1187 
1188 1030      to_log = d1 .eq. r2
1189           goto 9999
1190 
1191 1040      to_log = d1 .ne. r2
1192           goto 9999
1193 
1194 1050      to_log = d1 .ge. r2
1195           goto 9999
1196 
1197 1060      to_log = d1 .gt. r2
1198           goto 9999
1199 
1200       entry comp_dp_dp (op_id, d1, d2, error_code_2)
1201 
1202           goto (1110, 1120, 1130, 1140, 1150, 1160), op_id - 7
1203 
1204 1110      to_log = d1 .lt. d2
1205           goto 9999
1206 
1207 1120      to_log = d1 .le. d2
1208           goto 9999
1209 
1210 1130      to_log = d1 .eq. d2
1211           goto 9999
1212 
1213 1140      to_log = d1 .ne. d2
1214           goto 9999
1215 
1216 1150      to_log = d1 .ge. d2
1217           goto 9999
1218 
1219 1160      to_log = d1 .gt. d2
1220           goto 9999
1221 
1222       entry comp_cp_cp (op_id, c1, c2, error_code_2)
1223 
1224           goto (1630, 1640), op_id - 9
1225 
1226           error_code_2 = - 1
1227           goto 9999
1228 
1229 1630      to_log = c1 .eq. c2
1230           goto 9999
1231 
1232 1640      to_log = c1 .ne. c2
1233           goto 9999
1234 
1235       entry comp_lg_lg (op_id, l1, l2, error_code_2)
1236 
1237           goto (2530, 2540), op_id - 9
1238 
1239           error_code_2 = - 1
1240           goto 9999
1241 
1242 2530      to_log = l1 .eq. l2
1243           goto 9999
1244 
1245 2540      to_log = l1 .ne. l2
1246           goto 9999
1247 
1248       entry comp_ch_ch (op_id, ch1, ch2, error_code_2)
1249 
1250           goto (3610, 3620, 3630, 3640, 3650, 3660), op_id - 7
1251 
1252 3610      to_log = ch1 .lt. ch2
1253           goto 9999
1254 
1255 3620      to_log = ch1 .le. ch2
1256           goto 9999
1257 
1258 3630      to_log = ch1 .eq. ch2
1259           goto 9999
1260 
1261 3640      to_log = ch1 .ne. ch2
1262           goto 9999
1263 
1264 3650      to_log = ch1 .ge. ch2
1265           goto 9999
1266 
1267 3660      to_log = ch1 .gt. ch2
1268           goto 9999
1269 
1270 9999  continue
1271       return
1272       end
1273 %options truncate;
1274 c     ========================================
1275 c     Miscellaneous "do-nothing" entries
1276 c
1277 c     Written:  06/29/79 by Paul E. Smee
1278 c
1279 c     Modified:
1280 c     ========================================
1281 
1282       function misc_ops (ch_dum)
1283 
1284       character*8 misc_ops
1285       character*8 bad_data_types, binop_ch_ch, binop_lg_lg
1286       character*8 binop_no_op, unary_no_op, conv_ch_to_ch
1287       character*8 unary_bad_data
1288 
1289       character*8 ch0, ch1, ch2, ch_dum
1290       integer op_id
1291       integer error_code_1, error_code_2
1292 
1293       entry bad_data_types (op_id, ch1, ch2, error_code_2)
1294 
1295           error_code_2 = -1
1296           misc_ops = ch1
1297 
1298       return
1299 
1300       entry unary_bad_data (ch0, error_code_1)
1301 
1302           error_code_1 = -1
1303           misc_ops = ch0
1304 
1305       return
1306 
1307       entry binop_ch_ch (op_id, ch1, ch2, error_code_2)
1308 
1309           error_code_2 = -2
1310           misc_ops = ch1
1311 
1312       return
1313 
1314       entry binop_lg_lg (op_id, ch1, ch2, error_code_2)
1315 
1316           error_code_2 = -2
1317           misc_ops = ch1
1318 
1319       return
1320 
1321       entry binop_no_op (op_id, ch1, ch2, error_code_2)
1322 
1323           misc_ops = ch1
1324 
1325       return
1326 
1327       entry unary_no_op (ch0, error_code_1)
1328 
1329           misc_ops = ch0
1330 
1331       return
1332 
1333       entry conv_ch_to_ch (ch0, error_code_1)
1334 
1335           misc_ops = ch0
1336 
1337       return
1338       end