diff options
| author | stainer_t <thomas.stainer@oecd-nea.org> | 2025-09-08 13:48:49 +0200 |
|---|---|---|
| committer | stainer_t <thomas.stainer@oecd-nea.org> | 2025-09-08 13:48:49 +0200 |
| commit | 7dfcc480ba1e19bd3232349fc733caef94034292 (patch) | |
| tree | 03ee104eb8846d5cc1a981d267687a729185d3f3 /Ganlib/data | |
Initial commit from Polytechnique Montreal
Diffstat (limited to 'Ganlib/data')
49 files changed, 2162 insertions, 0 deletions
diff --git a/Ganlib/data/assertS.c2m b/Ganlib/data/assertS.c2m new file mode 100644 index 0000000..b5b6a58 --- /dev/null +++ b/Ganlib/data/assertS.c2m @@ -0,0 +1,36 @@ +* +* Assert procedure for non-regression testing +* Recover a value from a real array +* Author: A. Hebert +* +PARAMETER LCMNAM :: ::: LINKED_LIST LCMNAM ; ; +CHARACTER KEY ; +INTEGER ISET IPOS ; +REAL REFVALUE ; +:: >>KEY<< >>IPOS<< >>REFVALUE<< ; +INTEGER ITYLCM ; +REAL VALUE DELTA ; +DOUBLE PRECISION DVALUE ; +MODULE GREP: ABORT: END: ; +* +GREP: LCMNAM :: TYPE <<KEY>> >>ITYLCM<< ; +IF ITYLCM 2 = THEN + GREP: LCMNAM :: GETVAL <<KEY>> <<IPOS>> >>VALUE<< ; +ELSEIF ITYLCM 4 = THEN + GREP: LCMNAM :: GETVAL <<KEY>> <<IPOS>> >>DVALUE<< ; + EVALUATE VALUE := DVALUE D_TO_R ; +ELSE + PRINT "assertS: INVALID TYPE=" ITYLCM ; + ABORT: ; +ENDIF ; +EVALUATE DELTA := VALUE REFVALUE - REFVALUE / ABS ; +IF DELTA 5.0E-5 < THEN + PRINT "TEST SUCCESSFUL; DELTA=" DELTA ; +ELSE + PRINT "------------" ; + PRINT "TEST FAILURE" ; + PRINT "------------" ; + PRINT "REFERENCE=" REFVALUE " CALCULATED=" VALUE ; + ABORT: ; +ENDIF ; +END: ; diff --git a/Ganlib/data/badluk.x2m b/Ganlib/data/badluk.x2m new file mode 100644 index 0000000..2bdb2e5 --- /dev/null +++ b/Ganlib/data/badluk.x2m @@ -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/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* " . diff --git a/Ganlib/data/testgan1.x2m b/Ganlib/data/testgan1.x2m new file mode 100644 index 0000000..200dabb --- /dev/null +++ b/Ganlib/data/testgan1.x2m @@ -0,0 +1,12 @@ +* Regression tests for CLE-2000. +* R. Roy +* +PROCEDURE badluk xbessj0 xclecst xfact xjulday xmachar ; +* +badluk ; +xbessj0 ; +xclecst ; +xfact ; +xjulday ; +xmachar ; +QUIT "LIST" . 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* " . diff --git a/Ganlib/data/testgan2.access b/Ganlib/data/testgan2.access new file mode 100755 index 0000000..16f2570 --- /dev/null +++ b/Ganlib/data/testgan2.access @@ -0,0 +1,18 @@ +#!/bin/sh +if [ $# = 0 ] + then + echo "usage: TEST.access directory" 1>&2 + exit 1 +fi +System=`uname -s` +Sysx="`echo $System | cut -b -6`" +MACH=`uname -sm | sed 's/[ ]/_/'` +if [ $Sysx = "CYGWIN" ]; then + System=`uname -o` + MACH=$System +elif [ $Sysx = "AIX" ]; then + MACH=`uname -s` +fi +echo "System :" $System " MACH :" "$MACH" +ln -s $1/data/testgan2_proc/Macrolib . +ls diff --git a/Ganlib/data/testgan2.x2m b/Ganlib/data/testgan2.x2m new file mode 100644 index 0000000..4de50fa --- /dev/null +++ b/Ganlib/data/testgan2.x2m @@ -0,0 +1,22 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST TOTO FLUX MACRO GROUP ; +SEQ_ASCII Macrolib FLUX2 ; +MODULE DELETE: GREP: END: ; +PROCEDURE TESTproc assertS ; +REAL value ; +* +MACRO := Macrolib ; +GROUP := MACRO :: STEP UP GROUP STEP AT 1 ; +GREP: GROUP :: GETVAL NTOT0 2 >>value<< ; +ECHO "value=" value ; +* +FLUX2 := TESTproc MACRO :: 1.703945 ; +FLUX := FLUX2 :: EDIT 99 ; +FLUX2 := DELETE: FLUX2 ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +* +ECHO "test TEST completed" ; +END: ; +QUIT "XREF" . diff --git a/Ganlib/data/testgan2_proc/Macrolib b/Ganlib/data/testgan2_proc/Macrolib new file mode 100644 index 0000000..936c8c8 --- /dev/null +++ b/Ganlib/data/testgan2_proc/Macrolib @@ -0,0 +1,73 @@ +-> 1 12 10 2 <- +GROUP +-> 2 0 0 -1 <- 00000001 +-> 3 12 2 4 <- +NTOT0 + 3.01200002E-02 3.01200002E-02 2.91200001E-02 4.01600003E-02 +-> 3 12 2 4 <- +NUSIGF + 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 +-> 3 12 2 4 <- +DIFF + 1.89999998E+00 1.50000000E+00 1.50000000E+00 2.00000000E+00 +-> 3 12 2 4 <- +H-FACTOR + 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 +-> 3 12 2 4 <- +SCAT00 + 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 +-> 3 12 1 4 <- +IPOS00 + 1 2 3 4 +-> 3 12 1 4 <- +NJJS00 + 1 1 1 1 +-> 3 12 1 4 <- +IJJS00 + 1 1 1 1 +-> 3 12 2 4 <- +SIGW00 + 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 +-> -3 0 0 0 <- +-> 2 0 0 -1 <- 00000002 +-> 3 12 2 4 <- +NTOT0 + 8.30320120E-02 8.50319937E-02 1.26031995E-01 1.00240000E-02 +-> 3 12 2 4 <- +NUSIGF + 1.65000007E-01 1.35000005E-01 1.35000005E-01 0.00000000E+00 +-> 3 12 2 4 <- +DIFF + 4.39999998E-01 4.00000006E-01 4.00000006E-01 3.00000012E-01 +-> 3 12 2 4 <- +H-FACTOR + 1.65000007E-01 1.35000005E-01 1.35000005E-01 0.00000000E+00 +-> 3 12 2 8 <- +SCAT00 + 0.00000000E+00 1.99999996E-02 0.00000000E+00 1.99999996E-02 0.00000000E+00 + 1.99999996E-02 0.00000000E+00 3.99999991E-02 +-> 3 12 1 4 <- +IPOS00 + 1 3 5 7 +-> 3 12 1 4 <- +NJJS00 + 2 2 2 2 +-> 3 12 1 4 <- +IJJS00 + 2 2 2 2 +-> 3 12 2 4 <- +SIGW00 + 0.00000000E+00 0.00000000E+00 0.00000000E+00 0.00000000E+00 +-> -3 0 0 0 <- +-> 1 12 3 3 <- +SIGNATURE + 4 4 4 +L_MACROLIB +-> 1 12 1 40 <- +STATE-VECTOR + 2 4 1 1 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 +-> -1 0 0 0 <- diff --git a/Ganlib/data/testgan2_proc/TESTproc.c2m b/Ganlib/data/testgan2_proc/TESTproc.c2m new file mode 100644 index 0000000..ec89f58 --- /dev/null +++ b/Ganlib/data/testgan2_proc/TESTproc.c2m @@ -0,0 +1,37 @@ +* Library procedure +PARAMETER FLUX2 MACRO :: + EDIT 1 + ::: SEQ_ASCII FLUX2 ; + ::: LINKED_LIST MACRO ; + ; +REAL KEFF ; +:: >>KEFF<< +; +MODULE UTL: DELETE: ADD: END: ; +LINKED_LIST FLUX MACRO2 MACRO3 ; +SEQ_ASCII FLUX3 ; +PROCEDURE assertS ; +* +UTL: MACRO :: DIR ; +MACRO2 := MACRO ; +MACRO3 := MACRO ; +UTL: MACRO2 :: DIR ; +MACRO3 := ADD: MACRO3 MACRO2 ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'DOUBLE-INFO' 5 = 1.1D0 1.2D0 1.3D0 1.4D0 1.5D0 ; +MACRO3 := MACRO3 FLUX ; +UTL: MACRO3 :: DIR ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR DUMP ; +FLUX2 := FLUX ; +FLUX3 := FLUX ; +FLUX := UTL: FLUX :: ERAS ; ! erase the contents of object FLUX +FLUX := FLUX FLUX2 ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +FLUX := DELETE: FLUX ; +ECHO "procedure TESTproc completed" ; +* +END: ; +* +QUIT "XREF" . diff --git a/Ganlib/data/testgan3.x2m b/Ganlib/data/testgan3.x2m new file mode 100644 index 0000000..2b5c34b --- /dev/null +++ b/Ganlib/data/testgan3.x2m @@ -0,0 +1,28 @@ +* Regression tests based on Rowland's benchmarks with a Jef2.2 Draglib. +* Running time = ~ 10m +* A. Hebert +* +PROCEDURE uo2_1c_case1 uo2_1c_case2 uo2_1c_case3 uo2_1c_case4 + uo2_6c_case1 uo2_6c_case2 uo2_6c_case3 uo2_6c_case4 + uo2_6c_case5 mox_1c_case1 mox_1c_case2 mox_1c_case3 + mox_1c_case4 mox_6c_case1 mox_6c_case2 mox_6c_case3 + mox_6c_case4 mox_6c_case5 ; +uo2_1c_case1 ; +uo2_1c_case2 ; +uo2_1c_case3 ; +uo2_1c_case4 ; +uo2_6c_case1 ; +uo2_6c_case2 ; +uo2_6c_case3 ; +uo2_6c_case4 ; +uo2_6c_case5 ; +mox_1c_case1 ; +mox_1c_case2 ; +mox_1c_case3 ; +mox_1c_case4 ; +mox_6c_case1 ; +mox_6c_case2 ; +mox_6c_case3 ; +mox_6c_case4 ; +mox_6c_case5 ; +QUIT "XREF" . diff --git a/Ganlib/data/testgan3_proc/mox_1c_case1.c2m b/Ganlib/data/testgan3_proc/mox_1c_case1.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/mox_1c_case1.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/mox_1c_case2.c2m b/Ganlib/data/testgan3_proc/mox_1c_case2.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/mox_1c_case2.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/mox_1c_case3.c2m b/Ganlib/data/testgan3_proc/mox_1c_case3.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/mox_1c_case3.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/mox_1c_case4.c2m b/Ganlib/data/testgan3_proc/mox_1c_case4.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/mox_1c_case4.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/mox_6c_case1.c2m b/Ganlib/data/testgan3_proc/mox_6c_case1.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/mox_6c_case1.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/mox_6c_case2.c2m b/Ganlib/data/testgan3_proc/mox_6c_case2.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/mox_6c_case2.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/mox_6c_case3.c2m b/Ganlib/data/testgan3_proc/mox_6c_case3.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/mox_6c_case3.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/mox_6c_case4.c2m b/Ganlib/data/testgan3_proc/mox_6c_case4.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/mox_6c_case4.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/mox_6c_case5.c2m b/Ganlib/data/testgan3_proc/mox_6c_case5.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/mox_6c_case5.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/uo2_1c_case1.c2m b/Ganlib/data/testgan3_proc/uo2_1c_case1.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/uo2_1c_case1.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/uo2_1c_case2.c2m b/Ganlib/data/testgan3_proc/uo2_1c_case2.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/uo2_1c_case2.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/uo2_1c_case3.c2m b/Ganlib/data/testgan3_proc/uo2_1c_case3.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/uo2_1c_case3.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/uo2_1c_case4.c2m b/Ganlib/data/testgan3_proc/uo2_1c_case4.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/uo2_1c_case4.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/uo2_6c_case1.c2m b/Ganlib/data/testgan3_proc/uo2_6c_case1.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/uo2_6c_case1.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/uo2_6c_case2.c2m b/Ganlib/data/testgan3_proc/uo2_6c_case2.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/uo2_6c_case2.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/uo2_6c_case3.c2m b/Ganlib/data/testgan3_proc/uo2_6c_case3.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/uo2_6c_case3.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/uo2_6c_case4.c2m b/Ganlib/data/testgan3_proc/uo2_6c_case4.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/uo2_6c_case4.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan3_proc/uo2_6c_case5.c2m b/Ganlib/data/testgan3_proc/uo2_6c_case5.c2m new file mode 100644 index 0000000..0fd6683 --- /dev/null +++ b/Ganlib/data/testgan3_proc/uo2_6c_case5.c2m @@ -0,0 +1,13 @@ +*---- +* Define STRUCTURES and MODULES used +*---- +LINKED_LIST GEOM TRACK LIBRARY LIBRARY2 CP FLUX ; +MODULE LIB: UTL: DELETE: END: ; +PROCEDURE assertS ; +* +FLUX := UTL: :: CREA 'K-EFFECTIVE' 1 = 1.703945 ; +FLUX := UTL: FLUX :: CREA 'SIGNATURE' 3 = 'L_FL' 'UX' ' ' ; +UTL: FLUX :: DIR ; +assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; +ECHO "test uo2_6c_case5 completed" ; +QUIT "LIST" . diff --git a/Ganlib/data/testgan4.access b/Ganlib/data/testgan4.access new file mode 100755 index 0000000..f6bf391 --- /dev/null +++ b/Ganlib/data/testgan4.access @@ -0,0 +1,18 @@ +#!/bin/sh +if [ $# = 0 ] + then + echo "usage: testgan4.access directory" 1>&2 + exit 1 +fi +System=`uname -s` +Sysx="`echo $System | cut -b -6`" +MACH=`uname -sm | sed 's/[ ]/_/'` +if [ $Sysx = "CYGWIN" ]; then + System=`uname -o` + MACH=$System +elif [ $Sysx = "AIX" ]; then + MACH=`uname -s` +fi +echo "System :" $System " MACH :" "$MACH" +ln -s $1/data/testgan4_proc/*.h5 . +ls -l diff --git a/Ganlib/data/testgan4.x2m b/Ganlib/data/testgan4.x2m new file mode 100644 index 0000000..773f652 --- /dev/null +++ b/Ganlib/data/testgan4.x2m @@ -0,0 +1,98 @@ +* Regression test for hdf5 file support +* A. Hebert +* +MODULE HUTL: ABORT: END: ; +HDF5_FILE AFA_180 :: FILE './AFA_180.h5' ; +HDF5_FILE NEW_FILE ; +HDF5_FILE NEW_FILE2 :: FILE './NEW_FILE2.h5' ; +REAL delta ref_abso_2 ref_real4_2 abso_2 real4_2 ; + +HUTL: AFA_180 :: DIR + DIR 'input' + DIR 'input/SpectralRHOParameters' + DIR 'paramtree' + DIR 'paramvalues' + DIR 'calc 1/miscellaneous' + DIR 'explicit' + DIR 'physconst' + DIR 'explicit/ISONAME' + DIR 'physconst/ISOTYP' + DIR 'physconst/LAMNAME' + TEST physconst + TEST phys001 + TEST NCALS + TEST '/calc 1/xs/mac' + INFO NCALS IMPR NCALS + INFO ASSNAME IMPR ASSNAME + INFO physconst/LAMNAME IMPR physconst/LAMNAME + INFO physconst/ISOTYP IMPR physconst/ISOTYP + INFO explicit/ISONAME IMPR explicit/ISONAME + INFO physconst/FYIELDS + DIR '/calc 1/xs/mac/TOTAL' + INFO '/calc 1/xs/mac/TOTAL/ABSO' + IMPR '/calc 1/xs/mac/TOTAL/ABSO' + INFO '/calc 1/xs/mic/f.p./ABSO' + GREP '/calc 1/xs/mac/TOTAL/ABSO' 2 >>abso_2<< +; +ECHO "grep of ABSO(2)=" abso_2 ; +EVALUATE ref_abso_2 := 6.902077E-02 ; +EVALUATE delta := abso_2 ref_abso_2 - ref_abso_2 / ABS ; +IF delta 1.0E-5 < THEN + ECHO "TEST SUCCESSFUL; delta=" delta ; +ELSE + ECHO "------------" ; + ECHO "test failure" ; + ECHO "------------" ; + ECHO "REFERENCE=" ref_abso_2 " CALCULATED=" abso_2 ; + ABORT: ; +ENDIF ; + +NEW_FILE := HUTL: :: + CREA my_integer = 12345 + CREA integer_array 3 = 11111 22222 33333 + CREA real4_array 4 = 1.1111 2.2222 3.3333 5.0E6 + CREA single_string = zyxw + CREA string_array 4 = abcd efgh ijkl mnop + CREA "new_group" + CREA "new_group/new_dataset" 5 = 1.0 2.0 3.0 4.0 5.0 + DIR + IMPR my_integer + IMPR integer_array + IMPR real4_array + INFO single_string + IMPR single_string + IMPR string_array + DELE single_string + DELE string_array + CREA single_string2 = abzy + DIR + GREP real4_array 2 >>real4_2<< +; + +NEW_FILE2 := NEW_FILE ; +HUTL: NEW_FILE2 :: DIR ; + +ECHO "copy 'calc 1' group into NEW_FILE" ; +NEW_FILE := HUTL: NEW_FILE AFA_180 :: + DELE new_group + COPY 'calc 2' = 'calc 1' + DIR + DIR 'calc 2' +; + +ECHO "grep of real4_array(2)=" real4_2 ; +EVALUATE ref_real4_2 := 2.2222 ; +EVALUATE delta := real4_2 ref_real4_2 - ref_real4_2 / ABS ; +IF delta 1.0E-5 < THEN + ECHO "TEST SUCCESSFUL; delta=" delta ; +ELSE + ECHO "------------" ; + ECHO "test failure" ; + ECHO "------------" ; + ECHO "REFERENCE=" ref_real4_2 " CALCULATED=" real4_2 ; + ABORT: ; +ENDIF ; + +ECHO "test testgan4 completed" ; +END: ; +QUIT "XREF" . diff --git a/Ganlib/data/testgan4_proc/AFA_180.h5 b/Ganlib/data/testgan4_proc/AFA_180.h5 Binary files differnew file mode 100644 index 0000000..b9ca2af --- /dev/null +++ b/Ganlib/data/testgan4_proc/AFA_180.h5 diff --git a/Ganlib/data/testgan4_proc/AFA_310.h5 b/Ganlib/data/testgan4_proc/AFA_310.h5 Binary files differnew file mode 100644 index 0000000..560b59b --- /dev/null +++ b/Ganlib/data/testgan4_proc/AFA_310.h5 |