Initial commit from Polytechnique Montreal

10 files changed, 793 insertions, 0 deletions

diff --git a/Ganlib/data/testgan1_proc/badluk.c2m b/Ganlib/data/testgan1_proc/badluk.c2m
new file mode 100644
index 0000000..2bdb2e5
--- /dev/null
+++ b/Ganlib/data/testgan1_proc/badluk.c2m
@@ -0,0 +1,70 @@
+ ! "badluk" program to look for full moons on Friday the 13-th
+ !
+ !  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:  14 ("PROGRAM badluk")
+ 
+ INTEGER ic icon idwk ifrac im iyyy jd jday n ;
+ REAL    TIMZON := -5. 24. / ;  ! Time zone -5 is Eastern Standard Time
+ REAL    frac ;
+ INTEGER iybeg iyend := 1970 2000 ; ! Range to be searched
+ REAL    ifrac_R ;
+ LOGICAL LFLAG ;
+
+ PROCEDURE julday flmoon ;
+
+ ECHO "Full moons on Friday the 13th from" iybeg "to" iyend ;
+
+ EVALUATE iyyy := iybeg ;
+ WHILE iyyy iyend <= DO           ! Loop over each year
+   EVALUATE im := 1 ;
+   WHILE im 12 <= DO              ! Loop over each month
+     julday :: <<im>> 13 <<iyyy>> >>jday<< ; ! Call julday
+     EVALUATE idwk := jday 1 + jday 1 + 7 / 7 * - ;
+     IF idwk 5 = THEN             ! Is the 13-th a Friday
+       EVALUATE n := 12.37 iyyy I_TO_R 1900. -
+                           im   I_TO_R 0.5 - 12. / + * R_TO_I ;
+       EVALUATE LFLAG icon := $True_L 0 ;
+       WHILE LFLAG DO
+         flmoon :: <<n>> 2 >>jd<< >>frac<< ; ! Get date of full moon *n*
+         EVALUATE ifrac_R := frac TIMZON + 24. * ;
+         IF ifrac_R 0. >= THEN
+           EVALUATE ifrac_R := ifrac_R 0.5 + ;
+         ELSE
+           EVALUATE ifrac_R := ifrac_R 0.5 - ;
+         ENDIF ;
+         EVALUATE ifrac := ifrac_R R_TO_I ;
+         IF ifrac 0 < THEN
+           EVALUATE jd ifrac := jd 1 - ifrac 24 + ;
+         ENDIF ;
+         IF ifrac 12 > THEN
+           EVALUATE jd ifrac := jd 1 + ifrac 12 - ;
+         ELSE
+           EVALUATE    ifrac :=        ifrac 12 + ;
+         ENDIF ;
+         IF jd jday = THEN       ! Did we hit our target day ?
+           ECHO "Full moon" im "/13/" iyyy ":"
+           ifrac "hrs after midnight (EST)." ;
+           EVALUATE LFLAG := $False_L ;
+         ELSE                    ! Didn't hit it...
+           IF jday jd - 0 >= THEN
+             EVALUATE ic := +1 ;
+           ELSE
+             EVALUATE ic := -1 ;
+           ENDIF ;
+           IF ic icon CHS = THEN
+             EVALUATE LFLAG := $False_L ;
+           ELSE
+             EVALUATE icon n := ic n ic + ;
+           ENDIF ;
+         ENDIF ;
+       ENDWHILE ;
+     ENDIF ;
+     EVALUATE im := im 1 + ;
+   ENDWHILE ;
+   EVALUATE iyyy := iyyy 1 + ;
+ ENDWHILE ;
+ QUIT " Program *badluk* XREF " .
diff --git a/Ganlib/data/testgan1_proc/bessj0.c2m b/Ganlib/data/testgan1_proc/bessj0.c2m
new file mode 100644
index 0000000..e0d0595
--- /dev/null
+++ b/Ganlib/data/testgan1_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/testgan1_proc/fact.c2m b/Ganlib/data/testgan1_proc/fact.c2m
new file mode 100644
index 0000000..45a6dfd
--- /dev/null
+++ b/Ganlib/data/testgan1_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/testgan1_proc/flmoon.c2m b/Ganlib/data/testgan1_proc/flmoon.c2m
new file mode 100644
index 0000000..b4fec40
--- /dev/null
+++ b/Ganlib/data/testgan1_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/testgan1_proc/julday.c2m b/Ganlib/data/testgan1_proc/julday.c2m
new file mode 100644
index 0000000..73b7516
--- /dev/null
+++ b/Ganlib/data/testgan1_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/testgan1_proc/xbessj0.c2m b/Ganlib/data/testgan1_proc/xbessj0.c2m
new file mode 100644
index 0000000..4730a2b
--- /dev/null
+++ b/Ganlib/data/testgan1_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/testgan1_proc/xclecst.c2m b/Ganlib/data/testgan1_proc/xclecst.c2m
new file mode 100644
index 0000000..32d1c23
--- /dev/null
+++ b/Ganlib/data/testgan1_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/testgan1_proc/xfact.c2m b/Ganlib/data/testgan1_proc/xfact.c2m
new file mode 100644
index 0000000..0b68171
--- /dev/null
+++ b/Ganlib/data/testgan1_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/testgan1_proc/xjulday.c2m b/Ganlib/data/testgan1_proc/xjulday.c2m
new file mode 100644
index 0000000..b5cf44b
--- /dev/null
+++ b/Ganlib/data/testgan1_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/testgan1_proc/xmachar.c2m b/Ganlib/data/testgan1_proc/xmachar.c2m
new file mode 100644
index 0000000..f35e71d
--- /dev/null
+++ b/Ganlib/data/testgan1_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* " .