summaryrefslogtreecommitdiff
path: root/Ganlib/data/badluk_proc
diff options
context:
space:
mode:
Diffstat (limited to 'Ganlib/data/badluk_proc')
-rw-r--r--Ganlib/data/badluk_proc/bessj0.c2m44
-rw-r--r--Ganlib/data/badluk_proc/fact.c2m19
-rw-r--r--Ganlib/data/badluk_proc/flmoon.c2m56
-rw-r--r--Ganlib/data/badluk_proc/julday.c2m43
-rw-r--r--Ganlib/data/badluk_proc/xbessj0.c2m35
-rw-r--r--Ganlib/data/badluk_proc/xclecst.c2m110
-rw-r--r--Ganlib/data/badluk_proc/xfact.c2m14
-rw-r--r--Ganlib/data/badluk_proc/xjulday.c2m76
-rw-r--r--Ganlib/data/badluk_proc/xmachar.c2m326
9 files changed, 723 insertions, 0 deletions
diff --git a/Ganlib/data/badluk_proc/bessj0.c2m b/Ganlib/data/badluk_proc/bessj0.c2m
new file mode 100644
index 0000000..e0d0595
--- /dev/null
+++ b/Ganlib/data/badluk_proc/bessj0.c2m
@@ -0,0 +1,44 @@
+ ! "bessj0" function that returns the Bessel function J0(x) for any real x
+ !
+ !
+ ! REFERENCE: "Numerical recipes in FORTRAN,
+ ! The Art of Scientific Computing, Second Edition"
+ ! Press, Teukolsky, Vetterling, Flannery
+ ! Cambridge University Press
+ ! ISBN 0-521-43064-X
+ ! PAGES: 225 ("FUNCTION bessj0")
+ !
+ ! INPUT: "x" the input argument (REAL)
+ ! OUTPUT: "bessj0" is the value of J0(x) (REAL)
+
+ REAL bessj0 x ;
+ REAL ax xx z ;
+ DOUBLE p1 p2 p3 p4 p5 := 1.D0 -.1098628627D-2 .2734510407D-4
+ -.2073370639D-5 .2093887211D-6 ;
+ DOUBLE q1 q2 q3 q4 q5 := -.1562499995D-1 .1430488765D-3 -.6911147651D-5
+ .7621095161D-6 -.934945152D-7 ;
+ DOUBLE r1 r2 r3 r4 r5 r6 := 57568490574.D0 -13362590354.D0
+ 651619640.7D0 -11214424.18D0 77392.33017D0 -184.9052456D0 ;
+ DOUBLE s1 s2 s3 s4 s5 s6 := 57568490411.D0 1029532985.D0
+ 9494680.718D0 59272.64853D0 267.8532712D0 1.D0 ;
+ DOUBLE y ;
+
+ :: >>x<< ;
+ IF x ABS 8. < THEN
+ EVALUATE y := x x * R_TO_D ;
+ EVALUATE bessj0 := r6 y * r5 + y * r4 + y * r3 + y * r2 + y * r1 +
+ s6 y * s5 + y * s4 + y * s3 + y * s2 + y * s1 + /
+ D_TO_R ;
+ ELSE
+ EVALUATE ax := x ABS ;
+ EVALUATE z xx := 8. ax / ax .785398164 - ;
+ EVALUATE y := z z * R_TO_D ;
+ EVALUATE bessj0 := p5 y * p4 + y * p3 + y * p2 + y * p1 +
+ xx COS R_TO_D *
+ q5 y * q4 + y * q3 + y * q2 + y * q1 +
+ xx SIN z * R_TO_D * -
+ .636619772 ax / SQRT R_TO_D *
+ D_TO_R ;
+ ENDIF ;
+ :: <<bessj0>> ;
+ QUIT " Function *bessj0* XREF " .
diff --git a/Ganlib/data/badluk_proc/fact.c2m b/Ganlib/data/badluk_proc/fact.c2m
new file mode 100644
index 0000000..45a6dfd
--- /dev/null
+++ b/Ganlib/data/badluk_proc/fact.c2m
@@ -0,0 +1,19 @@
+ !
+ ! Example of a recursive procedure.
+ !
+ ! input to "fact": *n*
+ ! output from "fact": *n_fact*
+ !
+ INTEGER n n_fact prev_fact ;
+ :: >>n<< ;
+ IF n 1 = THEN
+ EVALUATE n_fact := 1 ;
+ ELSE
+ EVALUATE n := n 1 - ;
+ ! Here, "fact" calls itself
+ PROCEDURE fact ;
+ fact :: <<n>> >>prev_fact<< ;
+ EVALUATE n_fact := n 1 + prev_fact * ;
+ ENDIF ;
+ :: <<n_fact>> ;
+ QUIT " Recursive procedure *fact* XREF " .
diff --git a/Ganlib/data/badluk_proc/flmoon.c2m b/Ganlib/data/badluk_proc/flmoon.c2m
new file mode 100644
index 0000000..b4fec40
--- /dev/null
+++ b/Ganlib/data/badluk_proc/flmoon.c2m
@@ -0,0 +1,56 @@
+ ! "flmoon" function to compute the phases of the moon
+ !
+ ! REFERENCE: "Numerical recipes in FORTRAN,
+ ! The Art of Scientific Computing, Second Edition"
+ ! Press, Teukolsky, Vetterling, Flannery
+ ! Cambridge University Press
+ ! ISBN 0-521-43064-X
+ ! PAGES: 1-2 ("SUBROUTINE flmoon")
+ !
+ ! INPUT: "n" the n-th such phase since January, 1900
+ ! "nph" the phase desired
+ ! 0: new moon
+ ! 1: first quarter
+ ! 2: full moon
+ ! 3: last quarter
+ ! OUTPUT: "jd" the Julian day number
+ ! "frac" the fractional part of day to be added to it
+
+ INTEGER jd n nph ;
+ REAL frac ;
+
+ REAL RAD := $Pi_R 180. / ; ! NOTE: $Pi_R is a parametric constant
+ INTEGER i ;
+ REAL am as c t t2 xtra ;
+
+ :: >>n<< >>nph<< ;
+
+ EVALUATE c := n I_TO_R nph I_TO_R 4. / + ;
+ EVALUATE t := c 1236.85 / ;
+ EVALUATE t2 := t t * ;
+ EVALUATE as := 359.2242 29.105356 c * + ;
+ EVALUATE am := 306.0253 385.816918 c * 0.010730 t2 * + + ;
+ EVALUATE jd := 2415020 28 n * 7 nph * + + ;
+ EVALUATE xtra := 0.75933 1.53058868 c * +
+ 1.178E-4 1.55E-7 t * - t2 * + ;
+ IF nph 0 = nph 2 = + THEN
+ EVALUATE xtra := xtra
+ 0.1734 3.93E-4 t * - RAD as * SIN *
+ 0.4068 RAD am * SIN * - + ;
+ ELSEIF nph 1 = nph 3 = + THEN
+ EVALUATE xtra := xtra
+ 0.1721 4.E-4 t * - RAD as * SIN *
+ 0.6280 RAD am * SIN * - + ;
+ ELSE
+ ECHO "*nph* is unknown in *flmoon*" ;
+ ENDIF ;
+ IF xtra 0. >= THEN
+ EVALUATE i := xtra R_TO_I ;
+ ELSE
+ EVALUATE i := xtra 1. - R_TO_I ;
+ ENDIF ;
+ EVALUATE jd := jd i + ;
+ EVALUATE frac := xtra i I_TO_R - ;
+
+ :: <<jd>> <<frac>> ;
+ QUIT " Routine *flmoon* XREF " .
diff --git a/Ganlib/data/badluk_proc/julday.c2m b/Ganlib/data/badluk_proc/julday.c2m
new file mode 100644
index 0000000..73b7516
--- /dev/null
+++ b/Ganlib/data/badluk_proc/julday.c2m
@@ -0,0 +1,43 @@
+ ! "julday" function to compute the Julian day number
+ !
+ ! REFERENCE: "Numerical recipes in FORTRAN,
+ ! The Art of Scientific Computing, Second Edition"
+ ! Press, Teukolsky, Vetterling, Flannery
+ ! Cambridge University Press
+ ! ISBN 0-521-43064-X
+ ! PAGES: 13 ("FUNCTION julday")
+ !
+ ! INPUT: "mm" the month
+ ! "id" the day
+ ! "iyyy" the year
+ ! OUTPUT: "julday" the Julian day number
+
+ INTEGER mm id iyyy ;
+ INTEGER julday ;
+
+ ! Gregorian calendar was adopted October 15, 1582
+ INTEGER IGREG := 1582 12 * 10 + 31 * 15 + ;
+ INTEGER ja jm jy ;
+
+ :: >>mm<< >>id<< >>iyyy<< ;
+
+ EVALUATE jy := iyyy ;
+ IF jy 0 = THEN ECHO "There is no year 0" ;
+ ELSEIF jy 0 < THEN EVALUATE jy := jy 1 + ;
+ ENDIF ;
+ IF mm 2 > THEN EVALUATE jm := mm 1 + ;
+ ELSE EVALUATE jy jm := jy 1 - mm 13 + ;
+ ENDIF ;
+
+ EVALUATE julday := jy I_TO_R 365.25 * R_TO_I
+ jm I_TO_R 30.6001 * R_TO_I
+ + id + 1720995 + ;
+
+ IF iyyy 12 * mm + 31 * id + IGREG >= THEN
+ EVALUATE ja := jy I_TO_R 0.01 * R_TO_I ;
+ EVALUATE julday := julday 2 + ja - ja I_TO_R 0.25 * R_TO_I + ;
+ ENDIF ;
+
+ :: <<julday>> ;
+
+ QUIT " Function *julday* XREF " .
diff --git a/Ganlib/data/badluk_proc/xbessj0.c2m b/Ganlib/data/badluk_proc/xbessj0.c2m
new file mode 100644
index 0000000..4730a2b
--- /dev/null
+++ b/Ganlib/data/badluk_proc/xbessj0.c2m
@@ -0,0 +1,35 @@
+ ! driver for testing function * bessj0*
+
+ REAL bm5 bm4 bm3 bm2 bm1
+ b00 b01 b02 b03 b04
+ b05 b06 b07 b08 b09
+ b10 b11 b12 b13 b14
+ b15 :=
+ -0.1775968 -0.3971498 -0.2600520 0.2238908 0.7651976
+ 1.0000000 0.7651977 0.2238908 -0.2600520 -0.3971498
+ -0.1775968 0.1506453 0.3000793 0.1716508 -0.0903336
+ -0.2459358 -0.1711903 0.0476893 0.2069261 0.1710735
+ -0.0142245 ;
+ REAL x := -5.0 ;
+ REAL y ;
+ PROCEDURE bessj0 ;
+ ECHO "Bessel Function J0" ;
+
+ WHILE x 16. < DO
+ IF x 0. <> THEN
+ bessj0 :: <<x>> >>y<< ;
+ ECHO "x=" x "bessj0(x)=" y "reference=" bm5 ;
+ ENDIF ;
+ EVALUATE x := x 1. + ;
+ EVALUATE bm5 bm4 bm3 bm2 bm1
+ b00 b01 b02 b03 b04
+ b05 b06 b07 b08 b09
+ b10 b11 b12 b13 b14
+ b15 :=
+ bm4 bm3 bm2 bm1
+ b00 b01 b02 b03 b04
+ b05 b06 b07 b08 b09
+ b10 b11 b12 b13 b14
+ b15 bm5 ;
+ ENDWHILE ;
+ QUIT " Program *xbessj0* XREF " .
diff --git a/Ganlib/data/badluk_proc/xclecst.c2m b/Ganlib/data/badluk_proc/xclecst.c2m
new file mode 100644
index 0000000..32d1c23
--- /dev/null
+++ b/Ganlib/data/badluk_proc/xclecst.c2m
@@ -0,0 +1,110 @@
+ !
+ ! Describes the parametric constant package provided with the source.
+ ! Author: R. Roy
+ ! Date: Dec 13, 1999
+ !
+ ECHO "" ;
+ ECHO "Constants given in Example *CLECST* of"
+ $Code_S "Release" $Release_S ;
+ ECHO "" ;
+ ECHO "1) Integer constants:" ;
+ ECHO " $Version_I =" $Version_I ;
+ ECHO " $XLangLvl_I =" $XLangLvl_I ;
+ ECHO " $c0_I =" $c0_I ;
+ ECHO " $Date_I =" $Date_I ;
+ ECHO " $Time_I =" $Time_I ;
+ ECHO " $True_I =" $True_I ;
+ ECHO " $False_I =" $False_I ;
+ ECHO "" ;
+ ECHO "2) Real constants:" ;
+ ECHO " $Pi_R =" $Pi_R ;
+ ECHO " $E_R =" $E_R ;
+ ECHO " $Euler_R =" $Euler_R ;
+ ECHO " $c0_R =" $c0_R ;
+ ECHO " $Na_R =" $Na_R ;
+ ECHO " $u_R =" $u_R ;
+ ECHO " $eV_R =" $eV_R ;
+ ECHO " $h_R =" $h_R ;
+ ECHO "" ;
+ ECHO "3) String constants:" ;
+ ECHO " $Code_S =" $Code_S ;
+ ECHO " $Release_S =" $Release_S ;
+ ECHO " $XLang_S =" $XLang_S ;
+ ECHO " $Date_S =" $Date_S ;
+ ECHO " $Time_S =" $Time_S ;
+ ECHO " $Bang_S =" $Bang_S ;
+ ECHO " $GetIn_S =" $GetIn_S ;
+ ECHO " $GetOut_S =" $GetOut_S ;
+ ECHO "" ;
+ ECHO "4) Double constants:" ;
+ ECHO " $Pi_D =" $Pi_D ;
+ ECHO " $E_D =" $E_D ;
+ ECHO " $Euler_D =" $Euler_D ;
+ ECHO " $c0_D =" $c0_D ;
+ ECHO " $Na_D =" $Na_D ;
+ ECHO " $u_D =" $u_D ;
+ ECHO " $eV_D =" $eV_D ;
+ ECHO " $h_D =" $h_D ;
+ ECHO "" ;
+ ECHO "5) Logical constants:" ;
+ ECHO " $True_L =" $True_L ;
+ ECHO " $False_L =" $False_L ;
+ ECHO "" ;
+ !
+ IF $XLangLvl_I 77 = THEN
+ ECHO "Fortran-77:" ;
+ ECHO "$Date_S is hard-coded as:" $Date_S ;
+ ECHO "$Time_S is hard-coded as:" $Time_S ;
+ ECHO " Time is generic:" ;
+ ELSEIF $XLangLvl_I 90 = THEN
+ ECHO "Fortran-90:" ;
+ ECHO "$Date_S gives today-s ISO compilation date:" $Date_S ;
+ ECHO "$Time_S gives hhmmss ISO compilation time:" $Time_S ;
+ ECHO " Time *stamp* is:" ;
+ ENDIF ;
+ !
+ INTEGER yyyy_MM_dd := $Date_I ;
+ INTEGER yyyy_MM := yyyy_MM_dd 100 / ;
+ INTEGER yyyy := yyyy_MM 100 / ;
+ INTEGER MM := yyyy_MM yyyy 100 * - ;
+ INTEGER dd := yyyy_MM_dd yyyy_MM 100 * - ;
+ INTEGER hhmmss_sss := $Time_I ;
+ INTEGER hhmm := hhmmss_sss 100 / ;
+ INTEGER hh := hhmm 100 / ;
+ INTEGER mm := hhmm hh 100 * - ;
+ INTEGER ss := hhmmss_sss hhmm 100 * - ;
+ !
+ IF MM 1 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Jan" dd "," yyyy ;
+ IF yyyy 2000 = dd 1 = + THEN
+ ECHO " Have we solved all Y2K problems ?" ;
+ ENDIF ;
+ ELSEIF MM 2 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Feb" dd "," yyyy ;
+ ELSEIF MM 3 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Mar" dd "," yyyy ;
+ ELSEIF MM 4 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Apr" dd "," yyyy ;
+ ELSEIF MM 5 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on May" dd "," yyyy ;
+ ELSEIF MM 6 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Jun" dd "," yyyy ;
+ ELSEIF MM 7 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Jul" dd "," yyyy ;
+ ELSEIF MM 8 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Aug" dd "," yyyy ;
+ ELSEIF MM 9 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Sep" dd "," yyyy ;
+ ELSEIF MM 10 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Oct" dd "," yyyy ;
+ ELSEIF MM 11 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Nov" dd "," yyyy ;
+ ELSEIF MM 12 = THEN
+ ECHO " (" hh ":" mm ":" ss ") on Dec" dd "," yyyy ;
+ IF dd 21 = THEN
+ ECHO " " yyyy 1953 - "years old " $Bang_S + ;
+ ECHO " *HAPPY BIRTHDAY* to Robert " $Bang_S + ;
+ ENDIF ;
+ ENDIF ;
+ ECHO "" ;
+ QUIT " Program *xclecst* " .
diff --git a/Ganlib/data/badluk_proc/xfact.c2m b/Ganlib/data/badluk_proc/xfact.c2m
new file mode 100644
index 0000000..0b68171
--- /dev/null
+++ b/Ganlib/data/badluk_proc/xfact.c2m
@@ -0,0 +1,14 @@
+*
+* Calling the recursive "fact" procedure:
+*
+* input to "fact": *n*
+* output from "fact": *n_fact*
+*
+* use to compute n!
+*
+ PROCEDURE fact ;
+ INTEGER n := 8 ;
+ INTEGER n_fact ;
+ fact :: <<n>> >>n_fact<< ;
+ ECHO "FACTORIAL:" n $Bang_S "=" + n_fact ;
+ QUIT " Program *xfact* XREF " .
diff --git a/Ganlib/data/badluk_proc/xjulday.c2m b/Ganlib/data/badluk_proc/xjulday.c2m
new file mode 100644
index 0000000..b5cf44b
--- /dev/null
+++ b/Ganlib/data/badluk_proc/xjulday.c2m
@@ -0,0 +1,76 @@
+ ! driver for testing function *julday*
+
+ INTEGER im id iy julday ;
+ INTEGER i n := 1 16 ;
+ INTEGER m01 d01 y01
+ m02 d02 y02
+ m03 d03 y03
+ m04 d04 y04
+ m05 d05 y05
+ m06 d06 y06
+ m07 d07 y07
+ m08 d08 y08
+ m09 d09 y09
+ m10 d10 y10
+ m11 d11 y11
+ m12 d12 y12
+ m13 d13 y13
+ m14 d14 y14
+ m15 d15 y15
+ m16 d16 y16 :=
+ 12 31 -1
+ 01 01 1
+ 10 14 1582
+ 10 15 1582
+ 01 17 1706
+ 04 14 1865
+ 04 18 1906
+ 05 07 1915
+ 07 20 1923
+ 05 23 1934
+ 07 22 1934
+ 04 03 1936
+ 05 06 1937
+ 07 26 1956
+ 06 05 1976
+ 05 23 1968 ;
+ STRING
+ s01 s02 s03 s04 s05 s06 s07 s08 s09 s10 s11 s12 s13 s14 s15 s16 :=
+ "End of millennium"
+ "One day later"
+ "Day before Gregorian calendar"
+ "Gregorian calendar adopted"
+ "Benjamin Franklin born"
+ "Abraham Lincoln shot"
+ "San Francisco earthquake"
+ "Sinking of the Lusitania"
+ "Pancho Villa assassinated"
+ "Bonnie and Clyde eliminated"
+ "John Dillinger shot"
+ "Bruno Hauptman electrocuted"
+ "Hindenburg disaster"
+ "Sinking of the Andrea Doria"
+ "Teton dam collapse"
+ "Julian Day 2440000" ;
+ PROCEDURE julday ;
+ WHILE i n <= DO
+ EVALUATE im id iy := m01 d01 y01 ;
+ julday :: <<im>> <<id>> <<iy>> >>julday<< ;
+ ECHO "Date=" im id iy "Julday=" julday "Remark=" s01 ;
+
+ EVALUATE
+ d01 d02 d03 d04 d05 d06 d07 d08 d09 d10 d11 d12 d13 d14 d15 d16 :=
+ d02 d03 d04 d05 d06 d07 d08 d09 d10 d11 d12 d13 d14 d15 d16 d01 ;
+ EVALUATE
+ m01 m02 m03 m04 m05 m06 m07 m08 m09 m10 m11 m12 m13 m14 m15 m16 :=
+ m02 m03 m04 m05 m06 m07 m08 m09 m10 m11 m12 m13 m14 m15 m16 m01 ;
+ EVALUATE
+ y01 y02 y03 y04 y05 y06 y07 y08 y09 y10 y11 y12 y13 y14 y15 y16 :=
+ y02 y03 y04 y05 y06 y07 y08 y09 y10 y11 y12 y13 y14 y15 y16 y01 ;
+ EVALUATE
+ s01 s02 s03 s04 s05 s06 s07 s08 s09 s10 s11 s12 s13 s14 s15 s16 :=
+ s02 s03 s04 s05 s06 s07 s08 s09 s10 s11 s12 s13 s14 s15 s16 s01 ;
+ EVALUATE i := i 1 + ;
+ ENDWHILE ;
+
+ QUIT " Program *xjulday* XREF " .
diff --git a/Ganlib/data/badluk_proc/xmachar.c2m b/Ganlib/data/badluk_proc/xmachar.c2m
new file mode 100644
index 0000000..f35e71d
--- /dev/null
+++ b/Ganlib/data/badluk_proc/xmachar.c2m
@@ -0,0 +1,326 @@
+ ! "xmachar" program to check IEEE compliance of your machine
+ !
+ ! REFERENCE: "Numerical recipes in FORTRAN,
+ ! The Art of Scientific Computing, Second Edition"
+ ! Press, Teukolsky, Vetterling, Flannery
+ ! Cambridge University Press
+ ! ISBN 0-521-43064-X
+ ! PAGES: 881-886 (similar to "SUBROUTINE machar")
+ !
+
+ INTEGER ibeta_R iexp_R irnd_R it_R machep_R
+ maxexp_R minexp_R negep_R ngrd_R ;
+ REAL eps_R epsneg_R xmax_R xmin_R ;
+
+ INTEGER ibeta_D iexp_D irnd_D it_D machep_D
+ maxexp_D minexp_D negep_D ngrd_D ;
+ DOUBLE eps_D epsneg_D xmax_D xmin_D ;
+
+ REAL a_R b_R beta_R betah_R betain_R one_R t_R
+ temp_R temp1_R tempa_R two_R y_R z_R zero_R ;
+ DOUBLE a_D b_D beta_D betah_D betain_D one_D t_D
+ temp_D temp1_D tempa_D two_D y_D z_D zero_D ;
+ INTEGER i itemp iz j k mx nxres ;
+ LOGICAL LFLAG ;
+
+ ! "machar" routine for single precision
+ EVALUATE one_R := 1 I_TO_R ;
+ EVALUATE two_R zero_R a_R := one_R one_R + one_R one_R - one_R ;
+ REPEAT
+ EVALUATE a_R := a_R a_R + ;
+ EVALUATE temp_R := a_R one_R + ;
+ EVALUATE temp1_R := temp_R a_R - ;
+ UNTIL temp1_R one_R - zero_R <> ;
+ EVALUATE b_R := one_R ;
+ REPEAT
+ EVALUATE b_R := b_R b_R + ;
+ EVALUATE temp_R := a_R b_R + ;
+ EVALUATE itemp := temp_R a_R - R_TO_I ;
+ UNTIL itemp 0 <> ;
+ EVALUATE ibeta_R beta_R := itemp itemp I_TO_R ;
+ EVALUATE it_R b_R := 0 one_R ;
+ REPEAT
+ EVALUATE it_R := it_R 1 + ;
+ EVALUATE b_R := b_R beta_R * ;
+ EVALUATE temp_R := b_R one_R + ;
+ EVALUATE temp1_R := temp_R b_R - ;
+ UNTIL temp1_R one_R - zero_R <> ;
+ EVALUATE irnd_R := 0 ;
+ EVALUATE betah_R := beta_R two_R / ;
+ EVALUATE temp_R := a_R betah_R + ;
+ IF temp_R a_R - zero_R <> THEN
+ EVALUATE irnd_R := 1 ;
+ ENDIF ;
+ EVALUATE tempa_R := a_R beta_R + ;
+ EVALUATE temp_R := tempa_R betah_R + ;
+ IF irnd_R 0 = temp_R tempa_R - zero_R <> * THEN
+ EVALUATE irnd_R := 2 ;
+ ENDIF ;
+ EVALUATE negep_R := it_R 3 + ;
+ EVALUATE betain_R a_R := one_R beta_R / one_R ;
+ EVALUATE i := 1 ;
+ WHILE i negep_R <= DO
+ EVALUATE a_R i := a_R betain_R * i 1 + ;
+ ENDWHILE ;
+ EVALUATE b_R temp_R := a_R one_R a_R - ;
+ WHILE temp_R one_R - zero_R = DO
+ EVALUATE a_R negep_R := a_R beta_R * negep_R 1 - ;
+ EVALUATE temp_R := one_R a_R - ;
+ ENDWHILE ;
+ EVALUATE negep_R epsneg_R machep_R := negep_R CHS a_R it_R 3 + CHS ;
+ EVALUATE a_R := b_R ;
+ EVALUATE temp_R := one_R a_R + ;
+ WHILE temp_R one_R - zero_R = DO
+ EVALUATE a_R machep_R := a_R beta_R * machep_R 1 + ;
+ EVALUATE temp_R := one_R a_R + ;
+ ENDWHILE ;
+ EVALUATE eps_R := a_R ;
+ EVALUATE ngrd_R temp_R := 0 one_R eps_R + ;
+ IF irnd_R 0 = temp_R one_R * one_R - zero_R <> * THEN
+ EVALUATE ngrd_R := 1 ;
+ ENDIF ;
+ EVALUATE i k z_R t_R nxres := 0 1 betain_R one_R eps_R + 0 ;
+ EVALUATE y_R := z_R ;
+ EVALUATE z_R := y_R y_R * ;
+ EVALUATE a_R temp_R := z_R one_R * z_R t_R * ;
+ EVALUATE LFLAG := $True_L ;
+ WHILE a_R a_R + zero_R <> z_R ABS y_R < * LFLAG * DO
+ EVALUATE temp1_R := temp_R betain_R * ;
+ IF temp1_R beta_R * z_R = THEN
+ EVALUATE LFLAG := $False_L ;
+ ELSE
+ EVALUATE i k := i 1 + k k + ;
+ EVALUATE y_R := z_R ;
+ EVALUATE z_R := y_R y_R * ;
+ EVALUATE a_R temp_R := z_R one_R * z_R t_R * ;
+ ENDIF ;
+ ENDWHILE ;
+ IF ibeta_R 10 <> THEN
+ EVALUATE iexp_R mx := i 1 + k k + ;
+ ELSE
+ EVALUATE iexp_R iz := 2 ibeta_R ;
+ WHILE k iz >= DO
+ EVALUATE iz iexp_R := iz ibeta_R * iexp_R 1 + ;
+ ENDWHILE ;
+ EVALUATE mx := iz iz + 1 - ;
+ ENDIF ;
+ EVALUATE xmin_R := y_R ;
+ EVALUATE y_R := y_R betain_R * ;
+ EVALUATE a_R := y_R one_R * ;
+ EVALUATE temp_R := y_R t_R * ;
+ EVALUATE LFLAG := $True_L ;
+ WHILE a_R a_R + zero_R <> y_R ABS xmin_R < * LFLAG * DO
+ EVALUATE k := k 1 + ;
+ EVALUATE temp1_R := temp_R betain_R * ;
+ IF temp1_R beta_R * y_R <> temp_R y_R = + THEN
+ EVALUATE xmin_R := y_R ;
+ EVALUATE y_R := y_R betain_R * ;
+ EVALUATE a_R := y_R one_R * ;
+ EVALUATE temp_R := y_R t_R * ;
+ ELSE
+ EVALUATE nxres xmin_R := 3 y_R ;
+ EVALUATE LFLAG := $False_L ;
+ ENDIF ;
+ ENDWHILE ;
+ EVALUATE minexp_R := k CHS ;
+ IF mx k k + 3 - <= ibeta_R 10 <> * THEN
+ EVALUATE mx iexp_R := mx mx + iexp_R 1 + ;
+ ENDIF ;
+ EVALUATE maxexp_R irnd_R := mx minexp_R + irnd_R nxres + ;
+ IF irnd_R 2 >= THEN
+ EVALUATE maxexp_R := maxexp_R 2 - ;
+ ENDIF ;
+ EVALUATE i := maxexp_R minexp_R + ;
+ IF ibeta_R 2 = i 0 = * THEN
+ EVALUATE maxexp_R := maxexp_R 1 - ;
+ ENDIF ;
+ IF i 20 > THEN
+ EVALUATE maxexp_R := maxexp_R 1 - ;
+ ENDIF ;
+ IF a_R y_R <> THEN
+ EVALUATE maxexp_R := maxexp_R 2 - ;
+ ENDIF ;
+ EVALUATE xmax_R := one_R epsneg_R - ;
+ IF xmax_R one_R * xmax_R <> THEN
+ EVALUATE xmax_R := one_R beta_R epsneg_R * - ;
+ ENDIF ;
+ EVALUATE xmax_R := xmax_R beta_R beta_R * beta_R * xmin_R * / ;
+ EVALUATE i := maxexp_R minexp_R + 3 + ;
+ EVALUATE j := 1 ;
+ WHILE j i <= DO
+ IF ibeta_R 2 = THEN
+ EVALUATE xmax_R := xmax_R xmax_R + ;
+ ELSE
+ EVALUATE xmax_R := xmax_R beta_R * ;
+ ENDIF ;
+ EVALUATE j := j 1 + ;
+ ENDWHILE ;
+
+ ! "machar" routine for double precision
+ EVALUATE one_D := 1 I_TO_D ;
+ EVALUATE two_D zero_D a_D := one_D one_D + one_D one_D - one_D ;
+ REPEAT
+ EVALUATE a_D := a_D a_D + ;
+ EVALUATE temp_D := a_D one_D + ;
+ EVALUATE temp1_D := temp_D a_D - ;
+ UNTIL temp1_D one_D - zero_D <> ;
+ EVALUATE b_D := one_D ;
+ REPEAT
+ EVALUATE b_D := b_D b_D + ;
+ EVALUATE temp_D := a_D b_D + ;
+ EVALUATE itemp := temp_D a_D - D_TO_I ;
+ UNTIL itemp 0 <> ;
+ EVALUATE ibeta_D beta_D := itemp itemp I_TO_D ;
+ EVALUATE it_D b_D := 0 one_D ;
+ REPEAT
+ EVALUATE it_D := it_D 1 + ;
+ EVALUATE b_D := b_D beta_D * ;
+ EVALUATE temp_D := b_D one_D + ;
+ EVALUATE temp1_D := temp_D b_D - ;
+ UNTIL temp1_D one_D - zero_D <> ;
+ EVALUATE irnd_D := 0 ;
+ EVALUATE betah_D := beta_D two_D / ;
+ EVALUATE temp_D := a_D betah_D + ;
+ IF temp_D a_D - zero_D <> THEN
+ EVALUATE irnd_D := 1 ;
+ ENDIF ;
+ EVALUATE tempa_D := a_D beta_D + ;
+ EVALUATE temp_D := tempa_D betah_D + ;
+ IF irnd_D 0 = temp_D tempa_D - zero_D <> * THEN
+ EVALUATE irnd_D := 2 ;
+ ENDIF ;
+ EVALUATE negep_D := it_D 3 + ;
+ EVALUATE betain_D a_D := one_D beta_D / one_D ;
+ EVALUATE i := 1 ;
+ WHILE i negep_D <= DO
+ EVALUATE a_D i := a_D betain_D * i 1 + ;
+ ENDWHILE ;
+ EVALUATE b_D temp_D := a_D one_D a_D - ;
+ WHILE temp_D one_D - zero_D = DO
+ EVALUATE a_D negep_D := a_D beta_D * negep_D 1 - ;
+ EVALUATE temp_D := one_D a_D - ;
+ ENDWHILE ;
+ EVALUATE negep_D epsneg_D machep_D := negep_D CHS a_D it_D 3 + CHS ;
+ EVALUATE a_D := b_D ;
+ EVALUATE temp_D := one_D a_D + ;
+ WHILE temp_D one_D - zero_D = DO
+ EVALUATE a_D machep_D := a_D beta_D * machep_D 1 + ;
+ EVALUATE temp_D := one_D a_D + ;
+ ENDWHILE ;
+ EVALUATE eps_D := a_D ;
+ EVALUATE ngrd_D temp_D := 0 one_D eps_D + ;
+ IF irnd_D 0 = temp_D one_D * one_D - zero_D <> * THEN
+ EVALUATE ngrd_D := 1 ;
+ ENDIF ;
+ EVALUATE i k z_D t_D nxres := 0 1 betain_D one_D eps_D + 0 ;
+ EVALUATE y_D := z_D ;
+ EVALUATE z_D := y_D y_D * ;
+ EVALUATE a_D temp_D := z_D one_D * z_D t_D * ;
+ EVALUATE LFLAG := $True_L ;
+ WHILE a_D a_D + zero_D <> z_D ABS y_D < * LFLAG * DO
+ EVALUATE temp1_D := temp_D betain_D * ;
+ IF temp1_D beta_D * z_D = THEN
+ EVALUATE LFLAG := $False_L ;
+ ELSE
+ EVALUATE i k := i 1 + k k + ;
+ EVALUATE y_D := z_D ;
+ EVALUATE z_D := y_D y_D * ;
+ EVALUATE a_D temp_D := z_D one_D * z_D t_D * ;
+ ENDIF ;
+ ENDWHILE ;
+ IF ibeta_D 10 <> THEN
+ EVALUATE iexp_D mx := i 1 + k k + ;
+ ELSE
+ EVALUATE iexp_D iz := 2 ibeta_D ;
+ WHILE k iz >= DO
+ EVALUATE iz iexp_D := iz ibeta_D * iexp_D 1 + ;
+ ENDWHILE ;
+ EVALUATE mx := iz iz + 1 - ;
+ ENDIF ;
+ EVALUATE xmin_D := y_D ;
+ EVALUATE y_D := y_D betain_D * ;
+ EVALUATE a_D := y_D one_D * ;
+ EVALUATE temp_D := y_D t_D * ;
+ EVALUATE LFLAG := $True_L ;
+ WHILE a_D a_D + zero_D <> y_D ABS xmin_D < * LFLAG * DO
+ EVALUATE k := k 1 + ;
+ EVALUATE temp1_D := temp_D betain_D * ;
+ IF temp1_D beta_D * y_D <> temp_D y_D = + THEN
+ EVALUATE xmin_D := y_D ;
+ EVALUATE y_D := y_D betain_D * ;
+ EVALUATE a_D := y_D one_D * ;
+ EVALUATE temp_D := y_D t_D * ;
+ ELSE
+ EVALUATE nxres xmin_D := 3 y_D ;
+ EVALUATE LFLAG := $False_L ;
+ ENDIF ;
+ ENDWHILE ;
+ EVALUATE minexp_D := k CHS ;
+ IF mx k k + 3 - <= ibeta_D 10 <> * THEN
+ EVALUATE mx iexp_D := mx mx + iexp_D 1 + ;
+ ENDIF ;
+ EVALUATE maxexp_D irnd_D := mx minexp_D + irnd_D nxres + ;
+ IF irnd_D 2 >= THEN
+ EVALUATE maxexp_D := maxexp_D 2 - ;
+ ENDIF ;
+ EVALUATE i := maxexp_D minexp_D + ;
+ IF ibeta_D 2 = i 0 = * THEN
+ EVALUATE maxexp_D := maxexp_D 1 - ;
+ ENDIF ;
+ IF i 20 > THEN
+ EVALUATE maxexp_D := maxexp_D 1 - ;
+ ENDIF ;
+ IF a_D y_D <> THEN
+ EVALUATE maxexp_D := maxexp_D 2 - ;
+ ENDIF ;
+ EVALUATE xmax_D := one_D epsneg_D - ;
+ IF xmax_D one_D * xmax_D <> THEN
+ EVALUATE xmax_D := one_D beta_D epsneg_D * - ;
+ ENDIF ;
+ EVALUATE xmax_D := xmax_D beta_D beta_D * beta_D * xmin_D * / ;
+ EVALUATE i := maxexp_D minexp_D + 3 + ;
+ EVALUATE j := 1 ;
+ WHILE j i <= DO
+ IF ibeta_D 2 = THEN
+ EVALUATE xmax_D := xmax_D xmax_D + ;
+ ELSE
+ EVALUATE xmax_D := xmax_D beta_D * ;
+ ENDIF ;
+ EVALUATE j := j 1 + ;
+ ENDWHILE ;
+
+ ECHO "*** Single precision machine parameters ***" ;
+ ECHO " " ;
+ ECHO "ibeta= " ibeta_R ;
+ ECHO "it= " it_R ;
+ ECHO "machep=" machep_R ;
+ ECHO "eps= " eps_R ;
+ ECHO "negep= " negep_R ;
+ ECHO "epsneg=" epsneg_R ;
+ ECHO "iexp= " iexp_R ;
+ ECHO "minexp=" minexp_R ;
+ ECHO "xmin= " xmin_R ;
+ ECHO "maxexp=" maxexp_R ;
+ ECHO "xmax= " xmax_R ;
+ ECHO "irnd= " irnd_R ;
+ ECHO "ngrd= " ngrd_R ;
+ ECHO " " ;
+ ECHO "*** Double precision machine parameters ***" ;
+ ECHO " " ;
+ ECHO "ibeta= " ibeta_D ;
+ ECHO "it= " it_D ;
+ ECHO "machep=" machep_D ;
+ ECHO "eps= " eps_D ;
+ ECHO "negep= " negep_D ;
+ ECHO "epsneg=" epsneg_D ;
+ ECHO "iexp= " iexp_D ;
+ ECHO "minexp=" minexp_D ;
+ ECHO "xmin= " xmin_D ;
+ ECHO "maxexp=" maxexp_D ;
+ ECHO "xmax= " xmax_D ;
+ ECHO "irnd= " irnd_D ;
+ ECHO "ngrd= " ngrd_D ;
+ ECHO " " ;
+ ECHO "QUESTION: Do you have a typical IEEE-compliant machine ?" ;
+
+ QUIT " Program *xmachar* " .
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 14:40:10 +0000