diff options
Diffstat (limited to 'Ganlib')
137 files changed, 28897 insertions, 0 deletions
diff --git a/Ganlib/Makefile b/Ganlib/Makefile new file mode 100644 index 0000000..578c0f0 --- /dev/null +++ b/Ganlib/Makefile @@ -0,0 +1,40 @@ +#--------------------------------------------------------------------------- +# +# Makefile for executing the Ganlib non-regression tests +# Author : A. Hebert (2018-5-10) +# +#--------------------------------------------------------------------------- +# +OS = $(shell uname -s | cut -d"_" -f1) +ifneq (,$(filter $(OS),SunOS AIX)) + MAKE = gmake +endif +ifeq ($(openmp),1) + nomp = 16 +else + nomp = 0 +endif +ifeq ($(intel),1) + fcompilerSuite = intel +else + ifeq ($(nvidia),1) + fcompilerSuite = nvidia + else + ifeq ($(llvm),1) + fcompilerSuite = llvm + else + fcompilerSuite = custom + endif + endif +endif +all : + $(MAKE) -C src +clean : + $(MAKE) clean -C src +tests : + ./rganlib -c $(fcompilerSuite) -p $(nomp) -q testgan1.x2m + ./rganlib -c $(fcompilerSuite) -p $(nomp) -q testgan2.x2m + ./rganlib -c $(fcompilerSuite) -p $(nomp) -q testgan3.x2m +ifeq ($(hdf5),1) + ./rganlib -c $(fcompilerSuite) -p $(nomp) -q testgan4.x2m +endif 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 diff --git a/Ganlib/rganlib b/Ganlib/rganlib new file mode 100755 index 0000000..5640993 --- /dev/null +++ b/Ganlib/rganlib @@ -0,0 +1,166 @@ +#!/bin/sh +# +# author : A. Hebert +# use : rganlib [-c:|-q|-w|-p:|-i:] <file.x2m> +# note : <file.x2m> must be located on directory ./data/ +# If <file.access> exists, it is executed. +# -c name of compiler +# -q quiet execution for regression testing +# -w to execute in console (for debug purpose) +# -p number of parallel threads (=1 by default) +# -i name of x2m dataset (by default, use the last argument) +# +if [ $# = 0 ] + then + echo "usage: rganlib [-c:|-q|-w|-p:|-i:] <file.x2m>" 1>&2 + exit 1 +fi +System=`uname -s` +Sysx="`echo $System | cut -b -6`" +if [ $Sysx = "CYGWIN" ]; then + MACH=`uname -o` +elif [ $Sysx = "AIX" ]; then + MACH=`uname -s` +else + MACH=`uname -sm | sed 's/[ ]/_/'` +fi + +for last; do : ; done +mydata=${last} +typ='custom' +quiet=0 +term=0 +nomp=0 + +while getopts ":c:qwi:p:" opt; do + case $opt in + c) typ="$OPTARG" + ;; + q) quiet=1 + ;; + w) term=1 + ;; + p) nomp=$OPTARG + ;; + i) mydata=$OPTARG + ;; + \?) echo "Invalid option -$OPTARG" >&2 + exit 1 + ;; + esac + + case $OPTARG in + -*) echo "Option $opt needs a valid argument" + exit 1 + ;; + esac +done + +xxx=`basename $mydata .x2m` +Code=`basename "$PWD"` +if [ $quiet = 0 ]; then + echo 'execute' $xxx 'with' $Code 'on system' $MACH 'with' $typ 'compiler' +fi + +if [ -d "$MACH" ]; then + if [ $quiet = 0 ]; then + echo 'use the existing directory' $MACH + fi +else + echo 'creation of directory' $MACH + mkdir "$MACH" +fi +CodeDir=$PWD + +if [ $Sysx = "AIX" ]; then + Tmpdir=/usr/tmp +elif [ $Sysx = "SunOS" ]; then + Tmpdir=/var/tmp +else + Tmpdir=/tmp +fi +inum=1 +while [ -d $Tmpdir/rundir$inum ] + do + inum=`expr $inum + 1 ` +done +Rundir=$Tmpdir/rundir$inum +mkdir $Rundir +if [ $quiet = 0 ]; then + echo "RunDirectory:" $Rundir +fi +cd $Rundir + +if [ $typ = 'custom' ]; then + cp "$CodeDir"/bin/"$MACH"/$Code ./code +else + cp "$CodeDir"/bin/"$MACH"'_'$typ/$Code ./code +fi +cp "$CodeDir"/data/$mydata ./mydata + +export NO_STOP_MESSAGE=1 +if [ -d "$CodeDir"/data/`echo $xxx`_proc ]; then + cp "$CodeDir"/data/`echo $xxx`_proc/*.c2m . 2> /dev/null +fi +if [ -f "$CodeDir"/data/$xxx.access ]; then + if [ $quiet = 0 ]; then + "$CodeDir"/data/$xxx.access "$CodeDir" + else + "$CodeDir"/data/$xxx.access "$CodeDir" > /dev/null + fi +fi +if [ -f "$CodeDir"/data/assertS.c2m ]; then + cp "$CodeDir"/data/assertS.c2m . +fi +if [ -f "$CodeDir"/data/assertV.c2m ]; then + cp "$CodeDir"/data/assertV.c2m . +fi +before=$(date +%s) +if [ $nomp != 0 ]; then + echo 'number of OpenMP threads=' $nomp + export OMP_NUM_THREADS=$nomp + if command -v numactl >&2; then + numactl --cpunodebind=0 --membind=0 2>/dev/null + echo "use NUMA memory policy" + fi +else + export OMP_NUM_THREADS=1 +fi +if [ $term = 0 ]; then + ./code <mydata >$xxx.result +elif [ $term = 1 ]; then + ./code <mydata +fi +if [ $quiet = 0 ]; then + time=$(( $(date +%s) - before)) + printf 'End of execution. Total execution time: %dh %dmin %ds\n' \ + $(($time/3600)) $(($time%3600/60)) $(($time%60)) +fi +if [ -f "$CodeDir"/data/$xxx.save ]; then + if [ $quiet = 0 ]; then + "$CodeDir"/data/$xxx.save "$CodeDir" + else + "$CodeDir"/data/$xxx.save "$CodeDir" > /dev/null + fi +fi +mv $xxx.result "$CodeDir"/"$MACH" +if [ $quiet = 0 ]; then + echo 'the listing is located on ./'$MACH +fi + +cd "$CodeDir"/"$MACH" +if [ $quiet = 0 ] && [ $term = 0 ]; then + tail -15 $xxx.result +elif [ $term = 0 ]; then + RED='\033[0;31m' + GREEN='\033[0;32m' + NC='\033[0m' # No Color + if tail $xxx.result | grep -q "normal end" ; then + printf "${GREEN}[OK]${NC}\n" + else + printf "${RED}[FAILED]${NC}\n" + fi +fi +chmod -R 777 $Rundir +/bin/rm -r -f $Rundir +cd .. diff --git a/Ganlib/src/CLETIM.f90 b/Ganlib/src/CLETIM.f90 new file mode 100644 index 0000000..d7b5570 --- /dev/null +++ b/Ganlib/src/CLETIM.f90 @@ -0,0 +1,29 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for CLETIM. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +subroutine CLETIM(sec) + ! abort execution + use, intrinsic :: iso_c_binding + double precision :: sec + interface + subroutine cletim_c (sec) bind(c) + use, intrinsic :: iso_c_binding + real(c_double) :: sec + end subroutine cletim_c + end interface + call cletim_c(sec) +end subroutine CLETIM diff --git a/Ganlib/src/DRV000.f b/Ganlib/src/DRV000.f new file mode 100644 index 0000000..7e19563 --- /dev/null +++ b/Ganlib/src/DRV000.f @@ -0,0 +1,323 @@ + SUBROUTINE DRV000(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +* MODULE TO FIND A ZERO USING BRENT'S METHOD WITH +* GIVEN FUNCTION VALUES. +* +* INPUT/OUTPUT PARAMETERS: +* NENTRY : NUMBER OF LINKED LISTS AND FILES USED BY THE MODULE. +* HENTRY : CHARACTER*12 NAME OF EACH LINKED LIST OR FILE. +* IENTRY : =0 CLE-2000 VARIABLE; =1 LINKED LIST; =2 XSM FILE; +* =3 SEQUENTIAL BINARY FILE; =4 SEQUENTIAL ASCII FILE; +* =5 DIRECT ACCESS FILE. +* JENTRY : =0 THE LINKED LIST OR FILE IS CREATED. +* =1 THE LINKED LIST OR FILE IS OPEN FOR MODIFICATIONS; +* =2 THE LINKED LIST OR FILE IS OPEN IN READ-ONLY MODE. +* KENTRY : =FILE UNIT NUMBER; =LINKED LIST ADDRESS OTHERWISE. +* DIMENSION HENTRY(NENTRY),IENTRY(NENTRY),JENTRY(NENTRY), +* KENTRY(NENTRY) +* +*-------------------------------------- AUTHOR: R. ROY ; 29/11/94 --- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY + CHARACTER HENTRY(NENTRY)*12 + INTEGER IENTRY(NENTRY), JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + INTEGER NITMA, ITYP, I + CHARACTER TEXT12*12, SGNTUR*12 + LOGICAL LSTART, LCONV + DOUBLE PRECISION DFLOTT + INTEGER ITER,ITMAX,IPRT, ISGNTR(3),ITMD + INTEGER ITERV(3), ICONV + REAL A,B,C, D,E, FA,FB,FC, P,Q,R,S, TOL1,XM,TOL + REAL X(3), DE(2), Y(3), PQRS(4), ATOL(3) + REAL FLOTT + REAL EPM,TOLD,Z0,ZH,Z1,Z2,Z3,ZBESTM + TYPE(C_PTR) IPL0 + PARAMETER (EPM=3.E-8,TOLD=1.E-5,ITMD=100) + PARAMETER (Z0=0.0,ZH=0.5,Z1=1.0,Z2=2.0,Z3=3.0) +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.NE.1) CALL XABORT('DRV000: ONLY ONE ENTRY EXPECTED.') + TEXT12=HENTRY(1) + IF(IENTRY(1).NE.1) CALL XABORT('DRV000: LHS L_0 OBJECT EXPECTED (' + > //TEXT12//').') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('DRV000: LH' + > //'S L_0 OBJECT IN CREATE OR MODIFICATION MODE EXPECTED.') +* + LSTART= JENTRY(1).EQ.0 + IPL0= KENTRY(1) + IF( LSTART )THEN +* DEFINE ALL TEMP VARIABLES + D= 0.0 + E= 0.0 + P= 0.0 + Q= 0.0 + R= 0.0 + S= 0.0 +* + LCONV= .FALSE. + TOL= TOLD + ITMAX= ITMD + ITER= 0 + IPRT= 0 + 10 CONTINUE + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3 ) + > CALL XABORT('DRV000: KEYWORDS *TOL*, *POINT*... EXPECTED.') + IF( TEXT12.EQ.'TOL' )THEN + CALL REDGET(ITYP,NITMA,TOL,TEXT12,DFLOTT) + IF( ITYP.NE.2 ) + > CALL XABORT('DRV000: A REAL TOLERANCE *TOL* IS EXPECTED.') + IF( TOL.LT.1.E-7 ) + > CALL XABORT('DRV000: TOLERANCE .LT. 1.E-7.') + GO TO 10 + ELSEIF( TEXT12.EQ.'ITMAX' )THEN + CALL REDGET(ITYP,ITMAX,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.1 ) + > CALL XABORT('DRV000: AN INTEGER *ITMAX* IS EXPECTED.') + GO TO 10 + ELSEIF( TEXT12.EQ.'DEBUG' )THEN + IPRT= 1 + GO TO 10 + ELSEIF( TEXT12.EQ.'POINT' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3.OR.TEXT12.NE.'X') + > CALL XABORT('DRV000: *X* KEYWORD EXPECTED.') + CALL REDGET(ITYP,NITMA,A ,TEXT12,DFLOTT) + IF(ITYP.NE.2 ) CALL XABORT('DRV000: AFTER *X*,' + > // ' A REAL IS EXPECTED.') + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3.OR.TEXT12.NE.'Y') + > CALL XABORT('DRV000: *Y* KEYWORD EXPECTED.') + CALL REDGET(ITYP,NITMA,FA ,TEXT12,DFLOTT) + IF(ITYP.NE.2 ) CALL XABORT('DRV000: AFTER *Y*,' + > // ' A REAL IS EXPECTED.') + ELSE + CALL XABORT('DRV000: KEYWORDS *TOL* OR *POINT* EXPECTED.') + ENDIF + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3.OR.TEXT12.NE.'POINT') + > CALL XABORT('DRV000: ONCE MORE, *POINT* KEYWORD EXPECTED.') + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3.OR.TEXT12.NE.'X') + > CALL XABORT('DRV000: *X* KEYWORD EXPECTED.') + CALL REDGET(ITYP,NITMA,B ,TEXT12,DFLOTT) + IF(ITYP.NE.2 ) CALL XABORT('DRV000: AFTER *X*,' + > // ' A REAL IS EXPECTED.') + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3.OR.TEXT12.NE.'Y') + > CALL XABORT('DRV000: *Y* KEYWORD EXPECTED.') + CALL REDGET(ITYP,NITMA,FB ,TEXT12,DFLOTT) + IF(ITYP.NE.2 ) CALL XABORT('DRV000: AFTER *Y*,' + > // ' A REAL IS EXPECTED.') + SGNTUR='L_0' + READ(SGNTUR,'(3A4)') ISGNTR + CALL LCMSIX(IPL0,' ',0) +* +* PUT SIGNATURE + CALL LCMPUT(IPL0,'SIGNATURE',3,3,ISGNTR) +* +* PUT CONVERGENCE FLAG + ICONV=-1 + CALL LCMPUT(IPL0,'ICONV',1,1,ICONV) + ELSE +* + CALL LCMSIX(IPL0,' ',0) +* +* VERIFY SIGNATURE + CALL LCMGET(IPL0,'SIGNATURE',ISGNTR) + WRITE(SGNTUR,'(3A4)') (ISGNTR(I),I=1,3) + IF(SGNTUR.NE.'L_0') + > CALL XABORT('DRV000: L_0 OBJECT IS EXPECTED') +* + CALL LCMGET(IPL0,'ICONV',ICONV) + LCONV= ICONV.EQ.+1 +* +* NOTIFY USER IF ALREADY CONVERVED + IF( LCONV ) + > CALL XABORT('DRV000: PROCESS IS ALREADY CONVERGED') +* +* GET L_0 OBJECT VALUES + CALL LCMGET(IPL0,'X',X) + A=X(1) + B=X(2) + C=X(3) + CALL LCMGET(IPL0,'DE',DE) + D=DE(1) + E=DE(2) + CALL LCMGET(IPL0,'Y',Y) + FA=Y(1) + FB=Y(2) + FC=Y(3) + CALL LCMGET(IPL0,'PQRS',PQRS) + P=PQRS(1) + Q=PQRS(2) + R=PQRS(3) + S=PQRS(4) + CALL LCMGET(IPL0,'ATOL',ATOL) + TOL=ATOL(1) + XM=ATOL(2) + TOL1=ATOL(3) + CALL LCMGET(IPL0,'ITERV',ITERV) + ITER=ITERV(1) + ITMAX=ITERV(2) + IPRT=ITERV(3) +* +* GET NEW *Y* VALUE + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3.OR.TEXT12.NE.'Y') + > CALL XABORT('DRV000: *Y* KEYWORD EXPECTED.') + CALL REDGET(ITYP,NITMA,FB ,TEXT12,DFLOTT) + IF(ITYP.NE.2 ) + > CALL XABORT('DRV000: AFTER *Y*, A REAL IS EXPECTED.') + ENDIF +* +* METHOD: BRENT'S METHOD FOR FINDING ZEROS. +* FIRST INTERVAL MUST BE BRACKETED: FA*FB < 0. +* +* INPUT: ITER= NUMBER OF ITERATIONS (0 AT START) +* TOL= TOLERANCE FOR ZERO FINDING +* (A,FA)= FIRST POINT +* (B,FB)= SECOND POINT +* +* OUTPUT: ZBESTM= ESTIMATION OF NEXT ZERO +* + IF( ITER.EQ.0 )THEN + IF((FA.GT.Z0.AND.FB.GT.Z0).OR.(FA.LT.Z0.AND.FB.LT.Z0)) + > CALL XABORT(' DRV000: ROOT MUST BE BRACKETED') + C=B + FC=FB + ENDIF + IF((FB.GT.Z0.AND.FC.GT.Z0).OR.(FB.LT.Z0.AND.FC.LT.Z0))THEN + C=A + FC=FA + D=B-A + E=D + ENDIF + IF(ABS(FC).LT.ABS(FB)) THEN + A=B + B=C + C=A + FA=FB + FB=FC + FC=FA + ENDIF + TOL1=Z2*EPM*ABS(B)+ ZH*TOL + XM=ZH*(C-B) + IF(ABS(XM).LE.TOL1 .OR. FB.EQ.Z0)THEN + ZBESTM=B + LCONV= .TRUE. + GO TO 20 + ENDIF + IF(ABS(E).GE.TOL1 .AND. ABS(FA).GT.ABS(FB)) THEN + S=FB/FA + IF(A.EQ.C) THEN + P=Z2*XM*S + Q=Z1-S + ELSE + Q=FA/FC + R=FB/FC + P=S*(Z2*XM*Q*(Q-R)-(B-A)*(R-Z1)) + Q=(Q-Z1)*(R-Z1)*(S-Z1) + ENDIF + IF(P.GT.Z0) Q=-Q + P=ABS(P) + IF(Z2*P .LT. MIN(Z3*XM*Q-ABS(TOL1*Q),ABS(E*Q))) THEN + E=D + D=P/Q + ELSE + D=XM + E=D + ENDIF + ELSE + D=XM + E=D + ENDIF + A=B + FA=FB + IF(ABS(D) .GT. TOL1) THEN + B=B+D + ELSE + B=B+SIGN(TOL1,XM) + ENDIF + ZBESTM=B + ITER= ITER + 1 + IF( ITER.GT.ITMAX ) + > CALL XABORT('DRV000: MAX NUMBER OF ITERATIONS REACHED.') +* + 20 CONTINUE +* +* PUT L_0 OBJECT VALUES + X(1)=A + X(2)=B + X(3)=C + CALL LCMPUT(IPL0,'X',3,2,X) + DE(1)=D + DE(2)=E + CALL LCMPUT(IPL0,'DE',2,2,DE) + Y(1)=FA + Y(2)=FB + Y(3)=FC + CALL LCMPUT(IPL0,'Y',3,2,Y) + PQRS(1)=P + PQRS(2)=Q + PQRS(3)=R + PQRS(4)=S + CALL LCMPUT(IPL0,'PQRS',4,2,PQRS) + ATOL(1)=TOL + ATOL(2)=XM + ATOL(3)=TOL1 + CALL LCMPUT(IPL0,'ATOL',3,2,ATOL) + ITERV(1)=ITER + ITERV(2)=ITMAX + ITERV(3)=IPRT + CALL LCMPUT(IPL0,'ITERV',3,1,ITERV) + IF( LCONV )THEN + ICONV=+1 + ELSE + ICONV=-1 + ENDIF +* +* SAVE CONVERGENCE FLAG + CALL LCMPUT(IPL0,'ICONV',1,1,ICONV) + CALL LCMSIX(IPL0,' ',0) + IF( IPRT.EQ.1 )THEN + WRITE(6,*) 'DEBUG: A=', A,' B=', B,' C=', C + WRITE(6,*) 'DEBUG: FA=',FA,' FB=',FB,' FC=',FC + WRITE(6,*) 'DEBUG: D=', D,' E=', E + WRITE(6,*) 'DEBUG: P=', P,' Q=', Q,' R=',R,' S=',S + WRITE(6,*) 'DEBUG: TOL1=',TOL1,' XM=',XM,' TOL=',TOL + WRITE(6,*) 'DEBUG: ITER=',ITER,' ITMAX=',ITMAX + WRITE(6,*) 'DEBUG: ICONV=',ICONV + ENDIF +* +* NOW, RETURN BACK LOGICAL VALUE AND ZERO ESTIMATE + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + ITYP= -ITYP + IF( ITYP.NE.5 )THEN + CALL XABORT('DRV000: MUST WRITE LOGICAL FLAG INTO >>.<<') + ENDIF + CALL REDPUT(ITYP,ICONV,FLOTT,TEXT12,DFLOTT) + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + ITYP= -ITYP + IF( ITYP.NE.2 )THEN + CALL XABORT('DRV000: MUST WRITE REAL ZERO INTO >>.<<') + ENDIF + CALL REDPUT(ITYP,NITMA,ZBESTM,TEXT12,DFLOTT) +* + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3.OR.TEXT12.NE.';') + > CALL XABORT('DRV000: *;* IS EXPECTED FOR ENDING THE SENTENCE.') + RETURN + END diff --git a/Ganlib/src/DRVADD.f b/Ganlib/src/DRVADD.f new file mode 100644 index 0000000..79b6523 --- /dev/null +++ b/Ganlib/src/DRVADD.f @@ -0,0 +1,70 @@ +*DECK DRVADD + SUBROUTINE DRVADD(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +* STANDARD ADDITION MODULE. +* +* INPUT/OUTPUT PARAMETERS: +* NENTRY : NUMBER OF LINKED LISTS AND FILES USED BY THE MODULE. +* HENTRY : CHARACTER*12 NAME OF EACH LINKED LIST OR FILE. +* IENTRY : =0 CLE-2000 VARIABLE; =1 LINKED LIST; =2 XSM FILE; +* =3 SEQUENTIAL BINARY FILE; =4 SEQUENTIAL ASCII FILE. +* JENTRY : =0 THE LINKED LIST OR FILE IS CREATED. +* =1 THE LINKED LIST OR FILE IS OPEN FOR MODIFICATIONS; +* =2 THE LINKED LIST OR FILE IS OPEN IN READ-ONLY MODE. +* KENTRY : =FILE UNIT NUMBER; =LINKED LIST ADDRESS OTHERWISE. +* DIMENSION HENTRY(NENTRY),IENTRY(NENTRY),JENTRY(NENTRY), +* KENTRY(NENTRY) +* +*-------------------------------------- AUTHOR: A. HEBERT ; 21/12/93 --- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*131,TEXT12*12 + TYPE(C_PTR) IPLIST1,IPLIST2 +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.1) CALL XABORT('DRVADD: TWO PARAMETERS EXPECTED.') + TEXT12=HENTRY(1) + IF((JENTRY(1).EQ.2).OR.(IENTRY(1).GT.2)) CALL XABORT('DRVADD: LIN' + 1 //'KED LIST OR XSM FILE IN CREATION OR MODIFICATION MODE EXPECTE' + 2 //'D AT LHS ('//TEXT12//').') + IF((JENTRY(2).NE.2).OR.(IENTRY(2).GT.2)) CALL XABORT('DRVADD: LIN' + 1 //'KED LIST OR XSM FILE IN READ-ONLY MODE EXPECTED AT RHS.') +*---- +* COPY THE SECOND RHS INTO THE LHS. +*---- + IF(JENTRY(1).EQ.0) THEN + IF(NENTRY.LE.2) CALL XABORT('DRVADD: 3 PARAMETERS EXPECTED.') + IF((JENTRY(3).NE.2).OR.(IENTRY(3).GT.2)) CALL XABORT('DRVADD: ' + 1 //'LINKED LIST OR XSM FILE IN READ-ONLY MODE EXPECTED AT SECON' + 2 //'D RHS.') + NUNIT=KDROPN('DUMMYSQ',0,2,0) + IF(NUNIT.LE.0) CALL XABORT('DRVADD: KDROPN FAILURE.') + CALL LCMEXP(KENTRY(3),0,NUNIT,1,1) + REWIND(NUNIT) + CALL LCMEXP(KENTRY(1),0,NUNIT,1,2) + IERR=KDRCLS(NUNIT,2) + IF(IERR.LT.0) THEN + WRITE(HSMG,'(29HDRVADD: KDRCLS FAILURE. IERR=,I3)') IERR + CALL XABORT(HSMG) + ENDIF + ENDIF +*---- +* PERFORM THE ADDITION. +*---- + IPLIST1=KENTRY(1) + IPLIST2=KENTRY(2) + CALL LCMADD(IPLIST2,IPLIST1) + RETURN + END diff --git a/Ganlib/src/DRVBAC.f b/Ganlib/src/DRVBAC.f new file mode 100644 index 0000000..68f72e8 --- /dev/null +++ b/Ganlib/src/DRVBAC.f @@ -0,0 +1,160 @@ +*DECK DRVBAC + SUBROUTINE DRVBAC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Backup one or many LCM objects. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): read-only or modification type(VECTOR). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPLIST,JPLIST,KPLIST + CHARACTER TEXT12*12,TEXT4*4,HMEDIA*12,NAMT*12 + DOUBLE PRECISION DFLOTT +* + IF(NENTRY.LE.1) THEN + CALL XABORT('DRVBAC: TWO PARAMETERS EXPECTED.') + ELSE IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) THEN + CALL XABORT('DRVBAC: LHS LINKED LIST OR XSM FILE EXPECTED.') + ELSE IF(JENTRY(1).EQ.2) THEN + CALL XABORT('DRVBAC: LHS PARAMETER IN CREATE OR MODIFICATION ' + 1 //'MODE EXPECTED.') + ENDIF + ITYPE=IENTRY(1) + IPLIST=KENTRY(1) +* + IMPX=1 + IDIM=0 + IPOS=0 + JPLIST=C_NULL_PTR + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 30 + IF(INDIC.NE.3) CALL XABORT('DRVBAC: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVBAC: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'STEP') THEN +* CHANGE THE HIERARCHICAL LEVEL ON THE LCM OBJECT. + IF(ITYPE.GT.2) CALL XABORT('DRVBAC: UNABLE TO STEP INTO A SE' + 1 //'QUENTIAL FILE.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVBAC: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'UP') THEN + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVBAC: CHARACTER DATA EXPECT' + 1 //'ED.') + IF(IMPX.GT.0) WRITE (6,100) NAMT + CALL LCMLEN(IPLIST,NAMT,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + JPLIST=LCMGID(IPLIST,NAMT) + ELSE + JPLIST=LCMDID(IPLIST,NAMT) + ENDIF + ELSE IF(TEXT4.EQ.'AT') THEN + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVBAC: INTEGER EXPECTED.') + IF(IMPX.GT.0) WRITE (6,110) NITMA + CALL LCMLEL(IPLIST,NITMA,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + JPLIST=LCMGIL(IPLIST,NITMA) + ELSE + JPLIST=LCMDIL(IPLIST,NITMA) + ENDIF + ELSE + CALL XABORT('DRVBAC: UP OR AT EXPECTED.') + ENDIF + IPLIST=JPLIST + ELSE IF(TEXT4.EQ.'LIST') THEN + CALL REDGET(INDIC,IDIM,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVBAC: INTEGER DATA EXPECTED.') + CALL LCMPUT(IPLIST,'LISTDIM',1,1,IDIM) + ELSE IF(TEXT4.EQ.'ITEM') THEN + CALL REDGET(INDIC,IPOS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVBAC: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('DRVBAC: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +* + 30 CALL LCMLEN(IPLIST,'SIGNATURE',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGTC(IPLIST,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_ARCHIVE') THEN + HMEDIA=HENTRY(1) + CALL XABORT('DRVBAC: SIGNATURE OF '//HMEDIA//' IS '//TEXT12 + 1 //'. L_ARCHIVE EXPECTED.') + ENDIF + ELSE + TEXT12='L_ARCHIVE' + CALL LCMPTC(IPLIST,'SIGNATURE',12,TEXT12) + ENDIF + ISET=0 + DO 40 I=2,NENTRY + IF((JENTRY(I).EQ.0).OR.(JENTRY(I).EQ.1)) THEN + TEXT12=HENTRY(I) + CALL XABORT('DRVBAC: ENTRY '//TEXT12//' IS NOT EXPECTED.') + ELSE IF(IENTRY(I).GT.2) THEN + CALL XABORT('DRVBAC: RHS LINKED LIST OR XSM FILE EXPECTED.') + ENDIF + IF(IDIM.EQ.0) THEN + CALL LCMLEN(IPLIST,'LISTDIM',ILONG,ITYLCM) + IF(ILONG.EQ.1) CALL LCMGET(IPLIST,'LISTDIM',IDIM) + ENDIF + IF(IDIM.EQ.0) THEN + ! HENTRY(I) is stored as a directory + IF(IMPX.GT.0) WRITE (6,'(/17H DRVBAC: BACKUP '',A12,7H'' INTO , + 1 1H'',A,2H''.)') TRIM(HENTRY(I)),TRIM(HENTRY(1)) + CALL LCMSIX(IPLIST,HENTRY(I),1) + CALL LCMEQU(KENTRY(I),IPLIST) + CALL LCMSIX(IPLIST,' ',2) + ELSE + ! HENTRY(I) is stored as a list of directories + IF(IPOS.EQ.0) CALL XABORT('DRVBAC: IPOS IS NOT DEFINED.') + IF(IPOS.GT.IDIM) CALL XABORT('DRVBAC: LIST OVERFLOW FOR OBJECT' + 1 //' '//TRIM(HENTRY(I))//'.') + JPLIST=LCMLID(IPLIST,HENTRY(I),IPOS) + IF(IMPX.GT.0) WRITE (6,120) TRIM(HENTRY(I)),IPOS,TRIM(HENTRY(1)) + KPLIST=LCMDIL(JPLIST,IPOS) + CALL LCMEQU(KENTRY(I),KPLIST) + ENDIF + 40 CONTINUE + RETURN + 100 FORMAT (/27H DRVBAC: STEP UP TO LEVEL ',A12,2H'.) + 110 FORMAT (/26H DRVBAC: STEP AT COMPONENT,I6,1H.) + 120 FORMAT (/16H DRVBAC: BACKUP ,A,13H INTO ELEMENT,I5,9H OF LIST ,A, + 1 1H.) + END diff --git a/Ganlib/src/DRVEQU.F b/Ganlib/src/DRVEQU.F new file mode 100644 index 0000000..669e333 --- /dev/null +++ b/Ganlib/src/DRVEQU.F @@ -0,0 +1,262 @@ +*DECK DRVEQU + SUBROUTINE DRVEQU(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Standard equality module. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file; =6 HDF5 file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +#if defined(HDF5_LIB) + USE hdf5_wrap +#endif /* defined(HDF5_LIB) */ +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPLIST,JPLIST + CHARACTER HSMG*131,TEXT12*12,TEXT4*4,NAMT*24,TEXT2*2 + DOUBLE PRECISION DFLOTT + LOGICAL LOG +#if defined(HDF5_LIB) + CHARACTER(LEN=72) :: RECNAM + CHARACTER(LEN=1023), ALLOCATABLE, DIMENSION(:) :: TX1023 +#endif /* defined(HDF5_LIB) */ +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.1) CALL XABORT('DRVEQU: PARAMETER EXPECTED.') + NRHS=0 + NLHS=0 + LOG=.FALSE. + ITYPE=-1 + JPLIST=C_NULL_PTR + DO 10 I=1,NENTRY + IF(JENTRY(I).LE.1) THEN + IF(IENTRY(I).EQ.5) CALL XABORT('DRVEQU: THE EQUALITY MODULE ' + 1 //'CANNOT WORKS WITH DIRECT ACCESS FILES (1).') + NLHS=NLHS+1 + LOG=LOG.OR.(IENTRY(I).LE.2) + ELSE IF(JENTRY(I).EQ.2) THEN + IF(IENTRY(I).EQ.5) CALL XABORT('DRVEQU: THE EQUALITY MODULE ' + 1 //'CANNOT WORKS WITH DIRECT ACCESS FILES (2).') + NRHS=NRHS+1 + TEXT12=HENTRY(I) + ITYPE=IENTRY(I) + IPLIST=KENTRY(I) + GO TO 20 + ENDIF + 10 CONTINUE + 20 IF(NLHS.EQ.0) THEN + CALL XABORT('DRVEQU: NO LHS ENTRY.') + ELSE IF(NRHS.NE.1) THEN + CALL XABORT('DRVEQU: ONE RHS ENTRY EXPECTED.') + ENDIF +*---- +* STEP UP/AT FOR THE RHS OBJECT. +*---- + IMPX=1 + IMPY=0 + L1995=0 + NAMT='/' + 30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 50 + IF(INDIC.NE.3) CALL XABORT('DRVEQU: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVEQU: INTEGER DATA EXPECTED.') + IF(IMPX.GE.10) IMPY=1 + ELSE IF(TEXT4.EQ.'ERAS') THEN +* ERASE THE CONTENTS OF THE LCM OR XSM OBJECT. + DO 40 I=1,NENTRY + IF((IENTRY(I).LE.2).AND.(JENTRY(I).EQ.1)) THEN + IF(JENTRY(I).EQ.2) CALL XABORT('DRVEQU: ERAS IS A FORBIDDEN' + 1 //' OPERATION IN READ-ONLY MODE.') + CALL LCMCL(KENTRY(I),3) + CALL LCMOP(KENTRY(I),HENTRY(I),1,IENTRY(I),0) + ENDIF + 40 CONTINUE + ELSE IF(TEXT4.EQ.'OLD') THEN +* CREATE AN ASCII FILE IN 1995 SPECIFICATION. + L1995=1 + ELSE IF(TEXT4.EQ.'SAP') THEN +* IMPORT/CREATE AN ASCII FILE IN SAPHYR SPECIFICATION. + L1995=2 + ELSE IF(TEXT4.EQ.'STEP') THEN +* CHANGE THE HIERARCHICAL LEVEL ON THE LCM OBJECT. + IF((ITYPE.GT.2).AND.(ITYPE.NE.6)) THEN + CALL XABORT('DRVEQU: UNABLE TO STEP INTO A SEQUENTIAL FILE.') + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVEQU: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'UP') THEN + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVEQU: CHARACTER DATA EXPECT' + 1 //'ED.') + IF(IMPX.GT.0) WRITE (6,100) NAMT + IF(IENTRY(1).EQ.6) GO TO 30 + JPLIST=LCMGID(IPLIST,NAMT(:12)) + ELSE IF(TEXT4.EQ.'AT') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVEQU: INTEGER EXPECTED.') + IF(IMPX.GT.0) WRITE (6,110) NITMA + JPLIST=LCMGIL(IPLIST,NITMA) + ELSE + CALL XABORT('DRVEQU: UP OR AT EXPECTED.') + ENDIF + IPLIST=JPLIST + ELSE IF(TEXT4.EQ.';') THEN + GO TO 50 + ELSE + WRITE(HSMG,120) TEXT4 + CALL XABORT(HSMG) + ENDIF + GO TO 30 +*---- +* RECOVER THE RHS. +*---- + 50 NUNIT=0 + IF(LOG.AND.(ITYPE.LE.2)) THEN + IF(NLHS.EQ.1) THEN +* FAST COPY. + DO 60 I=1,NENTRY + IF(JENTRY(I).LE.1) CALL LCMEQU(IPLIST,KENTRY(I)) + 60 CONTINUE + RETURN + ENDIF + NUNIT=KDROPN('DUMMYSQ',0,2,0) + IF(NUNIT.LE.0) CALL XABORT('DRVEQU: KDROPN FAILURE.') + CALL LCMEXP(IPLIST,IMPY,NUNIT,1,1) + REWIND(NUNIT) + ENDIF +*---- +* COPY A HDF5 FILE (KENTRY(2) -> KENTRY(1)). +*---- + IF(IENTRY(1).EQ.6) THEN +#if defined(HDF5_LIB) + IF(NENTRY.NE.2) CALL XABORT('DRVEQU: HDF1 := HDF2 EXPECTED.') + IF(NLHS.NE.1) CALL XABORT('DRVEQU: ONE LHS EXPECTED.') + IF(IENTRY(2).NE.6) CALL XABORT('DRVEQU: RHS HDF5 EXPECTED.') + CALL hdf5_list_groups(KENTRY(2),TRIM(NAMT),TX1023) + DO I=1,SIZE(TX1023) + WRITE(RECNAM,'(A,1H/,A)') TRIM(NAMT),TRIM(TX1023(I)) + CALL hdf5_copy(KENTRY(2),RECNAM,KENTRY(1),TX1023(I)) + ENDDO + DEALLOCATE(TX1023) + CALL hdf5_list_datasets(KENTRY(2),TRIM(NAMT),TX1023) + DO I=1,SIZE(TX1023) + WRITE(RECNAM,'(A,1H/,A)') TRIM(NAMT),TRIM(TX1023(I)) + CALL hdf5_copy(KENTRY(2),RECNAM,KENTRY(1),TX1023(I)) + ENDDO + DEALLOCATE(TX1023) + RETURN +#else + CALL XABORT('DRVEQU: HDF5 API NOT SET.') +#endif /* defined(HDF5_LIB) */ + ENDIF +*---- +* CREATE THE LHS. +*---- + DO 70 I=1,NENTRY + IF(JENTRY(I).LE.1) THEN + IF((IENTRY(I).LE.2).AND.(ITYPE.LE.2)) THEN + CALL LCMEXP(KENTRY(I),IMPY,NUNIT,1,2) + REWIND(NUNIT) + IF(IMPX.GT.0) WRITE(6,130) HENTRY(I),TEXT12 + ELSE IF((IENTRY(I).GE.3).AND.(ITYPE.LE.2)) THEN + NUNIT2=FILUNIT(KENTRY(I)) + IF((L1995.EQ.1).AND.(IENTRY(I).EQ.4)) THEN +* THE EXPORT ASCII FILE IS A 1995 SPECIFICATION. + CALL LCMEXPV3(IPLIST,IMPY,NUNIT2,IENTRY(I)-2,1) + ELSE IF((L1995.EQ.2).AND.(IENTRY(I).EQ.4)) THEN +* THE EXPORT ASCII FILE IS A SAPHYR SPECIFICATION. + CALL LCMEXS(IPLIST,IMPY,NUNIT2,IENTRY(I)-2,1) + ELSE + CALL LCMEXP(IPLIST,IMPY,NUNIT2,IENTRY(I)-2,1) + ENDIF + REWIND(NUNIT2) + IF(IMPX.GT.0) WRITE(6,140) TEXT12,HENTRY(I) + IF((IMPX.GT.0).AND.(L1995.EQ.1)) THEN + WRITE(6,'(/35H DRVEQU: 1995 SPECIFICATION EXPORT.)') + ELSE IF((IMPX.GT.0).AND.(L1995.EQ.2)) THEN + WRITE(6,'(/37H DRVEQU: SAPHYR SPECIFICATION EXPORT.)') + ENDIF + ELSE IF((IENTRY(I).LE.2).AND.(ITYPE.GE.3)) THEN + NUNIT2=FILUNIT(IPLIST) + IF((ITYPE.EQ.4).AND.(L1995.EQ.0)) THEN + READ(NUNIT2,'(A2)',END=90) TEXT2 + IF(TEXT2.NE.'->') L1995=1 + REWIND(NUNIT2) + ENDIF + IF(L1995.EQ.1) THEN +* THE IMPORT ASCII FILE IS A 1995 SPECIFICATION. + CALL LCMEXPV3(KENTRY(I),IMPY,NUNIT2,ITYPE-2,2) + ELSE IF(L1995.EQ.2) THEN +* THE IMPORT ASCII FILE IS A SAPHYR SPECIFICATION. + CALL LCMEXS(KENTRY(I),IMPY,NUNIT2,ITYPE-2,2) + ELSE + CALL LCMEXP(KENTRY(I),IMPY,NUNIT2,ITYPE-2,2) + ENDIF + REWIND(NUNIT2) + IF(IMPX.GT.0) WRITE(6,150) HENTRY(I),TEXT12 + IF((IMPX.GT.0).AND.(L1995.EQ.1)) THEN + WRITE(6,'(/35H DRVEQU: 1995 SPECIFICATION IMPORT.)') + ELSE IF((IMPX.GT.0).AND.(L1995.EQ.2)) THEN + WRITE(6,'(/37H DRVEQU: SAPHYR SPECIFICATION IMPORT.)') + ENDIF + ELSE IF((IENTRY(I).GE.3).AND.(ITYPE.GE.3)) THEN + WRITE(HSMG,160) HENTRY(I),TEXT12 + CALL XABORT(HSMG) + ENDIF + ENDIF + 70 CONTINUE + IF(NUNIT.GT.0) THEN + IERR=KDRCLS(NUNIT,2) + IF(IERR.LT.0) THEN + WRITE(HSMG,'(29HDRVEQU: KDRCLS FAILURE. IERR=,I3)') IERR + CALL XABORT(HSMG) + ENDIF + ENDIF + RETURN + 90 CALL XABORT('DRVEQU: EOF ENCOUNTERED.') +* + 100 FORMAT(/27H DRVEQU: STEP UP TO LEVEL ',A,2H'.) + 110 FORMAT(/26H DRVEQU: STEP AT COMPONENT,I6,1H.) + 120 FORMAT(8HDRVEQU: ,A4,30H IS AN INVALID UTILITY ACTION.) + 130 FORMAT(/29H DRVEQU: A LCM OBJECT NAMED ',A12,16H' WAS SET EQUAL , + 1 4HTO ',A12,2H'.) + 140 FORMAT(/29H DRVEQU: A LCM OBJECT NAMED ',A12,16H' WAS EXPORTED T, + 1 8HO FILE ',A12,2H'.) + 150 FORMAT(/29H DRVEQU: A LCM OBJECT NAMED ',A12,16H' WAS IMPORTED F, + 1 10HROM FILE ',A12,2H'.) + 160 FORMAT(49HDRVEQU: UNABLE TO EQUAL THE TWO SEQUENTIAL FILES , + 1 1H',A12,7H' AND ',A12,2H'.) + END diff --git a/Ganlib/src/DRVGRP.f b/Ganlib/src/DRVGRP.f new file mode 100644 index 0000000..984d9e4 --- /dev/null +++ b/Ganlib/src/DRVGRP.f @@ -0,0 +1,489 @@ +*DECK DRVGRP + SUBROUTINE DRVGRP(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* standard grep module to recover cle-2000 values in a linked list or +* in an xsm file. +* +*Copyright: +* Copyright (C) 2000 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): read-only type(VECTOR). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(*)*12 +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12,HLIST*12,HNAME*12,TEXT72*72,TEXTIN*72,NAMT*12 + CHARACTER CLOGBG(5)*12,HSMG*131 + TYPE(C_PTR) IPDATA,JPDATA + INTEGER ITYLCM,IACTIO,I,J,K,N + INTEGER ITYP,ITYP1,NOUT,NSTP + INTEGER IBCHAR,NBCHAR,NRESID,IOFSET,ISET + INTEGER ITYPE,IOUT,ILENG,ILENG2,IPRINT + INTEGER NITMA, INTGMX, INTMIN, INTMAX, INDMIN, INDMAX + PARAMETER ( INTGMX= 2147483646 ) + DOUBLE PRECISION DFLOTT, DBLEMX, DBLMIN, DBLMAX, DBLMNV + PARAMETER ( DBLEMX= 1.D+100 ) + REAL FLOTT, REALMX, RELMIN, RELMAX, RELMNV + PARAMETER ( REALMX= 1.E+30 ) + INTEGER ISEEME(2),ITRANS + REAL ASEEME(2),ATRANS + DOUBLE PRECISION DSEEME + EQUIVALENCE ( DSEEME, ISEEME, ASEEME ) + EQUIVALENCE ( ITRANS, ATRANS ) + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA,JDATA + DATA CLOGBG + 1 / 'INTEGER' , 'REAL' , 'STRING' , 'DOUBLE', 'LOGICAL' / +*---- +* PARAMETER VALIDATION. +*---- + IACTIO=0 + INDMIN= 0 + INDMAX= 0 + NBCHAR= 0 + IF( NENTRY.NE.1 )THEN + CALL XABORT('DRVGRP: MORE THAN ONE ENTRY') + ELSEIF( IENTRY(1).NE.1.AND.IENTRY(1).NE.2 )THEN + CALL XABORT('DRVGRP: RHS LINKED LIST ' + > //'OR XSM FILE PARAMETER EXPECTED.') + ELSEIF( JENTRY(1).NE.2 )THEN + CALL XABORT('DRVGRP: RHS PARAMETER IN ' + > //'READ-ONLY MODE EXPECTED.') + ENDIF +* + HLIST=HENTRY(1) + IPDATA=KENTRY(1) + I= 1 + IPRINT= 0 + 20 CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + 25 CONTINUE + IF( ITYP.NE.3 )CALL XABORT('DRVGRP: CHARACTER DATA EXPECTED.') + IF( TEXT12.EQ.'EDIT' )THEN + CALL REDGET(ITYP,IPRINT,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.1 )CALL XABORT('DRVGRP: NO INTEGER AFTER *EDIT*.') + ELSE IF(TEXT12.EQ.'STEP') THEN +* CHANGE THE HIERARCHICAL LEVEL ON THE LCM OBJECT. + JPDATA=C_NULL_PTR + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3) CALL XABORT('DRVGRP: CHARACTER DATA EXPECTED.') + IF(TEXT12.EQ.'UP') THEN + CALL REDGET(ITYP,NITMA,FLOTT,NAMT,DFLOTT) + IF(ITYP.NE.3) CALL XABORT('DRVGRP: DIR-NAME EXPECTED.') + JPDATA=LCMGID(IPDATA,NAMT) + ELSE IF(TEXT12.EQ.'AT') THEN + CALL REDGET(ITYP,NITMA,FLOTT,NAMT,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('DRVGRP: INTEGER EXPECTED.') + JPDATA=LCMGIL(IPDATA,NITMA) + ELSE + CALL XABORT('DRVGRP: *UP* OR *AT* EXPECTED.') + ENDIF + IPDATA=JPDATA + ELSEIF( TEXT12.EQ.'GETVAL'.OR.TEXT12.EQ.'MAXVAL'.OR. + > TEXT12.EQ.'MINVAL'.OR.TEXT12.EQ.'INDMAX'.OR. + > TEXT12.EQ.'INDMIN'.OR.TEXT12.EQ.'MEAN' .OR. + > TEXT12.EQ.'TYPE' .OR.TEXT12.EQ.'LENGTH')THEN + IF( TEXT12.EQ.'GETVAL' )THEN + IACTIO= 1 + ELSEIF( TEXT12.EQ.'MAXVAL' )THEN + IACTIO= 2 + ELSEIF( TEXT12.EQ.'MINVAL' )THEN + IACTIO= 3 + ELSEIF( TEXT12.EQ.'INDMAX' )THEN + IACTIO= 4 + ELSEIF( TEXT12.EQ.'INDMIN' )THEN + IACTIO= 5 + ELSEIF( TEXT12.EQ.'MEAN' )THEN + IACTIO= 6 + ELSEIF( TEXT12.EQ.'TYPE' )THEN + IACTIO= 7 + ELSEIF( TEXT12.EQ.'LENGTH' )THEN + IACTIO= 8 + ENDIF +* +* FIND BLOCK NAME + CALL REDGET(ITYP1,ISET ,FLOTT,HNAME ,DFLOTT) + IF(ITYP1.EQ.1) THEN + CALL LCMLEL(IPDATA,ISET ,ILENG2,ITYLCM) + ELSE IF(ITYP1.EQ.3) THEN + CALL LCMLEN(IPDATA,HNAME ,ILENG2,ITYLCM) + ELSE + CALL XABORT('DRVGRP: BLOCK-NAME OR LIST INDEX EXPECTED.') + ENDIF + IF((ITYLCM.EQ.4).OR.(ITYLCM.EQ.6)) ILENG2=2*ILENG2 + IF( IACTIO.EQ.7 ) THEN + NOUT= 1 + NSTP= 1 + ITYPE= 1 + ALLOCATE(JDATA(NOUT)) + JDATA(1)= ITYLCM + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + GO TO 310 + ELSE IF( IACTIO.EQ.8 ) THEN + NOUT= 1 + NSTP= 1 + ITYPE= 1 + ALLOCATE(JDATA(NOUT)) + JDATA(1)= ILENG2 + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + GO TO 310 + ENDIF + IF( ILENG2.EQ.0 )THEN + CALL LCMLIB(IPDATA) + CALL XABORT('DRVGRP: BLOCK *'//HNAME//'* IS NOT STORED IN *' + > //HLIST//'*.') + ELSE IF( ITYLCM.EQ.10 ) THEN + CALL XABORT('DRVGRP: '//HNAME//' IS A LIST OF ARRAYS. USE A' + > //' STEP UP KEYWORD TO ACCESS THE LIST.') + ENDIF + ALLOCATE(IDATA(ILENG2)) + ALLOCATE(JDATA(ILENG2)) + IF( ITYLCM.EQ.3 )THEN + ILENG= ILENG2*4 + ELSE + ILENG= ILENG2 + ENDIF +* +* GET BLOCK + IF(ITYP1.EQ.1) THEN + CALL LCMGDL(IPDATA,ISET ,IDATA) + ELSE IF(ITYP1.EQ.3) THEN + CALL LCMGET(IPDATA,HNAME ,IDATA) + ENDIF +* + CALL REDGET(ITYP,I ,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.1.OR.I.LT.1 ) + > CALL XABORT('DRVGRP: POSITIVE INDEX EXPECTED.') + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + J= I + K= 1 + N= 1 + IF( ITYP.EQ.1 )THEN + J= NITMA + IF( J.LT.I ) + > CALL XABORT('DRVGRP: SECOND INDEX EXPECTED GREATER ' + > //'OR EQUAL THAN FIRST.') + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.EQ.1 )THEN + K= NITMA + IF( K.LT.1 ) + > CALL XABORT('DRVGRP: POSITIVE THIRD INDEX EXPECTED.') + IF( MOD(J-I,K).NE.0 ) + > CALL XABORT('DRVGRP: THIRD INDEX EXPECTED TO BALANCE' + > //' STEPS FROM FIRST TO SECOND INDEX.') + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + ENDIF + N= (J-I)/K + 1 + IF( N.LT.1 ) + > CALL XABORT('DRVGRP: INCONSISTENT NUMBER OF WORDS.') + ELSEIF( (ITYP.EQ.3).AND.(TEXT12.EQ.'*') )THEN + J= ILENG + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.EQ.1 )THEN + K= NITMA + IF( K.LT.1 ) + > CALL XABORT('DRVGRP: POSITIVE THIRD INDEX EXPECTED.') + IF( MOD(J-I,K).NE.0 ) + > CALL XABORT('DRVGRP: THIRD INDEX EXPECTED TO BALANCE' + > //' STEPS FROM FIRST TO SECOND INDEX.') + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + ENDIF + N= (J-I)/K + 1 + IF( N.LT.1 ) + > CALL XABORT('DRVGRP: INCONSISTENT NUMBER OF WORDS.') + ENDIF + IF( TEXT12.EQ.'NVAL' )THEN + IF( N.NE.1.OR.K.NE.1 )THEN + CALL XABORT('DRVGRP: NVALUE ALREADY GIVEN FROM INDEX.') + ENDIF + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.EQ.1)THEN + N= NITMA + IF( N.LT.1 ) + > CALL XABORT('DRVGRP: POSITIVE NVALUE EXPECTED.') + J= I + N - 1 + ELSEIF( (ITYP.EQ.3).AND.(TEXT12.EQ.'*') )THEN + J= ILENG + N= ILENG - I + 1 + ELSE + CALL XABORT('DRVGRP: NVAL IS FOLLOWED BY * OR INTEGER') + ENDIF + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + ENDIF + IF( J.GT.ILENG )THEN + WRITE(HSMG,'(29HDRVGRP: THE VALUE OF INDEX2 (,I8,7H) IS GR, + > 29HEATER THAN THE BLOCK LENGTH (,I8,2H).)') J,ILENG + CALL XABORT(HSMG) + ENDIF + GO TO 30 + ELSEIF( TEXT12.EQ.';' )THEN + GO TO 40 + ELSE + CALL XABORT('DRVGRP: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 20 +*---- +* PROCESSING THE COMMAND NUMBER: IACTIO. +*---- + 30 CONTINUE + NSTP= 1 + NOUT= 0 + ITYPE= ITYLCM + IF( ITYLCM.EQ.1 )THEN +* +* GREP INTEGER DATA + INTMIN= INTGMX + INTMAX=-INTGMX + DO 301 IOUT=I,J,K + NOUT= NOUT+1 + ITRANS= IDATA(IOUT) + JDATA(NOUT)= ITRANS + IF( ITRANS.GT.INTMAX )THEN + INTMAX= ITRANS + INDMAX= IOUT + ENDIF + IF( ITRANS.LT.INTMIN )THEN + INTMIN= ITRANS + INDMIN= IOUT + ENDIF + 301 CONTINUE + IF( IACTIO.EQ.2 )THEN + NOUT= 1 + JDATA(1)= INTMAX + ELSEIF( IACTIO.EQ.3 )THEN + NOUT= 1 + JDATA(1)= INTMIN + ELSEIF( IACTIO.EQ.4 )THEN + NOUT= 1 + JDATA(1)= INDMAX + ITYPE= 1 + ELSEIF( IACTIO.EQ.5 )THEN + NOUT= 1 + JDATA(1)= INDMIN + ITYPE= 1 + ELSEIF( IACTIO.NE.1 )THEN + CALL XABORT('DRVGRP: INVALID ACTION ON INTEGERS') + ENDIF + ELSEIF( ITYLCM.EQ.2 )THEN +* +* GREP REAL DATA + RELMIN= REALMX + RELMAX=-REALMX + RELMNV= 0.0 + DO 302 IOUT=I,J,K + NOUT= NOUT+1 + ITRANS= IDATA(IOUT) + JDATA(NOUT)= ITRANS + IF( ATRANS.GT.RELMAX )THEN + RELMAX= ATRANS + INDMAX= IOUT + ENDIF + IF( ATRANS.LT.RELMIN )THEN + RELMIN= ATRANS + INDMIN= IOUT + ENDIF + RELMNV= RELMNV+ATRANS + 302 CONTINUE + IF( IACTIO.EQ.2 )THEN + NOUT= 1 + ATRANS= RELMAX + JDATA(1)= ITRANS + ELSEIF( IACTIO.EQ.3 )THEN + NOUT= 1 + ATRANS= RELMIN + JDATA(1)= ITRANS + ELSEIF( IACTIO.EQ.4 )THEN + NOUT= 1 + JDATA(1)= INDMAX + ITYPE= 1 + ELSEIF( IACTIO.EQ.5 )THEN + NOUT= 1 + JDATA(1)= INDMIN + ITYPE= 1 + ELSEIF( IACTIO.EQ.6 )THEN + ATRANS= RELMNV/FLOAT(NOUT) + NOUT= 1 + JDATA(1)= ITRANS + ENDIF + ELSEIF( ITYLCM.EQ.3 )THEN + IF( IACTIO.NE.1 )THEN + CALL XABORT('DRVGRP: INVALID ACTION ON STRING') + ELSEIF( (J-I)/K.GT.71 )THEN + CALL XABORT('DRVGRP: STRING HAS LENGTH .GT. 72') + ENDIF + TEXT72= ' ' + IOFSET= 0 + IF( ILENG.GE.72 )THEN + DO 313 IBCHAR= 1, ILENG/72 + WRITE(TEXTIN,'(18A4)') (IDATA(IOFSET+IOUT),IOUT=1,18) + DO 303 IOUT= I,J,K + IF( IOUT.GT.NBCHAR.AND.IOUT.LE.NBCHAR+72 )THEN + NOUT= NOUT+1 + TEXT72(NOUT:NOUT)= TEXTIN(IOUT-NBCHAR:IOUT-NBCHAR) + ENDIF + 303 CONTINUE + IOFSET= IOFSET+18 + NBCHAR= NBCHAR+72 + 313 CONTINUE + ENDIF + NRESID= (ILENG-NBCHAR)/4 + IF( NRESID.GT.0 )THEN + WRITE(TEXTIN,'(18A4)') (IDATA(IOFSET+IOUT),IOUT=1,NRESID) + DO 323 IOUT= I,J,K + IF( IOUT.GT.NBCHAR.AND.IOUT.LE.NBCHAR+NRESID*4 )THEN + NOUT= NOUT+1 + TEXT72(NOUT:NOUT)= TEXTIN(IOUT-NBCHAR:IOUT-NBCHAR) + ENDIF + 323 CONTINUE + ENDIF + NBCHAR= NOUT + NOUT= 1 + ELSEIF( ITYLCM.EQ.4 )THEN +* +* GREP DOUBLE PRECISION DATA + I= I+I + J= J+J + K= K+K + DBLMIN= DBLEMX + DBLMAX=-DBLEMX + DBLMNV= 0.0D0 + DO 304 IOUT=I,J,K + NOUT= NOUT+1 + ISEEME(1)= IDATA(IOUT-1) + ISEEME(2)= IDATA(IOUT) + JDATA(2*NOUT-1)= ISEEME(1) + JDATA(2*NOUT)= ISEEME(2) + IF( DSEEME.GT.DBLMAX )THEN + DBLMAX= DSEEME + INDMAX= IOUT + ENDIF + IF( DSEEME.LT.DBLMIN )THEN + DBLMIN= DSEEME + INDMIN= IOUT + ENDIF + DBLMNV= DBLMNV+DSEEME + 304 CONTINUE + IF( IACTIO.EQ.2 )THEN + NOUT= 1 + DSEEME= DBLMAX + JDATA(1)= ISEEME(1) + JDATA(2)= ISEEME(2) + ELSEIF( IACTIO.EQ.3 )THEN + NOUT= 1 + DSEEME= DBLMIN + JDATA(1)= ISEEME(1) + JDATA(2)= ISEEME(2) + ELSEIF( IACTIO.EQ.4 )THEN + NOUT= 1 + JDATA(1)= INDMAX + ITYPE= 1 + ELSEIF( IACTIO.EQ.5 )THEN + NOUT= 1 + JDATA(1)= INDMIN + ITYPE= 1 + ELSEIF( IACTIO.EQ.6 )THEN + DSEEME= DBLMNV/DBLE(NOUT) + NOUT= 1 + JDATA(1)= ISEEME(1) + JDATA(2)= ISEEME(2) + ENDIF + IF( ITYPE.EQ.4 )THEN + NSTP= 2 + NOUT= 2*NOUT-1 + ENDIF + ELSEIF( ITYLCM.EQ.5 )THEN +* +* GREP LOGICAL DATA + IF( IACTIO.NE.1 )THEN + CALL XABORT('DRVGRP: INVALID ACTION ON LOGICALS') + ENDIF + DO 305 IOUT=I,J,K + NOUT= NOUT+1 + JDATA(NOUT)= IDATA(IOUT) + 305 CONTINUE + ELSE + CALL XABORT('DRVGRP: INVALID DATA TYPE.') + ENDIF + DEALLOCATE(IDATA) +*---- +* PUT CLE-2000 PARMS IN CREATE OR READ/WRITE MODES. +*---- + 310 DO 35 IOUT= 1, NOUT, NSTP + IF( -ITYP.NE.ITYPE )THEN + CALL XABORT('DRVGRP: NOT ENOUGH CLE-2000 PARAMETERS ' + > //'TO CONTAIN ALL VALUES ASKED TO BE PICKED') + ENDIF + ITYP= ITYPE + IF( ITYP.EQ.1.OR.ITYP.EQ.5 )THEN + NITMA= JDATA(IOUT) + IF( IPRINT.GT.0 )THEN + IF( ITYP.EQ.1 )THEN + WRITE(6,*) CLOGBG(ITYP),TEXT12,'<-',NITMA + ELSE + IF( NITMA.EQ.+1 )THEN + WRITE(6,*) CLOGBG(ITYP),TEXT12,'<- $True_L' + ELSEIF( NITMA.EQ.-1 )THEN + WRITE(6,*) CLOGBG(ITYP),TEXT12,'<- $False_L' + ELSE + WRITE(6,*) CLOGBG(ITYP),TEXT12,'<- ?_L' + ENDIF + ENDIF + ENDIF + ELSEIF( ITYP.EQ.2 )THEN + ITRANS= JDATA(IOUT) + FLOTT= ATRANS + IF( IPRINT.GT.0 )THEN + WRITE(6,*)CLOGBG(ITYP),TEXT12,'<-',FLOTT + ENDIF + ELSEIF( ITYP.EQ.3 )THEN + NITMA=NBCHAR + IF( IPRINT.GT.0 )THEN + WRITE(6,*)CLOGBG(ITYP),TEXT12,'<-"',TEXT72(1:NBCHAR),'"' + ENDIF + ELSEIF( ITYP.EQ.4 )THEN + ISEEME(1)= JDATA(IOUT) + ISEEME(2)= JDATA(IOUT+1) + DFLOTT= DSEEME + IF( IPRINT.GT.0 )THEN + WRITE(6,*)CLOGBG(ITYP),TEXT12,'<-',DFLOTT + ENDIF + ENDIF + CALL REDPUT(ITYP,NITMA,FLOTT,TEXT72,DFLOTT) + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + 35 CONTINUE + DEALLOCATE(JDATA) + GO TO 25 +*---- +* ENDING COMMANDS: CHECK UP/DOWN BALANCE AND REMAINING PARMS. +*---- + 40 CONTINUE + RETURN + END diff --git a/Ganlib/src/DRVMO1.f b/Ganlib/src/DRVMO1.f new file mode 100644 index 0000000..dd67f89 --- /dev/null +++ b/Ganlib/src/DRVMO1.f @@ -0,0 +1,47 @@ +*DECK DRVMO1 + SUBROUTINE DRVMO1(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* dummy call to be replaced by a user-specific module. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object or file unit address. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY + CHARACTER HENTRY(NENTRY)*12 + INTEGER IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) +* + WRITE(6,*) 'DRVMO1: USER-SPECIFIC MODULE.' + DO I=1,NENTRY + WRITE(6,*) HENTRY(I),IENTRY(I),JENTRY(I) + IF(IENTRY(I).LE.2) CALL LCMLIB(KENTRY(I)) + ENDDO + RETURN + END diff --git a/Ganlib/src/DRVMPI.F b/Ganlib/src/DRVMPI.F new file mode 100644 index 0000000..855ad4d --- /dev/null +++ b/Ganlib/src/DRVMPI.F @@ -0,0 +1,234 @@ +#if defined(MPI) +*DECK DRVMPI + SUBROUTINE DRVMPI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +* MPI INITIALIZATION. +* +* INPUT/OUTPUT PARAMETERS: +* NENTRY : NUMBER OF LCM OBJECTS AND FILES USED BY THE MODULE. +* HENTRY : CHARACTER*12 NAME OF EACH LCM OBJECT OR FILE. +* IENTRY : =1 LCM OBJECT; =2 XSM FILE; +* =3 SEQUENTIAL BINARY FILE; =4 SEQUENTIAL ASCII FILE; +* =5 DIRECT ACCESS FILE. +* JENTRY : =0 THE LCM OBJECT OR FILE IS CREATED. +* =1 THE LCM OBJECT OR FILE IS OPEN FOR MODIFICATIONS; +* =2 THE LCM OBJECT OR FILE IS OPEN IN READ-ONLY MODE. +* KENTRY : =FILE UNIT NUMBER; =LCM OBJECT ADDRESS OTHERWISE. +* DIMENSION HENTRY(NENTRY),IENTRY(NENTRY),JENTRY(NENTRY), +* KENTRY(NENTRY) +* +*--------------------------------------- AUTHOR: R.CHAMBON ; 04/2003 --- +* + USE GANLIB + include 'mpif.h' +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12 + LOGICAL LLCMCR + INTEGER BGLOOP,EDLOOP,NTLOOP,ITYP,INIPOS + INTEGER IPRINT + REAL FLOTT,FLOTT2 + INTEGER NITMA,NITMA2 + DOUBLE PRECISION DFLOTT,DFLOTT2,DTIME + INTEGER*4 RANK32,SIZE32,IPROC,IERR + INTEGER RANK,SIZE +*---- +* ALLOCATABLE STATEMENTS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOSBG,INBPOS + +#if defined(__x86_64__) +# define M64 2 +#else +# define M64 1 +#endif + +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.GE.2) THEN + CALL XABORT('DRVMPI: ONE ENTRY MAX EXPECTED') + ENDIF + IF(NENTRY.EQ.1) THEN + IF(JENTRY(1).NE.0) THEN + CALL XABORT('DRVMPI: IF ONE ENTRY, HAS TO BE' + 1 //' IN CREATE MODE'//HENTRY(1)) + ELSEIF((IENTRY(1).LE.0).OR.(IENTRY(1).GE.3)) THEN + CALL XABORT('DRVMPI: ONE ENTRY, HAS TO BE' + 1 //' LINKED_LIST OR XSM_FILE'//HENTRY(1)) + ELSE + LLCMCR=.TRUE. + WRITE(6,*) 'LLCMCR : ',LLCMCR + ENDIF + CALL LCMVAL(KENTRY(1),' ') + ENDIF +* + IPRINT= 0 + + CALL MPI_COMM_RANK(MPI_COMM_WORLD,RANK32,IERR) + RANK=RANK32 + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,SIZE32,IERR) + SIZE=SIZE32 + + ALLOCATE(IPOSBG(SIZE),INBPOS(SIZE)) +*---- +* READ INPUT +*---- + 20 CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.3 ) CALL XABORT('DRVMPI: CHARACTER DATA EXPECTED.') +* EDITION LEVEL + IF( TEXT12.EQ.'EDIT' )THEN + CALL REDGET(ITYP,IPRINT,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.1 ) CALL XABORT('DRVMPI: NO INTEGER AFTER *EDIT*.') +* TOTAL NUMBER OF CPU + ELSEIF( TEXT12.EQ.'WORLD-SIZE' )THEN + CALL REDGET(ITYP,NTLOOP,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.-1 ) CALL XABORT('DRVMPI: NO INTEGER VARIABLE '// + 1 'AFTER *SETLOOP*.') + ITYP = 1 + CALL REDPUT(ITYP,SIZE,FLOTT,TEXT12,DFLOTT) + IF(IPRINT.GE.1) WRITE(6,1000) SIZE +* CPU NUMBER + ELSEIF( TEXT12.EQ.'MY-ID' )THEN + CALL REDGET(ITYP,NTLOOP,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.-1 ) CALL XABORT('DRVMPI: NO INTEGER VARIABLE '// + 1 'AFTER *SETLOOP*.') + ITYP = 1 + CALL REDPUT(ITYP,RANK,FLOTT,TEXT12,DFLOTT) + IF(IPRINT.GE.1) WRITE(6,1010) RANK +* CPU REPARTITION FOR A LOOP + ELSEIF( TEXT12.EQ.'SETLOOP' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3.AND.TEXT12.NE.'B0'.AND.TEXT12.NE.'B1' ) THEN + CALL XABORT('DRVMPI: BO OR B1 KEYWORD EXPECTED '// + 1 'AFTER *SETLOOP*.') + ENDIF + INIPOS=-99999 + IF(TEXT12.EQ.'B0') INIPOS=0 + IF(TEXT12.EQ.'B1') INIPOS=1 + CALL REDGET(ITYP,NTLOOP,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.1 ) CALL XABORT('DRVMPI: NO INTEGER '// + 1 'AFTER *SETLOOP*.') + CALL REDGET(ITYP,BGLOOP,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.-1 ) CALL XABORT('DRVMPI: NO INTEGER VARIABLE '// + 1 'AFTER *SETLOOP*.') + CALL REDGET(ITYP,EDLOOP,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.-1 ) CALL XABORT('DRVMPI: NO INTEGER VARIABLE '// + 1 'AFTER *SETLOOP*.') + IF(SIZE.GT.NTLOOP) THEN + DO 3 IPROC=0,SIZE-1 + IPOSBG(IPROC+1)=MIN0(IPROC,NTLOOP-1)+INIPOS + INBPOS(IPROC+1)=1 + 3 CONTINUE + ELSE + DO 4 IPROC=0,SIZE-1 + IPOSBG(IPROC+1) = INIPOS + + 1 IPROC * (NTLOOP / SIZE) + MIN0(IPROC, MOD(NTLOOP, SIZE)) + INBPOS(IPROC+1) = + 1 (NTLOOP / SIZE) + MIN0(1, MOD(NTLOOP, SIZE)/(IPROC + 1)) + 4 CONTINUE + ENDIF + BGLOOP=IPOSBG(RANK+1) + EDLOOP=IPOSBG(RANK+1)+INBPOS(RANK+1)-1 + ITYP = 1 + CALL REDPUT(ITYP,EDLOOP,FLOTT,TEXT12,DFLOTT) + CALL REDPUT(ITYP,BGLOOP,FLOTT,TEXT12,DFLOTT) + IF(IPRINT.GE.1) THEN + WRITE(6,1020) BGLOOP,EDLOOP + IF(IPRINT.GE.2) THEN + WRITE (6,1030) + DO 5 IPROC=0,SIZE-1 + WRITE (6,1031) IPROC,IPOSBG(IPROC+1), + 1 IPOSBG(IPROC+1)+INBPOS(IPROC+1)-1 + 5 CONTINUE + ENDIF + ENDIF +* REDUCTION OPERATION + ELSEIF( TEXT12.EQ.'ALLREDUCE' )THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.3.AND.TEXT12.NE.'SUM'.AND.TEXT12.NE.'PROD' + 1 .AND.TEXT12.NE.'MAX'.AND.TEXT12.NE.'MIN') THEN + CALL XABORT('DRVMPI: REDUCE OPERATOR KEYWORD EXPECTED '// + 1 'AFTER *ALLREDUCE*.') + ENDIF + IF(TEXT12.EQ.'SUM') IOPERT=MPI_SUM + IF(TEXT12.EQ.'PROD') IOPERT=MPI_PROD + IF(TEXT12.EQ.'MAX') IOPERT=MPI_MAX + IF(TEXT12.EQ.'MIN') IOPERT=MPI_MIN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF( ITYP.NE.1.AND.ITYP.NE.2.AND.ITYP.NE.4 ) + 1 CALL XABORT('DRVMPI: SCALAR VARIABLE TO REDUCE '// + 2 'EXPECTED FOR *ALLREDUCE*.') + ITYPE=ITYP + CALL REDGET(ITYP,NITMA2,FLOTT2,TEXT12,DFLOTT2) + IF(-ITYP.NE.ITYPE ) CALL XABORT('DRVMPI: DESTINATION '// + 1 'AND SOURCE NOT SAME TYPE FOR *ALLREDUCE*.') + IF( ITYPE.EQ.1 ) THEN + CALL MPI_ALLREDUCE(NITMA,NITMA2,1*M64,MPI_INTEGER, + 1 IOPERT,MPI_COMM_WORLD,IERR) + CALL REDPUT(ITYPE,NITMA2,FLOTT2,TEXT12,DFLOTT2) + IF(IPRINT.GE.1) + 1 WRITE(6,*) 'RESULT OF THE ALLREDUCE',NITMA2 + ELSEIF( ITYPE.EQ.2 ) THEN + CALL MPI_ALLREDUCE(FLOTT,FLOTT2,1*M64,MPI_REAL, + 1 IOPERT,MPI_COMM_WORLD,IERR) + CALL REDPUT(ITYPE,NITMA2,FLOTT2,TEXT12,DFLOTT2) + IF(IPRINT.GE.1) + 1 WRITE(6,*) 'RESULT OF THE ALLREDUCE',FLOTT2 + ELSEIF( ITYPE.EQ.4 ) THEN + CALL MPI_ALLREDUCE(DFLOTT,DFLOTT2,1*M64,MPI_DOUBLE_PRECISION, + 1 IOPERT,MPI_COMM_WORLD,IERR) + CALL REDPUT(ITYPE,NITMA2,FLOTT2,TEXT12,DFLOTT2) + IF(IPRINT.GE.1) + 1 WRITE(6,*) 'RESULT OF THE ALLREDUCE',DFLOTT2 + ELSE + CALL XABORT('DRVMPI: NO LOGICAL OR STRING VARIABLE '// + 1 'ACCEPTED FOR *ALLREDUCE*.') + ENDIF +* TIME + ELSEIF( TEXT12.EQ.'TIME' )THEN + CALL REDGET(ITYP,NTLOOP,FLOTT,TEXT12,DTIME) + IF( ITYP.NE.-4 ) CALL XABORT('DRVMPI: NO DOUBLE VARIABLE ' // + 1 'AFTER *TIME*.') + ITYP = 4 + DTIME = MPI_WTIME() + CALL REDPUT(ITYP,SIZE,FLOTT,TEXT12,DTIME) + IF(IPRINT.GE.1) WRITE(6,1040) DTIME +* BARRIER + ELSEIF( TEXT12.EQ.'BARRIER' )THEN + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) + IF(IPRINT.GE.1) WRITE(6,1050) +* END OF THIS SUBROUTINE + ELSEIF( TEXT12.EQ.';' )THEN + GO TO 40 + ELSE + CALL XABORT('DRVMPI: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 20 +*---- +* END OF INPUT OPTIONS +*---- + 40 DEALLOCATE(INBPOS,IPOSBG) + RETURN +*---- +* FORMATS +*---- + 1000 FORMAT(35H TOTAL NUMBER OF CPU (WORLD-SIZE): ,I4) + 1010 FORMAT(35H NUMBER OF THIS CPU (MY-ID) : ,I4) + 1020 FORMAT(35H FOR THIS CPU: BEGIN LOOP (BGLOOP) ,I8, + 1 20H END LOOP (EDLOOP) ,I8) + 1030 FORMAT(37H FOR CPU #: BEGIN LOOP - END LOOP) + 1031 FORMAT(4H # ,I4,2X,1H:,1X,I8,5X,1H-,1X,I8) + 1040 FORMAT(35H TIME (DTIME): ,D20.14) + 1050 FORMAT(35H ALL CPU HAVE BEEN SYNCHRONISED. ) + END +#endif /* defined(MPI) */ diff --git a/Ganlib/src/DRVMPX.f b/Ganlib/src/DRVMPX.f new file mode 100644 index 0000000..8fe70ff --- /dev/null +++ b/Ganlib/src/DRVMPX.f @@ -0,0 +1,72 @@ +*DECK DRVMPX + SUBROUTINE DRVMPX(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +* STANDARD MULTIPLICATION MODULE. +* +* INPUT/OUTPUT PARAMETERS: +* NENTRY : NUMBER OF LINKED LISTS AND FILES USED BY THE MODULE. +* HENTRY : CHARACTER*12 NAME OF EACH LINKED LIST OR FILE. +* IENTRY : =0 CLE-2000 VARIABLE; =1 LINKED LIST; =2 XSM FILE; +* =3 SEQUENTIAL BINARY FILE; =4 SEQUENTIAL ASCII FILE. +* JENTRY : =0 THE LINKED LIST OR FILE IS CREATED. +* =1 THE LINKED LIST OR FILE IS OPEN FOR MODIFICATIONS; +* =2 THE LINKED LIST OR FILE IS OPEN IN READ-ONLY MODE. +* KENTRY : =FILE UNIT NUMBER; =LINKED LIST ADDRESS OTHERWISE. +* DIMENSION HENTRY(NENTRY),IENTRY(NENTRY),JENTRY(NENTRY), +* KENTRY(NENTRY) +* +*-------------------------------------- AUTHOR: A. HEBERT ; 23/07/94 --- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPLIST1 + CHARACTER HSMG*131,TEXT4*4,TEXT12*12 + DOUBLE PRECISION DFLOTT +* +* PARAMETER VALIDATION. + IF(NENTRY.EQ.0) CALL XABORT('DRVMPX: ONE PARAMETER EXPECTED.') + TEXT12=HENTRY(1) + IF((JENTRY(1).EQ.2).OR.(IENTRY(1).GT.2)) CALL XABORT('DRVMPX: LIN' + 1 //'KED LIST OR XSM FILE IN CREATION OR MODIFICATION MODE EXPECTE' + 2 //'D AT LHS ('//TEXT12//').') +* +* COPY THE RHS INTO THE LHS. + IF(JENTRY(1).EQ.0) THEN + IF(NENTRY.LE.1) CALL XABORT('DRVMPX: TWO PARAMETERS EXPECTED.') + IF((JENTRY(2).NE.2).OR.(IENTRY(2).GT.2)) CALL XABORT('DRVMPX: ' + 1 //'LINKED LIST OR XSM FILE IN READ-ONLY MODE EXPECTED AT RHS.') + NUNIT=KDROPN('DUMMYSQ',0,2,0) + IF(NUNIT.LE.0) CALL XABORT('DRVMPX: KDROPN FAILURE.') + CALL LCMEXP(KENTRY(2),0,NUNIT,1,1) + REWIND(NUNIT) + CALL LCMEXP(KENTRY(1),0,NUNIT,1,2) + IERR=KDRCLS(NUNIT,2) + IF(IERR.LT.0) THEN + WRITE(HSMG,'(29HDRVMPX: KDRCLS FAILURE. IERR=,I3)') IERR + CALL XABORT(HSMG) + ENDIF + ENDIF +* +* READ THE REAL NUMBER + CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT) + IF(ITYP.NE.2) CALL XABORT('DRVMPX: REAL DATA EXPECTED.') + CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT) + IF((ITYP.NE.3).OR.(TEXT4.NE.';')) THEN + CALL XABORT('DRVMPX: ; EXPECTED.') + ENDIF +* +* PERFORM THE MULTIPLICATION. + IPLIST1=KENTRY(1) + CALL LCMULT(IPLIST1,FLOTT) + RETURN + END diff --git a/Ganlib/src/DRVREC.f b/Ganlib/src/DRVREC.f new file mode 100644 index 0000000..b9cdd4a --- /dev/null +++ b/Ganlib/src/DRVREC.f @@ -0,0 +1,149 @@ +*DECK DRVREC + SUBROUTINE DRVREC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover one or many LCM objects. +* +*Copyright: +* Copyright (C) 1994 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): read-only or modification type(VECTOR). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPLIST,JPLIST,KPLIST + CHARACTER HMEDIA*12,TEXT12*12,TEXT4*4,NAMT*12 + DOUBLE PRECISION DFLOTT +* + IF(NENTRY.LE.1) CALL XABORT('DRVREC: TWO PARAMETERS EXPECTED.') + ITYPE=0 + JPLIST=C_NULL_PTR + DO 10 I=1,NENTRY + IF(JENTRY(I).EQ.2) THEN + ITYPE=IENTRY(I) + IPLIST=KENTRY(I) + HMEDIA=HENTRY(I) + IF((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2)) CALL XABORT('DRVREC:' + 1 //' RHS LINKED LIST OR XSM FILE EXPECTED.') + GO TO 20 + ENDIF + 10 CONTINUE + CALL XABORT('DRVREC: UNABLE TO FIND A BACKUP MEDIA OPEN IN READ-O' + 1 //'NLY MODE.') +* + 20 IMPX=1 + IPOS=0 + 30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 40 + IF(INDIC.NE.3) CALL XABORT('DRVREC: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVREC: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'ITEM') THEN + CALL REDGET(INDIC,IPOS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVREC: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'STEP') THEN +* CHANGE THE HIERARCHICAL LEVEL ON THE LCM OBJECT. + IF(ITYPE.GT.2) CALL XABORT('DRVREC: UNABLE TO STEP INTO A SE' + 1 //'QUENTIAL FILE.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVREC: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'UP') THEN + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVREC: CHARACTER DATA EXPECT' + 1 //'ED.') + IF(IMPX.GT.0) WRITE (6,100) NAMT + JPLIST=LCMGID(IPLIST,NAMT) + ELSE IF(TEXT4.EQ.'AT') THEN + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVREC: INTEGER EXPECTED.') + IF(IMPX.GT.0) WRITE (6,110) NITMA + JPLIST=LCMGIL(IPLIST,NITMA) + ELSE + CALL XABORT('DRVREC: UP OR AT EXPECTED.') + ENDIF + IPLIST=JPLIST + ELSE IF(TEXT4.EQ.';') THEN + GO TO 40 + ELSE + CALL XABORT('DRVREC: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 30 +* + 40 CALL LCMGTC(IPLIST,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_ARCHIVE') THEN + CALL XABORT('DRVREC: SIGNATURE OF '//HMEDIA//' IS '//TEXT12// + 1 '. L_ARCHIVE EXPECTED.') + ENDIF + DO 50 I=1,NENTRY-1 + IF((JENTRY(I).EQ.0).OR.(JENTRY(I).EQ.1)) THEN + IF(IENTRY(I).GT.2) CALL XABORT('DRVREC: LHS LINKED LIST OR XSM' + 1 //' FILE EXPECTED.') + IF(IMPX.GT.0) THEN + IF(IPOS.EQ.0) THEN + WRITE (6,'(/18H DRVREC: RECOVER '',A,8H'' FROM '',A, + 1 2H''.)') TRIM(HENTRY(I)),TRIM(HMEDIA) + ELSE + WRITE (6,'(/22H DRVREC: RECOVER ITEM=,I5,5H OF '',A, + 1 8H'' FROM '',A,2H''.)') IPOS,TRIM(HENTRY(I)),TRIM(HMEDIA) + ENDIF + ENDIF + TEXT12=HENTRY(I) + CALL LCMLEN(IPLIST,TEXT12,ILEN,ITYLCM) + IF(ILEN.EQ.0) THEN + CALL LCMLIB(IPLIST) + CALL XABORT('DRVREC: UNABLE TO FIND '//TEXT12//' ON THE BA' + 1 //'CKUP MEDIA NAMED '//HMEDIA//'.') + ELSE IF(ITYLCM.EQ.0) THEN + IF(IPOS.NE.0) CALL XABORT('DRVREC: RECORD '//TEXT12//' ON ' + 1 //'THE BACKUP MEDIA NAMED '//HMEDIA//' IS NOT A DIRECTORY.') + CALL LCMSIX(IPLIST,HENTRY(I),1) + CALL LCMEQU(IPLIST,KENTRY(I)) + CALL LCMSIX(IPLIST,' ',2) + ELSE IF(ITYLCM.EQ.10) THEN + IF(IPOS.EQ.0) CALL XABORT('DRVREC: RECORD '//TEXT12//' ON ' + 1 //'THE BACKUP MEDIA NAMED '//HMEDIA//' IS NOT A LIST.') + JPLIST=LCMGID(IPLIST,HENTRY(I)) + KPLIST=LCMGIL(JPLIST,IPOS) + CALL LCMEQU(KPLIST,KENTRY(I)) + ELSE + CALL LCMLIB(IPLIST) + CALL XABORT('DRVREC: RECORD '//TEXT12//' ON THE BACKUP MED' + 1 //'IA NAMED '//HMEDIA//' CANNOT BE COPIED.') + ENDIF + ENDIF + 50 CONTINUE + RETURN +* + 100 FORMAT (/27H DRVREC: STEP UP TO LEVEL ',A12,2H'.) + 110 FORMAT (/26H DRVREC: STEP AT COMPONENT,I6,1H.) + END diff --git a/Ganlib/src/DRVSTA.f b/Ganlib/src/DRVSTA.f new file mode 100644 index 0000000..23108a4 --- /dev/null +++ b/Ganlib/src/DRVSTA.f @@ -0,0 +1,53 @@ +*DECK DRVSTA + SUBROUTINE DRVSTA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +* STANDARD COMPARE MODULE. +* +* INPUT/OUTPUT PARAMETERS: +* NENTRY : NUMBER OF LINKED LISTS AND FILES USED BY THE MODULE. +* HENTRY : CHARACTER*12 NAME OF EACH LINKED LIST OR FILE. +* IENTRY : =0 CLE-2000 VARIABLE; =1 LINKED LIST; =2 XSM FILE; +* =3 SEQUENTIAL BINARY FILE; =4 SEQUENTIAL ASCII FILE; +* =5 DIRECT ACCESS FILE. +* JENTRY : =0 THE LINKED LIST OR FILE IS CREATED. +* =1 THE LINKED LIST OR FILE IS OPEN FOR MODIFICATIONS; +* =2 THE LINKED LIST OR FILE IS OPEN IN READ-ONLY MODE. +* KENTRY : =FILE UNIT NUMBER; =LINKED LIST STARESS OTHERWISE. +* DIMENSION HENTRY(NENTRY),IENTRY(NENTRY),JENTRY(NENTRY), +* KENTRY(NENTRY) +* +*-------------------------------------- AUTHOR: A. HEBERT ; 21/12/93 --- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12 + TYPE(C_PTR) IPLIST1,IPLIST2 +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.1) CALL XABORT('DRVSTA: TWO PARAMETER EXPECTED.') + TEXT12=HENTRY(1) + IF((JENTRY(1).NE.2).OR.(IENTRY(1).GT.2)) CALL XABORT('DRVSTA: LIN' + 1 //'KED LIST OR XSM FILE IN READ-ONLY MODE EXPECTED AT RHS (' + 2 //TEXT12//').') + IF((JENTRY(2).NE.2).OR.(IENTRY(2).GT.2)) CALL XABORT('DRVSTA: LIN' + 1 //'KED LIST OR XSM FILE IN READ-ONLY MODE EXPECTED AT RHS (' + 2 //TEXT12//').') +*---- +* PERFORM THE COMPARISON. +*---- + IPLIST1=KENTRY(1) + IPLIST2=KENTRY(2) + CALL LCMSTA(IPLIST2,IPLIST1) + RETURN + END diff --git a/Ganlib/src/DRVUF5.f90 b/Ganlib/src/DRVUF5.f90 new file mode 100644 index 0000000..ce2e12e --- /dev/null +++ b/Ganlib/src/DRVUF5.f90 @@ -0,0 +1,382 @@ +subroutine DRVUH5(nentry,hentry,ientry,jentry,kentry) + ! + !----------------------------------------------------------------------- + ! + !Purpose: + ! standard utility module for HDF5 files. + ! + !Copyright: + ! Copyright (C) 2021 Ecole Polytechnique de Montreal + ! This library is free software; you can redistribute it and/or + ! modify it under the terms of the GNU Lesser General Public + ! License as published by the Free Software Foundation; either + ! version 2.1 of the License, or (at your option) any later version + ! + !Author(s): A. Hebert + ! + !Parameters: input/output + ! NENTRY number of LCM objects or files used by the operator. + ! HENTRY name of each LCM object or file: + ! HENTRY(1): read-only or modification type(HDF5_FILE). + ! IENTRY type of each LCM object or file: + ! =1 LCM memory object; =2 XSM file; =3 sequential binary file; + ! =4 sequential ascii file; =6 HDF5 file. + ! JENTRY access of each LCM object or file: + ! =0 the LCM object or file is created; + ! =1 the LCM object or file is open for modifications; + ! =2 the LCM object or file is open in read-only mode. + ! KENTRY LCM object address or file unit number. + ! + ! List of utility actions: + ! DIR : print the table of content. + ! INFO : print information about a dataset. + ! TEST : test if a group exists. + ! IMPR : print a dataset. + ! CREA : create a group or a dataset. + ! DELE : delete a group or a dataset. + ! COPY : cCopy a group or a dataset from one location to another. + ! GREP : recover a single component in a dataset of rank 1. + ! + !----------------------------------------------------------------------- + ! + use hdf5_wrap + use, intrinsic :: iso_c_binding + use, intrinsic :: iso_fortran_env + !---- + ! subroutine arguments + !---- + integer :: nentry,ientry(nentry),jentry(nentry) + type(c_ptr) :: kentry(nentry) + character(len=12) :: hentry(nentry) + !---- + ! local variables + !---- + character :: text4*4,text12*12,text72*72,text72_s*12,hsmg*131 + integer :: dimsr(5) + integer :: rank,type,nbyte + double precision :: dflott + type(c_ptr) :: my_hdf5,my_hdf5_s + !---- + ! allocatable arrays + !---- + integer, allocatable, dimension(:) :: nitmaV1 + integer, allocatable, dimension(:,:) :: nitmaV2 + character(len=32) :: text32V0 + character(len=64) :: text64V0 + character(len=32), allocatable, dimension(:) :: text32V1 + character(len=64), allocatable, dimension(:) :: text64V1 + real, allocatable, dimension(:) :: flottV1 + real, allocatable, dimension(:,:) :: flottV2 + double precision, allocatable, dimension(:) :: dflottV1 + double precision, allocatable, dimension(:,:) :: dflottV2 + !---- + ! parameter validation. + !---- + if(nentry.eq.0) call XABORT('DRVUH5: parameter expected.') + text12=hentry(1) + ind=jentry(1) + if(ientry(1).ne.6) call XABORT('DRVUH5: the utility module works on' & + & //'ly for hdf5 files.') + my_hdf5=kentry(1) + !---- + ! perform some utility actions. + !---- + 10 call REDGET(indic,nitma,flott,text4,dflott) + if(indic.ne.3) call XABORT('DRVUH5: character data expected.') + 20 if(text4.eq.'DIR') then + ! print the group content + flush(OUTPUT_UNIT) + call REDGET(indprt,nitma,flott,text72,dflott) + if(indprt.ne.3) call XABORT('DRVUH5: dataset name expected.') + if((text72.eq.'INFO').or.(text72.eq.'TEST').or.(text72.eq.'IMPR').or. & + (text72.eq.'CREA').or.(text72.eq.'DELE').or.(text72.eq.'DIR').or. & + (text72.eq.'COPY').or.(text72.eq.'GREP').or.(text72.eq.';')) then + text4=text72(:4) + call hdf5_list(my_hdf5,' ') + go to 20 + endif + call hdf5_list(my_hdf5,text72) + else if(text4.eq.'INFO') then + ! print a dataset. + call REDGET(indprt,nitma,flott,text72,dflott) + if(indprt.ne.3) call XABORT('DRVUH5: dataset name expected.') + call hdf5_info(my_hdf5,text72,rank,type,nbyte,dimsr) + write(6,'(/32h DRVUF5: information on dataset ,a,1h:)') text72 + write(6,*) 'rank=',rank,' type=',type,' nbyte=',nbyte,' dimsr=',dimsr(:rank) + else if(text4.eq.'TEST') then + ! test if a group exists. + call REDGET(indprt,nitma,flott,text72,dflott) + if(indprt.ne.3) call XABORT('DRVUH5: dataset name expected.') + if (hdf5_group_exists(my_hdf5,text72)) then + write(6,'(/15h DRVUF5: group ,a,8h exists.)') trim(text72) + else + write(6,'(/15h DRVUF5: group ,a,15h doesn''t exist.)') trim(text72) + endif + else if(text4.eq.'IMPR') then + ! print a dataset. + call REDGET(indprt,nitma,flott,text72,dflott) + if(indprt.ne.3) call XABORT('DRVUH5: dataset name expected.') + call hdf5_info(my_hdf5,text72,rank,type,nbyte,dimsr) + write(6,'(/29h DRVUF5: printout of dataset ,a,1h:)') text72 + if(type.eq.1) then + if((rank.eq.1).and.(dimsr(1).eq.1)) then + call hdf5_read_data(my_hdf5,text72,nitma) + write(6,'(4x,i12)') nitma + else if(rank.eq.1) then + call hdf5_read_data(my_hdf5,text72,nitmaV1) + write(6,'(4x,10i12)') nitmaV1(:) + deallocate(nitmaV1) + else if(rank.eq.2) then + call hdf5_read_data(my_hdf5,text72,nitmaV2) + write(6,'(4x,10i12)') nitmaV2(:,:) + deallocate(nitmaV2) + else + write(hsmg,100) type,rank + call XABORT(hsmg) + endif + else if(type.eq.2) then + if((rank.eq.1).and.(dimsr(1).eq.1)) then + call hdf5_read_data(my_hdf5,text72,flott) + write (6,'(1x,1p,e13.4)') flott + else if(rank.eq.1) then + call hdf5_read_data(my_hdf5,text72,flottV1) + write (6,'(1x,1p,10e13.4)') flottV1(:) + deallocate(flottV1) + else if(rank.eq.2) then + call hdf5_read_data(my_hdf5,text72,flottV2) + write (6,'(1x,1p,10e13.4)') flottV2(:,:) + deallocate(flottV2) + else + write(hsmg,100) type,rank + call XABORT(hsmg) + endif + else if(type.eq.3) then + if((rank.eq.1).and.(dimsr(1).eq.1)) then + if(nbyte.le.32) then + call hdf5_read_data(my_hdf5,text72,text32V0) + write(6,'(4x,a)') text32V0 + else + call hdf5_read_data(my_hdf5,text72,text64V0) + write(6,'(4x,a)') text64V0 + endif + else if(rank.eq.1) then + if(nbyte.le.32) then + call hdf5_read_data(my_hdf5,text72,text32V1) + write(6,'(4x,5a32)') text32V1(:) + deallocate(text32V1) + else + call hdf5_read_data(my_hdf5,text72,text64V1) + write(6,'(4x,3a64)') text64V1(:) + deallocate(text64V1) + endif + else + write(hsmg,100) type,rank + call XABORT(hsmg) + endif + else if(type.eq.4) then + if((rank.eq.1).and.(dimsr(1).eq.1)) then + call hdf5_read_data(my_hdf5,text72,dflott) + write (6,'(1x,1p,d21.12)') dflott + else if(rank.eq.1) then + call hdf5_read_data(my_hdf5,text72,dflottV1) + write (6,'(1x,1p,6d21.12)') dflottV1(:) + deallocate(dflottV1) + else if(rank.eq.2) then + call hdf5_read_data(my_hdf5,text72,dflottV2) + write (6,'(1x,1p,6d21.12)') dflottV2(:,:) + deallocate(dflottV2) + else + write(hsmg,100) type,rank + call XABORT(hsmg) + endif + else + write(hsmg,100) type,rank + call XABORT(hsmg) + endif + else if(text4.eq.'CREA') then + if(ind.eq.2) call XABORT('DRVUF5: CREA is a forbidden operation in read-only mode.') + call REDGET(ntype,iset,flott,text72,dflott) + indico=0 + ilong0=0 + if(ntype.eq.3) then + call hdf5_info(my_hdf5,text72,rank,indico,nbyte,dimsr) + if(rank.gt.1) call XABORT('DRVUF5: rank>1 forbidden.') + ilong0=nbyte/4 + else + call XABORT('DRVUF5: character data expected.') + endif + call REDGET(indic,nitma,flott,text4,dflott) + if(indic.eq.1) then + ilong2=nitma + else if((indic.eq.3).and.(text4.eq.'=')) then + call REDGET(indic,nitma,float,text4,dflott) + if(indic.eq.1) then + call hdf5_write_data(my_hdf5, text72, nitma) + else if(indic.eq.2) then + call hdf5_write_data(my_hdf5, text72, float) + else if(indic.eq.3) then + call hdf5_write_data(my_hdf5, text72, text4) + else if(indic.eq.4) then + call hdf5_write_data(my_hdf5, text72, dflott) + else + call XABORT('DRVUF5: invalid type.') + endif + go to 10 + else if(indic.eq.3) then + call hdf5_create_group(my_hdf5, text72) + go to 20 + else + call XABORT('DRVUF5: integer, character data or = expected.') + endif + ilong1=1 + 30 call REDGET(indic,ilong,flott,text4,dflott) + if(indic.eq.1) then + if(ilong0.eq.0) call XABORT('DRVUF5: lower index not expected.') + ilong1=ilong2 + ilong2=ilong + go to 30 + else if((indic.ne.3).or.(text4.ne.'=')) then + call XABORT('DRVUF5: = sign expected.') + endif + call REDGET(indic,nitma,float,text4,dflott) + if(indico.eq.99) then + indico=indic + else if(indic.ne.indico) then + call XABORT('DRVUF5: inconsistent data type(1).') + endif + if(indic.eq.1) then + if(ilong0.ne.0) then + call hdf5_read_data(my_hdf5, text72, nitmaV1) + else + allocate(nitmaV1(ilong2)) + endif + nitmaV1(ilong1)=nitma + else if(indic.eq.2) then + if(ilong0.ne.0) then + call hdf5_read_data(my_hdf5, text72, flottV1) + else + allocate(flottV1(ilong2)) + endif + flottV1(ilong1)=float + else if(indic.eq.3) then + if(ilong0.ne.0) then + call hdf5_read_data(my_hdf5, text72, text32V1) + else + allocate(text32V1(ilong2)) + endif + text32V1(ilong1)=text4 + else if(indic.eq.4) then + if(ilong0.ne.0) then + call hdf5_read_data(my_hdf5, text72, dflottV1) + else + allocate(dflottV1(ilong2)) + endif + dflottV1(ilong1)=dflott + endif + do i=ilong1+1,ilong2 + call REDGET(indic,nitma,float,text4,dflott) + if(indic.ne.indico) then + call XABORT('DRVUF5: inconsistent data type(2).') + else if(indic.eq.1) then + nitmaV1(i)=nitma + else if(indic.eq.2) then + flottV1(i)=float + else if(indic.eq.3) then + text32V1(i)=text4 + else if(indic.eq.4) then + dflottV1(i)=dflott + endif + enddo + if(indico.eq.1) then + call hdf5_write_data(my_hdf5, text72, nitmaV1) + deallocate(nitmaV1) + else if(indico.eq.2) then + call hdf5_write_data(my_hdf5, text72, flottV1) + deallocate(flottV1) + else if(indico.eq.3) then + call hdf5_write_data(my_hdf5, text72, text32V1) + deallocate(text32V1) + else if(indico.eq.4) then + call hdf5_write_data(my_hdf5, text72, dflottV1) + deallocate(dflottV1) + endif + else if(text4.eq.'DELE') then + if(ind.eq.2) call XABORT('DRVUF5: DELE is a forbidden operation in read-only mode.') + call REDGET(ntype,nitma,flott,text72,dflott) + call hdf5_delete(my_hdf5, text72) + else if(text4.eq.'COPY') then + ! copy a group or a dataset from one location to another. + if(nentry.ne.2) call XABORT('DRVUH5: RHS HDF source file missing.') + if(ientry(2).ne.6) call XABORT('DRVUH5: the utility module works on' & + & //'ly for hdf5 files.') + my_hdf5_s=kentry(2) + call REDGET(indic,nitma,flott,text72,dflott) + if(indic.ne.3) call XABORT('DRVUH5: destination dataset name expected.') + call REDGET(indic,nitma,flott,text4,dflott) + if((indic.ne.3).or.(text4.ne.'=')) call XABORT('DRVUH5: = keyword expected.') + call REDGET(indic,nitma,flott,text72_s,dflott) + if(indic.ne.3) call XABORT('DRVUH5: source dataset name expected.') + if(.not.hdf5_group_exists(my_hdf5_s, text72_s)) then + write(hsmg,'(25hDRVUH5: group or dataset ,a,12h is missing.)') trim(text72_s) + call XABORT(hsmg) + endif + call hdf5_copy(my_hdf5_s, text72_s, my_hdf5, text72) + else if(text4.eq.'GREP') then + ! grep a single value in a rank 1 dataset. + call REDGET(indprt,nitma,flott,text72,dflott) + if(indprt.ne.3) call XABORT('DRVUH5: dataset name expected.') + call hdf5_info(my_hdf5,text72,rank,type,nbyte,dimsr) + if(rank.ne.1) call XABORT('DRVUH5: rank 1 dataset expected.') + call REDGET(indic,index,flott,text12,dflott) + if(indic.lt.0) then + index=1 + else if(indic.eq.1) then + call REDGET(indic,nitma,flott,text12,dflott) + if(indic.ge.0) call XABORT('DRVUH5: >>...<< expected.') + else + call XABORT('DRVUH5: integer value or >>...<< expected.') + endif + write(6,'(/19h DRVUF5: grep value,i8,12h in dataset ,a,1h:)') index,text72 + if(index.gt.dimsr(1)) call XABORT('DRVUH5: index overflow.') + indic=-indic + if(indic.ne.type) then + write(hsmg,'(33hDRVUH5: inconststent REDPUT type=,i2,14h dataset type=,i2,1h.)') & + & indic,type + call XABORT(hsmg) + endif + if(type.eq.1) then + call hdf5_read_data(my_hdf5,text72,nitmaV1) + call REDPUT(indic,nitmav1(index),flott,text12,dflott) + deallocate(nitmaV1) + else if(type.eq.2) then + call hdf5_read_data(my_hdf5,text72,flottV1) + call REDPUT(indic,nitma,flottv1(index),text12,dflott) + deallocate(flottV1) + else if(type.eq.3) then + if(nbyte.le.32) then + call hdf5_read_data(my_hdf5,text72,text32V1) + call REDPUT(indic,nitma,flott,text32v1(index),dflott) + deallocate(text32V1) + else + call hdf5_read_data(my_hdf5,text72,text64V1) + call REDPUT(indic,nitma,flott,text64v1(index),dflott) + deallocate(text64V1) + endif + else if(type.eq.4) then + call hdf5_read_data(my_hdf5,text72,dflottV1) + call REDPUT(indic,nitma,flott,text12,dflottv1(index)) + deallocate(dflottV1) + else + write(hsmg,100) type,rank + call XABORT(hsmg) + endif + else if(text4.eq.';') then + return + else + write(hsmg,'(8hDRVUH5: ,a4,30h is an invalid utility action.)') text4 + call XABORT(hsmg) + endif + go to 10 + ! + 100 format(12hDRVUF5: type,i3,9h and rank,i3,19h are not supported.) +end subroutine DRVUH5 diff --git a/Ganlib/src/DRVUTL.f b/Ganlib/src/DRVUTL.f new file mode 100644 index 0000000..36d171c --- /dev/null +++ b/Ganlib/src/DRVUTL.f @@ -0,0 +1,711 @@ +*DECK DRVUTL + SUBROUTINE DRVUTL(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* standard utility module for linked list or xsm files. +* +*Copyright: +* Copyright (C) 1988 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): read-only or modification type(VECTOR). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +* List of utility actions: +* IMPR : print a block. +* COPY : copy a block or a directory. +* CREA : create a block. +* DEL : delete a block. +* STAT : compare two blocks. +* ADD : add two floating point blocks or directories component by +* component. +* MULT : multiply the floating point components of a block or +* directory by a constant. +* SADD : add the floating point components of a block or directory +* by a constant. +* STEP : change of directory level. +* DIR : print the active directory content. +* DUMP : dump the active and son directories on the printer. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER :: NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) :: KENTRY(NENTRY) + CHARACTER :: HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER :: MAXLEV=50 + TYPE(C_PTR) :: IPLIST,IPLIS1,IPKEEP(MAXLEV) + CHARACTER :: TEXT4*4,NAMT*12,NAMT2*12,NAMMY*12,NAMLCM*72, + 1 CTYP(3)*11,CENT(3)*9,HSMG*131,TEXT12*12 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IARA + REAL, ALLOCATABLE, DIMENSION(:) :: ARA,ARA2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DARA + CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: HARA + COMPLEX, ALLOCATABLE, DIMENSION(:) :: CARA + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LARA + DOUBLE PRECISION :: DFLOTT + LOGICAL :: EMPTY,LCM + DATA (CTYP(ITY),ITY=1,3)/'CLE_2000','LINKED_LIST','XSM_FILE'/ + DATA (CENT(ITY),ITY=1,3)/'CREATE','IN_OUT','READ-ONLY'/ + SAVE CTYP,CENT +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.EQ.0) CALL XABORT('DRVUTL: PARAMETER EXPECTED.') + TEXT12=HENTRY(1) + IF(JENTRY(1).EQ.0) THEN + IF(IENTRY(1).GT.2) CALL XABORT('DRVUTL: THE UTILITY MODULE WO' + 1 //'RKS ONLY WITH LINKED LISTS AND XSM FILES ('//TEXT12//').') + ELSE IF(JENTRY(1).EQ.1) THEN + IF(IENTRY(1).GT.2) CALL XABORT('DRVUTL: THE UTILITY MODULE WO' + 1 //'RKS ONLY WITH LINKED LISTS AND XSM FILES ('//TEXT12//').') + ELSE IF(JENTRY(1).EQ.2) THEN + IF(IENTRY(1).GT.2) CALL XABORT('DRVUTL: THE UTILITY MODULE WO' + 1 //'RKS ONLY WITH LINKED LISTS AND XSM FILES ('//TEXT12//').') + ENDIF + IND=JENTRY(1) + ITYPE=IENTRY(1) + IPLIST=KENTRY(1) + IPKEEP(1)=IPLIST + ILEV=1 + FLUSH(6) +*---- +* SET EDITION FLAG. +*---- + IMPX=1 + CALL REDGET(INDIC,NITMA,DPREC,TEXT4,DFLOTT) + IF(INDIC.EQ.10) RETURN + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(ITYP,IMPX,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('DRVUTL: NO INTEGER AFTER *EDIT*.') + ELSE + GO TO 20 + ENDIF + CALL LCMINF(IPLIST,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(IMPX.GT.0) WRITE(6,180) CTYP(ITYPE+1),CENT(IND+1),NAMMY,NAMLCM +*---- +* PERFORM SOME UTILITY ACTIONS. +*---- + 10 CALL REDGET(INDIC,NITMA,DPREC,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + 20 IF(TEXT4.EQ.'IMPR') THEN +* PRINT A LCM OR XSM BLOCK. + CALL REDGET(INDPRT,ISET,FLOTT,NAMT,DFLOTT) + IF(INDPRT.EQ.1) THEN + CALL LCMLEL(IPLIST,ISET,ILONG,ITYBLK) + IF(ILONG.EQ.0) THEN + WRITE (6,245) ISET + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + GO TO 10 + ENDIF + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMLEN(IPLIST,NAMT,ILONG,ITYBLK) + IF(ILONG.EQ.0) THEN + WRITE (6,250) NAMT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + GO TO 10 + ENDIF + ELSE + CALL XABORT('DRVUTL: BLOCK-NAME OR LIST INDEX EXPECTED.') + ENDIF + IF(ITYBLK.EQ.10) CALL XABORT('DRVUTL: '//NAMT//' IS A LIST OF' + 1 //' ARRAYS. USE A STEP UP KEYWORD TO ACCESS THE LIST.') + IF((ITYBLK.EQ.1).OR.(ITYBLK.EQ.3).OR.(ITYBLK.EQ.5)) THEN + ALLOCATE(IARA(ILONG)) + IF(INDPRT.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,IARA) + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,IARA) + ENDIF + ELSE IF(ITYBLK.EQ.2) THEN + ALLOCATE(ARA(ILONG)) + IF(INDPRT.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,ARA) + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,ARA) + ENDIF + ELSE IF(ITYBLK.EQ.4) THEN + ALLOCATE(DARA(ILONG)) + IF(INDPRT.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,DARA) + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,DARA) + ENDIF + ELSE IF(ITYBLK.EQ.6) THEN + ALLOCATE(CARA(ILONG)) + IF(INDPRT.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,CARA) + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,CARA) + ENDIF + ELSE + CALL XABORT('DRVUTL: IMPR TYPE NOT SUPPORTED.') + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + LL=99999999 + IF(INDIC.EQ.1) THEN + LL=NITMA + ELSE IF(INDIC.NE.3) THEN + CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + ELSE IF(TEXT4.NE.'*') THEN + CALL XABORT('DRVUTL: CHARACTER * EXPECTED.') + ENDIF + ICONT=0 + IMAX=MIN0(LL,ILONG) + IF(ITYBLK.EQ.1) THEN + DO I=1,ILONG + IF(IARA(I).NE.0) ICONT=ICONT+1 + ENDDO + ELSE IF(ITYBLK.EQ.2) THEN + DO I=1,ILONG + IF(ARA(I).NE.0.0) ICONT=ICONT+1 + ENDDO + ELSE IF(ITYBLK.EQ.4) THEN + DO I=1,ILONG + IF(DARA(I).NE.0.0D0) ICONT=ICONT+1 + ENDDO + IMAX=MIN0(LL,ILONG) + ELSE IF(ITYBLK.EQ.6) THEN + DO I=1,ILONG + IF(CARA(I).NE.0.0) ICONT=ICONT+1 + ENDDO + IMAX=MIN0(LL,ILONG) + ENDIF + IF(INDPRT.EQ.1) THEN + WRITE (6,225) ISET,ILONG,ICONT + ELSE IF(INDPRT.EQ.3) THEN + WRITE (6,230) NAMT,ILONG,ICONT + ENDIF + IF((IMAX.GT.0).AND.(ITYBLK.EQ.1)) THEN + WRITE (6,'(1X,13I10)') (IARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.2)) THEN + WRITE (6,'(1X,1P,10E13.4)') (ARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.3)) THEN + WRITE (6,'(1X,32A4)') (IARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.4)) THEN + WRITE(6,'(1X,1P,6D21.12)') (DARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.5)) THEN + WRITE(6,'(1X,65L2)') (IARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.6)) THEN + WRITE(6,'(1X,1P,4(2H (,E13.4,1H,,E13.4,1H)))') + 1 (REAL(CARA(I)),AIMAG(CARA(I)),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.0)) THEN + WRITE (6,240) NAMT + ENDIF + WRITE (6,'(/)') + IF((ITYBLK.EQ.1).OR.(ITYBLK.EQ.3).OR.(ITYBLK.EQ.5)) THEN + DEALLOCATE(IARA) + ELSE IF(ITYBLK.EQ.2) THEN + DEALLOCATE(ARA) + ELSE IF(ITYBLK.EQ.4) THEN + DEALLOCATE(DARA) + ELSE IF(ITYBLK.EQ.6) THEN + DEALLOCATE(CARA) + ENDIF + ELSE IF(TEXT4.EQ.'ERAS') THEN +* ERASE THE CONTENTS OF THE LCM OR XSM OBJECT. + IF(IND.EQ.2) CALL XABORT('DRVUTL: ERAS IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL LCMINF(IPLIST,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(LCM) THEN + MEDIUM=1 + ELSE + MEDIUM=2 + ENDIF + CALL LCMCL(IPLIST,3) + CALL LCMOP(IPLIST,NAMLCM,1,MEDIUM,IMPX) + ELSE IF(TEXT4.EQ.'COPY') THEN +* COPY AND NAME A BLOCK OR DIRECTORY ON LCM OR XSM. + IF(IND.EQ.2) CALL XABORT('DRVUTL: COPY IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT2,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMLEN(IPLIST,NAMT,ILONG,ITYBLK) + IF(ILONG.EQ.-1) THEN +* COPY A COMPLETE DIRECTORY. + CALL LCMSIX(IPLIST,NAMT,1) + NUNIT=KDROPN('DUMMYSQ',0,2,0) + IF(NUNIT.LE.0) CALL XABORT('DRVUTL: KDROPN FAILURE.') + CALL LCMEXP(IPLIST,0,NUNIT,1,1) + REWIND(NUNIT) + CALL LCMSIX(IPLIST,' ',2) + CALL LCMSIX(IPLIST,NAMT2,1) + CALL LCMEXP(IPLIST,0,NUNIT,1,2) + IRC=KDRCLS(NUNIT,2) + IF(IRC.LT.0) CALL XABORT('DRVUTL: KDRCLS FAILURE.') + CALL LCMSIX(IPLIST,' ',2) + ELSE IF(ILONG.GT.0) THEN +* COPY A SINGLE RECORD. + IF((ITYBLK.EQ.4).OR.(ITYBLK.EQ.6)) THEN + ALLOCATE(ARA(2*ILONG)) + CALL LCMGET(IPLIST,NAMT,ARA) + CALL LCMPUT(IPLIST,NAMT2,ILONG,ITYBLK,ARA) + DEALLOCATE(ARA) + ELSEIF(ITYBLK.EQ.2) THEN + ALLOCATE(ARA(ILONG)) + CALL LCMGET(IPLIST,NAMT,ARA) + CALL LCMPUT(IPLIST,NAMT2,ILONG,ITYBLK,ARA) + DEALLOCATE(ARA) + ELSE + ALLOCATE(IARA(ILONG)) + CALL LCMGET(IPLIST,NAMT,IARA) + CALL LCMPUT(IPLIST,NAMT2,ILONG,ITYBLK,IARA) + DEALLOCATE(IARA) + ENDIF + ELSE IF(ILONG.EQ.0) THEN + CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT STORED ON LCM O' + 1 //'R XSM.') + ENDIF + ELSE IF(TEXT4.EQ.'CREA') THEN + IF(IND.EQ.2) CALL XABORT('DRVUTL: CREA IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL REDGET(NTYPE,ISET,FLOTT,NAMT,DFLOTT) + INDICO=0 + IF(NTYPE.EQ.1) THEN + CALL LCMLEL(IPLIST,ISET,ILONG0,INDICO) + ELSE IF(NTYPE.EQ.3) THEN + CALL LCMLEN(IPLIST,NAMT,ILONG0,INDICO) + ELSE + CALL XABORT('DRVUTL: INTEGER OR CHARACTER DATA EXPECTED.') + ENDIF + CALL REDGET(INDIC,ILONG2,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTED.') + ILONG1=1 + 30 CALL REDGET(INDIC,ILONG,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + IF(ILONG0.EQ.0) CALL XABORT('DRVUTL: LOWER INDEX NOT EXPEC' + 1 //'TED.') + ILONG1=ILONG2 + ILONG2=ILONG + GO TO 30 + ELSE IF((INDIC.NE.3).OR.(TEXT4.NE.'=')) THEN + CALL XABORT('DRVUTL: = SIGN EXPECTED.') + ENDIF + CALL REDGET(INDIC,NITMA,FLOAT,TEXT4,DFLOTT) + IF(INDICO.EQ.99) THEN + INDICO=INDIC + ELSE IF(INDIC.NE.INDICO) THEN + CALL XABORT('DRVUTL: INCONSISTENT DATA TYPE(1).') + ENDIF + IF(INDIC.EQ.1) THEN + ALLOCATE(IARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGDL(IPLIST,ISET,IARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGET(IPLIST,NAMT,IARA) + ENDIF + IARA(ILONG1)=NITMA + ELSE IF(INDIC.EQ.2) THEN + ALLOCATE(ARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGDL(IPLIST,ISET,ARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGET(IPLIST,NAMT,ARA) + ENDIF + ARA(ILONG1)=FLOAT + ELSE IF(INDIC.EQ.3) THEN + ALLOCATE(HARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGLC(IPLIST,ISET,4,MAX(ILONG2,ILONG0),HARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGTC(IPLIST,NAMT,4,MAX(ILONG2,ILONG0),HARA) + ENDIF + HARA(ILONG1)=TEXT4 + ELSE IF(INDIC.EQ.4) THEN + ALLOCATE(DARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGDL(IPLIST,ISET,DARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGET(IPLIST,NAMT,DARA) + ENDIF + DARA(ILONG1)=DFLOTT + ELSE IF(INDIC.EQ.5) THEN + ALLOCATE(LARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGDL(IPLIST,ISET,LARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGET(IPLIST,NAMT,LARA) + ENDIF + IF (NITMA.EQ.1) THEN + LARA(ILONG1)=.TRUE. + ELSE + LARA(ILONG1)=.FALSE. + ENDIF + ENDIF + DO I=ILONG1+1,ILONG2 + CALL REDGET(INDIC,NITMA,FLOAT,TEXT4,DFLOTT) + IF(INDIC.NE.INDICO) THEN + CALL XABORT('DRVUTL: INCONSISTENT DATA TYPE(2).') + ELSE IF(INDIC.EQ.1) THEN + IARA(I)=NITMA + ELSE IF(INDIC.EQ.2) THEN + ARA(I)=FLOAT + ELSE IF(INDIC.EQ.3) THEN + HARA(I)=TEXT4 + ELSE IF(INDIC.EQ.4) THEN + DARA(I)=DFLOTT + ELSE IF(INDIC.EQ.5) THEN + IF (NITMA.EQ.1) THEN + LARA(I)=.TRUE. + ELSE + LARA(I)=.FALSE. + ENDIF + ENDIF + ENDDO + IF(NTYPE.EQ.1) THEN + IF(INDICO.EQ.1) THEN + CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,IARA) + DEALLOCATE(IARA) + ELSE IF(INDICO.EQ.2) THEN + CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,ARA) + DEALLOCATE(ARA) + ELSE IF(INDICO.EQ.3) THEN + CALL LCMPLC(IPLIST,ISET,4,MAX(ILONG2,ILONG0),HARA) + DEALLOCATE(HARA) + ELSE IF(INDICO.EQ.4) THEN + CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,DARA) + DEALLOCATE(DARA) + ELSE IF(INDICO.EQ.5) THEN + CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,LARA) + DEALLOCATE(LARA) + ENDIF + ELSE IF(NTYPE.EQ.3) THEN + IF(INDICO.EQ.1) THEN + CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,IARA) + DEALLOCATE(IARA) + ELSE IF(INDICO.EQ.2) THEN + CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,ARA) + DEALLOCATE(ARA) + ELSE IF(INDICO.EQ.3) THEN + CALL LCMPTC(IPLIST,NAMT,4,MAX(ILONG2,ILONG0),HARA) + DEALLOCATE(HARA) + ELSE IF(INDICO.EQ.4) THEN + CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,DARA) + DEALLOCATE(DARA) + ELSE IF(INDICO.EQ.5) THEN + CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,LARA) + DEALLOCATE(LARA) + ENDIF + ENDIF + ELSE IF(TEXT4.EQ.'DEL') THEN +* DELETE A BLOCK. + IF(IND.EQ.2) CALL XABORT('DRVUTL: DEL IS A FORBIDDEN OPERATION' + 1 //' IN READ-ONLY MODE.') + IF(ITYPE.GT.1) CALL XABORT('DRVUTL: DEL CAN ONLY BE USED WITH ' + 1 //'LINKED-LISTS.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMDEL(IPLIST,NAMT) + ELSE IF(TEXT4.EQ.'STAT') THEN +* COMPARE TWO BLOCKS STORED ON LCM OR XSM. +* READ RELATIVE OR ABSOLUTE ERROR. + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') +* RECOVERY OF THE FIRST BLOCK. + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMLEN(IPLIST,NAMT,ILONG1,IT1BLK) + IF(IT1BLK.NE.2) CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT OF' + 1 //' REAL TYPE.') + ALLOCATE(ARA(ILONG1)) + CALL LCMGET(IPLIST,NAMT,ARA) +* RECOVERY OF THE SECOND BLOCK. + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMLEN(IPLIST,NAMT,ILONG2,IT2BLK) + IF(ILONG2.NE.ILONG1) THEN + CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT LENGTH.') + ELSE IF(IT1BLK.NE.IT2BLK) THEN + CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT TYPES.') + ENDIF + ALLOCATE(ARA2(ILONG2)) + CALL LCMGET(IPLIST,NAMT,ARA2) +* COMPARE THE TWO BLOCKS. + EPSMAX=0.0 + EPSAVG=0.0 + IF(TEXT4(1:3).EQ.'REL') THEN + WRITE (6,200) 'RELATIVE' + DO I=1,ILONG1 + IF(ARA2(I).NE.0.0) THEN + ABSEP=ABS((ARA(I)-ARA2(I))/ARA2(I)) + ELSE + ABSEP=0.0 + ENDIF + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + ENDDO + EPSMAX=100.0*EPSMAX + EPSAVG=100.0*EPSAVG/REAL(ILONG1) + WRITE (6,210) ILONG1,EPSMAX,INGRO,EPSAVG + ELSE IF(TEXT4(1:3).EQ.'ABS') THEN + WRITE (6,200) 'ABSOLUTE' + DO I=1,ILONG1 + ABSEP=ABS(ARA(I)-ARA2(I)) + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + ENDDO + EPSAVG=EPSAVG/REAL(ILONG1) + WRITE (6,220) ILONG1,EPSMAX,INGRO,EPSAVG + ELSE + CALL XABORT('DRVUTL: CHOOSE RELATIVE OR ABSOLUTE') + ENDIF + DEALLOCATE(ARA2,ARA) +*---- +* transfer EPSMAX and EPSAVG to output variables if required +*---- + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC .EQ. 3 ) GO TO 20 + IF(INDIC .NE. -2) CALL XABORT('DRVUTL: Output variable for ' + 1 //'maximum error is not a real number') + CALL REDPUT(-INDIC,NITMA,EPSMAX,TEXT4,DFLOTT) + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC .EQ. 3 ) GO TO 20 + IF(INDIC .NE. -2) CALL XABORT('DRVUTL: Output variable for ' + 1 //'average error is not a real number') + CALL REDPUT(-INDIC,NITMA,EPSAVG,TEXT4,DFLOTT) + ELSE IF(TEXT4.EQ.'ADD') THEN +* ADD TWO BLOCKS OR DIRECTORIES STORED ON LCM OR XSM. +* RECOVERY OF THE FIRST BLOCK. + IF(IND.EQ.2) CALL XABORT('DRVUTL: ADD IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT2,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMLEN(IPLIST,NAMT,ILONG1,IT1BLK) + IF(ILONG1.EQ.-1) THEN +* ADD TWO DIRECTORIES. + NUNIT=KDROPN('DUMMYSQ',0,2,0) + IF(NUNIT.LE.0) CALL XABORT('DRVUTL: KDROPN FAILURE.') + CALL LCMEXP(IPLIST,0,NUNIT,1,1) + REWIND(NUNIT) + CALL LCMOP(IPLIS1,'DUMMYDA',0,1,0) + CALL LCMEXP(IPLIS1,0,NUNIT,1,2) + IRC=KDRCLS(NUNIT,2) + IF(IRC.LT.0) CALL XABORT('DRVUTL: KDRCLS FAILURE.') + CALL LCMSIX(IPLIS1,NAMT,1) + CALL LCMSIX(IPLIST,NAMT2,1) + CALL LCMADD(IPLIS1,IPLIST) + CALL LCMSIX(IPLIS1,' ',2) + CALL LCMSIX(IPLIST,' ',2) + CALL LCMCL(IPLIS1,2) + ELSE IF(ILONG1.GT.0) THEN +* ADD TWO RECORDS. + IF(IT1BLK.NE.2) CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT' + 1 //' OF REAL TYPE.') + CALL LCMLEN(IPLIST,NAMT2,ILONG2,IT2BLK) + IF(ILONG2.NE.ILONG1) THEN + CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT LENGTH' + 1 //'S.') + ELSE IF(IT1BLK.NE.IT2BLK) THEN + CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT TYPES.') + ENDIF + ALLOCATE(ARA(ILONG1)) + CALL LCMGET(IPLIST,NAMT,ARA) + ALLOCATE(ARA(ILONG2)) + CALL LCMGET(IPLIST,NAMT,ARA2) + ARA2(:ILONG2)=ARA(:ILONG2)+ARA2(:ILONG2) + CALL LCMPUT(IPLIST,NAMT2,ILONG2,IT1BLK,ARA2) + DEALLOCATE(ARA2) + DEALLOCATE(ARA) + ELSE IF(ILONG1.EQ.0) THEN + CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT STORED.') + ENDIF + ELSE IF((TEXT4.EQ.'MULT').OR.(TEXT4.EQ.'SADD')) THEN +* MULTIPLY AN LCM OR XSM BLOCK OR DIRECTORY BY A CONSTANT. +* RECOVERY OF A BLOCK OR DIRECTORY. + IF(IND.EQ.2) CALL XABORT('DRVUTL: MULT IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL REDGET(NTYPE,ISET,FLOTT,NAMT,DFLOTT) + IF(NTYPE.EQ.1) THEN + CALL LCMLEL(IPLIST,ISET,ILONG1,ITYBLK) + ELSE IF(NTYPE.EQ.3) THEN + CALL LCMLEN(IPLIST,NAMT,ILONG1,ITYBLK) + ELSE + CALL XABORT('DRVUTL: INTEGER OR CHARACTER DATA EXPECTED.') + ENDIF +* READ A NUMBER. + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.EQ.3) CALL XABORT('DRVUTL: INTEGER OR REAL NUMBER EX' + 1 //'PECTED.') + IF(INDIC.EQ.1) FLOTT=REAL(NITMA) + CALL LCMLEN(IPLIST,NAMT,ILONG1,ITYBLK) + IF(ILONG1.EQ.-1) THEN +* MULTIPLY A DIRECTORY FLOATTING CONTENT BY A REAL NUMBER. + IF(NTYPE.EQ.1) THEN + IPLIS1=LCMDIL(IPLIST,ISET) + ELSE IF(NTYPE.EQ.3) THEN + IPLIS1=LCMDID(IPLIST,NAMT) + ENDIF + CALL LCMULT(IPLIS1,FLOTT) + ELSE IF(ILONG1.GT.0) THEN +* MULTIPLY A REAL RECORD BY A REAL NUMBER. + IF(ITYBLK.NE.2) CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT' + 1 //' OF REAL TYPE.') + ALLOCATE(ARA(ILONG1)) + IF(NTYPE.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,ARA) + ELSE IF(NTYPE.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,ARA) + ENDIF + IF(TEXT4.EQ.'MULT') THEN + ARA(:ILONG1)=ARA(:ILONG1)*FLOTT + ELSE IF(TEXT4.EQ.'SADD') THEN + ARA(:ILONG1)=ARA(:ILONG1)+FLOTT + ENDIF + IF(NTYPE.EQ.1) THEN + CALL LCMPDL(IPLIST,ISET,ILONG1,ITYBLK,ARA) + ELSE IF(NTYPE.EQ.3) THEN + CALL LCMPUT(IPLIST,NAMT,ILONG1,ITYBLK,ARA) + ENDIF + DEALLOCATE(ARA) + ELSE IF(ILONG1.EQ.0) THEN + CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT STORED.') + ENDIF + ELSE IF(TEXT4.EQ.'STEP') THEN +* CHANGE THE HIERARCHICAL LEVEL ON THE LCM OR XSM FILE. + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'UP') THEN + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(IMPX.GT.0) WRITE (6,190) NAMT + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) CALL XABORT('DRVUTL: MAXLEV OVERFLOW.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(TEXT4.NE.'NEW') THEN + IPLIST=LCMGID(IPLIST,NAMT) + IPKEEP(ILEV)=IPLIST + GO TO 20 + ELSE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF((INDIC.EQ.3).AND.(TEXT4.EQ.'DICT')) THEN + IPLIST=LCMDID(IPLIST,NAMT) + IPKEEP(ILEV)=IPLIST + ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'LIST')) THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTE' + 1 //'D.') + IPLIST=LCMLID(IPLIST,NAMT,NITMA) + IPKEEP(ILEV)=IPLIST + ELSE + CALL XABORT('DRVUTL: DICT OR LIST KEYWORD EXPECTED.') + ENDIF + ENDIF + ELSE IF(TEXT4.EQ.'AT') THEN + CALL REDGET(INDIC,ISET,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTED.') + IF(IMPX.GT.0) WRITE (6,195) ISET + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) CALL XABORT('DRVUTL: MAXLEV OVERFLOW.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(TEXT4.NE.'NEW') THEN + IPLIST=LCMGIL(IPLIST,ISET) + IPKEEP(ILEV)=IPLIST + GO TO 20 + ELSE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF((INDIC.EQ.3).AND.(TEXT4.EQ.'DICT')) THEN + IPLIST=LCMDIL(IPLIST,ISET) + IPKEEP(ILEV)=IPLIST + ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'LIST')) THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTE' + 1 //'D.') + IPLIST=LCMLIL(IPLIST,ISET,NITMA) + IPKEEP(ILEV)=IPLIST + ELSE + CALL XABORT('DRVUTL: DICT OR LIST KEYWORD EXPECTED.') + ENDIF + ENDIF + ELSE IF(TEXT4.EQ.'DOWN') THEN + IF(IMPX.GT.0) WRITE (6,'(/29H DRVUTL: STEP DOWN TO PARENT , + 1 6HLEVEL.)') + ILEV=ILEV-1 + IF(ILEV.LT.1) CALL XABORT('DRVUTL: TOO MANY STEPS DOWN.') + IPLIST=IPKEEP(ILEV) + ELSE IF(TEXT4.EQ.'ROOT') THEN + IF(IMPX.GT.0) WRITE (6,'(/29H DRVUTL: STEP DOWN TO ROOT LE, + 1 4HVEL.)') + ILEV=1 + IPLIST=IPKEEP(1) + ENDIF + ELSE IF(TEXT4.EQ.'DIR') THEN +* PRINT THE DIRECTORY OF THE ACTIVE LEVEL. + CALL LCMLIB(IPLIST) + ELSE IF(TEXT4.EQ.'VAL') THEN +* VALIDATE A LCM OBJECT. + CALL LCMVAL(IPLIST,' ') + ELSE IF(TEXT4.EQ.'NAN') THEN +* CHECK FOR NAN IN LCM OBJECT. + CALL LCMNAN(IPLIST) + ELSE IF(TEXT4.EQ.'DUMP') THEN +* DUMP THE ACTIVE AND SON DIRECTORIES ON THE PRINTER. + CALL LCMEXP(IPLIST,0,6,2,1) + ELSE IF(TEXT4.EQ.';') THEN + IF(IMPX.GT.0) THEN + CALL LCMINF(IPLIST,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + WRITE(6,260) NAMMY + ENDIF + RETURN + ELSE + WRITE(HSMG,'(8HDRVUTL: ,A4,30H IS AN INVALID UTILITY ACTION.) + 1 ') TEXT4 + CALL XABORT(HSMG) + ENDIF + GO TO 10 +* + 180 FORMAT (/36H DRVUTL: PERFORM UTILITY ACTIONS ON ,A11,9H OPEN IN , + 1 A9,29H MODE WITH ACTIVE DIRECTORY ',A12,2H'./9X,9HLCM NAME=,A) + 190 FORMAT (/27H DRVUTL: STEP UP TO LEVEL ',A12,2H'.) + 195 FORMAT (/27H DRVUTL: STEP AT COMPONENT ,I5,1H.) + 200 FORMAT (/17H DRVUTL: COMPARE ,A8,26H ERRORS OF THE TWO BLOCKS:/) + 210 FORMAT (/5H LEN=,I6,5X,7HEPSMAX=,F8.2,15H % IN COMPONENT,I6/16X, + 1 7HEPSAVG=,F8.2,2H %) + 220 FORMAT (/5H LEN=,I6,5X,7HEPSMAX=,E12.5,13H IN COMPONENT,I6/16X, + 1 7HEPSAVG=,E12.5) + 225 FORMAT (/29H DRVUTL: CONTENT OF COMPONENT,I6,5X,8HLENGTH =,I10, + 1 5X,26HNUMBER OF NON ZERO TERMS =,I10/) + 230 FORMAT (/27H DRVUTL: CONTENT OF BLOCK ',A12,1H',5X,8HLENGTH =, + 1 I10,5X,26HNUMBER OF NON ZERO TERMS =,I10/) + 240 FORMAT (/16H DRVUTL: BLOCK ',A12,21H' IS OF UNKNOWN TYPE./) + 245 FORMAT (/18H DRVUTL: COMPONENT,I6,27H IS NOT STORED ON THE CURRE, + 1 20HNT LCM OR XSM LEVEL./) + 250 FORMAT (/16H DRVUTL: BLOCK ',A12,28H' IS NOT STORED ON THE CURRE, + 1 20HNT LCM OR XSM LEVEL./) + 260 FORMAT (/40H DRVUTL: LEAVING WITH ACTIVE DIRECTORY ',A12,2H'.) + END diff --git a/Ganlib/src/GANDRV.F90 b/Ganlib/src/GANDRV.F90 new file mode 100644 index 0000000..197a7fb --- /dev/null +++ b/Ganlib/src/GANDRV.F90 @@ -0,0 +1,108 @@ +integer function GANDRV(hmodul,nentry,hentry,ientry,jentry,kentry) +! +!----------------------------------------------------------------------- +! +!Purpose: +! standard utility operator driver for Ganlib. +! +!Copyright: +! Copyright (C) 2002 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input/output +! hmodul name of the operator. +! nentry number of LCM objects or files used by the operator. +! hentry name of each LCM object or file. +! ientry type of each LCM object or file: +! =1 LCM memory object; =2 XSM file; =3 sequential binary file; +! =4 sequential ascii file; =6 for HDF5 file. +! jentry access of each LCM object or file: +! =0 the LCM object or file is created; +! =1 the LCM object or file is open for modifications; +! =2 the LCM object or file is open in read-only mode. +! kentry LCM object address or file unit number. +! +!Parameters: output +! kdrstd completion flag (=0: operator hmodul exists; =1: does not exists). +! +!----------------------------------------------------------------------- +! + use, intrinsic :: iso_c_binding +!---- +! subroutine arguments +!---- + integer nentry + character hmodul*(*),hentry(nentry)*12 + integer ientry(nentry),jentry(nentry) + type(c_ptr) kentry(nentry) +! + real tbeg,tend + double precision dmemb,dmemd +! + GANDRV=0 + call KDRCPU(tbeg) + call KDRMEM(dmemb) + if(hmodul == 'EQU:' )then +! standard equality module. + call DRVEQU(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'GREP:') then +! standard grep module. + call DRVGRP(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'UTL:') then +! standard LCM/XSM utility module. + call DRVUTL(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'ADD:') then +! standard addition module. + call DRVADD(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'MPX:') then +! standard multiplication module. + call DRVMPX(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'STAT:') then +! standard compare module. + call DRVSTA(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'BACKUP:') then +! standard backup module. + call DRVBAC(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'RECOVER:') then +! standard recovery module. + call DRVREC(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'FIND0:') then +! standard module to find zero of a continuous function. + call DRV000(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'MSTR:') then +! manage user-defined structures. + call MSTR(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'MODUL1:') then +! user-defined module. + call DRVMO1(nentry,hentry,ientry,jentry,kentry) + else if(hmodul == 'ABORT:') then +! requested abort. + call XABORT('GANDRV: requested abort.') +#if defined(MPI) + elseif(hmodul == 'DRVMPI:') then +! initialize MPI. + call DRVMPI(nentry,hentry,ientry,jentry,kentry) + elseif(hmodul == 'SNDMPI:') then +! export LCM or XSM using mpi. + call SNDMPI(nentry,hentry,ientry,jentry,kentry) +#endif /* defined(MPI) */ +#if defined(HDF5_LIB) + elseif(hmodul == 'HUTL:') then +! HDF5 utility module. + call DRVUH5(nentry,hentry,ientry,jentry,kentry) +#endif /* defined(HDF5_LIB) */ + else + GANDRV=1 + endif + call KDRCPU(tend) + call KDRMEM(dmemd) + write(6,5000) hmodul,(tend-tbeg),real(dmemd-dmemb) + return +! + 5000 format('-->>module ',a12,': time spent=',f13.3,' memory usage=',1p,e10.3) +end function GANDRV diff --git a/Ganlib/src/GANMAIN.f90 b/Ganlib/src/GANMAIN.f90 new file mode 100644 index 0000000..3d55bdd --- /dev/null +++ b/Ganlib/src/GANMAIN.f90 @@ -0,0 +1,47 @@ +program GANMAIN + use GANLIB + implicit none + character(len=131) :: hsmg +! +! local storage + integer :: iprint,ier + integer :: imvers + character(len=64) :: date + character(len=48) :: rev + integer, parameter :: iout=6 + character(len=6), parameter :: namsbr='ganlib' +! +! gan-2000 external functions + integer, external :: KERNEL + interface + integer(c_int) function ganmod(cmodul, nentry, hentry, ientry, jentry, & + kentry, hparam_c) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: cmodul + integer(c_int), value :: nentry + character(kind=c_char), dimension(13,*) :: hentry + integer(c_int), dimension(nentry) :: ientry, jentry + type(c_ptr), dimension(nentry) :: kentry + character(kind=c_char), dimension(73,*) :: hparam_c + end function ganmod + end interface +!---- +! version information recovered from cvs +!---- + imvers=5 + call KDRVER(rev,date) +!---- +! execute the cle-2000 driver +!---- + iprint=0 + ier=KERNEL(ganmod,iprint) + if( ier /= 0 )then + write(hsmg,'(28hGANMAIN: kernel error (code=,I5,2h).)') ier + call XABORT(hsmg) + endif + write(iout,6030) namsbr,imvers,rev + stop + 6030 format(/1x,'normal end of execution for ',a6,i2,2x,a/ & + 1x,'check for warning in listing'/ & + 1x,'before assuming your run was successful') +end program GANMAIN diff --git a/Ganlib/src/KDIOP.f90 b/Ganlib/src/KDIOP.f90 new file mode 100644 index 0000000..0af8d6a --- /dev/null +++ b/Ganlib/src/KDIOP.f90 @@ -0,0 +1,87 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for kdi. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +function KDIOP(name, iactio) + ! open a KDI file + use, intrinsic :: iso_c_binding + use LCMAUX + type(c_ptr) KDIOP + character(len=*) :: name + integer :: iactio + character(kind=c_char), dimension(13) :: name13 + interface + function kdiop_c (name_c, iactio) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) kdiop_c + character(kind=c_char), dimension(*) :: name_c + integer(c_int), value :: iactio + end function kdiop_c + end interface + call STRCUT(name13, name) + KDIOP=kdiop_c(name13, iactio) +end function KDIOP +! +subroutine KDIPUT(my_file, idata, iofset, length) + ! store a data array in a KDI file at offset iofset + use, intrinsic :: iso_c_binding + type(c_ptr) :: my_file, pt_data + integer, target, dimension(*) :: idata + integer :: iofset, length + interface + subroutine kdiput_c (my_file, idata, iofset, length) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: my_file, idata + integer(c_int), value :: iofset, length + end subroutine kdiput_c + end interface + pt_data=c_loc(idata) + call kdiput_c(my_file, pt_data, iofset, length) +end subroutine KDIPUT +! +subroutine KDIGET(my_file, idata, iofset, length) + ! read a data array from a KDI file at offset iofset + use, intrinsic :: iso_c_binding + type(c_ptr) :: my_file, pt_data + integer, target, dimension(*) :: idata + integer :: iofset, length + interface + subroutine kdiget_c (my_file, idata, iofset, length) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: my_file, idata + integer(c_int), value :: iofset, length + end subroutine kdiget_c + end interface + pt_data=c_loc(idata) + call kdiget_c(my_file, pt_data, iofset, length) +end subroutine KDIGET +! +function KDICL(my_file, istatu) + ! close a KDI file + use, intrinsic :: iso_c_binding + integer(c_int) KDICL + type(c_ptr) :: my_file + integer :: istatu + interface + function kdicl_c (my_file, istatu) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) kdicl_c + type(c_ptr), value :: my_file + integer(c_int), value :: istatu + end function kdicl_c + end interface + KDICL=kdicl_c(my_file, istatu) +end function KDICL diff --git a/Ganlib/src/KDRCPU.f90 b/Ganlib/src/KDRCPU.f90 new file mode 100644 index 0000000..9c3109f --- /dev/null +++ b/Ganlib/src/KDRCPU.f90 @@ -0,0 +1,34 @@ +subroutine KDRCPU(cpusec) +! +!----------------------------------------------------------------------- +! +!Purpose: +! system clock support. +! +!Copyright: +! Copyright (C) 2002 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!Parameters: output +! cpusec : number of seconds elapsed since the first call to KDRCPU. +! +!----------------------------------------------------------------------- +! + real :: cpusec + double precision :: dtloc + integer,save :: isave=0 + double precision,save :: dtloc0 +! + if(isave==0) then + call CLETIM(dtloc0) + isave=1 + endif + call CLETIM(dtloc) + cpusec=real(dtloc-dtloc0) + return +end subroutine KDRCPU diff --git a/Ganlib/src/KDRMEM.f90 b/Ganlib/src/KDRMEM.f90 new file mode 100644 index 0000000..b07d984 --- /dev/null +++ b/Ganlib/src/KDRMEM.f90 @@ -0,0 +1,31 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! recover user memory used +! +!Copyright: +! Copyright (C) 2019 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!Parameters: output +! utime allocated memory in bytes. +! +!----------------------------------------------------------------------- +! +subroutine KDRMEM(utime) + use, intrinsic :: iso_c_binding + double precision :: utime + interface + function getusage () bind(c) + use, intrinsic :: iso_c_binding + real(c_double) :: getusage + end function getusage + end interface + utime=getusage() +end subroutine KDRMEM diff --git a/Ganlib/src/KDROPN.f90 b/Ganlib/src/KDROPN.f90 new file mode 100644 index 0000000..126f1b2 --- /dev/null +++ b/Ganlib/src/KDROPN.f90 @@ -0,0 +1,311 @@ +! +!--------------------------- KDROPN ---------------------------------- +! +! 1- programme statistics: +! name : KDROPN, KDRCLS +! use : allocate and release file units associated to a given +! file name. word addressable (KDI), sequential (formatted +! or not) and direct access (DA) files are permitted +! modified : 91-01-24 +! author : G. Marleau and A. Hebert +! +! 2- routine parameters: +! +! - function KDROPN(cuname,iactio,iutype,lrda) +! +! open file and allocate unit number. allocate unit number to file +! name if unit is already opened, returns unit number. +! +! input +! cuname : filename c*12 +! if cuname=' ', use a default name +! iactio : action on file i +! =0 to allocate a new file +! =1 to access and modify an existing file +! =2 to access an existing file in +! read-only mode +! =3 unknown +! iutype : file type i +! =1 KDI word addressable file +! =2 sequential unformatted +! =3 sequential formatted +! =4 direct access (DA) unformatted file +! ldra : number of words in DA record i +! required for iutype = 4 only +! output +! KDROPN : unit number/error status type(c_ptr) +! address of file (successful allocation) +! == NULL allocation failure +! +! error codes: +! = -1 no more unit available +! = -2 file type requested inconsistent with file type of this file +! = -3 this file has been already opened +! = -4 file name is reserved or too long (FT06F00, FT07F00) +! = -5 illegal file type 1 < iutype < 4 +! = -6 (not used) +! = -7 error on open of unformatted sequential file +! = -8 error on open of formatted sequential file +! = -9 error on open of direct access file +! =-10 invalid number of word in direct access record +! lrda must be > 0 +! +!--------------------------- KDROPN ---------------------------------- +! +integer function KDROPN(cuname,iactio,iutype,lrda) +!---- +! subroutine arguments +!---- + character(len=*) :: cuname + integer :: iactio,iutype,lrda +!---- +! local variables +!---- + integer :: ret_val=0 + integer, parameter :: nbtape=99,nreser=2,ndummy=4 + character :: crdnam*72,cform*11,cstatu*12 + integer :: itapno + logical :: lfilop + character(len=8),save,dimension(ndummy) :: cdummy= & + (/ 'DUMMYKDI','DUMMYSQ ','DUMMYCA ','DUMMYIN ' /) + character(len=8),save,dimension(nreser) :: creser= & + (/ 'FT05F001','FT06F001' /) + character(len=22),save,dimension(ndummy) :: ctype= & + (/ 'WORD ADDRESSABLE KDI ','SEQUENTIAL UNFORMATTED', & + 'SEQUENTIAL CHARACTER ','DIRECT ACCESS DA ' /) +!---- +! check if iutype is valid +!---- + if((iutype > 4).or.(iutype <= 1)) then + ret_val=-5 + go to 6000 + endif +!---- +! check if lrda is valid +!---- + if((iutype == 4).and.(lrda < 1)) then + ret_val=-10 + go to 6000 + endif +!---- +! check if file name is more than 72 characters +!---- + luname= len(cuname) + if(luname > 72) then + ret_val=-4 + go to 6000 + endif +!---- +! check if file name not forbidden +!---- + if(luname < 8) go to 120 + do ireser=1,nreser + if(cuname(:8) == creser(ireser)) then + ret_val=-4 + go to 6000 + endif + enddo +!---- +! check for dummy file name/allocate dummy file name if requested +!---- + do idummy=1,ndummy + if(cuname(:8) == cdummy(idummy)) then + if(idummy /= iutype) then + ret_val=-2 + go to 6000 + endif + endif + enddo + 120 if(cuname == ' ') then + crdnam=cdummy(iutype) + else + crdnam=cuname + endif +!---- +! check if file opened/permitted +!---- + inquire(file=crdnam,opened=lfilop) + if(lfilop) then + ret_val = -3 + go to 6000 + endif +!---- +! look for never allocated unit location +!---- + do jboucl=nbtape,1,-1 + itapno=jboucl + inquire(unit=itapno,opened=lfilop) + if(.not.lfilop) go to 121 + enddo +!---- +! error - no unit number available +!---- + ret_val = -1 + go to 6000 +! + 121 if(iutype == 2) then +!---- +! open sequential unformatted file +!---- + ret_val=-7 + cform='UNFORMATTED' + else if(iutype == 3) then +!---- +! open sequential formatted file +!---- + ret_val=-8 + cform='FORMATTED' + else if(iutype == 4) then +!---- +! open DA file +!---- + ret_val=-9 + cform='UNFORMATTED' + endif + if(iactio == 0) then + cstatu='NEW' + else if(iactio == 1) then + cstatu='OLD' + else if(iactio == 2) then + cstatu='OLD' + else + cstatu='UNKNOWN' + endif + if((iutype == 4).and.(iactio == 2)) then + idummy=0 + inquire(iolength=lrecl) (idummy,i=1,lrda) + open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, & + access='DIRECT',recl=lrecl,status=cstatu,action='READ') + else if(iutype == 4) then + idummy=0 + inquire(iolength=lrecl) (idummy,i=1,lrda) + open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, & + access='DIRECT',recl=lrecl,status=cstatu) + else if(((iutype == 2).or.(iutype == 3)).and.(iactio == 0)) then + open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, & + access='SEQUENTIAL',status=cstatu) + else if(((iutype == 2).or.(iutype == 3)).and.(iactio == 1)) then + open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, & + access='SEQUENTIAL',position='APPEND',status=cstatu) + else if(((iutype == 2).or.(iutype == 3)).and.(iactio == 2)) then + open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, & + access='SEQUENTIAL',status=cstatu,action='READ') + rewind(itapno) + endif + KDROPN=itapno + return + 6000 write(6,8000) crdnam,ctype(iutype),ret_val + KDROPN=ret_val + return + 7000 write(6,9000) crdnam,ctype(iutype),ret_val,iercod + KDROPN=ret_val + return +!---- +! error format +!---- + 8000 format('1',5x,'ERROR IN OPENING OF FILE IN KDROPN'/ & + 6x,'FILE NAME = ',a/6x,'FILE TYPE = ',a22/ & + 6x,'ERROR CODE= ',i7) + 9000 format('1',5x,'ERROR IN OPENING OF FILE IN KDROPN'/ & + 6x,'FILE NAME = ',a/6x,'FILE TYPE = ',a22/ & + 6x,'ERROR CODE= ',i7,' IERCOD = ',i7) +end function KDROPN +! +!-------------------------- KDRCLS ------------------------------------- +! +! - function KDRCLS(itapno,iactio) +! +! close file and release unit number. +! +! input +! itapno : unit number i +! = 0 close all units +! > 0 unit to close +! iactio : action on file i +! = 1 to keep the file; +! = 2 to delete the file. +! output +! KDRCLS : error status i +! = 0 unit closed +! = -2 file not opened +! = -3 this file has been opened by routines other than KDROPN +! = -4 file unit is reserved (5,6) +! = -5 illegal unit number +! = -6 (not used) +! = -7 error on close of unformatted sequential file +! = -8 error on close of formatted sequential file +! = -9 error on close of DA file +! =-10 invalid close action (iactio=1,2 permitted only) +! =-11 type of file not supported +! +!-------------------------- KDRCLS ------------------------------------- +! +integer function KDRCLS(itapno,iactio) +!---- +! subroutine arguments +!---- + integer :: itapno,iactio +!---- +! local variables +!---- + integer, parameter :: ndummy=4 + character(len=10) :: acc + character(len=11) :: frm + character(len=22),save,dimension(ndummy) :: ctype= & + (/ ' ','SEQUENTIAL UNFORMATTED', 'SEQUENTIAL CHARACTER ', & + 'DIRECT ACCESS DA ' /) +! + integer, parameter :: nbtape=99 + integer :: ret_val=0,itapet=0 + logical :: lfilop,lnmd + character (len=72) :: cuname +!---- +! invalid unit number +!---- + if((itapno <= 0).or.(itapno > nbtape)) then + ret_val=-5 + go to 7000 + endif + inquire(unit=itapno,opened=lfilop,named=lnmd) + if((.not.lfilop).or.(.not.lnmd)) then + ret_val=-2 + go to 7000 + endif +!---- +! close the file +!---- + inquire(unit=itapno,access=acc,form=frm) + if((acc == 'SEQUENTIAL').and.(frm == 'UNFORMATTED')) then + itapet=2 + ret_val=-7 + else if((acc == 'SEQUENTIAL').and.(frm == 'FORMATTED')) then + itapet=3 + ret_val=-8 + else if((acc == 'DIRECT').and.(frm == 'UNFORMATTED')) then + itapet=4 + ret_val=-9 + else + ret_val=-11 + go to 7000 + endif + if(iactio == 1) then + close(itapno,iostat=iercod,status='KEEP',err=7000) + else if(iactio == 2) then + close(itapno,iostat=iercod,status='DELETE',err=7000) + else + ret_val=-10 + go to 7000 + endif + KDRCLS=0 + return + 7000 inquire(unit=itapno,name=cuname) + write(6,9000) itapno,cuname,ctype(itapet),ret_val,iercod + KDRCLS=ret_val + return +!---- +! error format +!---- + 9000 format('1',5x,'ERROR IN CLOSE OF FILE IN KDROPN'/ & + 6x,'UNIT NB. = ',i10/6x,'FILE NAME = ',a7/6x,'FILE TYPE = ',a22/ & + 6x,'ERROR CODE= ',i7,' IERCOD = ',i7) +end function KDRCLS diff --git a/Ganlib/src/KDRVER.f b/Ganlib/src/KDRVER.f new file mode 100644 index 0000000..75f5acd --- /dev/null +++ b/Ganlib/src/KDRVER.f @@ -0,0 +1,30 @@ +*DECK KDRVER + SUBROUTINE KDRVER(REV,DATE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To extract CVS or SVN version and production date. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: output +* REV revision character identification +* DATE revision character date +* +*----------------------------------------------------------------------- +* + CHARACTER REV*48,DATE*64 +* + REV='Version 5.0.12 ($Revision: 3956 $)' + DATE='$Date: 2025-09-05 09:32:25 -0400 (Fri, 05 Sep 2025) $' + IF(REV(22:).EQ.'ion$)') THEN +* CVS or SVN keyword expansion not performed + REV='Version 5.0.12' + DATE='September 5, 2025' + ENDIF + RETURN + END diff --git a/Ganlib/src/KERNEL.f90 b/Ganlib/src/KERNEL.f90 new file mode 100644 index 0000000..816df72 --- /dev/null +++ b/Ganlib/src/KERNEL.f90 @@ -0,0 +1,66 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for CLE-2000. Call the CLE-2000 driver. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +integer function KERNEL(dummod, iprint) + use GANLIB + implicit none +!---- +! subroutine arguments +!---- + integer :: iprint + interface + function dummod(cmodul, nentry, hentry, ientry, jentry, kentry, & + hparam_c) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) dummod + character(kind=c_char), dimension(*) :: cmodul + integer(c_int), value :: nentry + character(kind=c_char), dimension(13,*) :: hentry + integer(c_int), dimension(nentry) :: ientry, jentry + type(c_ptr), dimension(nentry) :: kentry + character(kind=c_char), dimension(73,*) :: hparam_c + end function dummod + end interface +!---- +! local variables +!---- + interface + function cle2000_c(ilevel, dummod_pt, filein, iprint, my_param) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) cle2000_c + integer(c_int), value :: ilevel, iprint + type(c_funptr), value :: dummod_pt + character(kind=c_char), dimension(*) :: filein + type(c_ptr), value :: my_param + end function cle2000_c + end interface + interface + function stdfil_c (s) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) stdfil_c + character(kind=c_char), dimension(*) :: s + end function stdfil_c + end interface + integer :: ilevel = 1 + type(c_funptr) :: dummod_pt +!---- +! call the driver +!---- + dummod_pt=c_funloc(dummod) + KERNEL=cle2000_c(ilevel, dummod_pt, " "//c_null_char, iprint, c_null_ptr) + return +end function KERNEL diff --git a/Ganlib/src/LCMADD.f b/Ganlib/src/LCMADD.f new file mode 100644 index 0000000..dc2eeb1 --- /dev/null +++ b/Ganlib/src/LCMADD.f @@ -0,0 +1,333 @@ +*DECK LCMADD + SUBROUTINE LCMADD(IPLIS1,IPLIS2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add the floating point information contained in the active directories +* of two tables or XSM files pointed by IPLIS1 and IPLIS2 and store the +* result in the table or XSM file pointed by IPLIS2. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIS1 address of the table or handle to the XSM file. +* IPLIS2 address of the table or handle to the XSM file. +* +*Parameters: output +* IPLIS2 address of the table or handle to the XSM file. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIS1,IPLIS2 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXLEV=50) + CHARACTER NAMT*12,HSMG*131,CTMP1*4,CTMP2*4,HNAME1*12,HNAME2*12, + 1 NAMMY*12,PATH(MAXLEV)*12,FIRST(MAXLEV)*12 + TYPE(C_PTR) KDATA1(MAXLEV),KDATA2(MAXLEV) + INTEGER IVEC(MAXLEV),KJLON(MAXLEV),IGO(MAXLEV) + LOGICAL EMPTY,LCM1,LCM2 + TYPE(C_PTR) :: PT_DATA1,PT_DATA2 + INTEGER, POINTER :: III1(:),III2(:) + REAL, POINTER :: RRR1(:),RRR2(:) + LOGICAL, POINTER :: LLL1(:),LLL2(:) + DOUBLE PRECISION, POINTER :: DDD1(:),DDD2(:) + COMPLEX, POINTER :: CCC1(:),CCC2(:) +* + IF(C_ASSOCIATED(IPLIS1,IPLIS2)) THEN + WRITE(HSMG,'(45HLCMADD: TWO TABLES OR XSM FILES HAVE THE SAME, + 1 8H HANDLE.)') + CALL XABORT(HSMG) + ENDIF + CALL LCMVAL(IPLIS1,' ') + CALL LCMVAL(IPLIS2,' ') + ILEV=1 + KDATA1(1)=IPLIS1 + KDATA2(1)=IPLIS2 + KJLON(1)=-1 + IVEC(1)=1 + IGO(1)=5 +* +* ASSOCIATIVE TABLE. + 10 CALL LCMINF(IPLIS1,HNAME1,NAMMY,EMPTY,ILONG,LCM1) + CALL LCMINF(IPLIS2,HNAME2,NAMMY,EMPTY,ILONG,LCM2) + IF(EMPTY) GO TO (150,150,270,270,380),IGO(ILEV) + NAMT=' ' + CALL LCMNXT(IPLIS1,NAMT) +* + FIRST(ILEV)=NAMT + 15 CALL LCMLEN(IPLIS1,NAMT,ILON1,ITY1) + CALL LCMLEN(IPLIS2,NAMT,ILON2,ITY2) + IF((ILON1.NE.ILON2).OR.(ITY1.NE.ITY2)) THEN + WRITE(6,'(/21H LCMADD: TWO BLOCKS '',A12,6H'' OF '',A12, + 1 7H'' AND '',A12,23H'' ARE OF UNEQUAL TYPE (,2I4,8H) OR LEN, + 2 5HGTH (,2I7,2H).)') NAMT,HNAME1,HNAME2,ITY1,ITY2,ILON1,ILON2 + GO TO 10 + ENDIF + IF(ITY1.EQ.0) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMADD: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME2,'''(1).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + KDATA2(ILEV)=LCMGID(IPLIS2,NAMT) + PATH(ILEV)=NAMT + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=1 + GO TO 10 + ELSE IF(ITY1.EQ.10) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMADD: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME2,'''(2).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILON1 + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + KDATA2(ILEV)=LCMGID(IPLIS2,NAMT) + PATH(ILEV)=NAMT + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=2 + GO TO 190 + ELSE IF(ITY1.LE.6) THEN + IF(ITY1.EQ.1) THEN +* INTEGER DATA. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, III1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, III2, (/ ILON2 /)) + DO 80 I=1,ILON1 + IF(III1(I).NE.III2(I)) THEN + WRITE(HSMG,'(39HLCMADD: INCONSISTENT INTEGER DATA ON TH, + 1 27HE TWO DIRECTORIES. RECORD='',A12,1H'')') NAMT + CALL XABORT(HSMG) + ENDIF + 80 CONTINUE + ELSE IF(ITY1.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, RRR1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, RRR2, (/ ILON2 /)) + DO 90 I=1,ILON1 + RRR2(I)=RRR1(I)+RRR2(I) + 90 CONTINUE + CALL LCMPPD(IPLIS2,NAMT,ILON2,ITY2,PT_DATA2) + ELSE IF(ITY1.EQ.3) THEN +* CHARACTER*4 DATA. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, III1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, III2, (/ ILON2 /)) + DO 100 I=1,ILON1 + WRITE(CTMP1,'(A4)') III1(I) + WRITE(CTMP2,'(A4)') III2(I) + IF(CTMP1.NE.CTMP2) THEN + WRITE(HSMG,'(37HLCMADD: INCONSISTENT CHARACTER DATA O, + 1 31HN THE TWO DIRECTORIES. RECORD='',A12,1H'')') NAMT + CALL XABORT(HSMG) + ENDIF + 100 CONTINUE + ELSE IF(ITY1.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, DDD1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, DDD2, (/ ILON2 /)) + DO 110 I=1,ILON1 + DDD2(I)=DDD1(I)+DDD2(I) + 110 CONTINUE + CALL LCMPPD(IPLIS2,NAMT,ILON2,ITY2,PT_DATA2) + ELSE IF(ITY1.EQ.5) THEN +* LOGICAL DATA. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, LLL1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, LLL2, (/ ILON2 /)) + DO 120 I=1,ILON1 + IF(LLL1(I).NEQV.LLL2(I)) THEN + WRITE(HSMG,'(39HLCMADD: INCONSISTENT LOGICAL DATA ON TH, + 1 27HE TWO DIRECTORIES. RECORD='',A12,1H'')') NAMT + CALL XABORT(HSMG) + ENDIF + 120 CONTINUE + ELSE IF(ITY1.EQ.6) THEN +* COMPLEX DATA. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, CCC1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, CCC2, (/ ILON2 /)) + DO 130 I=1,ILON1 + CCC2(I)=CCC1(I)+CCC2(I) + 130 CONTINUE + CALL LCMPPD(IPLIS2,NAMT,ILON2,ITY2,PT_DATA2) + ELSE + CALL XABORT('LCMADD: INVALID DATA TYPE(1).') + ENDIF + ENDIF + CALL LCMNXT(IPLIS1,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 15 + GO TO (150,150,270,270,380),IGO(ILEV) +* + 150 NAMT=PATH(ILEV) + ILEV=ILEV-1 + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + CALL LCMNXT(IPLIS1,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 15 + GO TO (150,150,270,270,380),IGO(ILEV) +* +* LIST. + 190 IVEC(ILEV)=IVEC(ILEV)+1 + IF(IVEC(ILEV).GT.KJLON(ILEV)) THEN + GO TO (150,150,270,270,380),IGO(ILEV) + ENDIF + CALL LCMLEL(KDATA1(ILEV),IVEC(ILEV),ILON1,ITY1) + CALL LCMLEL(KDATA2(ILEV),IVEC(ILEV),ILON2,ITY2) + IF((ILON1.NE.ILON2).OR.(ITY1.NE.ITY2)) THEN + WRITE(6,'(/24H LCMADD: TWO COMPONENTS ,I6,5H OF '',A12, + 1 7H'' AND '',A12,23H'' ARE OF UNEQUAL TYPE (,2I4,8H) OR LEN, + 2 5HGTH (,2I7,2H).)') IVEC(ILEV),HNAME1,HNAME2,ITY1,ITY2,ILON1, + 3 ILON2 + GO TO 190 + ENDIF + IF((ILON1.NE.0).AND.(ITY1.EQ.0)) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMADD: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME2,'''(3).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA1(ILEV)=LCMGIL(IPLIS1,IVEC(ILEV-1)) + KDATA2(ILEV)=LCMGIL(IPLIS2,IVEC(ILEV-1)) + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=3 + GO TO 10 + ELSE IF((ILON1.NE.0).AND.(ITY1.EQ.10)) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMADD: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME2,'''(4).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILON1 + KDATA1(ILEV)=LCMGIL(IPLIS1,IVEC(ILEV-1)) + KDATA2(ILEV)=LCMGIL(IPLIS2,IVEC(ILEV-1)) + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=4 + GO TO 190 + ELSE IF((ILON1.NE.0).AND.(ITY1.LE.6)) THEN + IF(ITY1.EQ.1) THEN +* INTEGER DATA. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, III1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, III2, (/ ILON2 /)) + DO 220 I=1,ILON1 + IF(III1(I).NE.III2(I)) THEN + WRITE(HSMG,'(39HLCMADD: INCONSISTENT INTEGER DATA ON TH, + 1 32HE TWO DIRECTORIES. LIST ELEMENT=,I5,1H.)') IVEC(ILEV) + CALL XABORT(HSMG) + ENDIF + 220 CONTINUE + ELSE IF((ITY1.EQ.2).OR.(ITY1.EQ.6)) THEN +* SINGLE PRECISION DATA. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, RRR1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, RRR2, (/ ILON2 /)) + DO 230 I=1,ILON1 + RRR2(I)=RRR1(I)+RRR2(I) + 230 CONTINUE + CALL LCMPPL(IPLIS2,IVEC(ILEV),ILON2,ITY2,PT_DATA2) + ELSE IF(ITY1.EQ.3) THEN +* CHARACTER*4 DATA. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, III1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, III2, (/ ILON2 /)) + DO 240 I=1,ILON1 + WRITE(CTMP1,'(A4)') III1(I) + WRITE(CTMP2,'(A4)') III2(I) + IF(CTMP1.NE.CTMP2) THEN + WRITE(HSMG,'(38HLCMADD: INCONSISTENT CHARACTER DATA ON, + 1 35H THE TWO DIRECTORIES. LIST ELEMENT=,I5,1H.)') + 2 IVEC(ILEV) + CALL XABORT(HSMG) + ENDIF + 240 CONTINUE + ELSE IF(ITY1.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, DDD1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, DDD2, (/ ILON2 /)) + DO 250 I=1,ILON1 + DDD2(I)=DDD1(I)+DDD2(I) + 250 CONTINUE + CALL LCMPPL(IPLIS2,IVEC(ILEV),ILON2,ITY2,PT_DATA2) + ELSE IF(ITY1.EQ.5) THEN +* LOGICAL DATA. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, LLL1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, LLL2, (/ ILON2 /)) + DO 260 I=1,ILON1 + IF(LLL1(I).NEQV.LLL2(I)) THEN + WRITE(HSMG,'(39HLCMADD: INCONSISTENT LOGICAL DATA ON TH, + 1 32HE TWO DIRECTORIES. LIST ELEMENT=,I5,1H.)') IVEC(ILEV) + CALL XABORT(HSMG) + ENDIF + 260 CONTINUE + ELSE IF(ITY1.EQ.6) THEN +* COMPLEX DATA. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, CCC1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, CCC2, (/ ILON2 /)) + DO 265 I=1,ILON1 + CCC2(I)=CCC1(I)+CCC2(I) + 265 CONTINUE + CALL LCMPPL(IPLIS2,IVEC(ILEV),ILON2,ITY2,PT_DATA2) + ELSE + CALL XABORT('LCMADD: INVALID DATA TYPE(2).') + ENDIF + ENDIF + GO TO 190 +* + 270 ILEV=ILEV-1 + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + GO TO 190 +* + 380 RETURN + END diff --git a/Ganlib/src/LCMAUX.f90 b/Ganlib/src/LCMAUX.f90 new file mode 100644 index 0000000..e6a4ee6 --- /dev/null +++ b/Ganlib/src/LCMAUX.f90 @@ -0,0 +1,578 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for lcm -- part 1. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +module LCMAUX +contains +subroutine STRCUT(name1, name2) + ! transform a Fortran string into a C null-terminated string + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: name1 + character(len=*) :: name2 + integer :: ilong + interface + subroutine strcut_c (s, ct, n) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: s, ct + integer(c_int), value :: n + end subroutine strcut_c + end interface + ilong=len(name2) + call strcut_c(name1, name2, ilong) +end subroutine STRCUT +! +subroutine STRFIL(name1, name2) + ! transform a C null-terminated string into a Fortran string + use, intrinsic :: iso_c_binding + character(len=*) :: name1 + character(kind=c_char), dimension(*) :: name2 + integer :: ilong + interface + subroutine strfil_c (s, ct, n) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: s, ct + integer(c_int), value :: n + end subroutine strfil_c + end interface + ilong=len(name1) + call strfil_c(name1, name2, ilong) +end subroutine STRFIL +! +function LCMARA(ilong) + ! allocate an array of length ilong and return a c_ptr pointer + use, intrinsic :: iso_c_binding + type(c_ptr) LCMARA + integer :: ilong + interface + function setara_c (length) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) setara_c + integer(c_int), value :: length + end function setara_c + end interface + LCMARA=setara_c(ilong) +end function LCMARA +! +subroutine LCMDRD(ipdata) + ! deallocate an array allocated by LCMARA + use, intrinsic :: iso_c_binding + type(c_ptr) ipdata + interface + subroutine rlsara_c (ipd) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr),value :: ipd + end subroutine rlsara_c + end interface + call rlsara_c(ipdata) +end subroutine LCMDRD +! +subroutine LCMOP(iplist, name, imp, medium, impx) + ! open a LCM object + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(len=*) :: name + character(kind=c_char), dimension(73) :: name73 + integer imp, medium, impx + interface + subroutine lcmop_c (iplist, namp, imp, medium, impx) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: imp, medium, impx + end subroutine lcmop_c + end interface + call STRCUT(name73, name) + call lcmop_c(iplist, name73, imp, medium, impx) +end subroutine LCMOP +! +subroutine LCMPPD(iplist, name, ilong, itype, pt_data) + ! store a record in an associative table via its c_ptr pointer + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + interface + subroutine lcmppd_c (iplist, namp, ilong, itype, iofdum) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: iofdum + end subroutine lcmppd_c + end interface + call STRCUT(name13, name) + call lcmppd_c(iplist, name13, ilong, itype, pt_data) + pt_data=c_null_ptr +end subroutine LCMPPD +! +subroutine LCMGPD(iplist, name, pt_data) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + interface + subroutine lcmgpd_c (iplist, namp, iofdum) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr) :: iofdum + end subroutine lcmgpd_c + end interface + call STRCUT(name13, name) + call lcmgpd_c(iplist, name13, pt_data) +end subroutine LCMGPD +! +subroutine LCMLEN(iplist, name, ilong, itylcm) + ! recover length and type of a record in an associative table + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(len=*),intent(in) :: name + integer :: ilong, itylcm + character(kind=c_char), dimension(13) :: name13 + interface + subroutine lcmlen_c (iplist, namp, ilong, itylcm) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: ilong, itylcm + end subroutine lcmlen_c + end interface + call STRCUT(name13, name) + call lcmlen_c(iplist, name13, ilong, itylcm) +end subroutine LCMLEN +! +subroutine LCMINF(iplist, fnamlcm, fnammy, fempty, ilong, flcml) + ! recover general info about a LCM object + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(len=*) :: fnamlcm, fnammy + logical :: fempty, flcml + integer :: empty, ilong, lcml, access + character(kind=c_char), dimension(73) :: namlcm + character(kind=c_char), dimension(13) :: nammy + interface + subroutine lcminf_c (iplist, namlcm, nammy, empty, ilong, lcml, access) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namlcm, nammy + integer(c_int) :: empty, ilong, lcml, access + end subroutine lcminf_c + end interface + call lcminf_c(iplist, namlcm, nammy, empty, ilong, lcml, access) + call STRFIL(fnamlcm, namlcm) + call STRFIL(fnammy, nammy) + fempty=(empty == 1) + flcml=(lcml == 1) +end subroutine LCMINF +! +subroutine LCMNXT(iplist, name) + ! recover name of next record in an associative table + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(len=*) :: name + character(kind=c_char), dimension(13) :: name13 + interface + subroutine lcmnxt_c (iplist, namp) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + end subroutine lcmnxt_c + end interface + call STRCUT(name13, name) + call lcmnxt_c(iplist, name13) + call STRFIL(name, name13) +end subroutine LCMNXT +! +subroutine LCMVAL(iplist, name) + ! validate an associative table, starting from name + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + interface + subroutine lcmval_c (iplist, namp) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + end subroutine lcmval_c + end interface + call STRCUT(name13, name) + call lcmval_c(iplist, name13) +end subroutine LCMVAL +! +subroutine LCMDEL(iplist, name) + ! delete a record in an associative table + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + interface + subroutine lcmdel_c (iplist, namp) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + end subroutine lcmdel_c + end interface + call STRCUT(name13, name) + call lcmdel_c(iplist, name13) +end subroutine LCMDEL +! +function LCMDID(iplist, name) + ! create/access a daughter table in a parent table in modification mode + use, intrinsic :: iso_c_binding + type(c_ptr) :: LCMDID,iplist + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + interface + function lcmdid_c (iplist, namp) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: lcmdid_c,iplist + character(kind=c_char), dimension(*) :: namp + end function lcmdid_c + end interface + call STRCUT(name13, name) + LCMDID = lcmdid_c(iplist, name13) +end function LCMDID +! +function LCMLID(iplist, name, ilong) + ! create/access a daughter list in a parent table in modification mode + use, intrinsic :: iso_c_binding + type(c_ptr) :: LCMLID,iplist + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong + interface + function lcmlid_c (iplist, namp, ilong) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: lcmlid_c,iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong + end function lcmlid_c + end interface + call STRCUT(name13, name) + LCMLID = lcmlid_c(iplist, name13, ilong) +end function LCMLID +! +function LCMDIL(iplist, ipos) + ! create/access a daughter table in a parent list in modification mode + use, intrinsic :: iso_c_binding + type(c_ptr) :: LCMDIL,iplist + integer :: ipos + interface + function lcmdil_c (iplist, ipos) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: lcmdil_c,iplist + integer(c_int), value :: ipos + end function lcmdil_c + end interface + LCMDIL = lcmdil_c(iplist, ipos-1) +end function LCMDIL +! +function LCMLIL(iplist, ipos, ilong) + ! create/access a daughter list in a parent list in modification mode + use, intrinsic :: iso_c_binding + type(c_ptr) :: LCMLIL,iplist + integer :: ipos, ilong + interface + function lcmlil_c (iplist, ipos, ilong) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: lcmlil_c,iplist + integer(c_int), value :: ipos, ilong + end function lcmlil_c + end interface + LCMLIL = lcmlil_c(iplist, ipos-1, ilong) +end function LCMLIL +! +function LCMGID(iplist, name) + ! access a daughter table/list in a parent table in read-only mode + use, intrinsic :: iso_c_binding + type(c_ptr) :: LCMGID,iplist + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + interface + function lcmgid_c (iplist, namp) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: lcmgid_c,iplist + character(kind=c_char), dimension(*) :: namp + end function lcmgid_c + end interface + call STRCUT(name13, name) + LCMGID = lcmgid_c(iplist, name13) +end function LCMGID +! +function LCMGIL(iplist, ipos) + ! access a daughter table/list in a parent list in read-only mode + use, intrinsic :: iso_c_binding + type(c_ptr) :: LCMGIL,iplist + integer :: ipos + interface + function lcmgil_c (iplist, ipos) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: lcmgil_c,iplist + integer(c_int), value :: ipos + end function lcmgil_c + end interface + LCMGIL = lcmgil_c(iplist, ipos-1) +end function LCMGIL +! +subroutine LCMSIX(iplist, name, iact) + ! create/access a daughter table in a parent table + ! depreciated: better to use LCMDID + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(len=*),intent(in) :: name + integer :: iact + character(kind=c_char), dimension(13) :: name13 + interface + subroutine lcmsix_c (iplist, namp, iact) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: iact + end subroutine lcmsix_c + end interface + call STRCUT(name13, name) + call lcmsix_c(iplist, name13, iact) +end subroutine LCMSIX +! +subroutine LCMPPL(iplist, ipos, ilong, itype, pt_data) + ! store a record in an heterogeneous list via its c_ptr pointer + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + interface + subroutine lcmppl_c (iplist, ipos, ilong, itype, iofdum) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: iofdum + end subroutine lcmppl_c + end interface + call lcmppl_c(iplist, ipos-1, ilong, itype, pt_data) + pt_data=c_null_ptr +end subroutine LCMPPL +! +subroutine LCMLEL(iplist, ipos, ilong, itylcm) + ! recover length and type of a record in an heterogeneous list + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer :: ipos, ilong, itylcm + interface + subroutine lcmlel_c (iplist, ipos, ilong, itylcm) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + integer(c_int) :: ilong, itylcm + end subroutine lcmlel_c + end interface + call lcmlel_c(iplist, ipos-1, ilong, itylcm) +end subroutine LCMLEL +! +subroutine LCMGPL(iplist, ipos, pt_data) + ! recover a record from an heterogeneous list via its c_ptr pointer + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + interface + subroutine lcmgpl_c (iplist, ipos, iofdum) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, iofdum + integer(c_int), value :: ipos + end subroutine lcmgpl_c + end interface + call lcmgpl_c(iplist, ipos-1, pt_data) +end subroutine LCMGPL +! +subroutine LCMCL(iplist, iact) + ! close a LCM object + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer :: iact + interface + subroutine lcmcl_c (iplist, iact) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: iact + end subroutine lcmcl_c + end interface + call lcmcl_c(iplist, iact) +end subroutine LCMCL +! +subroutine LCMEQU(iplis1, iplis2) + ! deep copy of a LCM object + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplis1, iplis2 + interface + subroutine lcmequ_c (iplis1, iplis2) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplis1, iplis2 + end subroutine lcmequ_c + end interface + call lcmequ_c(iplis1, iplis2) +end subroutine LCMEQU +! +subroutine LCMEXP(iplist, impx, nunit, imode, idir) + ! import/export a LCM object + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, file = c_null_ptr + integer, intent(in) :: impx, nunit, imode, idir + character(len=72) :: filename + character(kind=c_char), dimension(73) :: filename_c + integer(c_int) :: ier + interface + function fopen (filename_c, mode) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) fopen + character(kind=c_char), dimension(*) :: filename_c, mode + end function fopen + end interface + interface + function fclose (file) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) fclose + type(c_ptr), value :: file + end function fclose + end interface + interface + subroutine lcmexp_c (iplist, impx, file, imode, idir) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + type(c_ptr), value :: file + integer(c_int), value :: impx, imode, idir + end subroutine lcmexp_c + end interface + interface + function stdfil_c (s) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) stdfil_c + character(kind=c_char), dimension(*) :: s + end function stdfil_c + end interface +! + if(nunit == 0) then + file=c_null_ptr + else if(nunit == 6) then + file=stdfil_c("stdout"//c_null_char) + flush(6) + else + inquire(nunit,name=filename) + close(nunit,status='keep') + call STRCUT(filename_c, filename) + if(imode == 1) then + if(idir == 1) then + file=fopen(filename_c, "wb"//c_null_char) + else + file=fopen(filename_c, "rb"//c_null_char) + endif + else if(imode == 2) then + if(idir == 1) then + file=fopen(filename_c, "w"//c_null_char) + else + file=fopen(filename_c, "r"//c_null_char) + endif + endif + if(.not.c_associated(file)) call XABORT('LCMEXP: UNABLE TO OPEN FILE '//filename(:44)) + endif + call lcmexp_c(iplist, impx, file, imode, idir) + if(nunit /= 6) then + ier = fclose(file) + if(ier /= 0) call XABORT('LCMEXP: UNABLE TO CLOSE FILE '//filename(:43)) + if(imode == 1) then + open(nunit,file=filename,status='old',form='unformatted',position='append') + else + open(nunit,file=filename,status='old',position='append') + endif + endif +end subroutine LCMEXP +! +!----------------------------------------------------------------------- +! additionnal lcm subroutine specific to Version 3 +! R. Chambon (based on Version 4) +!----------------------------------------------------------------------- +subroutine LCMEXPV3(iplist, impx, nunit, imode, idir) + ! import/export a LCM object V3 + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, file = c_null_ptr + integer, intent(in) :: impx, nunit, imode, idir + character(len=72) :: filename + character(kind=c_char), dimension(73) :: filename_c + integer(c_int) :: ier + interface + function fopen (filename_c, mode) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) fopen + character(kind=c_char), dimension(*) :: filename_c, mode + end function fopen + end interface + interface + function fclose (file) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) fclose + type(c_ptr), value :: file + end function fclose + end interface + interface + subroutine lcmexpv3_c (iplist, impx, file, imode, idir) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + type(c_ptr), value :: file + integer(c_int), value :: impx, imode, idir + end subroutine lcmexpv3_c + end interface + interface + function stdfil_c (s) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) stdfil_c + character(kind=c_char), dimension(*) :: s + end function stdfil_c + end interface +! + if(nunit == 0) then + file=c_null_ptr + else if(nunit == 6) then + file=stdfil_c("stdout"//c_null_char) + else + inquire(nunit,name=filename) + close(nunit,status='keep') + call STRCUT(filename_c, filename) + if(imode == 1) then + if(idir == 1) then + file=fopen(filename_c, "wb"//c_null_char) + else + file=fopen(filename_c, "rb"//c_null_char) + endif + else if(imode == 2) then + if(idir == 1) then + file=fopen(filename_c, "w"//c_null_char) + else + file=fopen(filename_c, "r"//c_null_char) + endif + endif + if(.not.c_associated(file)) call XABORT('LCMEXPV3: UNABLE TO OPEN FILE '//filename(:44)) + endif + call lcmexpv3_c(iplist, impx, file, imode, idir) + if(nunit /= 6) then + ier = fclose(file) + if(ier /= 0) call XABORT('LCMEXPV3: UNABLE TO CLOSE FILE '//filename(:43)) + if(imode == 1) then + open(nunit,file=filename,status='old',form='unformatted',position='append') + else + open(nunit,file=filename,status='old',position='append') + endif + endif +end subroutine LCMEXPV3 +end module LCMAUX diff --git a/Ganlib/src/LCMCAR.f b/Ganlib/src/LCMCAR.f new file mode 100644 index 0000000..ef6d5a1 --- /dev/null +++ b/Ganlib/src/LCMCAR.f @@ -0,0 +1,109 @@ +*DECK LCMCAR + SUBROUTINE LCMCAR(TEXT,LACTIO,NITMA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transform a character variable into integer vector back and forth. +* This routine is portable and based on the *ascii* collating sequence, +* equivalence between: text=' ' <=> nitma=0, is imposed. +* +*Copyright: +* Copyright (C) 1999 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* TEXT character variable. +* LACT logical conversion flag: .true. character to integer; +* .false. integer to character. +* NITMA integer (32 bits) vector. +* +*Limitations: +* it is assumed that: 0 <= ichar() <= 255, +* otherwise a character would not stand in one byte. +* +*Internal parameters: +* ALPHAB limited alphabet used for variable names (character*96). +* TASCII table to convert ichar() values into *ascii* codes. +* IASCII inversion of tascii(). +* IBASE1 integral basis defined as maximum value of ichar()+1; +* to optimize calculations, it is a power of 2 (128 or 256). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE + CHARACTER TEXT*(*) + LOGICAL LACTIO + CHARACTER ALPHAB*96 + INTEGER NITMA(*) + INTEGER IBASE1,IBASE2,TASCII(0:255),IASCII(0:127) + INTEGER I0,I1,I2,I3,J01,J23,K,LMAX,L1,NBDIM,IBDIM + INTEGER IWRITE + PARAMETER ( IWRITE= 6 ) + SAVE IBASE1,IBASE2,TASCII,IASCII + DATA IBASE1/0/ +* + IF(IBASE1.EQ.0) THEN +* PREPARE TABLES TASCII() AND IASCII() AND SET INTEGERS IBASE1 +* + IBASE2 FOR CHARACTER/INTEGER CONVERSIONS. +* 0 1 2 3 +* 0123456789012345678901234567890123456789 + ALPHAB=' !..$%&.()*+,-./0123456789:;<=>?.ABCDEF'// + > 'GHIJKLMNOPQRSTUVWXYZ...._.abcdefghijklmn'// + > 'opqrstuvwxyz.....' +* + LMAX= 0 + DO 30 K=0,95 + L1= ICHAR(ALPHAB(K+1:K+1)) + LMAX= MAX(LMAX,L1) + TASCII(L1)= K + IASCII(K)= L1 + 30 CONTINUE + IF( LMAX.LT.128 )THEN + IBASE1= 128 + ELSE + IBASE1= 256 + ENDIF + IBASE2= IBASE1*IBASE1 + ENDIF +* + NBDIM= LEN(TEXT) + IF( MOD(NBDIM,4).NE.0 )THEN + WRITE(IWRITE,*) 'LCMCAR: LEN(TEXT)=',NBDIM,' NOT / BY 4' + CALL XABORT('LCMCAR: INVALID CHARACTER <-> INTEGER CONVERSION') + ELSE + NBDIM= NBDIM/4 + ENDIF + IF( LACTIO )THEN +* +* CONVERT EACH CHARACTER*4 TO INTEGER + DO 10 IBDIM= 1, NBDIM + I0= TASCII(ICHAR(TEXT(IBDIM*4-3:IBDIM*4-3))) + I1= TASCII(ICHAR(TEXT(IBDIM*4-2:IBDIM*4-2))) + I2= TASCII(ICHAR(TEXT(IBDIM*4-1:IBDIM*4-1))) + I3= TASCII(ICHAR(TEXT(IBDIM*4 :IBDIM*4 ))) + NITMA(IBDIM)= (I0+IBASE1*I1) + IBASE2*(I2+IBASE1*I3) + 10 CONTINUE + ELSE +* +* CONVERT INTEGER TO CHARACTER*4 + DO 20 IBDIM= 1, NBDIM + J23= NITMA(IBDIM)/IBASE2 + I3 = J23/IBASE1 + I2 = J23-IBASE1*I3 + J01= NITMA(IBDIM)-J23*IBASE2 + I1 = J01/IBASE1 + I0 = J01-IBASE1*I1 + TEXT(IBDIM*4-3:IBDIM*4-3)= CHAR(IASCII(I0)) + TEXT(IBDIM*4-2:IBDIM*4-2)= CHAR(IASCII(I1)) + TEXT(IBDIM*4-1:IBDIM*4-1)= CHAR(IASCII(I2)) + TEXT(IBDIM*4 :IBDIM*4 )= CHAR(IASCII(I3)) + 20 CONTINUE + ENDIF + RETURN + END diff --git a/Ganlib/src/LCMEXS.f b/Ganlib/src/LCMEXS.f new file mode 100644 index 0000000..a1b1659 --- /dev/null +++ b/Ganlib/src/LCMEXS.f @@ -0,0 +1,224 @@ +*DECK LCMEXS + SUBROUTINE LCMEXS(IPLIST,IMPX,NUNIT,IMODE,IDIR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Export/import the content of a table or xsm file using the contour +* method. Export start from the active directory. This version is +* backward compatible with the Saphyr version of xsm file export +* format. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIS1 address of the table or handle to the XSM file. +* IMPX equal to zero for no print. +* NUNIT file unit number where the export/import is performed. +* IMODE type of export/import file: =1 sequential unformatted; +* =2 sequential formatted (ascii). +* IDIR type of operation: =1 to export; =2 to import. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER IMPX,NUNIT,IMODE,IDIR +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NLEVEL=50) + CHARACTER NAMT*12,MYNAME*12,PATH(NLEVEL)*12,FIRST(NLEVEL)*12, + 1 NAMLCM*12,HSMG*131,CMEDIU(2)*8 + LOGICAL EMPTY,LCM + TYPE(C_PTR) PT_DATA + DATA (CMEDIU(II),II=1,2)/'TABLE','XSM FILE'/ +* + CALL LCMINF(IPLIST,NAMLCM,MYNAME,EMPTY,ILONG,LCM) + IMED=2 + IF(LCM) IMED=1 + IF(ILONG.GE.0) THEN + WRITE(HSMG,'(46HLCMEXS: UNABLE TO IMPORT/EXPORT A LIST IN THE , + 1 A8,8H NAMED '',A12,2H''.)') CMEDIU(IMED),NAMLCM + CALL XABORT(HSMG) + ENDIF + IF((IMODE.LT.1).OR.(IMODE.GT.2)) THEN + WRITE(HSMG,'(33HLCMEXS: INVALID FILE TYPE ON THE ,A8, + 1 8H NAMED '',A12,2H''.)') CMEDIU(IMED),NAMLCM + CALL XABORT(HSMG) + ENDIF + ITOT=0 + ILEVEL=1 + IF(IDIR.EQ.1) THEN + IF(IMPX.GT.0)THEN + WRITE(6,300) 'EXPORT',CMEDIU(IMED),NAMLCM,MYNAME + ENDIF + CALL LCMVAL(IPLIST,' ') + GO TO 10 + ELSE IF(IDIR.EQ.2) THEN + IF(IMPX.GT.0)THEN + WRITE(6,300) 'IMPORT',CMEDIU(IMED),NAMLCM,MYNAME + ENDIF + GO TO 50 + ELSE IF(EMPTY) THEN + WRITE(HSMG,'(14HLCMEXS: EMPTY ,A8,8H NAMED '',A12,2H''.)') + 1 CMEDIU(IMED),NAMLCM + CALL XABORT(HSMG) + ELSE + WRITE(HSMG,'(30HLCMEXS: INVALID ACTION ON THE ,A8,8H NAMED '', + 1 A12,2H''.)') CMEDIU(IMED),NAMLCM + CALL XABORT(HSMG) + ENDIF +*---- +* FILE EXPORT. +*---- + 10 NAMT=' ' + LENNAM=12 + CALL LCMNXT(IPLIST,NAMT) + IF(NAMT.EQ.' ') THEN + IF(ILEVEL.EQ.1) RETURN + NAMT=PATH(ILEVEL) + ILEVEL=ILEVEL-1 + CALL LCMSIX(IPLIST,' ',2) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) 0,0,0,0 + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,310) 0,0,0,0 + ENDIF + IF(IMPX.GT.0) WRITE(6,350) ILEVEL + GO TO 30 + ENDIF + FIRST(ILEVEL)=NAMT +* + 20 CALL LCMLEN(IPLIST,NAMT,ILONG,ITYLCM) + IF(ITYLCM.EQ.0) ILONG=1 + IF(IMPX.GT.0) WRITE(6,320) ILEVEL,NAMT,ITYLCM,ILONG + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) ILEVEL,LENNAM,ITYLCM,ILONG + WRITE(NUNIT) NAMT + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,310) ILEVEL,LENNAM,ITYLCM,ILONG + WRITE(NUNIT,'(A12,68(1H ))') NAMT + ENDIF + IF(ITYLCM.EQ.0) THEN +* DIRECTORY DATA. + ILEVEL=ILEVEL+1 + IF(ILEVEL.GT.NLEVEL) CALL XABORT('LCMEXS: TOO MANY DIRECTORY ' + 1 //'LEVELS.') + CALL LCMSIX(IPLIST,NAMT,1) + PATH(ILEVEL)=NAMT + GO TO 10 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.LE.6)) THEN + ITOT=ITOT+ILONG + IF(NUNIT.NE.0) THEN + CALL LCMGPD(IPLIST,NAMT,PT_DATA) +* ------------------ EXPORT A NODE ----------------- + CALL LCMNOS(NUNIT,IMODE,IDIR,ILONG,ITYLCM,PT_DATA) +* -------------------------------------------------- + ENDIF + ENDIF + 30 CALL LCMNXT(IPLIST,NAMT) + IF(NAMT.EQ.FIRST(ILEVEL)) THEN + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) 0,0,0,0 + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,310) 0,0,0,0 + ENDIF + IF(IMPX.GT.0) WRITE(6,350) ILEVEL + IF(ILEVEL.EQ.1) GO TO 40 + NAMT=PATH(ILEVEL) + ILEVEL=ILEVEL-1 + CALL LCMSIX(IPLIST,' ',2) + GO TO 30 + ENDIF + GO TO 20 + 40 IF(IMPX.GT.0) WRITE(6,330) 'EXPORTED',ITOT + RETURN +*---- +* FILE IMPORT. +*---- + 50 IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT,END=80) JLEVEL,LENNAM,ITYLCM,ILONG + IF(LENNAM.GT.12) THEN + CALL XABORT('LCMEXS: A RECORD NAME IS GREATER THAN 12 CHAR' + 1 //'ACTERS(1).') + ENDIF + READ(NUNIT) NAMT + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,340,END=70) JLEVEL,LENNAM,ITYLCM,ILONG + IF(LENNAM.GT.12) THEN + CALL XABORT('LCMEXS: A RECORD NAME IS GREATER THAN 12 CHAR' + 1 //'ACTERS(2).') + ENDIF + READ(NUNIT,'(A12)') NAMT + ENDIF + IF(JLEVEL.NE.1) THEN + WRITE(HSMG,'(29HLCMEXS: UNABLE TO IMPORT THE ,A8,9H LOCATED , + 1 7HON UNIT,I3,1H.)') CMEDIU(IMED),NUNIT + CALL XABORT(HSMG) + ENDIF +* + 60 IF(ITYLCM.EQ.0) THEN +* DIRECTORY DATA. + IF(IMPX.GT.0) WRITE(6,320) JLEVEL,NAMT,ITYLCM + ILEVEL=ILEVEL+1 + CALL LCMSIX(IPLIST,NAMT,1) + ELSE + IF(IMPX.GT.0) WRITE(6,320) JLEVEL,NAMT,ITYLCM,ILONG + JLONG=ILONG + IF((ITYLCM.EQ.4).OR.(ITYLCM.EQ.6)) JLONG=2*ILONG + PT_DATA = LCMARA(JLONG) +* ----------------- IMPORT A NODE ------------------ + CALL LCMNOS(NUNIT,IMODE,IDIR,ILONG,ITYLCM,PT_DATA) +* -------------------------------------------------- + CALL LCMPPD(IPLIST,NAMT,ILONG,ITYLCM,PT_DATA) + ITOT=ITOT+ILONG + ENDIF + 70 IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT,END=70) JLEVEL,LENNAM,ITYLCM,ILONG + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,340,END=70) JLEVEL,LENNAM,ITYLCM,ILONG + ENDIF + IF(JLEVEL.EQ.0) THEN + IF(IMPX.GT.0) WRITE(6,350) ILEVEL + ILEVEL=ILEVEL-1 + IF(ILEVEL.EQ.0) GO TO 80 + CALL LCMSIX(IPLIST,' ',2) + GO TO 70 + ELSE + IF(JLEVEL.NE.ILEVEL) THEN + CALL XABORT('LCMEXS: IMPORT FAILURE.') + ELSE IF(LENNAM.GT.12) THEN + CALL XABORT('LCMEXS: A RECORD NAME IS GREATER THAN 12 CHAR' + 1 //'ACTERS(3).') + ENDIF + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT) NAMT + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(A12)') NAMT + ENDIF + GO TO 60 + ENDIF +* + 80 IF(IMPX.GT.0) WRITE(6,330) 'IMPORTED',ITOT + RETURN +* + 300 FORMAT (//9H LCMEXS: ,A6,1H ,A8,8H NAMED ',A12,15H' FROM ACTIVE D, + 1 10HIRECTORY ',A12,3H' ://18H LEVEL BLOCK NAME,4(1H-),4X,5HTYPE , + 2 7H LENGTH/) + 310 FORMAT ('->',4I8,46(1H )) + 320 FORMAT ('&*',I5,' ''',A12,'''',2I8) + 330 FORMAT (/23H TOTAL NUMBER OF WORDS ,A8,2H =,I10/) + 340 FORMAT (2X,4I8) + 350 FORMAT ('&*',I5,2X,14('-')) + END diff --git a/Ganlib/src/LCMGCD.f b/Ganlib/src/LCMGCD.f new file mode 100644 index 0000000..291b073 --- /dev/null +++ b/Ganlib/src/LCMGCD.f @@ -0,0 +1,59 @@ +*DECK LCMGCD + SUBROUTINE LCMGCD(IPLIST,NAMP,ILONG,HDATA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Copy a character variable from a table into memory. +* +*Copyright: +* Copyright (C) 2000 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIST address of the table. +* NAMP character*12 name of the existing block. +* ILONG dimension of the character variable. +* +*Parameters: output +* HDATA character variable. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER ILONG + CHARACTER*(*) NAMP,HDATA(ILONG) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIST + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA +* + ILE1=(LEN(HDATA(1))+3)/4 + CALL LCMLEN(IPLIST,NAMP,JLONG,ITYLCM) + IF(ITYLCM.NE.10) CALL XABORT('LCMGCD: LIST EXPECTED.') + IF(JLONG.GT.ILONG) CALL XABORT('LCMGCD: HDATA OVERFLOW.') + JPLIST=LCMGID(IPLIST,NAMP) + DO ISET=1,JLONG + CALL LCMLEL(JPLIST,ISET,ILE2,ITYLCM) + IF(ITYLCM.NE.3) CALL XABORT('LCMGCD: CHARACTER EXPECTED.') + ALLOCATE(IDATA(ILE2)) + CALL LCMGDL(JPLIST,ISET,IDATA) + HDATA(ISET)=' ' + WRITE(HDATA(ISET),'(100A4)') (IDATA(I),I=1,MIN(ILE1,ILE2)) + DEALLOCATE(IDATA) + ENDDO + DO ISET=JLONG+1,ILONG + HDATA(ISET)=' ' + ENDDO + RETURN + END diff --git a/Ganlib/src/LCMGCL.f b/Ganlib/src/LCMGCL.f new file mode 100644 index 0000000..c58249e --- /dev/null +++ b/Ganlib/src/LCMGCL.f @@ -0,0 +1,59 @@ +*DECK LCMGCL + SUBROUTINE LCMGCL(IPLIST,ISET,ILONG,HDATA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Copy a character variable from a list into memory. +* +*Copyright: +* Copyright (C) 2000 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIST address of the table. +* ISET position of the block in the list. +* ILONG dimension of the character variable. +* +*Parameters: output +* HDATA character variable. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER ISET,ILONG + CHARACTER*(*) HDATA(ILONG) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIST + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA +* + ILE1=(LEN(HDATA(1))+3)/4 + CALL LCMLEL(IPLIST,ISET,JLONG,ITYLCM) + IF(ITYLCM.NE.10) CALL XABORT('LCMGCD: LIST EXPECTED.') + IF(JLONG.GT.ILONG) CALL XABORT('LCMGCD: HDATA OVERFLOW.') + JPLIST=LCMLIL(IPLIST,ISET,JLONG) + DO JSET=1,ILONG + CALL LCMLEL(JPLIST,JSET,ILE2,ITYLCM) + IF(ITYLCM.NE.3) CALL XABORT('LCMGCL: CHARACTER EXPECTED.') + ALLOCATE(IDATA(ILE2)) + CALL LCMGDL(JPLIST,JSET,IDATA) + HDATA(JSET)=' ' + WRITE(HDATA(JSET),'(100A4)') (IDATA(I),I=1,MIN(ILE1,ILE2)) + DEALLOCATE(IDATA) + ENDDO + DO ISET=JLONG+1,ILONG + HDATA(ISET)=' ' + ENDDO + RETURN + END diff --git a/Ganlib/src/LCMLIB.f b/Ganlib/src/LCMLIB.f new file mode 100644 index 0000000..ceacc8e --- /dev/null +++ b/Ganlib/src/LCMLIB.f @@ -0,0 +1,107 @@ +*DECK LCMLIB + SUBROUTINE LCMLIB(IPLIST) +* +*---------------------------------------------------------------------- +* +*Purpose: +* List the LCM entries contained in a table or a XSM file. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIST address of the table or handle to the XSM file. +* +*---------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NTYPE=11) + CHARACTER NAMT*12,NAMLCM*12,MYNAME*12,FIRST*12,CTYPE(NTYPE)*16, + 1 CMEDIU(2)*8 + LOGICAL EMPTY,LCM + SAVE CTYPE,CMEDIU + CHARACTER(LEN=12) HSIGN + DATA (CTYPE(ITY),ITY=1,NTYPE)/'DIRECTORY','INTEGER','REAL', + > 'CHARACTER','DOUBLE PRECISION','LOGICAL','COMPLEX','UNDEFINED', + > ' ',' ','LIST'/ + DATA (CMEDIU(II),II=1,2)/'TABLE','XSM FILE'/ +* + CALL LCMINF(IPLIST,NAMLCM,MYNAME,EMPTY,ILONG,LCM) + IMED=1 + IF(.NOT.LCM) IMED=2 + ITOT=0 + NAMT=' ' + IF(ILONG.EQ.-1) THEN + IF(EMPTY) THEN + WRITE (6,80) MYNAME,CMEDIU(IMED),NAMLCM + RETURN + ENDIF + CALL LCMNXT(IPLIST,NAMT) + FIRST=NAMT + WRITE(6,100) MYNAME,CMEDIU(IMED),NAMLCM + INMT=0 +* + 10 INMT=INMT+1 + CALL LCMLEN(IPLIST,NAMT,ILONG,ITYLCM) + IF((ITYLCM.EQ.0).OR.(ITYLCM.EQ.10)) THEN + WRITE (6,120) INMT,NAMT,ILONG,CTYPE(ITYLCM+1) + ELSE IF((ITYLCM.GE.1).AND.(ITYLCM.LE.6)) THEN + IF((ILONG.EQ.3).AND.(ITYLCM.EQ.3)) THEN + CALL LCMGTC(IPLIST,NAMT,12,HSIGN) + WRITE (6,110) INMT,NAMT,ILONG,CTYPE(ITYLCM+1), + 1 HSIGN + ELSE + WRITE (6,120) INMT,NAMT,ILONG,CTYPE(ITYLCM+1) + ENDIF + ITOT=ITOT+ILONG + ELSE + WRITE (6,120) INMT,NAMT,ILONG,CTYPE(8) + ENDIF + CALL LCMNXT(IPLIST,NAMT) + IF(NAMT.EQ.FIRST) GO TO 20 + GO TO 10 +* + 20 WRITE(6,130) MYNAME,ITOT + ELSE + IF(ILONG.EQ.0) THEN + WRITE (6,90) MYNAME,CMEDIU(IMED),NAMLCM + RETURN + ENDIF + WRITE(6,100) MYNAME,CMEDIU(IMED),NAMLCM + DO 30 INMT=1,ILONG + CALL LCMLEL(IPLIST,INMT,ILONG,ITYLCM) + IF((ITYLCM.EQ.0).OR.(ITYLCM.EQ.10)) THEN + WRITE (6,120) INMT,NAMT,ILONG,CTYPE(ITYLCM+1) + ELSE IF((ITYLCM.GE.1).AND.(ITYLCM.LE.6)) THEN + WRITE (6,120) INMT,NAMT,ILONG,CTYPE(ITYLCM+1) + ITOT=ITOT+ILONG + ELSE + WRITE (6,120) INMT,NAMT,ILONG,CTYPE(8) + ENDIF + 30 CONTINUE + WRITE(6,140) MYNAME,ITOT + ENDIF + RETURN +* + 80 FORMAT (/10H LCMLIB: ',A12,31H' IS AN EMPTY DIRECTORY OF THE ,A8, + 1 2H ',A12,2H'.) + 90 FORMAT (/10H LCMLIB: ',A12,26H' IS AN EMPTY LIST OF THE ,A8,2H ', + 1 A12,2H'.) + 100 FORMAT (//38H LCMLIB: CONTENT OF ACTIVE DIRECTORY ',A12, + 1 9H' OF THE ,A8,2H ',A12,2H'://5X,10HBLOCK NAME,10(1H-),4X, + 2 6HLENGTH,4X,4HTYPE/) + 110 FORMAT (1X,I8,3H ',A12,1H',I10,4X,A16,2H=',A12,1H') + 120 FORMAT (1X,I8,3H ',A12,1H',I10,4X,A16) + 130 FORMAT (//37H TOTAL NUMBER OF WORDS ON DIRECTORY ',A12,3H' =, + > I10/) + 140 FORMAT (//32H TOTAL NUMBER OF WORDS ON LIST ',A12,3H' =,I10/) + END diff --git a/Ganlib/src/LCMNAN.f b/Ganlib/src/LCMNAN.f new file mode 100644 index 0000000..3067042 --- /dev/null +++ b/Ganlib/src/LCMNAN.f @@ -0,0 +1,218 @@ +*DECK LCMNAN + SUBROUTINE LCMNAN(IPLIST) +* +*---------------------------------------------------------------------- +* +*Purpose: +* Scan a LCM object for NaN. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIST address of the table or handle to the XSM file. +* +*---------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXLEV=50) + CHARACTER NAMT*12,MYNAME*12,PATH(MAXLEV)*12,FIRST(MAXLEV)*12, + 1 NAMLCM*12,HSMG*131 + INTEGER IVEC(MAXLEV),KJLON(MAXLEV),IGO(MAXLEV) + TYPE(C_PTR) KDATA(MAXLEV) + LOGICAL EMPTY,LCM +*---- +* POINTER VARIABLES +*---- + TYPE(C_PTR) PT_DATA + REAL, POINTER :: RRR(:) + DOUBLE PRECISION, POINTER :: DDD(:) + COMPLEX, POINTER :: CCC(:) +* + ILEV=1 + KDATA(1)=IPLIST + KJLON(1)=-1 + IVEC(1)=1 + IGO(1)=5 + CALL LCMVAL(IPLIST,' ') + CALL LCMINF(IPLIST,NAMLCM,MYNAME,EMPTY,ILONG,LCM) + IF(EMPTY) GO TO 65 +* +* ASSOCIATIVE TABLE. + 10 NAMT=' ' + CALL LCMNXT(IPLIST,NAMT) + LENNAM=12 + IF(NAMT.EQ.' ') LENNAM=0 +* + FIRST(ILEV)=NAMT + 20 CALL LCMLEN(IPLIST,NAMT,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 60 + IF(ITYLCM.EQ.0) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMNAN: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',NAMLCM,'''(1).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA(ILEV)=LCMGID(IPLIST,NAMT) + PATH(ILEV)=NAMT + IPLIST=KDATA(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=1 + GO TO 10 + ELSE IF(ITYLCM.EQ.10) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMNAN: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',NAMLCM,'''(2).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + KDATA(ILEV)=LCMGID(IPLIST,NAMT) + PATH(ILEV)=NAMT + IPLIST=KDATA(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=2 + GO TO 70 + ELSE IF(ITYLCM.LE.6) THEN + CALL LCMGPD(IPLIST,NAMT,PT_DATA) + IF(ITYLCM.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, RRR, (/ ILONG /)) + DO I=1,ILONG + IF(RRR(I).NE.RRR(I)) THEN + WRITE(HSMG,'(36HLCMNAN: NAN DETECTED IN REAL ARRAY: , + 1 A12)') NAMT + CALL XABORT(HSMG) + ENDIF + ENDDO + ELSE IF(ITYLCM.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, DDD, (/ ILONG /)) + DO I=1,ILONG + IF(DDD(I).NE.DDD(I)) THEN + WRITE(HSMG,'(38HLCMNAN: NAN DETECTED IN DOUBLE ARRAY: , + 1 A12)') NAMT + CALL XABORT(HSMG) + ENDIF + ENDDO + ELSE IF(ITYLCM.EQ.6) THEN +* COMPLEX DATA. + CALL C_F_POINTER(PT_DATA, CCC, (/ ILONG /)) + DO I=1,ILONG + IF(CCC(I).NE.CCC(I)) THEN + WRITE(HSMG,'(39HLCMNAN: NAN DETECTED IN COMPLEX ARRAY: , + 1 A12)') NAMT + CALL XABORT(HSMG) + ENDIF + ENDDO + ENDIF + ELSE + WRITE(HSMG,'(34HLCMNAN: UNKNOWN TYPE RECORD NAMED ,A12, + 1 5H (1).)') NAMLCM + CALL XABORT(HSMG) + ENDIF + GO TO 60 +* + 55 NAMT=PATH(ILEV) + ILEV=ILEV-1 + IPLIST=KDATA(ILEV) +* + 60 CALL LCMNXT(IPLIST,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 20 + 65 GO TO (55,55,95,95,100),IGO(ILEV) +* +* LIST. + 70 IVEC(ILEV)=IVEC(ILEV)+1 + IF(IVEC(ILEV).GT.KJLON(ILEV)) THEN + GO TO (55,55,95,95,100),IGO(ILEV) + ENDIF + CALL LCMLEL(KDATA(ILEV),IVEC(ILEV),ILONG,ITYLCM) + IF((ILONG.NE.0).AND.(ITYLCM.EQ.0)) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMNAN: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',NAMLCM,'''(3).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA(ILEV)=LCMGIL(IPLIST,IVEC(ILEV-1)) + IPLIST=KDATA(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=3 + GO TO 10 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.EQ.10)) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMNAN: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',NAMLCM,'''(4).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + KDATA(ILEV)=LCMGIL(IPLIST,IVEC(ILEV-1)) + IPLIST=KDATA(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=4 + GO TO 70 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.LE.6)) THEN + CALL LCMGPL(IPLIST,IVEC(ILEV),PT_DATA) + IF(ITYLCM.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, RRR, (/ ILONG /)) + DO I=1,ILONG + IF(RRR(I).NE.RRR(I)) THEN + WRITE(HSMG,'(36HLCMNAN: NAN DETECTED IN REAL ARRAY: , + 1 I12)') IVEC(ILEV) + CALL XABORT(HSMG) + ENDIF + ENDDO + ELSE IF(ITYLCM.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, DDD, (/ ILONG /)) + DO I=1,ILONG + IF(DDD(I).NE.DDD(I)) THEN + WRITE(HSMG,'(38HLCMNAN: NAN DETECTED IN DOUBLE ARRAY: , + 1 I12)') IVEC(ILEV) + CALL XABORT(HSMG) + ENDIF + ENDDO + ELSE IF(ITYLCM.EQ.6) THEN +* COMPLEX DATA. + CALL C_F_POINTER(PT_DATA, CCC, (/ ILONG /)) + DO I=1,ILONG + IF(CCC(I).NE.CCC(I)) THEN + WRITE(HSMG,'(39HLCMNAN: NAN DETECTED IN COMPLEX ARRAY: , + 1 I12)') IVEC(ILEV) + CALL XABORT(HSMG) + ENDIF + ENDDO + ENDIF + ELSE IF(ILONG.NE.0) THEN + WRITE(HSMG,'(34HLCMNAN: UNKNOWN TYPE RECORD NAMED ,A12, + 1 5H (2).)') NAMLCM + CALL XABORT(HSMG) + ENDIF + GO TO 70 +* + 95 ILEV=ILEV-1 + IPLIST=KDATA(ILEV) + GO TO 70 +* + 100 WRITE(6,'(25H LCMNAN: NO NaN DETECTED.)') + RETURN + END + diff --git a/Ganlib/src/LCMNOD.f b/Ganlib/src/LCMNOD.f new file mode 100644 index 0000000..11558bd --- /dev/null +++ b/Ganlib/src/LCMNOD.f @@ -0,0 +1,203 @@ +*DECK LCMNOD + SUBROUTINE LCMNOD(NUNIT,IMODE,IDIR,JLONG,ITYLCM,PT_DATA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Export/import a single node. Called by LCMEXP. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NUNIT file unit number where the export/import is performed. +* IMODE type of export/import file (=1 sequential unformatted; +* =2 sequential formatted -- ascii). +* IDIR export-import flag(=1 to export ; =2 to import). +* JLONG node length. +* ITYLCM node type. +* PT_DATA c_ptr address of data. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER :: NUNIT,IMODE,IDIR,JLONG,ITYLCM + TYPE(C_PTR) :: PT_DATA +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NBLK=24,LENDAT=4) + INTEGER, POINTER :: III(:) + REAL, POINTER :: RRR(:) + LOGICAL, POINTER :: LLL(:) + DOUBLE PRECISION, POINTER :: DDD(:) + COMPLEX, POINTER :: CCC(:) +* + IF(IDIR.EQ.1) THEN +* EXPORT A NODE. + IF(ITYLCM.EQ.1) THEN +* INTEGER DATA. + CALL C_F_POINTER(PT_DATA, III, (/ JLONG /)) + DO 40 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) (III((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(8I10)') (III((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 40 CONTINUE + ELSE IF(ITYLCM.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, RRR, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 50 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + WRITE(NUNIT) (RRR((I-1)*NBLK+J),J=1,JMIN) + 50 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(1P,5E16.8)') (RRR(I),I=1,JLONG) + ENDIF + ELSE IF(ITYLCM.EQ.3) THEN +* CHARACTER*4 DATA. + CALL C_F_POINTER(PT_DATA, III, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 60 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + WRITE(NUNIT) (LENDAT,K=1,JMIN) + 60 CONTINUE + DO 70 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + WRITE(NUNIT) (III((I-1)*NBLK+J),J=1,JMIN) + 70 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(8I10)') (LENDAT,I=1,JLONG) + WRITE(NUNIT,'(20A4)') (III(I),I=1,JLONG) + ENDIF + ELSE IF(ITYLCM.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, DDD, (/ JLONG /)) + DO 90 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) (DDD((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(1P,4D20.12)') (DDD((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 90 CONTINUE + ELSE IF(ITYLCM.EQ.5) THEN +* LOGICAL DATA. + CALL C_F_POINTER(PT_DATA, LLL, (/ JLONG /)) + DO 110 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) (LLL((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(8L10)') (LLL((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 110 CONTINUE + ELSE IF(ITYLCM.EQ.6) THEN +* COMPLEX DATA. + CALL C_F_POINTER(PT_DATA, CCC, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 120 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + WRITE(NUNIT) (CCC((I-1)*NBLK+J),J=1,JMIN) + 120 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(1P,5E16.8)') (CCC(I),I=1,JLONG) + ENDIF + ENDIF + ELSE IF(IDIR.EQ.2) THEN +* IMPORT A NODE. + IF(ITYLCM.EQ.1) THEN +* INTEGER DATA. + CALL C_F_POINTER(PT_DATA, III, (/ JLONG /)) + DO 190 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT) (III((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(8I10)') (III((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 190 CONTINUE + ELSE IF(ITYLCM.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, RRR, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 200 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + READ(NUNIT) (RRR((I-1)*NBLK+J),J=1,JMIN) + 200 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(5E16.0)') (RRR(I),I=1,JLONG) + ENDIF + ELSE IF(ITYLCM.EQ.3) THEN +* CHARACTER*4 DATA. + CALL C_F_POINTER(PT_DATA, III, (/ JLONG /)) + KLONG=0 + DO 215 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT) (III((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(8I10)') (III((I-1)*NBLK+J),J=1,JMIN) + ENDIF + DO 210 J=1,JMIN + KLONG=KLONG+III(J) + 210 CONTINUE + 215 CONTINUE + IF((KLONG+3)/4.GT.JLONG) CALL XABORT('LCMNOD: OVERFLOW.') + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 220 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + READ(NUNIT) (III((I-1)*NBLK+J),J=1,JMIN) + 220 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(20A4)') (III(I),I=1,JLONG) + ENDIF + ELSE IF(ITYLCM.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, DDD, (/ JLONG /)) + DO 230 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT) (DDD((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(4D20.0)') (DDD((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 230 CONTINUE + ELSE IF(ITYLCM.EQ.5) THEN +* LOGICAL DATA. + CALL C_F_POINTER(PT_DATA, LLL, (/ JLONG /)) + DO 240 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT) (LLL((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(8L10)') (LLL((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 240 CONTINUE + ELSE IF(ITYLCM.EQ.6) THEN +* COMPLEX DATA. + CALL C_F_POINTER(PT_DATA, CCC, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 250 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + READ(NUNIT) (CCC((I-1)*NBLK+J),J=1,JMIN) + 250 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(5E16.0)') (CCC(I),I=1,JLONG) + ENDIF + ENDIF + ENDIF + RETURN + END diff --git a/Ganlib/src/LCMNOS.f b/Ganlib/src/LCMNOS.f new file mode 100644 index 0000000..41080e6 --- /dev/null +++ b/Ganlib/src/LCMNOS.f @@ -0,0 +1,212 @@ +*DECK LCMNOS + SUBROUTINE LCMNOS(NUNIT,IMODE,IDIR,JLONG,ITYLCM,PT_DATA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Export/import a single node in saphtool format. called by LCMEXS. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NUNIT file unit number where the export/import is performed. +* IMODE type of export/import file: =1 sequential unformatted; +* =2 sequential formatted (ascii). +* IDIR type of operation: =1 to export ; =2 to import. +* JLONG node length. +* ITYLCM node type. +* PT_DATA c_ptr address of data. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER :: NUNIT,IMODE,IDIR,JLONG,ITYLCM + TYPE(C_PTR) :: PT_DATA +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NBLK=24) + INTEGER, POINTER :: III(:) + REAL, POINTER :: RRR(:) + LOGICAL, POINTER :: LLL(:) + DOUBLE PRECISION, POINTER :: DDD(:) + COMPLEX, POINTER :: CCC(:) + CHARACTER FORM4*4 +* + IF(IDIR.EQ.1) THEN +* EXPORT A NODE. + IF(ITYLCM.EQ.1) THEN +* INTEGER DATA. + CALL C_F_POINTER(PT_DATA, III, (/ JLONG /)) + DO 40 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) (III((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(8I10)') (III((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 40 CONTINUE + ELSE IF(ITYLCM.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, RRR, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 50 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + WRITE(NUNIT) (RRR((I-1)*NBLK+J),J=1,JMIN) + 50 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(1P,5E16.8)') (RRR(I),I=1,JLONG) + ENDIF + ELSE IF(ITYLCM.EQ.3) THEN +* CHARACTER*4 DATA. +* partial support for a new format included in APOLLO 2.8 + CALL C_F_POINTER(PT_DATA, III, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) 'cte.' + WRITE(NUNIT) 4,JLONG + DO 70 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + WRITE(NUNIT) (III((I-1)*NBLK+J),J=1,JMIN) + 70 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(A4)') 'cte.' + WRITE(NUNIT,'(2I10)') 4,JLONG + WRITE(NUNIT,'(20A4)') (III(I),I=1,JLONG) + ENDIF + ELSE IF(ITYLCM.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, DDD, (/ JLONG /)) + DO 90 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) (DDD((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(1P,4D20.12)') (DDD((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 90 CONTINUE + ELSE IF(ITYLCM.EQ.5) THEN +* LOGICAL DATA. + CALL C_F_POINTER(PT_DATA, LLL, (/ JLONG /)) + DO 110 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + WRITE(NUNIT) (LLL((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(8L10)') (LLL((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 110 CONTINUE + ELSE IF(ITYLCM.EQ.6) THEN +* COMPLEX DATA. + CALL C_F_POINTER(PT_DATA, CCC, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 120 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + WRITE(NUNIT) (CCC((I-1)*NBLK+J),J=1,JMIN) + 120 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + WRITE(NUNIT,'(1P,5E16.8)') (CCC(I),I=1,JLONG) + ENDIF + ENDIF + ELSE IF(IDIR.EQ.2) THEN +* IMPORT A NODE. + IF(ITYLCM.EQ.1) THEN +* INTEGER DATA. + CALL C_F_POINTER(PT_DATA, III, (/ JLONG /)) + DO 190 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT) (III((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(8I10)') (III((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 190 CONTINUE + ELSE IF(ITYLCM.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, RRR, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 200 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + READ(NUNIT) (RRR((I-1)*NBLK+J),J=1,JMIN) + 200 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(5E16.0)') (RRR(I),I=1,JLONG) + ENDIF + ELSE IF(ITYLCM.EQ.3) THEN +* CHARACTER*4 DATA. +* partial support for a new format included in APOLLO 2.8 + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT) FORM4 + IF(FORM4.EQ.'cte.') THEN + READ(NUNIT) IIIS,NNNS + ELSE + BACKSPACE(NUNIT) + IIIS=4 + NNNS=JLONG + ENDIF + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(A4)') FORM4 + IF(FORM4.EQ.'cte.') THEN + READ(NUNIT,'(2I10)') IIIS,NNNS + ELSE + BACKSPACE(NUNIT) + IIIS=4 + NNNS=JLONG + ENDIF + ENDIF + JLONG=IIIS*NNNS/4 + CALL C_F_POINTER(PT_DATA, III, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 220 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + READ(NUNIT) (III((I-1)*NBLK+J),J=1,JMIN) + 220 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(20A4)') (III(I),I=1,JLONG) + ENDIF + ELSE IF(ITYLCM.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL C_F_POINTER(PT_DATA, DDD, (/ JLONG /)) + DO 230 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT) (DDD((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(4D20.0)') (DDD((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 230 CONTINUE + ELSE IF(ITYLCM.EQ.5) THEN +* LOGICAL DATA. + CALL C_F_POINTER(PT_DATA, LLL, (/ JLONG /)) + DO 240 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + READ(NUNIT) (LLL((I-1)*NBLK+J),J=1,JMIN) + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(8L10)') (LLL((I-1)*NBLK+J),J=1,JMIN) + ENDIF + 240 CONTINUE + ELSE IF(ITYLCM.EQ.6) THEN +* COMPLEX DATA. + CALL C_F_POINTER(PT_DATA, CCC, (/ JLONG /)) + IF((NUNIT.NE.0).AND.(IMODE.EQ.1)) THEN + DO 250 I=1,1+(JLONG-1)/NBLK + JMIN=MIN(NBLK,JLONG-(I-1)*NBLK) + READ(NUNIT) (CCC((I-1)*NBLK+J),J=1,JMIN) + 250 CONTINUE + ELSE IF((NUNIT.NE.0).AND.(IMODE.EQ.2)) THEN + READ(NUNIT,'(5E16.0)') (CCC(I),I=1,JLONG) + ENDIF + ENDIF + ENDIF + RETURN + END diff --git a/Ganlib/src/LCMPCD.f b/Ganlib/src/LCMPCD.f new file mode 100644 index 0000000..bd29b81 --- /dev/null +++ b/Ganlib/src/LCMPCD.f @@ -0,0 +1,49 @@ +*DECK LCMPCD + SUBROUTINE LCMPCD(IPLIST,NAMP,ILONG,HDATA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Copy a character variable from memory into a table. +* +*Copyright: +* Copyright (C) 2000 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIST address of the table. +* NAMP character*12 name of the block. +* ILONG dimension of the character variable. +* HDATA character variable. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER ILONG + CHARACTER*(*) NAMP,HDATA(*) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIST + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA +* + ILEN=(LEN(HDATA(1))+3)/4 + IF(ILEN.GT.100) CALL XABORT('LCMPCD: ILEN OVERFLOW.') + ALLOCATE(IDATA(ILEN)) + JPLIST=LCMLID(IPLIST,NAMP,ILONG) + DO ISET=1,ILONG + READ(HDATA(ISET),'(100A4)') (IDATA(I),I=1,ILEN) + CALL LCMPDL(JPLIST,ISET,ILEN,3,IDATA) + ENDDO + DEALLOCATE(IDATA) + RETURN + END diff --git a/Ganlib/src/LCMPCL.f b/Ganlib/src/LCMPCL.f new file mode 100644 index 0000000..667e03a --- /dev/null +++ b/Ganlib/src/LCMPCL.f @@ -0,0 +1,49 @@ +*DECK LCMPCL + SUBROUTINE LCMPCL(IPLIST,ISET,ILONG,HDATA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Copy a character variable from memory into a table. +* +*Copyright: +* Copyright (C) 2000 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIST address of the table. +* ISET position of the block in the list. +* ILONG dimension of the character variable. +* HDATA character variable. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER ISET,ILONG + CHARACTER*(*) HDATA(*) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIST + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA +* + ILEN=(LEN(HDATA(1))+3)/4 + IF(ILEN.GT.100) CALL XABORT('LCMPCL: ILEN OVERFLOW.') + ALLOCATE(IDATA(ILEN)) + JPLIST=LCMLIL(IPLIST,ISET,ILONG) + DO JSET=1,ILONG + READ(HDATA(JSET),'(100A4)') (IDATA(I),I=1,ILEN) + CALL LCMPDL(JPLIST,JSET,ILEN,3,IDATA) + ENDDO + DEALLOCATE(IDATA) + RETURN + END diff --git a/Ganlib/src/LCMSTA.f b/Ganlib/src/LCMSTA.f new file mode 100644 index 0000000..30c3cb0 --- /dev/null +++ b/Ganlib/src/LCMSTA.f @@ -0,0 +1,412 @@ +*DECK LCMSTA + SUBROUTINE LCMSTA(IPLIS1,IPLIS2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compare the floating point information contained in the active +* directories of two tables or XSM files pointed by IPLIS1 and IPLIS2. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIS1 address of the table or handle to the XSM file. +* IPLIS2 address of the table or handle to the XSM file. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIS1,IPLIS2 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXLEV=50) + TYPE(C_PTR) KDATA1(MAXLEV),KDATA2(MAXLEV) + CHARACTER NAMT*12,CTMP1*4,CTMP2*4,HNAME1*12,HNAME2*12,NAMMY*12, + 1 HSMG*131,PATH(MAXLEV)*12,FIRST(MAXLEV)*12,MYDIR(MAXLEV)*12 + INTEGER IVEC(MAXLEV),KJLON(MAXLEV),IGO(MAXLEV) + LOGICAL EMPTY,LCM + TYPE(C_PTR) :: PT_DATA1,PT_DATA2 + INTEGER, POINTER :: III1(:),III2(:) + REAL, POINTER :: RRR1(:),RRR2(:) + LOGICAL, POINTER :: LLL1(:),LLL2(:) + DOUBLE PRECISION, POINTER :: DDD1(:),DDD2(:) + COMPLEX, POINTER :: CCC1(:),CCC2(:) +* + CALL LCMVAL(IPLIS1,' ') + CALL LCMVAL(IPLIS2,' ') + ILEV=1 + KDATA1(1)=IPLIS1 + KDATA2(1)=IPLIS2 + KJLON(1)=-1 + IVEC(1)=1 + IGO(1)=5 + WRITE(6,'(/39H LCMSTA: COMPARISON OF TWO LCM OBJECTS.)') +* +* ASSOCIATIVE TABLE. + 10 CALL LCMINF(IPLIS1,HNAME1,NAMMY,EMPTY,ILONG,LCM) + CALL LCMINF(IPLIS2,HNAME2,NAMMY,EMPTY,ILONG,LCM) + MYDIR(ILEV)=NAMMY + IF(EMPTY) GO TO (185,185,370,370,380),IGO(ILEV) + NAMT=' ' + CALL LCMNXT(IPLIS1,NAMT) +* + FIRST(ILEV)=NAMT + 15 CALL LCMLEN(IPLIS1,NAMT,ILON1,ITY1) + CALL LCMLEN(IPLIS2,NAMT,ILON2,ITY2) + IF((ILON1.NE.ILON2).OR.(ITY1.NE.ITY2)) THEN + WRITE(6,'(/13H TWO BLOCKS '',A12,6H'' OF '',A12,7H'' AND '', + 1 A12,23H'' ARE OF UNEQUAL TYPE (,2I4,13H) OR LENGTH (,2I7, + 2 14H). DIRECTORY='',A12,2H''.)') NAMT,HNAME1,HNAME2,ITY1, + 3 ITY2,ILON1,ILON2,MYDIR(ILEV) + GO TO 180 + ENDIF + IF(ITY1.EQ.0) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMSTA: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME2,'''(1).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + KDATA2(ILEV)=LCMGID(IPLIS2,NAMT) + PATH(ILEV)=NAMT + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=1 + GO TO 10 + ELSE IF(ITY1.EQ.10) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMSTA: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME2,'''(2).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILON1 + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + KDATA2(ILEV)=LCMGID(IPLIS2,NAMT) + PATH(ILEV)=NAMT + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=2 + GO TO 190 + ELSE IF(ITY1.LE.6) THEN + IF(ITY1.EQ.1) THEN +* INTEGER DATA. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, III1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, III2, (/ ILON2 /)) + DO 80 I=1,ILON1 + IF(III1(I).NE.III2(I)) THEN + WRITE(6,'(/40H INCONSISTENT INTEGER DATA ON THE TWO DI, + 1 19HRECTORIES. RECORD='',A12,13H'' DIRECTORY='',A12, + 2 1H'')') NAMT,MYDIR(ILEV) + GO TO 180 + ENDIF + 80 CONTINUE + ELSE IF((ITY1.EQ.2).OR.(ITY1.EQ.6)) THEN +* COMPARE THE TWO SINGLE PRECISION OR COMPLEX BLOCKS. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, RRR1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, RRR2, (/ ILON2 /)) + EPSMAX=0.0 + EPSAVG=0.0 + INGRO=0 + WRITE(6,'(/32H COMPARE REAL OR COMPLEX BLOCK '',A12, + 1 26H'' IN TABLES OR XSM FILES '',A12,7H'' AND '',A12, + 2 16H'' IN DIRECTORY '',A12,2H'':)') NAMT,HNAME1,HNAME2, + 3 MYDIR(ILEV) + DO 100 I=1,ILON1 + ABSEP=ABS(RRR1(I)-RRR2(I)) + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + 100 CONTINUE + EPSAVG=EPSAVG/REAL(ILON1) + WRITE (6,'(/5H LEN=,I6,5X,7HEPSMAX=,E12.5,13H IN COMPONENT, + 1 I6/16X,7HEPSAVG=,E12.5)') ILON1,EPSMAX,INGRO,EPSAVG + ELSE IF(ITY1.EQ.3) THEN +* CHARACTER*4 DATA. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, III1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, III2, (/ ILON2 /)) + DO 130 I=1,ILON1 + WRITE(CTMP1,'(A4)') III1(I) + WRITE(CTMP2,'(A4)') III2(I) + IF(CTMP1.NE.CTMP2) THEN + WRITE(6,'(/39H INCONSISTENT CHARACTER DATA ON THE TWO, + 1 22H DIRECTORIES. RECORD='',A12,13H'' DIRECTORY '', + 2 A12,8H'' DATA='',A4,3H'' '',A4,1H'')') NAMT,MYDIR(ILEV), + 3 CTMP1,CTMP2 + GO TO 180 + ENDIF + 130 CONTINUE + ELSE IF(ITY1.EQ.4) THEN +* COMPARE THE TWO DOUBLE PRECISION BLOCKS. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, DDD1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, DDD2, (/ ILON2 /)) + EPSMAX=0.0 + EPSAVG=0.0 + INGRO=0 + WRITE(6,'(/33H COMPARE DOUBLE PRECISION BLOCK '',A12, + 1 26H'' IN TABLES OR XSM FILES '',A12,7H'' AND '',A12, + 2 16H'' IN DIRECTORY '',A12,2H'':)') NAMT,HNAME1,HNAME2, + 3 MYDIR(ILEV) + DO 150 I=1,ILON1 + ABSEP=REAL(ABS(DDD1(I)-DDD2(I))) + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + 150 CONTINUE + EPSAVG=EPSAVG/REAL(ILON1) + WRITE (6,'(/5H LEN=,I6,5X,7HEPSMAX=,E12.5,13H IN COMPONENT, + 1 I6/16X,7HEPSAVG=,E12.5)') ILON1,EPSMAX,INGRO,EPSAVG + ELSE IF(ITY1.EQ.5) THEN +* LOGICAL DATA. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, LLL1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, LLL2, (/ ILON2 /)) + DO 160 I=1,ILON1 + IF(LLL1(I).NEQV.LLL2(I)) THEN + WRITE(6,'(/40H INCONSISTENT LOGICAL DATA ON THE TWO DI, + 1 19HRECTORIES. RECORD='',A12,13H'' DIRECTORY='',A12, + 2 1H'')') NAMT,MYDIR(ILEV) + GO TO 180 + ENDIF + 160 CONTINUE + ELSE IF(ITY1.EQ.6) THEN +* COMPARE THE TWO COMPLEX BLOCKS. + CALL LCMGPD(IPLIS1,NAMT,PT_DATA1) + CALL LCMGPD(IPLIS2,NAMT,PT_DATA2) + CALL C_F_POINTER(PT_DATA1, CCC1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, CCC2, (/ ILON2 /)) + EPSMAX=0.0 + EPSAVG=0.0 + INGRO=0 + WRITE(6,'(/32H COMPARE REAL OR COMPLEX BLOCK '',A12, + 1 26H'' IN TABLES OR XSM FILES '',A12,7H'' AND '',A12, + 2 16H'' IN DIRECTORY '',A12,2H'':)') NAMT,HNAME1,HNAME2, + 3 MYDIR(ILEV) + DO 170 I=1,ILON1 + ABSEP=ABS(CCC1(I)-CCC2(I)) + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + 170 CONTINUE + EPSAVG=EPSAVG/REAL(ILON1) + WRITE (6,'(/5H LEN=,I6,5X,7HEPSMAX=,E12.5,13H IN COMPONENT, + 1 I6/16X,7HEPSAVG=,E12.5)') ILON1,EPSMAX,INGRO,EPSAVG + ELSE + CALL XABORT('LCMSTA: INVALID DATA TYPE(1).') + ENDIF + ENDIF + 180 CALL LCMNXT(IPLIS1,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 15 + GO TO (185,185,370,370,380),IGO(ILEV) +* + 185 NAMT=PATH(ILEV) + ILEV=ILEV-1 + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + CALL LCMNXT(IPLIS1,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 15 + GO TO (185,185,370,370,380),IGO(ILEV) +* +* LIST. + 190 IVEC(ILEV)=IVEC(ILEV)+1 + IF(IVEC(ILEV).GT.KJLON(ILEV)) THEN + GO TO (185,185,370,370,380),IGO(ILEV) + ENDIF + CALL LCMLEL(KDATA1(ILEV),IVEC(ILEV),ILON1,ITY1) + CALL LCMLEL(KDATA2(ILEV),IVEC(ILEV),ILON2,ITY2) + IF((ILON1.NE.ILON2).OR.(ITY1.NE.ITY2)) THEN + WRITE(6,'(/15H TWO COMPONENTS,I6,5H OF '',A12,7H'' AND '', + 1 A12,23H'' ARE OF UNEQUAL TYPE (,2I4,13H) OR LENGTH (, + 2 2I7,2H).)') IVEC(ILEV),HNAME1,HNAME2,ITY1,ITY2,ILON1, + 3 ILON2 + GO TO 190 + ENDIF + IF((ILON1.NE.0).AND.(ITY1.EQ.0)) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMSTA: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME2,'''(3).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA1(ILEV)=LCMGIL(IPLIS1,IVEC(ILEV-1)) + KDATA2(ILEV)=LCMGIL(IPLIS2,IVEC(ILEV-1)) + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=3 + GO TO 10 + ELSE IF((ILON1.NE.0).AND.(ITY1.EQ.10)) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMSTA: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME2,'''(4).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILON1 + KDATA1(ILEV)=LCMGIL(IPLIS1,IVEC(ILEV-1)) + KDATA2(ILEV)=LCMGIL(IPLIS2,IVEC(ILEV-1)) + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=4 + GO TO 190 + ELSE IF((ILON1.NE.0).AND.(ITY1.LE.6)) THEN + IF(ITY1.EQ.1) THEN +* INTEGER DATA. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, III1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, III2, (/ ILON2 /)) + DO 230 I=1,ILON1 + IF(III1(I).NE.III2(I)) THEN + WRITE(6,'(/40H INCONSISTENT INTEGER DATA ON THE TWO DI, + 1 24HRECTORIES. LIST ELEMENT=,I5,1H.)') IVEC(ILEV) + GO TO 190 + ENDIF + 230 CONTINUE + ELSE IF((ITY1.EQ.2).OR.(ITY1.EQ.6)) THEN +* COMPARE THE TWO SINGLE PRECISION BLOCKS. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, RRR1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, RRR2, (/ ILON2 /)) + EPSMAX=0.0 + EPSAVG=0.0 + INGRO=0 + WRITE(6,'(/37H COMPARE REAL OR COMPLEX LIST ELEMENT,I5, + 1 25H IN TABLES OR XSM FILES '',A12,7H'' AND '',A12,2H'':) + 2 ') IVEC(ILEV),HNAME1,HNAME2 + DO 250 I=1,ILON1 + ABSEP=ABS(RRR1(I)-RRR2(I)) + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + 250 CONTINUE + EPSAVG=EPSAVG/REAL(ILON1) + WRITE (6,'(/5H LEN=,I6,5X,7HEPSMAX=,E12.5,13H IN COMPONENT, + 1 I6/16X,7HEPSAVG=,E12.5)') ILON1,EPSMAX,INGRO,EPSAVG + ELSE IF(ITY1.EQ.3) THEN +* CHARACTER*4 DATA. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, III1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, III2, (/ ILON2 /)) + DO 280 I=1,ILON1 + WRITE(CTMP1,'(A4)') III1(I) + WRITE(CTMP2,'(A4)') III2(I) + IF(CTMP1.NE.CTMP2) THEN + WRITE(6,'(/40H INCONSISTENT CHARACTER DATA ON THE TWO , + 1 26HDIRECTORIES. LIST ELEMENT=,I5,8H'' DATA='',A4, + 2 3H'' '',A4,2H''.)') IVEC(ILEV),CTMP1,CTMP2 + GO TO 190 + ENDIF + 280 CONTINUE + ELSE IF(ITY1.EQ.4) THEN +* COMPARE THE TWO DOUBLE PRECISION BLOCKS. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, DDD1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, DDD2, (/ ILON2 /)) + EPSMAX=0.0 + EPSAVG=0.0 + INGRO=0 + WRITE(6,'(/33H COMPARE DOUBLE PRECISION BLOCK '',A12, + 1 26H'' IN TABLES OR XSM FILES '',A12,7H'' AND '',A12, + 2 2H'':)') NAMT,HNAME1,HNAME2 + DO 300 I=1,ILON1 + ABSEP=REAL(ABS(DDD1(I)-DDD2(I))) + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + 300 CONTINUE + EPSAVG=EPSAVG/REAL(ILON1) + WRITE (6,'(/5H LEN=,I6,5X,7HEPSMAX=,E12.5,13H IN COMPONENT, + 1 I6/16X,7HEPSAVG=,E12.5)') ILON1,EPSMAX,INGRO,EPSAVG + ELSE IF(ITY1.EQ.5) THEN +* LOGICAL DATA. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, LLL1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, LLL2, (/ ILON2 /)) + DO 340 I=1,ILON1 + IF(LLL1(I).NEQV.LLL2(I)) THEN + WRITE(6,'(/40H INCONSISTENT LOGICAL DATA ON THE TWO DI, + 1 24HRECTORIES. LIST ELEMENT=,I5,1H.)') IVEC(ILEV) + GO TO 190 + ENDIF + 340 CONTINUE + ELSE IF((ITY1.EQ.2).OR.(ITY1.EQ.6)) THEN +* COMPARE THE TWO COMPLEX BLOCKS. + CALL LCMGPL(IPLIS1,IVEC(ILEV),PT_DATA1) + CALL LCMGPL(IPLIS2,IVEC(ILEV),PT_DATA2) + CALL C_F_POINTER(PT_DATA1, CCC1, (/ ILON1 /)) + CALL C_F_POINTER(PT_DATA2, CCC2, (/ ILON2 /)) + EPSMAX=0.0 + EPSAVG=0.0 + INGRO=0 + WRITE(6,'(/37H COMPARE REAL OR COMPLEX LIST ELEMENT,I5, + 1 25H IN TABLES OR XSM FILES '',A12,7H'' AND '',A12,2H'':) + 2 ') IVEC(ILEV),HNAME1,HNAME2 + DO 350 I=1,ILON1 + ABSEP=ABS(CCC1(I)-CCC2(I)) + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + 350 CONTINUE + EPSAVG=EPSAVG/REAL(ILON1) + WRITE (6,'(/5H LEN=,I6,5X,7HEPSMAX=,E12.5,13H IN COMPONENT, + 1 I6/16X,7HEPSAVG=,E12.5)') ILON1,EPSMAX,INGRO,EPSAVG + ELSE + CALL XABORT('LCMSTA: INVALID DATA TYPE(2).') + ENDIF + ENDIF + GO TO 190 +* + 370 ILEV=ILEV-1 + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + GO TO 190 +* + 380 RETURN + END diff --git a/Ganlib/src/LCMTLC.f90 b/Ganlib/src/LCMTLC.f90 new file mode 100644 index 0000000..327ebe0 --- /dev/null +++ b/Ganlib/src/LCMTLC.f90 @@ -0,0 +1,624 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for lcm -- part 3. +! Support of character arrays. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!Parameters: input +! iplcm pointer to the LCM object. +! name character name of the LCM node. +! ipos heterogeneous list index. +! leng length of each character string in the array carr. +! nlin dimension of array carr. +! +!Parameters: input/output +! carr array of character strings. +! +!----------------------------------------------------------------------- +! +module LCMTLC + use LCMMOD + private + public :: LCMGTC, LCMPTC, LCMGLC, LCMPLC + interface LCMGTC + ! recover a string array from an associative table + MODULE PROCEDURE LCMGTC_S0, LCMGTC_S1, LCMGTC_S2 + end interface + interface LCMPTC + ! store a string array from an associative table + MODULE PROCEDURE LCMPTC_S0, LCMPTC_S1, LCMPTC_S2 + end interface + interface LCMGLC + ! recover a string array from an heterogeneous list + MODULE PROCEDURE LCMGLC_S0, LCMGLC_S1, LCMGLC_S2 + end interface + interface LCMPLC + ! store a string array from an heterogeneous list + MODULE PROCEDURE LCMPLC_S0, LCMPLC_S1, LCMPLC_S2 + end interface +contains +subroutine LCMGTC_S0(iplcm,name,leng,carr) + use, intrinsic :: iso_c_binding + use LCMAUX + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: leng + character(len=*), intent(in) :: name + character(len=*), intent(out) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + character(len=12) :: text12 + integer,allocatable :: ibase(:) + ! + fmt='( )' + allocate(ibase((leng+3)/4)) + !---- + ! Read from LCM object + !---- + call LCMLEN(iplcm,name,ilong,itylcm) + if(ilong == 0) then + call LCMLIB(iplcm) + text12=name + call XABORT('LCMGTC: record '//text12//' not found.') + endif + call LCMGET(iplcm,name,ibase) + !---- + ! Define format and dimensions for conversion + !---- + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert integers to string + !---- + write(carr(1:leng),fmt) (ibase(j),j=1,n) + deallocate(ibase) +end subroutine LCMGTC_S0 +! +subroutine LCMGTC_S1(iplcm,name,leng,nlin,carr) + use, intrinsic :: iso_c_binding + use LCMAUX + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: leng,nlin + character(len=*), intent(in) :: name + character(len=*), dimension(nlin), intent(out) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + character(len=12) :: text12 + integer,allocatable :: ibase(:) + ! + fmt='( )' + allocate(ibase(nlin*(leng+3)/4)) + !---- + ! Read from LCM object + !---- + call LCMLEN(iplcm,name,ilong,itylcm) + if(ilong == 0) then + call LCMLIB(iplcm) + text12=name + call XABORT('LCMGTC: record '//text12//' not found.') + endif + call LCMGET(iplcm,name,ibase) + !---- + ! Define format and dimensions for conversion + !---- + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert integers to strings + !---- + do i=1,nlin + write(carr(i)(1:leng),fmt) (ibase((i-1)*n+j),j=1,n) + enddo + deallocate(ibase) +end subroutine LCMGTC_S1 +! +subroutine LCMGTC_S2(iplcm,name,leng,nlin,carr) + use, intrinsic :: iso_c_binding + use LCMAUX + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: leng,nlin + character(len=*), intent(in) :: name + character(len=*), dimension(:,:), intent(out) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + character(len=12) :: text12 + character(len=131) :: hsmg + integer,allocatable :: ibase(:) + ! + fmt='( )' + allocate(ibase(nlin*(leng+3)/4)) + !---- + ! Read from LCM object + !---- + call LCMLEN(iplcm,name,ilong,itylcm) + if(ilong == 0) then + call LCMLIB(iplcm) + text12=name + call XABORT('LCMGTC: record '//text12//' not found.') + endif + call LCMGET(iplcm,name,ibase) + !---- + ! Define format and dimensions for conversion + !---- + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert integers to strings + !---- + nlin1=size(carr,1) + nlin2=size(carr,2) + if(nlin1*nlin2.ne.nlin) then + write(hsmg,'(29hLCMGTC_S2: allocated length (,i5,17h) is not equal to, & + & 16h argument size (,i5,2h).)') nlin1*nlin2,nlin + call xabort(hsmg) + endif + do i2=1,nlin2 + do i1=1,nlin1 + i=(i2-1)*nlin1+i1 + write(carr(i1,i2)(1:leng),fmt) (ibase((i-1)*n+j),j=1,n) + enddo + enddo + deallocate(ibase) +end subroutine LCMGTC_S2 +! +subroutine LCMPTC_S0(iplcm,name,leng,carr) + use, intrinsic :: iso_c_binding + use LCMMOD + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: leng + character(len=*), intent(in) :: name + character(len=*), intent(in) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + integer,allocatable :: ibase(:) + ! + fmt='( )' + !---- + ! Define format and dimensions for conversion + !---- + allocate(ibase((leng+3)/4)) + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert strings to integers + !---- + read(carr(1:leng),fmt) (ibase(j),j=1,n) + !---- + ! Write to LCM object + !---- + call LCMPUT(iplcm,name,n,3,ibase) + deallocate(ibase) +end subroutine LCMPTC_S0 +! +subroutine LCMPTC_S1(iplcm,name,leng,nlin,carr) + use, intrinsic :: iso_c_binding + use LCMMOD + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: leng,nlin + character(len=*), intent(in) :: name + character(len=*), dimension(nlin), intent(in) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + integer,allocatable :: ibase(:) + ! + fmt='( )' + !---- + ! Define format and dimensions for conversion + !---- + allocate(ibase(nlin*(leng+3)/4)) + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert strings to integers + !---- + do i=1,nlin + read(carr(i)(1:leng),fmt) (ibase((i-1)*n+j),j=1,n) + enddo + !---- + ! Write to LCM object + !---- + call LCMPUT(iplcm,name,n*nlin,3,ibase) + deallocate(ibase) +end subroutine LCMPTC_S1 +! +subroutine LCMPTC_S2(iplcm,name,leng,nlin,carr) + use, intrinsic :: iso_c_binding + use LCMMOD + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: leng,nlin + character(len=*), intent(in) :: name + character(len=*), dimension(:,:), intent(in) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + character(len=131) :: hsmg + integer,allocatable :: ibase(:) + ! + fmt='( )' + !---- + ! Define format and dimensions for conversion + !---- + allocate(ibase(nlin*(leng+3)/4)) + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert strings to integers + !---- + nlin1=size(carr,1) + nlin2=size(carr,2) + if(nlin1*nlin2.ne.nlin) then + write(hsmg,'(29hLCMPTC_S2: allocated length (,i5,17h) is not equal to, & + & 16h argument size (,i5,2h).)') nlin1*nlin2,nlin + call xabort(hsmg) + endif + do i2=1,nlin2 + do i1=1,nlin1 + i=(i2-1)*nlin1+i1 + read(carr(i1,i2)(1:leng),fmt) (ibase((i-1)*n+j),j=1,n) + enddo + enddo + !---- + ! Write to LCM object + !---- + call LCMPUT(iplcm,name,n*nlin,3,ibase) + deallocate(ibase) +end subroutine LCMPTC_S2 +! +subroutine LCMGLC_S0(iplcm,ipos,leng,carr) + use, intrinsic :: iso_c_binding + use LCMAUX + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: ipos,leng + character(len=*), intent(out) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + character(len=131) :: hsmg + integer,allocatable :: ibase(:) + ! + fmt='( )' + allocate(ibase((leng+3)/4)) + !---- + ! Read from LCM object + !---- + call lcmlel(iplcm,ipos,ilong,itylcm) + if(ilong == 0) then + call LCMLIB(iplcm) + write(hsmg,'(8hLCMGLC: ,i5,21h-th record not found.)') ipos + call XABORT(hsmg) + endif + call LCMGDL(iplcm,ipos,ibase) + !---- + ! Define format and dimensions for conversion + !---- + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert integer to strings + !---- + write(carr(1:leng),fmt) (ibase(j),j=1,n) + deallocate(ibase) +end subroutine LCMGLC_S0 +! +subroutine LCMGLC_S1(iplcm,ipos,leng,nlin,carr) + use, intrinsic :: iso_c_binding + use LCMAUX + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: ipos,leng,nlin + character(len=*), dimension(nlin), intent(out) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + character(len=131) :: hsmg + integer,allocatable :: ibase(:) + ! + fmt='( )' + allocate(ibase(nlin*(leng+3)/4)) + !---- + ! Read from LCM object + !---- + call lcmlel(iplcm,ipos,ilong,itylcm) + if(ilong == 0) then + call LCMLIB(iplcm) + write(hsmg,'(8hLCMGLC: ,i5,21h-th record not found.)') ipos + call XABORT(hsmg) + endif + call LCMGDL(iplcm,ipos,ibase) + !---- + ! Define format and dimensions for conversion + !---- + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert integers to strings + !---- + do i=1,nlin + write(carr(i)(1:leng),fmt) (ibase((i-1)*n+j),j=1,n) + enddo + deallocate(ibase) +end subroutine LCMGLC_S1 +! +subroutine LCMGLC_S2(iplcm,ipos,leng,nlin,carr) + use, intrinsic :: iso_c_binding + use LCMAUX + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: ipos,leng,nlin + character(len=*), dimension(:,:), intent(out) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + character(len=131) :: hsmg + integer,allocatable :: ibase(:) + ! + fmt='( )' + allocate(ibase(nlin*(leng+3)/4)) + !---- + ! Read from LCM object + !---- + call lcmlel(iplcm,ipos,ilong,itylcm) + if(ilong == 0) then + call LCMLIB(iplcm) + write(hsmg,'(8hLCMGLC: ,i5,21h-th record not found.)') ipos + call XABORT(hsmg) + endif + call LCMGDL(iplcm,ipos,ibase) + !---- + ! Define format and dimensions for conversion + !---- + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert integers to strings + !---- + nlin1=size(carr,1) + nlin2=size(carr,2) + if(nlin1*nlin2.ne.nlin) then + write(hsmg,'(29hLCMGLC_S2: allocated length (,i5,17h) is not equal to, & + & 16h argument size (,i5,2h).)') nlin1*nlin2,nlin + call xabort(hsmg) + endif + do i2=1,nlin2 + do i1=1,nlin1 + i=(i2-1)*nlin1+i1 + write(carr(i1,i2)(1:leng),fmt) (ibase((i-1)*n+j),j=1,n) + enddo + enddo + deallocate(ibase) +end subroutine LCMGLC_S2 +! +subroutine LCMPLC_S0(iplcm,ipos,leng,carr) + use, intrinsic :: iso_c_binding + use LCMMOD + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: ipos,leng + character(len=*), intent(in) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + integer,allocatable :: ibase(:) + ! + fmt='( )' + !---- + ! Define format and dimensions for conversion + !---- + allocate(ibase((leng+3)/4)) + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert strings to integers + !---- + read(carr(1:leng),fmt) (ibase(j),j=1,n) + !---- + ! Write to LCM object + !---- + call LCMPDL(iplcm,ipos,n,3,ibase) + deallocate(ibase) +end subroutine LCMPLC_S0 +! +subroutine LCMPLC_S1(iplcm,ipos,leng,nlin,carr) + use, intrinsic :: iso_c_binding + use LCMMOD + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: ipos,leng,nlin + character(len=*), dimension(nlin), intent(in) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + integer,allocatable :: ibase(:) + ! + fmt='( )' + !---- + ! Define format and dimensions for conversion + !---- + allocate(ibase(nlin*(leng+3)/4)) + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert strings to integers + !---- + do i=1,nlin + read(carr(i)(1:leng),fmt) (ibase((i-1)*n+j),j=1,n) + enddo + !---- + ! Write to LCM object + !---- + call LCMPDL(iplcm,ipos,n*nlin,3,ibase) + deallocate(ibase) +end subroutine LCMPLC_S1 +! +subroutine LCMPLC_S2(iplcm,ipos,leng,nlin,carr) + use, intrinsic :: iso_c_binding + use LCMMOD + !---- + ! Subroutine arguments + !---- + type(c_ptr), intent(in) :: iplcm + integer, intent(in) :: ipos,leng,nlin + character(len=*), dimension(:,:), intent(in) :: carr + !---- + ! Local variables + !---- + character(len=13) :: fmt + character(len=131) :: hsmg + integer,allocatable :: ibase(:) + ! + fmt='( )' + !---- + ! Define format and dimensions for conversion + !---- + allocate(ibase(nlin*(leng+3)/4)) + n=leng/4 + m=mod(leng,4) + if(n > 0)write(fmt(2:9),'(i6,''a4'')') n + if(m > 0)then + if(n.gt.0)fmt(10:10)=',' + write(fmt(11:12),'(''a'',i1)') m + n=n+1 + endif + !---- + ! Convert strings to integers + !---- + nlin1=size(carr,1) + nlin2=size(carr,2) + if(nlin1*nlin2.ne.nlin) then + write(hsmg,'(29hLCMPLC_S2: allocated length (,i5,17h) is not equal to, & + & 16h argument size (,i5,2h).)') nlin1*nlin2,nlin + call xabort(hsmg) + endif + do i2=1,nlin2 + do i1=1,nlin1 + i=(i2-1)*nlin1+i1 + read(carr(i1,i2)(1:leng),fmt) (ibase((i-1)*n+j),j=1,n) + enddo + enddo + !---- + ! Write to LCM object + !---- + call LCMPDL(iplcm,ipos,n*nlin,3,ibase) + deallocate(ibase) +end subroutine LCMPLC_S2 +end module LCMTLC diff --git a/Ganlib/src/LCMULT.f b/Ganlib/src/LCMULT.f new file mode 100644 index 0000000..aa7f4b4 --- /dev/null +++ b/Ganlib/src/LCMULT.f @@ -0,0 +1,197 @@ +*DECK LCMULT + SUBROUTINE LCMULT(IPLIST,FLOTT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiply the floating point information contained in the active +* directory of a table or XSM file by a real number. +* +*Copyright: +* Copyright (C) 1993 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIS1 address of the table or handle to the XSM file. +* FLOTT real number. +* +*Parameters: output +* IPLIS1 address of the table or handle to the XSM file. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + REAL FLOTT +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXLEV=50) + TYPE(C_PTR) KDATA(MAXLEV) + CHARACTER NAMT*12,HSMG*131,MYNAME*12,NAMLCM*12,PATH(MAXLEV)*12, + 1 FIRST(MAXLEV)*12 + LOGICAL EMPTY,LCM + INTEGER IVEC(MAXLEV),KJLON(MAXLEV),IGO(MAXLEV) + TYPE(C_PTR) :: PT_DATA + REAL, POINTER :: RRR(:) + DOUBLE PRECISION, POINTER :: DDD(:) + COMPLEX, POINTER :: CCC(:) +* + CALL LCMVAL(IPLIST,' ') + ILEV=1 + KDATA(1)=IPLIST + KJLON(1)=-1 + IVEC(1)=1 + IGO(1)=5 +* +* ASSOCIATIVE TABLE. + 10 CALL LCMINF(IPLIST,MYNAME,NAMLCM,EMPTY,ILONG,LCM) + IF(EMPTY) GO TO (100,100,240,240,250),IGO(ILEV) + NAMT=' ' + CALL LCMNXT(IPLIST,NAMT) +* + FIRST(ILEV)=NAMT + 15 CALL LCMLEN(IPLIST,NAMT,ILON1,ITY1) + IF(ITY1.EQ.0) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMULT: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',MYNAME,'''(1).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA(ILEV)=LCMGID(IPLIST,NAMT) + PATH(ILEV)=NAMT + IPLIST=KDATA(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=1 + GO TO 10 + ELSE IF(ITY1.EQ.10) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMULT: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',MYNAME,'''(2).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILON1 + KDATA(ILEV)=LCMGID(IPLIST,NAMT) + PATH(ILEV)=NAMT + IPLIST=KDATA(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=2 + GO TO 190 + ELSE IF(ITY1.EQ.2) THEN +* SINGLE PRECISION DATA. + CALL LCMGPD(IPLIST,NAMT,PT_DATA) + CALL C_F_POINTER(PT_DATA, RRR, (/ ILON1 /)) + DO 70 I=1,ILON1 + RRR(I)=FLOTT*RRR(I) + 70 CONTINUE + CALL LCMPPD(IPLIST,NAMT,ILON1,ITY1,PT_DATA) + ELSE IF(ITY1.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL LCMGPD(IPLIST,NAMT,PT_DATA) + CALL C_F_POINTER(PT_DATA, DDD, (/ ILON1 /)) + DO 80 I=1,ILON1 + DDD(I)=FLOTT*DDD(I) + 80 CONTINUE + CALL LCMPPD(IPLIST,NAMT,ILON1,ITY1,PT_DATA) + ELSE IF(ITY1.EQ.6) THEN +* COMPLEX DATA. + CALL LCMGPD(IPLIST,NAMT,PT_DATA) + CALL C_F_POINTER(PT_DATA, CCC, (/ ILON1 /)) + DO 90 I=1,ILON1 + CCC(I)=FLOTT*CCC(I) + 90 CONTINUE + CALL LCMPPD(IPLIST,NAMT,ILON1,ITY1,PT_DATA) + ENDIF + CALL LCMNXT(IPLIST,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 15 + GO TO (100,100,240,240,250),IGO(ILEV) +* + 100 NAMT=PATH(ILEV) + ILEV=ILEV-1 + IPLIST=KDATA(ILEV) + CALL LCMNXT(IPLIST,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 15 + GO TO (100,100,240,240,250),IGO(ILEV) +* +* LIST. + 190 IVEC(ILEV)=IVEC(ILEV)+1 + IF(IVEC(ILEV).GT.KJLON(ILEV)) THEN + GO TO (100,100,240,240,250),IGO(ILEV) + ENDIF + CALL LCMLEL(KDATA(ILEV),IVEC(ILEV),ILON1,ITY1) + IF((ILON1.NE.0).AND.(ITY1.EQ.0)) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMULT: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',MYNAME,'''(3).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + KDATA(ILEV)=LCMGIL(IPLIST,IVEC(ILEV-1)) + IPLIST=KDATA(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=3 + GO TO 10 + ELSE IF((ILON1.NE.0).AND.(ITY1.EQ.10)) THEN +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LCMULT: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',MYNAME,'''(4).' + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILON1 + KDATA(ILEV)=LCMGIL(IPLIST,IVEC(ILEV-1)) + IPLIST=KDATA(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=4 + GO TO 190 + ELSE IF((ILON1.NE.0).AND.(ITY1.LE.6)) THEN + IF((ITY1.EQ.2).OR.(ITY1.EQ.6)) THEN +* SINGLE PRECISION DATA. + CALL LCMGPL(IPLIST,IVEC(ILEV),PT_DATA) + CALL C_F_POINTER(PT_DATA, RRR, (/ ILON1 /)) + DO 210 I=1,ILON1 + RRR(I)=FLOTT*RRR(I) + 210 CONTINUE + CALL LCMPPL(IPLIST,IVEC(ILEV),ILON1,ITY1,PT_DATA) + ELSE IF(ITY1.EQ.4) THEN +* DOUBLE PRECISION DATA. + CALL LCMGPL(IPLIST,IVEC(ILEV),PT_DATA) + CALL C_F_POINTER(PT_DATA, DDD, (/ ILON1 /)) + DO 220 I=1,ILON1 + DDD(I)=FLOTT*DDD(I) + 220 CONTINUE + CALL LCMPPL(IPLIST,IVEC(ILEV),ILON1,ITY1,PT_DATA) + ELSE IF(ITY1.EQ.6) THEN +* COMPLEX DATA. + CALL LCMGPL(IPLIST,IVEC(ILEV),PT_DATA) + CALL C_F_POINTER(PT_DATA, CCC, (/ ILON1 /)) + DO 230 I=1,ILON1 + CCC(I)=FLOTT*CCC(I) + 230 CONTINUE + CALL LCMPPL(IPLIST,IVEC(ILEV),ILON1,ITY1,PT_DATA) + ENDIF + ENDIF + GO TO 190 +* + 240 ILEV=ILEV-1 + IPLIST=KDATA(ILEV) + GO TO 190 +* + 250 RETURN + END diff --git a/Ganlib/src/MSTANP.f b/Ganlib/src/MSTANP.f new file mode 100644 index 0000000..ca87030 --- /dev/null +++ b/Ganlib/src/MSTANP.f @@ -0,0 +1,104 @@ +*DECK MSTANP + SUBROUTINE MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR,ACSTR, + 1 TYSTR,NBDIR,DIRS,ROOT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Analyse user defined path. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): R. Le Tellier +* +*Parameters: input +* NENTRY number of LCM objects or files used by the operator. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* PATH user defined path. +* +*Parameters: output +* IPSTR structure address. +* ACSTR structure access. +* TYSTR structure type. +* NBDIR number of directories/blocks in PATH. +* DIRS array of the directories/blocks names. +* ROOT flag to know if the path is relative or absolute. +* +*----------------------------------------------------------------------- +* + USE, INTRINSIC :: ISO_C_BINDING + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY + CHARACTER DIRS(37)*12,PATH*72 + INTEGER IENTRY(NENTRY),JENTRY(NENTRY),ACSTR,TYSTR,NBDIR + TYPE(C_PTR) KENTRY(NENTRY),IPSTR + LOGICAL ROOT +*---- +* LOCAL VARIABLES +*---- + INTEGER II,IBEG,IEND,I + CHARACTER*12 OBJNAM,MYDIR +* +* SEARCH FOR OBJECT NAME + OBJNAM=' ' + IBEG=0 + DO II=1,72 + IF (PATH(II:II).EQ.':') THEN + OBJNAM=PATH(1:II-1) + IBEG=II+1 + GOTO 10 + ENDIF + ENDDO + 10 CONTINUE + IF (OBJNAM.EQ.' ') THEN + IBEG=1 + ELSE + READ(OBJNAM,'(I12)') I + IF ((I.GT.NENTRY).OR.(I.LT.1)) THEN + CALL XABORT('MSTANP: INCORRECT OBJECT INDEX') + ENDIF + ACSTR=JENTRY(I) + TYSTR=IENTRY(I) + IPSTR=KENTRY(I) + GOTO 15 + ENDIF + 15 CONTINUE +* FIND THE HIERCHICAL DIRECTORIES STRUCTURE + IF (PATH(IBEG:IBEG).EQ.'/') THEN + ROOT=.TRUE. + ELSE + ROOT=.FALSE. + ENDIF + NBDIR=0 + DO II=IBEG,72 + IF ((PATH(II:II).EQ.'/').OR. + 1 (PATH(II:II).EQ.' ')) THEN + IEND=II-1 + IF ((IBEG.LE.IEND).AND.(PATH(IBEG:IEND).NE.'.')) THEN + NBDIR=NBDIR+1 + MYDIR=PATH(IBEG:IEND) + DIRS(NBDIR)=MYDIR + ENDIF + IBEG=II+1 + IF (PATH(II:II).EQ.' ') GOTO 20 + ENDIF + ENDDO + 20 CONTINUE +* + RETURN + END diff --git a/Ganlib/src/MSTCDI.f b/Ganlib/src/MSTCDI.f new file mode 100644 index 0000000..5094911 --- /dev/null +++ b/Ganlib/src/MSTCDI.f @@ -0,0 +1,106 @@ +*DECK MSTCDI + SUBROUTINE MSTCDI(IPSTR,ACSTR,IPRINT,NBLOCK,MYDIR,BLNAM,BLTYP, + 1 BLLEN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create a new directory and move in a structure according to a defined +* directory name. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* ACSTR structure access. +* IPRINT level of print index. +* NBLOCK number of existing block in the directory. +* MYDIR name of the directory to be created/moved in. +* BLNAM names of these blocks. +* BLTYP types of these blocks. +* BLLEN lengths of these blocks. +* +*Parameters: input/output +* IPSTR entering/leaving directory address. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSTR + INTEGER ACSTR,IPRINT,NBLOCK,BLTYP(NBLOCK+1),BLLEN(NBLOCK+1) + CHARACTER(LEN=12) BLNAM(NBLOCK+1) + CHARACTER*12 MYDIR +*---- +* LOCAL VARIABLES +*---- + INTEGER IOUT,NSTATE + PARAMETER (IOUT=6,NSTATE=40) + INTEGER ISTATE(NSTATE),JJ,ILEN,ITYP + LOGICAL EXIST +*---- +* PERFORM CD RELATED ACTIONS +*---- + IF (MYDIR.EQ.'..') THEN +* GOING TO FATHER DIR + IF (IPRINT.GT.2) WRITE(IOUT,*) 'MSTCDI: GOING TO FATHER DIR' + CALL LCMSIX(IPSTR,' ',2) + ELSE +* GOING TO SON DIR + EXIST=.FALSE. + IF (NBLOCK.NE.0) THEN +* IS THIS SON DIR ALREADY PART OF THE STRUCTURE ? + DO JJ=1,NBLOCK + IF(BLNAM(JJ).EQ.MYDIR) THEN + IF (BLLEN(JJ).NE.-1) CALL XABORT('MSTCDI: '//MYDIR// + 1 ' IS AN EXISTING BLOCK.') + EXIST=.TRUE. + GOTO 10 + ENDIF + ENDDO + 10 CONTINUE + ENDIF + IF (EXIST) THEN +* YES: + IF (IPRINT.GT.2) + 1 WRITE(IOUT,*) 'MSTCDI: ENTERING EXISTING DIR '//MYDIR + ELSE +* NO: + CALL LCMLEN(IPSTR,MYDIR,ILEN,ITYP) + IF (ILEN.NE.0) THEN +* IT IS ASSUMED THAT THIS IS AN EXTERNAL STRUCTURE FROM WHICH INFORMATION CAN BE RETRIEVED + EXIST=.TRUE. + GOTO 20 + ENDIF + IF (ACSTR.EQ.2) + 1 CALL XABORT('MSTCDI: CANNOT CREATE DIR IN READ-ONLY MODE') + IF (IPRINT.GT.2) + 1 WRITE(IOUT,*) 'MSTCDI: CREATING DIR '//MYDIR + CALL LCMGET(IPSTR,'STATE-VECTOR',ISTATE) + ISTATE(40)=ISTATE(40)+1 + BLNAM(NBLOCK+1)=MYDIR + BLTYP(NBLOCK+1)=0 + BLLEN(NBLOCK+1)=-1 + CALL LCMPUT(IPSTR,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPTC(IPSTR,'REC-NAMES',12,NBLOCK+1,BLNAM) + CALL LCMPUT(IPSTR,'REC-TYPES',(NBLOCK+1),1,BLTYP) + CALL LCMPUT(IPSTR,'REC-LENGTHS',(NBLOCK+1),1,BLLEN) + ENDIF + 20 CALL LCMSIX(IPSTR,MYDIR,1) + IF (.NOT.EXIST) THEN + ISTATE(:NSTATE)=0 + CALL LCMPUT(IPSTR,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF + ENDIF + + RETURN + END diff --git a/Ganlib/src/MSTCPB.f b/Ganlib/src/MSTCPB.f new file mode 100644 index 0000000..4fc6a0a --- /dev/null +++ b/Ganlib/src/MSTCPB.f @@ -0,0 +1,211 @@ +*DECK MSTCPB + SUBROUTINE MSTCPB(IPSTR,IPSTR2,IPRINT,IBEG,IEND,IINC,NAME,NAME2, + 1 NBLOCK,BLNAM,BLTYP,BLLEN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Copy some elements from a structure's block to another. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPSTR address of the structure from which the information is +* retrieved. +* IPSTR2 destination structure address. +* IPRINT level of print index. +* IBEG index of the first element. +* IEND index of the last element. +* IINC index increment between two consecutive elements. +* NAME name of the block from which the information is retrieved. +* NAME2 destination block name. +* NBLOCK number of existing block in the directory. +* BLNAM names of these blocks. +* BLTYP types of these blocks. +* BLLEN lengths of these blocks. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) :: IPSTR,IPSTR2 + INTEGER :: IPRINT,IBEG,IEND,IINC,NBLOCK,BLTYP(NBLOCK+1), + 1 BLLEN(NBLOCK+1) + CHARACTER(LEN=12) :: BLNAM(NBLOCK+1),NAME,NAME2 +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER :: IOUT=6,NSTATE=40 + INTEGER :: ISTATE(NSTATE),NARA,ITYP,SIZE,ITYPO,NELEO,NARA2,II,JJ, + 1 SIZE2 + CHARACTER(LEN=12) :: WHITE12 + LOGICAL :: EXIST + INTEGER, ALLOCATABLE, DIMENSION(:) :: IARA,IARA2 + REAL, ALLOCATABLE, DIMENSION(:) :: ARA,ARA2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DARA,DARA2 +*---- +* RETRIEVING BLOCK TO BE COPIED +*---- + CALL LCMLEN(IPSTR,NAME,SIZE,ITYP) + IF (SIZE.LE.0) THEN + CALL LCMLIB(IPSTR) + CALL XABORT('MSTCPB: INVALID BLOCK '//NAME//'.') + ENDIF + NARA=0 + IF (ITYP.EQ.1) THEN + NARA=SIZE + ALLOCATE(IARA(NARA)) + CALL LCMGET(IPSTR,NAME,IARA) + ELSEIF (ITYP.LE.2) THEN + NARA=SIZE + ALLOCATE(ARA(NARA)) + CALL LCMGET(IPSTR,NAME,ARA) + ELSEIF (ITYP.EQ.3) THEN + NARA=SIZE/3 + ALLOCATE(IARA(3*NARA)) + CALL LCMGET(IPSTR,NAME,IARA) + ELSEIF (ITYP.EQ.4) THEN + NARA=SIZE + ALLOCATE(DARA(NARA)) + CALL LCMGET(IPSTR,NAME,DARA) + ELSE + CALL XABORT('MSTCPB: UNSUPPORTED TYPE') + ENDIF + IF (IEND.GT.NARA) CALL XABORT('MSTCPB: INCOMPATIBLE SIZE') +* DOES THIS BLOCK ALREADY EXIST IN THE DESTINATION STRUCTURE ? + EXIST=.FALSE. + NELEO=0 +* SPECIAL CASE OF STATE-VECTOR MODIFICATION + IF (NAME2.EQ.'STATE-VECTOR') THEN + IF (IEND.GT.40) + 1 CALL XABORT('MSTCPM: STATE-VECTOR SIZE IS LIMITED TO 40.') + IF (IEND.EQ.40) + 2 CALL XABORT('MSTCPM: 40th STATE-VECTOR ELEMENT SHOULD'// + 3 ' NOT BE MODIFIED.') + ITYPO=1 + NELEO=NSTATE + EXIST=.TRUE. + ENDIF + IF (NBLOCK.NE.0) THEN + DO II=1,NBLOCK + IF(BLNAM(II).EQ.NAME2) THEN + ITYPO=BLTYP(II) + IF (ITYPO.EQ.0) + 1 CALL XABORT('MSTCPM: '//NAME2// + 2 ' IS AN EXISTING DIRECTORY.') + IF (ITYPO.NE.ITYP) + 1 CALL XABORT('MSTCPM: INCOMPATIBLE TYPES') + NELEO=BLLEN(II) + EXIST=.TRUE. + GOTO 20 + ENDIF + ENDDO + 20 CONTINUE + ENDIF + IF (IPRINT.GT.2) THEN + IF (EXIST) THEN +* YES: IT WILL BE UPDATED + WRITE(IOUT,*) 'MSTCPB: BLOCK '//NAME//' IN UPDATE MODE' + ELSE +* NO: IT WILL BE CREATED + WRITE(IOUT,*) 'MSTCPB: BLOCK '//NAME//' IN CREATION MODE' + ENDIF + ENDIF + NARA2=MAX(NARA,NELEO) +* ALLOCATE MEMORY + IF (ITYP.EQ.1) THEN + SIZE2=NARA2 + ALLOCATE(IARA2(NARA2)) + ELSEIF (ITYP.EQ.2) THEN + SIZE2=NARA2 + ALLOCATE(ARA2(NARA2)) + ELSEIF (ITYP.EQ.3) THEN + SIZE2=3*NARA2 + ALLOCATE(IARA2(3*NARA2)) + ELSEIF (ITYP.EQ.4) THEN + SIZE2=NARA2 + ALLOCATE(DARA2(NARA2)) + ENDIF +* INITIALIZE BLOCK + IF (EXIST) THEN + IF (ITYP.EQ.1) THEN + CALL LCMGET(IPSTR2,NAME2,IARA2) + ELSEIF (ITYP.EQ.2) THEN + CALL LCMGET(IPSTR2,NAME2,ARA2) + ELSEIF (ITYP.EQ.3) THEN + CALL LCMGET(IPSTR2,NAME2,IARA2) + ELSEIF (ITYP.EQ.4) THEN + CALL LCMGET(IPSTR2,NAME2,DARA2) + ENDIF + ELSE + IF (ITYP.EQ.1) THEN + IARA2(:NARA)=0 + ELSEIF (ITYP.EQ.2) THEN + ARA2(:NARA)=0 + ELSEIF (ITYP.EQ.3) THEN + WHITE12=' ' + DO II=1,NARA + READ(WHITE12,'(3A4)') (IARA2(3*(II-1)+JJ),JJ=0,2) + ENDDO + ELSEIF (ITYP.EQ.4) THEN + DARA2(:NARA)=0.D0 + ENDIF + ENDIF +* COPY ACTION + DO II=IBEG,IEND,IINC + IF (ITYP.EQ.1) THEN + IARA2(II)=IARA(II) + ELSEIF (ITYP.EQ.2) THEN + ARA2(II)=ARA(II) + ELSEIF (ITYP.EQ.3) THEN + DO JJ=0,2 + IARA2(3*(II-1)+JJ)=IARA(3*(II-1)+JJ) + ENDDO + ELSEIF (ITYP.EQ.4) THEN + DARA2(II)=DARA(II) + ENDIF + ENDDO + IF (ITYP.EQ.1) THEN + CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,IARA2) + DEALLOCATE(IARA2) + DEALLOCATE(IARA) + ELSEIF (ITYP.EQ.2) THEN + CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,ARA2) + DEALLOCATE(ARA2) + DEALLOCATE(ARA) + ELSEIF (ITYP.EQ.3) THEN + CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,IARA2) + DEALLOCATE(IARA2) + DEALLOCATE(IARA) + ELSEIF (ITYP.EQ.4) THEN + CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,DARA2) + DEALLOCATE(DARA2) + DEALLOCATE(DARA) + ENDIF +*---- +* UPDATE NB. BLOCKS, REC-NAMES, REC-TYPES, REC-LENGTHS IN STATE-VECTOR +* IF REQUIRED +*---- + IF (.NOT.EXIST) THEN + CALL LCMGET(IPSTR2,'STATE-VECTOR',ISTATE) + ISTATE(40)=ISTATE(40)+1 + BLNAM(NBLOCK+1)=NAME + BLTYP(NBLOCK+1)=ITYP + BLLEN(NBLOCK+1)=NARA + CALL LCMPUT(IPSTR2,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPTC(IPSTR2,'REC-NAMES',12,NBLOCK+1,BLNAM) + CALL LCMPUT(IPSTR2,'REC-TYPES',(NBLOCK+1),1,BLTYP) + CALL LCMPUT(IPSTR2,'REC-LENGTHS',(NBLOCK+1),1,BLLEN) + ENDIF + RETURN + END diff --git a/Ganlib/src/MSTGET.f b/Ganlib/src/MSTGET.f new file mode 100644 index 0000000..300145a --- /dev/null +++ b/Ganlib/src/MSTGET.f @@ -0,0 +1,100 @@ +*DECK MSTGET + SUBROUTINE MSTGET(IPSTR,IPRINT,IBEG,IEND,IINC,NAME) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Retrieve data from an existing block and put them into input variables. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPSTR structure address. +* IPRINT level of print index. +* IBEG index of the first element. +* IEND index of the last element. +* IINC index increment between two consecutive elements. +* NAME block name. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) :: IPSTR + INTEGER :: IPRINT,IBEG,IEND,IINC + CHARACTER(LEN=12) :: NAME +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER :: IOUT=6 + INTEGER :: INDIC,NITMA,NARA,ITYP,SIZE,II,JJ + REAL :: FLOTT + DOUBLE PRECISION :: DFLOTT + CHARACTER(LEN=12) :: TEXT12 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IARA + REAL, ALLOCATABLE, DIMENSION(:) :: ARA + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DARA +*---- +* RETRIEVING BLOCK +*---- + CALL LCMLEN(IPSTR,NAME,SIZE,ITYP) + IF (SIZE.LE.0) THEN + CALL LCMLIB(IPSTR) + CALL XABORT('MSTGET: INVALID BLOCK '//NAME//'.') + ENDIF + NARA=0 + IF (ITYP.EQ.1) THEN + NARA=SIZE + ALLOCATE(IARA(NARA)) + CALL LCMGET(IPSTR,NAME,IARA) + ELSEIF (ITYP.EQ.2) THEN + NARA=SIZE + ALLOCATE(ARA(NARA)) + CALL LCMGET(IPSTR,NAME,ARA) + ELSEIF (ITYP.EQ.3) THEN + NARA=SIZE/3 + ALLOCATE(IARA(3*NARA)) + CALL LCMGET(IPSTR,NAME,IARA) + ELSEIF (ITYP.EQ.4) THEN + NARA=SIZE + ALLOCATE(DARA(NARA)) + CALL LCMGET(IPSTR,NAME,DARA) + ELSE + CALL XABORT('MSTGET: UNSUPPORTED TYPE') + ENDIF + IF (IEND.GT.NARA) CALL XABORT('MSTGET: INCOMPATIBLE SIZE') + IF (IPRINT.GT.2) + 1 WRITE(IOUT,*) 'MSTGET: RETRIEVING DATA FROM '//NAME//' BLOCK' +* PUT USER REQUESTED DATA IN INPUT VARIABLES + DO II=IBEG,IEND,IINC + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF (-INDIC.NE.ITYP) + 1 CALL XABORT('MSTGET: INVALID VARIABLE TYPE.') + IF (ITYP.EQ.1) THEN + NITMA=IARA(II) + DEALLOCATE(IARA) + ELSEIF (ITYP.EQ.2) THEN + FLOTT=ARA(II) + DEALLOCATE(ARA) + ELSEIF (ITYP.EQ.3) THEN + WRITE(TEXT12,'(3A4)') (IARA(3*(II-1)+JJ),JJ=0,2) + NITMA=12 + DEALLOCATE(IARA) + ELSEIF (ITYP.EQ.4) THEN + DFLOTT=DARA(II) + DEALLOCATE(DARA) + ENDIF + CALL REDPUT(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + ENDDO + RETURN + END diff --git a/Ganlib/src/MSTMOV.f b/Ganlib/src/MSTMOV.f new file mode 100644 index 0000000..ce4d8ab --- /dev/null +++ b/Ganlib/src/MSTMOV.f @@ -0,0 +1,69 @@ +*DECK MSTMOV + SUBROUTINE MSTMOV(IPSTR,ACSTR,IPRINT,NBDIR,DIRS,ROOT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Analyse user defined path. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPSTR structure address. +* ACSTR structure access. +* IPRINT level of print index. +* NBDIR number of successive directories. +* DIRS array of directories names. +* ROOT flag to know if the path is relative or absolute. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IPRINT,ACSTR,NBDIR + CHARACTER DIRS(NBDIR)*12 + TYPE(C_PTR) IPSTR + LOGICAL ROOT +*---- +* LOCAL VARIABLES +*---- + INTEGER I,NBLOCK + INTEGER, PARAMETER :: IOUT=6 + INTEGER, PARAMETER :: NSTATE=40 + INTEGER ISTATE(NSTATE) + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: BLNAM + INTEGER, ALLOCATABLE, DIMENSION(:) :: BLTYP,BLLEN +* + IF (ROOT) THEN +* FIRST OF ALL, GOING TO ROOT DIR IF THE PATH IS ABSOLUTE + IF (IPRINT.GT.2) WRITE(IOUT,*) 'MSTMOV: GOING TO ROOT DIR' + CALL LCMSIX(IPSTR,' ',0) + ENDIF + DO I=1,NBDIR +* ENTERING SUCCESSIVE DIRECTORIES +* (A DIRECTORY IS CREATED IF IT DOES NOT EXIST +* AND THE STRUCTURE IS NOT IN READ-ONLY MODE) + CALL LCMGET(IPSTR,'STATE-VECTOR',ISTATE) + NBLOCK=ISTATE(40) + ALLOCATE(BLNAM(NBLOCK+1),BLTYP(NBLOCK+1),BLLEN(NBLOCK+1)) + IF (NBLOCK.GT.0) THEN + CALL LCMGTC(IPSTR,'REC-NAMES',12,NBLOCK+1,BLNAM) + CALL LCMGET(IPSTR,'REC-TYPES',BLTYP) + CALL LCMGET(IPSTR,'REC-LENGTHS',BLLEN) + ENDIF + CALL MSTCDI(IPSTR,ACSTR,IPRINT,NBLOCK,DIRS(I),BLNAM,BLTYP, + 1 BLLEN) + DEALLOCATE(BLLEN,BLTYP,BLNAM) + ENDDO + RETURN + END diff --git a/Ganlib/src/MSTPUT.f b/Ganlib/src/MSTPUT.f new file mode 100644 index 0000000..93ec582 --- /dev/null +++ b/Ganlib/src/MSTPUT.f @@ -0,0 +1,187 @@ +*DECK MSTPUT + SUBROUTINE MSTPUT(IPSTR,IPRINT,IBEG,IEND,IINC,NAME,NBLOCK,BLNAM, + 1 BLTYP,BLLEN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create or update a block in a structure from user input data. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input +* IPSTR structure address. +* IPRINT level of print index. +* IBEG index of the first element. +* IEND index of the last element. +* IINC index increment between two consecutive elements. +* NAME block name. +* NBLOCK number of existing block in the directory. +* BLNAM names of these blocks. +* BLTYP types of these blocks. +* BLLEN lengths of these blocks. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) :: IPSTR + INTEGER :: IPRINT,IBEG,IEND,IINC,NBLOCK,BLTYP(NBLOCK+1), + 1 BLLEN(NBLOCK+1) + CHARACTER(LEN=12) :: BLNAM(NBLOCK+1),NAME +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER :: IOUT=6 + INTEGER, PARAMETER :: NSTATE=40 + INTEGER :: INDIC,NITMA,ISTATE(NSTATE),II,JJ,ITYPO,NELEO,ITYP, + 1 NARA,SIZE + REAL :: FLOTT + DOUBLE PRECISION :: DFLOTT + CHARACTER(LEN=12) :: TEXT12,WHITE12 + LOGICAL :: EXIST + INTEGER, ALLOCATABLE, DIMENSION(:) :: IARA + REAL, ALLOCATABLE, DIMENSION(:) :: ARA + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DARA +* +* BLOCK NAME + EXIST=.FALSE. + NELEO=0 +* SPECIAL CASE OF STATE-VECTOR MODIFICATION + IF (NAME.EQ.'STATE-VECTOR') THEN + IF (IEND.GT.40) + 1 CALL XABORT('MSTPUT: STATE-VECTOR SIZE IS LIMITED TO 40.') + IF (IEND.EQ.40) + 2 CALL XABORT('MSTPUT: 40th STATE-VECTOR ELEMENT SHOULD'// + 3 ' NOT BE MODIFIED.') + ITYPO=1 + NELEO=NSTATE + EXIST=.TRUE. + ENDIF + IF (NBLOCK.NE.0) THEN +* IS THIS BLOCK ALREADY PART OF THE STRUCTURE ? + DO II=1,NBLOCK + IF(BLNAM(II).EQ.NAME) THEN + ITYPO=BLTYP(II) + IF (ITYPO.EQ.0) + 1 CALL XABORT('MSTPUT: '//NAME//' IS AN EXISTING DIRECTORY.') + NELEO=BLLEN(II) + EXIST=.TRUE. + GOTO 20 + ENDIF + ENDDO + 20 CONTINUE + ENDIF + IF (IPRINT.GT.2) THEN + IF (EXIST) THEN +* YES: IT WILL BE UPDATED + WRITE(IOUT,*) 'MSTPUT: BLOCK '//NAME//' IN UPDATE MODE' + ELSE +* NO: IT WILL BE CREATED + WRITE(IOUT,*) 'MSTPUT: BLOCK '//NAME//' IN CREATION MODE' + ENDIF + ENDIF +* FIRST ELEMENT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + ITYP=INDIC + IF ((EXIST).AND.(ITYP.NE.ITYPO)) + 1 CALL XABORT('MSTPUT: HETEROGENEOUS BLOCK NOT SUPPORTED') + IF (INDIC.GT.4) + 1 CALL XABORT('MSTPUT: UNSUPPORTED TYPE(1)') + NARA=MAX(IEND,NELEO) +* ALLOCATE MEMORY + IF (ITYP.EQ.1) THEN + SIZE=NARA + ALLOCATE(IARA(NARA)) + ELSEIF (ITYP.EQ.2) THEN + SIZE=NARA + ALLOCATE(ARA(NARA)) + ELSEIF (ITYP.EQ.3) THEN + SIZE=3*NARA + ALLOCATE(IARA(3*NARA)) + ELSEIF (ITYP.EQ.4) THEN + SIZE=NARA + ALLOCATE(DARA(NARA)) + ENDIF +* INITIALIZE BLOCK + IF (EXIST) THEN + IF (ITYP.EQ.1) THEN + CALL LCMGET(IPSTR,NAME,IARA) + ELSEIF (ITYP.EQ.2) THEN + CALL LCMGET(IPSTR,NAME,ARA) + ELSEIF (ITYP.EQ.3) THEN + CALL LCMGET(IPSTR,NAME,IARA) + ELSEIF (ITYP.EQ.4) THEN + CALL LCMGET(IPSTR,NAME,DARA) + ENDIF + ELSE + IF (ITYP.EQ.1) THEN + IARA(:IEND)=0 + ELSEIF (ITYP.EQ.2) THEN + ARA(:IEND)=0.0 + ELSEIF (ITYP.EQ.3) THEN + WHITE12=' ' + DO II=1,IEND + READ(WHITE12,'(3A4)') (IARA(3*(II-1)+JJ),JJ=0,2) + ENDDO + ELSEIF (ITYP.EQ.4) THEN + DARA(:IEND)=0.D0 + ENDIF + ENDIF +* RETRIEVE USER'S INPUT VALUES + DO II=IBEG,IEND,IINC + IF (INDIC.NE.ITYP) + 1 CALL XABORT('MSTPUT: HETEROGENEOUS BLOCK NOT SUPPORTED') + IF (INDIC.EQ.1) THEN + IARA(II)=NITMA + ELSEIF (INDIC.EQ.2) THEN + ARA(II)=FLOTT + ELSEIF (INDIC.EQ.3) THEN + READ(TEXT12,'(3A4)') (IARA(3*(II-1)+JJ),JJ=0,2) + ELSEIF (INDIC.EQ.4) THEN + DARA(II)=DFLOTT + ELSE + CALL XABORT('MSTPUT: UNSUPPORTED TYPE(2)') + ENDIF + IF (II.LT.IEND) CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + ENDDO + IF (INDIC.EQ.1) THEN + CALL LCMPUT(IPSTR,NAME,SIZE,ITYP,IARA) + DEALLOCATE(IARA) + ELSEIF (INDIC.EQ.2) THEN + CALL LCMPUT(IPSTR,NAME,SIZE,ITYP,ARA) + DEALLOCATE(ARA) + ELSEIF (INDIC.EQ.3) THEN + CALL LCMPUT(IPSTR,NAME,SIZE,ITYP,IARA) + DEALLOCATE(IARA) + ELSEIF (INDIC.EQ.4) THEN + CALL LCMPUT(IPSTR,NAME,SIZE,ITYP,DARA) + DEALLOCATE(DARA) + ENDIF +*---- +* UPDATE NB. BLOCKS, REC-NAMES, REC-TYPES, REC-LENGTHS IN STATE-VECTOR +* IF REQUIRED +*---- + IF (.NOT.EXIST) THEN + CALL LCMGET(IPSTR,'STATE-VECTOR',ISTATE) + ISTATE(40)=ISTATE(40)+1 + BLNAM(NBLOCK+1)=NAME + BLTYP(NBLOCK+1)=ITYP + BLLEN(NBLOCK+1)=NARA + CALL LCMPUT(IPSTR,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPTC(IPSTR,'REC-NAMES',12,NBLOCK+1,BLNAM) + CALL LCMPUT(IPSTR,'REC-TYPES',(NBLOCK+1),1,BLTYP) + CALL LCMPUT(IPSTR,'REC-LENGTHS',(NBLOCK+1),1,BLLEN) + ENDIF + RETURN + END diff --git a/Ganlib/src/MSTR.f b/Ganlib/src/MSTR.f new file mode 100644 index 0000000..567369b --- /dev/null +++ b/Ganlib/src/MSTR.f @@ -0,0 +1,222 @@ +*DECK MSTR + SUBROUTINE MSTR(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Manage user-defined structures. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Le Tellier +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): modification type(VECTOR); +* HENTRY(2): read-only type(VECTOR). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY + CHARACTER HENTRY(NENTRY)*12 + INTEGER IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,ACSTR,TYSTR,ACSTRO,TYSTRO,ACSTR2,TYSTR2 + INTEGER, PARAMETER :: IOUT=6 + INTEGER, PARAMETER :: NSTATE=40 + INTEGER INDIC,NITMA,ISTATE(NSTATE),IPRINT,NBLOCK,ILEN,ITYP,NBDIR + REAL FLOTT + DOUBLE PRECISION DFLOTT + CHARACTER TEXT4*4,NAME*12,PATH*72,DIRS(37)*12,NAME2*12,TEXT12*12 + LOGICAL ROOT + TYPE(C_PTR) IPSTR,IPSTRO,IPSTR2 + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: BLNAM + INTEGER, ALLOCATABLE, DIMENSION(:) :: BLTYP,BLLEN +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LT.1) + 1 CALL XABORT('MSTR: AT LEAST ONE PARAMETER EXPECTED.') + DO I=1,NENTRY + IF(IENTRY(I).GT.2) + 1 CALL XABORT('MSTR: LINKED LIST OR XSM EXPECTED.') + ENDDO +*---- +* CREATE STATE-VECTOR/SIGNATURE FOR STRUCTURES IN CREATION MODE +* VERIFY IF IT EXISTS FOR STRUCTURES IN MODIFICATION MODE +*---- + DO I=1,NENTRY + ACSTR=JENTRY(I) + IPSTR=KENTRY(I) + IF (ACSTR.EQ.0) THEN +* THE STRUCTURE IS CREATED: +* ASSIGN IT A DEFAULT SIGNATURE AND A STATE-VECTOR + NAME='VECTOR' + CALL LCMPTC(IPSTR,'SIGNATURE',12,NAME) + ISTATE(:NSTATE)=0 + CALL LCMPUT(IPSTR,'STATE-VECTOR',NSTATE,1,ISTATE) + ELSEIF (ACSTR.EQ.1) THEN + CALL LCMLEN(IPSTR,'SIGNATURE',ILEN,ITYP) + IF ((ILEN.NE.3).OR.(ITYP.NE.3)) + 1 CALL XABORT('MSTR: INVALID SIGNATURE FOR '//HENTRY(I) + 2 //'.') + CALL LCMLEN(IPSTR,'STATE-VECTOR',ILEN,ITYP) + IF ((ILEN.NE.40).OR.(ITYP.NE.1)) + 1 CALL XABORT('MSTR: INVALID STATE-VECTOR FOR '//HENTRY(I) + 2 //'.') + ENDIF + ENDDO +*--- +* PROCESS USER'S INPUT +*--- + IPRINT=0 + ACSTR=JENTRY(1) + TYSTR=IENTRY(1) + IPSTR=KENTRY(1) + ACSTR2=ACSTR + TYSTR2=TYSTR + IPSTR2=IPSTR + 50 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 60 + IF(INDIC.NE.3) CALL XABORT('MSTR: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'EDIT') THEN +* MODULE EDITION LEVEL + CALL REDGET(INDIC,IPRINT,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MSTR: INTEGER DATA EXPECTED(1).') + ELSEIF(TEXT4.EQ.'TYPE') THEN +* USER DEFINED TYPE FOR THE STRUCTURE + CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT) + IF(INDIC.NE.3) + 1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(2).') + CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR, + 1 ACSTR,TYSTR,NBDIR,DIRS,ROOT) + IF (NBDIR.NE.1) CALL XABORT('MSTR: INVALID TYPE ENTRY.') + CALL LCMPTC(IPSTR,'SIGNATURE',12,DIRS(1)) + ELSEIF((TEXT4.EQ.'PUT').OR. + 1 (TEXT4.EQ.'GET').OR. + 2 (TEXT4.EQ.'CP')) THEN +* PUT, GET OR CP ACTION + CALL REDGET(INDIC,NELEM,FLOTT,TEXT12,DFLOTT) +* NUMBER OF ELEMENTS + IF(INDIC.NE.1) CALL XABORT('MSTR: INTEGER DATA EXPECTED(2).') + IBEG=1 + IEND=NELEM + IINC=1 + CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT) + IF(INDIC.EQ.1) THEN +* STARTING INDEX + IBEG=NITMA + CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT) + IF(INDIC.EQ.1) THEN +* INCREMENT + IINC=NITMA + ELSE + GOTO 10 + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT) + ENDIF + 10 CONTINUE + IEND=IBEG+(NELEM-1)*IINC + IF (INDIC.NE.3) + 1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(3).') + IPSTRO=IPSTR + ACSTRO=ACSTR + TYSTRO=TYSTR +* ANALYSE USER'S PATH + CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR, + 1 ACSTR,TYSTR,NBDIR,DIRS,ROOT) +* GO TO REQUESTED DIRECTORY + IF (NBDIR.GT.1) THEN + CALL MSTMOV(IPSTR,ACSTR,IPRINT,NBDIR-1,DIRS,ROOT) + ENDIF + NAME=DIRS(NBDIR) + IF (TEXT4.EQ.'PUT') THEN +* CREATING OR UPDATING DATA IN A BLOCK + IF (ACSTR.EQ.2) + 1 CALL XABORT('MSTR: PUT NOT PERMITTED IN READ-ONLY MODE') + CALL LCMGET(IPSTR,'STATE-VECTOR',ISTATE) + NBLOCK=ISTATE(40) + ALLOCATE(BLNAM(NBLOCK+1),BLTYP(NBLOCK+1),BLLEN(NBLOCK+1)) + IF (NBLOCK.GT.0) THEN + CALL LCMGTC(IPSTR,'REC-NAMES',12,NBLOCK+1,BLNAM) + CALL LCMGET(IPSTR,'REC-TYPES',BLTYP) + CALL LCMGET(IPSTR,'REC-LENGTHS',BLLEN) + ENDIF + CALL MSTPUT(IPSTR,IPRINT,IBEG,IEND,IINC,NAME,NBLOCK,BLNAM, + 1 BLTYP,BLLEN) + DEALLOCATE(BLLEN,BLTYP,BLNAM) + ELSEIF(TEXT4.EQ.'GET') THEN +* RETRIEVING DATA FROM A BLOCK + CALL MSTGET(IPSTR,IPRINT,IBEG,IEND,IINC,NAME) + ELSEIF(TEXT4.EQ.'CP') THEN +* COPYING A BLOCK FROM ONE PLACE TO ANOTHER + CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT) + IF (INDIC.NE.3) + 1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(4).') +* ANALYSE USER'S PATH + CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR2, + 1 ACSTR2,TYSTR2,NBDIR,DIRS,ROOT) + IF (ACSTR2.EQ.2) + 1 CALL XABORT('MSTR: CP NOT PERMITTED IN READ-ONLY MODE') +* GO TO REQUESTED DIRECTORY + IF (NBDIR.GT.1) THEN + CALL MSTMOV(IPSTR2,ACSTR2,IPRINT,NBDIR-1,DIRS,ROOT) + ENDIF + NAME2=DIRS(NBDIR) + CALL LCMGET(IPSTR2,'STATE-VECTOR',ISTATE) + NBLOCK=ISTATE(40) + ALLOCATE(BLNAM(NBLOCK+1),BLTYP(NBLOCK+1),BLLEN(NBLOCK+1)) + IF (NBLOCK.GT.0) THEN + CALL LCMGTC(IPSTR2,'REC-NAMES',12,NBLOCK+1,BLNAM) + CALL LCMGET(IPSTR2,'REC-TYPES',BLTYP) + CALL LCMGET(IPSTR2,'REC-LENGTHS',BLLEN) + ENDIF + CALL MSTCPB(IPSTR,IPSTR2,IPRINT,IBEG,IEND,IINC,NAME,NAME2, + 1 NBLOCK,BLNAM,BLTYP,BLLEN) + DEALLOCATE(BLLEN,BLTYP,BLNAM) + ENDIF + IPSTR=IPSTRO + ACSTR=ACSTRO + TYSTR=TYSTRO + ELSEIF(TEXT4.EQ.'CD') THEN +* CHANGING DIRECTORY + CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT) + IF(INDIC.NE.3) + 1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(5).') +* ANALYSE USER'S PATH + CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR, + 1 ACSTR,TYSTR,NBDIR,DIRS,ROOT) +* GO TO REQUESTED DIRECTORY + CALL MSTMOV(IPSTR,ACSTR,IPRINT,NBDIR,DIRS,ROOT) + ELSEIF(TEXT4.EQ.';') THEN + GOTO 60 + ELSE + CALL XABORT('MSTR: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GOTO 50 +* + 60 CONTINUE +* + RETURN + END diff --git a/Ganlib/src/Makefile b/Ganlib/src/Makefile new file mode 100644 index 0000000..0a4ad6f --- /dev/null +++ b/Ganlib/src/Makefile @@ -0,0 +1,232 @@ +#--------------------------------------------------------------------------- +# +# Makefile for building the Ganlib library and load module +# Author : A. Hebert (2018-5-10) +# +#--------------------------------------------------------------------------- +# +ARCH = $(shell uname -m) +ifneq (,$(filter $(ARCH),aarch64 arm64)) + nbit = +else + ifneq (,$(filter $(ARCH),i386 i686)) + nbit = -m32 + else + nbit = -m64 + endif +endif + +DIRNAME = $(shell uname -sm | sed 's/[ ]/_/') +OS = $(shell uname -s | cut -d"_" -f1) +opt = -O -g +PREPRO = cpp +ifeq ($(openmp),1) + COMP = -fopenmp + PREPRO = cpp -DOPENMP +else + COMP = +endif + +ifeq ($(intel),1) + fcompiler = ifort + ccompiler = icc +else + ifeq ($(nvidia),1) + fcompiler = nvfortran + ccompiler = nvc + else + ifeq ($(llvm),1) + fcompiler = flang-new + ccompiler = clang + else + fcompiler = gfortran + ccompiler = gcc + endif + endif +endif + +ifeq ($(mpi),1) + FMPI = -DMPI + fcompiler = mpif90 + ccompiler = mpicc +else + FMPI = +endif + +ifeq ($(OS),AIX) + python_version_major := 2 +else + python_version_full := $(wordlist 2,4,$(subst ., ,$(shell python --version 2>&1))) + python_version_major := $(word 1,${python_version_full}) + ifneq ($(python_version_major),2) + python_version_major := 3 + endif +endif + +ifeq ($(OS),Darwin) + ifeq ($(openmp),1) + ccompiler = gcc-14 + endif + F90 = $(fcompiler) + C = $(ccompiler) + FLAGS = -DLinux -DUnix + CFLAGS = -Wall $(nbit) -fPIC + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC + LFLAGS = $(nbit) +else +ifeq ($(OS),Linux) + F90 = $(fcompiler) + C = $(ccompiler) + FLAGS = -DLinux -DUnix + CFLAGS = -Wall $(nbit) -fPIC + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC + LFLAGS = $(nbit) +else +ifeq ($(OS),CYGWIN) + F90 = $(fcompiler) + C = $(ccompiler) + FLAGS = -DLinux -DUnix + CFLAGS = -Wall $(nbit) -fPIC + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC + LFLAGS = $(nbit) +else +ifeq ($(OS),SunOS) + fcompiler = + F90 = f90 + C = cc + PREPRO = /usr/lib/cpp + FLAGS = -DSunOS -DUnix + CFLAGS = $(nbit) + FFLAGS = $(nbit) -s -ftrap=%none + FFLAG77 = $(nbit) -s -ftrap=%none + LFLAGS = $(nbit) +else +ifeq ($(OS),AIX) + fcompiler = + opt = -O4 + DIRNAME = AIX + F90 = xlf90 + C = cc + FLAGS = -DF90 -DAIX -DUnix + CFLAGS = -qstrict + FFLAGS = -qstrict -qmaxmem=-1 -qsuffix=f=f90 + FFLAG77 = -qstrict -qmaxmem=-1 -qxlf77=leadzero -qfixed + LFLAGS = -qstrict -bmaxdata:0x80000000 -qipa +else + $(error $(OS) is not a valid OS) +endif +endif +endif +endif +endif +ifeq ($(fcompiler),gfortran) + ifneq (,$(filter $(ARCH),i386 i686 x86_64)) + summary = + else + summary = -ffpe-summary=none + endif + ifeq ($(OS),Darwin) + summary = -ffpe-summary=none + endif + FFLAGS += -Wall -Wno-maybe-uninitialized $(summary) + FFLAG77 += -Wall -frecord-marker=4 $(summary) +endif + +ifeq ($(intel),1) + FFLAGS = -fPIC + FFLAG77 = -fPIC + lib = ../lib/$(DIRNAME)_intel + bin = ../bin/$(DIRNAME)_intel + lib_module = ../lib/$(DIRNAME)_intel/modules +else + ifeq ($(nvidia),1) + lib = ../lib/$(DIRNAME)_nvidia + bin = ../bin/$(DIRNAME)_nvidia + lib_module = ../lib/$(DIRNAME)_nvidia/modules + else + ifeq ($(llvm),1) + lib = ../lib/$(DIRNAME)_llvm + bin = ../bin/$(DIRNAME)_llvm + lib_module = ../lib/$(DIRNAME)_llvm/modules + FFLAGS += -mmlir -fdynamic-heap-array + LFLAGS += -lclang_rt.osx + else + lib = ../lib/$(DIRNAME) + bin = ../bin/$(DIRNAME) + lib_module = ../lib/$(DIRNAME)/modules + endif + endif +endif + +ifeq ($(hdf5),1) + FLAGS += -DHDF5_LIB -I${HDF5_INC} + FFLAGS += -I${HDF5_INC} + LFLAGS += -L${HDF5_API} -lhdf5 +endif + +SRCC = $(shell ls *.c) +SRC77 = $(shell ls *.f) +SRCF77 = $(shell ls *.F) +ifeq ($(python_version_major),2) + SRC90 = $(shell python ../../script/make_depend.py *.f90) +else + SRC90 = $(shell python3 ../../script/make_depend_py3.py *.f90) +endif +SRCF90 = $(shell ls *.F90) +OBJC = $(SRCC:.c=.o) +OBJ90 = $(SRC90:.f90=.o) +OBJF90 = $(SRCF90:.F90=.o) +OBJ77 = $(SRC77:.f=.o) +OBJF77 = $(SRCF77:.F=.o) +all : sub-make Ganlib +ifeq ($(mpi),1) + @echo 'Ganlib: mpi is defined' +endif +ifeq ($(openmp),1) + @echo 'Ganlib: openmp is defined' +endif +ifeq ($(intel),1) + @echo 'Ganlib: intel is defined' +endif +ifeq ($(nvidia),1) + @echo 'Ganlib: nvidia is defined' +endif +ifeq ($(llvm),1) + @echo 'Ganlib: llvm is defined' +endif +ifeq ($(hdf5),1) + @echo 'Ganlib: hdf5 is defined' +endif + @echo 'Ganlib: python version=' $(python_version_major) +sub-make: +%.o : %.c + $(C) $(CFLAGS) $(FLAGS) $(opt) $(COMP) -c $< -o $@ +%.o : %.f90 + $(F90) $(FFLAGS) $(opt) $(COMP) -c $< -o $@ +%.o : %.F90 + $(PREPRO) -P -W -traditional $(FLAGS) $< temp.f90 + $(F90) $(FFLAGS) $(opt) $(COMP) -c temp.f90 -o $@ + /bin/rm temp.f90 +%.o : %.f + @/bin/rm -f temp.f + $(F90) $(FFLAG77) $(opt) $(COMP) -c $< -o $@ +%.o : %.F + $(PREPRO) -P -W -traditional $(FLAGS) $(FMPI) $< temp.f + $(F90) $(FFLAG77) $(opt) $(COMP) -c temp.f -o $@ + /bin/rm temp.f +$(lib_module)/: + mkdir -p $(lib_module)/ +libGanlib.a: $(OBJC) $(OBJ90) $(OBJF90) $(OBJ77) $(OBJF77) $(lib_module)/ + ar r $@ $(OBJC) $(OBJ90) $(OBJF90) $(OBJ77) $(OBJF77) + cp $@ $(lib)/$@ + cp *.mod $(lib_module) +$(bin)/: + mkdir -p $(bin)/ +Ganlib: libGanlib.a GANMAIN.o $(bin)/ + $(F90) $(opt) $(COMP) GANMAIN.o $(lib)/libGanlib.a $(LFLAGS) -o Ganlib + cp $@ $(bin)/$@ +clean: + /bin/rm -f *.o *.mod *.a sub-make temp.* Ganlib* diff --git a/Ganlib/src/OPNMOD.f90 b/Ganlib/src/OPNMOD.f90 new file mode 100644 index 0000000..6c73a15 --- /dev/null +++ b/Ganlib/src/OPNMOD.f90 @@ -0,0 +1,263 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for fortran direct access in WIMS-AECL. Open, +! read or close indexed random file using fortran direct access files +! Subroutines: +! OPNIND: open file and read master index +! REDIND: read data on indexed file +! CLSIND: close file +! +!Copyright: +! Copyright (C) 2020 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): J. Donnelly +! +!Parameters: input/output +! IUNIT read unit +! INDEX index table (master index for OPNIND) +! LINDEX length of index table (LINDEX >=(# of entries) + 1) +! DATA data array to retreive from file +! NWORDS lenght of data array to retreive from file +! KEY location of data array in index +! +!Internal parameter description +! IOUT output unit = 6 +! NBLOCKS number of blocks per record = 256 +! IOFSET offset for index length = 65536 +! +!----------------------------------------------------------------------- +! +module OPNMOD + private + integer iunitr + public :: OPNIND, REDIND, CLSIND + interface REDIND + ! read data on indexed file + module procedure REDIND_I1, REDIND_R1 + end interface +contains + subroutine OPNIND(iunit,index,lindex) + parameter (iout=6,nblock=256,iofset=65536) + integer iunit,index(lindex),lindex + logical exst, opnd + character dirst*7 + !---- + ! unit number must be > zero + !---- + if(iunit.le.0) then + write(iout,6000) iunit + call XABORT('OPNIND: (readonly) illegal unit number') + endif + !---- + ! find out file status, and if unit already associated with + ! an open file + !---- + inquire(unit=iunit,exist=exst,opened=opnd,direct=dirst) + if(.not.opnd) then + !---- + ! file closed + !---- + write(iout,6010) iunit + call XABORT('OPNIND: (readonly) file not opened') + endif + if( exst .and. dirst .eq. 'no' ) then + !---- + ! file already exists, but is not direct access + !---- + write(iout,6020) iunit + call XABORT('OPNIND: (readonly) file is nor direct access') + endif + if(.not.exst) then + !---- + ! file does not exists + !---- + write(iout,6030) iunit + call XABORT('OPNIND: (readonly) file does not exists ') + endif + !---- + ! process the file master index + !---- + iunitr=iunit + irec = 1 + minw = 1 + 40 continue + maxw = min0( minw + nblock - 1 , lindex ) + ierr=0 + read(iunit,rec=irec,iostat=ierr) (index(i),i=minw,maxw) + if(ierr.ne.0) then + write(iout,6040) iunit,ierr + call XABORT('OPNIND: read master record error') + endif + irec = irec + 1 + if( maxw .ne. lindex ) then + minw = maxw + 1 + go to 40 + endif + return + !---- + ! format + !---- + 6000 format(' //// OPNIND: file, ',i5,' invalid') + 6010 format(' //// OPNIND: file, ',i5,' has not been opened with KDROPN') + 6020 format(' //// OPNIND: unit ',i5,' is not a direct access file') + 6030 format(' //// OPNIND: unit ',i5,' does not exists (readonly version)') + 6040 format(' //// OPNIND: error during reading of master index ', & + 'of unit ',i5,' status = ',i5) + end subroutine OPNIND + !---- + subroutine CLSIND(iunit) + parameter (iout=6) + integer iunit + if(iunitr.ne.iunit) then + write(iout,6100) iunit + call XABORT('CLSIND: file not opened by OPNIND') + endif + iunitr=kdrcls(iunit,1) + if(iunitr.ne.0) then + write(iout,6110) iunitr + call XABORT('CLSIND: error in file closing') + endif + return + !---- + ! format + !---- + 6100 format(' //// CLSIND: unit ',i5,' not found') + 6110 format(' //// CLSIND: error status =',i5,' from kdrcls') + end subroutine CLSIND + !---- + subroutine REDIND_I1(iunit,index,lindex,data,nwords,key) + parameter (iout=6,nblock=256,iofset=65536) + integer iunit,index(lindex),lindex,nwords,key + integer data(nwords) + ! + if(iunitr.ne.iunit) then + write(iout,6200) iunit + call XABORT('REDIND_I1: file not opened by OPNIND') + endif + !---- + ! validate key number + !---- + if(key.le.0.or.key.ge.lindex) then + write(iout,6210) iunit, key + call XABORT('REDIND_I1: invalid key') + endif + !---- + ! key number valid, validate record number + !---- + indr=index(key+1) + if(indr.eq.0) then + write(iout,6220) iunit, key + call XABORT('REDIND_I1: invalid record number for key') + endif + !---- + ! validate record length + !---- + lrecrd = (nwords-1)/nblock + 1 + loldrc = indr/iofset + if(loldrc.lt.lrecrd) then + write(iout,6230) iunit, key + call XABORT('REDIND_I1: invalid record length') + endif + !---- + ! record found, read the data + !---- + nrec = mod( indr, iofset ) + minw = 1 + 50 continue + maxw = min0( minw + nblock - 1 , nwords ) + ierr=0 + read(iunit,rec=nrec,iostat=ierr) (data(i),i=minw,maxw) + if(ierr.ne.0) then + write(iout,6240) iunit,ierr + call XABORT('REDIND_I1: read record error') + endif + nrec = nrec + 1 + if( maxw .ne. nwords ) then + minw = maxw + 1 + go to 50 + endif + return + !---- + ! format + !---- + 6200 format(' //// REDIND_I1: unit ',i5,' not found') + 6210 format(' //// REDIND_I1: invalid record number, unit ',i5,' key= ',i10) + 6220 format(' //// REDIND_I1: non-existant record, unit ',i5, & + ' record key =',i10) + 6230 format(' //// REDIND_I1: data count exceeds record, unit ',i5, & + ' record key =',i10) + 6240 format(' //// REDIND_I1: error during reading of record ', & + 'of unit ',i5,' status = ',i5) + end subroutine REDIND_I1 + !---- + subroutine REDIND_R1(iunit,index,lindex,data,nwords,key) + parameter (iout=6,nblock=256,iofset=65536) + integer iunit,index(lindex),lindex,nwords,key + real data(nwords) + ! + if(iunitr.ne.iunit) then + write(iout,6200) iunit + call XABORT('REDIND_R1: file not opened by OPNIND') + endif + !---- + ! validate key number + !---- + if(key.le.0.or.key.ge.lindex) then + write(iout,6210) iunit, key + call XABORT('REDIND_R1: invalid key') + endif + !---- + ! key number valid, validate record number + !---- + indr=index(key+1) + if(indr.eq.0) then + write(iout,6220) iunit, key + call XABORT('REDIND_R1: invalid record number for key') + endif + !---- + ! validate record length + !---- + lrecrd = (nwords-1)/nblock + 1 + loldrc = indr/iofset + if(loldrc.lt.lrecrd) then + write(iout,6230) iunit, key + call XABORT('REDIND_R1: invalid record length') + endif + !---- + ! record found, read the data + !---- + nrec = mod( indr, iofset ) + minw = 1 + 50 continue + maxw = min0( minw + nblock - 1 , nwords ) + ierr=0 + read(iunit,rec=nrec,iostat=ierr) (data(i),i=minw,maxw) + if(ierr.ne.0) then + write(iout,6240) iunit,ierr + call XABORT('REDIND_R1: read record error') + endif + nrec = nrec + 1 + if( maxw .ne. nwords ) then + minw = maxw + 1 + go to 50 + endif + return + !---- + ! format + !---- + 6200 format(' //// REDIND_R1: unit ',i5,' not found') + 6210 format(' //// REDIND_R1: invalid record number, unit ',i5,' key= ',i10) + 6220 format(' //// REDIND_R1: non-existant record, unit ',i5, & + ' record key =',i10) + 6230 format(' //// REDIND_R1: data count exceeds record, unit ',i5, & + ' record key =',i10) + 6240 format(' //// REDIND_R1: error during reading of record ', & + 'of unit ',i5,' status = ',i5) + end subroutine REDIND_R1 +end module OPNMOD diff --git a/Ganlib/src/REDGET.f90 b/Ganlib/src/REDGET.f90 new file mode 100644 index 0000000..19d2dea --- /dev/null +++ b/Ganlib/src/REDGET.f90 @@ -0,0 +1,149 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for CLE-2000. REDGET and REDPUT support +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +subroutine REDGET(ityp, nitma, flott, text, dflot) + ! read a value from input deck + use, intrinsic :: iso_c_binding + use LCMAUX + integer :: ityp, nitma + real :: flott + character(len=*) :: text + double precision :: dflot + character(kind=c_char), dimension(73) :: text_c + interface + subroutine redget_c (ityp, nitma, flott, text_c, dflot) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) :: ityp, nitma + real(c_float) :: flott + character(kind=c_char), dimension(*) :: text_c + real(c_double) :: dflot + end subroutine redget_c + end interface + call redget_c(ityp, nitma, flott, text_c, dflot) + if(ityp == 3) call STRFIL(text, text_c) +end subroutine REDGET +! +subroutine REDPUT(ityp, nitma, flott, text, dflot) + ! write a value into the input deck + use, intrinsic :: iso_c_binding + use LCMAUX + integer :: ityp, nitma + real :: flott + character(len=*) :: text + double precision :: dflot + character(kind=c_char), dimension(73) :: text_c + interface + subroutine redput_c (ityp, nitma, flott, text_c, dflot) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) :: ityp, nitma + real(c_float) :: flott + character(kind=c_char), dimension(*) :: text_c + real(c_double) :: dflot + end subroutine redput_c + end interface + if(ityp == 3) call STRCUT(text_c, text) + call redput_c(ityp, nitma, flott, text_c, dflot) +end subroutine REDPUT +! +subroutine REDOPN(iinp1, iout1, nrec) + ! read a value from input deck + use, intrinsic :: iso_c_binding + use LCMAUX + type(c_ptr) :: iinp1, file + integer :: iout1, nrec + character(len=72) :: filename + character(kind=c_char), dimension(73) :: filename_c + interface + subroutine redopn_c (iinp1, file, filename_c, nrec) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: iinp1, file + character(kind=c_char), dimension(*) :: filename_c + integer(c_int), value :: nrec + end subroutine redopn_c + end interface + interface + function fopen (filename_c, mode) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) fopen + character(kind=c_char), dimension(*) :: filename_c, mode + end function fopen + end interface + interface + function stdfil_c (s) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) stdfil_c + character(kind=c_char) :: s + end function stdfil_c + end interface + if(iout1 == 0) then + file=c_null_ptr + filename_c=c_null_char + else if(iout1 == 6) then + file=stdfil_c("stdout"//c_null_char) + filename_c=c_null_char + else + inquire(iout1,name=filename) + close(iout1,status='keep') + call STRCUT(filename_c, filename) + file=fopen(filename_c, "w"//c_null_char) + if(.not.c_associated(file)) call XABORT('REDOPN: UNABLE TO OPEN FILE '//filename(:44)) + endif + call redopn_c(iinp1, file, filename_c, nrec) +end subroutine REDOPN +! +subroutine REDCLS(iinp1, iout1, nrec) + ! read a value from input deck + use, intrinsic :: iso_c_binding + use LCMAUX + type(c_ptr) :: iinp1, file + integer :: iout1, nrec, ier + character(len=72) :: filename + character(kind=c_char), dimension(73) :: filename_c + interface + subroutine redcls_c (iinp1, file, filename_c, nrec) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iinp1, file + character(kind=c_char), dimension(*) :: filename_c + integer(c_int) :: nrec + end subroutine redcls_c + end interface + interface + function fclose (file) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) fclose + type(c_ptr), value :: file + end function fclose + end interface + interface + function stdfil_c (s) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) stdfil_c + character(kind=c_char) :: s + end function stdfil_c + end interface + call redcls_c(iinp1, file, filename_c, nrec) + if(c_associated(file,c_null_ptr)) then + iout1=0 + else if(c_associated(file,stdfil_c("stdout"//c_null_char))) then + iout1=6 + else + call STRFIL(filename, filename_c) + ier=fclose(file) + if(ier /= 0) call XABORT('REDOPN: UNABLE TO CLOSE FILE '//filename(:44)) + iout1=KDROPN(filename,1,3,0) + endif +end subroutine REDCLS diff --git a/Ganlib/src/SNDMPI.F b/Ganlib/src/SNDMPI.F new file mode 100644 index 0000000..0023cfc --- /dev/null +++ b/Ganlib/src/SNDMPI.F @@ -0,0 +1,616 @@ +#if defined(MPI) +*DECK SNDMPI + SUBROUTINE SNDMPI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +* EXPORT THE CONTENT OF A LCM OBJECT USING MPI +* +* INPUT/OUTPUT PARAMETERS: +* NENTRY : NUMBER OF LCM OBJECTS AND FILES USED BY THE MODULE. +* HENTRY : CHARACTER*12 NAME OF EACH LCM OBJECT. +* IENTRY : =0 CLE-2000 VARIABLE; =1 LINKED LIST; =2 XSM FILE; +* =3 SEQUENTIAL BINARY FILE; =4 SEQUENTIAL ASCII FILE; +* =5 DIRECT ACCESS FILE. +* JENTRY : =0 THE LINKED LIST OR FILE IS CREATED. +* =1 THE LINKED LIST OR FILE IS OPEN FOR MODIFICATIONS; +* =2 THE LINKED LIST OR FILE IS OPEN IN READ-ONLY MODE. +* KENTRY : =FILE UNIT NUMBER; =LCM OBJECT ADDRESS OTHERWISE. +* DIMENSION HENTRY(NENTRY),IENTRY(NENTRY),JENTRY(NENTRY), +* KENTRY(NENTRY) +* +* LCM OBJECTS: +* HENTRY(1) : ANY CREATE LCM OBJECT +* HENTRY(2) : ANY READ-ONLY LCM OBJECT +* +*----------------------------------- AUTHOR: R. CHAMBON ; 01/05/2003 --- +* + USE GANLIB + include 'mpif.h' +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXLEV=50) + PARAMETER (IHEAD=0,IHNAM=1,ILLIST=4,INEXT=5,IFATH=6,IFDIR=7, + 1 IMODE=8,INREF=10,LFNODE=12) + PARAMETER (JDATA=0,JJLON=1,JJTYP=2,JCMT=7) + PARAMETER (IPRT=1) + TYPE(C_PTR) IPLIS1,IPLIS2 + CHARACTER NAMT*12,HSMG*131,NAMLCM*12,MYNAME*12,PATH(MAXLEV)*12, + 1 FIRST(MAXLEV)*12 + LOGICAL EMPTY,LCM + TYPE(C_PTR) KDATA1(MAXLEV),KDATA2(MAXLEV) + INTEGER KJLON(MAXLEV),IVEC(MAXLEV),IGO(MAXLEV) + INTEGER*4 IPRINT,RANK,SIZE,IERR,ICOMM,ITAG + INTEGER*4 ICPUFM,ICPUTO + LOGICAL LALL,LCPUFM,LCPUTO,LITEM + INTEGER ILONG,ITYLCM + CHARACTER TEXT12*12 + CHARACTER HMSG*131 + DOUBLE PRECISION DFLOTT,DFLOTTT,DFLOTTF +*---- +* ALLOCATABLE STATEMENTS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISTATU,IASS + +#if defined(__x86_64__) +# define M64 2 +#else +# define M64 1 +#endif + +*---- +* VALIDITY OF OBJECTS +*---- + IF( NENTRY.EQ.2 )THEN +* CALL XABORT('SENDP: 2 OBJECTS EXPECTED.') +* CHECK LL# 1 = ANY OBJECT (LINKED_LIST OR XSM_FILE) IS READ ONLY + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('SNDMPI: LINKED LIST OR XSM FILE IN READ-ONLY' + 2 //' MODE EXPECTED AT RHS:'//HENTRY(2)) + IPLIS1= KENTRY(2) +* CHECK LL# 2 = ANY OBJECT (LINKED_LIST OR XSM_FILE) IS CREATED + IF((JENTRY(1).NE.0).OR.((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2))) + 1 CALL XABORT('SNDMPI: LINKED LIST OR XSM FILE IN CREATED' + 2 //' MODE EXPECTED AT LHS:'//HENTRY(1)) + IPLIS2= KENTRY(1) + ENDIF +*---- +* VARIABLE INITIALISATION +*---- + IPRINT= 0 + ICPUFM= -1 + ICPUTO= -1 + ICOMM= MPI_COMM_WORLD + ALLOCATE(ISTATU(MPI_STATUS_SIZE)) + ITAG=1 + LALL=.FALSE. + LITEM=.FALSE. + CALL MPI_COMM_RANK(ICOMM,RANK,IERR) + CALL MPI_COMM_SIZE(ICOMM,SIZE,IERR) + CALL MPI_TYPE_CONTIGUOUS(12,MPI_CHARACTER,MPI_DIRNAME,IERR) + CALL MPI_TYPE_COMMIT(MPI_DIRNAME,IERR) + CALL MPI_TYPE_CONTIGUOUS(4,MPI_CHARACTER,MPI_CHAR4,IERR) + CALL MPI_TYPE_COMMIT(MPI_CHAR4,IERR) + LCPUFM=.FALSE. + LCPUTO=.FALSE. +*---- +* READ USER INPUT: +*---- + 2 CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) +* EDITION LEVEL + IF(TEXT12.EQ.'EDIT') THEN + CALL REDGET(ITYP,IPRINT,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('SNDMPI: *IPRINT* MUST BE INTEGER') +* CPU FROM + ELSEIF(TEXT12.EQ.'FROM')THEN + CALL REDGET(ITYP,ICPUFM,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('SNDMPI: *ICPUFM* MUST BE' + 1 //'INTEGER AFTER FROM') + IF((ICPUFM.LT.0).OR.(ICPUFM.GE.SIZE)) THEN + WRITE(HMSG,2000) ICPUFM,SIZE-1 + CALL XABORT(HMSG) + ENDIF + LCPUFM=(ICPUFM.EQ.RANK) +* CPU TO + ELSEIF(TEXT12.EQ.'TO')THEN + CALL REDGET(ITYP,ICPUTO,FLOTT,TEXT12,DFLOTT) + IF((ITYP.NE.1).AND.(TEXT12.NE.'ALL')) CALL XABORT('SNDMPI:' + 1 //'*ICPUTO* MUST BE INTEGER OR THE KEYWORD: ALL') + IF(((ICPUTO.LT.0).OR.(ICPUTO.GE.SIZE)).AND.(TEXT12.NE.'ALL')) + 1 THEN + WRITE(HMSG,2010) ICPUTO,SIZE-1 + CALL XABORT(HMSG) + ENDIF + IF(TEXT12.EQ.'ALL')THEN + LALL=.TRUE. + ELSE + LCPUTO=(ICPUTO.EQ.RANK) + ENDIF +* ITEM + ELSEIF(TEXT12.EQ.'ITEM')THEN + LITEM=.TRUE. + CALL REDGET(ITYPF,NITMAF,FLOTTF,TEXT12,DFLOTTF) + CALL REDGET(ITYPT,NITMAT,FLOTTT,TEXT12,DFLOTTT) + IF((ITYPF.NE.1.AND.ITYPF.NE.2.AND.ITYPF.NE.4.AND.ITYPF.NE.5) + 1 .OR.(ITYPF.NE.-ITYPT))THEN + CALL XABORT('SNDMPI: INVALID TYPE FOR ITEM "FROM" OR "TO"') + ENDIF +* END OF THIS SUBROUTINE + ELSEIF( TEXT12.EQ.';' )THEN + IF((ICPUFM.LT.0).OR.(ICPUTO.LT.0)) CALL XABORT('SNDMPI: ' + 1 //'*FROM* OR *TO* KEYWORD IS MISSING') + IF(LITEM.AND.(LALL.OR.LCPUFM.OR.LCPUTO)) GOTO 191 + ILEV=1 + KDATA1(1)=IPLIS1 + KDATA2(1)=IPLIS2 + KJLON(1)=-1 + IVEC(1)=1 + IGO(1)=5 + IF(LALL)THEN + GOTO 120 + ELSEIF(LCPUFM.OR.LCPUTO)THEN + GOTO 20 + ELSE + GOTO 200 + ENDIF + ELSE + CALL XABORT('SNDMPI: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 2 +*---- +* READING ON A CPU AND WRITING ON ANOTHER ONE +*---- +* USE A GENERAL COPY ALGORITHM. +* +* ASSOCIATIVE TABLE. + 20 IF(LCPUFM) THEN + CALL LCMINF(IPLIS1,NAMLCM,MYNAME,EMPTY,ILONG,LCM) + CALL MPI_SEND(EMPTY,1*M64,MPI_LOGICAL,ICPUTO, + 1 ITAG,ICOMM,IERR) + CALL MPI_SEND(ILONG,1*M64,MPI_INTEGER,ICPUTO, + 1 ITAG,ICOMM,IERR) + ENDIF + IF(LCPUTO) THEN + CALL MPI_RECV(EMPTY,1*M64,MPI_LOGICAL,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + CALL MPI_RECV(ILONG,1*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + ENDIF + IF(EMPTY) GO TO ( 60, 60, 90, 90,200),IGO(ILEV) + NAMT=' ' + IF(LCPUFM) THEN + CALL LCMNXT(IPLIS1,NAMT) + CALL MPI_SEND(NAMT,1,MPI_DIRNAME,ICPUTO,ITAG,ICOMM,IERR) + ENDIF + IF(LCPUTO) THEN + CALL MPI_RECV(NAMT,1,MPI_DIRNAME,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + ENDIF +* + FIRST(ILEV)=NAMT + 30 IF(LCPUFM) THEN + CALL LCMLEN(IPLIS1,NAMT,ILONG,ITYLCM) + CALL MPI_SEND(ILONG,1*M64,MPI_INTEGER,ICPUTO, + 1 ITAG,ICOMM,IERR) + CALL MPI_SEND(ITYLCM,1*M64,MPI_INTEGER,ICPUTO, + 1 ITAG,ICOMM,IERR) + ENDIF + IF(LCPUTO) THEN + CALL MPI_RECV(ILONG,1*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + CALL MPI_RECV(ITYLCM,1*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + ENDIF + IF((ILONG.NE.0).AND.(ITYLCM.EQ.0)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,2020) NAMLCM,1 + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + IF(LCPUFM) THEN + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + ENDIF + IF(LCPUTO) THEN + KDATA2(ILEV)=LCMDID(IPLIS2,NAMT) + ENDIF + PATH(ILEV)=NAMT + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IF(LCPUTO) THEN + IPLIS2=KDATA2(ILEV) + ENDIF + IVEC(ILEV)=1 + IGO(ILEV)=1 + GO TO 20 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.EQ.10)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,2020) NAMLCM,2 + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + IF(LCPUFM) THEN + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + ENDIF + IF(LCPUTO) THEN + KDATA2(ILEV)=LCMLID(IPLIS2,NAMT,ILONG) + ENDIF + PATH(ILEV)=NAMT + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IF(LCPUTO) THEN + IPLIS2=KDATA2(ILEV) + ENDIF + IVEC(ILEV)=0 + IGO(ILEV)=2 + GO TO 70 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.LE.6)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* DATA + ALLOCATE(IASS(ILONG)) + IF(LCPUFM) THEN + CALL LCMGET(IPLIS1,NAMT,IASS) + CALL MPI_SEND(IASS,ILONG*M64,MPI_INTEGER,ICPUTO, + 1 ITAG,ICOMM,IERR) + ENDIF + IF(LCPUTO) THEN + CALL MPI_RECV(IASS,ILONG*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + CALL LCMPUT(IPLIS2,NAMT,ILONG,ITYLCM,IASS) + DEALLOCATE(IASS) + ENDIF + IF(LCPUFM) DEALLOCATE(IASS) + ENDIF + IF(LCPUFM) THEN + CALL LCMNXT(IPLIS1,NAMT) + CALL MPI_SEND(NAMT,1,MPI_DIRNAME,ICPUTO,ITAG,ICOMM,IERR) + ENDIF + IF(LCPUTO) THEN + CALL MPI_RECV(NAMT,1,MPI_DIRNAME,ICPUFM,ITAG,ICOMM,ISTATU,IERR) + ENDIF + IF(NAMT.NE.FIRST(ILEV)) GO TO 30 + GO TO ( 60, 60, 90, 90,200),IGO(ILEV) +* + 60 NAMT=PATH(ILEV) + ILEV=ILEV-1 + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IF(LCPUTO) THEN + IPLIS2=KDATA2(ILEV) + ENDIF + IF(LCPUFM) THEN + CALL LCMNXT(IPLIS1,NAMT) + CALL MPI_SEND(NAMT,1,MPI_DIRNAME,ICPUTO,ITAG,ICOMM,IERR) + ENDIF + IF(LCPUTO) THEN + CALL MPI_RECV(NAMT,1,MPI_DIRNAME,ICPUFM,ITAG,ICOMM,ISTATU,IERR) + ENDIF + IF(NAMT.NE.FIRST(ILEV)) GO TO 30 + GO TO ( 60, 60, 90, 90,200),IGO(ILEV) +* +* LIST. + 70 IVEC(ILEV)=IVEC(ILEV)+1 + IF(IVEC(ILEV).GT.KJLON(ILEV)) THEN + GO TO ( 60, 60, 90, 90,200),IGO(ILEV) + ENDIF + IF(LCPUFM) THEN + CALL LCMLEL(KDATA1(ILEV),IVEC(ILEV),ILONG,ITYLCM) + CALL MPI_SEND(ILONG,1*M64,MPI_INTEGER,ICPUTO,ITAG,ICOMM,IERR) + CALL MPI_SEND(ITYLCM,1*M64,MPI_INTEGER,ICPUTO,ITAG,ICOMM,IERR) + ENDIF + IF(LCPUTO) THEN + CALL MPI_RECV(ILONG,1*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + CALL MPI_RECV(ITYLCM,1*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + ENDIF + IF((ILONG.NE.0).AND.(ITYLCM.EQ.0)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,2020) NAMLCM,3 + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + IF(LCPUFM) THEN + KDATA1(ILEV)=LCMGIL(IPLIS1,IVEC(ILEV-1)) + ENDIF + IF(LCPUTO) THEN + KDATA2(ILEV)=LCMDIL(IPLIS2,IVEC(ILEV-1)) + ENDIF + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IF(LCPUTO) THEN + IPLIS2=KDATA2(ILEV) + ENDIF + IVEC(ILEV)=1 + IGO(ILEV)=3 + GO TO 20 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.EQ.10)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,2020) NAMLCM,4 + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + IF(LCPUFM) THEN + KDATA1(ILEV)=LCMGIL(IPLIS1,IVEC(ILEV-1)) + ENDIF + IF(LCPUTO) THEN + KDATA2(ILEV)=LCMLIL(IPLIS2,IVEC(ILEV-1),ILONG) + ENDIF + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IF(LCPUTO) THEN + IPLIS2=KDATA2(ILEV) + ENDIF + IVEC(ILEV)=0 + IGO(ILEV)=4 + GO TO 70 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.LE.6)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* DATA + ALLOCATE(IASS(ILONG)) + IF(LCPUFM) THEN + CALL LCMGDL(IPLIS1,IVEC(ILEV),IASS) + CALL MPI_SEND(IASS,ILONG*M64,MPI_INTEGER,ICPUTO, + 1 ITAG,ICOMM,IERR) + ENDIF + IF(LCPUTO) THEN + CALL MPI_RECV(IASS,ILONG*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + CALL LCMPDL(IPLIS2,IVEC(ILEV),ILONG,ITYLCM,IASS) + DEALLOCATE(IASS) + ENDIF + IF(LCPUFM) DEALLOCATE(IASS) + ENDIF + GO TO 70 +* + 90 ILEV=ILEV-1 + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IF(LCPUTO) THEN + IPLIS2=KDATA2(ILEV) + ENDIF + GO TO 70 +*---- +* READING ON A CPU AND WRITING ON ALL OTHER +*---- +* USE A GENERAL COPY ALGORITHM. +* +* ASSOCIATIVE TABLE. + 120 IF(LCPUFM) THEN + CALL LCMINF(IPLIS1,NAMLCM,MYNAME,EMPTY,ILONG,LCM) + ENDIF + CALL MPI_BCAST(EMPTY,1*M64,MPI_LOGICAL,ICPUFM,ICOMM,IERR) + CALL MPI_BCAST(ILONG,1*M64,MPI_INTEGER,ICPUFM,ICOMM,IERR) + IF(EMPTY) GO TO (160,160,190,190,200),IGO(ILEV) + NAMT=' ' + IF(LCPUFM) THEN + CALL LCMNXT(IPLIS1,NAMT) + ENDIF + CALL MPI_BCAST(NAMT,1,MPI_DIRNAME,ICPUFM,ICOMM,IERR) +* + FIRST(ILEV)=NAMT + 130 IF(LCPUFM) THEN + CALL LCMLEN(IPLIS1,NAMT,ILONG,ITYLCM) + ENDIF + CALL MPI_BCAST(ILONG,1*M64,MPI_INTEGER,ICPUFM,ICOMM,IERR) + CALL MPI_BCAST(ITYLCM,1*M64,MPI_INTEGER,ICPUFM,ICOMM,IERR) + IF((ILONG.NE.0).AND.(ITYLCM.EQ.0)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,2020) NAMLCM,5 + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + IF(LCPUFM) THEN + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + ENDIF + KDATA2(ILEV)=LCMDID(IPLIS2,NAMT) + PATH(ILEV)=NAMT + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=1 + GO TO 120 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.EQ.10)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,2020) NAMLCM,6 + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + IF(LCPUFM) THEN + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + ENDIF + KDATA2(ILEV)=LCMLID(IPLIS2,NAMT,ILONG) + PATH(ILEV)=NAMT + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=2 + GO TO 170 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.LE.6)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* DATA + ALLOCATE(IASS(ILONG)) + IF(LCPUFM) THEN + CALL LCMGET(IPLIS1,NAMT,IASS) + ENDIF + CALL MPI_BCAST(IASS,ILONG*M64,MPI_INTEGER,ICPUFM, + 1 ICOMM,IERR) + CALL LCMPUT(IPLIS2,NAMT,ILONG,ITYLCM,IASS) + DEALLOCATE(IASS) + ENDIF + IF(LCPUFM) THEN + CALL LCMNXT(IPLIS1,NAMT) + ENDIF + CALL MPI_BCAST(NAMT,1,MPI_DIRNAME,ICPUFM,ICOMM,IERR) + IF(NAMT.NE.FIRST(ILEV)) GO TO 130 + GO TO (160,160,190,190,200),IGO(ILEV) +* + 160 NAMT=PATH(ILEV) + ILEV=ILEV-1 + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IPLIS2=KDATA2(ILEV) + IF(LCPUFM) THEN + CALL LCMNXT(IPLIS1,NAMT) + ENDIF + CALL MPI_BCAST(NAMT,1,MPI_DIRNAME,ICPUFM,ICOMM,IERR) + IF(NAMT.NE.FIRST(ILEV)) GO TO 130 + GO TO (160,160,190,190,200),IGO(ILEV) +* +* LIST. + 170 IVEC(ILEV)=IVEC(ILEV)+1 + IF(IVEC(ILEV).GT.KJLON(ILEV)) THEN + GO TO (160,160,190,190,200),IGO(ILEV) + ENDIF + IF(LCPUFM) THEN + CALL LCMLEL(KDATA1(ILEV),IVEC(ILEV),ILONG,ITYLCM) + ENDIF + CALL MPI_BCAST(ILONG,1*M64,MPI_INTEGER,ICPUFM,ICOMM,IERR) + CALL MPI_BCAST(ITYLCM,1*M64,MPI_INTEGER,ICPUFM,ICOMM,IERR) + IF((ILONG.NE.0).AND.(ITYLCM.EQ.0)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,2020) NAMLCM,7 + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=-1 + IF(LCPUFM) THEN + KDATA1(ILEV)=LCMGIL(IPLIS1,IVEC(ILEV-1)) + ENDIF + KDATA2(ILEV)=LCMDIL(IPLIS2,IVEC(ILEV-1)) + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=1 + IGO(ILEV)=3 + GO TO 120 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.EQ.10)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* LIST DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,2020) NAMLCM,8 + CALL XABORT(HSMG) + ENDIF + KJLON(ILEV)=ILONG + IF(LCPUFM) THEN + KDATA1(ILEV)=LCMGIL(IPLIS1,IVEC(ILEV-1)) + ENDIF + KDATA2(ILEV)=LCMLIL(IPLIS2,IVEC(ILEV-1),ILONG) + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IPLIS2=KDATA2(ILEV) + IVEC(ILEV)=0 + IGO(ILEV)=4 + GO TO 170 + ELSE IF((ILONG.NE.0).AND.(ITYLCM.LE.6)) THEN + IF(IPRT.GT.0) WRITE(6,1010) ILEV,NAMT,ITYLCM,ILONG +* DATA + ALLOCATE(IASS(ILONG)) + IF(LCPUFM) THEN + CALL LCMGDL(IPLIS1,IVEC(ILEV),IASS) + ENDIF + CALL MPI_BCAST(IASS,ILONG*M64,MPI_INTEGER,ICPUFM, + 1 ICOMM,IERR) + CALL LCMPDL(IPLIS2,IVEC(ILEV),ILONG,ITYLCM,IASS) + DEALLOCATE(IASS) + ENDIF + GO TO 170 +* + 190 ILEV=ILEV-1 + IF(LCPUFM) THEN + IPLIS1=KDATA1(ILEV) + ENDIF + IPLIS2=KDATA2(ILEV) + GO TO 170 +*---- +* SENDING ITEM +*---- + 191 IF(LALL)THEN + IF(ITYPF.EQ.1.OR.ITYPF.EQ.5)THEN + CALL MPI_BCAST(NITMAF,1*M64,MPI_INTEGER,ICPUFM,ICOMM,IERR) + ELSEIF(ITYPF.EQ.2)THEN + CALL MPI_BCAST(FLOTTF,1*M64,MPI_INTEGER,ICPUFM,ICOMM,IERR) + ELSEIF(ITYPF.EQ.4)THEN + CALL MPI_BCAST(DFLOTTF,2*M64,MPI_INTEGER,ICPUFM,ICOMM,IERR) + ENDIF + GO TO 199 + ENDIF + IF(LCPUFM) THEN + IF(ITYPF.EQ.1.OR.ITYPF.EQ.5)THEN + CALL MPI_SEND(NITMAF,1*M64,MPI_INTEGER,ICPUTO, + 1 ITAG,ICOMM,IERR) + ELSEIF(ITYPF.EQ.2)THEN + CALL MPI_SEND(FLOTTF,1*M64,MPI_INTEGER,ICPUTO, + 1 ITAG,ICOMM,IERR) + ELSEIF(ITYPF.EQ.4)THEN + CALL MPI_SEND(DFLOTTF,2*M64,MPI_INTEGER,ICPUTO, + 1 ITAG,ICOMM,IERR) + ENDIF + ENDIF + IF(LCPUTO) THEN + IF(ITYPF.EQ.1.OR.ITYPF.EQ.5)THEN + CALL MPI_RECV(NITMAF,1*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + ELSEIF(ITYPF.EQ.2)THEN + CALL MPI_RECV(FLOTTF,1*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + ELSEIF(ITYPF.EQ.4)THEN + CALL MPI_RECV(DFLOTTF,2*M64,MPI_INTEGER,ICPUFM, + 1 ITAG,ICOMM,ISTATU,IERR) + ENDIF + ENDIF + 199 CALL REDPUT(ITYPF,NITMAF,FLOTTF,TEXT12,DFLOTTF) + + 200 RETURN + STOP +*---- +* FORMAT +*---- + 1010 FORMAT (1X,I5,3H ',A12,1H',2I8) + 2000 FORMAT(38HSNDMPI: PROCESSOR NUMBER *FROM* SET TO,I4, + 1 30HINSTEAD OF BEING BETWEEN 0 AND,I4) + 2010 FORMAT(36HSNDMPI: PROCESSOR NUMBER *TO* SET TO,I4, + 1 30HINSTEAD OF BEING BETWEEN 0 AND,I4) + 2020 FORMAT(37HSNDMPI: TOO MANY DIRECTORY LEVELS ON ,A,2H (,I1,2H).) + END +#endif /* defined(MPI) */ diff --git a/Ganlib/src/XABORT.f90 b/Ganlib/src/XABORT.f90 new file mode 100644 index 0000000..7b83ca9 --- /dev/null +++ b/Ganlib/src/XABORT.f90 @@ -0,0 +1,33 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for XABORT. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +subroutine XABORT(msg) + ! abort execution + use, intrinsic :: iso_c_binding + use LCMAUX + character(len=*) :: msg + character(kind=c_char), dimension(73) :: msg_c + interface + subroutine xabort_c (msg) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: msg + end subroutine xabort_c + end interface + flush(6) + call STRCUT(msg_c, msg) + call xabort_c(msg_c) +end subroutine XABORT diff --git a/Ganlib/src/XDREED.f90 b/Ganlib/src/XDREED.f90 new file mode 100644 index 0000000..e804042 --- /dev/null +++ b/Ganlib/src/XDREED.f90 @@ -0,0 +1,85 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Read or write CCCC format records. +! XDREED: transfer data from CCCC file to array. +! XDRITE: transfer data from array to CCCC file. +! XDRCLS: close file and release unit number. +! +!Copyright: +! Copyright (C) 1991 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): G. Marleau +! +!Parameters: input +! iucccc file unit +! numrec record number to read +! nwds number of words to read +! +!Parameters: input/output +! array location in central memory where information is to be stored +! +!Reference: +! R. D. O'Dell, 'Standard interface files and procedures for +! reactor physics codes, Version IV', Los Alamos National +! Laboratory Report LA-6941-MS (Sept. 1977). +! +!----------------------------------------------------------------------- +! +module XDRMOD + private + integer, parameter :: nbunit=99 + integer, save, dimension(nbunit) :: ipunit(1:nbunit)=0 + public :: XDREED, XDRITE, XDRCLS +contains + subroutine XDREED(iucccc,numrec,array,nwds) + integer, intent(in) :: iucccc,numrec,nwds + real, intent(out) :: array(nwds) + ! + if (numrec.eq.0) then + call XABORT('XDREED: record number 0 cannot be read '// & + 'from cccc file') + endif + if (nwds.eq.0) return + if (numrec.eq.1) then + rewind iucccc + else + nskip=numrec-ipunit(iucccc)-1 + if (nskip.gt.0) then + do i=1,nskip + read(iucccc) dum + enddo + else if (nskip.lt.0) then + do i=1,-nskip + backspace iucccc + enddo + endif + endif + read(iucccc) (array(jj),jj=1,nwds) + ipunit(iucccc)=numrec + end subroutine XDREED + ! + subroutine XDRITE(iucccc,numrec,array,nwds) + integer, intent(in) :: iucccc,numrec,nwds + real, intent(in) :: array(nwds) + ! + if (numrec.eq.0) then + call XABORT('XDRITE: record number 0 cannot be written '// & + 'on cccc file') + endif + if (nwds.eq.0) return + if (numrec.eq.1) rewind iucccc + write(iucccc) (array(jj),jj=1,nwds) + end subroutine XDRITE + ! + subroutine XDRCLS(iucccc) + integer, intent(in) :: iucccc + ! + ipunit(iucccc)=0 + end subroutine XDRCLS +end module XDRMOD diff --git a/Ganlib/src/cle2000.h b/Ganlib/src/cle2000.h new file mode 100644 index 0000000..6dc2948 --- /dev/null +++ b/Ganlib/src/cle2000.h @@ -0,0 +1,98 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. HEBERT ; 31/07/10 */ +/*****************************************/ + +/* +Copyright (C) 2010 Ecole Polytechnique de Montreal + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. +*/ + +#include "lcm.h" +#if defined(HDF5_LIB) +#include "hdf5.h" +#endif +#define nmaskc 5 /* size of maskck and ipacki */ +#define kdisize(object) (sizeof(object)+sizeof(int_32)-1)/sizeof(int_32) +#if !defined(max) +#define max(A,B) ((A) > (B) ? (A) : (B)) +#define min(A,B) ((A) < (B) ? (A) : (B)) +#endif +#define lrclen max(kdisize(record1),kdisize(record2)) /* max kdisize of record1 and record2 */ + +typedef struct LIFO { /* last-in-first-out (lifo) stack */ + int_32 nup; /* number of nodes in stack */ + struct LIFO_NODE *root; /* address of the first node in stack */ + struct LIFO_NODE *node; /* address of the last node in stack */ +} lifo ; + +typedef struct LIFO_NODE { /* node in last-in-first-out (lifo) stack */ + int_32 type; /* type of node: 3= lcm object; 4= xsm file; 5= seq binary; + 6= seq ascii; 7= da binary; 8= hdf5 file; 11= integer value; + 12= real value; 13= character string; 14= double precision value; + 15= logical value */ + int_32 access; /* 0=creation mode/1=modification mode/2=read-only mode */ + int_32 lparam; /* record length for DA file objects */ + union { + int_32 ival; /* integer or logical value */ + float_32 fval; /* real value */ + double dval; /* double precision value */ + lcm *mylcm; /* handle towards a LCM object */ + char hval[73]; /* character value */ +#if defined(HDF5_LIB) + hid_t myhdf5; /* handle towards a HDF5 file */ +#endif + } value; + struct LIFO_NODE *daughter; /* address of the daughter node in stack */ + char name[13]; /* name of node in the calling script */ + char name_daughter[13]; /* name of node in the daughter script */ + char OSname[73]; /* physical filename */ +} lifo_node ; + +void cletim_c(double *); +void cleopn(lifo **); +lifo_node * clepop(lifo **); +void clepush(lifo **, lifo_node *); +int_32 clecls(lifo **); +lifo_node * clenode(lifo **, const char *); +lifo_node * clepos(lifo **, int_32); +void clelib(lifo **); + +void redopn_c(kdi_file *, FILE *, char *, int_32); +void redcls_c(kdi_file **, FILE **, char [73], int_32 *); +void redget_c(int_32 *, int_32 *, float_32 *, char [73], double *); +void redput_c(int_32 *, int_32 *, float_32 *, char *, double *); + +int_32 cle2000_c(int_32, + int_32 (*)(char *, int_32, char (*)[13], int_32 *, int_32 *, lcm **, char (*)[73]), + char *, int_32, lifo *); +int_32 clemod_c(char *, FILE *, int_32, char (*)[13], int_32 *, int_32 *, lcm **, char (*)[73], + int_32 (*)(char *, int_32, char (*)[13], int_32 *, int_32 *, lcm **, char (*)[73])); +int_32 kdrcln(lifo *, int_32); + +void drviox(lifo *, int_32, int_32 *); +int_32 objpil(kdi_file *, FILE *, int_32); +int_32 objstk(kdi_file *, FILE *, int_32); +int_32 objxrf(kdi_file *, FILE *); +int_32 clepil(FILE *, FILE *, kdi_file *, int_32 (*clecst)(char *, int_32 *, int_32 *, float_32 *, char *, double *)); +int_32 clecst(char *, int_32 *, int_32 *, float_32 *, char *, double *); +int_32 clecop(kdi_file *, kdi_file *); +int_32 clexrf(kdi_file *, FILE *); +int_32 clestk(kdi_file *, FILE *,int_32 (*)(char *, int_32 *, int_32 *, float_32 *, char *, double *)); +int_32 clelog(FILE *, FILE *, kdi_file *); + +int_32 kdrdpr(lifo **, int_32, char (*)[13]); +int_32 kdrprm(lifo **, lifo **, int_32 minput, int_32, int_32 *, char (*)[13]); +int_32 kdrdmd(lifo **, int_32, char (*)[13]); +int_32 kdrdll(lifo **, int_32, char (*)[13]); +int_32 kdrdxf(lifo **, int_32, char (*)[13]); +int_32 kdrdsb(lifo **, int_32, char (*)[13]); +int_32 kdrdsa(lifo **, int_32, char (*)[13]); +int_32 kdrdda(lifo **, int_32, char (*)[13]); +int_32 kdrdh5(lifo **, int_32, char (*)[13]); diff --git a/Ganlib/src/cle2000_c.c b/Ganlib/src/cle2000_c.c new file mode 100644 index 0000000..fa19339 --- /dev/null +++ b/Ganlib/src/cle2000_c.c @@ -0,0 +1,725 @@ + +/**************************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR OF C VERSION: A. Hebert ; 31/07/2010 */ +/**************************************************/ + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include "cle2000.h" + +int_32 cle2000_c(int_32 ilevel, + int_32 (*dummod)(char *, int_32, char (*)[13], int_32 *, int_32 *, lcm **, char (*)[73]), + char *filenm, int_32 iprint, lifo *my_param) +{ + char *nomsub = "cle2000_c"; + int_32 ret_val = 0; + static char *cdclkw[] = {"PROCEDURE", "MODULE", "LINKED_LIST", "XSM_FILE", + "SEQ_BINARY", "SEQ_ASCII", "DIR_ACCESS", "HDF5_FILE", + "PARAMETER"}; + int ldatav, lobnew; + kdi_file *iKDI, *icobj; + FILE *icinp = NULL, *icout = NULL, *icfile; + lifo *my_iptrun; + char hwrite[73] = " "; + int_32 nusec2, jrecin; + lcm *kparam = NULL; + int_32 iretcd, iloop1, iparam, jparam, lparam; + int_32 jdispe, nentry, nmodul, ilogin, ityp, nitma; + float_32 flott; + double_64 dflot; + char cmodul[13], hparam[73], text[73], cproce[73] = " "; + char filinp[73], filobj[73], filout[73], filkdi[73]; + + double tk1 = 0; + if (ilevel == 1) cletim_c(&tk1); + +/* ALLOCATE maxent ARRAYS */ + int maxent = 1000; /* maximum number of module arguments */ + char (*hentry)[13]; + int_32 *ientry, *jentry; + lcm **kentry; + hentry = (char(*)[])malloc(maxent*13); + ientry = (int_32 *)malloc(maxent*sizeof(int_32)); + jentry = (int_32 *)malloc(maxent*sizeof(int_32)); + kentry = (lcm **)malloc(maxent*sizeof(*kentry)); + +/* COMPILE MAIN INPUT INTO OBJECT FILE */ + if (strcmp(filenm, " ") == 0) { + icinp = stdin; + icfile = NULL; + icout = stdout; + strcpy(filobj, "_DUMMY"); + } else { + sprintf(filinp, "%s.c2m",filenm); + sprintf(filobj, "%s.o2m",filenm); + sprintf(filout, "%s.l2m",filenm); + icfile = fopen(filobj, "r"); + } + if (icfile == NULL) { +/* OPEN SOURCE FILE '.c2m' */ + if (icinp != stdin) { + icinp = fopen(filinp, "r"); + if (icinp == NULL) goto L9003; + } + if (icout != stdout) { + icout = fopen(filout, "w+"); + if (icout == NULL) goto L9005; + } + +/* CREATE OBJECT FILE SUFFIX IS '.o2m' */ + icobj = kdiop_c(filobj, 0); + if (icobj == NULL) goto L9001; + +/* COMPILE NEW FUNCTION */ + iretcd = clepil(icinp, icout, icobj, clecst); + if (iretcd != 0) { + printf("%s: COMPILING _MAIN.c2m FILE (ERROR CODE) IRC=%d\n", nomsub,(int)iretcd); + goto L666; + } + +/* ADD OBJECTS/MODULES TO OBJECT FILE */ + iretcd = objpil(icobj, icout, 0); + if (iretcd != 0) { + printf("%s: BAD OBJECTS _MAIN.c2m FILE (ERROR CODE) IRC=%d\n", nomsub,(int)iretcd); + goto L666; + } + +/* CLOSE & KEEP SOURCE & OUTPUT FILES */ + if (icout != stdout) { + iretcd = fclose(icout); + if (iretcd != 0) goto L9006; + } + if (icinp != stdin) { + iretcd = fclose(icinp); + if (iretcd != 0) goto L9004; + } + } else { + iretcd = fclose(icfile); + if (iretcd != 0) goto L9002; + icobj = kdiop_c(filobj, 1); + if (icobj->fd == NULL) { + printf("%s: DID YOU FORGET TO COMPILE *%s*?\n", nomsub, filobj); + goto L9001; + } + } + +/* NOW, MAKE A COPY OF OBJECT FILE */ + if (strcmp(filenm," ") == 0) { + sprintf(filkdi,"_main%.3d", (int)ilevel); + } else { + sprintf(filkdi,"_%s%.3d", filenm,(int)ilevel); + } + iKDI = kdiop_c(filkdi, 0); + if (iKDI == NULL) goto L9007; + iretcd = clecop(icobj, iKDI); + if (iretcd != 0) { + printf("%s: COPYING PREVIOUS FILE *%s* IRC=%d\n", nomsub, cproce, (int)iretcd); + goto L666; + } + +/* CLOSE AND KEEP ORIGINAL OBJECT FILE */ + iretcd = kdicl_c(icobj, 1); + if (iretcd != 0) goto L9002; + if (strcmp(filobj, "_DUMMY") == 0) { + iretcd = remove(filobj); + if (iretcd != 0) goto L9006; + } + + if (iprint > 0) printf("%s: STARTING EXECUTION ON _MAIN.o2m FILE\n", nomsub); + redopn_c(iKDI, stdout, hwrite, 0); + cleopn(&my_iptrun); + nusec2 = 0; + +L10: +/* GET SENTENCE */ + jdispe = 0, nentry = 0, nmodul = 0; + redget_c(&ityp, &nitma, &flott, text, &dflot); +/* TREAT FIRST WORD */ + if (ityp == 3) { + ilogin = 0; + for (iloop1 = 0; iloop1 < 9; ++iloop1) { + if (strcmp(cdclkw[iloop1], text) == 0) ilogin = iloop1+1; + } +/* OUTSIDE THE DATA SECTION ( *HERE* :: ... ) */ +L30: + if (strcmp(text, ":=") == 0) { + jdispe = 2; + } else if (strcmp(text, "::") == 0) { +/* FOR PROCEDURE/MODULE WITHOUT DATA, BRANCH NOW */ + ldatav = 1; + goto L40; + } else if (strcmp(text, ";") == 0) { +/* FOR PROCEDURE/MODULE WITH DATA, BRANCH NOW */ + ldatav = 0; + goto L40; + } else { + lifo_node *my_node; + my_node = clenode(&my_iptrun, text); + if (my_node == NULL) { + my_node = (lifo_node *) malloc(sizeof(lifo_node)); + strcpy(my_node->name, text); + strcpy(my_node->OSname, " "); + clepush(&my_iptrun, my_node); + } + if (ilogin != 0) { + if (strcmp(text, cdclkw[ilogin-1]) == 0) { +/* DECLARATION ITSELF IS A MODULE */ + iparam = 2; + } else { +/* TYPE IS SET TO VALUE < 0 (UNDEFINED) */ + iparam = -ilogin; + } + strcpy(hparam, text); + my_node->type = iparam; + jparam = -1; my_node->access = jparam; + kparam = NULL; my_node->value.mylcm = kparam; + lparam = 0; my_node->lparam = lparam; + if (iparam < 0) strcpy(my_node->OSname, hparam); + } else { + if(my_node == NULL) { + printf("%s: NODE DOES NOT EXIST\n", nomsub); + goto L666; + } + iparam = my_node->type; + kparam = my_node->value.mylcm; + lparam = my_node->lparam; + strcpy(hparam, my_node->OSname); + } + if (nmodul == 0 && (abs(iparam) == 1 || abs(iparam) == 2)) { +/* ONCE MODULE/PROCEDURE FOUND, RESET *JDISPE=2, (READ-ONLY MODE) */ + strcpy(cmodul, text); + jdispe = 2; + if (abs(iparam) == 2) { + nmodul = 1; + } else { + nmodul = -1; + strcpy(cproce, hparam); + if (iparam == -1) { + printf("%s: FILE *%s* DOES NOT EXIST\n", nomsub, hparam); + goto L666; + } + } + } else { + lobnew = 1; + if (nentry != 0) { + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + if (strcmp(hentry[iloop1], text) == 0) { + if (jentry[iloop1] == 0) { +/* OBJECT GOES TO (MODIFICATION) MODE */ + jentry[iloop1] = 1; + } else { + printf("%s: INCONSISTENT CALL (text=%s)\n", nomsub,text); + goto L666; + } + lobnew = 0; + } + } + } + if (lobnew) { + ++(nentry); + if (nentry > maxent) { + maxent += 1000; /* increase maximum number of module arguments */ + hentry = (char(*)[])realloc(hentry,maxent*13); + ientry = (int_32 *)realloc(ientry,maxent*sizeof(int_32)); + jentry = (int_32 *)realloc(jentry,maxent*sizeof(int_32)); + kentry = (lcm **)realloc(kentry,maxent*sizeof(*kentry)); + } + strcpy(hentry[nentry-1], text); + jentry[nentry-1] = jdispe; + } + } + } + redget_c(&ityp, &nitma, &flott, text, &dflot); + goto L30; +L40: + if (nmodul == 0) { + if (nentry == 0) { + strcpy(cmodul, "IOX:"); + } else { + strcpy(cmodul, "EQU:"); + } + nmodul = 1; + } + if (nmodul == 1) { +/* FOR MODULES */ +/* IF NOT LDATAV DISCONNECT READER */ + if (!ldatav) redcls_c(&iKDI, &icout, hwrite, &jrecin); + if (ilogin == 0) { + if (strcmp(cmodul, "IOX:") == 0) { + int_32 minput = 0; + if (nentry != 0) { + printf("%s: MODULE *IOX:* WITH INVALID PARAMETERS\n", nomsub); + goto L666; + } + drviox(my_param, minput, &nusec2); + } else { + char (*hparam_c)[73]; + hparam_c = (char(*)[])malloc(maxent*73); + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + lifo_node *my_node; + my_node = clenode(&my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + goto L666; + } + iparam = my_node->type; + jparam = my_node->access; + if (iparam == 3) kparam = my_node->value.mylcm; + if (iparam == 7) lparam = my_node->lparam; +#if defined(HDF5_LIB) + if (iparam == 8) kparam = (lcm*)my_node->value.myhdf5; +#endif + strcpy(hparam, my_node->OSname); + strcpy(hparam_c[iloop1], hparam); +/* CONSISTENCY TESTS */ + if (jentry[iloop1] == 0) { + if (jparam == 1 || jparam == 2 || iparam >= 0) { + printf("%s: %s *%s* ALREADY EXISTS\n", nomsub, cdclkw[abs(iparam)-1], hentry[iloop1]); + ret_val = -2; + goto L666; + } + iparam = -iparam; + my_node->type = iparam; + } else if (jentry[iloop1] == 1) { + if (jparam == 2) { + printf("%s: %s *%s* IS PROTECTED\n", nomsub, cdclkw[abs(iparam)-1], hentry[iloop1]); + ret_val = -2; + goto L666; + } else if (iparam <= 0) { +/* ALLOW ACCESS TO ANY FILE AT MAIN LEVEL */ + if (ilevel == 1 && (iparam == -4 || iparam == -5 || iparam == -6 || iparam == -7 || iparam == -8)) { + iparam = -iparam; + my_node->type = iparam; + } else { + printf("%s: %s *%s* IS NOT DEFINED(1)\n", nomsub, cdclkw[-iparam-1], hentry[iloop1]); + ret_val = -2; + goto L666; + } + } + } else if (jentry[iloop1] == 2) { + if (iparam <= 0) { +/* ALLOW ACCESS TO ANY FILE AT MAIN LEVEL */ + if (ilevel == 1 && (iparam == -4 || iparam == -5 || iparam == -6 || iparam == -7 || iparam == -8)) { + iparam = -iparam; + my_node->type = iparam; + } else { + printf("%s: %s *%s* IS NOT DEFINED(2)\n", nomsub, cdclkw[-iparam-1], hentry[iloop1]); + ret_val = -2; + goto L666; + } + } + } else { + printf("%s: INVALID JENTRY=%d\n", nomsub,(int)jentry[iloop1]); + goto L666; + } + jdispe = jentry[iloop1]; + if (iprint > 1) { + if (jdispe == 0) { + printf("%s: OPEN %s *%s* IN CREATION MODE\n", nomsub, cdclkw[iparam-1], hparam); + } else if (jdispe == 1) { + printf("%s: OPEN %s *%s* IN MODIFICATION MODE\n", nomsub, cdclkw[iparam-1], hparam); + } else if (jdispe == 2) { + printf("%s: OPEN %s *%s* IN READ/ONLY MODE\n", nomsub, cdclkw[iparam-1], hparam); + } + } + if (iparam == 3 || iparam == 4) { + if (jdispe > 0) kentry[iloop1] = kparam; + lcmop_c(&kentry[iloop1], hparam, jdispe, iparam-2, 0); + kparam = kentry[iloop1]; + } else if (iparam == 5 || iparam == 6 || iparam == 7) { + kentry[iloop1] = NULL; +#if defined(HDF5_LIB) + } else if (iparam == 8) { + if (jdispe > 0) kentry[iloop1] = kparam; + hid_t myhdf5 = 0; + if (jdispe == 0) { + myhdf5 = H5Fcreate(hparam, H5F_ACC_EXCL, H5P_DEFAULT, H5P_DEFAULT); + if (iprint > 1) { + printf("%s: create HDF5 file at address=%lld\n",nomsub, (long long int)myhdf5); + } + } else if (jdispe == 1) { + myhdf5 = H5Fopen(hparam, H5F_ACC_RDWR, H5P_DEFAULT); + if (iprint > 1) { + printf("%s: open HDF5 file in read-write mode at address=%lld\n",nomsub, (long long int)myhdf5); + } + } else if (jdispe == 2) { + myhdf5 = H5Fopen(hparam, H5F_ACC_RDONLY, H5P_DEFAULT); + if (iprint > 1) { + printf("%s: open HDF5 file in read-only mode at address=%lld\n",nomsub, (long long int)myhdf5); + } + } + if (myhdf5 < 0) { + printf("%s: H5Fopen failure on HDF5 file '%s'.\n",nomsub,hparam); + goto L666; + } + kentry[iloop1] = (lcm*)myhdf5; + kparam = kentry[iloop1]; +#endif + } else { + printf("%s: USE %s *%s* IS IMPOSSIBLE. INVALID IPARAM (%d)\n", nomsub, + cdclkw[iparam-1], hparam, (int)iparam); + goto L666; + } + ientry[iloop1] = iparam - 2; + if (jdispe == 0) { + my_node->value.mylcm = kparam; + } else if (strcmp(cmodul, "DELETE:") == 0) { + if (abs(jparam) != 1) { + printf("%s: KIL %s *%s* IS IMPOSSIBLE. INVALID DELETE\n", nomsub, + cdclkw[iparam-1], hparam); + goto L666; + } + kparam = 0; + iparam = -iparam; + my_node->type = iparam; + if (iparam == 3) my_node->value.mylcm = kparam; + } + } + +/* CALLING MODULES */ + jdispe = 1; + if (strcmp(cmodul, "END:") == 0) { + if (ldatav) { + printf("%s: *END:* HAS NO DATA\n", nomsub); + goto L666; + } else if (nentry != 0) { + printf("%s: *END:* HAS NO OBJECT\n", nomsub); + goto L666; + } + iretcd = 0; + } else if (strcmp(cmodul, "DELETE:") == 0) { +/* STANDARD DELETE MODULE (SEE BELOW). */ + jdispe = 2; + iretcd = 0; + } else if (strcmp(cmodul, "ERASE:") == 0) { +/* STANDARD ERASE MODULE (SEE BELOW). */ + jdispe = 3; + iretcd = 0; + } else if (dummod != NULL) { +/* CALLING ANOTHER STANDARD UTILITY MODULE in ANSI-C. */ + fflush(stdout); + iretcd = (*dummod)(cmodul, nentry, hentry, ientry, jentry, kentry, hparam_c); + } else if (dummod == NULL) { + printf("%s: MODULE *%s* NOT FOUND; DUMMOD NOT SET\n", nomsub, cmodul); + goto L666; + } + if (iretcd != 0) { + printf("%s: MODULE *%s* NOT FOUND\n", nomsub, cmodul); + goto L666; + } + free(hparam_c); + +/* CLOSE EVERYTHING */ + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + iparam = ientry[iloop1]; + if (iprint > 1) { + lifo_node *my_node; + my_node = clenode(&my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + goto L666; + } + strcpy(hparam, my_node->OSname); + if (jdispe == 1) { + printf("%s: CLS %s *%s*\n", nomsub, cdclkw[iparam-1], hparam); + } else { + printf("%s: KIL %s *%s* (AS IF IT NEVER EXISTED)\n", nomsub, + cdclkw[iparam-1], hparam); + } + } + if (iparam == 1 || iparam == 2) { + lcmcl_c(&kentry[iloop1], jdispe); + } else if (iparam == 3 || iparam == 4 || iparam == 5) { + if (jdispe == 2) { + iretcd = remove(hentry[iloop1]); + if (iretcd != 0) { + printf("%s: REMOVE FAILURE. file=*%s*\n", nomsub, hentry[iloop1]); + goto L666; + } + kparam = 0; + } +#if defined(HDF5_LIB) + } else if (iparam == 6) { + iretcd = H5Fclose((hid_t)kentry[iloop1]); + if (iretcd != 0) { + printf("%s: HDF5 CLOSE FAILURE. file=*%s* iretcd=%d\n", nomsub, hentry[iloop1], + iretcd); + goto L666; + } + if (jdispe == 2) { + iretcd = remove(hentry[iloop1]); + if (iretcd != 0) { + printf("%s: REMOVE FAILURE. file=*%s*\n", nomsub, hentry[iloop1]); + goto L666; + } + kparam = 0; + } +#endif + } else { + printf("%s: UNABLE TO CLOSE *%s*\n", nomsub, hentry[iloop1]); + goto L666; + } + } + } + } else { +/* CHARGE ENTRIES FOR DECLARATION MODULES */ + if (strcmp(cmodul, "PARAMETER") == 0) { +/* *PARAMETER * DECLARATION MODULE */ + int_32 minput = 0; + iretcd = kdrprm(&my_iptrun, &my_param, minput, nentry, jentry, hentry); + if (iretcd != 0) { + printf("%s: PROBLEM ACCEPTING PARAMETERS IER=%d\n", nomsub, (int)iretcd); + goto L666; + } + nusec2 = nentry; + } else if (strcmp(cmodul, "PROCEDURE") == 0) { +/* *PROCEDURE * DECLARATION MODULE */ + iretcd = kdrdpr(&my_iptrun, nentry, hentry); + } else if (strcmp(cmodul, "MODULE") == 0) { +/* *MODULE * DECLARATION MODULE */ + iretcd = kdrdmd(&my_iptrun, nentry, hentry); + } else if (strcmp(cmodul, "LINKED_LIST") == 0) { +/* *LINKED_LIST * DECLARATION MODULE */ + iretcd = kdrdll(&my_iptrun, nentry, hentry); + } else if (strcmp(cmodul, "XSM_FILE") == 0) { +/* *XSM_FILE * DECLARATION MODULE */ + iretcd = kdrdxf(&my_iptrun, nentry, hentry); + } else if (strcmp(cmodul, "SEQ_BINARY") == 0) { +/* *SEQ_BINARY * DECLARATION MODULE */ + iretcd = kdrdsb(&my_iptrun, nentry, hentry); + } else if (strcmp(cmodul, "SEQ_ASCII") == 0) { +/* *SEQ_ASCII * DECLARATION MODULE */ + iretcd = kdrdsa(&my_iptrun, nentry, hentry); + } else if (strcmp(cmodul, "DIR_ACCESS") == 0) { +/* *DIR_ACCESS * DECLARATION MODULE */ + iretcd = kdrdda(&my_iptrun, nentry, hentry); + } else if (strcmp(cmodul, "HDF5_FILE") == 0) { +/* *HDF5_FILE * DECLARATION MODULE */ + iretcd = kdrdh5(&my_iptrun, nentry, hentry); + } else { +/* OTHERWISE, DECLARATION MODULE IS NOT AVAILABLE */ + printf("%s: DECLARATION MODULE *%s* NOT AVAILABLE IN THIS CODE\n", nomsub, cmodul); + goto L666; + } + if (iretcd != 0) { + printf("%s: PROBLEM WITH MODULE *%s*\n", nomsub, cmodul); + goto L666; + } + } + if (iprint > 0) printf("%s: END OF MODULE *%s*\n", nomsub, cmodul); + if (!ldatav && strcmp(cmodul, "END:") != 0) { +/* RECONNECT READER IF DISCONNECTED OUTSIDE END: */ + redopn_c(iKDI, stdout, hwrite, jrecin); + } + } else { +/* FOR PROCEDURES */ + int_32 minput; + lifo *my_param_daughter; + + minput = -1; + iretcd = kdrprm(&my_iptrun, &my_param_daughter, minput, nentry, jentry, hentry); + if (iretcd != 0) { + printf("%s: PROBLEM PASSING PARAMETERS\n", nomsub); + goto L666; + } else if (my_param_daughter == NULL) { + printf("%s: MISSING call_daughter SUB-STRUCTURE\n", nomsub); + goto L666; + } + +/* HERE, ONE STEP UP */ + ++(ilevel); + if (ldatav) { +/* FOR PROCEDURES, READ DATA SECTION ( ... :: *HERE* ) */ + drviox(my_param_daughter, minput, &nusec2); + } + if (iprint > 0) printf("%s: BEG PROCEDURE *%s* (LEVEL: STEP UP)\n", nomsub, cmodul); + +/* CLOSE THE READER AT CURRENT LEVEL */ + redcls_c(&iKDI, &icout, hwrite, &jrecin); + +/* RECURSIVE CALL TO cle2000_c.c */ + iretcd = cle2000_c(ilevel, dummod, cmodul, iprint, my_param_daughter); + if (iretcd != 0) return iretcd; + +/* REOPEN THE READER AT CURRENT LEVEL */ + redopn_c(iKDI, stdout, hwrite, jrecin); + +/* RETURN BACK TO PREVIOUS LEVEL AT SELECTED RECORD */ + minput = 1; + iretcd = kdrprm(&my_iptrun, &my_param_daughter, minput, nentry, jentry, hentry); + if (iretcd != 0) { + printf("%s: PROBLEM RETURNING PARAMETERS\n", nomsub); + goto L666; + } + +/* RECOVERING OUTPUT IN DATA FIELD */ + drviox(my_param_daughter, minput, &nusec2); + +/* CLEANING NON-DUMMY OBJECTS */ + iretcd = kdrcln(my_param_daughter, iprint); + if (iretcd != 0) { + printf("%s: PROBLEM CLEANING NON-DUMMY OBJECTS\n", nomsub); + goto L666; + } + +/* HERE, ONE STEP DOWN */ + --(ilevel); + if (iprint > 0) { + if (ityp == 9) { + printf("%s: END PROCEDURE NO MORE DATA (LEVEL: STEP DOWN). LEV=%d\n", nomsub, (int)ilevel); + } else { + printf("%s: END PROCEDURE RETURN (LEVEL: STEP DOWN). LEV=%d\n", nomsub, (int)ilevel); + } + } + } + } else if (ityp == 9 || ityp == 10) { + goto L100; + } else { + printf("%s: INVALID TYPE\n", nomsub); + goto L666; + } + goto L10; + +L100: +/* RECOVER NEW OBJECTS IN LIFO STACK */ + if (my_param != NULL) { + for (iloop1 = 0; iloop1 < my_param->nup; ++iloop1) { + char dparam[13]; + lifo_node *my_node, *my_node_daughter; + my_node = clepos(&my_param, iloop1); + if ((my_node->type <= -10) || (my_node->type > 0)) continue; + strcpy(dparam, my_node->name_daughter); + my_node_daughter = clenode(&my_iptrun, dparam); + if (my_node_daughter == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s<-->%s at position %d\n", nomsub, dparam, my_node->name, (int)iloop1); + goto L666; + } + if (my_node_daughter->type != -my_node->type) { + printf("%s: INCONSISTENT TYPE IN NODES %s<-->%s at position %d\n", nomsub, dparam, my_node->name, (int)iloop1); + goto L666; + } + if (my_node->type == -3) my_node->value.mylcm = my_node_daughter->value.mylcm; + my_node->type = -my_node->type; + } + } + +/* DESTROY THE LIFO STACK */ + iretcd = kdrcln(my_iptrun, iprint); + if (iretcd != 0) { + printf("%s: PROBLEM CLEANING NON-DUMMY OBJECTS\n", nomsub); + goto L666; + } + +/* CLOSE AND DESTROY MAIN OBJECT FILE */ + iretcd = kdicl_c(iKDI, 2); + if (iretcd != 0) goto L9008; + if ((iprint > 0) && (ret_val == 0)) { + printf("%s: SUCCESSFUL EXECUTION AT LEVEL %d\n", nomsub, (int)ilevel); + } + if (ilevel == 1) { + double tk2; + cletim_c(&tk2); + printf("%s: cpu time= %.2f second\n", nomsub, tk2-tk1); + } + +/* DEALLOCATE maxent ARRAYS */ + free(kentry); + free(jentry); + free(ientry); + free(hentry); + return ret_val; +L666: + return 666; +L9001: + printf("%s: ERROR WHEN OPENING OBJECT FILE *%s*\n", nomsub, filenm); + goto L666; +L9002: + printf("%s: ERROR WHEN CLOSING OBJECT FILE *%s*\n", nomsub, filenm); + goto L666; +L9003: + printf("%s: ERROR WHEN OPENING SOURCE FILE *.c2m\n", nomsub); + goto L666; +L9004: + printf("%s: ERROR WHEN CLOSING SOURCE FILE *.c2m\n", nomsub); + goto L666; +L9005: + printf("%s: ERROR WHEN OPENING OUTPUT FILE *.l2m\n", nomsub); + goto L666; +L9006: + printf("%s: ERROR WHEN CLOSING OUTPUT FILE *.l2m; IRC=%d\n", nomsub, (int)iretcd); + goto L666; +L9007: + if (strcmp(filenm," ") == 0) { + printf("%s: ERROR WHEN OPENING OBJECT FILE _main%.3d\n", nomsub, (int)ilevel); + } else { + printf("%s: ERROR WHEN OPENING OBJECT FILE _%s%.3d\n", nomsub, filenm, (int)ilevel); + } + goto L666; +L9008: + if (strcmp(filenm," ") == 0) { + printf("%s: ERROR WHEN CLOSING OBJECT FILE _main%.3d\n", nomsub, (int)ilevel); + } else { + printf("%s: ERROR WHEN CLOSING OBJECT FILE _%s%.3d\n", nomsub, filenm, (int)ilevel); + } + goto L666; +} + +int_32 kdrcln(lifo *my_iptrun, int_32 iprint) +{ + char *nomsub = "kdrcln"; + int_32 ret_val = 0; + char *cdclkw[] = {"PROCEDURE", "MODULE", "LINKED_LIST", "XSM_FILE", + "SEQ_BINARY", "SEQ_ASCII", "DIR_ACCESS", "PARAMETER"}; + + while (my_iptrun->nup > 0) { + lifo_node *my_node; + int_32 iparam,jparam; + + my_node = clepop(&my_iptrun); + if (my_node == NULL) { + printf("%s: POP FAILURE IN LIFO STACK.\n",nomsub); + ret_val = -1; + goto L20; + } + if (iprint > 0) printf("%s: CLEANING FOR NODE %d (*%s*).\n", nomsub, (int)my_iptrun->nup, my_node->name); + + iparam = my_node->type; + jparam = my_node->access; + if (iparam <= 10) { + if (jparam == -1 && (abs(iparam) >= 3 && abs(iparam) < 8)) { + if (iparam > 0) { + int_32 jdispe = 1; +/* DESTROY OBJECT */ + if (iparam == 3) { + char recnam[73]; + strcpy(recnam, my_node->OSname); + lcmop_c(&my_node->value.mylcm, recnam, jdispe, iparam-2, 0); + lcmcl_c(&my_node->value.mylcm, 2); + } else if (iparam == 4 || iparam == 5 || iparam == 6 || iparam == 7) { + ret_val = (int_32)remove(my_node->OSname); + if (ret_val != 0) { + printf("%s: CANNOT DESTROY %s FILE %s (irc=%d).\n",nomsub,cdclkw[iparam-1],my_node->name,(int)ret_val); + ret_val = -2; + goto L20; + } + } + if (iprint > 0) printf("%s: DEL %s %s (WILL NEVER EXIST ANYMORE).\n",nomsub,cdclkw[iparam-1],my_node->name); + my_node->type = -iparam; + } else { + if (iprint > 1) printf("%s: DEL %s %s (WAS NOT DEFINED ANYWAY).\n",nomsub,cdclkw[-iparam-1],my_node->name); + } + } + } + free(my_node); + } + ret_val = clecls(&my_iptrun); + if (ret_val != 0) { + printf("%s: LIFO STACK NOT EMPTY (irc=%d).\n",nomsub, (int)ret_val); + ret_val = -3; + } +L20: + return ret_val; +} diff --git a/Ganlib/src/clecop.c b/Ganlib/src/clecop.c new file mode 100644 index 0000000..899c3cc --- /dev/null +++ b/Ganlib/src/clecop.c @@ -0,0 +1,80 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 15/05/09 */ +/*****************************************/ + +#include <string.h> +#include "cle2000.h" +#include "header.h" + +int_32 clecop(kdi_file *iuniti, kdi_file *iunito) +{ + static char cl2000[] = "CLE2000(V3)"; + +/* CLE-2000 SYSTEM: R.ROY (09/1999), VERSION 2.1 */ + +/* *CLECOP* WILL COPY ONE OBJECT FILE TO ANOTHER */ + +/* INPUT: *IUNITI* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */ +/* *IUNITO* IS ITS COPY */ + +/* NOTE: FACULTATIVE IN THE CLE-2000 SYSTEM. */ +/* THIS UTILITARY FUNCTION CAN BE USED IN THE APPLICATION */ +/* (MUST BE USED IN CASES WHERE THE OBJECT FILE IS RECURSIVE) */ + + int_32 iretcd, iofset; + int_32 ret_val = 0; + int_32 irecor; + +/* READ AND WRITE TOP OF OBJECT FILE */ + iretcd = kdiget_c(iuniti, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9023; + iretcd = kdiput_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9025; + +/* VERIFY CONSISTENCY OF VERSION */ + if (strcmp(header.cparin, cl2000) != 0) goto L9002; + if (header.nrecor <= 0) goto L9003; + if (header.nrecor != header.ninput + header.nstack + header.nobjet) goto L9003; + +/* CASE WHERE THERE ARE NO LOG-FILE (TRIVIAL FILE) */ + if (header.ninput == 1) goto L666; + +/* COPY ALL LOG-FILE RECORDS */ + for (irecor = 1; irecor < header.ninput; ++irecor) { + iofset = irecor * lrclen; + iretcd = kdiget_c(iuniti, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9023; + iretcd = kdiput_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9025; + } + +/* CASE WHERE THERE ARE NO CLE-2000 VARIABLES */ + if (header.nstack + header.nobjet <= 0) goto L666; + +/* COPY ALL VAR-STACK AND OBJECT RECORDS */ + for (irecor = header.ninput; irecor < header.nrecor; ++irecor) { + iofset = irecor * lrclen; + iretcd = kdiget_c(iuniti, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9025; + } + +L666: + return ret_val; +L9002: + ret_val = 9002; + goto L666; +L9003: + ret_val = 9003; + goto L666; +L9023: + ret_val = 9023; + goto L666; +L9025: + ret_val = 9025; + goto L666; +} /* clecop */ diff --git a/Ganlib/src/clecst.c b/Ganlib/src/clecst.c new file mode 100644 index 0000000..d1823f6 --- /dev/null +++ b/Ganlib/src/clecst.c @@ -0,0 +1,119 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 15/05/09 */ +/*****************************************/ + +#include <string.h> +#include "cle2000.h" +#define index_f(A, B) (strstr(A, B) == NULL ? 0 : strstr(A, B) - A + 1) + +int_32 clecst(char *cparm, int_32 *ityp, int_32 *nitma, float_32 *flott, char *text, double_64 *dflot) +{ + static char *ctypes[] = {"_I", "_R", "_S", "_D", "_L"}; + static char *cinteg[] = {"$Version", "$XLangLvl", "$c0", "$Date", "$Time", "$True", "$False"}; + static int_32 dinteg[] = { 2,77,299792458,20000101,0,1,-1 }; + static char *cfloat[] = {"$Pi", "$E", "$Euler", "$c0", "$Na", "$u", "$eV", "$h"}; + static double_64 dfloat[] = {3.141592653589793, 2.718281828459045, .577215664901533, 299792458., + 6.02214199e23, 1.66053873e-27, 1.602176462e-19, 6.62606876e-34}; + static char *cstrin[] = {"$Code", "$Release", "$XLang", "$Date", "$Time", "$Bang", "$GetIn", + "$GetOut"}; + static char *dstrin[] = {"CLE2000", "3", "Fortran", "20000101", "000000", "!", ">>", + "<<"}; + +/* CLE-2000 CONSTANTS: R.ROY (11/1999) */ + +/* *CLECST* WILL ATTEMPT TO FIND VALUES FOR */ +/* A CLE-2000 CONSTANT. */ + +/* INPUT: *CPARM * IS THE TENTATIVE CONSTANT NAME */ + +/* OUTPUT: *ITYP * IS THE CONSTANT TYPE (1:INTEGER) */ +/* (2:REAL) */ +/* (3:CHARACTER STRING) */ +/* (4:DOUBLE) */ +/* (5:LOGICAL) */ +/* *NITMA * IS AN INTEGER VALUE */ +/* (= LENGTH OF STRING IF *ITYP* .EQ.3) */ +/* (= -1 FOR .F. +1 FOR .T. IF *ITYP* .EQ.5) */ +/* *FLOTT * IS AN REAL VALUE */ +/* *TEXT * IS AN CHARACTER STRING */ +/* *DFLOT * IS AN DOUBLE PRECISION VALUE */ + +/* NOTE: *CLECST* = 0, IF WE FOUND THE PARAMETER *CPARM* */ + +/* THIS FUNCTION DEPEND ON THE APPLICATION */ +/* THE EXAMPLE GIVEN HERE SHOULD HELP THE DEVELOPER */ +/* TO WRITE ITS OWN APPLICATION-BASED CONSTANT LIST. */ + +/* PHYSICAL CONSTANTS GIVEN HERE WERE TAKEN FROM: */ +/* http://physics.nist.gov/cuu/Constants/ */ + +/* EXAMPLE: HERE *ITYP* IS IMPOSED AT THE END OF *CPARM* */ +/* (1:INTEGER) => END: _I */ +/* (2:REAL ) => END: _R */ +/* (3:STRING ) => END: _S */ +/* (4:DOUBLE ) => END: _D */ +/* (5:LOGICAL) => END: _L */ +/* ALL FLOATING (_R, _D ) ARE KEPT IN DOUBLE */ +/* AND CONVERTED INTO THE APPROPRIATE MODE. */ + + int_32 iloop1, ret_val = 1; + char cparin[13]; + +/* IDENTITY WHICH TYPE: _I ,_R, _D, _S, _L */ + int_32 indlec = 0; + for (iloop1 = 0; iloop1 < 5; ++iloop1) { + int_32 idftyp = index_f(cparm, ctypes[iloop1]); + if (idftyp != 0) { + indlec = iloop1 + 1; + strncpy(cparin, cparm, idftyp-1); cparin[idftyp-1] = '\0'; + } + } + + if (indlec == 1 || indlec == 5) { +/* LOOK FOR INTEGER VARIABLES */ + for (iloop1 = 0; iloop1 < 7; ++iloop1) { + if (strcmp(cparin, cinteg[iloop1]) == 0) { +/* FOUND: RETURN => TYPE=1, INTEGER */ +/* => TYPE=5, LOGICAL */ + *ityp = indlec; + *nitma = dinteg[iloop1]; + ret_val = 0; + goto L666; + } + } + } else if (indlec == 3) { +/* LOOK FOR STRING VARIABLES */ + for (iloop1 = 0; iloop1 < 8; ++iloop1) { + if (strcmp(cparin, cstrin[iloop1]) == 0) { +/* FOUND: RETURN => TYPE=3, STRING AND ITS LENGTH */ + *ityp = 3; + strcpy(text, dstrin[iloop1]); + *nitma = strlen(dstrin[iloop1]); + ret_val = 0; + goto L666; + } + } + } else if (indlec != 0) { +/* LOOK FOR FLOATING VARIABLES */ + for (iloop1 = 0; iloop1 < 8; ++iloop1) { + if (strcmp(cparin, cfloat[iloop1]) == 0) { + if (indlec == 2) { +/* FOUND: RETURN => TYPE=2, REAL */ + *flott = (float_32) dfloat[iloop1]; + } else { +/* FOUND: RETURN => TYPE=4, DOUBLE */ + *dflot = dfloat[iloop1]; + } + *ityp = indlec; + ret_val = 0; + goto L666; + } + } + } + +L666: + return ret_val; +} /* clecst */ diff --git a/Ganlib/src/clelog.c b/Ganlib/src/clelog.c new file mode 100644 index 0000000..3c1db28 --- /dev/null +++ b/Ganlib/src/clelog.c @@ -0,0 +1,772 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 09/05/09 */ +/*****************************************/ + +#include <string.h> +#include "cle2000.h" +#include "header.h" +#define min(A,B) ((A) < (B) ? (A) : (B)) +#define max(A,B) ((A) > (B) ? (A) : (B)) +#define index_f(A, B) (strstr(A, B) == NULL ? 0 : strstr(A, B) - A + 1) +#define ndecal 4 +#define nmawrd 60 +#define ndimst 128 +static char AbortString[132]; + +int_32 clelog(FILE *iredin, FILE *iwrite, kdi_file *iunito) +{ + char *nomsub="clelog"; + static char cl2000[] = "CLE2000(V3)"; + static int_32 lvelbg[] = {0, 0, 0, 0, 0, 0, 0, -1, 0, 0, -1, -1, 0, -1, -1}; + static char *clognd[] = {";", ";", ";", ";", ";", ";", ";", "THEN", "THEN", "DO", + ";", ";", "REPEAT", "ELSE", ";"}; + static int_32 lvelnd[] = {0, 0, 0, 0, 0, 0, 0, 0, 1, 1, -1, -1, 1, 0, -1}; + static char ctitle[] = "* CLE-2000 VERS 3.0 * R.ROY, EPM COPYRIGHT 1999 *"; + static char *terror[] = {"! CLELOG: UNEXPECTED CHARACTERS TO BE REPLACED WITH BLANKS", + "! CLELOG: UNBALANCED OPENING OR CLOSING STRINGS", + "! CLELOG: MISPLACED SEMICOLON ...; OR ;... OR ...;...", + "! CLELOG: CHARACTERS SUPPRESSED OUTSIDE COLUMN RANGE 1:120", + "! CLELOG: << AND >> NOT ALLOWED IN STRINGS (SUPPRESSED)", + "! CLELOG: (* ... *) INVALID COMMENTS (USE ! INSTEAD)", + "! CLELOG: QUIT \"...\" . SHOULD APPEAR ALONE A SINGLE LINE"}; + static char csemic[] = ";"; + static char digped[] = "0123456789+-.ED"; + static char onelet[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-*/%<>=;"; + static char *clogbg[] = {"INTEGER", "REAL", "STRING", "DOUBLE", "LOGICAL", "EVALUATE", "ECHO", + "ELSEIF", "IF", "WHILE", "UNTIL", "ENDWHILE", "REPEAT", "ELSE", "ENDIF"}; + +/* CLE-2000 SYSTEM: R.ROY (11/1999), VERSION 3.0 */ + +/* *CLELOG* FIRST-PASS COMPILE OF THE INPUT UNIT *IREDIN* */ +/* COMPILER COMMENTS ARE WRITTEN ON UNIT *IWRITE* */ +/* RESULT IS THE OBJECT D.A. UNIT *IUNITO* */ + +/* USE: INPUT DATA IS COPIED ON D.A. UNIT, */ +/* SENTENCES AND LOGIC DESCRIPTORS ARE SEPARATED, */ +/* LOGICAL LEVELS ARE BUILT AND LOGIC IS CHECKED. */ + +/* INPUT: *IREDIN* IS THE INPUT UNIT */ +/* *IWRITE* IS THE OUTPUT UNIT FOR COMPILER COMMENTS */ +/* *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */ + +/* NOTE: *CLELOG* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */ + + int_32 ret_val = 0, lapos1 = 0, lapos2 = 0; + int_32 ilines = 0, idblst = -1, ixrlst = -1, ioulst = -1, lnwsen = 1, lrecio = 1, l1lett = 1, + nequal = 0, nwrsen = -2, nrecio = 0, nlevel = 1, maxlvl = 0, irecor = 0, nstlvl = 0, + ninput = 1, nstack = 0, nrecor = 1; + int_32 i, iloop1, jloop2, iretcd, iofset, ilevel, ilogin=0; + int_32 maskck[nmaskc], ipacki[nmaskc]; + int_32 idebwd[nmawrd], ifinwd[nmawrd], jndlec[nmawrd]; + int_32 irclvl[ndimst], itylvl[ndimst]; + char crecbg[13], chrend[13], cerror[121]; + char recred[134+ndecal], cemask[121], myreco[121], cbla120[120], rwrite[121]; + int_32 jcm0bg, jst2bg, jfndbg; + int_32 jst1bg, jfndnd, jcm0nd; + int_32 ilengv=0, jsc0bg; + int_32 jkthen, jkelse, jkrepe, jkdodo, jquitp; + int_32 lnbprv, nwords, iapo12=0; + int_32 iwords; + char crecnd[13]; + + fprintf(iwrite, "%-120s LINE\n", ctitle); + for ( i = 0; i < 120; i++) cbla120[i] = ' '; + strcpy(crecbg, " "); + strcpy(chrend, csemic); + +/* WRITE TOP OF OBJECT FILE */ + strcpy(header.cparin, cl2000); + strcpy(header.cdatin, " "); + header.nrecor = nrecor; + header.ninput = ninput; + header.maxlvl = maxlvl; + header.nstack = nstack; + header.ixrlst = ixrlst; + header.ioulst = ioulst; + header.idblst = idblst; + header.nobjet = 0; + iretcd = kdiput_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9001; + +/* DUMP INPUT FILE TO OBJECT FILE */ + strncpy(cemask, cbla120, 120); + for ( i = 0; i < ndecal+132; i++) recred[i] = ' '; + recred[ndecal+132] = '\0'; +L10: + ++ilines; +/* READ A NEW RECORD */ + iretcd = fscanf(iredin, "%133[^\n]\n", &recred[ndecal]); + if (iretcd == EOF) goto L100; + if (strlen(&recred[ndecal]) > 132) goto L5000; + for(i = strlen(&recred[ndecal]); i < 132; i++) recred[ndecal+i] = ' '; + recred[ndecal+132] = '\0'; + strncpy(myreco, &recred[ndecal], 120); myreco[120] = '\0'; + +/* OUPUT THE RECORD */ + fprintf(iwrite, "%-120s %04d\n", myreco, (int)ilines); + +/* SUPPRESS RECORD IF ALL COMMENTS OR BLANK */ + if (strncmp(myreco, cbla120, 120) == 0) { + if (ilines == 1) { + sprintf(AbortString,"%s: empty line %d",nomsub,ilines); + xabort_c(AbortString); + } + goto L10; + } + +/* SUPPRESS ! EXCLAMATION COMMENTS FROM *RECRED* AND RECORD */ + jcm0bg = index_f(recred, "!"); + if (jcm0bg != 0) { + for ( i = jcm0bg - 1; i < ndimst; i++) recred[i]=' '; + if (jcm0bg + ndecal - 1 < 120) { + for ( i = jcm0bg - ndecal - 1; i < 120; i++) myreco[i]=' '; + } + } + if (myreco[0] == '*') goto L10; + +/* ANYTHING OUTSIDE COLUMNS NDECAL+1:NDECAL+120 RANGE IN *RECRED* */ + if (strncmp(&recred[ndecal+120], " ", 7) != 0) { + printf("%.132s\n", &recred[ndecal]); + printf("%120s????????\n", " "); + printf("%120s\n", terror[3]); + ++ret_val; + } + for (iloop1 = 0; iloop1 < 120; ++iloop1) { +/* SUPPRESS UNEXPECTED CHARACTERS */ + if (strncmp(&myreco[iloop1], " ", 1) < 0) { + cemask[iloop1] = '?'; + myreco[iloop1] = ' '; + recred[iloop1+ndecal] = ' '; + ++ret_val; + } + } + +/* SUPPRESS STRINGS OF TYPES: '...' OR "...." FROM *RECRED* */ +L25: + jst1bg = index_f(recred, " \'"); + if (jst1bg == 0) jst1bg = 132; + jst2bg = index_f(recred, " \""); + if (jst2bg == 0) jst2bg = 132; + jfndbg = min(jst1bg,jst2bg); + if (jfndbg != 132) { + if (jfndbg == jst1bg) { + jfndnd = index_f(&recred[jfndbg+1], "\' ") + jfndbg + 1; + } else { + jfndnd = index_f(&recred[jfndbg+1], "\" ") + jfndbg + 1; + } + if (jfndnd == jfndbg + 1) { + cemask[jfndbg-ndecal] = '?'; + strcpy(cerror, terror[1]); + ++ret_val; + jfndnd = 132; + } + +/* STRING IS FOUND, CHECK IF << OR >> IS CONTAINED INSIDE */ + strncpy(rwrite, &recred[jfndbg], jfndnd-jfndbg); rwrite[jfndnd-jfndbg] = '\0'; + jcm0bg = index_f(rwrite, "<<") + jfndbg; + jcm0nd = index_f(rwrite, ">>") + jfndbg; + if (jcm0bg != jfndbg) { + memcpy(&cemask[jcm0bg-ndecal-1], "??", 2); + memcpy(&myreco[jcm0bg-ndecal-1], " ", 2); + strcpy(cerror, terror[4]); + ++ret_val; + } + if (jcm0nd != jfndbg) { + memcpy(&cemask[jcm0nd-ndecal-1], "??", 2); + memcpy(&myreco[jcm0nd-ndecal-1], " ", 2); + strcpy(cerror, terror[4]); + ++ret_val; + } + for ( i = jfndbg; i < jfndnd; i++) recred[i] = ' '; + goto L25; + } + +/* CONTROL STRANGE FORMS OF TYPES: ...'... OR ..."... */ + jst1bg = index_f(recred, "'"); + if (jst1bg != 0) { + cemask[jst1bg-ndecal-1] = '?'; + strcpy(cerror, terror[1]); + ++ret_val; + recred[jst1bg-1] = ' '; + myreco[jst1bg-ndecal-1] = ' '; + } + + if (strncmp(cemask, cbla120, 120) != 0) { + fprintf(iwrite, "%-120s\n", cemask); + fprintf(iwrite, "%-120s\n", cerror); + strncpy(cemask, cbla120, 120); + } + +/* SUPPRESS OLD FORMS OF COMMENTS: (*... ...*) */ +L26: + jcm0bg = index_f(recred, "(*"); + jcm0nd = index_f(recred, "*)"); + if (jcm0bg != 0) { + strcpy(cerror, "! WARNING: (* ... *) OBSOLETE COMMENTS (USE ! INSTEAD)"); + if (jcm0nd == 0) { + strncpy(&myreco[jcm0bg-ndecal-1], cbla120, 120-(jcm0bg-ndecal-1)); + strncpy(&recred[jcm0bg-1], cbla120, 132-(jcm0bg-1)); + strcpy(cerror, terror[5]); + ++ret_val; + } else { + strncpy(&myreco[jcm0bg-ndecal-1], cbla120, jcm0nd + 1 - (jcm0bg - 1)); + strncpy(&recred[jcm0bg-1], cbla120, jcm0nd + 1 - (jcm0bg - 1)); + } + goto L26; + } else if (jcm0nd != 0) { + memcpy(&cemask[jcm0nd-ndecal-1], "??", 2); + strcpy(cerror, terror[5]); + ++ret_val; + strncpy(recred, cbla120, jcm0nd + 1); + strncpy(myreco, cbla120, jcm0nd - ndecal + 1); + goto L26; + } + + if (strncmp(cemask, cbla120, 120) != 0) { + fprintf(iwrite, "%-120s\n", cemask); + fprintf(iwrite, "%-120s\n", cerror); + strncpy(cemask, cbla120, 120); + } + +/* TO SEPARATE LOGIC, PUT RETURNS FOR INPUT LINES ENDING WITH: */ +/* *;*, *REPEAT*, *THEN*, *ELSE* OR *DO* */ +L30: + jsc0bg = index_f(recred, " ; "); + if (jsc0bg == 0) { +/* CONTROL STRANGE FORMS OF TYPES: ...; OR ;... OR ...;... */ + jsc0bg = index_f(recred, ";"); + if (jsc0bg != 0) { + cemask[jsc0bg-ndecal-1] = '?'; + strcpy(cerror, terror[2]); + ++ret_val; + recred[jsc0bg-1] = ' '; + myreco[jsc0bg-ndecal-1] = ' '; + } + jfndbg = 132; + } else { + jfndbg = jsc0bg; + ilengv = 1; + } + jkthen = index_f(recred, " THEN "); + if (jkthen == 0) jkthen = 132; + if (jkthen < jfndbg) { + jfndbg = jkthen; + ilengv = 4; + } + jkelse = index_f(recred, " ELSE "); + if (jkelse == 0) jkelse = 132; + if (jkelse < jfndbg) { + jfndbg = jkelse; + ilengv = 4; + } + jkrepe = index_f(recred, " REPEAT "); + if (jkrepe == 0) jkrepe = 132; + if (jkrepe < jfndbg) { + jfndbg = jkrepe; + ilengv = 6; + } + jkdodo = index_f(recred, " DO "); + if (jkdodo == 0) jkdodo = 132; + if (jkdodo < jfndbg) { + jfndbg = jkdodo; + ilengv = 2; + } + jquitp = index_f(recred, " QUIT "); + if (jquitp == 0) jquitp = 132; + if (jquitp < jfndbg) { + jfndbg = jquitp; + ilengv = 4; + } + + if (jfndbg == 132) { + strncpy(rwrite, myreco, 120); + strncpy(myreco, cbla120, 120); + } else { + if (jfndbg == jquitp) { + strncpy(myreco, cbla120, jfndbg - ndecal + ilengv); + goto L200; + } else { + strncpy(rwrite, cbla120, 120); + strncpy(rwrite, myreco, jfndbg - ndecal + ilengv); + strncpy(myreco, cbla120, jfndbg - ndecal + ilengv); + strncpy(&recred[jfndbg], cbla120, jfndbg + ilengv - jfndbg); + } + } + if (strncmp(cemask, cbla120, 120) != 0) { + fprintf(iwrite, "%-120s\n", cemask); + fprintf(iwrite, "%-120s\n", cerror); + strncpy(cemask, cbla120, 120); + goto L30; + } + +/* SUPPRESS RECORD IF ALL IS STILL BLANK */ + if (strncmp(rwrite, cbla120, 120) == 0) goto L10; + +/* NEW RECORD FOUND, READY TO PROCESS *RWRITE* */ + for (iloop1 = 0; iloop1 < nmaskc; ++iloop1) { + maskck[iloop1] = 0; + ipacki[iloop1] = 0; + } + +/* *** BEWARE **** FROM HERE WORDS ARE IN REVERSE ORDER... */ + +/* BEGIN: CONSTRUCT MASK NUMBERS */ + +/* PREVIOUS NON-BLANK CHARACTER (ASSUME BLANK AT START) */ + lnbprv = 0; + nwords = 0; + for (iloop1 = 120; iloop1 >= 1; --iloop1) { + jloop2 = (iloop1 + 23) / 24; + maskck[jloop2-1] <<= 1; + if (lapos1) { +/* ALL CHARACTERS ARE MASKED WHILE *LAPOS1* */ + ++maskck[jloop2-1]; + lapos1 = rwrite[iloop1-1] != '\''; + +/* MAKE AS IF PREVIOUS WAS BLANK */ + lnbprv = 0; + --idebwd[nwords-1]; + } else if (lapos2) { +/* ALL CHARACTERS ARE MASKED WHILE *LAPOS1* */ + ++maskck[jloop2-1]; + lapos2 = rwrite[iloop1-1] != '"'; + +/* MAKE AS IF PREVIOUS WAS BLANK */ + lnbprv = 0; + --idebwd[nwords-1]; + } else { + int_32 lnbcur = rwrite[iloop1-1] != ' '; + if (lnbcur) { +/* FIND A NON-BLANK CHARACTER, MASK IT */ + ++maskck[jloop2-1]; + if (lnbprv) { + --idebwd[nwords-1]; + } else { +/* PREVIOUS ONE WAS BLANK, LOOK FOR ' OR " */ + lapos1 = rwrite[iloop1-1] == '\''; + lapos2 = rwrite[iloop1-1] == '\"'; + if (lapos1 || lapos2) iapo12 = iloop1; +/* BEGIN A NEW WORD (REVERSED ORDER) */ + ++nwords; + ifinwd[nwords-1] = iloop1; + idebwd[nwords-1] = iloop1; + } + } else if (lnbprv) { +/* FIND A BLANK CHARACTER, BUT AFTER A NON-BLANK */ +/* THIS COULD BE A MISTAKE IF ' OR " ARE NOT IN USE. */ + if ((!lapos1 && rwrite[iloop1] == '\'') || (!lapos2 && rwrite[iloop1] == '\"')) { + cemask[iloop1] = '?'; + } + } + lnbprv = lnbcur; + } + } + if (lapos1 || lapos2) { + cemask[iapo12-1] = '?'; + lapos1 = 0; + lapos2 = 0; + } + if (strncmp(cemask, cbla120, 120) != 0) { + fprintf(iwrite, "%-120s\n", cemask); + fprintf(iwrite, "%-120s\n", terror[1]); + strncpy(cemask, cbla120, 120); + } +/* END: CONSTRUCT MASK NUMBERS */ + +/* BEGIN: IDENTITY TYPES AND PACK *JNDLEC* WITH (ITYP-1) DATA */ + for (iwords = 1; iwords <= nwords; ++iwords) { + char cdatin[121]; + int_32 jindex=0; + ilengv = ifinwd[iwords-1] - idebwd[iwords-1] + 1; + strncpy(cdatin, &rwrite[idebwd[iwords-1]-1], ilengv); cdatin[ilengv] = '\0'; + +/* DETERMINATION OF TYPE FOR THAT WORD */ + if (cdatin[0] == '\'' || cdatin[0] == '"') { + jndlec[iwords-1] = 2; + } else if (ilengv == 1) { + jindex = index_f(digped, &cdatin[0]); + if (jindex > 0 && jindex <= 10) { + jndlec[iwords-1] = 0; + } else { + jndlec[iwords-1] = 2; + l1lett = l1lett && index_f(onelet, &cdatin[0]) != 0; + } + } else { + int_32 ipoint = 0; + int_32 ifloat = 0; + int_32 idoubl = 0; + for (iloop1 = 1; iloop1 <= ilengv; ++iloop1) { + char cc[] = {cdatin[iloop1-1], '\0'}; + jindex = index_f(digped, cc); + if (jindex == 0) { + goto L62; + } else if (jindex == 11 || jindex == 12) { + if (iloop1 != 1) { +/* CHECK SIGN AFTER EXPONENT */ + if (iloop1 - 1 != ifloat && iloop1 - 1 != idoubl) { + jindex = 0; + goto L62; + } + } + } else if (jindex == 13) { + if (ipoint != 0) { + jindex = 0; + goto L62; + } + ipoint = iloop1; + } else if (jindex == 14) { + if (ifloat != 0 || iloop1 == 1) { + jindex = 0; + goto L62; + } + ifloat = iloop1; + } else if (jindex == 15) { + if (idoubl != 0 || iloop1 == 1) { + jindex = 0; + goto L62; + } + idoubl = iloop1; + } + } +L62: + if (jindex == 0) { + jndlec[iwords-1] = 2; + } else if (idoubl != 0) { + jndlec[iwords-1] = 3; + } else if (ifloat != 0 || ipoint != 0) { + jndlec[iwords-1] = 1; + } else { + jndlec[iwords-1] = 0; + } + } + jloop2 = (((nwords - iwords + 1) << 1) + 23) / 24; + ipacki[jloop2-1] <<= 2; + ipacki[jloop2-1] += jndlec[iwords-1]; + +/* COUNT FOR THE NUMBER OF *:=*, *<<.>>* AND *>>.<<* */ +/* AND THE NUMBER OF *$.* BEFORE *:=* */ + if (jndlec[iwords-1] == 2) { + if (ilengv == 2 && strcmp(cdatin, ":=") == 0) { + ++nequal; + } else if (ilengv >= 2) { + if (strncmp(cdatin, ">>", 2) == 0) { + lrecio = ilengv >= 5; + if (lrecio) { + lrecio = strcmp(&cdatin[ilengv-2], "<<") == 0 && cdatin[2] != '$'; + } + ++nrecio; + } else if (strncmp(cdatin, "<<", 2) == 0) { + lrecio = ilengv >= 5; + if (lrecio) { + lrecio = strcmp(&cdatin[ilengv-2], ">>") == 0 && cdatin[2] != '$'; + } + ++nrecio; + } + } + } + } +/* END: IDENTITY TYPES AND PACK *JNDLEC* WITH (ITYP-1) DATA */ + +/* NOW, LOOK FOR 1-ST WORD OF SENTENCES */ + if (lnwsen && jndlec[nwords-1] == 2 && ifinwd[nwords-1] - idebwd[nwords-1] <= 11) { + +/* RECOVER 1-ST WORD TO CHECK BEGIN OF SENTENCE */ + char cparin[13]; + strncpy(cparin, &rwrite[idebwd[nwords-1]-1], ifinwd[nwords-1] - idebwd[nwords-1] + 1); + cparin[ifinwd[nwords-1] - idebwd[nwords-1] + 1] = '\0'; + ilogin = 0; + for (iloop1 = 0; iloop1 < 15; ++iloop1) { + if (strcmp(cparin, clogbg[iloop1]) == 0) ilogin = iloop1 + 1; + } + +/* BACKWARD COMPATIBILITY ( *CHARACTER* / *PRINT* ) */ + if (strcmp(cparin, "CHARACTER") == 0) { + ilogin = 3; + strcpy(cerror, "! WARNING: *CHARACTER* => *STRING* (REPLACED)"); + fprintf(iwrite, "%s\n", cerror); + } else if (strcmp(cparin, "PRINT") == 0) { + ilogin = 7; + strcpy(cerror, "! WARNING: *PRINT* => *ECHO* (REPLACED)"); + fprintf(iwrite, "%s\n", cerror); + } + + if (ilogin == 0) { + strcpy(crecbg, " "); + strcpy(chrend, csemic); + } else { + strcpy(crecbg, clogbg[ilogin-1]); + strcpy(chrend, clognd[ilogin-1]); +/* KEYWORDS: *IF+/+WHILE+/+REPEAT* */ + if (ilogin == 9 || ilogin == 10 || ilogin == 13) { + if (nstlvl == ndimst) goto L7000; + ++nstlvl; + itylvl[nstlvl-1] = ilogin; + irclvl[nstlvl-1] = ninput + 1; +/* KEYWORDS: *ENDWHILE* */ + } else if (ilogin == 12) { + if (itylvl[nstlvl-1] != 10) goto L7001; +/* KEYWORDS: *UNTIL* */ + } else if (ilogin == 11) { + if (itylvl[nstlvl-1] != 13) goto L7001; +/* KEYWORD: *ELSEIF+/+ELSE* */ + } else if (ilogin == 8 || ilogin == 14) { + if (nstlvl == 0) goto L7000; + if (itylvl[nstlvl-1] != 8 && itylvl[nstlvl-1] != 9) goto L7001; + itylvl[nstlvl-1] = ilogin; +/* KEYWORD: *ENDIF* */ + } else if (ilogin == 15) { + if (itylvl[nstlvl-1] != 8 && itylvl[nstlvl-1] != 9 && itylvl[nstlvl-1] != 14) goto L7001; + } + +/* KEYWORDS: *UNTIL+/+ENDWHILE+/+ENDIF* */ + if (ilogin == 11 || ilogin == 12 || ilogin == 15) { + int_32 jrecor = ninput + 1; + if (nstlvl == 0) goto L7002; + irecor = irclvl[nstlvl-1]; + --nstlvl; + +/* REWRITE OLD RECORD TO KEEP LINK WITH THIS END */ + iofset = (irecor - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9003; + record1.irecor = jrecor; + iretcd = kdiput_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9001; + } + } + } + + if (ilogin == 0) { + ilevel = 0; +/* STATEMENTS OUTSIDE CLE-2000, STRINGS MUST BE '...' */ + for (iwords = 1; iwords <= nwords; ++iwords) { + if (jndlec[iwords-1] == 2 && rwrite[idebwd[iwords-1]-1] == '\"') { + cemask[idebwd[iwords-1]-1] = '?'; + cemask[ifinwd[iwords-1]-1] = '?'; + fprintf(iwrite, "%-120s\n", cemask); + strcpy(cerror, "! WARNING: OUTSIDE CLE-2000, ENCLOSE STRINGS IN '...' (REPLACED)"); + strncpy(cemask, cbla120, 120); + rwrite[idebwd[iwords-1]-1] = '\''; + rwrite[ifinwd[iwords-1]-1] = '\''; + } + } + } else { +/* FOR CLE-2000 STATEMENTS, */ +/* AND INVALID *ILENGV* > 12 FOR STRINGS NOT ENCLOSED BY "..." */ + for (iwords = 1; iwords <= nwords; ++iwords) { + if (jndlec[iwords-1] == 2 && rwrite[idebwd[iwords-1]-1] != '\"') { + if (rwrite[idebwd[iwords-1]-1] == '\'') { + cemask[idebwd[iwords-1]-1] = '?'; + cemask[ifinwd[iwords-1]-1] = '?'; + fprintf(iwrite, "%-120s\n", cemask); + strcpy(cerror, "! WARNING: INSIDE CLE-2000, ENCLOSE STRINGS IN \"...\" (REPLACED)"); + strncpy(cemask, cbla120, 120); + rwrite[idebwd[iwords-1]-1] = '\"'; + rwrite[ifinwd[iwords-1]-1] = '\"'; + } else { + if (ifinwd[iwords-1] - idebwd[iwords-1] > 11) goto L5012; + } + } + } + ilevel = nlevel + lvelbg[ilogin-1]; + maxlvl = max(maxlvl,ilevel); + nwrsen += nwords; + } + +/* RECOVER LAST WORD TO CHECK END OF SENTENCE */ + if (jndlec[0] == 2 && ifinwd[0] - idebwd[0] <= 11) { + strncpy(crecnd, &rwrite[idebwd[0]-1], ifinwd[0] - idebwd[0] + 1); + crecnd[ifinwd[0] - idebwd[0] + 1] = '\0'; + } else { + strcpy(crecnd, " "); + } + +/* WRITE RECORD OR PART OF IT */ + ++ninput; + iofset = (ninput - 1) * lrclen; + strcpy(record1.cparin, crecbg); + rwrite[120] = '\0'; + strcpy(record1.myreco, rwrite); + record1.ilines = ilines; + record1.ilevel = ilevel; + record1.irecor = irecor; + for (i = 0; i < nmaskc; i++) record1.maskck[i] = maskck[i]; + for (i = 0; i < nmaskc; i++) record1.ipacki[i] = ipacki[i]; + iretcd = kdiput_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9001; + if (!lrecio) goto L7005; + irecor = 0; + strcpy(crecbg, " "); + lnwsen = (strcmp(crecnd, chrend) == 0); + if (lnwsen) { + if (ilogin != 0) { + nlevel += lvelnd[ilogin-1]; + if (nrecio != 0) goto L7005; + if (!l1lett) goto L5001; +/* KEYWORDS: *INTEGER+/+REAL+/+STRING+/+DOUBLE+/+LOGICAL* */ + if (ilogin <= 5) { + if (nequal == 0) { + if (nwrsen <= 0) goto L7004; + } else if (nequal == 1) { + if (nwrsen <= 2) goto L7004; + } else { + goto L7003; + } + if (nlevel != 1) goto L7006; +/* KEYWORD: *EVALUATE+/ */ + } else if (ilogin == 6) { + if (nequal != 1) goto L7003; + if (nwrsen <= 2) goto L7004; +/* KEYWORDS: *ECHO+/+ELSEIF+/+IF+/+WHILE+/+UNTIL* */ + } else if (ilogin >= 7 && ilogin <= 11) { + if (nequal != 0) goto L7003; + if (nwrsen <= 0) goto L7004; +/* KEYWORDS: *REPEAT+/+ELSE* */ + } else if (ilogin == 13 || ilogin == 14) { + if (nequal != 0) goto L7003; + if (nwrsen != -1) goto L7004; +/* KEYWORDS: *ENDWHILE+/+ENDIF* */ + } else if (ilogin == 12 || ilogin == 15) { + if (nequal != 0) goto L7003; + if (nwrsen != 0) goto L7004; + } + } else { +/* USE OF <<.>> OR >>.<<, BUT STILL NO CLE-2000 INSTRUCTION */ + if (maxlvl == 0 && nrecio != 0) goto L7005; + } +/* RESET NUMBER OF EQUALS, WORDS, <<.>> >>.<<, $. */ + nequal = 0; + nwrsen = -2; + nrecio = 0; + l1lett = 1; + } + if (strncmp(myreco, cbla120, 120) != 0) goto L30; + goto L10; +L100: + memcpy(myreco, "QUIT .", 6); + fprintf(iwrite, "%-120sIMPLICIT\n",myreco); + memcpy(myreco, " .", 6); +L200: + if (nlevel != 1 || strcmp(chrend, csemic) != 0) goto L7007; + fprintf(iwrite, " \n"); + strncpy(rwrite, cbla120, 120); + jfndbg = index_f(myreco, "\""); + if (jfndbg != 0) { + jfndnd = index_f(&myreco[jfndbg], "\"") + jfndbg; + if (jfndnd == jfndbg) { + cemask[jfndbg-1] = '?'; + printf("%s\n", cemask); + printf("%s\n", terror[6]); + ++ret_val; + strncpy(cemask, cbla120, 120); + } else { + strncpy(rwrite, &myreco[jfndbg], jfndnd - jfndbg - 1); + strncpy(&myreco[jfndbg-1], cbla120, jfndnd - jfndbg + 1); + } + } + if (index_f(rwrite, "NODEBUG") == 0) { + if (index_f(rwrite, "DEBUG") != 0) idblst = 1; + } + if (index_f(rwrite, "NOXREF") == 0) { + if (index_f(rwrite, "XREF") != 0) ixrlst = 1; + } + if (index_f(rwrite, "NOLIST") == 0) { + if (index_f(rwrite, "LIST") != 0) ioulst = 1; + } + jfndnd = index_f(myreco, "."); + if (jfndnd == 0) { + printf("%s\n", terror[6]); + ++ret_val; + } else { + myreco[jfndnd-1] = ' '; + } + if (strncmp(myreco, cbla120, 120) != 0) { + printf("%s\n", terror[6]); + ++ret_val; + } + +/* REWRITE TOP OF OBJECT FILE TO KEEP THE NUMBER OF RECORDS */ +/* AND THE MAXIMUM LEVEL; TRANSMIT LAST STRING AS TITLE */ + nrecor = ninput; + rwrite[120] = '\0'; + strcpy(header.cdatin, rwrite); + header.nrecor = nrecor; + header.ninput = ninput; + header.maxlvl = maxlvl; + header.nstack = nstack; + header.ixrlst = ixrlst; + header.ioulst = ioulst; + header.idblst = idblst; + iretcd = kdiput_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9001; + +L666: + return ret_val; + +L5000: + printf("! %s: INPUT LINE OVERFLOW\n", nomsub); + strncpy(myreco, &recred[65], 120); myreco[120] = '\0'; + printf("! -->%s<--\n",myreco); + ret_val = 5000; + goto L666; +L5001: + printf("! %s: INVALID 1-CHARACTER WORD IN CLE-2000\n", nomsub); + ret_val = 5001; + goto L666; +L5012: + printf("! %s: MORE THAN 12-CHARACTER WORD IN CLE-2000\n", nomsub); + ret_val = 5012; + goto L666; +L7000: + printf("! %s: KEYWORD= *%s*, BUT MAXIMUM NUMBER OF LEVELS IS ACHIEVED\n", nomsub, clogbg[ilogin-1]); + printf("! %s: REVISE YOUR LOGIC\n", nomsub); + ret_val = 7000; + goto L666; +L7001: + printf("! %s: AFTER *%s*, NOT EXPECTING KEYWORD= *%s\n", + nomsub, clogbg[itylvl[nstlvl-1]-1], clogbg[ilogin-1]); + printf("! %s: REVISE YOUR LOGIC\n", nomsub); + ret_val = 7001; + goto L666; +L7002: + printf("! %s: KEYWORD= *%s*, BUT NOTHING LEFT FOR THIS LEVEL\n", nomsub, clogbg[ilogin-1]); + printf("! %s: REVISE YOUR LOGIC\n", nomsub); + ret_val = 7002; + goto L666; +L7003: + printf("! %s: KEYWORD= *%s*, BUT THE NUMBER OF EQUALS *:=* IS %d\n", + nomsub, clogbg[ilogin-1], (int)nequal); + ret_val = 7003; + goto L666; +L7004: + printf("! %s: KEYWORD= *%s*, BUT THE NUMBER OF WORDS IS %d\n", + nomsub, clogbg[ilogin-1], (int)nwrsen); + ret_val = 7003; + goto L666; +L7005: + printf("! %s: INVALID <<.>> OR >>.<< INSTRUCTION\n", nomsub); + ret_val = 7005; + goto L666; +L7006: + printf("! %s: DECLARATION AS *%s* MUST APPEAR AT LOGIC LEVEL 1\n", nomsub, clogbg[ilogin-1]); + ret_val = 7006; + goto L666; +L7007: + printf("! %s: INCONSISTENT END-OF-FILE, LOGIC LEVEL IS %d > 1\n", nomsub, (int)nlevel); + printf("! %s: EXPECTING *%s* AT THE END OF STATEMENT\n", nomsub, crecbg); + ret_val = 7007; + goto L666; +L9001: + iretcd = -1; + printf("! %s: WRITING RETURN CODE = %d\n", nomsub, (int)iretcd); + ret_val = iretcd; + goto L666; +L9003: + iretcd = -1; + printf("! %s: READING RETURN CODE = %d\n", nomsub, (int)iretcd); + ret_val = iretcd; + goto L666; +} /* clelog */ diff --git a/Ganlib/src/clemod_c.c b/Ganlib/src/clemod_c.c new file mode 100644 index 0000000..9ef8ad7 --- /dev/null +++ b/Ganlib/src/clemod_c.c @@ -0,0 +1,79 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 19/06/09 */ +/*****************************************/ + +/* Call a single module without a CLE-2000 procedure */ + +#include <string.h> +#include "cle2000.h" +int_32 clemod_c(char *cmodul, FILE *filein, int_32 nentry, char (*hentry)[13], int_32 *ientry, + int_32 *jentry, lcm **kentry, char (*hparam)[73], + int_32 (*dummod)(char *, int_32, char (*)[13], int_32 *, int_32 *, lcm **, char (*)[73])) +{ + char *nomsub = "clemod_c"; + int_32 ret_val = 0; + FILE *jwrite; + char hsmg[132], filenm[8]; + int_32 iretcd, jrecin; + kdi_file *iKDI; + char hwrite[73] = " "; + +/* first step, initialize stuff and compile main */ + sprintf(filenm,"_FIL%.3d",0); + iKDI = kdiop_c(filenm,0); + if (iKDI == NULL) { + sprintf(hsmg, "%s: kdiop failure\n", nomsub); + printf("%s\n", hsmg); + ret_val = -1; + goto L10; + } + +/* compile main input into object file */ + iretcd = clepil(filein, stdout, iKDI, clecst); + if (iretcd != 0) { + sprintf(hsmg, "%s: COMPILING _MAIN.c2m FILE (ERROR CODE) IRC=%d\n", nomsub,(int)iretcd); + printf("%s\n", hsmg); + ret_val = -2; + goto L10; + } + +/* add objects/modules to object file */ + iretcd = objpil(iKDI, stdout, 1); + if (iretcd != 0) { + sprintf(hsmg, "%s: BAD OBJECTS _MAIN.c2m FILE (ERROR CODE) IRC=%d\n", nomsub,(int)iretcd); + printf("%s\n", hsmg); + ret_val = -3; + goto L10; + } + +/* execute a module of the software application */ + redopn_c(iKDI, stdout, hwrite, 0); + fflush(stdout); + if (strcmp(cmodul, "END:") == 0) { + printf("%s: dummy END: module called\n", nomsub); + ret_val = 0; + } else { + iretcd = (*dummod)(cmodul, nentry, hentry, ientry, jentry, kentry, hparam); + if (iretcd != 0) { + sprintf(hsmg, "%s: calculation module failure IRC=%d\n", nomsub,(int)iretcd); + printf("%s\n", hsmg); + ret_val = -4; + goto L10; + } + } + +/* close the REDGET input reader */ + redcls_c(&iKDI, &jwrite, hwrite, &jrecin); + iretcd = kdicl_c(iKDI, 2); + if (iretcd != 0) { + sprintf(hsmg, "%s: kdicl failure IRC=%d\n", nomsub,(int)iretcd); + printf("%s\n", hsmg); + ret_val = -5; + } +L10: + fflush(stdout); + return ret_val; +} diff --git a/Ganlib/src/cleopn.c b/Ganlib/src/cleopn.c new file mode 100644 index 0000000..c842a1f --- /dev/null +++ b/Ganlib/src/cleopn.c @@ -0,0 +1,96 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* LIFO stack utility for CLE-2000 */ +/* AUTHOR: A. Hebert ; 27/07/10 */ +/*****************************************/ + +#include <stdlib.h> +#include <string.h> +#include "cle2000.h" + +void cleopn(lifo **my_lifo) +{ + (*my_lifo) = (lifo *) malloc(sizeof(lifo)); + (*my_lifo)->nup = 0; + (*my_lifo)->root = NULL; + (*my_lifo)->node = NULL; +} +lifo_node * clepop(lifo **my_lifo) +{ + lifo_node *my_node; + if ((*my_lifo)->nup == 0) return NULL; + my_node = (*my_lifo)->node; + (*my_lifo)->node = my_node->daughter; + my_node->daughter = NULL; + (*my_lifo)->nup--; + return my_node; +} +void clepush(lifo **my_lifo, lifo_node *my_node) +{ + lifo_node *daughter_node; + if ((*my_lifo)->nup == 0) { + (*my_lifo)->root = my_node; + daughter_node = NULL; + } else { + daughter_node = (*my_lifo)->node; + } + (*my_lifo)->node = my_node; + (*my_lifo)->node->daughter = daughter_node; + (*my_lifo)->nup++; +} +int_32 clecls(lifo **my_lifo) +{ + if ((*my_lifo)->nup != 0) return -1; + free(*my_lifo); + (*my_lifo) = NULL; + return 0; +} +lifo_node * clenode(lifo **my_lifo, const char *name) +{ + lifo_node *my_node; + my_node = (*my_lifo)->node; + if (my_node == NULL) return NULL; + while (my_node->daughter != NULL) { + if (strcmp(my_node->name, name) == 0) return my_node; + my_node = my_node->daughter; + } + if (strcmp(my_node->name, name) == 0) return my_node; + return NULL; +} +lifo_node * clepos(lifo **my_lifo, int_32 ipos) +{ + lifo_node *my_node; + int_32 iloop; + if ((ipos > (*my_lifo)->nup - 1) || (ipos < 0)) return NULL; + my_node = (*my_lifo)->node; + for (iloop = 0; iloop < (*my_lifo)->nup - ipos - 1; ++iloop) { + my_node = my_node->daughter; + } + return my_node; +} +void clelib(lifo **my_lifo) +{ + lifo_node *my_node; + int_32 iloop; + printf("\n lifo content:\n node type name........ access OSname/value\n"); + for (iloop = 0; iloop < (*my_lifo)->nup; ++iloop) { + my_node = clepos(my_lifo, iloop); + if (abs((int)my_node->type) < 10) { + printf(" %4d (%4d) %12s (%2d) %s\n", (int)iloop, (int)my_node->type, my_node->name, (int)my_node->access, my_node->OSname); + } else if ((int)my_node->type == 11) { + printf(" %4d (%4d) %12s val = %d\n", (int)iloop, (int)my_node->type, my_node->name, my_node->value.ival); + } else if ((int)my_node->type == 12) { + printf(" %4d (%4d) %12s val = %e\n", (int)iloop, (int)my_node->type, my_node->name, my_node->value.fval); + } else if ((int)my_node->type == 13) { + printf(" %4d (%4d) %12s val = '%s'\n", (int)iloop, (int)my_node->type, my_node->name, my_node->value.hval); + } else if ((int)my_node->type == 14) { + printf(" %4d (%4d) %12s val = %e\n", (int)iloop, (int)my_node->type, my_node->name, my_node->value.dval); + } else if ((int)my_node->type == 15) { + printf(" %4d (%4d) %12s val = %d\n", (int)iloop, (int)my_node->type, my_node->name, my_node->value.ival); + } else { + printf(" %4d (%4d) %12s\n", (int)iloop, (int)my_node->type, my_node->name); + } + } + printf("\n access= 0:creation mode / 1:modification mode / 2:read-only mode\n\n"); +} diff --git a/Ganlib/src/clepil.c b/Ganlib/src/clepil.c new file mode 100644 index 0000000..7aeeb54 --- /dev/null +++ b/Ganlib/src/clepil.c @@ -0,0 +1,60 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 15/05/09 */ +/*****************************************/ + +#include <string.h> +#include "cle2000.h" + +int_32 clepil(FILE *iredin, FILE *iwrite, kdi_file *iunito, + int_32 (*dumcst)(char *, int_32 *, int_32 *, float_32 *, char *, double_64 *)) +{ + +/* CLE-2000 SYSTEM: R.ROY (03/1999), VERSION 2.1 */ + +/* *CLEPIL* WILL PERFORM A SYNTACTICAL ANALYSIS */ +/* AND COMPILE THE INPUT UNIT *IREDIN*. */ +/* RESULT IS THE OBJECT D.A. UNIT *IUNITO* */ +/* COMPILER COMMENTS ARE WRITTEN ON UNIT *IWRITE* */ +/* WORDS ARE SEPARATED AND CLASSIFIED BY TYPES. */ +/* EVERYTHING IS CHECKED FOR CORRECT EXECUTION. */ + +/* INPUT: *IREDIN* IS THE INPUT UNIT */ +/* *IWRITE* IS THE OUTPUT UNIT FOR COMPILER COMMENTS */ +/* *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */ +/* *DUMCST* IS THE EXTERNAL FUNCTION FOR *CLE-2000* CONSTANTS */ + +/* NOTE: *CLEPIL* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */ + + char *nomsub = "clepil"; + char *clistc[] = {"clelog", "clestk", "clexrf"}; + int_32 iretcd, istepc; + int_32 ret_val = 0; + +/* CONSTRUCT OBJECT FILE AND ANALYSE LOGIC */ + istepc = 0; + iretcd = clelog(iredin, iwrite, iunito); + if (iretcd != 0) goto L9002; + +/* ADD CLE-2000 VARIABLES */ + istepc = 1; + iretcd = clestk(iunito, iwrite, dumcst); + if (iretcd != 0) goto L9002; + istepc = 3; + +/* X-REF CLE-2000 VARIABLES */ + istepc = 2; + iretcd = clexrf(iunito, iwrite); + if (iretcd != 0) goto L9002; + +L666: + return ret_val; + +L9002: + printf("! %s: ERROR CODE IN >>%s<< ERROR NUMBER (%d)\n", nomsub, clistc[istepc], (int)iretcd); + ret_val = iretcd; + goto L666; + +} /* clepil */ diff --git a/Ganlib/src/clestk.c b/Ganlib/src/clestk.c new file mode 100644 index 0000000..607757e --- /dev/null +++ b/Ganlib/src/clestk.c @@ -0,0 +1,685 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 11/05/09 */ +/*****************************************/ + +#include <stdlib.h> +#include <string.h> +#include "cle2000.h" +#include "header.h" +#define index_f(A, B) (strstr(A, B) == NULL ? 0 : strstr(A, B) - A + 1) +#define ndimst 128 +#define nmawrd 60 + +int_32 clestk(kdi_file *iunito, FILE *iwrite, + int_32 (*dumcst)(char *, int_32 *, int_32 *, float_32 *, char *, double_64 *)) +{ + char *nomsub = "clestk"; + static char cerror[] = "* CLE-2000 VERS 3.0 * ERROR FOUND FOR THIS LINE *"; + static char cl2000[] = "CLE2000(V3)"; + static char cequal[] = ":="; + static char alphab[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"; + static char digits[] = "0123456789"; + static char *ckeywd[] = {"INTEGER", "REAL", "STRING", "DOUBLE", "LOGICAL", "EVALUATE", "ECHO", "ELSEIF", + "IF", "WHILE", "UNTIL", "ENDWHILE", "REPEAT", "ELSE", "ENDIF", "THEN", "DO", + "QUIT", "NOT", "ABS", "CHS", "LN", "SIN", "COS", "TAN", "ARCSIN", "ARCCOS", + "ARCTAN", "EXP", "SQRT", "R_TO_I", "D_TO_I", "I_TO_R", "D_TO_R", "I_TO_D", + "R_TO_D", "I_TO_S", "I_TO_S4", "_MIN_", "_MAX_", "_TRIM_"}; + static char *clognd[] = {";", ";", ";", ";", ";", ";", ";", "THEN", "THEN", "DO", + ";", ";", "REPEAT", "ELSE", ";"}; + +/* CLE-2000 SYSTEM: R.ROY (11/1999), VERSION 3.0 */ + +/* *CLESTK* SECOND-PASS COMPILE OF THE D.A. UNIT *IUNITO* */ +/* RESULT IS STILL THE OBJECT D.A. UNIT *IUNITO* */ +/* COMPILER COMMENTS ARE WRITTEN ON UNIT *IWRITE* */ +/* STACK IS BUILT AT THE END OF *IUNITO* */ + +/* USE: VARIABLE NAMES ARE DEFINED AND ALLOCATED, */ +/* CONSISTENCE OF TYPES IN EVALUATIONS IS CHECKED, */ +/* <<.>> AND >>.<< STATEMENTS ARE ALSO CHECKED. */ + +/* INPUT: *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */ +/* *IWRITE* IS THE OUTPUT UNIT FOR COMPILER COMMENTS */ +/* *DUMCST* IS THE EXTERNAL FUNCTION FOR *CLE-2000* CONSTANTS */ + +/* NOTE: *CLESTK* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */ + + int_32 ret_val = 0; + char cparin[13], myreco[121], cdatin[121], cparav[13]; + int_32 indrgt[ndimst], indlft[ndimst], irclft[ndimst]; + int_32 idebwd[nmawrd+1], ifinwd[nmawrd+1], jndlec[nmawrd]; + float_32 adatin; + double_64 ddatin; + int_32 maskck[nmaskc], ipacki[nmaskc]; + int_32 i, iretcd, nrecor, ninput, maxlvl, nstack, iofset, ilines, ilevel, + indlin, idclin, idefin, iusein, idatin, iloop1, jloop2; + int_32 ivabeg, ivaend, ilogin, nstlft, nstrgt; + int_32 irecor; + int_32 lequal=0; + +/* READ TOP OF OBJECT FILE */ + iretcd = kdiget_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9023; + strcpy(cparin, header.cparin); + strcpy(myreco, header.cdatin); + nrecor = header.nrecor; + ninput = header.ninput; + maxlvl = header.maxlvl; + nstack = header.nstack; + if (strcmp(cparin, cl2000) != 0) goto L9025; + if (nstack != 0) goto L9025; + +/* CASE WHERE THERE ARE NO CLE-2000 SENTENCES */ + if (maxlvl == 0) goto L666; + ivabeg = ninput; + ivaend = ninput; + ilogin = 0; + nstlft = 0; + nstrgt = 0; + +/* *** MAIN LOOP OVER RECORDS (BEGIN) */ + for (irecor = 2; irecor <= ninput; ++irecor) { + +/* READ A NEW RECORD */ + iofset = (irecor - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record1.cparin); + strcpy(myreco, record1.myreco); + ilines = record1.ilines; + ilevel = record1.ilevel; + for (i = 0; i < nmaskc; i++) maskck[i] = record1.maskck[i]; + for (i = 0; i < nmaskc; i++) ipacki[i] = record1.ipacki[i]; + +/* RECORDS OUTSIDE CLE-2000, CHECK >>.<< DEFINITIONS */ +/* AND <<.>> USES (FOR DECLARED VARIABLE) */ + if (ilevel == 0) { +L10: + iloop1 = index_f(myreco, ">>"); + jloop2 = index_f(myreco, "<<"); + if (iloop1 != 0 || jloop2 != 0) { + int_32 ilowrc = ivabeg; + int_32 ihigrc = ivaend + 1; + + if (iloop1 == 0) goto L5006; + if (jloop2 == 0) goto L5006; + +/* RECOVER VARIABLE NAME INSIDE <<.>> OR >>.<< */ + if (jloop2 > iloop1) { + strncpy(cparav, &myreco[iloop1+1], jloop2-iloop1-2); cparav[jloop2-iloop1-2] = '\0'; + for (i = iloop1-1; i < jloop2+1; i++) myreco[i] = ' '; + } else { + strncpy(cparav, &myreco[jloop2+1], iloop1-jloop2-2); cparav[iloop1-jloop2-2] = '\0'; + for (i = jloop2-1; i < iloop1+1; i++) myreco[i] = ' '; + } +L11: + if (ihigrc - ilowrc <= 1) { +/* VARIABLE WAS NOT FOUND (USED BEFORE DECLARED...) */ + goto L5004; + } else { + int_32 imedrc = (ihigrc + ilowrc) / 2; + iofset = (imedrc - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9003; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idatin = record2.idatin; + adatin = record2.adatin; + ddatin = record2.ddatin; + idclin = record2.idclin; + idefin = record2.idefin; + iusein = record2.iusein; + if (strcmp(cparin, cparav) == 0) { + if (jloop2 > iloop1 && idefin == 0) { +/* CHANGE FIRST DEFINED LINE FOR >>.<< */ + record2.idefin = ilines; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } else if (iloop1 > jloop2 && iusein == 0) { +/* CHANGE FIRST USED LINE FOR <<.>> */ + record2.iusein = ilines; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } + } else if (strcmp(cparin, cparav) < 0) { + ilowrc = imedrc; + goto L11; + } else { + ihigrc = imedrc; + goto L11; + } + } + goto L10; + } + +/* RECORDS INSIDE CLE-2000, CHECK ALL DECLARATIONS AND DEFINITIONS */ + } else { + char chrend[13]; + int_32 logprv = (ilogin == 0); + int_32 iwords = 1; + int_32 nwords = 1; + int_32 jbiprv = 0; + if (logprv) { + for (iloop1 = 1; iloop1 <= 11; ++iloop1) { + if (strcmp(cparin, ckeywd[iloop1-1]) == 0) ilogin = iloop1; + } + if (ilogin == 0) goto L100; + +/* KEYWORDS: *ECHO+/+ELSEIF+/+IF+/+WHILE+/+UNTIL* */ +/* ASSUME THAT THERE WAS AN *:=* SIGN */ +/* (AS IF WE WERE THEN ON RIGHT SIDE OF AN EVALUATE) */ + lequal = ilogin > 6; + if (lequal) { + nstlft = 1; + indlft[0] = 5; + } + strcpy(chrend, clognd[ilogin-1]); + } + +/* HERE, WE HAVE FOUND A SENTENCE INCLUDING A STACK... */ + +/* BEGIN: MASK RECOVERY */ + for (iloop1 = 1; iloop1 <= 120; ++iloop1) { + int_32 jbicur; + jloop2 = (iloop1 + 23) / 24; + jbicur = maskck[jloop2 - 1] % 2; + iwords += jbiprv * (1 - jbicur); + idebwd[nwords-1] = iloop1; + ifinwd[iwords-1] = iloop1; + nwords += jbicur * (1 - jbiprv); + jbiprv = jbicur; + maskck[jloop2 - 1] /= 2; + } + --nwords; +/* END: MASK RECOVERY */ + + if (logprv) { +/* THIS IS A NEW *ILOGIN* */ + if (nwords == 1) goto L100; + +/* START AT CURRENT WORD NUMBER 2 */ + iwords = 2; + } else { +/* THIS IS NOW THE FIRST WORD, BUT WITH AN OLD *ILOGIN* */ + iwords = 1; + } + +/* BEGIN: UNPACK JNDLEC WITH TYPES (ITYP-1) */ + for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { + jloop2 = ((iloop1 << 1) + 23) / 24; + jndlec[iloop1-1] = ipacki[jloop2-1] % 4; + ipacki[jloop2-1] /= 4; + } +/* END: UNPACK JNDLEC WITH TYPES (ITYP-1) */ + + for (iloop1 = iwords; iloop1 <= nwords; ++iloop1) { + if (jndlec[iloop1-1] == 2 && myreco[idebwd[iloop1-1]-1] != '\"') { + strncpy(cparav, &myreco[idebwd[iloop1-1]-1], ifinwd[iloop1-1]-idebwd[iloop1-1]+1); + cparav[ifinwd[iloop1-1]-idebwd[iloop1-1]+1] = '\0'; + if (strcmp(cparav, chrend) == 0) { + if (iloop1 != nwords) goto L9010; +/* END OF STATEMENT REACHED */ + +/* CHECK CONSISTENCY ON NUMBER OF LEFT/RIGHT EVALUATIONS */ + if (ilogin != 7 && lequal) { + if (nstlft != nstrgt) goto L9008; + for (jloop2 = 1; jloop2 <= nstlft; ++jloop2) { + if (indrgt[jloop2-1] != indlft[jloop2-1]) goto L9009; + } + } + +/* RESET *ILOGIN* AND LEFT/RIGHT NUMBERS */ + ilogin = 0; + nstlft = 0; + nstrgt = 0; + } else if (lequal) { +/* RIGHT-SIDE: VALUES, OPERATIONS & VARIABLES */ +/* VALUES ARE NOW EXCLUDED, STILL OPERATIONS & VARIABLES */ +/* CHECK CONVERSION OPERATIONS */ + if (strcmp(cparav, "R_TO_I") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 2) goto L8001; + indrgt[nstrgt-1] = 1; + } else if (strcmp(cparav, "D_TO_I") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 4) goto L8001; + indrgt[nstrgt-1] = 1; + } else if (strcmp(cparav, "I_TO_R") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 1) goto L8001; + indrgt[nstrgt-1] = 2; + } else if (strcmp(cparav, "D_TO_R") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 4) goto L8001; + indrgt[nstrgt-1] = 2; + } else if (strcmp(cparav, "I_TO_D") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 1) goto L8001; + indrgt[nstrgt-1] = 4; + } else if (strcmp(cparav, "R_TO_D") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 2) goto L8001; + indrgt[nstrgt-1] = 4; + } else if (strcmp(cparav, "I_TO_S") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 1) goto L8001; + indrgt[nstrgt-1] = 3; + } else if (strcmp(cparav, "I_TO_S4") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 1) goto L8001; + indrgt[nstrgt-1] = 3; + +/* CHECK UNARY OPERATIONS */ + } else if (strcmp(cparav, "NOT") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 5) goto L8002; + } else if (strcmp(cparav, "CHS") == 0 || strcmp(cparav, "ABS") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 1 && indrgt[nstrgt-1] != 2 && indrgt[nstrgt-1] != 4) { + goto L8002; + } + } else if (strcmp(cparav, "EXP") == 0 || strcmp(cparav, "LN") == 0 + || strcmp(cparav, "SIN") == 0 || strcmp(cparav, "COS") == 0 + || strcmp(cparav, "TAN") == 0 || strcmp(cparav, "ARCSIN") == 0 + || strcmp(cparav, "ARCCOS") == 0 || strcmp(cparav, "ARCTAN") == 0 + || strcmp(cparav, "SQRT") == 0) { + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 2 && indrgt[nstrgt-1] != 4) goto L8003; + +/* CHECK BINARY OPERATIONS */ + } else if (strcmp(cparav, "_MIN_") == 0 || strcmp(cparav, "_MAX_") == 0) { + --nstrgt; + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 1 && indrgt[nstrgt-1] != 2 && indrgt[nstrgt-1] != 4) { + goto L8006; + } + if (indrgt[nstrgt-1] != indrgt[nstrgt]) { + goto L8006; + } + } else if (strcmp(cparav, "_TRIM_") == 0) { + --nstrgt; + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 2 && indrgt[nstrgt-1] != 4) { + goto L8007; + } + if (indrgt[nstrgt] != 1) { + goto L8007; + } + } else if (strcmp(cparav, "+") == 0 || strcmp(cparav, "-") == 0) { + --nstrgt; + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != indrgt[nstrgt]) goto L8004; + } else if (strcmp(cparav, "*") == 0 || strcmp(cparav, "/") == 0) { + --nstrgt; + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] == 3) goto L8004; + if (indrgt[nstrgt-1] != indrgt[nstrgt]) goto L8004; + } else if (strcmp(cparav, "%") == 0) { + --nstrgt; + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 1) goto L8004; + if (indrgt[nstrgt-1] != indrgt[nstrgt]) goto L8004; + } else if (strcmp(cparav, "**") == 0) { + --nstrgt; + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] != 1 && indrgt[nstrgt-1] != 2 && indrgt[nstrgt-1] != 4) goto L8004; + if (indrgt[nstrgt-1] != indrgt[nstrgt]) goto L8004; + } else if (strcmp(cparav, "<") == 0 || strcmp(cparav, ">") == 0 + || strcmp(cparav, "=") == 0 || strcmp(cparav, "<=") == 0 + || strcmp(cparav, ">=") == 0 || strcmp(cparav, "<>") == 0) { + --nstrgt; + if (nstrgt <= 0) goto L9006; + if (indrgt[nstrgt-1] == 5) goto L8005; + if (indrgt[nstrgt-1] != indrgt[nstrgt]) goto L8005; + indrgt[nstrgt-1] = 5; + } else { +/* RIGHT-SIDE VARIABLES (FOR ... := ... ; ) */ +/* USING *CPARAV* VARIABLE, SCAN ALL DECLARED VARIABLES */ + int_32 ilowrc = ivabeg; + int_32 ihigrc = ivaend + 1; +L41: + if (ihigrc - ilowrc <= 1) { +/* VARIABLE NOT FOUND */ + if (cparav[0] != '$') goto L5004; +/* ONLY INTERESTED IN PARAMETRIC CONSTANTS */ + ++ivaend; + +/* SHIFT GREATER VARIABLES */ + if (ihigrc != ivaend) { + for (jloop2 = ivaend - 1; jloop2 >= ihigrc; --jloop2) { + iofset = (jloop2 - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9003; + iofset = jloop2 * lrclen; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } + } + +/* NEW PARAMETRIC CONSTANT FOUND ? => CALL *CLECST* */ + iretcd = (*dumcst)(cparav, &indlin, &idatin, &adatin, cdatin, &ddatin); + if (iretcd != 0) goto L5005; + +/* VALID PARAMETRIC CONSTANT, WRITE AT END */ + iofset = (ihigrc - 1) * lrclen; + strcpy(record2.cparin, cparav); + strcpy(record2.cdatin, cdatin); + record2.indlin = indlin; + record2.idatin = idatin; + record2.adatin = adatin; + record2.ddatin = ddatin; + record2.idclin = ilines; + record2.idefin = ilines; + record2.iusein = ilines; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } else { + int_32 imedrc = (ihigrc + ilowrc) / 2; + iofset = (imedrc - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9003; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idatin = record2.idatin; + adatin = record2.adatin; + ddatin = record2.ddatin; + idclin = record2.idclin; + idefin = record2.idefin; + iusein = record2.iusein; + if (strcmp(cparin, cparav) == 0) { + if (iusein == 0) { +/* CHANGE FIRST USED LINE FOR VARIABLE */ + record2.iusein = ilines; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } + } else if (strcmp(cparin, cparav) < 0) { + ilowrc = imedrc; + goto L41; + } else { + ihigrc = imedrc; + goto L41; + } + } + if (nstrgt == ndimst) goto L9005; + ++nstrgt; + indrgt[nstrgt-1] = abs(indlin); + } + } else { + if (strcmp(cparav, cequal) == 0) { + lequal = 1; +/* FIRST DEFINED LINE FOR LEFT ( := ) VARIABLES FOR */ +/* KEYWORDS: *INTEGER+/+REAL+/+STRING+/+DOUBLE+/+LOGICAL* */ + if (ilogin != 6) { + for (jloop2 = 1; jloop2 <= nstlft; ++jloop2) { + iofset = (irclft[jloop2 - 1] - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9003; + record2.idefin = record2.idclin; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } + } + } else { + int_32 ilowrc = ivabeg; + int_32 ihigrc = ivaend + 1; + +/* DECLARATION FOR A VARIABLE */ +/* ( PARAMETRIC CONSTANTS SHOULD NOT BE DECLARED) */ + if (cparav[0] == '$') goto L5002; +/* NEW VARIABLE NAME FOUND ? */ +L44: +/* BINARY SEARCH (WITH POSSIBLE INSERTION) */ + if (ihigrc - ilowrc <= 1) { +/* NEW VARIABLE NAME FOUND (INVALID *EVALUATE*) */ + ++ivaend; + if (ilogin == 6) goto L5004; + +/* CHECK IF VARIABLE NAME COMPLIES WITH THE RULES */ + for (jloop2 = 2; jloop2 <= strlen(cparav); ++jloop2) { + char cc[] = {cparav[jloop2-1], '\0'}; + int_32 jin1 = index_f(alphab, cc); + int_32 jin2 = index_f(digits, cc); + int_32 jin3 = index_f(cc, " "); + if (jin1 + jin2 + jin3 == 0) { + printf("%s: CHARACTER *%c* IS NOT ALLOWED\n", nomsub, cc[0]); + goto L5001; + } + } + +/* CHECK IF VARIABLE NAME IS A KEYWORD */ + for (jloop2 = 1; jloop2 <= 40; ++jloop2) { + if (strcmp(cparav, ckeywd[jloop2-1]) == 0) { + printf("%s: VARIABLE *%s* IS A CLE-2000 KEYWORD\n", nomsub, cparav); + goto L5001; + } + } + +/* SHIFT GREATER VARIABLES */ + if (ihigrc != ivaend) { + for (jloop2 = ivaend - 1; jloop2 >= ihigrc; --jloop2) { + iofset = (jloop2 - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9003; + iofset = jloop2 * lrclen; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } + if (nstlft != 0) { + for (jloop2 = 0; jloop2 < nstlft; ++jloop2) { + if (irclft[jloop2] >= ihigrc) ++irclft[jloop2]; + } + } + } + for (i = 0; i < 120; i++) cdatin[i] = ' '; + cdatin[120] = '\0'; + indlin = -ilogin; + idatin = 0; + adatin = 0.f; + ddatin = 0.; + idclin = ilines; + idefin = 0; + iusein = 0; + +/* VALID VARIABLE NAME, WRITE AT *IHIGRC* */ + iofset = (ihigrc - 1) * lrclen; + strcpy(record2.cparin, cparav); + strcpy(record2.cdatin, cdatin); + record2.indlin = indlin; + record2.idatin = idatin; + record2.adatin = adatin; + record2.ddatin = ddatin; + record2.idclin = idclin; + record2.idefin = idefin; + record2.iusein = iusein; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + +/* COUNT LEFT VARIABLES (FOR ... := ... ; ) AND */ +/* KEEP RECORD NUMBER (IN CASE OF := DEFINITION) */ + if (nstlft == ndimst) goto L9005; + ++nstlft; + irclft[nstlft-1] = ihigrc; + indlft[nstlft-1] = ilogin; + } else { + int_32 imedrc = (ihigrc + ilowrc) / 2; + iofset = (imedrc - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9003; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idatin = record2.idatin; + adatin = record2.adatin; + ddatin = record2.ddatin; + idclin = record2.idclin; + idefin = record2.idefin; + iusein = record2.iusein; + if (strcmp(cparin, cparav) == 0) { + if (ilogin == 6) { + if (idefin == 0) { +/* CHANGE FIRST DEFINED LINE FOR VARIABLE */ + record2.idefin = ilines; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } else if (nstlft != 0) { +/* VARIABLE DEFINED ONCE IN *EVALUATE* ? */ + for (jloop2 = 1; jloop2 <= nstlft; ++jloop2) { + if (imedrc == irclft[jloop2 - 1]) goto L5007; + } + } + if (nstlft == ndimst) goto L9005; + ++nstlft; + indlft[nstlft-1] = abs(indlin); + irclft[nstlft-1] = imedrc; + } else { +/* VARIABLE ALREADY DECLARED */ + goto L5003; + } + } else if (strcmp(cparin, cparav) < 0) { + ilowrc = imedrc; + goto L44; + } else { + ihigrc = imedrc; + goto L44; + } + } + } + } + } else { + if (!lequal) goto L5001; + if (nstrgt == ndimst) goto L9005; + ++nstrgt; + indrgt[nstrgt-1] = jndlec[iloop1-1] + 1; + } + } + } + +L100: + ; + } +/* *** MAIN LOOP OVER RECORDS (END) */ + +/* ALL VARIABLES ARE NOW SORTED AT THE END OF THE OBJECT FILE */ + +/* REWRITE TOP OF OBJECT FILE TO UPDATE *NSTACK+/+NRECOR* */ + nstack = ivaend - ivabeg; + nrecor = ivaend; + header.nrecor = nrecor; + header.nstack = nstack; + iretcd = kdiput_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9001; + +L666: + return ret_val; + +L5000: + printf("%-120s LINE\n", cerror); + printf("%-120s %04d\n", myreco, (int)ilines); + goto L666; +L5001: + printf("! %s: INVALID VARIABLE NAME IN RECORD\n", nomsub); + ret_val = 5001; + goto L5000; +L5002: + printf("! %s: *%s* CANNOT BE DECLARED\n", nomsub, cparav); + ret_val = 5002; + goto L5000; +L5003: + printf("! %s: VARIABLE DECLARED TWICE *%s*\n", nomsub, cparav); + ret_val = 5003; + goto L5000; +L5004: + printf("! %s: VARIABLE NOT YET DECLARED *%s*\n", nomsub, cparav); + ret_val = 5004; + goto L5000; +L5005: + printf("! %s: INVALID PARAMETER *%s*\n", nomsub, cparav); + ret_val = 5005; + goto L5000; +L5006: + printf("! %s: INVALID VARIABLE FOR >>.<< OR <<.>>\n", nomsub); + ret_val = 5006; + goto L5000; +L5007: + printf("! %s: VARIABLE EVALUATED TWICE *%s*\n", nomsub, cparav); + ret_val = 5007; + goto L5000; +L8000: + printf("! %s: *%s* WITH TYPE %s\n", nomsub, cparav, ckeywd[indrgt[nstrgt-1]-1]); + goto L5000; +L8001: + printf("! %s: INVALID TYPE_TO_TYPE CONVERSION\n", nomsub); + ret_val = 8001; + goto L8000; +L8002: + printf("! %s: INVALID *NOT* OR *ABS*\n", nomsub); + ret_val = 8002; + goto L8000; +L8003: + printf("! %s: INVALID TYPE FOR REAL/DOUBLE FUNCTION\n", nomsub); + ret_val = 8003; + goto L8000; +L8004: + printf("! %s: INVALID TYPE FOR +,-,*,/,modulo OR **\n", nomsub); + ret_val = 8004; + goto L8000; +L8005: + printf("! %s: INVALID TYPE FOR <,>,=,<=,>= OR <>\n", nomsub); + ret_val = 8005; + goto L8000; +L8006: + printf("! %s: INVALID TYPE FOR _MIN_ OR _MAX_\n", nomsub); + ret_val = 8006; + goto L8000; +L8007: + printf("! %s: INVALID TYPE FOR _TRIM_\n", nomsub); + ret_val = 8006; + goto L8000; +L9001: + iretcd = -1; + printf("! %s: WRITING RETURN CODE =%d\n", nomsub, (int)iretcd); + ret_val = iretcd; + goto L666; +L9003: + iretcd = -1; + printf("! %s: WRITING RETURN CODE =%d\n", nomsub, (int)iretcd); + ret_val = iretcd; + goto L666; +L9005: + printf("! %s: *STACK* MEMORY IS FULL\n", nomsub); + ret_val = 9005; + goto L5000; +L9006: + printf("! %s: *STACK* MEMORY IS EMPTY\n", nomsub); + ret_val = 9006; + goto L5000; +L9008: + printf("! %s: ERROR ON THE NUMBER OF EVALUATIONS\n", nomsub); + printf("! %s: CLESTK: LEFT=%d VS. RIGHT=%d\n", nomsub, (int)nstlft, (int)nstrgt); + ret_val = 9008; + goto L5000; +L9009: + printf("! %s: ERROR ON THE TYPE OF AN EVALUATION\n", nomsub); + ret_val = 9009; + goto L5000; +L9010: + printf("! %s: UNEXPECTED END OF STATEMENT\n", nomsub); + ret_val = 9010; + goto L5000; +L9023: + iretcd = -1; + printf("! %s: IOSTAT RETURN CODE =%d\n", nomsub, (int)iretcd); + printf("! %s: IMPOSSIBLE TO USE THIS *OBJECT* FILE\n", nomsub); + ret_val = -2; + goto L666; +L9025: + printf("! %s: IMPOSSIBLE TO USE OLD *OBJECT* FILE\n", nomsub); + ret_val = -3; + goto L666; +} /* clestk */ diff --git a/Ganlib/src/cletim_c.c b/Ganlib/src/cletim_c.c new file mode 100644 index 0000000..addb037 --- /dev/null +++ b/Ganlib/src/cletim_c.c @@ -0,0 +1,20 @@ +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR: A. Hebert ; 16/07/10 */ +/*****************************************/ + +#include <stdlib.h> +#include <time.h> +#include "cle2000.h" + +#ifdef _OPENMP +#include <omp.h> +void cletim_c(double *sec){ + *sec = omp_get_wtime(); +} +#else +void cletim_c(double *sec){ + long value = (long) clock(); + *sec = (double) (value / CLOCKS_PER_SEC); +} +#endif diff --git a/Ganlib/src/clexrf.c b/Ganlib/src/clexrf.c new file mode 100644 index 0000000..d418f35 --- /dev/null +++ b/Ganlib/src/clexrf.c @@ -0,0 +1,323 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 11/05/09 */ +/*****************************************/ + +#include <stdlib.h> +#include <string.h> +#include "cle2000.h" +#include "header.h" +#define index_f(A, B) (strstr(A, B) == NULL ? 0 : strstr(A, B) - A + 1) +#define ntotxr 7 +#define nmawrd 60 +#define nlogkw 15 + +int_32 clexrf(kdi_file *iunito, FILE *iwrite) +{ + char *nomsub = "clexrf"; + static char cl2000[] = "CLE2000(V3)"; + static char ctitxr[] = "* CLE-2000 VERS 3.0 * CROSS REFERENCE LISTING"; + static char ctitdb[] = "* CLE-2000 VERS 3.0 * DEBUG (WARNINGS AND ERRORS)"; + static char *clogbg[] = {"INTEGER", "REAL", "STRING", "DOUBLE", "LOGICAL", "EVALUATE", + "ECHO", "ELSEIF", "IF", "WHILE", "UNTIL", "ENDWHILE", "REPEAT", + "ELSE", "ENDIF"}; + static char *clognd[] = {";", ";", ";", ";", ";", ";", ";", "THEN", "THEN", "DO", + ";", ";", "REPEAT", "ELSE", ";"}; + static char *ctypes[] = {"_I", "_R", "_S", "_D", "_L"}; + +/* CLE-2000 SYSTEM: R.ROY (11/1999), VERSION 3.0 */ + +/* *CLEXRF* X-REF FOR VARIABLES ON THE D.A. UNIT *IUNITO* */ +/* OUTPUT IS WRITTEN ON UNIT *IWRITE* */ + +/* USE: DRESS UP A LIST OF VARIABLES AND LINES WHERE USED. */ +/* <<.>> AND >>.<< STATEMENTS ARE ALSO CHECKED; */ +/* IN DEBUG MODE, ATTEMPT TO LIST POSSIBLE ERRORS. */ + +/* INPUT: *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */ +/* *IWRITE* IS THE OUTPUT UNIT */ + +/* NOTE: *CLEXRF* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */ + + int_32 ret_val = 0; + int_32 i, irecor, iofset, ninput, maxlvl, nstack, ixrlst, idblst, iretcd, indlin, + idclin, idefin, iusein, ilines, ilevel; + char cparin[13], myparm[13], chrend[13], myreco[121], cdatin[121]; + char cerror[13], cdefst[21], cusest[21]; + int_32 maskck[nmaskc], ipacki[nmaskc]; + int_32 idebwd[nmawrd+1], ifinwd[nmawrd+1], jndlec[nmawrd]; + int_32 lequal=0, istack, linxrf[ntotxr]; + char my_header[38]; + +/* READ TOP OF OBJECT FILE */ + iretcd = kdiget_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9023; + strcpy(cparin, header.cparin); + strcpy(myreco, header.cdatin); + ninput = header.ninput; + maxlvl = header.maxlvl; + nstack = header.nstack; + ixrlst = header.ixrlst; + idblst = header.idblst; + if (strcmp(cparin, cl2000) != 0) goto L9025; + +/* CASE WHERE DEBUG IS ACTIVE */ + if (idblst > 0) { + int_32 lfirst = 1; + for (irecor = ninput + 1; irecor <= ninput + nstack; ++irecor) { + iofset = (irecor - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idclin = record2.idclin; + idefin = record2.idefin; + iusein = record2.iusein; + if (cparin[0] == '$') goto L60; + if (idefin == 0) { + strcpy(cdefst, "NOT DEFINED"); + if (iusein == 0) { + strcpy(cusest, "NOT USED"); + strcpy(cerror, "WARNING"); + } else { + strcpy(cusest, "BEFORE DEFINED"); + strcpy(cerror, "EXTERNAL"); + } + } else if (iusein == 0) { + strcpy(cusest, "NOT USED"); + strcpy(cerror, "WARNING"); + } else { + if (idclin > idefin) { + strcpy(cdefst, "BEFORE DECLARED"); + strcpy(cerror, "ERROR"); + ++ret_val; + } + if (idefin > iusein) { + strcpy(cusest, "BEFORE DEFINED"); + strcpy(cerror, "ERROR"); + ++ret_val; + } + } + if (lfirst && strcmp(cerror, " ") != 0) { + fprintf(iwrite, "\n"); + fprintf(iwrite, "%-72s\n", ctitdb); + fprintf(iwrite, " REPORT-----/VARIABLE----/DEFINED-STATUS------/USED-STATUS---------\n"); + lfirst = 0; + } + if (strcmp(cerror, " ") != 0) { + fprintf(iwrite, "%-12s/%-12s/%-20s/%-20s\n", cerror, cparin, cdefst, cusest); + } +L60: + ; + } + if (!lfirst) { + if (ret_val > 0) { + fprintf(iwrite, " REPORT-----> NB. OF ERRORS=%7d\n", (int)ret_val); + fprintf(iwrite, " REPORT-----> MAY STILL EXECUTE WELL...\n"); + } + fprintf(iwrite, " \n"); + } + } + +/* CASE WHERE NO XREF WAS ASKED */ + if (ixrlst <= 0) goto L666; + +/* CASES WHERE THERE ARE NO CLE-2000 VARIABLES OR SENTENCES */ + if (nstack == 0 || maxlvl == 0) goto L666; + fprintf(iwrite, "%-72s\n", ctitxr); + fprintf(iwrite, " \n"); + fprintf(iwrite, " VARIABLE TYPE LIN_DCL **** FOUND IN LINES (- MEANS NEW EVALUATION) ****\n"); + fprintf(iwrite, " \n"); + +/* *** MAIN LOOP OVER VARIABLES (BEGIN) */ + for (istack = ninput + 1; istack <= ninput + nstack; ++istack) { + int_32 ilogin = 0; + int_32 jlines = 0; + int_32 iuseln = 0; + int_32 idefln = 0; + int_32 nxreft = 0; + + iofset = (istack - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + strcpy(myparm, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idclin = record2.idclin; + idefin = record2.idefin; + iusein = record2.iusein; + +/* PREPARE HEADER FOR VARIABLE *MYPARM* */ + sprintf(my_header, " %-4d %-12s %-2s %04d_", (int)istack, myparm, ctypes[abs(indlin)-1], (int)idclin); + +/* *** MAIN LOOP OVER RECORDS (BEGIN) */ + for (irecor = 2; irecor <= ninput; ++irecor) { + int_32 iloop1, jloop2; + char cparav[13]; + +/* READ A NEW RECORD */ + iofset = (irecor - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record1.cparin); + strcpy(myreco, record1.myreco); + ilines = record1.ilines; + ilevel = record1.ilevel; + for (i = 0; i < nmaskc; i++) maskck[i] = record1.maskck[i]; + for (i = 0; i < nmaskc; i++) ipacki[i] = record1.ipacki[i]; + +/* RECORDS OUTSIDE CLE-2000, CHECK >>.<< DEFINITIONS */ +/* AND <<.>> USES (FOR DECLARED VARIABLE) */ + if (ilevel == 0) { +L10: + iloop1 = index_f(myreco, ">>"); + jloop2 = index_f(myreco, "<<"); + if (iloop1 != 0) { +/* RECOVER VARIABLE NAME INSIDE <<.>> OR >>.<< */ + if (jloop2 > iloop1) { + strncpy(cparav, &myreco[iloop1+1], jloop2-iloop1-2); + cparav[jloop2-iloop1-2] = '\0'; + if (strcmp(cparav, myparm) == 0) iuseln = -ilines; + for (i = iloop1-1; i < jloop2+1; i++) myreco[i] = ' '; + } else { + strncpy(cparav, &myreco[jloop2+1], iloop1-jloop2-2); + cparav[iloop1-jloop2-2] = '\0'; + if (strcmp(cparav, myparm) == 0) { + if (iuseln == 0) iuseln = ilines; + } + for (i = jloop2-1; i < iloop1+1; i++) myreco[i] = ' '; + } + goto L10; + } + +/* RECORDS INSIDE CLE-2000, CHECK ALL DEFINITIONS/EVALUATIONS */ + } else { + int_32 logprv = (ilogin == 0); + int_32 iwords = 1; + int_32 nwords = 1; + int_32 jbiprv = 0; + if (logprv) { + for (iloop1 = 1; iloop1 <= nlogkw - 4; ++iloop1) { + if (strcmp(cparin, clogbg[iloop1- 1]) == 0) ilogin = iloop1; + } + if (ilogin == 0) goto L100; + +/* KEYWORDS: *ECHO+/+ELSEIF+/+IF+/+WHILE+/+UNTIL* */ +/* ASSUME THAT THERE WAS AN *:=* SIGN */ +/* (AS IF WE WERE THEN ON RIGHT SIDE OF AN EVALUATE) */ + lequal = (ilogin >= 7); + strcpy(chrend, clognd[ilogin-1]); + } + +/* HERE, WE HAVE FOUND A SENTENCE INCLUDING A STACK... */ + +/* BEGIN: MASK RECOVERY */ + for (iloop1 = 1; iloop1 <= 72; ++iloop1) { + int_32 jbicur; + jloop2 = (iloop1 + 23) / 24; + jbicur = maskck[jloop2-1] % 2; + iwords += jbiprv * (1 - jbicur); + idebwd[nwords-1] = iloop1; + ifinwd[iwords-1] = iloop1; + nwords += jbicur * (1 - jbiprv); + jbiprv = jbicur; + maskck[jloop2-1] /= 2; + } + --nwords; +/* END: MASK RECOVERY */ + + if (logprv) { +/* THIS IS A NEW *ILOGIN* */ + if (nwords == 1) goto L100; +/* START AT CURRENT WORD NUMBER 2 */ + iwords = 2; + } else { +/* THIS IS NOW THE FIRST WORD, BUT WITH AN OLD *ILOGIN* */ + iwords = 1; + } + +/* BEGIN: UNPACK JNDLEC WITH TYPES (ITYP-1) */ + for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { + jloop2 = ((iloop1 << 1) + 23) / 24; + jndlec[iloop1 - 1] = ipacki[jloop2 - 1] % 4; + ipacki[jloop2 - 1] /= 4; + } +/* END: UNPACK JNDLEC WITH TYPES (ITYP-1) */ + + for (iloop1 = iwords; iloop1 <= nwords; ++iloop1) { + if (jndlec[iloop1-1] == 2 && myreco[idebwd[iloop1-1]-1] != '\"') { + strncpy(cparav, &myreco[idebwd[iloop1 - 1] - 1], ifinwd[iloop1-1]-idebwd[iloop1-1]+1); + cparav[ifinwd[iloop1-1]-idebwd[iloop1-1]+1] = '\0'; + if (strcmp(cparav, chrend) == 0) { +/* RESET *ILOGIN* AND LEFT/RIGHT NUMBERS */ + ilogin = 0; + idefln = 0; + } else if (lequal) { + if (strcmp(cparav, myparm) == 0) { +/* USING THIS VARIABLE */ + if (iuseln == 0) iuseln = ilines; + } + } else { + if (strcmp(cparav, ":=") == 0) { + lequal = 1; +/* *:=* SIGN IMPLIES REDEFINITION */ + if (idefln != 0) iuseln = -idefln; + idefln = 0; + } else { +/* KEEP THE DEFINITION LINE UNTIL *:=* OR CHREND */ + if (strcmp(cparav, myparm) == 0) idefln = ilines; + } + } + } + } + } + +/* HAVE WE FOUND A NEW XREF LINE ? */ + if (iuseln != 0 && iuseln != jlines) { + if (nxreft == ntotxr) { + char xline[81]; + sprintf(&xline[0], "%-24s", my_header); + for (i = 0; i < ntotxr; i++) sprintf(&xline[24 + 8*i], " %04d", (int)linxrf[i]); + fprintf(iwrite, "%-80s\n", xline); + strcpy(my_header, " "); + nxreft = 0; + } + ++nxreft; + linxrf[nxreft - 1] = iuseln; + jlines = iuseln; + } + iuseln = 0; +L100: + ; + } +/* *** MAIN LOOP OVER RECORDS (END) */ + +/* POSSIBLE INCOMPLETE LAST LINE... */ + if (nxreft != 0) { + char xline[81]; + sprintf(&xline[0], "%-24s", my_header); + for (i = 0; i < nxreft; i++) sprintf(&xline[24 + 8*i], " %04d", (int)linxrf[i]); + fprintf(iwrite, "%-80s\n", xline); + } else if (strcmp(my_header, " ") != 0) { + fprintf(iwrite, "%-24s <= WARNING: NEVER DEFINED, NEVER USED... POSSIBLE ERROR\n", my_header); + } + } +/* *** MAIN LOOP OVER VARIABLES (END) */ + + fprintf(iwrite, " \n"); +L666: + return ret_val; +L9023: + iretcd = -1; + printf("! %s: IOSTAT RETURN CODE =%d\n", nomsub,(int)iretcd); + printf("! %s: IMPOSSIBLE TO USE THIS *OBJECT* FILE\n", nomsub); + ret_val = -2; + goto L666; +L9025: + printf("! %s: IMPOSSIBLE TO USE OLD *OBJECT* FILE\n", nomsub); + ret_val = -3; + goto L666; +} /* clexrf */ diff --git a/Ganlib/src/drviox.c b/Ganlib/src/drviox.c new file mode 100644 index 0000000..0ca1987 --- /dev/null +++ b/Ganlib/src/drviox.c @@ -0,0 +1,194 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 31/07/10 */ +/*****************************************/ + +#include <stdlib.h> +#include <string.h> +#include "cle2000.h" + +void drviox(lifo *my_iptdat, int_32 minput, int_32 *nusec2) +{ + char *nomsub = "drviox"; + static char *ctypes[] = {"_I", "_R", "_S", "_D", "_L"}; + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *DRVIOX* IS USED TO INPUT/OUTPUT CLE-2000 VALUES */ +/* INTO/FROM DATA STRUCTURE. */ + +/* INPUT: *IPTDAT* IS THE DATA STRUCTURE POINTER (ALLOCATED) */ +/* *MINPUT* IS AN INTEGER -1: TO READ DATA INPUT (IN MAIN) */ +/* 0: TO GET THIS INPUT (IN PROC, AFTER "::") */ +/* +1: TO RETURN VALUES (IN MAIN) */ +/* *NUSEC2* IS THE OFFSET OF NEXT DATA VALUE ENTERED AFTER "::" */ + + int_32 ityp, nitma, ntypc2; + float_32 flott; + double_64 dflot; + char text[73], messag[73]; + lifo_node *my_node; + + if (minput == -1) { + int_32 nembed = 0; + +/* INPUT CLE-2000 VARIABLES FROM MAIN PROGRAM */ +L10: + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp == 10) { + xabort_c("DRVIOX: REDGET HITS THE ; (1)."); + } else if (ityp == 3 && strcmp(text, ";") == 0 && nembed == 0) { +/* END OF STATEMENT REACHED */ + goto L666; + } else { + my_node = (lifo_node *) malloc(sizeof(lifo_node)); + clepush(&my_iptdat, my_node); + strcpy(my_node->name, "_dummy"); + if (ityp > 0) { + my_node->type = 10 + ityp; + my_node->access = 1; + if (ityp == 3) { + if (strcmp(text, ":::") == 0) { + ++nembed; + } else if (strcmp(text, ";") == 0) { + --nembed; + } else if (strcmp(text, "::") == 0) { + xabort_c("DRVIOX: INPUT DATA MISTAKE (ACT)."); + } + strcpy(my_node->value.hval, text); + } else if (ityp == 1 || ityp == 5) { + my_node->value.ival = nitma; + } else if (ityp == 2) { + my_node->value.fval = flott; + } else if (ityp == 4) { + my_node->value.dval = dflot; + } else { + xabort_c("DRVIOX: INVALID TYPE (ACT)."); + } + } else { + my_node->type = -10 + ityp; + my_node->access = 0; + strcpy(my_node->name, text); + } + } + goto L10; + } else if (minput == 0) { +/* READ/WRITE CLE-2000 VARIABLES IN THE PROCEDURE CALL */ +L20: + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp == 10) { + xabort_c("DRVIOX: REDGET HITS THE ; (2)."); + } else if (ityp == 3 && strcmp(text, ";") == 0) { + goto L666; + } else { + if (*nusec2 + 1 > my_iptdat->nup) { + printf("%s: INVALID NUMBER OF PARAMETERS (nusec2=%d)\n", nomsub, (int)(*nusec2 + 1)); + sprintf(messag, "%s: PROC WAS CALLED WITH ONLY %d PARAMETERS.\n", nomsub, (int)my_iptdat->nup); + xabort_c(messag); + } + if (ityp < 0) { + my_node = clepos(&my_iptdat, *nusec2); + ntypc2 = my_node->type - 10; + if (-ityp != ntypc2) { + if (ityp < 0) { + printf("%s: DUMMY VARIABLE NAME *%.12s* OF TYPE(%s)\n", + nomsub, text, ctypes[-ityp-1]); + } else { + printf("%s: DUMMY VALUE OF TYPE(%s)\n", nomsub, ctypes[ityp-1]); + } + if (my_node->type < 0) { + strcpy(text, my_node->name); + printf("%s: ACTUAL VARIABLE NAME *%.12s* OF TYPE(%s)\n", nomsub, text, ctypes[-ntypc2-1]); + } else { + printf("%s: DUMMY VALUE OF TYPE(%s)\n", nomsub, ctypes[ntypc2-1]); + } + xabort_c("DRVIOX: INVALID TYPE (DUMMY) 5."); + } + if (strcmp(my_node->name, "_dummy") == 0) strcpy(my_node->name, text); + nitma = 0; + flott = 0.f; + dflot = 0.L; + strcpy(text, " "); + if (ityp == -1 || ityp == -5) { + nitma = my_node->value.ival; + } else if (ityp == -2) { + flott = my_node->value.fval; + } else if (ityp == -3) { + strcpy(text, my_node->value.hval); + nitma = strlen(text); + } else if (ityp == -4) { + dflot = my_node->value.dval; + } else { + xabort_c("DRVIOX: INVALID TYPE (DUMMY) 6."); + } + redput_c(&ntypc2, &nitma, &flott, text, &dflot); + } else { + my_node = clepos(&my_iptdat, *nusec2); + ntypc2 = my_node->type + 10; + if (-ityp != ntypc2) { + if (ityp < 0) { + printf("%s: DUMMY VARIABLE NAME *%.12s* OF TYPE(%s)\n", nomsub, text, ctypes[-ityp-1]); + } else { + printf("%s: DUMMY VALUE OF TYPE(%s)\n", nomsub, ctypes[ityp-1]); + } + if (my_node->type < 0) { + strcpy(text, my_node->name); + printf("%s: ACTUAL VARIABLE NAME *%.12s* OF TYPE(%s)\n", nomsub, text, ctypes[-ntypc2-1]); + } else { + printf("%s: DUMMY VALUE OF TYPE(%s)\n", nomsub, ctypes[ntypc2-1]); + } + xabort_c("DRVIOX: INVALID TYPE (DUMMY) 5."); + } + if (ityp == 1 || ityp == 5) { + my_node->value.ival = nitma; + } else if (ityp == 2) { + my_node->value.fval = flott; + } else if (ityp == 3) { + strcpy(my_node->value.hval, text); + } else if (ityp == 4) { + my_node->value.dval = dflot; + } else { + xabort_c("DRVIOX: INVALID TYPE (DUMMY) 7."); + } + my_node->type = -my_node->type; + } + ++(*nusec2); + } + goto L20; + } else if (minput == 1) { + int_32 iloop; + +/* CONSISTENT RETURN (NOW, *REDPUT* IN THE REVERSE ORDER) */ + for (iloop = my_iptdat->nup - 1; iloop >= 0; --iloop) { + my_node = clepos(&my_iptdat, iloop); + if (my_node->type < 10) continue; + ityp = my_node->type - 10; + nitma = 0; + flott = 0.f; + dflot = 0.L; + strcpy(text, " "); + if (my_node->access == 0) { + if (ityp == 1 || ityp == 5) { + nitma = my_node->value.ival; + } else if (ityp == 2) { + flott = my_node->value.fval; + } else if (ityp == 3) { + strcpy(text, my_node->value.hval); + nitma = strlen(text); + } else if (ityp == 4) { + dflot = my_node->value.dval; + } else { + xabort_c("DRVIOX: INVALID TYPE (DUMMY) 4."); + } + redput_c(&ityp, &nitma, &flott, text, &dflot); + my_node->access = 1; + } + } + } else { + xabort_c("DRVIOX: INVALID VALUE FOR *MINPUT* ARG"); + } +L666: + return; +} /* drviox */ diff --git a/Ganlib/src/filmod.f90 b/Ganlib/src/filmod.f90 new file mode 100644 index 0000000..a138d5a --- /dev/null +++ b/Ganlib/src/filmod.f90 @@ -0,0 +1,161 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! allocate and release file units associated to a given file name. Word +! addressable (KDI), sequential (formatted or not) and direct access +! (DA) files are permitted. These functions are Ganlib wrappers for the +! KDROPN and KDIOP utilities. +! FILOPN: open file and allocate unit number. Allocate a unit number to +! to file name. If unit is already opened, returns its address. +! FILCLS: close file and release unit number. +! FILUNIT: recover Fortran file unit number. +! FILKDI: recover KDI file c_ptr. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!Parameters: input +! iplcm pointer to the LCM object. +! cuname filename. if cuname=' ', use a default name +! iactio action on file +! =0 to allocate a new file +! =1 to access and modify an existing file +! =2 to access an existing file in read-only mode +! =3 unknown +! iutype file type +! =1 KDI word addressable file +! =2 sequential unformatted +! =3 sequential formatted +! =4 direct access (DA) unformatted file +! ldra number of words in DA a record (required for iutype=4 only) +! file_pt type(c_ptr) address of file +! my_file type(FIL_file) address of file +! iactio action on file +! = 1 to keep the file; +! = 2 to delete the file. +! +!Parameters: output +! FILOPN type(FIL_file) address of file (successful allocation). +! = NULL in case of allocation failure. +! FILCLS error status +! = 0 unit closed +! = -1 error on close of kdi file +! = -2 error on close of Fortran file +! = -3 unknown file at close +! FILUNIT Fortran file unit number +! FILKDI KDI file c_ptr +! +!----------------------------------------------------------------------- +! +module FILMOD + use, intrinsic :: iso_c_binding + type, bind(c) :: FIL_file + integer(c_int) :: unit + type(c_ptr) :: kdi_file + end type FIL_file +contains + function FILOPN(cuname,iactio,iutype,lrda) result(my_file) + use, intrinsic :: iso_c_binding + character(len=*) :: cuname + integer :: iactio,iutype,lrda + !---- + ! local variables + !---- + type(FIL_file), pointer :: my_file + type(c_ptr) :: my_kdi_file + type(c_ptr),external :: KDIOP + integer,external :: KDROPN + integer :: ret_val + !---- + ! kdi (word addressable) file open + !---- + if(iutype == 1) then + my_kdi_file=KDIOP(crdnam,iactio) + if(.not.c_associated(my_kdi_file)) go to 6000 + allocate(my_file) + my_file%kdi_file=my_kdi_file + my_file%unit=0 + else + !---- + ! Fortran file open + !---- + ret_val=KDROPN(cuname,iactio,iutype,lrda) + if(ret_val <= 0) go to 6000 + allocate(my_file) + my_file%kdi_file=c_null_ptr + my_file%unit=ret_val + endif + return + !---- + ! Error + !---- + 6000 NULLIFY(my_file) + return + end function FILOPN + integer function FILCLS(my_file,iactio) + use, intrinsic :: iso_c_binding + type(FIL_file), pointer :: my_file + integer :: iactio + integer, parameter :: ndummy=4 + type(c_ptr) :: my_kdi_file + integer,external :: KDICL,KDRCLS + integer :: ret_val + ! + itapno=my_file%unit + my_kdi_file=my_file%kdi_file + !---- + ! kdi (word addressable) file open + !---- + if((itapno == 0).and.c_associated(my_kdi_file)) then + iercod=KDICL(my_kdi_file,iactio) + ret_val=-1 + if(iercod /= 0) go to 7000 + else if((itapno > 0).and..not.c_associated(my_kdi_file)) then + ret_val=-2 + iercod=KDRCLS(itapno,iactio) + if(iercod /= 0) go to 7000 + else + ret_val=-3 + go to 7000 + endif + deallocate(my_file) + FILCLS=0 + return + 7000 FILCLS=ret_val + return + end function FILCLS + integer function FILUNIT(file_pt) + use, intrinsic :: iso_c_binding + type(c_ptr), intent(in) :: file_pt + type(FIL_file), pointer :: my_file + ! + call c_f_pointer(file_pt,my_file) + if(c_associated(my_file%kdi_file)) then + FILUNIT = -1 + return + endif + FILUNIT=my_file%unit + return + end function FILUNIT + function FILKDI(file_pt) + use, intrinsic :: iso_c_binding + type(c_ptr) FILKDI + type(c_ptr), intent(in) :: file_pt + type(FIL_file), pointer :: my_file + ! + call c_f_pointer(file_pt,my_file) + if(my_file%unit > 0) then + FILKDI=c_null_ptr + return + endif + FILKDI=my_file%kdi_file + return + end function FILKDI +end module diff --git a/Ganlib/src/ganlib.f90 b/Ganlib/src/ganlib.f90 new file mode 100644 index 0000000..e0ecee3 --- /dev/null +++ b/Ganlib/src/ganlib.f90 @@ -0,0 +1,106 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for Ganlib support. This module defines the +! interface prototypes of the Ganlib Fortran API, defines TYPE(C_PTR) +! and defines the external functions in the Ganlib API. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +module GANLIB + use FILMOD + use LCMAUX + use LCMMOD + use LCMTLC + use OPNMOD + use XDRMOD + use, intrinsic :: iso_c_binding + integer, parameter :: dp = kind(0.0d0) + interface + subroutine CUT(name1, name2, ilong) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: name1 + character(len=*) :: name2 + integer :: ilong + end subroutine CUT + end interface + interface + subroutine FIL(name1, name2, ilong) + use, intrinsic :: iso_c_binding + character(len=*) :: name1 + character(kind=c_char), dimension(*) :: name2 + integer :: ilong + end subroutine FIL + end interface + interface + subroutine XABORT(msg) + character(len=*) :: msg + end subroutine XABORT + end interface + interface + subroutine REDGET(ityp, nitma, flott, text, dflot) + integer :: ityp, nitma + real :: flott + character(len=*) :: text + double precision :: dflot + end subroutine REDGET + end interface + interface + subroutine REDPUT(ityp, nitma, flott, text, dflot) + integer :: ityp, nitma + real :: flott + character(len=*) :: text + double precision :: dflot + end subroutine REDPUT + end interface + interface + subroutine REDOPN(iinp1, iout1, nrec) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iinp1, iout1 + integer :: nrec + end subroutine REDOPN + end interface + interface + subroutine REDCLS(iinp1, iout1, nrec) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iinp1, iout1 + integer :: nrec + end subroutine REDCLS + end interface + interface + function KDIOP(name, iactio) + use, intrinsic :: iso_c_binding + type(c_ptr) KDIOP + character(len=*) :: name + integer :: iactio + end function KDIOP + end interface + interface + function KDICL(my_file, istatu) + use, intrinsic :: iso_c_binding + integer(c_int) KDICL + type(c_ptr) :: my_file + integer :: istatu + end function KDICL + end interface + interface + integer function GANDRV(hmodul, nentry, hentry, ientry, jentry, kentry) + use, intrinsic :: iso_c_binding + character(len=*), intent(in) :: hmodul + integer, intent(in) :: nentry + character(len=12), dimension(nentry), intent(in) :: hentry + integer, dimension(nentry), intent(in) :: ientry, jentry + type(c_ptr), dimension(nentry), intent(in) :: kentry + end function GANDRV + end interface +end module GANLIB diff --git a/Ganlib/src/ganlib.h b/Ganlib/src/ganlib.h new file mode 100644 index 0000000..9b483e3 --- /dev/null +++ b/Ganlib/src/ganlib.h @@ -0,0 +1,27 @@ + +/**********************************/ +/* C API for Ganlib5 support */ +/* author: A. Hebert (31/05/2009) */ +/**********************************/ + +/* +Copyright (C) 2009 Ecole Polytechnique de Montreal + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. +*/ + +typedef float float_32; +typedef double double_64; + +#if __LP64__ || __64BIT__ +typedef int int_32; +#else +typedef long int_32; +#endif + +void xabort_c(char *); +int_32 * setara_c(int_32); +void rlsara_c(int_32 *); diff --git a/Ganlib/src/ganmod.f90 b/Ganlib/src/ganmod.f90 new file mode 100644 index 0000000..0882995 --- /dev/null +++ b/Ganlib/src/ganmod.f90 @@ -0,0 +1,89 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Dispatch to a calculation module in GANLIB. ANSI-C interoperable. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +integer(c_int) function ganmod(cmodul, nentry, hentry, ientry, jentry, & + kentry, hparam_c) bind(c) +! + use GANLIB + implicit none +!---- +! subroutine arguments +!---- + character(kind=c_char), dimension(*) :: cmodul + integer(c_int), value :: nentry + character(kind=c_char), dimension(13,*) :: hentry + integer(c_int), dimension(nentry) :: ientry, jentry + type(c_ptr), dimension(nentry) :: kentry + character(kind=c_char), dimension(73,*) :: hparam_c +!---- +! local variables +!---- + integer :: i, ier + character :: hmodul*12, hsmg*131, hparam*72 + character(len=12), allocatable :: hentry_f(:) + type FIL_file_array + type(FIL_file), pointer :: my_file + end type FIL_file_array + type(FIL_file_array), pointer :: my_file_array(:) +! + allocate(hentry_f(nentry),my_file_array(nentry)) + call STRFIL(hmodul, cmodul) + do i=1,nentry + call STRFIL(hentry_f(i), hentry(1,i)) + if((ientry(i) >= 3).and.(ientry(i) <= 5)) then +! open a Fortran file. + call STRFIL(hparam, hparam_c(1,i)) + my_file_array(i)%my_file=>FILOPN(hparam,jentry(i),ientry(i)-1,0) + if(.not.associated(my_file_array(i)%my_file)) then + write(hsmg,'(29hganmod: unable to open file '',a12,2h''.)') hentry_f(i) + call XABORT(hsmg) + endif + kentry(i)=c_loc(my_file_array(i)%my_file) + endif + enddo +! ---------------------------------------------------------- + ganmod=GANDRV(hmodul,nentry,hentry_f,ientry,jentry,kentry) +! ---------------------------------------------------------- + do i=1,nentry + if(jentry(i) == -2) then +! destroy a LCM object or a Fortran file. + if(ientry(i) <= 2) then + call LCMCL(kentry(i),2) + kentry(i)=c_null_ptr + else if((ientry(i) >= 3).and.(ientry(i) <= 5)) then + ier=FILCLS(my_file_array(i)%my_file,2) + if(ier < 0) then + write(hsmg,'(32hganmod: unable to destroy file '',a12,2h''.)') hentry_f(i) + call XABORT(hsmg) + endif + kentry(i)=c_null_ptr + endif + else +! close a Fortran file. + if((ientry(i) >= 3).and.(ientry(i) <= 5)) then + ier=FILCLS(my_file_array(i)%my_file,1) + if(ier < 0) then + write(hsmg,'(30hganmod: unable to close file '',a12,2h''.)') hentry_f(i) + call XABORT(hsmg) + endif + endif + endif + enddo + deallocate(my_file_array,hentry_f) + flush(6) + return +end function ganmod diff --git a/Ganlib/src/getusage.c b/Ganlib/src/getusage.c new file mode 100644 index 0000000..c5b484a --- /dev/null +++ b/Ganlib/src/getusage.c @@ -0,0 +1,44 @@ +/* + ----------------------------------------------------------------------- + Copyright (C) 2019 Ecole Polytechnique de Montreal + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + RECOVER USER ALLOCATED MEMORY USED + + ----------------------------------------------------------------------- + */ + +#include <stdio.h> +#ifndef MSDOS +#include <sys/time.h> +#include <sys/resource.h> + +double getusage() +{ + struct rusage r_usage; + getrusage(RUSAGE_SELF, &r_usage); + double utime=(double) r_usage.ru_maxrss; + return utime; +#else +#include <windows.h> +#include <psapi.h> + +double getusage() +{ + HANDLE h_process = GetCurrentProcess(); + PROCESS_MEMORY_COUNTERS pmc; + + if(GetProcessMemoryInfo(h_process, &pmc, sizeof(pmc))) { + // The *nix equivalent is expressed in KB, but Windows uses bytes + SIZE_T mem_kb = pmc.WorkingSetSize / 1024; + return (double)mem_kb; + } else { + return 0.0; + } +} +#endif +} diff --git a/Ganlib/src/hdf5_aux.c b/Ganlib/src/hdf5_aux.c new file mode 100644 index 0000000..74e7565 --- /dev/null +++ b/Ganlib/src/hdf5_aux.c @@ -0,0 +1,877 @@ + +/**********************************/ +/* C API for hdf5 file support */ +/* (auxiliary functions) */ +/* author: A. Hebert (30/11/2021) */ +/**********************************/ + +/* + Copyright (C) 2021 Ecole Polytechnique de Montreal + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + */ + +#if defined(HDF5_LIB) +#include <stdlib.h> +#include <string.h> +#include "hdf5_aux.h" +#define MAX_NAME 1024 + +hid_t h5tools_get_native_type(hid_t type); +herr_t print_info(hid_t ifile, const char *name, void *opdata); /* Operator function */ + +herr_t iretcd; + +static char AbortString[164]; +static char name1024[1024]; + +void hdf5_open_file_c(const char *fname, hid_t *ifile, int_32 irdonly) { +/* + *---------------------------------------------------------------------- + * + * Open an HDF5 file + * + * input parameters: + * fname : hdf5 file namr + * ifile : hdf5 file identificator. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_open_file_c"; + switch (irdonly) { + case 0: + *ifile = H5Fopen(fname, H5F_ACC_RDWR, H5P_DEFAULT); + if (*ifile < 0) { + sprintf(AbortString,"%s: H5Fopen failure on read-write HDF5 file '%s'.",nomsub,fname); + xabort_c(AbortString); + } + break; + case 1: + *ifile = H5Fopen(fname, H5F_ACC_RDONLY, H5P_DEFAULT); + if (*ifile < 0) { + sprintf(AbortString,"%s: H5Fopen failure on read-only HDF5 file '%s'.",nomsub,fname); + xabort_c(AbortString); + } + break; + default: + sprintf(AbortString,"%s: Invalid action on HDF5 file '%.72s'.",nomsub,fname); + xabort_c(AbortString); + break; + } +} + +void hdf5_close_file_c(hid_t *ifile) { +/* + *---------------------------------------------------------------------- + * + * Close an HDF5 file + * + * input parameters: + * ifile : hdf5 file identificator. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_close_file_c"; + iretcd = H5Fclose(*ifile); + if (iretcd != 0) { + sprintf(AbortString,"%s: HDF5 close failure. iretcd=%d\n", nomsub, iretcd); + xabort_c(AbortString); + } +} + +void hdf5_list_c(hid_t *ifile, const char *namp) { +/* + *---------------------------------------------------------------------- + * + * List the root table of contents + * + * input parameters: + * ifile : hdf5 file identificator. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_list_c"; + H5G_stat_t statbuf; + hid_t loc_id=*ifile; + sprintf(name1024,"/%s",namp); + printf("\nTable of contents --'%s'--\n", name1024); + if(!hdf5_group_exists_c(ifile, namp)) { + printf("%s: HDF5 missing group=%s\n", nomsub, namp); + return; + } + H5Gget_objinfo(loc_id, name1024, 0, &statbuf); + switch (statbuf.type) { + case H5G_GROUP: + printf("dataset/group name........................ "); + printf("type............ bytes.. shape.................\n"); + H5Giterate(loc_id, name1024, NULL, print_info, NULL); + break; + default: + printf("%s is not a H5G_GROUP.\n", namp); + break; + } +} + +void hdf5_get_dimensions_c(hid_t *ifile, const char *namp, int_32 *rank) { +/* + *---------------------------------------------------------------------- + * + * Find dataset rank (number of dimensions) + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * + * output parameter: + * rank : number of dimensions. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_get_dimensions_c"; + hid_t loc_id=*ifile; + + hid_t dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + hid_t filespace = H5Dget_space (dataset); + *rank = (int_32)H5Sget_simple_extent_ndims(filespace); + if (*rank < 0) { + sprintf(AbortString,"%s: H5Sget_simple_extent_ndims failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + H5Dclose(dataset); +} + +void hdf5_get_num_group_c(hid_t *ifile, const char *namp, int_32 *nbobj) { +/* + *---------------------------------------------------------------------- + * + * Find the number of objects (daughter datasets and daughter groups) in a group + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the group. + * + * output parameter: + * nbobj : number of objects + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_get_num_group_c"; + hid_t loc_id=*ifile; + + hid_t group = H5Oopen(loc_id,namp,H5P_DEFAULT); + if (group < 0) { + sprintf(AbortString,"%s: H5Oopen failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + hsize_t nobj; + iretcd = H5Gget_num_objs(group, &nobj); + if (iretcd < 0) { + sprintf(AbortString,"%s: H5Gget_num_objs failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + *nbobj = (int_32)nobj; + H5Oclose(group); +} + +void hdf5_list_datasets_c(hid_t *ifile, const char *namp, int_32 *ndsets, char *idata) { +/* + *---------------------------------------------------------------------- + * + * Recover character daughter dataset names in a group. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the group. + * + * output parameter: + * ndsets : number of daughter datasets. + * idata : dataset names. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_list_datasets_c"; + hid_t loc_id=*ifile; + int idx; + + hid_t group = H5Oopen(loc_id,namp,H5P_DEFAULT); + if (group < 0) { + sprintf(AbortString,"%s: H5Oopen failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + hsize_t nobj; + int otype; + char memb_name[MAX_NAME]; + iretcd = H5Gget_num_objs(group, &nobj); + if (iretcd < 0) { + sprintf(AbortString,"%s: H5Gget_num_objs failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + *ndsets = 0; + for (idx = 0; idx < nobj; idx++) { + H5Gget_objname_by_idx(group, (hsize_t)idx, memb_name, (size_t)MAX_NAME); + otype = H5Gget_objtype_by_idx(group, (size_t)idx); + switch(otype) { + case H5G_DATASET: + strncpy (idata+MAX_NAME*(*ndsets), memb_name, MAX_NAME); + (*ndsets)++; + break; + } + } + H5Oclose(group); +} + +void hdf5_list_groups_c(hid_t *ifile, const char *namp, int_32 *ndsets, char *idata) { +/* + *---------------------------------------------------------------------- + * + * Recover character daughter group names in a group. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the group. + * + * output parameter: + * ndsets : number of daughter groups. + * idata : group names. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_list_groups_c"; + hid_t loc_id=*ifile; + int idx; + + hid_t group = H5Oopen(loc_id,namp,H5P_DEFAULT); + if (group < 0) { + sprintf(AbortString,"%s: H5Oopen failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + hsize_t nobj; + int otype; + char memb_name[MAX_NAME]; + iretcd = H5Gget_num_objs(group, &nobj); + if (iretcd < 0) { + sprintf(AbortString,"%s: H5Gget_num_objs failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + *ndsets = 0; + for (idx = 0; idx < nobj; idx++) { + H5Gget_objname_by_idx(group, (hsize_t)idx, memb_name, (size_t)MAX_NAME); + otype = H5Gget_objtype_by_idx(group, (size_t)idx); + switch(otype) { + case H5G_GROUP: + strncpy (idata+MAX_NAME*(*ndsets), memb_name, MAX_NAME); + (*ndsets)++; + break; + } + } + H5Oclose(group); +} + +void hdf5_info_c(hid_t *ifile, const char *namp, int_32 *rank, int_32 *type, int_32 *nbyte, int_32 *dimsr) { +/* + *---------------------------------------------------------------------- + * + * Find dataset information. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * + * output parameter: + * rank : number of dimensions. + * type : type of dataset. + * nbyte : number of bytes per value. + * dimsr : shape. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_info_c"; + hid_t loc_id=*ifile; + hsize_t dimsr_t[10]; + int i; + + hid_t dataset = -1; + H5E_BEGIN_TRY { + dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + } H5E_END_TRY; + if (dataset < 0) { + *rank=0; + *type=99; + *nbyte=0; + return; + } + hid_t filespace = H5Dget_space (dataset); + *rank = H5Sget_simple_extent_ndims (filespace); + if (*rank < 0) { + sprintf(AbortString,"%s: H5Sget_simple_extent_ndims failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } else if (*rank > 10) { + sprintf(AbortString,"%s: the object '%.72s' has rank= %d > 10.",nomsub,namp,*rank); + xabort_c(AbortString); + } + hid_t htype = H5Dget_type(dataset); + if (htype < 0) { + sprintf(AbortString,"%s: H5Dget_type failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + size_t precision = 0; + switch (H5Tget_class(htype)) { + case H5T_INTEGER: + *type=1; + precision = H5Tget_size(htype); + break; + case H5T_FLOAT: + /*precision = H5Tget_precision(htype);*/ + precision = H5Tget_size(htype); + if (precision == 4) { + *type=2; + } else if (precision == 8) { + *type=4; + } else { + *type=7; + } + break; + case H5T_STRING: + *type=3; + precision = H5Tget_size(htype); + break; + default: + *type=7; + } + *nbyte = precision; + iretcd = H5Sget_simple_extent_dims(filespace, dimsr_t, NULL); + if (iretcd == -1) { + sprintf(AbortString,"%s: H5Sget_simple_extent_dims failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + for(i=0; i<*rank; i++) dimsr[i] = (int_32)dimsr_t[(*rank)-i-1]; + + H5Tclose(htype); + H5Dclose(dataset); +} + +int_32 hdf5_group_exists_c(hid_t *ifile, const char *namp) +/* + *----------------------------------------------------------------------- + * + * Test for existence of a group. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the group. + * + * output parameter: + * hdf5_group_exists_c : =0: the group does exists; =1: does not exists. + * + *----------------------------------------------------------------------- + */ +{ + hid_t loc_id=*ifile; + H5G_stat_t statbuf; +H5E_BEGIN_TRY + if(strlen(namp)==0) { + iretcd = H5Gget_objinfo(loc_id, "/", 0, &statbuf); + } else { + iretcd = H5Gget_objinfo(loc_id, namp, 0, &statbuf); + } +H5E_END_TRY + if (iretcd >= 0) { + if (statbuf.type == H5G_GROUP) return 1; + } + return 0; +} + +void hdf5_create_group_c(hid_t *ifile, const char *namp) +/* + *----------------------------------------------------------------------- + * + * Create a group. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the group to create. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="hdf5_create_group_c"; + hid_t loc_id=*ifile; + H5G_stat_t statbuf; +H5E_BEGIN_TRY + iretcd = H5Gget_objinfo(loc_id, namp, 0, &statbuf); +H5E_END_TRY + if (iretcd >= 0) { + if (statbuf.type == H5G_GROUP) return; + } + hid_t groupid = H5Gcreate(loc_id, namp, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT); + if (groupid < 0) { + sprintf(AbortString,"%s: H5Gcreate failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + H5Gclose(groupid); +} + +void hdf5_delete_c(hid_t *ifile, const char *namp) +/* + *----------------------------------------------------------------------- + * + * Delete a group or a dataset. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the group or dataset to delete. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="hdf5_delete_c"; + hid_t loc_id=*ifile; + iretcd = H5Ldelete(loc_id,namp,H5P_DEFAULT); + if (iretcd < 0) { + sprintf(AbortString,"%s: HDF5 delete failure. iretcd=%d\n", nomsub, iretcd); + xabort_c(AbortString); + } +} + +void hdf5_copy_c(hid_t *ifile_s, const char *namp_s, hid_t *ifile_d, const char *namp_d) +/* + *----------------------------------------------------------------------- + * + * Copy a group or a dataset from one location to another. The source and + * destination need not be in the same file. + * + * input parameters: + * ifile_s : hdf5 source file identificator. + * namp_s : character name of the source group or dataset to copy. + * + * output parameters: + * ifile_d : hdf5 destination file identificator. + * namp_d : character name of the destination group or dataset. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="hdf5_copy_c"; + if(hdf5_group_exists_c(ifile_s, namp_s)) { + /* namp_s is a group */ + hid_t loc_id_s=*ifile_s; + hid_t loc_id_d=*ifile_d; + iretcd = H5Ocopy(loc_id_s,namp_s,loc_id_d,namp_d,H5P_DEFAULT,H5P_DEFAULT); + if (iretcd < 0) { + sprintf(AbortString,"%s: HDF5 copy failure. iretcd=%d\n", nomsub, iretcd); + xabort_c(AbortString); + } + } else { + /* namp_s is a dataset */ + int i; + int_32 rank, type, nbyte, dimsr[10], dimsr2[10], length; + hdf5_info_c(ifile_s, namp_s, &rank, &type, &nbyte, dimsr); + length = 1; + for(i=0; i<rank; i++) { + dimsr2[i] = (int_32)dimsr[(rank)-i-1]; + length = length*dimsr2[i]; + } + if (type == 1) { + int_32 *idata = (int_32 *)malloc(sizeof(int_32)*length); + hdf5_read_data_int_c(ifile_s, namp_s, idata); + hdf5_write_data_int_c(ifile_d, namp_s, rank, dimsr2, idata); + free(idata); + } else if (type == 2) { + float *rdata = (float *)malloc(sizeof(float)*length); + hdf5_read_data_real4_c(ifile_s, namp_s, rdata); + hdf5_write_data_real4_c(ifile_d, namp_s, rank, dimsr2, rdata); + free(rdata); + } else if (type == 3) { + char *ihdata = (char *)malloc(nbyte*length); + hdf5_read_data_string_c(ifile_s, namp_s, ihdata); + hdf5_write_data_string_c(ifile_d, namp_s, rank, nbyte, dimsr2, ihdata); + free(ihdata); + } else if (type == 4) { + double *rddata = (double *)malloc(sizeof(double)*length); + hdf5_read_data_real8_c(ifile_s, namp_s, rddata); + hdf5_write_data_real8_c(ifile_d, namp_s, rank, dimsr2, rddata); + free(rddata); + } else { + sprintf(AbortString,"%s: dataset '%.60s' has the wrong type(2).", nomsub, namp_s); + xabort_c(AbortString); + } + } +} + +void hdf5_read_data_int_c(hid_t *ifile, const char *namp, int_32 *idata) { +/* + *---------------------------------------------------------------------- + * + * Copy an integer dataset from hdf5 into memory. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * + * output parameter: + * idata : information elements. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_read_data_int_c"; + hid_t loc_id=*ifile; + hid_t dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + iretcd = H5Dread(dataset, H5T_NATIVE_INT, H5S_ALL, H5S_ALL, H5P_DEFAULT, idata); + if (iretcd != 0) { + sprintf(AbortString,"%s: the object '%.72s' cannot be readed.",nomsub,namp); + xabort_c(AbortString); + } + H5Dclose(dataset); +} + +void hdf5_read_data_real4_c(hid_t *ifile, const char *namp, float *rdata) { +/* + *---------------------------------------------------------------------- + * + * Copy a real(4) dataset from hdf5 into memory. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * + * output parameter: + * rdata : information elements. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_read_data_real4_c"; + hid_t loc_id=*ifile; + hid_t dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + iretcd = H5Dread(dataset, H5T_NATIVE_FLOAT, H5S_ALL, H5S_ALL, H5P_DEFAULT, rdata); + if (iretcd != 0) { + sprintf(AbortString,"%s: the object '%.72s' cannot be readed.",nomsub,namp); + xabort_c(AbortString); + } + H5Dclose(dataset); +} + +void hdf5_read_data_real8_c(hid_t *ifile, const char *namp, double *rdata) { +/* + *---------------------------------------------------------------------- + * + * Copy a real(8) dataset from hdf5 into memory. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * + * output parameter: + * rdata : information elements. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_read_data_real8_c"; + hid_t loc_id=*ifile; + hid_t dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + iretcd = H5Dread(dataset, H5T_NATIVE_DOUBLE, H5S_ALL, H5S_ALL, H5P_DEFAULT, rdata); + if (iretcd != 0) { + sprintf(AbortString,"%s: the object '%.72s' cannot be readed.",nomsub,namp); + xabort_c(AbortString); + } + H5Dclose(dataset); +} + +void hdf5_read_data_string_c(hid_t *ifile, const char *namp, char *idata) { +/* + *---------------------------------------------------------------------- + * + * Copy a string dataset from hdf5 into memory. + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * + * output parameter: + * idata : information elements. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_read_data_string_c"; + hid_t loc_id=*ifile; + + hid_t dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + hid_t datatype = H5Dget_type(dataset); + if (datatype < 0) { + sprintf(AbortString,"%s: H5Dget_type failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + iretcd = H5Dread(dataset, datatype, H5S_ALL, H5S_ALL, H5P_DEFAULT, idata); + if (iretcd != 0) { + sprintf(AbortString,"%s: the object '%.72s' cannot be readed.",nomsub,namp); + xabort_c(AbortString); + } + H5Tclose(datatype); + H5Dclose(dataset); +} + +void hdf5_write_data_int_c(hid_t *ifile, const char *namp, int_32 rank, int_32 *dimsr, int_32 *idata) { +/* + *---------------------------------------------------------------------- + * + * Copy an integer array from memory into a hdf5 dataset + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * rank : number of dimensions. + * dimsr : number of information along each dimension. + * idata : information elements. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_write_data_int_c"; + hid_t loc_id=*ifile; + int i; + hsize_t dimsr_t[10]; + if (rank > 10) { + sprintf(AbortString,"%s: rank > 10 on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + hid_t dataset = -1; + H5E_BEGIN_TRY { + dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + } H5E_END_TRY; + if (dataset >= 0) { + iretcd = H5Ldelete(loc_id,namp,H5P_DEFAULT); + if (iretcd < 0) { + sprintf(AbortString,"%s: HDF5 delete failure. iretcd=%d\n", nomsub, iretcd); + xabort_c(AbortString); + } + H5Dclose(dataset); + } + for (i = 0; i < rank; ++i) dimsr_t[i] = dimsr[i]; + hid_t dataspace = H5Screate_simple(rank, dimsr_t, NULL); + hid_t datatype = H5Tcopy(H5T_NATIVE_INT); + dataset = H5Dcreate(loc_id, namp, datatype, dataspace, + H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT); + if (dataset < 0) { + sprintf(AbortString,"%s: H5Dcreate failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + iretcd = H5Dwrite(dataset, datatype, H5S_ALL, H5S_ALL, H5P_DEFAULT, idata); + if (iretcd != 0) { + sprintf(AbortString,"%s: the object '%.72s' cannot be written.",nomsub,namp); + xabort_c(AbortString); + } + H5Sclose(dataspace); + H5Tclose(datatype); + H5Dclose(dataset); +} + +void hdf5_write_data_real4_c(hid_t *ifile, const char *namp, int_32 rank, int_32 *dimsr, float *rdata) { +/* + *---------------------------------------------------------------------- + * + * Copy a real(4) array from memory into a hdf5 dataset + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * rank : number of dimensions. + * dimsr : number of information along each dimension. + * rdata : information elements. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_write_data_real4_c"; + hid_t loc_id=*ifile; + int i; + hsize_t dimsr_t[10]; + if (rank > 10) { + sprintf(AbortString,"%s: rank > 10 on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + hid_t dataset = -1; + H5E_BEGIN_TRY { + dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + } H5E_END_TRY; + if (dataset >= 0) { + iretcd = H5Ldelete(loc_id,namp,H5P_DEFAULT); + if (iretcd < 0) { + sprintf(AbortString,"%s: HDF5 delete failure. iretcd=%d\n", nomsub, iretcd); + xabort_c(AbortString); + } + H5Dclose(dataset); + } + for (i = 0; i < rank; ++i) dimsr_t[i] = dimsr[i]; + hid_t dataspace = H5Screate_simple(rank, dimsr_t, NULL); + hid_t datatype = H5Tcopy(H5T_NATIVE_FLOAT); + dataset = H5Dcreate(loc_id, namp, datatype, dataspace, + H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT); + if (dataset < 0) { + sprintf(AbortString,"%s: H5Dcreate failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + iretcd = H5Dwrite(dataset, datatype, H5S_ALL, H5S_ALL, H5P_DEFAULT, rdata); + if (iretcd != 0) { + sprintf(AbortString,"%s: the object '%.72s' cannot be written.",nomsub,namp); + xabort_c(AbortString); + } + H5Sclose(dataspace); + H5Tclose(datatype); + H5Dclose(dataset); +} + +void hdf5_write_data_real8_c(hid_t *ifile, const char *namp, int_32 rank, int_32 *dimsr, double *rdata) { +/* + *---------------------------------------------------------------------- + * + * Copy a real(8) array from memory into a hdf5 dataset + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * rank : number of dimensions. + * dimsr : number of information along each dimension. + * rdata : information elements. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_write_data_real8_c"; + hid_t loc_id=*ifile; + int i; + hsize_t dimsr_t[10]; + if (rank > 10) { + sprintf(AbortString,"%s: rank > 10 on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + hid_t dataset = -1; + H5E_BEGIN_TRY { + dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + } H5E_END_TRY; + if (dataset >= 0) { + iretcd = H5Ldelete(loc_id,namp,H5P_DEFAULT); + if (iretcd < 0) { + sprintf(AbortString,"%s: HDF5 delete failure. iretcd=%d\n", nomsub, iretcd); + xabort_c(AbortString); + } + H5Dclose(dataset); + } + for (i = 0; i < rank; ++i) dimsr_t[i] = dimsr[i]; + hid_t dataspace = H5Screate_simple(rank, dimsr_t, NULL); + hid_t datatype = H5Tcopy(H5T_NATIVE_DOUBLE); + dataset = H5Dcreate(loc_id, namp, datatype, dataspace, + H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT); + if (dataset < 0) { + sprintf(AbortString,"%s: H5Dcreate failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + iretcd = H5Dwrite(dataset, datatype, H5S_ALL, H5S_ALL, H5P_DEFAULT, rdata); + if (iretcd != 0) { + sprintf(AbortString,"%s: the object '%.72s' cannot be written.",nomsub,namp); + xabort_c(AbortString); + } + H5Sclose(dataspace); + H5Tclose(datatype); + H5Dclose(dataset); +} + +void hdf5_write_data_string_c(hid_t *ifile, const char *namp, int_32 rank, int_32 len, int_32 *dimsr, char *idata) { +/* + *---------------------------------------------------------------------- + * + * Copy a character array from memory into a hdf5 dataset + * + * input parameters: + * ifile : hdf5 file identificator. + * namp : character name of the dataset. + * rank : number of dimensions. + * len : length of a string element in the array (in bytes). + * dimsr : number of information along each dimension. + * idata : information elements. + * + *---------------------------------------------------------------------- + */ + char *nomsub="hdf5_write_data_string_c"; + hid_t loc_id=*ifile; + int i; + hsize_t dimsr_t[10]; + if (rank > 10) { + sprintf(AbortString,"%s: rank > 10 on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + hid_t dataset = -1; + H5E_BEGIN_TRY { + dataset = H5Dopen(loc_id,namp,H5P_DEFAULT); + } H5E_END_TRY; + if (dataset >= 0) { + iretcd = H5Ldelete(loc_id,namp,H5P_DEFAULT); + if (iretcd < 0) { + sprintf(AbortString,"%s: HDF5 delete failure. iretcd=%d\n", nomsub, iretcd); + xabort_c(AbortString); + } + H5Dclose(dataset); + } + for (i = 0; i < rank; ++i) dimsr_t[i] = dimsr[i]; + hid_t dataspace = H5Screate_simple(rank, dimsr_t, NULL); + hid_t datatype = H5Tcopy(H5T_C_S1); + H5Tset_size(datatype, len * sizeof(char)); + dataset = H5Dcreate(loc_id, namp, datatype , dataspace, H5P_DEFAULT, + H5P_DEFAULT, H5P_DEFAULT); + if (dataset < 0) { + sprintf(AbortString,"%s: H5Dcreate failure on object '%.72s'.",nomsub,namp); + xabort_c(AbortString); + } + iretcd = H5Dwrite(dataset, datatype, H5S_ALL, H5S_ALL, H5P_DEFAULT, idata); + if (iretcd != 0) { + sprintf(AbortString,"%s: the object '%.72s' cannot be written.",nomsub,namp); + xabort_c(AbortString); + } + H5Sclose(dataspace); + H5Tclose(datatype); + H5Dclose(dataset); +} + +herr_t print_info(hid_t loc_id, const char *name, void *opdata) { + H5G_stat_t statbuf; + char* ctype[]={"","INTEGER","REAL","CHARACTER","DOUBLE PRECISION", + "LOGICAL","COMPLEX","UNDEFINED"}; + /* + * Get type of the object and display its name and type. + * The name of the object is passed to this function by + * the Library. + */ + H5Gget_objinfo(loc_id, name, 0, &statbuf); + int rank, type, nbyte; + int_32 dimsr[6]; + switch (statbuf.type) { + case H5G_GROUP: + printf(" '%-72s' GROUP \n", name); + break; + case H5G_DATASET: + hdf5_info_c(&loc_id, name, &rank, &type, &nbyte, dimsr); + if (rank == 1) { + printf(" '%-72s' %-16s %-10d %d \n", name,ctype[type],nbyte,dimsr[0]); + } else if (rank == 2) { + printf(" '%-72s' %-16s %-10d %d %d\n", name,ctype[type],nbyte,dimsr[0],dimsr[1]); + } else if (rank == 3) { + printf(" '%-72s' %-16s %-10d %d %d %d\n", name,ctype[type],nbyte,dimsr[0],dimsr[1],dimsr[2]); + } else if (rank == 4) { + printf(" '%-72s' %-16s %-10d %d %d %d %d\n", name,ctype[type],nbyte,dimsr[0],dimsr[1], + dimsr[2],dimsr[3]); + } else if (rank == 5) { + printf(" '%-72s' %-16s %-10d %d %d %d %d %d\n", name,ctype[type],nbyte,dimsr[0], + dimsr[1],dimsr[2],dimsr[3],dimsr[4]); + } else if (rank == 6) { + printf(" '%-72s' %-16s %-10d %d %d %d %d %d %d\n", name,ctype[type],nbyte,dimsr[0], + dimsr[1],dimsr[2],dimsr[3],dimsr[4],dimsr[5]); + } + break; + case H5G_TYPE: + printf(" '%-72s' NAMED DATATYPE \n", name); + break; + default: + printf(" '%-72s' UNKNOWN \n", name); + } + fflush(stdout); + return 0; + } +#endif /* defined(HDF5_LIB) */ diff --git a/Ganlib/src/hdf5_aux.h b/Ganlib/src/hdf5_aux.h new file mode 100644 index 0000000..9023cd3 --- /dev/null +++ b/Ganlib/src/hdf5_aux.h @@ -0,0 +1,40 @@ + +/**********************************/ +/* C API for hdf5 file support */ +/* (auxiliary functions) */ +/* author: A. Hebert (30/11/2021) */ +/**********************************/ + +/* + Copyright (C) 2021 Ecole Polytechnique de Montreal + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + */ + +#if defined(HDF5_LIB) +#include "ganlib.h" +#include "hdf5.h" +void hdf5_open_file_c(const char *, hid_t *, int_32); +void hdf5_close_file_c(hid_t *); +void hdf5_list_c(hid_t *, const char *); +void hdf5_get_dimensions_c(hid_t *, const char *, int_32 *); +void hdf5_get_num_group_c(hid_t *, const char *, int_32 *); +void hdf5_list_datasets_c(hid_t *, const char *, int_32 *, char *idata); +void hdf5_list_groups_c(hid_t *, const char *, int_32 *, char *idata); +void hdf5_info_c(hid_t *, const char *, int_32 *, int_32 *, int_32 *, int_32 *); +int_32 hdf5_group_exists_c(hid_t *, const char *); +void hdf5_create_group_c(hid_t *, const char *); +void hdf5_delete_c(hid_t *, const char *); +void hdf5_copy_c(hid_t *, const char *, hid_t *, const char *); +void hdf5_read_data_int_c(hid_t *, const char *, int_32 *); +void hdf5_read_data_real4_c(hid_t *, const char *, float *); +void hdf5_read_data_real8_c(hid_t *, const char *, double *); +void hdf5_read_data_string_c(hid_t *, const char *, char *); +void hdf5_write_data_int_c(hid_t *, const char *, int_32, int_32 *, int_32 *); +void hdf5_write_data_real4_c(hid_t *, const char *, int_32, int_32 *, float *); +void hdf5_write_data_real8_c(hid_t *, const char *, int_32, int_32 *, double *); +void hdf5_write_data_string_c(hid_t *, const char *, int_32, int_32, int_32 *, char *); +#endif diff --git a/Ganlib/src/hdf5_wrap.f90 b/Ganlib/src/hdf5_wrap.f90 new file mode 100644 index 0000000..e1e7026 --- /dev/null +++ b/Ganlib/src/hdf5_wrap.f90 @@ -0,0 +1,1410 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for hdf5. +! +!Copyright: +! Copyright (C) 2021 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +module hdf5_wrap + use, intrinsic :: iso_c_binding + private + integer, parameter :: MAX_NAME = 1024 + public :: hdf5_open_file,hdf5_close_file,hdf5_get_dimensions,hdf5_get_shape, & + hdf5_list,hdf5_info,hdf5_read_data,hdf5_write_data,hdf5_list_datasets, & + hdf5_list_groups,hdf5_group_exists,hdf5_create_group,hdf5_delete, & + hdf5_copy + + interface hdf5_read_data + module procedure hdf5_read_data_0d_int4, hdf5_read_data_1d_int4, & + hdf5_read_data_2d_int4, hdf5_read_data_3d_int4, & + hdf5_read_data_0d_real4, hdf5_read_data_1d_real4, & + hdf5_read_data_2d_real4, hdf5_read_data_3d_real4, & + hdf5_read_data_4d_real4, hdf5_read_data_0d_real8, & + hdf5_read_data_1d_real8, hdf5_read_data_2d_real8, & + hdf5_read_data_3d_real8, hdf5_read_data_4d_real8, & + hdf5_read_data_0d_string,hdf5_read_data_1d_string + end interface hdf5_read_data + interface hdf5_write_data + module procedure hdf5_write_data_0d_int4, hdf5_write_data_1d_int4, & + hdf5_write_data_2d_int4, hdf5_write_data_3d_int4, & + hdf5_write_data_0d_real4, hdf5_write_data_1d_real4, & + hdf5_write_data_2d_real4, hdf5_write_data_3d_real4, & + hdf5_write_data_4d_real4, hdf5_write_data_0d_real8, & + hdf5_write_data_1d_real8, hdf5_write_data_2d_real8, & + hdf5_write_data_3d_real8, hdf5_write_data_4d_real8, & + hdf5_write_data_0d_string,hdf5_write_data_1d_string + end interface hdf5_write_data + + character(len=131) :: hsmg + character(kind=c_char), dimension(MAX_NAME) :: name1024 + +contains +subroutine STRCUT(name1, name2) + ! transform a Fortran string into a C null-terminated string + character(kind=c_char), dimension(*) :: name1 + character(len=*) :: name2 + integer :: ilong + interface + subroutine strcut_c (s, ct, n) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: s, ct + integer(c_int), value :: n + end subroutine strcut_c + end interface + ilong=len(trim(adjustl(name2))) + call strcut_c(name1, trim(adjustl(name2)), ilong) +end subroutine STRCUT +! +subroutine STRFIL(name1, name2, nbyte) + ! transform a C null-terminated string into a Fortran string + character(len=*) :: name1 + character(kind=c_char), dimension(*) :: name2 + integer :: nbyte, ilong + interface + subroutine strfil_c (s, ct, n) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: s, ct + integer(c_int), value :: n + end subroutine strfil_c + end interface + ilong=len(name1) + name1=' ' + call strfil_c(name1, name2, min(ilong,nbyte)) +end subroutine STRFIL +! +subroutine STRFIL1D(name1, name2, nbyte) + ! transform a C null-terminated string into a Fortran string array + character(len=*),dimension(:) :: name1 + character(kind=c_char), dimension(*) :: name2 + integer :: nbyte, ilong + character(len=MAX_NAME) :: text1024 + interface + subroutine strfil_c (s, ct, n) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: s, ct + integer(c_int), value :: n + end subroutine strfil_c + end interface + ilong=len(name1) + idim=size(name1,1) + iof=1 + do i=1,idim + name1(i)=' ' + call strfil_c(text1024, name2(iof), nbyte) + name1(i)=text1024(:min(ilong,nbyte)) + iof=iof+nbyte + enddo +end subroutine STRFIL1D +! +subroutine hdf5_open_file(fname, ifile, rdonly) + ! open a HDF5 file + character(len=*), intent(in) :: fname + type(c_ptr), intent(out) :: ifile + logical, optional :: rdonly + interface + subroutine hdf5_open_file_c (fname, ifile, irdonly) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: fname + type(c_ptr) :: ifile + integer(c_int), value :: irdonly + end subroutine hdf5_open_file_c + end interface + ! + irdonly=0 + if(present(rdonly)) then + if(rdonly) irdonly=1 + endif + call STRCUT(name1024, fname) + call hdf5_open_file_c (name1024, ifile, irdonly) +end subroutine hdf5_open_file +! +subroutine hdf5_close_file(ifile) + ! close a HDF5 file + type(c_ptr),intent(in) :: ifile + interface + subroutine hdf5_close_file_c (ifile) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + end subroutine hdf5_close_file_c + end interface + call hdf5_close_file_c(ifile) +end subroutine hdf5_close_file +! +subroutine hdf5_list(ifile, name) + ! table of contents + type(c_ptr) :: ifile + character(len=*),intent(in) :: name + ! + interface + subroutine hdf5_list_c (ifile, namp) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + end subroutine hdf5_list_c + end interface + call STRCUT(name1024, name) + call hdf5_list_c(ifile, name1024) +end subroutine hdf5_list +! +subroutine hdf5_info(ifile, name, rank, type, nbyte, dimsr) + ! find dataset info + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + integer,intent(out) :: rank, type, nbyte + integer,target,dimension(5),intent(out) :: dimsr + ! + type(c_ptr) :: pt_dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + dimsr(:5)=0 + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) +end subroutine hdf5_info +! +integer function hdf5_get_dimensions(ifile, name) + ! find dataset rank (number of dimensions + type(c_ptr),intent(in) :: ifile + character(len=*), intent(in) :: name + integer :: rank + ! + interface + subroutine hdf5_get_dimensions_c(ifile, namp, rank) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank + end subroutine hdf5_get_dimensions_c + end interface + call STRCUT(name1024, name) + call hdf5_get_dimensions_c(ifile, name1024, rank) + hdf5_get_dimensions = rank +end function hdf5_get_dimensions +! +subroutine hdf5_get_shape(ifile, name, dimsr) + ! find dataset shape + type(c_ptr), intent(in) :: ifile + character(len=*), intent(in) :: name + integer, allocatable, target :: dimsr(:) + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr + ! + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + rank=hdf5_get_dimensions(ifile, name) + allocate(dimsr(rank)) + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) +end subroutine hdf5_get_shape +! +subroutine hdf5_list_datasets(ifile, name, dsets) + ! collect daughter dataset names in a group + type(c_ptr), intent(in) :: ifile + character(len=*), intent(in) :: name + character(len=*), allocatable, dimension(:) :: dsets + integer :: nbobj, ndsets + ! + character(kind=c_char), allocatable, dimension(:) :: pt_strim + interface + subroutine hdf5_get_num_group_c(ifile, namp, nbobj) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: nbobj + end subroutine hdf5_get_num_group_c + end interface + interface + subroutine hdf5_list_datasets_c(ifile, namp, ndsets, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp, idata + integer(c_int) :: ndsets + end subroutine hdf5_list_datasets_c + end interface + ! + call STRCUT(name1024, name) + call hdf5_get_num_group_c (ifile, name1024, nbobj) + if (nbobj .eq. 0) return + allocate(pt_strim(nbobj*MAX_NAME)) + call hdf5_list_datasets_c (ifile, name1024, ndsets, pt_strim) + allocate(dsets(ndsets)) + call STRFIL1D(dsets,pt_strim,MAX_NAME) + deallocate(pt_strim) +end subroutine hdf5_list_datasets +! +subroutine hdf5_list_groups(ifile, name, groups) + ! collect daughter group names in a group + type(c_ptr), intent(in) :: ifile + character(len=*), intent(in) :: name + character(len=*), allocatable, dimension(:) :: groups + integer :: nbobj, ngroups + ! + character(kind=c_char), allocatable, dimension(:) :: pt_strim + interface + subroutine hdf5_get_num_group_c(ifile, namp, nbobj) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: nbobj + end subroutine hdf5_get_num_group_c + end interface + interface + subroutine hdf5_list_groups_c(ifile, namp, ngroups, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp, idata + integer(c_int) :: ngroups + end subroutine hdf5_list_groups_c + end interface + ! + call STRCUT(name1024, name) + call hdf5_get_num_group_c (ifile, name1024, nbobj) + if (nbobj .eq. 0) return + allocate(pt_strim(nbobj*MAX_NAME)) + call hdf5_list_groups_c (ifile, name1024, ngroups, pt_strim) + allocate(groups(ngroups)) + call STRFIL1D(groups,pt_strim,MAX_NAME) + deallocate(pt_strim) +end subroutine hdf5_list_groups +! +function hdf5_group_exists(ifile, name) result(lexist) + ! test for existence of a group + type(c_ptr), intent(in) :: ifile + character(len=*), intent(in) :: name + logical :: lexist + interface + function hdf5_group_exists_c (ifile, namp) bind(c) + use, intrinsic :: iso_c_binding + integer(c_int) :: hdf5_group_exists_c + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + end function hdf5_group_exists_c + end interface + call STRCUT(name1024, name) + lexist = (hdf5_group_exists_c(ifile, name1024) /= 0) +end function hdf5_group_exists +! +subroutine hdf5_create_group(ifile, name) + ! create a group + type(c_ptr), intent(in) :: ifile + character(len=*), intent(in) :: name + interface + subroutine hdf5_create_group_c (ifile, namp) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + end subroutine hdf5_create_group_c + end interface + call STRCUT(name1024, name) + call hdf5_create_group_c(ifile, name1024) +end subroutine hdf5_create_group +! +subroutine hdf5_delete(ifile, name) + ! delete a group or a dataset + type(c_ptr), intent(in) :: ifile + character(len=*), intent(in) :: name + interface + subroutine hdf5_delete_c (ifile, namp) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + end subroutine hdf5_delete_c + end interface + call STRCUT(name1024, name) + call hdf5_delete_c(ifile, name1024) +end subroutine hdf5_delete +! +subroutine hdf5_copy(ifile_s, name_s, ifile_d, name_d) + ! copy a group or a dataset from one location to another + type(c_ptr), intent(in) :: ifile_s, ifile_d + character(len=*), intent(in) :: name_s, name_d + character(kind=c_char), dimension(MAX_NAME) :: name1024_d + interface + subroutine hdf5_copy_c (ifile_s, namp_s, ifile_d, namp_d) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile_s, ifile_d + character(kind=c_char), dimension(*) :: namp_s, namp_d + end subroutine hdf5_copy_c + end interface + call STRCUT(name1024, name_s) + call STRCUT(name1024_d, name_d) + call hdf5_copy_c(ifile_s, name1024, ifile_d, name1024_d) +end subroutine hdf5_copy +! +subroutine hdf5_read_data_0d_int4(ifile, name, idata) + ! read a rank 0 integer dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + integer, target :: idata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_int_c(ifile, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine hdf5_read_data_int_c + end interface + pt_data=c_loc(idata) + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if((rank.ne.1).or.(dimsr(1).ne.1)) then + write(hsmg,'(49hhdf5_read_data_0d_int4: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + call hdf5_read_data_int_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_0d_int4 +! +subroutine hdf5_read_data_1d_int4(ifile, name, idata) + ! read a rank 1 integer dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + integer, allocatable, dimension(:), target :: idata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_int_c(ifile, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine hdf5_read_data_int_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.1) then + write(hsmg,'(49hhdf5_read_data_1d_int4: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(idata(dimsr(1))) + pt_data=c_loc(idata) + call hdf5_read_data_int_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_1d_int4 +! +subroutine hdf5_read_data_2d_int4(ifile, name, idata) + ! read a rank 2 integer dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + integer, allocatable, dimension(:,:), target :: idata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_int_c(ifile, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine hdf5_read_data_int_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.2) then + write(hsmg,'(49hhdf5_read_data_2d_int4: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(idata(dimsr(1),dimsr(2))) + pt_data=c_loc(idata) + call hdf5_read_data_int_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_2d_int4 +! +subroutine hdf5_read_data_3d_int4(ifile, name, idata) + ! read a rank 3 integer dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + integer, allocatable, dimension(:,:,:), target :: idata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_int_c(ifile, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine hdf5_read_data_int_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.3) then + write(hsmg,'(49hhdf5_read_data_3d_int4: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(idata(dimsr(1),dimsr(2),dimsr(3))) + pt_data=c_loc(idata) + call hdf5_read_data_int_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_3d_int4 +! +subroutine hdf5_read_data_0d_real4(ifile, name, rdata) + ! read a rank 0 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real4_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real4_c + end interface + pt_data=c_loc(rdata) + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if((rank.ne.1).or.(dimsr(1).ne.1)) then + write(hsmg,'(50hhdf5_read_data_0d_real4: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + call hdf5_read_data_real4_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_0d_real4 +! +subroutine hdf5_read_data_1d_real4(ifile, name, rdata) + ! read a rank 1 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4), allocatable, dimension(:), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real4_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real4_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.1) then + write(hsmg,'(50hhdf5_read_data_1d_real4: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(rdata(dimsr(1))) + pt_data=c_loc(rdata) + call hdf5_read_data_real4_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_1d_real4 +! +subroutine hdf5_read_data_2d_real4(ifile, name, rdata) + ! read a rank 2 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4), allocatable, dimension(:,:), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real4_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real4_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.2) then + write(hsmg,'(50hhdf5_read_data_2d_real4: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(rdata(dimsr(1),dimsr(2))) + pt_data=c_loc(rdata) + call hdf5_read_data_real4_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_2d_real4 +! +subroutine hdf5_read_data_3d_real4(ifile, name, rdata) + ! read a rank 3 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4), allocatable, dimension(:,:,:), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real4_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real4_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.3) then + write(hsmg,'(50hhdf5_read_data_3d_real4: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(rdata(dimsr(1),dimsr(2),dimsr(3))) + pt_data=c_loc(rdata) + call hdf5_read_data_real4_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_3d_real4 +! +subroutine hdf5_read_data_4d_real4(ifile, name, rdata) + ! read a rank 4 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4), allocatable, dimension(:,:,:,:), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real4_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real4_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.4) then + write(hsmg,'(50hhdf5_read_data_4d_real4: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(rdata(dimsr(1),dimsr(2),dimsr(3),dimsr(4))) + pt_data=c_loc(rdata) + call hdf5_read_data_real4_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_4d_real4 +! +subroutine hdf5_read_data_0d_real8(ifile, name, rdata) + ! read a rank 0 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real8_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real8_c + end interface + pt_data=c_loc(rdata) + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if((rank.ne.1).or.(dimsr(1).ne.1)) then + write(hsmg,'(50hhdf5_read_data_0d_real8: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + call hdf5_read_data_real8_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_0d_real8 +! +subroutine hdf5_read_data_1d_real8(ifile, name, rdata) + ! read a rank 1 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8), allocatable, dimension(:), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real8_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real8_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.1) then + write(hsmg,'(50hhdf5_read_data_1d_real8: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(rdata(dimsr(1))) + pt_data=c_loc(rdata) + call hdf5_read_data_real8_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_1d_real8 +! +subroutine hdf5_read_data_2d_real8(ifile, name, rdata) + ! read a rank 2 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8), allocatable, dimension(:,:), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real8_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real8_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.2) then + write(hsmg,'(50hhdf5_read_data_2d_real8: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(rdata(dimsr(1),dimsr(2))) + pt_data=c_loc(rdata) + call hdf5_read_data_real8_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_2d_real8 +! +subroutine hdf5_read_data_3d_real8(ifile, name, rdata) + ! read a rank 3 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8), allocatable, dimension(:,:,:), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real8_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real8_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.3) then + write(hsmg,'(50hhdf5_read_data_3d_real8: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(rdata(dimsr(1),dimsr(2),dimsr(3))) + pt_data=c_loc(rdata) + call hdf5_read_data_real8_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_3d_real8 +! +subroutine hdf5_read_data_4d_real8(ifile, name, rdata) + ! read a rank 4 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8), allocatable, dimension(:,:,:,:), target :: rdata + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr, pt_data + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_real8_c(ifile, namp, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: rdata + end subroutine hdf5_read_data_real8_c + end interface + pt_dimsr=c_loc(dimsr) + call STRCUT(name1024, name) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.4) then + write(hsmg,'(50hhdf5_read_data_4d_real8: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(rdata(dimsr(1),dimsr(2),dimsr(3),dimsr(4))) + pt_data=c_loc(rdata) + call hdf5_read_data_real8_c(ifile, name1024, pt_data) +end subroutine hdf5_read_data_4d_real8 +! +subroutine hdf5_read_data_0d_string(ifile, name, idata) + ! read a rank 0 string dataset + type(c_ptr),intent(in) :: ifile + character(len=*), intent(in) :: name + character(len=*), target :: idata + character(kind=c_char), allocatable, dimension(:) :: pt_data + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_string_c(ifile, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp, idata + end subroutine hdf5_read_data_string_c + end interface + call STRCUT(name1024, name) + pt_dimsr=c_loc(dimsr) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if((rank.ne.1).or.(dimsr(1).ne.1)) then + write(hsmg,'(51hhdf5_read_data_0d_string: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + allocate(pt_data(nbyte+1)) ! add one byte for null termination + call hdf5_read_data_string_c(ifile, name1024, pt_data) + call STRFIL(idata,pt_data,nbyte) + deallocate(pt_data) +end subroutine hdf5_read_data_0d_string +! +subroutine hdf5_read_data_1d_string(ifile, name, idata) + ! read a rank 1 string dataset + type(c_ptr),intent(in) :: ifile + character(len=*), intent(in) :: name + character(len=*), allocatable, dimension(:), target :: idata + character(kind=c_char), allocatable, dimension(:) :: pt_data + ! + integer :: rank, type, nbyte + type(c_ptr) :: pt_dimsr + integer,target,dimension(5) :: dimsr + interface + subroutine hdf5_info_c(ifile, namp, rank, type, nbyte, dimsr) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int) :: rank, type, nbyte + type(c_ptr), value :: dimsr + end subroutine hdf5_info_c + end interface + interface + subroutine hdf5_read_data_string_c(ifile, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp, idata + end subroutine hdf5_read_data_string_c + end interface + call STRCUT(name1024, name) + pt_dimsr=c_loc(dimsr) + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + if(rank.ne.1) then + write(hsmg,'(51hhdf5_read_data_1d_string: invalid info for dataset ,a)') name + call XABORT(hsmg) + endif + call hdf5_info_c(ifile, name1024, rank, type, nbyte, pt_dimsr) + allocate(idata(dimsr(1))) + allocate(pt_data(dimsr(1)*nbyte+1)) ! add one byte for null termination + call hdf5_read_data_string_c(ifile, name1024, pt_data) + call STRFIL1D(idata,pt_data,nbyte) + deallocate(pt_data) +end subroutine hdf5_read_data_1d_string +! +subroutine hdf5_write_data_0d_int4(ifile, name, idata) + ! write a rank 1 integer dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + integer,intent(in), target :: idata + ! + integer, parameter :: rank = 1 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + interface + subroutine hdf5_write_data_int_c(ifile, namp, rank, dimsf, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, idata + end subroutine hdf5_write_data_int_c + end interface + dimsr(1)=1 + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(idata) + call STRCUT(name1024, name) + call hdf5_write_data_int_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_0d_int4 +! +subroutine hdf5_write_data_1d_int4(ifile, name, idata) + ! write a rank 1 integer dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + integer,dimension(:),intent(in), target :: idata + ! + integer, parameter :: rank = 1 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + integer, pointer :: idata_p + interface + subroutine hdf5_write_data_int_c(ifile, namp, rank, dimsf, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, idata + end subroutine hdf5_write_data_int_c + end interface + dimsr(1)=size(idata,1) + idata_p => idata(1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(idata_p) + call STRCUT(name1024, name) + call hdf5_write_data_int_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_1d_int4 +! +subroutine hdf5_write_data_2d_int4(ifile, name, idata) + ! write a rank 2 integer dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + integer,dimension(:,:),intent(in), target :: idata + ! + integer, parameter :: rank = 2 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + integer, pointer :: idata_p + interface + subroutine hdf5_write_data_int_c(ifile, namp, rank, dimsf, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, idata + end subroutine hdf5_write_data_int_c + end interface + dimsr(2)=size(idata,1) + dimsr(1)=size(idata,2) + idata_p => idata(1,1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(idata_p) + call STRCUT(name1024, name) + call hdf5_write_data_int_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_2d_int4 +! +subroutine hdf5_write_data_3d_int4(ifile, name, idata) + ! write a rank 3 integer dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + integer,dimension(:,:,:),intent(in), target :: idata + ! + integer, parameter :: rank = 3 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + integer, pointer :: idata_p + interface + subroutine hdf5_write_data_int_c(ifile, namp, rank, dimsf, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, idata + end subroutine hdf5_write_data_int_c + end interface + dimsr(3)=size(idata,1) + dimsr(2)=size(idata,2) + dimsr(1)=size(idata,3) + idata_p => idata(1,1,1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(idata_p) + call STRCUT(name1024, name) + call hdf5_write_data_int_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_3d_int4 +! +subroutine hdf5_write_data_0d_real4(ifile, name, rdata) + ! write a rank 0 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4),intent(in), target :: rdata + ! + integer, parameter :: rank = 1 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + interface + subroutine hdf5_write_data_real4_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real4_c + end interface + dimsr(1)=1 + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata) + call STRCUT(name1024, name) + call hdf5_write_data_real4_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_0d_real4 +! +subroutine hdf5_write_data_1d_real4(ifile, name, rdata) + ! write a rank 1 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4),dimension(:),intent(in), target :: rdata + ! + integer, parameter :: rank = 1 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + real, pointer :: rdata_p + interface + subroutine hdf5_write_data_real4_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real4_c + end interface + dimsr(1)=size(rdata,1) + rdata_p => rdata(1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata_p) + call STRCUT(name1024, name) + call hdf5_write_data_real4_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_1d_real4 +! +subroutine hdf5_write_data_2d_real4(ifile, name, rdata) + ! write a rank 2 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4),dimension(:,:),intent(in), target :: rdata + ! + integer, parameter :: rank = 2 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + real, pointer :: rdata_p + interface + subroutine hdf5_write_data_real4_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real4_c + end interface + dimsr(2)=size(rdata,1) + dimsr(1)=size(rdata,2) + rdata_p => rdata(1,1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata_p) + call STRCUT(name1024, name) + call hdf5_write_data_real4_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_2d_real4 +! +subroutine hdf5_write_data_3d_real4(ifile, name, rdata) + ! write a rank 3 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4),dimension(:,:,:),intent(in), target :: rdata + ! + integer, parameter :: rank = 3 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + real, pointer :: rdata_p + interface + subroutine hdf5_write_data_real4_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real4_c + end interface + dimsr(3)=size(rdata,1) + dimsr(2)=size(rdata,2) + dimsr(1)=size(rdata,3) + rdata_p => rdata(1,1,1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata_p) + call STRCUT(name1024, name) + call hdf5_write_data_real4_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_3d_real4 +! +subroutine hdf5_write_data_4d_real4(ifile, name, rdata) + ! write a rank 4 real4 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(4),dimension(:,:,:,:),intent(in), target :: rdata + ! + integer, parameter :: rank = 4 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + real, pointer :: rdata_p + interface + subroutine hdf5_write_data_real4_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real4_c + end interface + dimsr(4)=size(rdata,1) + dimsr(3)=size(rdata,2) + dimsr(2)=size(rdata,3) + dimsr(1)=size(rdata,4) + rdata_p => rdata(1,1,1,1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata_p) + call STRCUT(name1024, name) + call hdf5_write_data_real4_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_4d_real4 +! +subroutine hdf5_write_data_0d_real8(ifile, name, rdata) + ! write a rank 0 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8),intent(in), target :: rdata + ! + integer, parameter :: rank = 1 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + interface + subroutine hdf5_write_data_real8_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real8_c + end interface + dimsr(1)=1 + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata) + call STRCUT(name1024, name) + call hdf5_write_data_real8_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_0d_real8 +! +subroutine hdf5_write_data_1d_real8(ifile, name, rdata) + ! write a rank 1 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8),dimension(:),intent(in), target :: rdata + ! + integer, parameter :: rank = 1 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + real(8), pointer :: rdata_p + interface + subroutine hdf5_write_data_real8_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real8_c + end interface + dimsr(1)=size(rdata,1) + rdata_p => rdata(1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata_p) + call STRCUT(name1024, name) + call hdf5_write_data_real8_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_1d_real8 +! +subroutine hdf5_write_data_2d_real8(ifile, name, rdata) + ! write a rank 2 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8),dimension(:,:),intent(in), target :: rdata + ! + integer, parameter :: rank = 2 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + real(8), pointer :: rdata_p + interface + subroutine hdf5_write_data_real8_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real8_c + end interface + dimsr(2)=size(rdata,1) + dimsr(1)=size(rdata,2) + rdata_p => rdata(1,1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata_p) + call STRCUT(name1024, name) + call hdf5_write_data_real8_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_2d_real8 +! +subroutine hdf5_write_data_3d_real8(ifile, name, rdata) + ! write a rank 3 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8),dimension(:,:,:),intent(in), target :: rdata + ! + integer, parameter :: rank = 3 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + real(8), pointer :: rdata_p + interface + subroutine hdf5_write_data_real8_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real8_c + end interface + dimsr(3)=size(rdata,1) + dimsr(2)=size(rdata,2) + dimsr(1)=size(rdata,3) + rdata_p => rdata(1,1,1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata_p) + call STRCUT(name1024, name) + call hdf5_write_data_real8_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_3d_real8 +! +subroutine hdf5_write_data_4d_real8(ifile, name, rdata) + ! write a rank 4 real8 dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + real(8),dimension(:,:,:,:),intent(in), target :: rdata + ! + integer, parameter :: rank = 4 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + real(8), pointer :: rdata_p + interface + subroutine hdf5_write_data_real8_c(ifile, namp, rank, dimsf, rdata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank + type(c_ptr), value :: dimsf, rdata + end subroutine hdf5_write_data_real8_c + end interface + dimsr(4)=size(rdata,1) + dimsr(3)=size(rdata,2) + dimsr(2)=size(rdata,3) + dimsr(1)=size(rdata,4) + rdata_p => rdata(1,1,1,1) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(rdata_p) + call STRCUT(name1024, name) + call hdf5_write_data_real8_c(ifile, name1024, rank, pt_dimsr, pt_data) +end subroutine hdf5_write_data_4d_real8 +! +subroutine hdf5_write_data_0d_string(ifile, name, idata) + ! write a rank 1 string dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + character(len=*),intent(in), target :: idata + ! + integer, parameter :: rank = 1 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + character(len=1), pointer :: idata_p + interface + subroutine hdf5_write_data_string_c(ifile, namp, rank, lenstr, dimsf, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank, lenstr + type(c_ptr), value :: dimsf, idata + end subroutine hdf5_write_data_string_c + end interface + dimsr(1)=1 + idata_p => idata + lenstr=len(idata) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(idata_p) + call STRCUT(name1024, name) + call hdf5_write_data_string_c(ifile, name1024, rank, lenstr, pt_dimsr, pt_data) +end subroutine hdf5_write_data_0d_string +! +subroutine hdf5_write_data_1d_string(ifile, name, idata) + ! write a rank 1 string dataset + type(c_ptr),intent(in) :: ifile + character(len=*),intent(in) :: name + character(len=*),intent(in), dimension(:), target :: idata + ! + integer, parameter :: rank = 1 + integer,dimension(rank),target :: dimsr + type(c_ptr) :: pt_dimsr, pt_data + character(len=1), pointer :: idata_p + interface + subroutine hdf5_write_data_string_c(ifile, namp, rank, lenstr, dimsf, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: ifile + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: rank, lenstr + type(c_ptr), value :: dimsf, idata + end subroutine hdf5_write_data_string_c + end interface + dimsr(1)=size(idata,1) + idata_p => idata(1) + lenstr=len(idata(1)) + pt_dimsr=c_loc(dimsr) + pt_data=c_loc(idata_p) + call STRCUT(name1024, name) + call hdf5_write_data_string_c(ifile, name1024, rank, lenstr, pt_dimsr, pt_data) +end subroutine hdf5_write_data_1d_string +end module hdf5_wrap diff --git a/Ganlib/src/header.h b/Ganlib/src/header.h new file mode 100644 index 0000000..d61fd33 --- /dev/null +++ b/Ganlib/src/header.h @@ -0,0 +1,34 @@ +static struct { + int_32 nrecor; + int_32 ninput; + int_32 maxlvl; + int_32 nstack; + int_32 ixrlst; + int_32 ioulst; + int_32 idblst; + int_32 nobjet; + char cparin[13]; + char cdatin[121]; +} header ; + +static struct { + int_32 ilines; + int_32 ilevel; + int_32 irecor; + int_32 maskck[nmaskc]; + int_32 ipacki[nmaskc]; + char cparin[13]; + char myreco[121]; +} record1 ; + +static struct { + int_32 indlin; + int_32 idatin; + float_32 adatin; + double ddatin; + int_32 idclin; + int_32 idefin; + int_32 iusein; + char cparin[13]; + char cdatin[121]; +} record2 ; diff --git a/Ganlib/src/kdi.h b/Ganlib/src/kdi.h new file mode 100644 index 0000000..07f6078 --- /dev/null +++ b/Ganlib/src/kdi.h @@ -0,0 +1,27 @@ + +/**********************************/ +/* C API for kdi file support */ +/* author: A. Hebert (08/04/2005) */ +/**********************************/ + +/* +Copyright (C) 2005 Ecole Polytechnique de Montreal + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. +*/ + +#include <stdio.h> +#include "ganlib.h" + +typedef struct { + char nom[73]; /* FILE NAME */ + FILE *fd; /* FILE POINTER */ +} kdi_file; + +kdi_file * kdiop_c(char *, int_32); +int_32 kdiput_c(kdi_file *, int_32 *, int_32, int_32); +int_32 kdiget_c(kdi_file *, int_32 *, int_32, int_32); +int_32 kdicl_c(kdi_file *, int_32); diff --git a/Ganlib/src/kdi_c.c b/Ganlib/src/kdi_c.c new file mode 100644 index 0000000..8c551bb --- /dev/null +++ b/Ganlib/src/kdi_c.c @@ -0,0 +1,133 @@ + +/**********************************/ +/* C API for kdi file support */ +/* author: A. Hebert (30/04/2002) */ +/**********************************/ + +/* +Copyright (C) 2002 Ecole Polytechnique de Montreal + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. +*/ + +#if defined(CRAY) +#define lnword 8 +#else +#define lnword 4 +#endif + +#if !defined(MSDOS) +#include <unistd.h> +#endif +#include <fcntl.h> +#include <stdlib.h> +#include <string.h> +#include "kdi.h" + +long long offset; + +kdi_file * kdiop_c(char *nomC,int_32 iactio) +{ + kdi_file *my_file; + my_file = (kdi_file *) malloc(sizeof(*my_file)); + strcpy(my_file->nom,nomC); + my_file->fd = NULL; + if (iactio == 0) { + FILE *file ; + long fd; + if ( ( file = fopen(nomC,"rb") ) != NULL ) { + fclose(file) ; + perror ("open error 0 in kdiop_c "); + return NULL; + } + fd = creat(nomC,0600); + close(fd); + my_file->fd = fopen(nomC,"r+b"); + } else if (iactio == 1) { + FILE *file ; + if ( ( file = fopen(nomC,"rb") ) == NULL ) { + perror ("open error 1 in kdiop_c "); + return NULL; + } + fclose(file) ; + my_file->fd = fopen(nomC,"r+b"); + } else if (iactio == 2) { + FILE *file ; + if ( ( file = fopen(nomC,"rb") ) == NULL ) { + perror ("open error 2 in kdiop_c "); + return NULL; + } + my_file->fd = file; + } else { + return NULL; + } + if ( my_file->fd == NULL ) { + perror ("open error 3 in kdiop_c "); + return NULL; + } + return my_file; +} + +int_32 kdiput_c(kdi_file *my_file,int_32 *data,int_32 iofset,int_32 length) +{ + int_32 irc=0; + offset=(long long)iofset*lnword; + if (my_file == NULL) { + irc = -1; + } else if (fseek(my_file->fd,offset,0) >= 0) { + long long n, iof=0; + while ((n = fwrite(&data[iof],lnword,length,my_file->fd)) < length-iof) { + if (n < 0) return n-1; + iof+=n; + } + } else { + irc = -3; + } + return irc; +} + +int_32 kdiget_c(kdi_file *my_file,int_32 *data,int_32 iofset,int_32 length) +{ + int_32 irc=0; + offset=(long long)iofset*lnword; + if (my_file == NULL) { + irc = -1; + } else if (fseek(my_file->fd,offset,0) >= 0) { + long long n, iof=0; + while ((n = fread(&data[iof],lnword,length,my_file->fd)) < length-iof) { + if (n == 0) return -4; + if (n < 0) return n-1; + iof+=n; + } + } else { + irc = -3; + } + return irc; +} + +int_32 kdicl_c(kdi_file *my_file,int_32 istatu) +{ + long irc; + if (my_file == NULL) { + irc = -1; + } else if (istatu == 1) { + irc = fclose(my_file->fd); + free(my_file); + } else if (istatu == 2) { + irc = fclose(my_file->fd); + if (irc != 0 ) { + perror ("close error 1 in kdicl_c "); + return irc; + } + irc = remove(my_file->nom); + free(my_file); + } else { + irc = -999; + } + my_file = NULL; + if (irc != 0) perror ("close error 2 in kdicl_c "); + return irc; +} diff --git a/Ganlib/src/kdrdpr.c b/Ganlib/src/kdrdpr.c new file mode 100644 index 0000000..b911620 --- /dev/null +++ b/Ganlib/src/kdrdpr.c @@ -0,0 +1,120 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 31/07/10 */ +/*****************************************/ + +#include <string.h> +#include "cle2000.h" + +int_32 kdrdpr(lifo **my_iptrun, int_32 nentry, char (*hentry)[13]) +{ + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *KDRDPR* IS THE MODULE FOR *PROCEDURE * DECLARATIONS */ +/* =0 IF NO ERROR */ + +/* INPUT: *MY_IPTRUN* IS THE EXEC STRUCTURE POINTER (ALLOCATED) */ +/* *NENTRY* IS THE # OF LINKED LISTS AND FILES USED. */ +/* *HENTRY* NAMES OF EACH OBJECT <- LINKED LIST OR FILE. */ +/* ( CHARACTER*12 HENTRY(NENTRY) ) */ + +/* SYNTAX: */ +/* PROCEDURE *HENTRY(I=1,NENTRY)* ; */ +/* (DEFAULT VALUES, CHECK EXISTENCE) */ + +/* PROCEDURE *HENTRY(I=1,NENTRY)* :: *DATA* ; */ +/* (USER DEFINED VALUES, ACCESS TO CLE-2000 COMPILER) */ + + char *nomsub = "kdrdpr"; + int_32 ret_val = 0; + int_32 ityp, nitma, lndata; + float_32 flott; + double_64 dflot; + char text[73], messag[133], filenm[73], filinp[77], filobj[77]; + int_32 iloop1; + + if (nentry <= 0) goto L666; + + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + if (lndata) { + sprintf(messag, "%s: NOT DEVELOPED YET (RR)", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + int_32 iparam; + lifo_node *my_node; + + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -665; + goto L666; + } + iparam = my_node->type; + if (lndata) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp == 3) { + strcpy(filenm, text); + } else { + goto L8001; + } + } else { + strcpy(filenm, my_node->name); + } + + sprintf(filinp, "%s.c2m",filenm); + sprintf(filobj, "%s.o2m",filenm); + if (iparam == 1) { +/* ONLY VERIFY IF *filobj* EXISTS */ + FILE *file; + file = fopen(filobj, "r"); + if (file == NULL) { + sprintf(messag, "%s: OBJECT FILE *%s* DOES NOT EXIST: MUST BE COMPILED", nomsub, filobj); + printf("%-132s\n", messag); + ret_val = -1; + goto L666; + } else { + fclose(file); + } + } else { +/* ONLY VERIFY IF *filinp* EXISTS */ + FILE *file; + file = fopen(filinp, "r"); + if (file == NULL) { + sprintf(messag, "%s: INPUT FILE *%s* DOES NOT EXIST",nomsub, filinp); + printf("%-132s\n", messag); + ret_val = -1; + goto L666; + } else { + fclose(file); + } + my_node->type = -iparam; + strcpy(my_node->OSname, filobj); + } + } + +/* CAN WE FOUND *;* AT THE END OF THE SENTENCE ? */ + if (lndata) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3 || strcmp(text, ";") != 0) goto L8002; + } +L666: + return ret_val; + +L8001: + sprintf(messag, "%s: INVALID TYPE IN *PROCEDURE* DATA.", nomsub); + printf("%-132s\n", messag); + ret_val = 8001; + goto L666; +L8002: + sprintf(messag, "%s: INVALID END IN *PROCEDURE* DATA.", nomsub); + printf("%-132s\n", messag); + ret_val = 8002; + goto L666; +} /* kdrdpr */ diff --git a/Ganlib/src/kdrprm.c b/Ganlib/src/kdrprm.c new file mode 100644 index 0000000..5818835 --- /dev/null +++ b/Ganlib/src/kdrprm.c @@ -0,0 +1,994 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 31/07/10 */ +/*****************************************/ + +#include <stdlib.h> +#include <string.h> +#include "cle2000.h" +#define mpara2 64 +#define ndclkw 9 + +int_32 kdrprm(lifo **my_iptrun, lifo **my_param, int_32 minput, int_32 nentry, int_32 *jentry, char (*hentry)[13]) +{ + char *nomsub = "kdrprm"; + static char *cdclkw[] = {"PROCEDURE", "MODULE", "LINKED_LIST", "XSM_FILE", "SEQ_BINARY", + "SEQ_ASCII", "DIR_ACCESS", "HDF5_FILE", "PARAMETER"}; + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *KDRPRM* IS USED TO PASS DUMMY ARGUMENTS */ +/* IN CLE-2000 PROCEDURES. */ + +/* INPUT: *MY_IPTRUN* IS THE EXEC STRUCTURE POINTER (ALLOCATED) */ +/* *MY_PARAM* IS THE PARAMETER STRUCTURE POINTER (ALLOCATED) */ +/* *MINPUT* IS AN INTEGER -1: TO READ PARM INPUT (IN MAIN) */ +/* 0: TO GET PARM INPUT (IN PROC) */ +/* +1: TO RETURN VALUES (IN MAIN) */ +/* *NENTRY* IS THE # OF LINKED LISTS AND FILES USED. */ +/* *HENTRY* NAMES OF EACH OBJECT <- LINKED LIST OR FILE. */ +/* ( CHARACTER*12 HENTRY(NENTRY) ) */ + + int_32 ret_val = 0; + int_32 iloop1, iparam, jparam, lparam=0, nusepr; + lcm *kparam = NULL; + char hparam[73], messag[133], AbortString[132]; + char hwrite[73] = " "; + lifo_node *my_node; + + if (minput == -1) { +/* PUT OBJECTS INTO *IPTRUN* BEFORE CALLING A PROCEDURE */ + cleopn(my_param); + if (nentry != 0) { + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -20; + goto L666; + } + iparam = my_node->type; + jparam = my_node->access; + if (iparam == 3) kparam = my_node->value.mylcm; + if (iparam == 7) lparam = my_node->lparam; + if (abs(iparam) <= 10) { + if (strlen(my_node->OSname) > 72) { + sprintf(AbortString,"%s: OSname EXCEEDING 72 CHARACTERS.",nomsub); + xabort_c(AbortString); + } + strcpy(hparam, my_node->OSname); + } else { + strcpy(hparam, " "); + } + + my_node = (lifo_node *) malloc(sizeof(lifo_node)); + strcpy(my_node->name, hentry[iloop1]); + my_node->type = iparam; + my_node->access = jentry[iloop1]; + if (iparam == 3) my_node->value.mylcm = kparam; + if (iparam == 7) my_node->lparam = lparam; + strcpy(my_node->OSname, hparam); + clepush(my_param, my_node); + } + } + + } else if (minput == 0) { + int_32 npara2, l2data=0, jrecin, iretcd; + FILE *jwrite; + char hpara2[mpara2][13]; + kdi_file *jread; + +/* LINK DUMMY OBJECTS WITH THEIR ACTUAL ARGUMENTS */ + int_32 ityp, nitma, lndata; + float_32 flott; + double_64 dflot; + char text[73], cmodul[13], aparam[13]; + int_32 iprint = 0; + + if (nentry <= 0) { + sprintf(messag, "%s: *PARAMETER* WITHOUT OBJECTS", nomsub); + printf("%-132s\n", messag); + ret_val = -1; + goto L666; + } + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + if (lndata && ityp == 3 && strcmp(text, "EDIT") == 0) { + redget_c(&ityp, &iprint, &flott, text, &dflot); + if (ityp != 1 && iprint < 0) { + sprintf(messag, "%s: AFTER *EDIT*, PUT A POSITIVE INT", nomsub); + printf("%-132s\n", messag); + ret_val = -2; + goto L666; + } + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + } + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + my_node = clepos(my_param, iloop1); + strcpy(my_node->name_daughter, hentry[iloop1]); + if (strlen(my_node->name) > 12) { + sprintf(AbortString,"%s: name EXCEEDING 12 CHARACTERS.",nomsub); + xabort_c(AbortString); + } + strcpy(aparam, my_node->name); + iparam = my_node->type; + jparam = my_node->access; + if (iparam == 3) kparam = my_node->value.mylcm; + if (iparam == 7) lparam = my_node->lparam; + if (abs(iparam) <= 10) { + if (strlen(my_node->OSname) > 72) { + sprintf(AbortString,"%s: OSname EXCEEDING 72 CHARACTERS.",nomsub); + xabort_c(AbortString); + } + strcpy(hparam, my_node->OSname); + } else { + strcpy(hparam, " "); + } + + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -21; + goto L666; + } + my_node->type = iparam; + my_node->access = jparam; + if (iparam == 3) my_node->value.mylcm = kparam; + if (iparam == 7) my_node->lparam = lparam; +#if defined(HDF5_LIB) + if (iparam == 8) my_node->value.myhdf5 = (hid_t)kparam; +#endif + strcpy(my_node->OSname, hparam); + if (iprint > 0) { + printf("PARAMETER %s <= %s with name(*%s*)\n", hentry[iloop1], aparam, hparam); + if (iparam <= 0) { + printf(" %s UNDEFINED.\n", cdclkw[-iparam-1]); + } else { + printf(" %s DEFINED.\n", cdclkw[iparam-1]); + } + } + } + +/* NOW, CALL THE EMBEDDED DECLARATION MODULE IF DATA */ +L21: +/* MAKES IT A *DO WHILE* STRUCTURE */ + if (!lndata) goto L666; + if (ityp != 3 || strcmp(text, ":::") != 0) { + sprintf(messag, "%s: INVALID EMBEDDED DECL MODUL DATA", nomsub); + printf("%-132s\n", messag); + ret_val = -4; + goto L666; + } + +/* GET DECLARATION MODULE NAME */ + redget_c(&ityp, &nitma, &flott, text, &dflot); + nusepr = 0; + for (iloop1 = 0; iloop1 < ndclkw; ++iloop1) { + if (strcmp(text, cdclkw[iloop1]) == 0) nusepr = iloop1 + 1; + } + if (nusepr == 0) { + sprintf(messag, "%s: INVALID DECLARATION KEYWORD", nomsub); + printf("%-132s\n", messag); + ret_val = -5; + goto L666; + } + strcpy(cmodul, cdclkw[nusepr-1]); + +/* GET OBJECT LIST */ + npara2 = 0; + for (iloop1 = 0; iloop1 < nentry + 1; ++iloop1) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp == 3) { + if (strcmp(text, ";") == 0) { + l2data = 0; + redcls_c(&jread, &jwrite, hwrite, &jrecin); + break; + } else if (strcmp(text, "::") == 0) { + l2data = 1; + break; + } else { +/* READER'S NAME *MUST* BE ONE OF *HENTRY* */ + int_32 jloop2; + for (jloop2 = 1; jloop2 <= nentry; ++jloop2) { + if (strcmp(text, hentry[jloop2-1]) == 0) { + ++npara2; + strcpy(hpara2[npara2-1], hentry[jloop2-1]); + goto L25; + } + } + if (iloop1 != nentry) { + sprintf(messag, "%s: OBJECT *%s* NOT IN THE INPUT LIST", nomsub, text); + ret_val = -7; + } else { + sprintf(messag, "%s: TOO MANY OBJECTS IN EMBEDDED MODULE", nomsub); + ret_val = -8; + } + printf("%-132s\n", messag); + } + } else { + sprintf(messag, "%s: INVALID TYPE IN EMBEDDED MODULE", nomsub); + printf("%-132s\n", messag); + ret_val = -6; + } + goto L666; +L25: + continue; + } +/* NOW CALL THE SELECTED DECLARATION MODULE */ + if (strcmp(cmodul, "MODULE") == 0) { +/* *MODULE * DECLARATION MODULE */ + iretcd = kdrdmd(my_iptrun, npara2, hpara2); + } else if (strcmp(cmodul, "LINKED_LIST") == 0) { +/* *LINKED_LIST * DECLARATION MODULE */ + iretcd = kdrdll(my_iptrun, npara2, hpara2); + } else if (strcmp(cmodul, "XSM_FILE") == 0) { +/* *XSM_FILE * DECLARATION MODULE */ + iretcd = kdrdxf(my_iptrun, npara2, hpara2); + } else if (strcmp(cmodul, "SEQ_BINARY") == 0) { +/* *SEQ_BINARY * DECLARATION MODULE */ + iretcd = kdrdsb(my_iptrun, npara2, hpara2); + } else if (strcmp(cmodul, "SEQ_ASCII") == 0) { +/* *SEQ_ASCII * DECLARATION MODULE */ + iretcd = kdrdsa(my_iptrun, npara2, hpara2); + } else if (strcmp(cmodul, "DIR_ACCESS") == 0) { +/* *DIR_ACCESS * DECLARATION MODULE */ + iretcd = kdrdda(my_iptrun, npara2, hpara2); + } else if (strcmp(cmodul, "HDF5_FILE") == 0) { +/* *HDF5_FILE * DECLARATION MODULE */ + iretcd = kdrdh5(my_iptrun, npara2, hpara2); + } else { +/* OTHERWISE, DECLARATION MODULE IS NOT AVAILABLE */ + sprintf(messag, "%s: EMBEDDED PARAMETER MODULE *%s* IS NOT AVAILABLE", nomsub, cmodul); + printf("%-132s\n", messag); + ret_val = -9; + goto L666; + } + if (iretcd != 0) { + sprintf(messag, "%s: PROBLEM WITH EMBEDDED MODULE *%s*", nomsub, cmodul); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + + if (!l2data) redopn_c(jread, jwrite, hwrite, jrecin); + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + goto L21; + + } else if (minput == 1) { +/* RETURN OBJECTS CREATED IN THE PROCEDURE BEFORE ENDING */ + if ((*my_param)->nup != 0) { + char aparam[13]; + for (iloop1 = 0; iloop1 < (*my_param)->nup; ++iloop1) { + my_node = clepos(my_param, iloop1); + if ((my_node->type < 0) || (my_node->type >= 10)) continue; + if (strlen(my_node->name) > 12) { + sprintf(AbortString,"%s: name EXCEEDING 12 CHARACTERS.",nomsub); + xabort_c(AbortString); + } + strcpy(aparam, my_node->name); + iparam = my_node->type; + if (iparam == 3) kparam = my_node->value.mylcm; + + my_node = clenode(my_iptrun, aparam); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, aparam); + ret_val = -23; + goto L666; + } + my_node->type = iparam; + if (iparam == 3) my_node->value.mylcm = kparam; + } + } + } else { + sprintf(messag, "%s: INVALID VALUE FOR *MINPUT* ARG", nomsub); + printf("%-132s\n", messag); + ret_val = -3; + } +L666: + return ret_val; +} /* kdrprm */ + +int_32 kdrdmd(lifo **my_iptrun, int_32 nentry, char (*hentry)[13]) +{ + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *KDRDMD* IS THE MODULE FOR *MODULE * DECLARATIONS */ +/* =0 IF NO ERROR */ + +/* INPUT: *MY_IPTRUN* IS THE EXEC STRUCTURE POINTER (ALLOCATED) */ +/* *NENTRY* IS THE # OF LINKED LISTS AND FILES USED. */ +/* *HENTRY* NAMES OF EACH OBJECT <- LINKED LIST OR FILE. */ +/* ( CHARACTER*12 HENTRY(NENTRY) ) */ + + char *nomsub = "kdrdmd"; + int_32 ret_val = 0; + int_32 ityp, nitma, lndata; + float_32 flott; + double_64 dflot; + char text[73], messag[73]; + int_32 iloop1, iparam; + + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + if (lndata) { + sprintf(messag, "%s: NOT DEVELOPED YET (RR)", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + lifo_node *my_node; + + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -21; + goto L666; + } + iparam = my_node->type ; + if (abs(iparam) != 2) goto L8001; + } + +/* CAN WE FOUND *;* AT THE END OF THE SENTENCE ? */ + if (lndata) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3 || strcmp(text, ";") != 0) goto L8002; + } +L666: + return ret_val; + +L8001: + sprintf(messag, "%s: INVALID TYPE (%d) IN *MODULE* DATA.", nomsub, (int)iparam); + printf("%-132s\n", messag); + ret_val = 8001; + goto L666; +L8002: + sprintf(messag, "%s: INVALID END IN *MODULE* DATA.", nomsub); + printf("%-132s\n", messag); + ret_val = 8002; + goto L666; +} /* kdrdmd */ + +int_32 kdrdll(lifo **my_iptrun, int_32 nentry, char (*hentry)[13]) +{ + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *KDRDLL* IS THE MODULE FOR *LINKED_LIST * DECLARATIONS */ +/* =0 IF NO ERROR */ + +/* INPUT: *MY_IPTRUN* IS THE EXEC STRUCTURE POINTER (ALLOCATED) */ +/* *NENTRY* IS THE # OF LINKED LISTS AND FILES USED. */ +/* *HENTRY* NAMES OF EACH OBJECT <- LINKED LIST OR FILE. */ +/* ( CHARACTER*12 HENTRY(NENTRY) ) */ + + char *nomsub = "kdrdll"; + int_32 ret_val = 0; + int_32 ityp, nitma, lndata; + float_32 flott; + double_64 dflot; + char text[73], messag[73]; + int_32 iloop1, iparam; + + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + if (lndata) { + sprintf(messag, "%s: NOT DEVELOPED YET (RR)", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + lifo_node *my_node; + + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -21; + goto L666; + } + iparam = my_node->type ; + if (abs(iparam) != 3) goto L8001; + } + +/* CAN WE FOUND *;* AT THE END OF THE SENTENCE ? */ + if (lndata) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3 || strcmp(text, ";") != 0) goto L8002; + } +L666: + return ret_val; + +L8001: + sprintf(messag, "%s: INVALID TYPE (%d) IN *LINKED_LIST * DATA.", nomsub, (int)iparam); + printf("%-132s\n", messag); + ret_val = 8001; + goto L666; +L8002: + sprintf(messag, "%s: INVALID END IN *LINKED_LIST * DATA.", nomsub); + printf("%-132s\n", messag); + ret_val = 8002; + goto L666; +} /* kdrdll */ + +int_32 kdrdxf(lifo **my_iptrun, int_32 nentry, char (*hentry)[13]) +{ + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *KDRDXF* IS THE MODULE FOR *XSM_FILE * DECLARATIONS */ +/* =0 IF NO ERROR */ + +/* INPUT: *MY_IPTRUN* IS THE EXEC STRUCTURE POINTER (ALLOCATED) */ +/* *NENTRY* IS THE # OF LINKED LISTS AND FILES USED. */ +/* *HENTRY* NAMES OF EACH OBJECT <- LINKED LIST OR FILE. */ +/* ( CHARACTER*12 HENTRY(NENTRY) ) */ + + char *nomsub = "kdrdxf"; + int_32 ret_val = 0; + int_32 ityp, nitma, lndata; + float_32 flott; + double_64 dflot; + char text[73], messag[73]; + int_32 iprint = 0; + int_32 iloop1, iparam; + + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + if (lndata) { + if (ityp == 3) { + if (strcmp(text, "EDIT") == 0) { + redget_c(&ityp, &iprint, &flott, text, &dflot); + if (ityp != 1 && iprint < 0) { + sprintf(messag, "%s: AFTER *EDIT*, PUT A POSITIVE INT", nomsub); + printf("%-132s\n", messag); + ret_val = -1; + goto L666; + } + redget_c(&ityp, &nitma, &flott, text, &dflot); + } + if (strcmp(text, "FILE") != 0) { + sprintf(messag, "%s: EXPECTING *FILE* KEYWORD; TEXT=%.12s", nomsub, text); + printf("%-132s\n", messag); + ret_val = -2; + goto L666; + } + } else { + sprintf(messag, "%s: INVALID INPUT", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + } + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + lifo_node *my_node; + + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -21; + goto L666; + } + iparam = my_node->type ; + if (abs(iparam) != 4) goto L8001; + if (lndata) { + FILE *file; + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3) { + sprintf(messag, "%s: INVALID FILE NAME", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + file = fopen(text, "r"); + +/* DEFINE EXISTENCE MODE */ + if (file != NULL) { + fclose(file); + if (iprint != 0) printf("OLD/XF: %s\n", text); + if (iparam < 0) my_node->type = -iparam; + my_node->access = 1; + } else { + if (iprint != 0) printf("NEW/XF: %s\n", text); + if (iparam > 0) my_node->type = -iparam; + my_node->access = 0; + } + +/* REGISTER FILE NAME */ + strcpy(my_node->OSname, text); + } + } + +/* CAN WE FOUND *;* AT THE END OF THE SENTENCE ? */ + if (lndata) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3 || strcmp(text, ";") != 0) goto L8002; + } +L666: + return ret_val; + +L8001: + sprintf(messag, "%s: INVALID TYPE (%d) IN *XSM_FILE * DATA.", nomsub, (int)iparam); + printf("%-132s\n", messag); + ret_val = 8001; + goto L666; +L8002: + sprintf(messag, "%s: INVALID END IN *XSM_FILE * DATA.", nomsub); + printf("%-132s\n", messag); + ret_val = 8002; + goto L666; +} /* kdrdxf */ + +int_32 kdrdsb(lifo **my_iptrun, int_32 nentry, char (*hentry)[13]) +{ + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *KDRDSB* IS THE MODULE FOR *SEQ_BINARY * DECLARATIONS */ +/* =0 IF NO ERROR */ + +/* INPUT: *MY_IPTRUN* IS THE EXEC STRUCTURE POINTER (ALLOCATED) */ +/* *NENTRY* IS THE # OF LINKED LISTS AND FILES USED. */ +/* *HENTRY* NAMES OF EACH OBJECT <- LINKED LIST OR FILE. */ +/* ( CHARACTER*12 HENTRY(NENTRY) ) */ + + char *nomsub = "kdrdsb"; + int_32 ret_val = 0; + int_32 ityp, nitma, lndata; + float_32 flott; + double_64 dflot; + char text[73], messag[73]; + int_32 iprint = 0; + int_32 iloop1, iparam; + + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + if (lndata) { + if (ityp == 3) { + if (strcmp(text, "EDIT") == 0) { + redget_c(&ityp, &iprint, &flott, text, &dflot); + if (ityp != 1 && iprint < 0) { + sprintf(messag, "%s: AFTER *EDIT*, PUT A POSITIVE INT", nomsub); + printf("%-132s\n", messag); + ret_val = -1; + goto L666; + } + redget_c(&ityp, &nitma, &flott, text, &dflot); + } + if (strcmp(text, "FILE") != 0) { + sprintf(messag, "%s: EXPECTING *FILE* KEYWORD; TEXT=%.12s", nomsub, text); + printf("%-132s\n", messag); + ret_val = -2; + goto L666; + } + } else { + sprintf(messag, "%s: INVALID INPUT", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + } + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + lifo_node *my_node; + + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -21; + goto L666; + } + iparam = my_node->type ; + if (abs(iparam) != 5) goto L8001; + if (lndata) { + FILE *file; + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3) { + sprintf(messag, "%s: INVALID FILE NAME", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + file = fopen(text, "r"); + +/* DEFINE EXISTENCE MODE */ + if (file != NULL) { + fclose(file); + if (iprint != 0) printf("OLD/SB: %s\n", text); + if (iparam < 0) my_node->type = -iparam; + my_node->access = 2; + } else { + if (iprint != 0) printf("NEW/SB: %s\n", text); + if (iparam > 0) my_node->type = -iparam; + my_node->access = 0; + } + +/* REGISTER FILE NAME */ + strcpy(my_node->OSname, text); + } + } + +/* CAN WE FOUND *;* AT THE END OF THE SENTENCE ? */ + if (lndata) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3 || strcmp(text, ";") != 0) goto L8002; + } +L666: + return ret_val; + +L8001: + sprintf(messag, "%s: INVALID TYPE (%d) IN *SEQ_BINARY * DATA.", nomsub, (int)iparam); + printf("%-132s\n", messag); + ret_val = 8001; + goto L666; +L8002: + sprintf(messag, "%s: INVALID END IN *SEQ_BINARY * DATA.", nomsub); + printf("%-132s\n", messag); + ret_val = 8002; + goto L666; +} /* kdrdsb */ + +int_32 kdrdsa(lifo **my_iptrun, int_32 nentry, char (*hentry)[13]) +{ + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *KDRDSA* IS THE MODULE FOR *SEQ_ASCII * DECLARATIONS */ +/* =0 IF NO ERROR */ + +/* INPUT: *MY_IPTRUN* IS THE EXEC STRUCTURE POINTER (ALLOCATED) */ +/* *NENTRY* IS THE # OF LINKED LISTS AND FILES USED. */ +/* *HENTRY* NAMES OF EACH OBJECT <- LINKED LIST OR FILE. */ +/* ( CHARACTER*12 HENTRY(NENTRY) ) */ + + char *nomsub = "kdrdsa"; + int_32 ret_val = 0; + int_32 ityp, nitma, lndata; + float_32 flott; + double_64 dflot; + char text[73], messag[73]; + int_32 iprint = 0; + int_32 iloop1, iparam; + + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + if (lndata) { + if (ityp == 3) { + if (strcmp(text, "EDIT") == 0) { + redget_c(&ityp, &iprint, &flott, text, &dflot); + if (ityp != 1 && iprint < 0) { + sprintf(messag, "%s: AFTER *EDIT*, PUT A POSITIVE INT", nomsub); + printf("%-132s\n", messag); + ret_val = -1; + goto L666; + } + redget_c(&ityp, &nitma, &flott, text, &dflot); + } + if (strcmp(text, "FILE") != 0) { + sprintf(messag, "%s: EXPECTING *FILE* KEYWORD; TEXT=%.12s", nomsub, text); + printf("%-132s\n", messag); + ret_val = -2; + goto L666; + } + } else { + sprintf(messag, "%s: INVALID INPUT", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + } + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + lifo_node *my_node; + + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -21; + goto L666; + } + iparam = my_node->type ; + if (abs(iparam) != 6) goto L8001; + if (lndata) { + FILE *file; + redget_c(&ityp, &nitma, &flott,text, &dflot); + if (ityp != 3) { + sprintf(messag, "%s: INVALID FILE NAME", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + file = fopen(text, "r"); + +/* DEFINE EXISTENCE MODE */ + if (file != NULL) { + fclose(file); + if (iprint != 0) printf("OLD/SA: %s\n", text); + if (iparam < 0) my_node->type = -iparam; + my_node->access = 2; + } else { + if (iprint != 0) printf("NEW/SA: %s\n", text); + if (iparam > 0) my_node->type = -iparam; + my_node->access = 0; + } + +/* REGISTER FILE NAME */ + strcpy(my_node->OSname, text); + } + } + +/* CAN WE FOUND *;* AT THE END OF THE SENTENCE ? */ + if (lndata) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3 || strcmp(text, ";") != 0) goto L8002; + } +L666: + return ret_val; + +L8001: + sprintf(messag, "%s: INVALID TYPE (%d) IN *SEQ_ASCII * DATA.", nomsub, (int)iparam); + printf("%-132s\n", messag); + ret_val = 8001; + goto L666; +L8002: + sprintf(messag, "%s: INVALID END IN *SEQ_ASCII * DATA.", nomsub); + printf("%-132s\n", messag); + ret_val = 8002; + goto L666; +} /* kdrdsa */ + +int_32 kdrdda(lifo **my_iptrun, int_32 nentry, char (*hentry)[13]) +{ + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *KDRDDA* IS THE MODULE FOR *DIR_ACCESS * DECLARATIONS */ +/* =0 IF NO ERROR */ + +/* INPUT: *MY_IPTRUN* IS THE EXEC STRUCTURE POINTER (ALLOCATED) */ +/* *NENTRY* IS THE # OF LINKED LISTS AND FILES USED. */ +/* *HENTRY* NAMES OF EACH OBJECT <- LINKED LIST OR FILE. */ +/* ( CHARACTER*12 HENTRY(NENTRY) ) */ + + char *nomsub = "kdrdda"; + int_32 ret_val = 0; + int_32 ityp, nitma, lnfile=0, lndata; + float_32 flott; + double_64 dflot; + char text[73], messag[73], filenm[73]; + int_32 iprint = 0; + int_32 iloop1, iparam, lparam; + + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + if (lndata) { + if (ityp == 3) { + if (strcmp(text, "EDIT") == 0) { + redget_c(&ityp, &iprint, &flott, text, &dflot); + if (ityp != 1 && iprint < 0) { + sprintf(messag, "%s: AFTER *EDIT*, PUT A POSITIVE INT", nomsub); + printf("%-132s\n", messag); + ret_val = -1; + goto L666; + } + redget_c(&ityp, &nitma, &flott, text, &dflot); + } + if (strcmp(text, "FILE") == 0) { + lnfile = 1; + redget_c(&ityp, &nitma, &flott, text, &dflot); + } else { + lnfile = 0; + } + if (strcmp(text, "RECL") != 0) { + sprintf(messag, "%s: KEYWORD *RECL* MUST BE THERE", nomsub); + printf("%-132s\n", messag); + ret_val = -2; + goto L666; + } + } else { + sprintf(messag, "%s: INVALID INPUT", nomsub); + printf("%-132s\n", messag); + ret_val = -3; + goto L666; + } + } + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + lifo_node *my_node; + + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -21; + goto L666; + } + iparam = my_node->type ; + if (abs(iparam) != 7) goto L8001; + if (lndata) { + lparam = 0; + strcpy(filenm, ";"); + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp == 1) lparam = nitma; + if (ityp == 3) strcpy(filenm, text); + if (lnfile) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp == 1) lparam = nitma; + if (ityp == 3) strcpy(filenm, text); + } + if (lparam <= 0) { + sprintf(messag, "%s: INVALID VALUE FOR *RECL*", nomsub); + printf("%-132s\n", messag); + ret_val = -4; + goto L666; + } else { +/* REGISTER RECORD LENGTH OF EACH DA FILES */ + my_node->lparam = lparam; + } + if (lnfile) { + FILE *file; + if (strcmp(filenm, ";") == 0) { + sprintf(messag, "%s: INVALID FILE NAME", nomsub); + printf("%-132s\n", messag); + ret_val = -5; + goto L666; + } + file = fopen(filenm, "r"); + +/* DEFINE EXISTENCE MODE */ + if (file != NULL) { + fclose(file); + if (iprint != 0) printf("OLD/DA: %s\n", text); + if (iparam < 0) my_node->type = -iparam; + my_node->access = 2; + } else { + if (iprint != 0) printf("NEW/DA: %s\n", text); + if (iparam > 0) my_node->type = -iparam; + my_node->access = 0; + } + +/* REGISTER FILE NAME */ + strcpy(my_node->OSname, text); + } + } else { +/* ONLY VERIFY IF *RECL* MAKES SENSE FOR A DEFINED DA */ + if (iparam > 0) { + lparam = my_node->lparam; + if (lparam <= 0) { + sprintf(messag, "%s: INVALID VALUE FOR *RECL*", nomsub); + printf("%-132s\n", messag); + ret_val = -6; + goto L666; + } + } + } + } + +/* CAN WE FOUND *;* AT THE END OF THE SENTENCE ? */ + if (lndata) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3 || strcmp(text, ";") != 0) goto L8002; + } +L666: + return ret_val; + +L8001: + sprintf(messag, "%s: INVALID TYPE (%d) IN *DIR_ACCESS * DATA.", nomsub, (int)iparam); + printf("%-132s\n", messag); + ret_val = 8001; + goto L666; +L8002: + sprintf(messag, "%s: INVALID END IN *DIR_ACCESS * DATA.", nomsub); + printf("%-132s\n", messag); + ret_val = 8002; + goto L666; +} /* kdrdda */ + +int_32 kdrdh5(lifo **my_iptrun, int_32 nentry, char (*hentry)[13]) +{ + +/* GAN-2000 SYSTEM: R.ROY (01/2000), VERSION 2.1 */ + +/* *KDRDH5* IS THE MODULE FOR *HDF5_FILE * DECLARATIONS */ +/* =0 IF NO ERROR */ + +/* INPUT: *MY_IPTRUN* IS THE EXEC STRUCTURE POINTER (ALLOCATED) */ +/* *NENTRY* IS THE # OF LINKED LISTS AND FILES USED. */ +/* *HENTRY* NAMES OF EACH OBJECT <- LINKED LIST OR FILE. */ +/* ( CHARACTER*12 HENTRY(NENTRY) ) */ + + char *nomsub = "kdrdh5"; + int_32 ret_val = 0; + int_32 ityp, nitma, lndata; + float_32 flott; + double_64 dflot; + char text[73], messag[73]; + int_32 iprint = 0; + int_32 iloop1, iparam; + + redget_c(&ityp, &nitma, &flott, text, &dflot); + lndata = ityp != 10 && (ityp != 3 || strcmp(text, ";") != 0); + if (lndata) { + if (ityp == 3) { + if (strcmp(text, "EDIT") == 0) { + redget_c(&ityp, &iprint, &flott, text, &dflot); + if (ityp != 1 && iprint < 0) { + sprintf(messag, "%s: AFTER *EDIT*, PUT A POSITIVE INT", nomsub); + printf("%-132s\n", messag); + ret_val = -1; + goto L666; + } + redget_c(&ityp, &nitma, &flott, text, &dflot); + } + if (strcmp(text, "FILE") != 0) { + sprintf(messag, "%s: EXPECTING *FILE* KEYWORD; TEXT=%.12s", nomsub, text); + printf("%-132s\n", messag); + ret_val = -2; + goto L666; + } + } else { + sprintf(messag, "%s: INVALID INPUT", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + } + for (iloop1 = 0; iloop1 < nentry; ++iloop1) { + lifo_node *my_node; + + my_node = clenode(my_iptrun, hentry[iloop1]); + if (my_node == NULL) { + printf("%s: UNABLE TO FIND NODE FOR %s\n", nomsub, hentry[iloop1]); + ret_val = -21; + goto L666; + } + iparam = my_node->type ; + if (abs(iparam) != 8) goto L8001; + if (lndata) { + FILE *file; + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3) { + sprintf(messag, "%s: INVALID FILE NAME", nomsub); + printf("%-132s\n", messag); + ret_val = -666; + goto L666; + } + file = fopen(text, "r"); + +/* DEFINE EXISTENCE MODE */ + if (file != NULL) { + fclose(file); + if (iprint != 0) printf("OLD/XF: %s\n", text); + if (iparam < 0) my_node->type = -iparam; + my_node->access = 1; + } else { + if (iprint != 0) printf("NEW/XF: %s\n", text); + if (iparam > 0) my_node->type = -iparam; + my_node->access = 0; + } + +/* REGISTER FILE NAME */ + strcpy(my_node->OSname, text); + } + } + +/* CAN WE FOUND *;* AT THE END OF THE SENTENCE ? */ + if (lndata) { + redget_c(&ityp, &nitma, &flott, text, &dflot); + if (ityp != 3 || strcmp(text, ";") != 0) goto L8002; + } +L666: + return ret_val; + +L8001: + sprintf(messag, "%s: INVALID TYPE (%d) IN *HDF5_FILE * DATA.", nomsub, (int)iparam); + printf("%-132s\n", messag); + ret_val = 8001; + goto L666; +L8002: + sprintf(messag, "%s: INVALID END IN *HDF5_FILE * DATA.", nomsub); + printf("%-132s\n", messag); + ret_val = 8002; + goto L666; +} /* kdrdh5 */ diff --git a/Ganlib/src/lcm.h b/Ganlib/src/lcm.h new file mode 100644 index 0000000..5f80ab8 --- /dev/null +++ b/Ganlib/src/lcm.h @@ -0,0 +1,97 @@ + +/**********************************/ +/* C API for lcm object support */ +/* author: A. Hebert (30/04/2002) */ +/**********************************/ + +/* +Copyright (C) 2002 Ecole Polytechnique de Montreal + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. +*/ +#ifndef lcm_H +#define lcm_H + +#define maxext 70 +#define lhash 251 +#include <stdio.h> +#include "xsm.h" + +typedef struct Blocka { /* fixed length resident-memory structure */ + int_32 header; /* header (=100 remory-resident; =200 xsm file) */ + char hname[73]; /* character*72 name of the lcm object */ + int_32 listlen; /* number of elements in the list */ + struct Blockb *inext; /* address of block 2 array in memory */ + struct Blocka *father; /* address of the father lcm object. =null for root directory */ + int_32 ifdir; /* 0 / record index in father table */ + int_32 imode; /* 0=closed/1=modification mode/2=read-only mode */ + int_32 imax; /* maximum number of records in table */ + int_32 inref; /* exact number of records in table */ + struct Db0 *icang; /* address of the directory database handle */ + struct Dbref *global; /* address of the global variable database handle */ + int_32 *hash; /* hash table address */ +} lcm ; + +typedef struct Blockb { /* variable length resident-memory structure */ + int_32 *jdata; /* data offset */ + int_32 jjlon; /* record length (in words) */ + int_32 jjtyp; /* record type */ + int_32 jidat[4]; /* first/last element of record (4 words) */ + int jcmt[3]; /* character*12 name of record (3 words) */ +} blockb ; + +typedef struct Db0{ /* database handle */ + int_32 nad; /* number of addresses in the database */ + int_32 maxad; /* maximum slots in the database */ + lcm **idir; /* address of the array of pointers */ +} db0 ; + +typedef struct Dbref{ /* database handle */ + int_32 nad; /* number of addresses in the database */ + int_32 maxad; /* maximum slots in the database */ + int_32 **local; /* address of the array of local references */ +} dbref ; + +void lcmop_c(lcm **, char *, int_32, int_32, int_32); +void lcmppd_c(lcm **, const char *, int_32, int_32, int_32 *); +void lcmlen_c(lcm **, const char *, int_32 *, int_32 *); +void lcminf_c(lcm **, char *, char *, int_32 *, int_32 *, int_32 *, int_32 *); +void lcmnxt_c(lcm **, char *); +void lcmgpd_c(lcm **, const char *, int_32 **); +void lcmget_c(lcm **, const char *, int_32 *); +void lcmval_c(lcm **, const char *); +void lcmcl_c(lcm **, int_32); +void lcmdel_c(lcm **,const char *); +void lcmsix_c(lcm **, const char *, int_32); +lcm * lcmdid_c(lcm **, const char *); +lcm * lcmlid_c(lcm **, const char *, int_32); +lcm * lcmdil_c(lcm **, int_32); +lcm * lcmlil_c(lcm **, int_32, int_32); +void lcmppl_c(lcm **, int_32, int_32, int_32, int_32 *); +void lcmlel_c(lcm **, int_32, int_32 *, int_32 *); +void lcmgpl_c(lcm **, int_32, int_32 **); +void lcmgdl_c(lcm **, int_32, int_32 *); +lcm * lcmgid_c(lcm **, const char *); +lcm * lcmgil_c(lcm **, int_32); +void lcmequ_c(lcm **,lcm **); +void lcmput_c(lcm **,const char *,int_32,int_32,int_32 *); +void lcmpdl_c(lcm **,int_32,int_32,int_32 itype,int_32 *); +void lcmpcd_c(lcm **,const char *,int_32,char *[]); +void lcmgcd_c(lcm **,const char *,char *[]); +void lcmpcl_c(lcm **,int_32,int_32 iint_32,char *[]); +void lcmgcl_c(lcm **,int_32,char *[]); +void lcmpsd_c(lcm **,const char *,char *); +char * lcmgsd_c(lcm **,const char *); +void lcmpsl_c(lcm **,int_32,char *); +char * lcmgsl_c(lcm **,int_32); +void lcmlib_c(lcm **); +void lcmexp_c(lcm **, int_32, FILE *, int_32, int_32); +void lcmexpv3_c(lcm **, int_32, FILE *, int_32, int_32); +void refpush(lcm **, int_32 *); +int_32 refpop(lcm **, int_32 *); +void strcut_c(char *, char *, int_32); +void strfil_c(char *, char *, int_32); +#endif diff --git a/Ganlib/src/lcm_c.c b/Ganlib/src/lcm_c.c new file mode 100644 index 0000000..ee4a83a --- /dev/null +++ b/Ganlib/src/lcm_c.c @@ -0,0 +1,3952 @@ + +/**********************************/ +/* C API for lcm object support */ +/* author: A. Hebert (30/04/2002) */ +/**********************************/ + +/* + Copyright (C) 2002 Ecole Polytechnique de Montreal + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + */ + +#include <stdlib.h> +#include <string.h> +#include "lcm.h" + +#if !defined(max) +#define min(A,B) ((A) < (B) ? (A) : (B)) +#define max(A,B) ((A) > (B) ? (A) : (B)) +#endif + +static int_32 c__1 = 1; +static int_32 c__2 = 2; +static char AbortString[132]; + +FILE * stdfil_c(char *s) +/* + *----------------------------------------------------------------------- + * + * Return standard file pointers in ANSI C. + * + *----------------------------------------------------------------------- + */ +{ + if (strcmp(s, "stdin") == 0) { + return stdin; + } else if (strcmp(s, "stdout") == 0) { + return stdout; + } else if (strcmp(s, "stderr") == 0) { + return stderr; + } else { + return NULL; + } +} + +void strcut_c(char *s, char *ct, int_32 n) +/* + *----------------------------------------------------------------------- + * + * Copy n characters from string ct to s. Eliminate leading ' ' and '\0' + * characters in s. Terminate s with a '\0'. + * + *----------------------------------------------------------------------- + */ +{ + int i; + for(i=n-1; i>0; i--) { + if(ct[i] != ' ' && ct[i] != '\0') break; + } + strncpy(s, ct, i+1); s[i+1] = '\0'; +} + +void strfil_c(char *s, char *ct, int_32 n) +/* + *----------------------------------------------------------------------- + * + * Copy n characters from string ct to s. Eliminate '\0' characters and + * pack with ' '. Assume that ct is null-terminated. + * + *----------------------------------------------------------------------- + */ +{ + int i; + for(i=0; i<n; i++) s[i] = ' '; + for(i=min(n,(int)strlen(ct))-1; i>0; i--) { + if(ct[i] != ' ' && ct[i] != '\0') break; + } + strncpy(s, ct, i+1); +} + +void refpush(lcm **iplist, int_32 *iplocal) +/* + *----------------------------------------------------------------------- + * + * store a new address in the shared lcm reference database. + * This database is used to keep track of the elementary array pointers + * which are shared between LCM and external objects (implemented in a OO + * language such as C++/Boost, Python or Java). If a pointer is stored + * in this database (using refpush), the free call on this pointer + * is replaced by a refpop call. + * + * input parameters: + * iplist : address of the object. + * iplocal : local reference. + * + *----------------------------------------------------------------------- + */ +{ + dbref* ipkeep = (*iplist)->global; + int_32 n = ipkeep->nad; + int_32 i; + for (i = 0; i < n; ++i) { + if (ipkeep->local[i] == iplocal) return; + } + if (ipkeep->nad + 1 > ipkeep->maxad) { + /* increase the size of the database */ + int_32 **my_local; + ipkeep->maxad += 50; + my_local = (int_32 **) malloc((ipkeep->maxad)*sizeof(*my_local)); + for (i = 0; i < n; ++i) my_local[i]=ipkeep->local[i]; + if (n > 0) free(ipkeep->local); + ipkeep->local=my_local; + } + ++ipkeep->nad; + ipkeep->local[n] = iplocal; + return; +} + +int_32 refpop(lcm **iplist, int_32 *iplocal) +/* + *----------------------------------------------------------------------- + * + * remove one address of the shared lcm reference database. + * + * input parameters: + * iplist : address of the object. + * iplocal : local reference. + * + * output parameter: + * refpop : =0:the reference does exists; =1: does not exists. + * + *----------------------------------------------------------------------- + */ +{ + dbref* ipkeep = (*iplist)->global; + int_32 n = ipkeep->nad; + int_32 i; + if (n == 0) return 1; + for (i = 0; i < n; ++i) { + if (ipkeep->local[i] == iplocal) return 0; + } + return 1; +} + +void lcmkep(db0 *ipkeep, int_32 imode, lcm **iplist) +/* + *----------------------------------------------------------------------- + * + * keep the addresses of the open active directories. + * + * input parameters: + * ipkeep : address of the database handle (always the same). + * imode : =1: add to the database; =2: remove from the database. + * iplist : address of an active directory. + * + * output parameter: + * iplist : last active directory in the database. =0 if the + * database is empty. + * + * database handle structure: + * 0 : number of addresses in the database. + * 1 : maximum slots in the database. + * 2 : address of the database. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmkep"; + int_32 n = ipkeep->nad; + if (imode == 1) { + int_32 i; + lcm **my_parray; + if ((*iplist)->header != 100) { + sprintf(AbortString,"%s: WRONG HEADER(1).",nomsub); + xabort_c(AbortString); + } else if (ipkeep->nad + 1 > ipkeep->maxad) { + ipkeep->maxad += 500; + my_parray = (lcm **) malloc((ipkeep->maxad)*sizeof(*my_parray)); + for (i = 0; i < n; ++i) my_parray[i]=ipkeep->idir[i]; + if (n > 0) free(ipkeep->idir); + ipkeep->idir=my_parray; + } + ++ipkeep->nad; + ipkeep->idir[n] = *iplist; + } else if (imode == 2) { + int_32 i; + for (i = n; i >= 1; --i) { + if (ipkeep->idir[i-1] == *iplist) { + ipkeep->idir[i-1] = NULL; + return; + } + } + sprintf(AbortString,"%s: UNABLE TO FIND AN ADDRESS.",nomsub); + xabort_c(AbortString); + } else { + sprintf(AbortString,"%s: INVALID VALUE OF IMODE.",nomsub); + xabort_c(AbortString); + } + return; +} + +void lcmop_c(lcm **iplist, char *namp, int_32 imp, int_32 medium, int_32 impx) +/* + *----------------------------------------------------------------------- + * + * open an existing or create a new object. + * + * input parameters: + * iplist : address of the existing object if imp=1 or imp=2. + * namp : character name (null terminated) of the object if imp=0. + * imp : =0 to create a new object; =1 to modify an existing object; + * =2 to access an existing object in read-only mode. + * medium : =1 use memory; =2 use an xsm file. + * impx : if impx=0, we suppress printing on lcmop. + * + * output parameters: + * iplist : address of the new object if imp=0. + * namp : character name (null terminated) of the object if imp=1 or imp=2. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmop_c"; + char text12[13]; + blockb *my_blockb; + db0 *my_db0; + dbref *my_dbref; + if (medium == 2) { +/* USE A XSM FILE TO STORE INFORMATION */ + xsmop_c((xsm **)iplist, namp, imp, impx); + return; + } else if (medium != 1) { + sprintf(AbortString,"%s: INVALID MEDIUM (%d).",nomsub,(int)medium); + xabort_c(AbortString); + } else if (imp < 0 || imp > 2) { + sprintf(AbortString,"%s: INVALID ACTION (%d) ON LCM OBJECT '%s'.",nomsub,(int)imp,namp); + xabort_c(AbortString); + } else if (strlen(namp) > 72) { + sprintf(AbortString,"%s: OBJECT NAME '%s' EXCEEDING 72 CHARACTERS.",nomsub,namp); + xabort_c(AbortString); + } + if (imp == 0) { + *iplist = (lcm *) malloc(sizeof(**iplist)); + my_db0 = (db0 *) malloc(sizeof(*my_db0)); + my_dbref = (dbref *) malloc(sizeof(*my_dbref)); + (*iplist)->header = 100; + if (strcmp(namp," ") == 0) { + strcpy((*iplist)->hname,"*TEMPORARY*"); + } else { + strcpy((*iplist)->hname,namp); + } + (*iplist)->listlen = -1; + (*iplist)->inext = NULL; + (*iplist)->father = NULL; + (*iplist)->ifdir = 0; + (*iplist)->imode = 1; + (*iplist)->imax = 0; + (*iplist)->inref = 0; + (*iplist)->icang = my_db0; + (*iplist)->global = my_dbref; + (*iplist)->hash = NULL; + my_db0->nad = 0; + my_db0->maxad = 0; + my_db0->idir = NULL; + my_dbref->nad = 0; + my_dbref->maxad = 0; + my_dbref->local = NULL; + } else if ((*iplist)->header != 100) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' WITH ADDRESS =%ld HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname,(long)(*iplist)); + xabort_c(AbortString); + } else if ((*iplist)->imode != 0) { + if ((*iplist)->father == NULL) { + strcpy(text12,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + my_blockb = my_father->inext; + if (my_blockb == NULL) { + memcpy(text12," ",12); + } else { + strncpy(text12,(char*)my_blockb[(*iplist)->ifdir - 1].jcmt,12); + } + text12[12]='\0'; + } + sprintf(AbortString,"%s: DIRECTORY '%s' IN THE OBJECT '%.45s' WITH ADDRESS =%ld IS ALREADY OPEN.", + nomsub,text12,(*iplist)->hname,(long)(*iplist)); + xabort_c(AbortString); + } else { + int_32 i, n; + db0 *ipkeep; + strcpy(namp,(*iplist)->hname); + (*iplist)->imode = imp; + ipkeep = (*iplist)->icang; + n = ipkeep->nad; + if (n > 0) { + for (i = 0; i < n; ++i) { + if (ipkeep->idir[i] != NULL) (ipkeep->idir[i])->imode = imp; + } + } + } + if (impx > 0 && imp == 0) { + printf("%s: OPEN A NEW OBJECT NAMED '%s' WITH ADDRESS = %ld.\n", + nomsub,(*iplist)->hname,(long)(*iplist)); + } else if (impx > 0 && imp == 1) { + printf("%s: MODIFY AN OBJECT NAMED '%s' WITH ADDRESS = %ld.\n", + nomsub,(*iplist)->hname,(long)(*iplist)); + } else if (impx > 0 && imp == 2) { + printf("%s: OPEN AN OBJECT NAMED '%s' WITH ADDRESS = %ld IN READ-ONLY MODE.\n", + nomsub,(*iplist)->hname,(long)(*iplist)); + } + return; +} + +void lcmppd_c(lcm **iplist, const char *namp, int_32 ilong, int_32 itype, int_32 *iofdum) +/* + *----------------------------------------------------------------------- + * + * add a new pointer entry in the table. + * + * input parameters: + * iplist : address of the object. + * namp : character*12 name of the current block. + * ilong : number of information elements stored in the current block. + * itype : type of information elements stored in the current block. + * iofdum : pointer of the first information element. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmppd_c"; + int_32 i, j, ipos, iref, *jofdum; + int inamt[3]; + blockb *ipnode, *jpnode; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iofdum == NULL) { + sprintf(AbortString,"%s: THE MALLOC POINTER OF NODE '%s' IS NOT SET IN THE OBJECT '%.60s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } else if (ilong <= 0) { + sprintf(AbortString,"%s: INVALID LENGTH (%d) FOR NODE '%s' IN THE OBJECT '%.60s'.", + nomsub,(int)ilong,namp,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsmppd_c((xsm **)iplist,namp,ilong,itype,iofdum); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->imode == 2) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS OPEN IN READ-ONLY MODE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + /* SCAN THE NODAL TABLE AND INCLUDE THE NEW ENTRY. */ + ipnode = (*iplist)->inext; + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + if (ipnode == NULL) goto L10; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + iref = i + 1; + /* REMOVE THE OLD NODE. */ + jofdum = ipnode[i].jdata; + if (jofdum != iofdum) { + if(refpop(iplist,jofdum)) free(jofdum); /* rlsara_c(jofdum); */ + } + goto L20; + } + } + } + } +L10: + iref = (*iplist)->inref + 1; + if (iref > (*iplist)->imax) { + /* INCREASE THE SIZE OF THE NODE TABLE. */ + jpnode = (blockb *) malloc(((*iplist)->imax + maxext) * sizeof(*jpnode)); + (*iplist)->inext = jpnode; + if (ipnode != NULL) { + for (i = 0; i < (*iplist)->imax; ++i) { + jpnode[i].jdata = ipnode[i].jdata; + jpnode[i].jjlon = ipnode[i].jjlon; + jpnode[i].jjtyp = ipnode[i].jjtyp; + for (j = 0; j < 4; ++j) jpnode[i].jidat[j] = ipnode[i].jidat[j]; + for (j = 0; j < 3; ++j) jpnode[i].jcmt[j] = ipnode[i].jcmt[j]; + } + free(ipnode); + } else { + (*iplist)->hash = (int_32 *) malloc(lhash*sizeof(int_32)); + for (i = 0; i < lhash; ++i) (*iplist)->hash[i] = 0; + } + (*iplist)->imax += maxext; + ipnode = jpnode; + } + (*iplist)->hash[ipos] = max(iref, (*iplist)->hash[ipos]); + (*iplist)->inref = iref; + for (j = 0; j < 3; ++j) ipnode[iref-1].jcmt[j] = inamt[j]; + + /* STORE THE INFORMATION RELATIVE TO THE NEW INFORMATION ELEMENT. */ +L20: + (ipnode[iref-1]).jdata = iofdum; + (ipnode[iref-1]).jjlon = ilong; + (ipnode[iref-1]).jjtyp = itype; + + /* STORE THE FIRST AND LAST ELEMENTS FOR VALIDATION PURPOSE. */ + if (itype == 1 || itype == 2 || itype == 3 || itype == 5) { + (ipnode[iref-1]).jidat[0] = iofdum[0]; + (ipnode[iref-1]).jidat[1] = iofdum[ilong-1]; + } else if (itype == 4 || itype == 6) { + (ipnode[iref-1]).jjlon = 2*ilong; + (ipnode[iref-1]).jidat[0] = iofdum[0]; + (ipnode[iref-1]).jidat[1] = iofdum[1]; + (ipnode[iref-1]).jidat[2] = iofdum[2*ilong-2]; + (ipnode[iref-1]).jidat[3] = iofdum[2*ilong-1]; + } + return; +} + +void lcmlen_c(lcm **iplist, const char *namp, int_32 *ilong, int_32 *itylcm) +/* + *----------------------------------------------------------------------- + * + * return the length and type of a table entry. + * + * input parameters: + * iplist : address of the object. + * namp : character*12 name of the current block. + * + * output parameters: + * ilong : number of information elements pointed by the lcm entry. + * ilong=0 is returned if the entry does not exists. + * ilong=-1 is returned for an associative table. + * itylcm : type of information elements pointed by the lcm entry. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex 99: empty node + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmlen_c"; + blockb *ipnode; + int_32 i, ipos; + int inamt[3]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsmlen_c((xsm **)iplist,namp,ilong,itylcm); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + ipnode = (*iplist)->inext; + if (ipnode == NULL) goto L10; + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + *ilong = ipnode[i].jjlon; + *itylcm = ipnode[i].jjtyp; + if (*itylcm == 4 || *itylcm == 6) *ilong=*ilong/2; + return; + } + } + } + } +L10: + *ilong = 0; + *itylcm = 99; + return; +} + +void lcminf_c(lcm **iplist, char *namlcm, char *nammy, int_32 *empty, int_32 *ilong, int_32 *lcml, + int_32 *access) +/* + *----------------------------------------------------------------------- + * + * find general information about an associative table or list. + * + * input parameters: + * iplist : address of the object. + * + * output parameter: + * namlcm : character name (null terminated) of the object. + * nammy : character name (null terminated) of the active directory. + * empty : =.true. if the active directory is empty. + * ilong : =-1: for a table; >0: number of list items. + * lcml : =.true.: memory used; =.false.: xsm file used. + * access : type of access. =0: object closed (lcm only); =1: object + * open for modification; =2: object in read-only mode. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcminf_c"; + blockb *my_blockb; + if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + *lcml = 0; + xsminf_c((xsm **)iplist,namlcm,nammy,empty,ilong,access); + return; + } else if ((*iplist)->header != 100) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + *lcml = 1; + *access = (*iplist)->imode; + if ((*iplist)->father == NULL) { + strcpy(nammy,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + my_blockb = my_father->inext; + if (my_blockb == NULL) { + memcpy(nammy," ",12); + } else { + strncpy(nammy,(char*)my_blockb[(*iplist)->ifdir - 1].jcmt,12); + } + nammy[12]='\0'; + } + strcpy(namlcm,(*iplist)->hname); + *ilong = (*iplist)->listlen; + my_blockb = (*iplist)->inext; + *empty = (my_blockb == NULL); + if ((!*empty) && (*ilong == -1)) { + char namp[13]; + int_32 iref, i; + iref = 0; +L10: + ++iref; + if (iref > (*iplist)->inref) { + *empty = 1; + return; + } + strncpy(namp,(char*)my_blockb[iref-1].jcmt,12); + namp[12]=' '; + for(i=12; i>0; i--) { + if (namp[i] != ' ') break; + namp[i]='\0'; + } + if (strcmp(namp," ") == 0) goto L10; + } + return; +} + +void lcmnxt_c(lcm **iplist,char *namp) +/* + *----------------------------------------------------------------------- + * + * input parameters: + * iplist : address of the object. + * namp : character*12 name of a block. if namp=' ' at input, find + * any name for any block stored in this directory. + * + * output parameter: + * namp : character*12 name of the next block. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmnxt_c"; + char nammy[13]; + blockb *ipnode; + int_32 i, ipos, iref, lcheck; + int inamt[3]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsmnxt_c((xsm **)iplist,namp); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + ipnode = (*iplist)->inext; + if (ipnode == NULL) { + if ((*iplist)->father == NULL) { + strcpy(nammy,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode == NULL) { + memcpy(nammy," ",12); + } else { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + } + nammy[12]='\0'; + } + sprintf(AbortString,"%s: EMPTY DIRECTORY '%s' IN THE OBJECT '%.60s' (1).", + nomsub,nammy,(*iplist)->hname); + xabort_c(AbortString); + } else if (strcmp(namp," ") == 0) { + iref = 0; +L10: + ++iref; + if (iref > (*iplist)->inref) { + if ((*iplist)->father == NULL) { + strcpy(nammy,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode == NULL) { + memcpy(nammy," ",12); + } else { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + } + nammy[12]='\0'; + } + sprintf(AbortString,"%s: EMPTY DIRECTORY '%s' IN THE OBJECT '%.60s' (2).", + nomsub,nammy,(*iplist)->hname); + xabort_c(AbortString); + } + strncpy(namp,(char*)ipnode[iref-1].jcmt,12); + namp[12]=' '; + for(i=12; i>0; i--) { + if (namp[i] != ' ') break; + namp[i]='\0'; + } + if (strcmp(namp," ") == 0) goto L10; + return; + } + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + iref = i+1; + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + lcheck = 0; +L20: + if (iref < (*iplist)->inref) { + ++iref; + } else { + if (lcheck == 1) { + sprintf(AbortString,"%s: INFINITE LOOPING.",nomsub); + xabort_c(AbortString); + } + iref = 1; + lcheck = 1; + } + strncpy(namp,(char*)ipnode[iref-1].jcmt,12); + namp[12]=' '; + for(i=12; i>0; i--) { + if (namp[i] != ' ') break; + namp[i]='\0'; + } + if (strcmp(namp," ") == 0) goto L20; + return; + } + } + } + } + if ((*iplist)->father == NULL) { + strcpy(nammy,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode == NULL) { + memcpy(nammy," ",12); + } else { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + } + nammy[12]='\0'; + } + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE OBJECT '%.50s'.", + nomsub,namp,nammy,(*iplist)->hname); + xabort_c(AbortString); +} + +void lcmgpd_c(lcm **iplist, const char *namp, int_32 **iofdum) +/* + *----------------------------------------------------------------------- + * + * get a malloc pointer for an entry in the table. + * + * input parameters: + * iplist : address of the object. + * namp : character*12 name of the current block. + * + * output parameter: + * iofdum : malloc pointer to the lcm entry named namp. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmgpd_c"; + char nammy[13]; + blockb *ipnode; + int_32 i, ipos; + int inamt[3]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsmgpd_c((xsm **)iplist,namp,iofdum); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + ipnode = (*iplist)->inext; + if (ipnode == NULL) goto L10; + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + *iofdum = ipnode[i].jdata; + return; + } + } + } + } +L10: + if ((*iplist)->father == NULL) { + strcpy(nammy,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode == NULL) { + memcpy(nammy," ",12); + } else { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + } + nammy[12]='\0'; + } + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE OBJECT '%.50s'.", + nomsub,namp,nammy,(*iplist)->hname); + xabort_c(AbortString); +} + +void lcmget_c(lcm **iplist, const char *namp, int_32 *idata) +/* + *----------------------------------------------------------------------- + * + * copy a block of data from a table into memory. + * + * input parameters: + * iplist : address of the object. + * namp : character*12 name of the current block. + * + * output parameter: + * idata : information elements. dimension idata1(ilong) where ilong + * is the number of information elements. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmget_c"; + char nammy[13]; + blockb *ipnode; + int_32 i, j, ipos; + int inamt[3]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsmget_c((xsm **)iplist,namp,idata); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + ipnode = (*iplist)->inext; + if (ipnode == NULL) goto L10; + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + for (j = 0; j < ipnode[i].jjlon; ++j) idata[j] = ipnode[i].jdata[j]; + return; + } + } + } + } +L10: + if ((*iplist)->father == NULL) { + strcpy(nammy,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode == NULL) { + memcpy(nammy," ",12); + } else { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + } + nammy[12]='\0'; + } + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE OBJECT '%.50s'.", + nomsub,namp,nammy,(*iplist)->hname); + xabort_c(AbortString); +} + +void lcmval_part2(int_32 ilong,lcm *iplist); + +void lcmval_part1(lcm *iplist,const char *namp) +/* ASSOCIATIVE TABLE VALIDATION. */ +{ + char *nomsub="lcmval_part1"; + char namt[13]; + int_32 iref, ilong, itylcm, lerr1, lerr2; + blockb *inode; + inode = iplist->inext; + for (iref = 0; iref < iplist->inref; ++iref) { + strncpy(namt,(char*)inode[iref].jcmt,12); + namt[12]='\0'; + if ( ((strcmp(namp," ") == 0 || strcmp(namp,namt) == 0)) && + (strcmp(namt," ") != 0) ) { + ilong = inode[iref].jjlon; + itylcm = inode[iref].jjtyp; + lerr1 = 0; + lerr2 = 0; + if (itylcm == 0 && ilong == -1) { + /* ASSOCIATIVE TABLE. */ + lcmval_part1((lcm *)inode[iref].jdata," "); + } else if (itylcm == 10) { + /* LIST. */ + lcmval_part2(ilong,(lcm *)inode[iref].jdata); + } else if (itylcm == 1 || itylcm == 2 || itylcm == 3 || itylcm == 5) { + lerr1 = inode[iref].jidat[0] != inode[iref].jdata[0]; + lerr2 = inode[iref].jidat[1] != inode[iref].jdata[ilong - 1]; + } else if (itylcm == 4 || itylcm == 6) { + lerr1 = (inode[iref].jidat[0] != inode[iref].jdata[0]) || + (inode[iref].jidat[1] != inode[iref].jdata[1]); + lerr2 = (inode[iref].jidat[2] != inode[iref].jdata[ilong - 2]) || + (inode[iref].jidat[3] != inode[iref].jdata[ilong - 1]); + } + if (lerr1) { + sprintf(AbortString,"%s: BLOCK '%s' OF THE OBJECT '%.50s' HAS BEEN OVERWRITTEN (1).", + nomsub,namt,iplist->hname); + xabort_c(AbortString); + } else if (lerr2) { + sprintf(AbortString,"%s: BLOCK '%s' OF THE OBJECT '%.50s' HAS BEEN OVERWRITTEN (2).", + nomsub,namt,iplist->hname); + xabort_c(AbortString); + } + } + } + return; +} + +void lcmval_part2(int_32 kjlon,lcm *iplist) +/* LIST VALIDATION. */ +{ + char *nomsub="lcmval_part2"; + int_32 ilong, itylcm, lerr1, lerr2, ivec; + blockb *knode; + for (ivec = 0; ivec < kjlon; ++ivec) { + knode = iplist[ivec].inext; + if (knode) { + ilong = knode[0].jjlon; + itylcm = knode[0].jjtyp; + lerr1 = 0; + lerr2 = 0; + if (itylcm == 0 && ilong == -1) { + /* ASSOCIATIVE TABLE. */ + lcmval_part1((lcm *)knode[0].jdata," "); + } else if (itylcm == 10) { + /* LIST. */ + lcmval_part2(ilong,(lcm *)knode[0].jdata); + } else if (itylcm == 1 || itylcm == 2 || itylcm == 3 || itylcm == 5) { + lerr1 = knode[0].jidat[0] != knode[0].jdata[0]; + lerr2 = knode[0].jidat[1] != knode[0].jdata[ilong - 1]; + } else if (itylcm == 4 || itylcm == 6) { + lerr1 = (knode[0].jidat[0] != knode[0].jdata[0]) || + (knode[0].jidat[1] != knode[0].jdata[1]); + lerr2 = (knode[0].jidat[2] != knode[0].jdata[ilong - 2]) || + (knode[0].jidat[3] != knode[0].jdata[ilong - 1]); + } + if (lerr1) { + sprintf(AbortString,"%s: LIST ELEMENT %d OF THE OBJECT '%.50s' HAS BEEN OVERWRITTEN (1).", + nomsub,(int)ivec,iplist->hname); + xabort_c(AbortString); + } else if (lerr2) { + sprintf(AbortString,"%s: LIST ELEMENT %d OF THE OBJECT '%.50s' HAS BEEN OVERWRITTEN (2).", + nomsub,(int)ivec,iplist->hname); + xabort_c(AbortString); + } + } + } + return; +} + +void lcmval_c(lcm **iplist,const char *namp) +{ + char *nomsub="lcmval_c"; + if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + return; + } else if ((*iplist)->header != 100) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + if ((*iplist)->listlen == -1) { + lcmval_part1(*iplist,namp); + } else { + lcmval_part2((*iplist)->listlen,*iplist); + } + return; +} + +void lcmcl_part2(int_32 kjlon, lcm *iplist); + +void lcmcl_part1(lcm *iplist) +/* ASSOCIATIVE TABLE DESTRUCTION. */ +{ + int_32 iref, ilong, itylcm; + blockb *inode; + lcm *kplist; + inode = iplist->inext; + for (iref = 0; iref < iplist->inref; ++iref) { + ilong = inode[iref].jjlon; + itylcm = inode[iref].jjtyp; + if (itylcm == 0 && ilong == -1) { + /* ASSOCIATIVE TABLE. */ + kplist = (lcm *)inode[iref].jdata; + lcmcl_part1(kplist); + lcmkep(iplist->icang,c__2,&kplist); + free(inode[iref].jdata); + } else if (itylcm == 10) { + /* LIST. */ + kplist = (lcm *)inode[iref].jdata; + lcmcl_part2(ilong, kplist); + lcmkep(iplist->icang,c__2,&kplist); + free(inode[iref].jdata); + } else if (itylcm != 99) { + if(refpop(&iplist,inode[iref].jdata)) free(inode[iref].jdata); /* rlsara_c() */ + } + } + if (inode != NULL) free(inode); + if (iplist->hash != NULL) free(iplist->hash); + return; +} + +void lcmcl_part2(int_32 kjlon, lcm *iplist) +/* LIST DESTRUCTION. */ +{ + int_32 ilong, itylcm, ivec; + lcm *kplist; + blockb *knode; + for (ivec = 0; ivec < kjlon; ++ivec) { + knode = iplist[ivec].inext; + if (knode) { + ilong = knode[0].jjlon; + itylcm = knode[0].jjtyp; + if (itylcm == 0 && ilong == -1) { + /* ASSOCIATIVE TABLE. */ + kplist = (lcm *)knode[0].jdata; + lcmcl_part1(kplist); + lcmkep(iplist[ivec].icang,c__2,&kplist); + free(knode[0].jdata); + } else if (itylcm == 10) { + /* LIST. */ + kplist = (lcm *)knode[0].jdata; + lcmcl_part2(ilong,kplist); + lcmkep(iplist[ivec].icang,c__2,&kplist); + free(knode[0].jdata); + } else if (itylcm != 99) { + if(refpop(&iplist,knode[0].jdata)) free(knode[0].jdata); /* rlsara_c() */ + } + free(knode); + } + } + return; +} + +void lcmcl_c(lcm **iplist,int_32 iact) +/* + *----------------------------------------------------------------------- + * + * close, destroy or erase an object with validation. + * + * input parameters: + * iplist : address of the existing object. + * iact : =1 to close; =2 to destroy; =3 to erase and close. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmcl_c"; + db0 *ipkeep; + dbref *ipkref; + if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + if (iact == 3) { + sprintf(AbortString,"%s: THE XSM FILE '%s' CANNOT BE ERASED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + xsmcl_c((xsm **)iplist, iact); + return; + } else if ((*iplist)->header != 100) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iact != 1 && iact != 2 && iact != 3) { + sprintf(AbortString,"%s: INVALID ACTION (%d) ON THE OBJECT '%.60s'.", + nomsub,(int)iact,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS ALREADY CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->father != NULL) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS NOT ROOT.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + lcmval_c(iplist, " "); + if (iact == 2 || iact == 3) { + /* DESTROY OR ERASE THE OBJECT. */ + if ((*iplist)->imode == 2) { + sprintf(AbortString,"%s: CANNOT DESTROY OR ERASE THE OBJECT '%.60s' OPEN IN READ-ONLY MODE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + /* RECURSIVE DESTRUCTION OF THE OBJECT CONTENT WITH ADDRESS IPLIST. */ + if ((*iplist)->listlen == -1) { + lcmcl_part1(*iplist); + } else { + lcmcl_part2((*iplist)->listlen,*iplist); + } + } else { + int_32 i, n; + ipkeep = (*iplist)->icang; + n = ipkeep->nad; + if (n > 0) { + for (i = 0; i < n; ++i) { + if (ipkeep->idir[i] != NULL) (ipkeep->idir[i])->imode = 0; + } + } + } + if ((*iplist)->father == NULL && iact >= 2) { + /* DESTROY THE TABLE. */ + int_32 i, n; + ipkeep = (*iplist)->icang; + n = ipkeep->nad; + if (n > 0) { + for (i = 0; i < n; ++i) { + if (ipkeep->idir[i] != NULL) free(ipkeep->idir[i]); + } + free(ipkeep->idir); + } + free(ipkeep); + ipkref = (*iplist)->global; + n = ipkref->nad; + if (n > 0) free(ipkref->local); + free(ipkref); + if (iact == 2) { + free(*iplist); + *iplist = NULL; + } else if (iact == 3) { + /* ERASE THE TABLE. */ + db0 *my_db0; + dbref *my_dbref; + my_db0 = (db0 *) malloc(sizeof(*my_db0)); + my_dbref = (dbref *) malloc(sizeof(*my_dbref)); + (*iplist)->inext = NULL; + (*iplist)->imode = 0; + (*iplist)->imax = 0; + (*iplist)->inref = 0; + (*iplist)->icang = my_db0; + (*iplist)->global = my_dbref; + (*iplist)->hash = NULL; + my_db0->nad = 0; + my_db0->maxad=0; + my_db0->idir=NULL; + my_dbref->nad = 0; + my_dbref->maxad=0; + my_dbref->local=NULL; + } + } else { + (*iplist)->imode = 0; + } + return; +} + +void lcmsix_c(lcm **iplist,const char *namp,int_32 iact) +/* + *----------------------------------------------------------------------- + * + * move in the hierarchical structure of a node table. + * + * input parameters: + * iplist : address of the table. + * namp : character*12 name of the directory if iact=1. not used if + * iact.ne.1. + * iact : type of movement in the hierarchical structure. + * 0: return to the root directory; + * 1: move to a son directory; + * 2: move back to the parent directory. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmsix_c"; + blockb *ipnode, *jpnode; + int_32 i, j, ipos, mode, iref; + int inamt[3]; + lcm *jplist; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iact < 0 || iact > 2) { + sprintf(AbortString,"%s: INVALID ACTION (%d) ON THE OBJECT '%.60s'.", + nomsub,(int)iact,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsmsix_c((xsm **)iplist,namp,iact); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + if (iact == 0 && (*iplist)->father == NULL) return; + ipnode = (*iplist)->inext; + mode = (*iplist)->imode; + if (iact == 1) { + /* MOVE TO A SON DIRECTORY. */ + /* CHECK IF THE DIRECTORY EXISTS IN THE NODE TABLE. */ + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + if (ipnode == NULL) goto L10; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + iref = i+1; + goto L20; + } + } + } + } + /* THE DIRECTORY DOES NOT EXISTS IN THE NODE TABLE. */ +L10: + if ((*iplist)->imode == 2) { + char nammy[13]; + if ((*iplist)->father == NULL) { + strcpy(nammy,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode == NULL) { + memcpy(nammy," ",12); + } else { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + } + nammy[12]='\0'; + } + sprintf(AbortString,"%s: UNABLE TO CREATE DIRECTORY '%s' FROM DIRECTORY '%s' IN READ-ONLY OBJECT '%.35s'.", + nomsub,namp,nammy,(*iplist)->hname); + xabort_c(AbortString); + } + /* CREATE A NEW NODE TABLE. */ + iref = (*iplist)->inref + 1; + if (iref > (*iplist)->imax) { + /* INCREASE THE SIZE OF THE NODE TABLE. */ + jpnode = (blockb *) malloc(((*iplist)->imax + maxext) * sizeof(*jpnode)); + (*iplist)->inext = jpnode; + if (ipnode != NULL) { + for (i = 0; i < (*iplist)->imax; ++i) { + jpnode[i].jdata = ipnode[i].jdata; + jpnode[i].jjlon = ipnode[i].jjlon; + jpnode[i].jjtyp = ipnode[i].jjtyp; + for (j = 0; j < 4; ++j) jpnode[i].jidat[j] = ipnode[i].jidat[j]; + for (j = 0; j < 3; ++j) jpnode[i].jcmt[j] = ipnode[i].jcmt[j]; + } + free(ipnode); + } else { + (*iplist)->hash = (int_32 *) malloc(lhash*sizeof(int_32)); + for (i = 0; i < lhash; ++i) (*iplist)->hash[i] = 0; + } + (*iplist)->imax += maxext; + ipnode = jpnode; + } + (*iplist)->hash[ipos] = max(iref, (*iplist)->hash[ipos]); + (*iplist)->inref = iref; + for (j = 0; j < 3; ++j) ipnode[iref-1].jcmt[j]=inamt[j]; + (ipnode[iref-1]).jjlon = -1; + (ipnode[iref-1]).jjtyp = 0; + + jplist = (lcm *) malloc(sizeof(*jplist)); + jplist->header = (*iplist)->header; + strcpy(jplist->hname, (*iplist)->hname); + jplist->listlen = -1; + jplist->inext = NULL; + jplist->father = *iplist; + jplist->ifdir = iref; + jplist->imode = 0; + jplist->imax = 0; + jplist->inref = 0; + jplist->icang = (*iplist)->icang; + jplist->global = (*iplist)->global; + jplist->hash = NULL; + lcmkep(jplist->icang, c__1, &jplist); + (ipnode[iref-1]).jdata = (int_32 *)jplist; + + /* SWITCH TO THE SON DIRECTORY. */ +L20: + if ((ipnode[iref-1]).jjlon != -1 || (ipnode[iref-1]).jjtyp != 0) { + sprintf(AbortString,"%s: '%s' IS AN INVALID DIRECTORY TYPE. OBJECT='%s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + *iplist = (lcm *)(ipnode[iref-1]).jdata; + (*iplist)->imode = mode; + } else if (iact == 0 || iact == 2) { + /* MOVE BACK TO THE ROOT OR PARENT DIRECTORY. */ + if ((*iplist)->father == NULL) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS ON ROOT DIRECTORY.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } +L30: + jplist = *iplist; + *iplist = jplist->father; + if (iact == 0 && (*iplist)->father != NULL) goto L30; + } + return; +} + +lcm * lcmdid_c(lcm **iplist,const char *namp) +/* + *----------------------------------------------------------------------- + * + * create/access a son table in a father table. + * + * input parameters: + * iplist : address of the father table. + * namp : character*12 name of the son table. + * + * output parameter: + * lcmdid_c : address of the son table. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmdid_c"; + blockb *ipnode, *jpnode; + int_32 i, j, ipos, mode, iref; + int inamt[3]; + lcm *jplist; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *kplist; + xsmdid_c((xsm **)iplist,namp,&kplist); + return (lcm*)kplist; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->imode == 2) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS OPEN IN READ-ONLY MODE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + ipnode = (*iplist)->inext; + mode = (*iplist)->imode; + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + if (ipnode == NULL) goto L10; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + iref = i+1; + goto L20; + } + } + } + } + /* THE DIRECTORY DOES NOT EXISTS IN THE NODE TABLE. */ +L10: + /* CREATE A NEW NODE TABLE. */ + iref = (*iplist)->inref + 1; + if (iref > (*iplist)->imax) { + /* INCREASE THE SIZE OF THE NODE TABLE. */ + jpnode = (blockb *) malloc(((*iplist)->imax + maxext) * sizeof(*jpnode)); + (*iplist)->inext = jpnode; + if (ipnode != NULL) { + for (i = 0; i < (*iplist)->imax; ++i) { + jpnode[i].jdata = ipnode[i].jdata; + jpnode[i].jjlon = ipnode[i].jjlon; + jpnode[i].jjtyp = ipnode[i].jjtyp; + for (j = 0; j < 4; ++j) jpnode[i].jidat[j] = ipnode[i].jidat[j]; + for (j = 0; j < 3; ++j) jpnode[i].jcmt[j] = ipnode[i].jcmt[j]; + } + free(ipnode); + } else { + (*iplist)->hash = (int_32 *) malloc(lhash*sizeof(int_32)); + for (i = 0; i < lhash; ++i) (*iplist)->hash[i] = 0; + } + (*iplist)->imax += maxext; + ipnode = jpnode; + } + (*iplist)->hash[ipos] = max(iref, (*iplist)->hash[ipos]); + (*iplist)->inref = iref; + for (j = 0; j < 3; ++j) ipnode[iref-1].jcmt[j]=inamt[j]; + (ipnode[iref-1]).jjlon = -1; + (ipnode[iref-1]).jjtyp = 0; + + jplist = (lcm *) malloc(sizeof(*jplist)); + jplist->header = (*iplist)->header; + strcpy(jplist->hname, (*iplist)->hname); + jplist->listlen = -1; + jplist->inext = NULL; + jplist->father = *iplist; + jplist->ifdir = iref; + jplist->imode = 0; + jplist->imax = 0; + jplist->inref = 0; + jplist->icang = (*iplist)->icang; + jplist->global = (*iplist)->global; + jplist->hash = NULL; + lcmkep(jplist->icang, c__1, &jplist); + (ipnode[iref-1]).jdata = (int_32 *)jplist; + + /* SWITCH TO THE SON DIRECTORY. */ +L20: + if ((ipnode[iref-1]).jjlon != -1 || (ipnode[iref-1]).jjtyp != 0) { + sprintf(AbortString,"%s: '%s' IS AN INVALID DIRECTORY TYPE. OBJECT='%s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + jplist = (lcm *)(ipnode[iref-1]).jdata; + jplist->imode = mode; + return jplist; +} + +lcm * lcmlid_c(lcm **iplist,const char *namp,int_32 ilong) +/* + *----------------------------------------------------------------------- + * + * create/access the hierarchical structure of a list in a father table. + * + * input parameters: + * iplist : address of the father table. + * namp : character*12 name of the list. + * ilong : dimension of the list. + * + * output parameter: + * lcmlid_c : address of the list. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmlid_c"; + blockb *ipnode, *jpnode; + int_32 i, j, ipos, lenold, ityold, mode, iref=0; + int inamt[3]; + lcm *jplist; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsmlid_c((xsm **)iplist,namp,ilong,(xsm **)(&jplist)); + return jplist; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->imode == 2) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS OPEN IN READ-ONLY MODE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (ilong <= 0) { + sprintf(AbortString,"%s: INVALID LENGTH (%d) FOR NODE '%s' IN THE OBJECT '%.60s'.", + nomsub,(int)ilong,namp,(*iplist)->hname); + xabort_c(AbortString); + } + ipnode = (*iplist)->inext; + mode = (*iplist)->imode; + lenold = 0; + ityold = 10; + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + if (ipnode == NULL) goto L10; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + iref = i+1; + lenold = (ipnode[i]).jjlon; + ityold = (ipnode[i]).jjtyp; + goto L10; + } + } + } + } +L10: + if (ityold != 10) { + sprintf(AbortString,"%s: '%s' IS AN INVALID LIST TYPE. OBJECT='%s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } else if (lenold != 0 && lenold > ilong) { + ilong = lenold; + } + if (lenold == 0) { + /* CREATE A NEW NODE TABLE. */ + iref = (*iplist)->inref + 1; + if (iref > (*iplist)->imax) { + /* INCREASE THE SIZE OF THE NODE TABLE. */ + jpnode = (blockb *) malloc(((*iplist)->imax + maxext) * sizeof(*jpnode)); + (*iplist)->inext = jpnode; + if (ipnode != NULL) { + for (i = 0; i < (*iplist)->imax; ++i) { + jpnode[i].jdata = ipnode[i].jdata; + jpnode[i].jjlon = ipnode[i].jjlon; + jpnode[i].jjtyp = ipnode[i].jjtyp; + for (j = 0; j < 4; ++j) jpnode[i].jidat[j] = ipnode[i].jidat[j]; + for (j = 0; j < 3; ++j) jpnode[i].jcmt[j] = ipnode[i].jcmt[j]; + } + free(ipnode); + } else { + (*iplist)->hash = (int_32 *) malloc(lhash*sizeof(int_32)); + for (i = 0; i < lhash; ++i) (*iplist)->hash[i] = 0; + } + (*iplist)->imax += maxext; + ipnode = jpnode; + } + (*iplist)->hash[ipos] = max(iref, (*iplist)->hash[ipos]); + (*iplist)->inref = iref; + for (j = 0; j < 3; ++j) ipnode[iref-1].jcmt[j] = inamt[j]; + (ipnode[iref-1]).jjtyp = 10; + } + if (ilong != lenold) { + lcm *iofset, *iofold; + (ipnode[iref-1]).jjlon = ilong; + iofset = (lcm *) malloc(ilong*sizeof(*iofset)); + for (i = 0; i < ilong; ++i) { + if (i < lenold) { + iofold = (lcm *)(ipnode[iref-1]).jdata; + iofset[i].header = iofold[i].header; + strcpy(iofset[i].hname, iofold[i].hname); + iofset[i].listlen = 0; + iofset[i].inext = iofold[i].inext; + iofset[i].father = iofold[i].father; + iofset[i].ifdir = iofold[i].ifdir; + iofset[i].imode = iofold[i].imode; + iofset[i].imax = iofold[i].imax; + iofset[i].inref = iofold[i].inref; + iofset[i].icang = iofold[i].icang; + iofset[i].global = iofold[i].global; + iofset[i].hash = iofold[i].hash; + /* PUT THE OLD OBJECT IN READ-ONLY MODE */ + iofold[i].imode = 2; + } else { + iofset[i].header = (*iplist)->header; + strcpy(iofset[i].hname, (*iplist)->hname); + iofset[i].listlen = 0; + iofset[i].inext = NULL; + iofset[i].father = *iplist; + iofset[i].ifdir = iref; + iofset[i].imode = 0; + iofset[i].imax = 0; + iofset[i].inref = 0; + iofset[i].icang = (*iplist)->icang; + iofset[i].global = (*iplist)->global; + iofset[i].hash = NULL; + } + } + iofset[0].listlen = ilong; + lcmkep(iofset->icang, c__1, &iofset); + (ipnode[iref-1]).jdata = (int_32 *)iofset; + } + /* SWITCH TO THE SON LIST. */ + jplist = (lcm *)(ipnode[iref-1]).jdata; + for (i = 0; i < ilong; ++i) jplist[i].imode = mode; + return jplist; +} + +lcm * lcmgid_c(lcm **iplist, const char *namp) +/* + *----------------------------------------------------------------------- + * + * get the address of a table or of a list located in a father table. + * + * input parameters: + * iplist : address of the father table. + * namp : character*12 name of the son table or list. + * + * output parameter: + * lcmgid_c : address of the table or of the list named namp. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmgid_c"; + char nammy[13]; + blockb *ipnode; + int_32 i, ipos; + lcm *jplist; + int inamt[3]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *jplist; + int_32 ilong, itylcm; + xsmlen_c((xsm**)iplist, namp, &ilong, &itylcm); + if (ilong == -1) { + xsmdid_c((xsm **)iplist,namp,&jplist); + } else { + xsmlid_c((xsm **)iplist,namp,ilong,&jplist); + } + return (lcm*)jplist; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + ipnode = (*iplist)->inext; + if (ipnode == NULL) goto L10; + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + if ((ipnode[i].jjtyp != 0) && (ipnode[i].jjtyp != 10)) { + sprintf(AbortString,"%s: BLOCK '%s' IN OBJECT '%s' IS NOT A TABLE/LIST.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + jplist = (lcm *)(ipnode[i]).jdata; + return jplist; + } + } + } + } +L10: + if ((*iplist)->father == NULL) { + strcpy(nammy,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode == NULL) { + memcpy(nammy," ",12); + } else { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + } + nammy[12]='\0'; + } + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE OBJECT '%.50s'.", + nomsub,namp,nammy,(*iplist)->hname); + xabort_c(AbortString); + return NULL; +} + +void lcmdel_c(lcm **iplist,const char *namp) +/* + *----------------------------------------------------------------------- + * + * delete an entry in the table. + * + * input parameters: + * iplist : address of the table. + * namp : character*12 name of the block to delete. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmdel_c"; + char nammy[13]; + blockb *ipnode; + int_32 i, ipos; + int inamt[3]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->listlen >= 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS A LIST.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + sprintf(AbortString,"%s: UNABLE TO DELETE RECORD '%s' FROM AN XSM FILE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + ipnode = (*iplist)->inext; + if (ipnode == NULL) goto L10; + strncpy((char*)inamt,namp,12); + ipos = abs(inamt[0] + inamt[1] * 3 + inamt[2] * 5) % lhash; + for (i = (*iplist)->hash[ipos] - 1; i >= 0; --i) { + if (ipnode[i].jcmt[0] == inamt[0]) { + if (ipnode[i].jcmt[1] == inamt[1]) { + if (ipnode[i].jcmt[2] == inamt[2]) { + if (ipnode[i].jjtyp == 0) { + /* DELETE AN ASSOCIATIVE TABLE. */ + lcm *kplist; + kplist = (lcm *)ipnode[i].jdata; + lcmcl_part1(kplist); + lcmkep((*iplist)->icang,c__2,&kplist); + free(ipnode[i].jdata); + } else if (ipnode[i].jjtyp == 10) { + /* DELETE A LIST. */ + lcm *kplist; + kplist = (lcm *)ipnode[i].jdata; + lcmcl_part2(kplist->listlen,kplist); + lcmkep((*iplist)->icang,c__2,&kplist); + free(ipnode[i].jdata); + } else if (ipnode[i].jjtyp == 99) { + sprintf(AbortString,"%s: BLOCK '%s' IN THE OBJECT '%.60s' IS ARLEADY DELETED.", + nomsub,nammy,(*iplist)->hname); + xabort_c(AbortString); + } else { + /* DELETE A NODE. */ + if(refpop(iplist,ipnode[i].jdata)) free(ipnode[i].jdata); /* rlsara_c */ + } + ipnode[i].jdata = NULL; + ipnode[i].jjlon = 0; + ipnode[i].jjtyp = 99; + memcpy((char*)ipnode[i].jcmt," ",12); + if (i+1 == (*iplist)->inref) --(*iplist)->inref; + return; + } + } + } + } +L10: + if ((*iplist)->father == NULL) { + strcpy(nammy,"/"); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode == NULL) { + memcpy(nammy," ",12); + } else { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + } + nammy[12]='\0'; + } + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE OBJECT '%.50s'.", + nomsub,namp,nammy,(*iplist)->hname); + xabort_c(AbortString); +} + +lcm * lcmdil_c(lcm **iplist,int_32 iset) +/* + *----------------------------------------------------------------------- + * + * create/access the hierarchical structure of a node table located in + * a list. + * + * input parameters: + * iplist : address of the list. + * iset : position in the father list of the son table. + * + * output parameter: + * lcmdil_c : address of the son table. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmdil_c"; + lcm *jplist; + blockb *ipnode; + int_32 mode, lenold, ityold; + char nammy[13]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iset < 0 || iset >= (*iplist)->listlen) { + sprintf(AbortString,"%s: LIST INDEX %d OUT OF BOUNDS (%d,%d) IN OBJECT '%.60s'.", + nomsub,(int)iset,0,(int)((*iplist)->listlen-1),(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *ipxsm; + ipxsm = (xsm *)*iplist + iset; + xsmdid_c(&ipxsm," ",(xsm **)(&jplist)); + return jplist; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->imode == 2) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS OPEN IN READ-ONLY MODE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->father == NULL) { + sprintf(AbortString,"%s: THE FATHER OBJECT ('/') IS NOT A LIST.", + nomsub); + xabort_c(AbortString); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode[(*iplist)->ifdir - 1].jjtyp != 10) { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + nammy[12]='\0'; + sprintf(AbortString,"%s: THE FATHER OBJECT ('%s') IS NOT A LIST.", + nomsub,nammy); + xabort_c(AbortString); + } + } + ipnode = ((*iplist)[iset]).inext; + mode = ((*iplist)[iset]).imode; + if (ipnode == NULL) { + lenold = 0; + ityold = 0; + } else { + lenold = (ipnode[0]).jjlon; + ityold = (ipnode[0]).jjtyp; + } + + if (ityold != 0) { + sprintf(AbortString,"%s: LIST ELEMENT %d IS AN INVALID DIRECTORY TYPE. OBJECT='%.60s'.", + nomsub,(int)iset,(*iplist)[iset].hname); + xabort_c(AbortString); + } else if (lenold != 0 && lenold != -1) { + sprintf(AbortString,"%s: LIST ELEMENT %d OF THE OBJECT '%.60s' HAS AN INVALID LENGTH ( %d ).", + nomsub,(int)iset,(*iplist)[iset].hname,(int)lenold); + xabort_c(AbortString); + } else if (lenold == 0) { + /* CREATE A NEW NODE TABLE. */ + ipnode = (blockb *) malloc(sizeof(*ipnode)); + (*iplist)[iset].inext = ipnode; + (*iplist)[iset].imax = 1; + (*iplist)[iset].inref = 1; + memcpy((char*)ipnode[0].jcmt," ",12); + (ipnode[0]).jjlon = -1; + (ipnode[0]).jjtyp = 0; + jplist = (lcm *) malloc(sizeof(*jplist)); + jplist->header = (*iplist)->header; + strcpy(jplist->hname, (*iplist)->hname); + jplist->listlen = -1; + jplist->inext = NULL; + jplist->father = *iplist; + jplist->ifdir = 1; + jplist->imax = 0; + jplist->inref = 0; + jplist->icang = (*iplist)->icang; + jplist->global = (*iplist)->global; + jplist->hash = NULL; + lcmkep(jplist->icang, c__1, &jplist); + (ipnode[0]).jdata = (int_32 *)jplist; + } + /* SWITCH TO THE SON DIRECTORY. */ + jplist = (lcm *)(ipnode[0]).jdata; + jplist->imode = mode; + return jplist; +} + +lcm * lcmlil_c(lcm **iplist,int_32 iset,int_32 ilong) +/* + *----------------------------------------------------------------------- + * + * create/access the hierarchical structure of a list embedded in + * another list. + * + * input parameters: + * iplist : address of the father list. + * iset : position of the embedded list in the father list. + * ilong : dimension of the embedded list. + * + * output parameter: + * lcmlil_c : address of the embedded list. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmlil_c"; + lcm *jplist, *iofset, *iofold; + blockb *ipnode; + int_32 i, mode, lenold, ityold; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iset < 0 || iset >= (*iplist)->listlen) { + sprintf(AbortString,"%s: LIST INDEX %d OUT OF BOUNDS (%d,%d) IN OBJECT '%.60s'.", + nomsub,(int)iset,0,(int)((*iplist)->listlen-1),(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *ipxsm; + ipxsm = (xsm *)*iplist + iset; + xsmlid_c(&ipxsm," ",ilong,(xsm **)(&jplist)); + return jplist; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->imode == 2) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS OPEN IN READ-ONLY MODE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (ilong <= 0) { + sprintf(AbortString,"%s: INVALID LENGTH (%d) FOR LIST ELEMENT %d IN THE OBJECT '%.45s'.", + nomsub,(int)ilong,(int)iset,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->father == NULL) { + sprintf(AbortString,"%s: THE FATHER OBJECT ('/') IS NOT A LIST.", + nomsub); + xabort_c(AbortString); + } + ipnode = ((*iplist)[iset]).inext; + mode = ((*iplist)[iset]).imode; + if (ipnode == NULL) { + lenold = 0; + ityold = 10; + } else { + lenold = (ipnode[0]).jjlon; + ityold = (ipnode[0]).jjtyp; + } + + if (ityold != 10) { + sprintf(AbortString,"%s: LIST ELEMENT %d IS AN INVALID LIST TYPE. TYPE=%d OBJECT='%.60s'.", + nomsub,(int)iset,(int)ityold,(*iplist)->hname); + xabort_c(AbortString); + } else if (lenold != 0 && lenold > ilong) { + ilong = lenold; + } + + if (lenold == 0) { + /* CREATE A NEW NODE TABLE. */ + ipnode = (blockb *) malloc(sizeof(*ipnode)); + (*iplist)[iset].inext = ipnode; + (*iplist)[iset].imax = 1; + (*iplist)[iset].inref = 1; + memcpy((char*)ipnode[0].jcmt," ",12); + (ipnode[0]).jjtyp = 10; + } + + if (ilong != lenold) { + (ipnode[0]).jjlon = ilong; + iofset = (lcm *) malloc(ilong*sizeof(*iofset)); + for (i = 0; i < ilong; ++i) { + if (i < lenold) { + iofold = (lcm *)(ipnode[0]).jdata; + iofset[i].header = iofold[i].header; + strcpy(iofset[i].hname, iofold[i].hname); + iofset[i].listlen = 0; + iofset[i].inext = iofold[i].inext; + iofset[i].father = iofold[i].father; + iofset[i].ifdir = iofold[i].ifdir; + iofset[i].imode = iofold[i].imode; + iofset[i].imax = iofold[i].imax; + iofset[i].inref = iofold[i].inref; + iofset[i].icang = iofold[i].icang; + iofset[i].global = iofold[i].global; + iofset[i].hash = iofold[i].hash; + /* PUT THE OLD TABLE IN READ-ONLY MODE */ + iofold[i].imode = 2; + } else { + iofset[i].header = (*iplist)->header; + strcpy(iofset[i].hname, (*iplist)->hname); + iofset[i].listlen = 0; + iofset[i].inext = NULL; + iofset[i].father = *iplist + iset; + iofset[i].ifdir = 1; + iofset[i].imode = 0; + iofset[i].imax = 0; + iofset[i].inref = 0; + iofset[i].icang = (*iplist)->icang; + iofset[i].global = (*iplist)->global; + iofset[i].hash = NULL; + } + } + iofset[0].listlen = ilong; + lcmkep(iofset->icang, c__1, &iofset); + (ipnode[0]).jdata = (int_32 *)iofset; + } + /* SWITCH TO THE SON LIST. */ + jplist = (lcm *)(ipnode[0]).jdata; + for (i = 0; i < ilong; ++i) jplist[i].imode = mode; + return jplist; +} + +void lcmppl_c(lcm **iplist,int_32 iset,int_32 ilong,int_32 itype,int_32 *iofdum) +/* + *----------------------------------------------------------------------- + * + * add a new malloc pointer entry in the list. + * + * input parameters: + * iplist : address of the list. + * iset : position of the specific element. + * ilong : number of information elements stored in the current block. + * itype : type of information elements stored in the current block. + * iofdum : malloc pointer of the first information element. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmppl_c"; + blockb *ipnode; + int_32 *jofdum; + char nammy[13]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iset < 0 || iset >= (*iplist)->listlen) { + sprintf(AbortString,"%s: LIST INDEX %d OUT OF BOUNDS (%d,%d) IN OBJECT '%.60s'.", + nomsub,(int)iset,0,(int)((*iplist)->listlen-1),(*iplist)->hname); + xabort_c(AbortString); + } else if (iofdum == NULL) { + sprintf(AbortString,"%s: THE MALLOC POINTER OF LIST ELEMENT %d IS NOT SET IN THE OBJECT '%.45s'.", + nomsub,(int)iset,(*iplist)->hname); + xabort_c(AbortString); + } else if (ilong <= 0) { + sprintf(AbortString,"%s: INVALID LENGTH ( %d ) FOR LIST ELEMENT %d IN THE OBJECT '%.45s'.", + nomsub,(int)ilong,(int)iset,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *ipxsm; + ipxsm = (xsm *)*iplist + iset; + xsmppd_c(&ipxsm," ",ilong,itype,iofdum); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->imode == 2) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS OPEN IN READ-ONLY MODE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->father == NULL) { + sprintf(AbortString,"%s: THE FATHER OBJECT ('/') IS NOT A LIST.", + nomsub); + xabort_c(AbortString); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode[(*iplist)->ifdir - 1].jjtyp != 10) { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + nammy[12]='\0'; + sprintf(AbortString,"%s: THE FATHER OBJECT ('%s') IS NOT A LIST.", + nomsub,nammy); + xabort_c(AbortString); + } + } + ipnode = (*iplist)[iset].inext; + if (ipnode == NULL) { + ipnode = (blockb *) malloc(sizeof(*ipnode)); + (*iplist)[iset].inext = ipnode; + (*iplist)[iset].imax = 1; + (*iplist)[iset].inref = 1; + memcpy((char*)ipnode[0].jcmt," ",12); + } else { + jofdum = (ipnode[0]).jdata; + if (jofdum != iofdum) { + if(refpop(iplist,jofdum)) free(jofdum); /* rlsara_c(jofdum); */ + } + } + + /* STORE THE INFORMATION RELATIVE TO THE NEW INFORMATION ELEMENT. */ + (ipnode[0]).jdata = iofdum; + (ipnode[0]).jjlon = ilong; + (ipnode[0]).jjtyp = itype; + + /* STORE THE FIRST AND LAST ELEMENTS FOR VALIDATION PURPOSE. */ + if (itype == 1 || itype == 2 || itype == 3 || itype == 5) { + (ipnode[0]).jidat[0] = iofdum[0]; + (ipnode[0]).jidat[1] = iofdum[ilong-1]; + } else if (itype == 4 || itype == 6) { + (ipnode[0]).jjlon = 2*ilong; + (ipnode[0]).jidat[0] = iofdum[0]; + (ipnode[0]).jidat[1] = iofdum[1]; + (ipnode[0]).jidat[2] = iofdum[2*ilong-2]; + (ipnode[0]).jidat[3] = iofdum[2*ilong-1]; + } + return; +} + +void lcmlel_c(lcm **iplist, int_32 iset, int_32 *ilong, int_32 *itylcm) +/* + *----------------------------------------------------------------------- + * + * return the length and type of a list entry. + * + * input parameters: + * iplist : address of the list. + * iset : position of the specific element. + * + * output parameters: + * ilong : number of information elements pointed by the lcm entry. + * ilong=0 is returned if the entry does not exists. + * itylcm : type of information elements pointed by the lcm entry. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex 99: empty node + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmlel_c"; + blockb *ipnode; + char nammy[13]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iset < 0 || iset >= (*iplist)->listlen) { + *ilong = 0; + *itylcm = 999; + return; + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *ipxsm; + ipxsm = (xsm *)*iplist + iset; + xsmlen_c(&ipxsm," ",ilong,itylcm); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->father == NULL) { + sprintf(AbortString,"%s: THE FATHER OBJECT ('/') IS NOT A LIST.", + nomsub); + xabort_c(AbortString); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode[(*iplist)->ifdir - 1].jjtyp != 10) { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + nammy[12]='\0'; + sprintf(AbortString,"%s: THE FATHER OBJECT ('%s') IS NOT A LIST.", + nomsub,nammy); + xabort_c(AbortString); + } + } + ipnode = (*iplist)[iset].inext; + if (ipnode == NULL) { + *ilong = 0; + *itylcm = 99; + } else { + *ilong = ipnode[0].jjlon; + *itylcm = ipnode[0].jjtyp; + if (*itylcm == 4 || *itylcm == 6) *ilong=*ilong/2; + } + return; +} + +void lcmgpl_c(lcm **iplist, int_32 iset, int_32 **iofdum) +/* + *----------------------------------------------------------------------- + * + * get a malloc pointer for a list entry. + * + * input parameters: + * iplist : address of the list. + * iset : position of the specific element. + * + * output parameter: + * iofdum : malloc pointer to the iset-th list entry. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmgpl_c"; + blockb *ipnode; + char nammy[13]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iset < 0 || iset >= (*iplist)->listlen) { + sprintf(AbortString,"%s: LIST INDEX %d OUT OF BOUNDS (%d,%d) IN OBJECT '%.60s'.", + nomsub,(int)iset,0,(int)((*iplist)->listlen-1),(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *ipxsm; + ipxsm = (xsm *)*iplist + iset; + xsmgpd_c(&ipxsm," ",iofdum); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->father == NULL) { + sprintf(AbortString,"%s: THE FATHER OBJECT ('/') IS NOT A LIST.", + nomsub); + xabort_c(AbortString); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode[(*iplist)->ifdir - 1].jjtyp != 10) { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + nammy[12]='\0'; + sprintf(AbortString,"%s: THE FATHER OBJECT ('%s') IS NOT A LIST.", + nomsub,nammy); + xabort_c(AbortString); + } + } + ipnode = (*iplist)[iset].inext; + if (ipnode != NULL) { + *iofdum = ipnode[0].jdata; + return; + } + ipnode = (*iplist)->father->inext; + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + nammy[12]='\0'; + sprintf(AbortString,"%s: UNABLE TO FIND LIST ELEMENT %d INTO DIRECTORY '%s' IN OBJECT '%.45s'.", + nomsub,(int)iset,nammy,(*iplist)->hname); + xabort_c(AbortString); +} + +void lcmgdl_c(lcm **iplist, int_32 iset, int_32 *idata) +/* + *----------------------------------------------------------------------- + * + * copy a block of data from a list into memory. + * + * input parameters: + * iplist : address of the list. + * iset : position of the specific element. + * + * output parameter: + * idata : information elements. dimension idata1(ilong) where ilong + * is the number of information elements. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmgdl_c"; + blockb *ipnode; + int_32 j; + char nammy[13]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iset < 0 || iset >= (*iplist)->listlen) { + sprintf(AbortString,"%s: LIST INDEX %d OUT OF BOUNDS (%d,%d) IN OBJECT '%.60s'.", + nomsub,(int)iset,0,(int)((*iplist)->listlen-1),(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *ipxsm; + ipxsm = (xsm *)*iplist + iset; + xsmget_c(&ipxsm," ",idata); + return; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->father == NULL) { + sprintf(AbortString,"%s: THE FATHER OBJECT ('/') IS NOT A LIST.", + nomsub); + xabort_c(AbortString); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode[(*iplist)->ifdir - 1].jjtyp != 10) { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + nammy[12]='\0'; + sprintf(AbortString,"%s: THE FATHER OBJECT ('%s') IS NOT A LIST.", + nomsub,nammy); + xabort_c(AbortString); + } + } + ipnode = (*iplist)[iset].inext; + if (ipnode != NULL) { + for (j = 0; j < ipnode[0].jjlon; ++j) idata[j] = ipnode[0].jdata[j]; + return; + } + ipnode = (*iplist)->father->inext; + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + nammy[12]='\0'; + sprintf(AbortString,"%s: UNABLE TO FIND LIST ELEMENT %d INTO DIRECTORY '%s' IN OBJECT '%.45s'.", + nomsub,(int)iset,nammy,(*iplist)->hname); + xabort_c(AbortString); +} + +lcm * lcmgil_c(lcm **iplist, int_32 iset) +/* + *----------------------------------------------------------------------- + * + * get the address of a table or of a list located in a father list. + * + * input parameters: + * iplist : address of the father list. + * iset : position of the specific element. + * + * output parameter: + * lcmgil_c : address of the table or of the list named namp. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmgil_c"; + blockb *ipnode; + char nammy[13]; + if ((*iplist)->header != 100 && (*iplist)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (iset < 0 || iset >= (*iplist)->listlen) { + sprintf(AbortString,"%s: LIST INDEX %d OUT OF BOUNDS (%d,%d) IN OBJECT '%.60s'.", + nomsub,(int)iset,0,(int)((*iplist)->listlen-1),(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *ipxsm, *jpxsm; + int_32 iilong, itylcm; + ipxsm = (xsm *)*iplist + iset; + xsmlen_c(&ipxsm," ",&iilong,&itylcm); + if (itylcm == 0) { + xsmdid_c(&ipxsm," ",&jpxsm); + } else { + xsmlid_c(&ipxsm," ",iilong,&jpxsm); + } + return (lcm *)jpxsm; + } else if ((*iplist)->imode == 0) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->father == NULL) { + sprintf(AbortString,"%s: THE FATHER OBJECT ('/') IS NOT A LIST.", + nomsub); + xabort_c(AbortString); + } else { + lcm *my_father; + my_father = (*iplist)->father; + ipnode = my_father->inext; + if (ipnode[(*iplist)->ifdir - 1].jjtyp != 10) { + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + nammy[12]='\0'; + sprintf(AbortString,"%s: THE FATHER OBJECT ('%s') IS NOT A LIST.", + nomsub,nammy); + xabort_c(AbortString); + } + } + ipnode = (*iplist)[iset].inext; + if (ipnode != NULL) { + lcm *jplist; + if ((ipnode[0].jjtyp != 0) && (ipnode[0].jjtyp != 10)) { + sprintf(AbortString,"%s: LIST ELEMENT %d IN LIST '%s' IS NOT A TABLE/LIST.", + nomsub,(int)iset,(*iplist)->hname); + xabort_c(AbortString); + } + jplist = (lcm *)(ipnode[0]).jdata; + return jplist; + } + ipnode = (*iplist)->father->inext; + strncpy(nammy,(char*)ipnode[(*iplist)->ifdir - 1].jcmt,12); + nammy[12]='\0'; + sprintf(AbortString,"%s: UNABLE TO FIND LIST ELEMENT %d INTO DIRECTORY '%s' IN OBJECT '%.45s'.", + nomsub,(int)iset,nammy,(*iplist)->hname); + xabort_c(AbortString); + return NULL; +} + +void lcmequ_part2(int_32 ilong, lcm *iplis1, lcm *iplis2); + +void lcmequ_part1(lcm *iplis1, lcm *iplis2) +/* FAST COPY OF AN ASSOCIATIVE TABLE */ +{ + int_32 i, iref, ilong, itylcm; + int inamt[3]; + blockb *inode; + lcm *kdata2; + char namt[13]; + inode = iplis1->inext; + for (iref = 0; iref < iplis1->inref; ++iref) { + memcpy((char*)inamt," ",12); + if ( (inode[iref].jcmt[0] != inamt[0]) || + (inode[iref].jcmt[1] != inamt[1]) || + (inode[iref].jcmt[2] != inamt[2]) ) { + ilong = inode[iref].jjlon; + itylcm = inode[iref].jjtyp; + strncpy(namt,(char*)inode[iref].jcmt,12); + namt[12]='\0'; + if (itylcm == 0 && ilong == -1) { + /* ASSOCIATIVE TABLE. */ + kdata2 = lcmdid_c(&iplis2, namt); + lcmequ_part1((lcm *)inode[iref].jdata, kdata2); + } else if (itylcm == 10) { + /* LIST. */ + kdata2 = lcmlid_c(&iplis2, namt, ilong); + lcmequ_part2(ilong, (lcm *)inode[iref].jdata, kdata2); + } else { + int_32 *iass; + int_32 jlong = ilong; + if(itylcm == 4 || itylcm == 6) jlong = ilong/2; + iass = (int_32 *)malloc(ilong*sizeof(int_32)); /* setara_c(ilong); */ + for (i = 0; i < ilong; ++i) iass[i] = inode[iref].jdata[i]; + lcmppd_c(&iplis2, namt, jlong, itylcm, iass); + } + } + } + return; +} +void lcmequ_part2(int_32 ilong, lcm *iplis1, lcm *iplis2) +/* FAST COPY OF A LIST */ +{ + int_32 i, ivec, kjlon, itylcm; + blockb *knode; + lcm *kdata2; + for (ivec = 0; ivec < ilong; ++ivec) { + knode = iplis1[ivec].inext; + if (knode) { + kjlon = knode[0].jjlon; + itylcm = knode[0].jjtyp; + if (itylcm == 0 && kjlon == -1) { + /* ASSOCIATIVE TABLE. */ + kdata2 = lcmdil_c(&iplis2, ivec); + lcmequ_part1((lcm *)knode[0].jdata, kdata2); + } else if (itylcm == 10) { + /* LIST. */ + kdata2=lcmlil_c(&iplis2, ivec, kjlon); + lcmequ_part2(kjlon, (lcm *)knode[0].jdata, kdata2); + } else { + int_32 *iass; + int_32 jlong = kjlon; + if(itylcm == 4 || itylcm == 6) jlong = kjlon/2; + iass = (int_32 *)malloc(kjlon*sizeof(int_32)); /* setara_c(kjlon); */ + for (i = 0; i < kjlon; ++i) iass[i] = knode[0].jdata[i]; + lcmppl_c(&iplis2, ivec, jlong, itylcm, iass); + } + } + } + return; +} + +void lcmequ_part4(int_32 ilong, lcm *iplis1, lcm *iplis2); + +void lcmequ_part3(lcm *iplis1, lcm *iplis2) +/* GENERAL COPY OF AN ASSOCIATIVE TABLE */ +{ + char namlcm[73], myname[13], namt[13], first[13]; + int_32 empty, ilong, lcml, access, itylcm; + lcm *kdata1, *kdata2; + lcminf_c(&iplis1, namlcm, myname, &empty, &ilong, &lcml, &access); + if (empty) return; + strcpy(namt," "); + lcmnxt_c(&iplis1,namt); + strcpy(first,namt); +L10: + lcmlen_c(&iplis1, namt, &ilong, &itylcm); + if (ilong != 0 && itylcm == 0) { + /* ASSOCIATIVE TABLE. */ + kdata1 = lcmgid_c(&iplis1, namt); + kdata2 = lcmdid_c(&iplis2, namt); + lcmequ_part3(kdata1, kdata2); + } else if (ilong != 0 && itylcm == 10) { + /* LIST. */ + kdata1 = lcmgid_c(&iplis1, namt); + kdata2 = lcmlid_c(&iplis2, namt, ilong); + lcmequ_part4(ilong, kdata1, kdata2); + } else if (ilong != 0 && itylcm <= 6) { + int_32 *iass; + int_32 jlong = ilong; + if (itylcm == 4 || itylcm == 6) jlong = 2*ilong; + iass = (int_32 *)malloc(jlong*sizeof(int_32)); /* setara_c(jlong); */ + lcmget_c(&iplis1, namt, iass); + lcmppd_c(&iplis2, namt, ilong, itylcm, iass); + } + lcmnxt_c(&iplis1, namt); + if (strcmp(namt,first) != 0) goto L10; + return; +} + +void lcmequ_part4(int_32 ilong, lcm *iplis1, lcm *iplis2) +/* GENERAL COPY OF A LIST */ +{ + int_32 ivec, kjlon, itylcm; + lcm *kdata1, *kdata2; + for (ivec = 0; ivec < ilong; ++ivec) { + lcmlel_c(&iplis1, ivec, &kjlon, &itylcm); + if (kjlon != 0 && itylcm == 0) { + /* ASSOCIATIVE TABLE. */ + kdata1 = lcmgil_c(&iplis1, ivec); + kdata2 = lcmdil_c(&iplis2, ivec); + lcmequ_part3(kdata1, kdata2); + } else if (kjlon != 0 && itylcm == 10) { + /* LIST. */ + kdata1=lcmgil_c(&iplis1, ivec); + kdata2=lcmlil_c(&iplis2, ivec, kjlon); + lcmequ_part4(kjlon, kdata1, kdata2); + } else if (kjlon != 0 && itylcm <= 6) { + int_32 *iass; + int_32 jlong = kjlon; + if (itylcm == 4 || itylcm == 6) jlong = 2*kjlon; + iass = (int_32 *)malloc(jlong*sizeof(int_32)); /* setara_c(jlong); */ + lcmgdl_c(&iplis1, ivec, iass); + lcmppl_c(&iplis2, ivec, kjlon, itylcm, iass); + } + } + return; +} + +void lcmequ_c(lcm **iplis1,lcm **iplis2) +/* + *----------------------------------------------------------------------- + * + * copy the information contained in the active directory of the memory + * or xsm file object pointed by iplis1 into the table or xsm file + * pointed by iplis2. iplis2 is not created by lcmequ. + * + * input parameters: + * iplis1 : address of the existing object. + * + * output parameter: + * iplis2 : address of the object where the copy is performed. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmequ_c"; + if ((*iplis1)->header != 100 && (*iplis1)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER(1).", + nomsub,(*iplis1)->hname); + xabort_c(AbortString); + } else if ((*iplis2)->header != 100 && (*iplis2)->header != 200) { + sprintf(AbortString,"%s: THE OBJECT '%.60s' HAS THE WRONG HEADER(2).", + nomsub,(*iplis1)->hname); + xabort_c(AbortString); + } + if ((*iplis1)->header == 100 && (*iplis2)->header == 100) { + /* USE A FAST COPY ALGORITHM. */ + if ((*iplis1)->listlen == -1) { + lcmequ_part1(*iplis1,*iplis2); + } else { + lcmequ_part2((*iplis1)->listlen,*iplis1,*iplis2); + } + } else { + /* USE A GENERAL COPY ALGORITHM. */ + if ((*iplis1)->listlen == -1) { + lcmequ_part3(*iplis1,*iplis2); + } else { + lcmequ_part4((*iplis1)->listlen,*iplis1,*iplis2); + } + } + return; +} + +typedef char String8[9]; +typedef char String10[11]; + +void Ote_blanc (char *chaine) +/* + *---------------------------------------------------------------------- + * + * Remove lagging blank characters from a C string. + * + *---------------------------------------------------------------------- + */ +{ + int len, i; + + len = strlen(chaine); + for (i = len-1; i > -1; i--) { + if(chaine[i] == '\n') { + chaine[i] = '\0'; + break; + } + else if(chaine[i] != ' ' && chaine[i] != '\0') { + chaine[i+1] = '\0'; + break; + } + } +} + +void lcmlib_c(lcm **iplist) +/* + *---------------------------------------------------------------------- + * + * list the lcm entries contained in memory or in a xsm file. + * + * input parameters: + * iplist : address of the object or handle to the xsm file. + * + *---------------------------------------------------------------------- + */ +{ + char *nomsub = "LCMLIB"; + char *nomlist = "LIST"; + char *nomtable = "TABLE"; + char namlcm[73], myname[13], namt[13], first[13], isign[13]; + int_32 empty, ilong, lcm, access, imed, itylcm, ilon, iset; + int_32 itot, inmt; + char* ctype[]={"DIRECTORY","INTEGER","REAL","CHARACTER","DOUBLE PRECISION", + "LOGICAL","COMPLEX","UNDEFINED"," "," ","LIST"}; + char* cmediu[]={"TABLE","XSM FILE"}; + + lcminf_c(iplist, namlcm, myname, &empty, &ilong, &lcm, &access); + if(lcm == 0) { + imed=2; + } + else{ + imed=1; + } + printf("\n\n %s: name=%s mode=%d ilong=%d access=%d\n",nomsub, namlcm, (*iplist)->imode, ilong, access); + if(ilong > 0) { + printf(" %s: CONTENT OF ACTIVE %s NAMED '%s' IN THE %8s-LOCATED LCM OBJECT '%.50s':\n", + nomsub, nomlist, myname, cmediu[imed-1], namlcm); + itot=0; + printf(" LIST ITEM --- LENGTH TYPE\n"); + for ( iset = 0; iset < ilong; iset++) { + lcmlel_c(iplist, iset, &ilon, &itylcm); + if(itylcm == 0 || itylcm ==10) { + printf(" %13d%10d %-16s\n", (int)(iset+1), (int)ilon, ctype[itylcm]); + } + else if(itylcm >= 1 && itylcm <= 6) { + printf(" %13d%10d %-16s\n", (int)(iset+1), (int)ilon, ctype[itylcm]); + itot=itot+ilon; + } + else{ + printf(" %13d%10d %-16s\n", (int)(iset+1), (int)ilon, ctype[7]); + } + } + printf(" TOTAL NUMBER OF WORDS ON LIST =%10d\n", (int)itot); + } + else{ + printf(" %s: CONTENT OF ACTIVE %5s NAMED '%s' IN THE %8s-LOCATED LCM OBJECT '%.50s':\n", + nomsub, nomtable, myname, cmediu[imed-1], namlcm); + if(empty == 1) { + printf(" %s: EMPTY TABLE.\n", nomsub); + return; + } + strcpy(namt, " "); + lcmnxt_c(iplist,namt); + strcpy(first,namt); + printf(" BLOCK NAME------------ LENGTH TYPE\n"); + itot=0; + inmt=0; + while (strcmp(namt, first) != 0 || inmt == 0) { + inmt++; + lcmlen_c(iplist, namt, &ilong, &itylcm); + if(itylcm == 0 || itylcm ==10) { + printf(" %6d '%-12s'%10d %-16s\n",(int)inmt,namt,(int)ilong,ctype[itylcm]); + } + else if(itylcm >= 1 && itylcm <= 6) { + if((ilong == 3) && itylcm == 3) { + int_32 i, ndata[13]; + lcmget_c(iplist,namt,ndata); + for (i=0; i<3; i++) strncpy ((isign+4*i),(char *) &ndata[i], 4); + isign[12] = '\0'; + printf(" %6d '%-12s'%10d %-16s='%-12s'\n", + (int)inmt,namt,(int)ilong,ctype[itylcm],isign); + } + else{ + printf(" %6d '%-12s'%10d %-16s\n",(int)inmt,namt,(int)ilong,ctype[itylcm]); + } + itot=itot+ilong; + } + else{ + printf(" %6d '%-12s'%10d %-16s\n",(int)inmt,namt,(int)ilong,ctype[7]); + } + lcmnxt_c(iplist, namt); + } + printf("\n\n TOTAL NUMBER OF WORDS IN TABLE =%10d\n", (int)itot); + } + fflush(stdout); + return; +} + +/****************************************/ +/* C API for lcm export/import support */ +/****************************************/ + +void lcmnod_c(FILE *file, int_32 imode, int_32 idir, int_32 jlong, + int_32 itylcm, int_32 *iass) +{ + char *nomsub="lcmnod_c"; + char *ccc = NULL; + int_32 *iii; + float_32 *rrr; + double_64 *ddd; + int_32 *lll; + int_32 i, j, nb_ligne, reste; + int_32 lendat = 4; + String10 typelogic[8]; + + if (idir == 1) { + /* EXPORT A NODE.*/ + if(itylcm == 1) { + /* INTEGER DATA */ + iii = (int_32*)iass; + if( file != NULL && imode == 1) { + fwrite(iii, sizeof(int_32), (int)jlong, file); + } else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 8; j++) fprintf(file, "%10d", (int)iii[i*8+j]); + fprintf(file, "\n"); + } + reste = jlong%8; + for (j = 0; j < reste; j++) fprintf(file, "%10d", (int)iii[nb_ligne*8+j]); + if(reste != 0) fprintf(file, "\n"); + } + } else if(itylcm == 2) { + /* SINGLE PRECISION DATA */ + rrr = (float_32*)iass; + if( file != NULL && imode == 1) { + fwrite(rrr, sizeof(float_32), (int)jlong, file); + } else if( file != NULL && imode == 2) { + /* 5 DATA BY LINE */ + nb_ligne = (int)jlong/5; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 5; j++) fprintf(file, "%16.8E", rrr[i*5+j]); + fprintf(file, "\n"); + } + reste = jlong%5; + for (j = 0; j < reste; j++) fprintf(file, "%16.8E", rrr[nb_ligne*5+j]); + if(reste != 0) fprintf(file, "\n"); + } + } else if(itylcm == 3) { + /* CHARACTER*4 DATA */ + int i; + ccc = (char *) malloc ((int)jlong*lendat + 1); /* +1 for \0 */ + for (i=0; i<jlong; i++) strncpy ((ccc+lendat*i),(char *) (iass + i), (int)lendat); + ccc[(int)jlong*lendat] = '\0'; + if( file != NULL && imode == 1) { + for (i = 0; i < jlong; i++) fwrite(&lendat, sizeof(int), 1, file); + fwrite(ccc, sizeof(char), (int)jlong*lendat, file); + } + else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 8; j++) fprintf(file, "%10d", (int)lendat); + fprintf(file, "\n"); + } + reste = jlong%8; + for (j = 0; j < reste; j++) fprintf(file, "%10d", (int)lendat); + if(reste != 0) fprintf(file, "\n"); + /* 20 DATA BY LINE */ + nb_ligne = (int)jlong/20; + reste = jlong%20; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 20*lendat; j++) + fprintf(file, "%1c",ccc[i*20*lendat+j]); + fprintf(file, "\n"); + } + for (j = 0; j < reste*lendat; j++) + fprintf(file, "%1c",ccc[nb_ligne*20*lendat+j]); + if(reste != 0) fprintf(file, "\n"); + } + if(ccc != NULL) { + free(ccc); + ccc = NULL; + } + } else if(itylcm == 4) { + /* DOUBLE PRECISION DATA */ + ddd = (double_64*)iass; + if( file != NULL && imode == 1) { + fwrite(ddd, sizeof(double_64), (int)jlong, file); + } + else if( file != NULL && imode == 2) { + /* 4 DATA BY LINE */ + nb_ligne = (int)jlong/4; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 4; j++) fprintf(file, "%20.12E", ddd[i*4+j]); + fprintf(file, "\n"); + } + reste = jlong%4; + for (j = 0; j < reste; j++) + fprintf(file, "%20.12E", ddd[nb_ligne*4+j]); + if(reste != 0) fprintf(file, "\n"); + } + } else if(itylcm == 5) { + /* LOGICAL DATA */ + lll = (int_32*)iass; + if( file != NULL && imode == 1) { + fwrite(lll, sizeof(int_32), (int)jlong, file); + } else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 8; j++) { + if (lll[i*8+j] == 0) { + fprintf(file, " F"); + } else { + fprintf(file, " T"); + } + } + fprintf(file, "\n"); + } + reste = jlong%8; + for (j = 0; j < reste; j++) { + if (lll[nb_ligne*8+j] == 0) { + fprintf(file, " F"); + } else { + fprintf(file, " T"); + } + } + fprintf(file, "\n"); + } + } else if(itylcm == 6) { + /* COMPLEX DATA */ + rrr = (float_32*)iass; + if( file != NULL && imode == 1) { + fwrite(rrr, sizeof(float_32), 2*(int)jlong, file); + } else if( file != NULL && imode == 2) { + /* 5 DATA BY LINE */ + nb_ligne = (int)(2*jlong/5); + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 5; j++) fprintf(file, "%16.8E", rrr[i*5+j]); + fprintf(file, "\n"); + } + reste = 2*jlong%5; + for (j = 0; j < reste; j++) fprintf(file, "%16.8E", rrr[nb_ligne*5+j]); + if(reste != 0) fprintf(file, "\n"); + } + } + free(iass); /* rlsara_c(iass); */ + } else if (idir == 2) { + /* IMPORT A NODE. */ + if (itylcm == 1) { + /* INTEGER DATA */ + iii = (int_32*)iass; + if( file != NULL && imode == 1) { + if(fread(iii, sizeof(int_32), (int)jlong, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 8; j++) { + if(fscanf(file, "%10d", (int *)&iii[i*8+j]) == EOF) goto L20; + } + if(fscanf(file, "\n") == EOF) goto L20; + } + reste = jlong%8; + for (j = 0; j < reste; j++) { + if(fscanf(file, "%10d", (int *)&iii[nb_ligne*8+j]) == EOF) goto L20; + } + if(reste != 0) { + if(fscanf(file, "\n") == EOF) goto L20; + } + } + } else if (itylcm == 2) { + /* SINGLE PRECISION DATA */ + rrr = (float_32*)iass; + if( file != NULL && imode == 1) { + if(fread(rrr, sizeof(float_32), (int)jlong, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 5 DATA BY LINE */ + nb_ligne = (int)jlong/5; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 5; j++) { + if(fscanf(file, "%e", &rrr[i*5+j]) == EOF) goto L20; + } + if(fscanf(file, "\n") == EOF) goto L20; + } + reste = jlong%5; + for (j = 0; j < reste; j++) { + if(fscanf(file, "%e", &rrr[nb_ligne*5+j]) == EOF) goto L20; + } + if(reste != 0) { + if(fscanf(file, "\n") == EOF) goto L20; + } + } + } else if(itylcm == 3) { + /* CHARACTER*4 DATA */ + ccc= (char *)malloc((int)jlong*lendat + 1); + if( file != NULL && imode == 1) { + for (i = 0; i < jlong; i++) { + if(fread(&lendat, sizeof(int), 1, file) < 1) goto L10; + } + if(fread(ccc, sizeof(char), (int)jlong*lendat, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 8; j++) { + if( fscanf(file, "%10d", (int *)&lendat) == EOF) goto L20; + } + fgetc(file); + } + reste = jlong%8; + for (j = 0; j < reste; j++) { + if( fscanf(file, "%10d", (int *)&lendat) == EOF) goto L20; + } + if(reste != 0) fgetc(file); + /* 20 DATA BY LINE */ + nb_ligne = (int)jlong/20; + reste = jlong%20; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 20*lendat; j++) + ccc[i*20*lendat+j] = fgetc(file); + fgetc(file); + } + if(reste != 0) { + for (j = 0; j < reste*lendat; j++) + ccc[nb_ligne*20*lendat+j] = fgetc(file); + fgetc(file); + } + } + ccc[(int)jlong*lendat] = '\0'; + strncpy((char*)iass, ccc, (int)jlong*lendat); + if(ccc != NULL) { + free(ccc); + ccc = NULL; + } + } + else if(itylcm == 4) { + /* DOUBLE PRECISION DATA */ + ddd = (double_64*)iass; + if( file != NULL && imode == 1) { + if(fread(ddd, sizeof(double_64), (int)jlong, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 4 DATA BY LINE */ + nb_ligne = (int)jlong/4; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 4; j++) { + if(fscanf(file, "%lE", &ddd[i*4+j]) == EOF) goto L20; + } + if(fscanf(file, "\n") == EOF) goto L20; + } + reste = jlong%4; + for (j = 0; j < reste; j++) { + if(fscanf(file, "%lE", &ddd[nb_ligne*4+j]) == EOF) goto L20; + } + if(reste != 0) { + if( fscanf(file, "\n") == EOF) goto L20; + } + } + } else if(itylcm == 5) { + /* LOGICAL DATA */ + lll = (int_32*)iass; + if( file != NULL && imode == 1) { + if(fread(lll, sizeof(int), (int)jlong, file) < 1) goto L10; + } + else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + if(fscanf(file, "%s %s %s %s %s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], typelogic[3], + typelogic[4], typelogic[5], typelogic[6], typelogic[7]) == EOF) goto L20; + for (j = 0; j < 8; j++) { + if(strcmp(typelogic[j],"F") == 0) lll[i*8+j] = 0; + else lll[i*8+j] = 1; + } + } + reste = jlong%8; + switch(reste) { + case 1: + if(fscanf(file, "%s\n", + typelogic[0]) == EOF) goto L20; + break; + case 2: + if(fscanf(file, "%s %s\n", + typelogic[0], typelogic[1]) == EOF) goto L20; + break; + case 3: + if(fscanf(file, "%s %s %s\n", + typelogic[0], typelogic[1], typelogic[2]) == EOF) goto L20; + break; + case 4: + if(fscanf(file, "%s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], typelogic[3]) == EOF) goto L20; + break; + case 5: + if(fscanf(file, "%s %s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], + typelogic[3], typelogic[4]) == EOF) goto L20; + break; + case 6: + if(fscanf(file, "%s %s %s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], + typelogic[3], typelogic[4], typelogic[5]) == EOF) goto L20; + break; + case 7: + if( fscanf(file, "%s %s %s %s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], + typelogic[3], typelogic[4], typelogic[5], typelogic[6]) == EOF) goto L20; + break; + } + for (j = 0; j < reste; j++) { + if(strcmp(typelogic[j],"F") == 0) lll[nb_ligne*8+j] = 0; + else lll[nb_ligne*8+j] = 1; + } + } + } + else if(itylcm == 6) { + /* COMPLEX DATA */ + rrr = (float_32*)iass; + if( file != NULL && imode == 1) { + if(fread(rrr, sizeof(float_32), 2*(int)jlong, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 5 DATA BY LINE */ + nb_ligne = (int)(2*jlong/5); + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 5; j++) { + if(fscanf(file, "%e", &rrr[i*5+j]) == EOF) goto L20; + } + if(fscanf(file, "\n") == EOF) goto L20; + } + reste = 2*jlong%5; + for (j = 0; j < reste; j++) { + if(fscanf(file, "%e", &rrr[nb_ligne*5+j]) == EOF) goto L20; + } + if(reste != 0) { + if(fscanf(file, "\n") == EOF) goto L20; + } + } + } + } + return; +L10: + sprintf(AbortString,"%s: fread failure", nomsub); + xabort_c(AbortString); +L20: + sprintf(AbortString,"%s: fscanf failure", nomsub); + xabort_c(AbortString); +} + +void lcmexp_part2(int_32 ilong, int_32 impx, int_32 imode, lcm *iplist, int_32 idir, + FILE *file,int_32 imed, int_32 *ilev, int_32 *itot, int_32 *lennam, + char namlcm[]); + +void lcmexp_part1(lcm *iplist, int_32 impx, int_32 imode, int_32 idir, FILE *file, + int_32 imed, int_32 *ilev, int_32 *itot, int_32 *lennam) +/* GENERAL EXPORT OF AN ASSOCIATIVE TABLE */ +{ + char *nomsub = "lcmexp_part1"; + String8 cmediu[2]; + char namlcm[73], myname[13], namt[13], first[13]; + int_32 empty, ilong, licm, access, itylcm, jlong; + int zero = 0; + lcm *kdata1; + + strcpy(cmediu[0], "TABLE"); + strcpy(cmediu[1], "XSM FILE"); + /* FILE EXPORT.*/ + /* ASSOCIATIVE TABLE.*/ + lcminf_c(&iplist, namlcm, myname, &empty, &ilong, &licm, &access); + if(empty == 1) { + if( file != NULL && imode == 1) { + int_32 negilev = -(*ilev); + fwrite(&negilev, sizeof(int_32), 1, file); + fwrite(&zero, sizeof(int_32), 1, file); + fwrite(&zero, sizeof(int_32), 1, file); + fwrite(&zero, sizeof(int_32), 1, file); + } else if( file != NULL && imode == 2) { + fprintf(file, "->%8d%8d%8d%8d%32s <- \n",(int)(-(*ilev)),zero,zero,zero," "); + } + return; + } + strcpy(namt, " "); + lcmnxt_c(&iplist, namt); + *lennam = 12; + if(strcmp(namt, " ") == 0) *lennam = 0; + strcpy(first,namt); +L10: + lcmlen_c(&iplist, namt, &jlong, &itylcm); + if (jlong != 0 ) { + if (impx > 0) { + printf(" %5d '%-12s'%8d%8d\n", (int)(*ilev), namt, (int)itylcm, (int)jlong); + fflush(stdout); + } + if( file != NULL && imode == 1) { + fwrite(ilev, sizeof(int_32), 1, file); + fwrite(lennam, sizeof(int_32), 1, file); + fwrite(&itylcm, sizeof(int_32), 1, file); + fwrite(&jlong, sizeof(int_32), 1, file); + if ( *lennam > 0) fwrite(namt, sizeof(char), *lennam, file); + } else if( file != NULL && imode == 2) { + fprintf(file, "->%8d%8d%8d%8d%32s <- \n",(int)(*ilev),(int)(*lennam),(int)itylcm,(int)jlong," "); + if(*lennam > 0) fprintf(file, "%-80s\n", namt); + } + if(itylcm == 0 ) { + /* EXPORT ASSOCIATIVE TABLE DATA.*/ + *ilev = *ilev + 1; + kdata1 = lcmgid_c(&iplist, namt); + lcmexp_part1(kdata1, impx, imode, idir, file, imed, ilev, itot, lennam); + *ilev =*ilev - 1; + } else if(itylcm ==10) { + /* EXPORT LIST DATA.*/ + *ilev = *ilev + 1; + kdata1 = lcmgid_c(&iplist, namt); + lcmexp_part2(jlong, impx, imode, kdata1, idir, file, imed, + ilev, itot, lennam, namlcm); + *ilev =*ilev - 1; + } else if(itylcm <= 6) { + int_32 *iass; + *itot = *itot + jlong; + ilong = jlong; + if(itylcm == 4 || itylcm == 6) ilong = 2*jlong; + iass = (int_32 *)malloc(ilong*sizeof(int_32)); /* setara_c(ilong); */ + lcmget_c(&iplist, namt, iass); + + /*--------------- EXPORT A NODE ---------------*/ + lcmnod_c(file, imode, idir, jlong, itylcm, iass); + /*---------------------------------------------*/ + } else { + sprintf(AbortString,"%s: TRY TO EXPORT UNKNOWN TYPE RECORD %d ON THE " + "%8s NAMED %.45s.",nomsub, (int)itylcm, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } + } + lcmnxt_c(&iplist, namt); + if (strcmp(namt,first) != 0) goto L10; + if( file != NULL && imode == 1) { + int_32 negilev = -(*ilev); + fwrite(&negilev, sizeof(int_32), 1, file); + fwrite(&zero, sizeof(int_32), 1, file); + fwrite(&zero, sizeof(int_32), 1, file); + fwrite(&zero, sizeof(int_32), 1, file); + } else if( file != NULL && imode == 2) { + fprintf(file, "->%8d%8d%8d%8d%32s <- \n",(int)(-(*ilev)),zero,zero,zero," "); + } + return; +} + +void lcmexp_part2(int_32 ilong, int_32 impx, int_32 imode, lcm *iplist, int_32 idir, + FILE *file, int_32 imed, int_32 *ilev, int_32 *itot, int_32 *lennam, + char namlcm[]) +/* GENERAL COPY OF A LIST */ +{ + char *nomsub = "lcmexp_part2"; + String8 cmediu[2]; + int_32 ivec; + lcm *kdata1; + + strcpy(cmediu[0], "TABLE"); + strcpy(cmediu[1], "XSM FILE"); + for (ivec = 0; ivec < ilong; ++ivec) { + int_32 jlong, itylcm; + lcmlel_c(&iplist, ivec, &jlong, &itylcm); + if (impx > 0) { + printf(" %5d '%-12s'%8d%8d\n", (int)*ilev, " ", (int)itylcm, (int)jlong); + fflush(stdout); + } + if( file != NULL && imode == 1) { + int_32 zero = 0; + fwrite(ilev, sizeof(int_32), 1, file); + fwrite(&zero, sizeof(int_32), 1, file); + fwrite(&itylcm, sizeof(int_32), 1, file); + fwrite(&jlong, sizeof(int_32), 1, file); + } else if( file != NULL && imode == 2) { + fprintf(file, "->%8d%8d%8d%8d%32s <- %08d\n",(int)(*ilev),0,(int)itylcm,(int)jlong," ",(int)(ivec+1)); + } + if (jlong != 0 && itylcm == 0) { + /* EXPORT ASSOCIATIVE TABLE DATA. */ + *ilev = *ilev +1; + kdata1 = lcmgil_c(&iplist, ivec); + lcmexp_part1(kdata1, impx, imode, idir, file, imed, ilev, itot, lennam); + *ilev =*ilev - 1; + } else if (jlong != 0 && itylcm == 10) { + /* EXPORT LIST DATA. */ + *ilev = *ilev +1; + kdata1=lcmgil_c(&iplist, ivec); + lcmexp_part2(jlong, impx, imode, kdata1, idir, file, imed, + ilev, itot, lennam, namlcm); + *ilev =*ilev - 1; + } else if (jlong != 0 && itylcm <= 6) { + int_32 *iass, kjlon; + *itot = *itot + jlong; + kjlon = jlong; + if(itylcm == 4 || itylcm == 6) kjlon = 2*jlong; + iass = (int_32 *)malloc(kjlon*sizeof(int_32)); /* setara_c(kjlon); */ + lcmgdl_c(&iplist, ivec, iass); + /*--------------- EXPORT A NODE ---------------*/ + lcmnod_c(file, imode, idir, jlong, itylcm, iass); + /*---------------------------------------------*/ + } else if (jlong != 0) { + sprintf(AbortString, "%s: TRY TO IMPORT BAD TYPE RECORD %d ON THE %8s " + "NAMED %.50s.",nomsub, (int)itylcm, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } + } + return; +} + +void lcmexp_part4(int_32 ilong, int_32 impx, int_32 imode, lcm *iplist, int_32 idir, + FILE *file, int_32 imed, int_32 *ilev, int_32 *itot, int_32 *lennam, + char namlcm[]); + +void lcmexp_part3(lcm *iplist, int_32 impx, int_32 imode, int_32 idir, FILE *file, + int_32 imed, int_32 *ilev, int_32 *itot, int_32 *lennam, char namlcm[]) +/* GENERAL IMPORT OF AN ASSOCIATIVE TABLE */ +{ + char *nomsub = "lcmexp_part3"; + String8 cmediu[2]; + char namt[13]; + int_32 ilong, itylcm, jlong; + int jtylcm; + lcm *kdata1; + int_32 jlev; + + strcpy(cmediu[0], "TABLE"); + strcpy(cmediu[1], "XSM FILE"); +L10: + if( file != NULL && imode == 1) { + if((int)fread(&jlev, sizeof(int_32), 1, file) == EOF) return; + if(fread(lennam, sizeof(int_32), 1, file) < 1) goto L20; + if(fread(&itylcm, sizeof(int_32), 1, file) < 1) goto L20; + if(fread(&ilong, sizeof(int_32), 1, file) < 1) goto L20; + } else if( file != NULL && imode == 2) { + char cnt1[9], cnt2[9], cnt3[9], cnt4[9]; + if(fscanf(file, "->%8c%8c%8c%8c%*s\n", cnt1,cnt2,cnt3,cnt4) == EOF) { + return; + } + cnt1[8] = cnt2[8] = cnt3[8] = cnt4[8] ='\0'; + sscanf(cnt1, "%d", (int_32 *)&jlev); sscanf(cnt2, "%d", (int_32 *)lennam); + sscanf(cnt3, "%d", (int_32 *)&itylcm); sscanf(cnt4, "%d", (int_32 *)&ilong); + } + jtylcm = itylcm; + if (jlev == *ilev) { + namt[12] = '\0'; + if( *lennam == 0) strcpy(namt, " "); + else if( file != NULL && imode == 1) { + if( *lennam > 0) { + if(fread(namt, sizeof(char), *lennam, file) < 1) goto L20; + } + } else if( file != NULL && imode == 2) { + if(*lennam > 0) { + if(fscanf(file, "%c%c%c%c%c%c%c%c%c%c%c%c\n", + &namt[0], &namt[1], &namt[2], &namt[3], &namt[4], + &namt[5], &namt[6], &namt[7], &namt[8], &namt[9], + &namt[10], &namt[11]) == EOF) goto L30; + Ote_blanc(namt); + } + } + if(impx > 0) { + printf("\n %5d '%-12s'%8d%8d", (int)jlev, namt, (int)itylcm, (int)ilong); + fflush(stdout); + } + if(jtylcm == 0 ) { + /* IMPORT ASSOCIATIVE TABLE DATA.*/ + *ilev = *ilev + 1; + kdata1 = lcmdid_c(&iplist, namt); + lcmexp_part3(kdata1, impx, imode, idir, file, imed, ilev, + itot, lennam, namlcm); + *ilev =*ilev - 1; + } else if (jtylcm == 10) { + /* IMPORT LIST DATA.*/ + *ilev = *ilev + 1; + kdata1 = lcmlid_c(&iplist, namt, ilong); + lcmexp_part4(ilong, impx, imode, kdata1, idir, file, imed, + ilev, itot, lennam, namlcm); + *ilev =*ilev - 1; + } else if (jtylcm <= 6) { + int_32 *iass; + jlong = ilong; + if(jtylcm == 4 || jtylcm == 6) jlong = 2*ilong; + iass = (int_32 *)malloc(jlong*sizeof(int_32)); /* setara_c(jlong); */ + /*--------------- IMPORT A NODE ---------------*/ + lcmnod_c(file, imode, idir, ilong, itylcm, iass); + /*---------------------------------------------*/ + lcmppd_c(&iplist, namt, ilong, itylcm, iass); + *itot = *itot + jlong; + } else { + sprintf(AbortString, "%s: TRY TO IMPORT UNKNOWN TYPE RECORD %d ON " + "THE %8s NAMED %.50s.",nomsub, (int)itylcm, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } + goto L10; + } else if (jlev == -(*ilev)) { + return; + } else { + sprintf(AbortString, "%s: UNABLE TO IMPORT '%8s' NAMED '%.50s'.", + nomsub, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } +L20: + sprintf(AbortString,"%s: fread failure", nomsub); + xabort_c(AbortString); +L30: + sprintf(AbortString,"%s: fscanf failure", nomsub); + xabort_c(AbortString); +} + +void lcmexp_part4(int_32 jlong, int_32 impx, int_32 imode, lcm *iplist, int_32 idir, + FILE *file, int_32 imed, int_32 *ilev, int_32 *itot, int_32 *lennam, + char namlcm[]) +/* GENERAL IMPORT OF A LIST */ +{ + char *nomsub = "lcmexp_part4"; + String8 cmediu[2]; + int_32 ivec, ilong, itylcm; + int jtylcm; + lcm *kdata1; + int_32 jlev; + + strcpy(cmediu[0], "TABLE"); + strcpy(cmediu[1], "XSM FILE"); + for (ivec = 0; ivec < jlong; ++ivec) { + if( file != NULL && imode == 1) { + if((int)fread(&jlev, sizeof(int_32), 1, file) == EOF) return; + if(fread(lennam, sizeof(int_32), 1, file) < 1) goto L20; + if(fread(&itylcm, sizeof(int_32), 1, file) < 1) goto L20; + if(fread(&ilong, sizeof(int_32), 1, file) < 1) goto L20; + } else if (file != NULL && imode == 2) { + char cnt1[9], cnt2[9], cnt3[9], cnt4[9]; + if(fscanf(file, "->%8c%8c%8c%8c%*s%*d\n", cnt1,cnt2,cnt3,cnt4) == EOF) { + return; + } + cnt1[8] = cnt2[8] = cnt3[8] = cnt4[8] ='\0'; + sscanf(cnt1, "%d", (int_32 *)&jlev); sscanf(cnt2, "%d", (int_32 *)lennam); + sscanf(cnt3, "%d", (int_32 *)&itylcm); sscanf(cnt4, "%d", (int_32 *)&ilong); + } + jtylcm = itylcm; + if (jlev != *ilev) { + sprintf(AbortString,"%s: INVALID LIST LEVEL ON THE '%8s' NAMED '%.50s'.", + nomsub, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } + if(impx > 0) { + printf("\n %5d '%-12s'%8d%8d", (int)jlev, " ", (int)itylcm,(int)ilong); + fflush(stdout); + } + if (ilong != 0 && jtylcm == 0) { + /* IMPORT ASSOCIATIVE TABLE DATA. */ + *ilev = *ilev + 1; + kdata1 = lcmdil_c(&iplist, ivec); + lcmexp_part3(kdata1, impx, imode, idir, file, imed, ilev, itot, + lennam, namlcm); + *ilev =*ilev - 1; + } else if (ilong != 0 && jtylcm == 10) { + /* IMPORT LIST DATA. */ + *ilev = *ilev + 1; + kdata1=lcmlil_c(&iplist, ivec, ilong); + lcmexp_part4(ilong, impx, imode, kdata1, idir, file, imed, + ilev, itot, lennam, namlcm); + *ilev =*ilev - 1; + } else if (ilong != 0 && jtylcm <= 6) { + int_32 *iass, kjlon; + kjlon = ilong; + if(jtylcm == 4 || jtylcm == 6) kjlon = 2*ilong; + iass = (int_32 *)malloc(kjlon*sizeof(int_32)); /* setara_c(kjlon); */ + /*--------------- IMPORT A NODE ---------------*/ + lcmnod_c(file, imode, idir, ilong, itylcm, iass); + /*---------------------------------------------*/ + lcmppl_c(&iplist, ivec, ilong, itylcm, iass); + *itot = *itot + jlong; + } else if(ilong != 0) { + sprintf(AbortString, "%s: TRY TO IMPORT UNKNOWN TYPE RECORD %d ON " + "THE %8s NAMED %.50s.",nomsub, (int)itylcm, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } + } + return; +L20: + sprintf(AbortString,"%s: fread failure", nomsub); + xabort_c(AbortString); +} + +void lcmexp_c(lcm **iplist, int_32 impx, FILE *file, int_32 imode, int_32 idir) +/* + *----------------------------------------------------------------------- + * + * export/import the content of a table or xsm file using the contour + * method. Export start from the active directory. + * + * iplist : address of the table or handle to the xsm file. + * impx : equal to zero for no print. + * nunit : file unit number where the export/import is performed. + * imode : type of export/import file: + * =1 sequential unformatted; =2 sequential formatted (ascii). + * idir : =1 to export ; =2 to import. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub = "lcmexp_c"; + String8 cmediu[2]; + char namlcm[73], myname[13]; + int_32 empty, ilong, lcm, access, imed; + int_32 itot, ilev, lennam; + FILE *fileout = NULL; + + strcpy(cmediu[0], "TABLE"); + strcpy(cmediu[1], "XSM FILE"); + + lcminf_c(iplist, namlcm, myname, &empty, &ilong, &lcm, &access); + imed=2; + if(lcm == 1) imed=1; + if(imode < 1 || imode > 2) { + sprintf(AbortString, "%s: INVALID FILE TYPE ON THE %8s NAMED '%.50s'.", + nomsub, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } else if(idir != 1 && idir != 2) { + sprintf(AbortString, "%s: INVALID ACTION ON THE %8s NAMED '%.50s'.", + nomsub, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } + if (file == NULL) { + sprintf(AbortString, "%s: NULL IMPORT/EXPORT FILE.", nomsub); + xabort_c(AbortString); + } else { + fileout = file; + } + itot = 0; + ilev = 1; + if (idir == 1) { + /* FILE EXPORT. ALGORITHM. */ + if ((*iplist)->listlen == -1) { + lcmval_c(iplist," "); + lcmexp_part1(*iplist, impx, imode, idir, fileout, imed, &ilev, &itot, + &lennam); + } else { + lcmexp_part2((*iplist)->listlen, impx, imode, *iplist, idir, fileout, imed, + &ilev, &itot, &lennam, namlcm); + } + if(impx > 0) printf("\n TOTAL NUMBER OF WORDS EXPORTED =%10d\n",(int)itot); + } else { + /* FILE IMPORT. ALGORITHM. */ + if(impx > 0) { + printf("\n\n%s: %6s %8s NAMED '%-12s' FROM ACTIVE DIRECTORY '%.50s' :" + "\n\n LEVEL BLOCK NAME--- TYPE LENGTH\n", + nomsub, "IMPORT",cmediu[imed-1],namlcm,myname); + fflush(stdout); + } + if ((*iplist)->listlen == -1) { + lcmexp_part3(*iplist, impx, imode, idir, fileout, imed, &ilev, &itot, + &lennam, namlcm); + } else { + lcmexp_part4((*iplist)->listlen, impx, imode, *iplist, idir, fileout, imed, + &ilev, &itot, &lennam, namlcm); + } + if(impx > 0) printf("\n TOTAL NUMBER OF WORDS IMPORTED =%10d\n",(int)itot); + } + fflush(stdout); + return; +} + +void lcmnodv3_c(FILE *file, int_32 imode, int_32 idir, int_32 jlong, + int_32 itylcm, int_32 *iass) +{ + char *nomsub = "lcmnodv3_c"; + char *ccc = NULL; + int_32 *iii; + float_32 *rrr; + double_64 *ddd; + int_32 *lll; + int_32 i, j, nb_ligne, reste; + int_32 lendat = 4; + String10 typelogic[8]; + + if (idir == 1) { + /* EXPORT A NODE.*/ + if(itylcm == 1) { + /* INTEGER DATA */ + iii = (int_32*)iass; + if( file != NULL && imode == 1) { + fwrite(iii, sizeof(int_32), (int)jlong, file); + } else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 8; j++) fprintf(file, "%10d", (int)iii[i*8+j]); + fprintf(file, "\n"); + } + reste = jlong%8; + for (j = 0; j < reste; j++) fprintf(file, "%10d", (int)iii[nb_ligne*8+j]); + if(reste != 0) fprintf(file, "\n"); + } + } else if(itylcm == 2) { + /* SINGLE PRECISION DATA */ + rrr = (float_32*)iass; + if( file != NULL && imode == 1) { + fwrite(rrr, sizeof(float_32), (int)jlong, file); + } else if( file != NULL && imode == 2) { + /* 5 DATA BY LINE */ + nb_ligne = (int)jlong/5; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 5; j++) fprintf(file, "%16.8E", rrr[i*5+j]); + fprintf(file, "\n"); + } + reste = jlong%5; + for (j = 0; j < reste; j++) fprintf(file, "%16.8E", rrr[nb_ligne*5+j]); + if(reste != 0) fprintf(file, "\n"); + } + } else if(itylcm == 3) { + /* CHARACTER*4 DATA */ + int i; + ccc = (char *) malloc ((int)jlong*lendat + 1); /* +1 for \0 */ + for (i=0; i<jlong; i++) strncpy ((ccc+lendat*i),(char *) (iass + i), (int)lendat); + ccc[(int)jlong*lendat] = '\0'; + if( file != NULL && imode == 1) { + fwrite(ccc, sizeof(char), (int)jlong*lendat, file); + } + else if( file != NULL && imode == 2) { + /* 20 DATA BY LINE */ + nb_ligne = (int)jlong/20; + reste = jlong%20; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 20*lendat; j++) + fprintf(file, "%1c",ccc[i*20*lendat+j]); + fprintf(file, "\n"); + } + for (j = 0; j < reste*lendat; j++) + fprintf(file, "%1c",ccc[nb_ligne*20*lendat+j]); + if(reste != 0) fprintf(file, "\n"); + } + if(ccc != NULL) { + free(ccc); + ccc = NULL; + } + } else if(itylcm == 4) { + /* DOUBLE PRECISION DATA */ + ddd = (double_64*)iass; + if( file != NULL && imode == 1) { + fwrite(ddd, sizeof(double_64), (int)jlong, file); + } + else if( file != NULL && imode == 2) { + /* 4 DATA BY LINE */ + nb_ligne = (int)jlong/4; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 4; j++) fprintf(file, "%20.12E", ddd[i*4+j]); + fprintf(file, "\n"); + } + reste = jlong%4; + for (j = 0; j < reste; j++) + fprintf(file, "%20.12E", ddd[nb_ligne*4+j]); + if(reste != 0) fprintf(file, "\n"); + } + } else if(itylcm == 5) { + /* LOGICAL DATA */ + lll = (int_32*)iass; + if( file != NULL && imode == 1) { + fwrite(lll, sizeof(int_32), (int)jlong, file); + } else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 8; j++) { + if (lll[i*8+j] == 0) { + fprintf(file, " F"); + } else { + fprintf(file, " T"); + } + } + fprintf(file, "\n"); + } + reste = jlong%8; + for (j = 0; j < reste; j++) { + if (lll[nb_ligne*8+j] == 0) { + fprintf(file, " F"); + } else { + fprintf(file, " T"); + } + } + fprintf(file, "\n"); + } + } else if(itylcm == 6) { + /* COMPLEX DATA */ + rrr = (float_32*)iass; + if( file != NULL && imode == 1) { + fwrite(rrr, sizeof(float_32), 2*(int)jlong, file); + } else if( file != NULL && imode == 2) { + /* 5 DATA BY LINE */ + nb_ligne = (int)(2*jlong/5); + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 5; j++) fprintf(file, "%16.8E", rrr[i*5+j]); + fprintf(file, "\n"); + } + reste = 2*jlong%5; + for (j = 0; j < reste; j++) fprintf(file, "%16.8E", rrr[nb_ligne*5+j]); + if(reste != 0) fprintf(file, "\n"); + } + } + free(iass); /* rlsara_c(iass); */ + } else if (idir == 2) { + /* IMPORT A NODE. */ + if (itylcm == 1) { + /* INTEGER DATA */ + iii = (int_32*)iass; + if( file != NULL && imode == 1) { + if(fread(iii, sizeof(int_32), (int)jlong, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 8; j++) { + if(fscanf(file, "%10d", (int *)&iii[i*8+j]) == EOF) goto L20; + } + if(fscanf(file, "\n") == EOF) goto L20; + } + reste = jlong%8; + for (j = 0; j < reste; j++) { + if(fscanf(file, "%10d", (int *)&iii[nb_ligne*8+j]) == EOF) goto L20; + } + if(reste != 0) { + if(fscanf(file, "\n") == EOF) goto L20; + } + } + } else if (itylcm == 2) { + /* SINGLE PRECISION DATA */ + rrr = (float_32*)iass; + if( file != NULL && imode == 1) { + if(fread(rrr, sizeof(float_32), (int)jlong, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 5 DATA BY LINE */ + nb_ligne = (int)jlong/5; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 5; j++) { + if(fscanf(file, "%e", &rrr[i*5+j]) == EOF) goto L20; + } + getc(file); + } + reste = jlong%5; + for (j = 0; j < reste; j++) { + if(fscanf(file, "%e", &rrr[nb_ligne*5+j]) == EOF) goto L20; + } + if(reste != 0) getc(file); + } + } else if(itylcm == 3) { + /* CHARACTER*4 DATA */ + ccc= (char *)malloc((int)jlong*lendat + 1); + if( file != NULL && imode == 1) { + if(fread(ccc, sizeof(char), (int)jlong*lendat, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 20 DATA BY LINE */ + nb_ligne = (int)jlong/20; + reste = jlong%20; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 20*lendat; j++) { + ccc[i*20*lendat+j] = getc(file); + } + getc(file); + } + if(reste != 0) { + for (j = 0; j < reste*lendat; j++) { + ccc[nb_ligne*20*lendat+j] = getc(file); + } + getc(file); + } + } + ccc[(int)jlong*lendat] = '\0'; + strncpy((char*)iass, ccc, (int)jlong*lendat); + if(ccc != NULL) { + free(ccc); + ccc = NULL; + } + } + else if(itylcm == 4) { + /* DOUBLE PRECISION DATA */ + ddd = (double_64*)iass; + if( file != NULL && imode == 1) { + if(fread(ddd, sizeof(double_64), (int)jlong, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 4 DATA BY LINE */ + nb_ligne = (int)jlong/4; + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 4; j++) { + if(fscanf(file, "%lE", &ddd[i*4+j]) == EOF) goto L20; + } + if(fscanf(file, "\n") == EOF) goto L20; + } + reste = jlong%4; + for (j = 0; j < reste; j++) { + if(fscanf(file, "%lE", &ddd[nb_ligne*4+j]) == EOF) goto L20; + } + if(reste != 0) { + if(fscanf(file, "\n") == EOF) goto L20; + } + } + } else if(itylcm == 5) { + /* LOGICAL DATA */ + lll = (int_32*)iass; + if( file != NULL && imode == 1) { + if(fread(lll, sizeof(int), (int)jlong, file) < 1) goto L10; + } + else if( file != NULL && imode == 2) { + /* 8 DATA BY LINE */ + nb_ligne = (int)jlong/8; + for (i = 0; i < nb_ligne; i++) { + if(fscanf(file, "%s %s %s %s %s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], typelogic[3], + typelogic[4], typelogic[5], typelogic[6], typelogic[7]) == EOF) goto L20; + for (j = 0; j < 8; j++) { + if(strcmp(typelogic[j],"F") == 0) lll[i*8+j] = 0; + else lll[i*8+j] = 1; + } + } + reste = jlong%8; + switch(reste) { + case 1: + if(fscanf(file, "%s\n", + typelogic[0]) == EOF) goto L20; + break; + case 2: + if(fscanf(file, "%s %s\n", + typelogic[0], typelogic[1]) == EOF) goto L20; + break; + case 3: + if(fscanf(file, "%s %s %s\n", + typelogic[0], typelogic[1], typelogic[2]) == EOF) goto L20; + break; + case 4: + if(fscanf(file, "%s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], typelogic[3]) == EOF) goto L20; + break; + case 5: + if(fscanf(file, "%s %s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], + typelogic[3], typelogic[4]) == EOF) goto L20; + break; + case 6: + if(fscanf(file, "%s %s %s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], + typelogic[3], typelogic[4], typelogic[5]) == EOF) goto L20; + break; + case 7: + if(fscanf(file, "%s %s %s %s %s %s %s\n", + typelogic[0], typelogic[1], typelogic[2], + typelogic[3], typelogic[4], typelogic[5], typelogic[6]) == EOF) goto L20; + break; + } + for (j = 0; j < reste; j++) { + if(strcmp(typelogic[j],"F") == 0) lll[nb_ligne*8+j] = 0; + else lll[nb_ligne*8+j] = 1; + } + } + } + else if(itylcm == 6) { + /* COMPLEX DATA */ + rrr = (float_32*)iass; + if( file != NULL && imode == 1) { + if(fread(rrr, sizeof(float_32), 2*(int)jlong, file) < 1) goto L10; + } else if( file != NULL && imode == 2) { + /* 5 DATA BY LINE */ + nb_ligne = (int)(2*jlong/5); + for (i = 0; i < nb_ligne; i++) { + for (j = 0; j < 5; j++) { + if(fscanf(file, "%e", &rrr[i*5+j]) == EOF) goto L20; + } + if(fscanf(file, "\n") == EOF) goto L20; + } + reste = 2*jlong%5; + for (j = 0; j < reste; j++) { + if(fscanf(file, "%e", &rrr[nb_ligne*5+j]) == EOF) goto L20; + } + if(reste != 0) { + if(fscanf(file, "\n") == EOF) goto L20; + } + } + } + } + return; +L10: + sprintf(AbortString,"%s: fread failure", nomsub); + xabort_c(AbortString); +L20: + sprintf(AbortString,"%s: fscanf failure", nomsub); + xabort_c(AbortString); +} + +void lcmexpv3_part1(lcm *iplist, int_32 impx, int_32 imode, int_32 idir, FILE *file, + int_32 imed, int_32 *ilev, int_32 *itot, int_32 *lennam) +/* GENERAL EXPORT OF AN ASSOCIATIVE TABLE */ +{ + char *nomsub = "lcmexpv3_part1"; + String8 cmediu[2]; + char namlcm[73], myname[13], namt[13], first[13]; + int_32 empty, ilong, licm, access, itylcm, jlong; + lcm *kdata1; + + strcpy(cmediu[0], "TABLE"); + strcpy(cmediu[1], "XSM FILE"); + /* FILE EXPORT.*/ + /* ASSOCIATIVE TABLE.*/ + lcminf_c(&iplist, namlcm, myname, &empty, &ilong, &licm, &access); + if(empty == 1) return; + strcpy(namt, " "); + lcmnxt_c(&iplist, namt); + *lennam = 12; + if(strcmp(namt, " ") == 0) *lennam = 0; + strcpy(first,namt); +L10: + lcmlen_c(&iplist, namt, &jlong, &itylcm); + if (jlong != 0) { + if(itylcm == 3) jlong = jlong*4; + if (impx > 0) { + printf(" %5d '%-12s'%8d%8d\n", (int)(*ilev), namt, (int)itylcm, (int)jlong); + fflush(stdout); + } + if( file != NULL && imode == 1) { + fwrite(ilev, sizeof(int_32), 1, file); + fwrite(namt, sizeof(char), *lennam, file); + fwrite(&itylcm, sizeof(int_32), 1, file); + fwrite(&jlong, sizeof(int_32), 1, file); + } else if( file != NULL && imode == 2) { + fprintf(file," %5d '%-12s'%8d%8d\n", (int)(*ilev), namt, (int)itylcm, (int)jlong); + } + if(itylcm == 3) jlong = jlong/4; + if(itylcm == 0) { + /* EXPORT ASSOCIATIVE TABLE DATA.*/ + *ilev = *ilev + 1; + kdata1 = lcmgid_c(&iplist, namt); + lcmexpv3_part1(kdata1, impx, imode, idir, file, imed, ilev, itot, lennam); + *ilev =*ilev - 1; + } else if(itylcm <= 6) { + int_32 *iass; + *itot = *itot + jlong; + ilong = jlong; + if(itylcm == 4 || itylcm == 6) ilong = 2*jlong; + iass = (int_32 *)malloc(ilong*sizeof(int_32)); /* setara_c(ilong); */ + lcmget_c(&iplist, namt, iass); + + /*---------------- EXPORT A NODE ----------------*/ + lcmnodv3_c(file, imode, idir, jlong, itylcm, iass); + /*-----------------------------------------------*/ + } else { + sprintf(AbortString,"%s: TRY TO EXPORT UNKNOWN TYPE RECORD %d ON THE " + "%8s NAMED %.45s.",nomsub, (int)itylcm, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } + } + lcmnxt_c(&iplist, namt); + if (strcmp(namt,first) != 0) goto L10; + return; +} + +void lcmexpv3_part3(lcm *iplist, int_32 impx, int_32 imode, int_32 idir, FILE *file, + int_32 imed, int_32 *ilev, int_32 *itot, int_32 *lennam, char namlcm[]) +/* GENERAL IMPORT OF AN ASSOCIATIVE TABLE */ +{ + char *nomsub = "lcmexpv3_part3"; + String8 cmediu[2]; + char namt[13]; + int_32 ilong, itylcm; + int jtylcm; + lcm *kdata1[100]; + int_32 jlev; + kdata1[0]=iplist; + + strcpy(cmediu[0], "TABLE"); + strcpy(cmediu[1], "XSM FILE"); +L10: + if( file != NULL && imode == 1) { + if((int)fread(&jlev, sizeof(int_32), 1, file) == EOF) return; + if(fread(namt, sizeof(char), 12, file) < 1) goto L20; + if(fread(&itylcm, sizeof(int_32), 1, file) < 1) goto L20; + if(fread(&ilong, sizeof(int_32), 1, file) < 1) goto L20; + } else if( file != NULL && imode == 2) { + if(fscanf(file, " %5d '%c%c%c%c%c%c%c%c%c%c%c%c'%8d%8d", (int *)(&jlev), + &namt[0], &namt[1], &namt[2], &namt[3], &namt[4], + &namt[5], &namt[6], &namt[7], &namt[8], &namt[9], + &namt[10], &namt[11], (int *)(&itylcm),(int *)(&ilong)) == EOF) { + return; + } else { + getc(file); + } + } + if(itylcm == 3 ) ilong = ilong/4; + jtylcm = itylcm; + if (jlev <= *ilev) { + *ilev=jlev; + namt[12] = '\0'; + Ote_blanc(namt); + if(jtylcm == 0 ) { + /* IMPORT ASSOCIATIVE TABLE DATA.*/ + *ilev = *ilev + 1; + kdata1[*ilev-1] = lcmdid_c((&kdata1[*ilev-2]), namt); + } else if (jtylcm <= 6) { + int_32 *iass; + int_32 jlong = ilong; + if(jtylcm == 4 || jtylcm == 6) jlong = 2*ilong; + iass = (int_32 *)malloc(jlong*sizeof(int_32)); /* setara_c(jlong); */ + /*---------------- IMPORT A NODE ----------------*/ + lcmnodv3_c(file, imode, idir, ilong, itylcm, iass); + /*-----------------------------------------------*/ + lcmppd_c(&kdata1[*ilev-1], namt, ilong, itylcm, iass); + *itot = *itot + jlong; + } else { + sprintf(AbortString, "%s: IMPORT UNKNOWN TYPE RECORD %d ON THE %8s " + "NAMED %.50s.",nomsub, (int)itylcm, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } + goto L10; + } else { + printf("\n%8d<>%8d\n", (int)jlev, (int ) *ilev); + sprintf(AbortString, "%s: UNABLE TO IMPORT '%8s' NAMED '%.50s'.", + nomsub, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } +L20: + sprintf(AbortString,"%s: fread failure", nomsub); + xabort_c(AbortString); +} + +void lcmexpv3_c(lcm **iplist, int_32 impx, FILE *file, int_32 imode, int_32 idir) +/* + *----------------------------------------------------------------------- + * + * export/import the content of a table or xsm file using the contour + * method for version 3. Export start from the active directory. + * + * iplist : address of the table or handle to the xsm file. + * impx : equal to zero for no print. + * nunit : file unit number where the export/import is performed. + * imode : type of export/import file: + * =1 sequential unformatted; =2 sequential formatted (ascii). + * idir : =1 to export ; =2 to import. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub = "lcmexpv3_c"; + String8 cmediu[2]; + char namlcm[73], myname[13]; + int_32 empty, ilong, lcm, access, imed; + int_32 itot, ilev, lennam; + FILE *fileout = NULL; + + strcpy(cmediu[0], "TABLE"); + strcpy(cmediu[1], "XSM FILE"); + + lcminf_c(iplist, namlcm, myname, &empty, &ilong, &lcm, &access); + imed=2; + if(lcm == 1) imed=1; + if(imode < 1 || imode > 2) { + sprintf(AbortString, "%s: INVALID FILE TYPE ON THE %8s NAMED '%.50s'.", + nomsub, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } else if(idir != 1 && idir != 2) { + sprintf(AbortString, "%s: INVALID ACTION ON THE %8s NAMED '%.50s'.", + nomsub, cmediu[imed-1], namlcm); + xabort_c(AbortString); + } + if (file == NULL) { + sprintf(AbortString, "%s: NULL IMPORT/EXPORT FILE.", nomsub); + xabort_c(AbortString); + } else { + fileout = file; + } + itot = 0; + ilev = 1; + if (idir == 1) { + /* FILE EXPORT. ALGORITHM. */ + lcmval_c(iplist," "); + lcmexpv3_part1(*iplist, impx, imode, idir, fileout, imed, &ilev, &itot, &lennam); + if(impx > 0) printf("\n TOTAL NUMBER OF WORDS EXPORTED =%10d\n",(int)itot); + } else { + /* FILE IMPORT. ALGORITHM. */ + if(impx > 0) { + printf("\n\n%s: %6s %8s NAMED '%-12s' FROM ACTIVE DIRECTORY '%-12s' :" + "\n\n LEVEL BLOCK NAME--- TYPE LENGTH\n", + nomsub, "IMPORT",cmediu[imed-1],namlcm,myname); + fflush(stdout); + } + lcmexpv3_part3(*iplist, impx, imode, idir, fileout, imed, &ilev, &itot, + &lennam, namlcm); + if(impx > 0) printf("\n TOTAL NUMBER OF WORDS IMPORTED =%10d\n",(int)itot); + } + fflush(stdout); + return; +} + +long lcmcast_c(lcm **iplist) +/* cast a LCM pointer into an integer (not 64-bit clean) */ +{ + long ret_val = (long) *iplist; + return ret_val; +} diff --git a/Ganlib/src/lcmc_aux.c b/Ganlib/src/lcmc_aux.c new file mode 100644 index 0000000..357c33a --- /dev/null +++ b/Ganlib/src/lcmc_aux.c @@ -0,0 +1,346 @@ + +/**********************************/ +/* C API for lcm object support */ +/* (auxiliary functions) */ +/* author: A. Hebert (30/04/2002) */ +/**********************************/ + +/* + Copyright (C) 2002 Ecole Polytechnique de Montreal + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + */ + +#include <stdlib.h> +#include <string.h> +#include "lcm.h" + +static char AbortString[132]; + +void lcmput_c(lcm **iplist,const char *namp,int_32 ilong,int_32 itype,int_32 *idata) +/* + *---------------------------------------------------------------------- + * + * copy a block of data from memory into a table. + * + * input parameters: + * iplist : address of the table. + * namp : character*12 name of the current block. + * ilong : number of information elements stored in the current block. + * itype : type of information elements stored in the current block. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex 99: undefined + * idata : information elements. + * + *---------------------------------------------------------------------- + */ +{ + if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsmput_c((xsm **)iplist,namp,ilong,itype,idata); + } else { + int_32 i, *iofdat; + int_32 jlong = ilong; + if (itype == 4 || itype == 6) jlong = 2*ilong; + iofdat = (int_32 *)malloc(jlong*sizeof(int_32)); /* setara_c(jlong); */ + for (i = 0; i < jlong; ++i) iofdat[i] = idata[i]; + lcmppd_c(iplist,namp,ilong,itype,iofdat); + } +} + +void lcmpdl_c(lcm **iplist,int_32 iset,int_32 ilong,int_32 itype,int_32 *idata) +/* + *---------------------------------------------------------------------- + * + * copy a block of data from memory into a list. + * + * input parameters: + * iplist : address of the list. + * iset : position of the specific element. + * ilong : number of information elements stored in the current block. + * itype : type of information elements stored in the current block. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex 99: undefined + * idata : information elements. + * + *---------------------------------------------------------------------- + */ +{ + if ((*iplist)->header == 200) { + /* USE A XSM FILE. */ + xsm *ipxsm = (xsm *)*iplist + iset; + xsmput_c(&ipxsm," ",ilong,itype,idata); + } else { + int_32 i, *iofdat; + int_32 jlong = ilong; + if (itype == 4 || itype == 6) jlong = 2*ilong; + iofdat = (int_32 *)malloc(jlong*sizeof(int_32)); /* setara_c(jlong); */ + for (i = 0; i < jlong; ++i) iofdat[i] = idata[i]; + lcmppl_c(iplist,iset,ilong,itype,iofdat); + } +} + +void lcmpcd_c(lcm **iplist,const char *namp,int_32 ilong,char *hdata[]) +/* + *---------------------------------------------------------------------- + * + * copy an array of c string variables from memory into a table. + * + * input parameters: + * iplist : address of the table. + * namp : character*12 name of the block. + * ilong : dimension of the string array. + * hdata : array of ilong strings. + * + *---------------------------------------------------------------------- + */ +{ + int_32 iset; + lcm *jplist; + jplist = lcmlid_c(iplist, namp, ilong); + for (iset=0; iset<ilong; iset++) { + int_32 i, ilen, *iofset; + ilen = (strlen(hdata[iset]) + 4 ) / 4; + iofset = (int_32 *)malloc(ilen*sizeof(int_32)); /* setara_c(ilen); */ + for (i=0; i<ilen; i++) strncpy ((char *)(iofset+i), hdata[iset]+4*i, 4); + lcmppl_c(&jplist, iset, ilen, 3, iofset); + } +} + +void lcmgcd_c(lcm **iplist,const char *namp,char *hdata[]) +/* + *----------------------------------------------------------------------- + * + * copy an array of c string variables from a table into memory. + * + * input parameters: + * iplist : address of the table. + * namp : character*12 name of the existing block. + * + * output parameter: + * hdata : array of ilong strings (allocated by lcmgcd_c). + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmgcd_c"; + int_32 iset, ilong, itylcm; + lcm *jplist; + lcmlen_c(iplist, namp, &ilong, &itylcm); + if (itylcm != 10) { + sprintf(AbortString,"%s: LIST EXPECTED.",nomsub); + xabort_c(AbortString); + } + jplist = lcmgid_c(iplist, namp); + for (iset=0; iset<ilong; iset++) { + int_32 j, ilcmg, *iass; + lcmlel_c(&jplist, iset, &ilcmg, &itylcm); + iass = (int_32 *)malloc(ilcmg*sizeof(int_32)); /* setara_c(ilcmg); */ + lcmgdl_c(&jplist, iset, iass); + hdata[iset] = (char *)malloc((int)4*ilcmg+1); + for (j=0; j<ilcmg; j++) strncpy ((hdata[iset]+4*j),(char *) (iass + j), 4); + hdata[iset][4*ilcmg]=' '; + free(iass); /* rlsara_c(iass); */ + for(j=4*ilcmg; j>0; j--) { + if (hdata[iset][j] != ' ') break; + hdata[iset][j]='\0'; + } + } +} + +void lcmpcl_c(lcm **iplist,int_32 iset,int_32 ilong,char *hdata[]) +/* + *---------------------------------------------------------------------- + * + * copy an array of c string variables from memory into a list. + * + * input parameters: + * iplist : address of the table. + * iset : position of the block in the list. + * ilong : dimension of the character variable. + * hdata : array of ilong strings. + * + *---------------------------------------------------------------------- + */ +{ + int_32 jset; + lcm *jplist; + jplist=lcmlil_c(iplist, iset, ilong); + for (jset=0; jset<ilong; jset++) { + int_32 i, ilen, *iofset; + ilen = (strlen(hdata[jset]) + 4 ) / 4; + iofset = (int_32 *)malloc(ilen*sizeof(int_32)); /* setara_c(ilen); */ + for (i=0; i<ilen; i++) strncpy ((char *)(iofset+i), hdata[jset]+4*i, 4); + lcmppl_c(&jplist, jset, ilen, 3, iofset); + } +} + +void lcmgcl_c(lcm **iplist,int_32 iset,char *hdata[]) +/* + *----------------------------------------------------------------------- + * + * copy an array of c string variables from a list into memory. + * + * input parameters: + * iplist : address of the table. + * iset : position of the block in the list. + * + * output parameter: + * hdata : array of ilong strings (allocated by lcmgcl_c). + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="lcmgcl_c"; + int_32 jset, ilong, itylcm; + lcm *jplist; + lcmlel_c(iplist, iset, &ilong, &itylcm); + if (itylcm != 10) { + sprintf(AbortString,"%s: LIST EXPECTED.",nomsub); + xabort_c(AbortString); + } + jplist = lcmgil_c(iplist, iset); + for (jset=0; jset<ilong; jset++) { + int_32 j, ilcmg, *iass; + lcmlel_c(&jplist, jset, &ilcmg, &itylcm); + iass = (int_32 *)malloc(ilcmg*sizeof(int_32)); /* setara_c(ilcmg); */ + lcmgdl_c(&jplist, jset, iass); + hdata[jset] = (char *)malloc((int)4*ilcmg+1); + for (j=0; j<ilcmg; j++) strncpy ((hdata[jset]+4*j),(char *) (iass + j), 4); + hdata[jset][4*ilcmg]=' '; + free(iass); /* rlsara_c(iass); */ + for(j=4*ilcmg; j>0; j--) { + if (hdata[jset][j] != ' ') break; + hdata[jset][j]='\0'; + } + } +} + +void lcmpsd_c(lcm **iplist,const char *namp,char *hdata) +/* + *---------------------------------------------------------------------- + * + * copy a single c string variable from memory into a table. + * + * input parameters: + * iplist : address of the table. + * namp : character*12 name of the block. + * hdata : c string. + * + *---------------------------------------------------------------------- + */ +{ + int_32 i, ilong, *iofset; + ilong = (strlen(hdata) + 4 ) / 4; + iofset = (int_32 *)malloc(ilong*sizeof(int_32)); /* setara_c(ilong); */ + for (i=0; i<ilong; i++) strncpy ((char *)(iofset+i), hdata+4*i, 4); + lcmppd_c(iplist, namp, ilong, 3, iofset); +} + +char * lcmgsd_c(lcm **iplist,const char *namp) +/* + *----------------------------------------------------------------------- + * + * copy a single c string variable from a table into memory. + * + * input parameters: + * iplist : address of the table. + * namp : character*12 name of the existing block. + * + * output parameter: + * lcmgsd_c : c string. + * + *----------------------------------------------------------------------- + */ +{ + static char nomstatic[133]; + char *nomsub="lcmgsd_c"; + int_32 i, ilong, itylcm, *iass; + lcmlen_c(iplist, namp, &ilong, &itylcm); + if (itylcm != 3) { + sprintf(AbortString,"%s: CHARACTER DATA EXPECTED.",nomsub); + xabort_c(AbortString); + } else if (ilong*4 > 132) { + sprintf(AbortString,"%s: CHARACTER DATA OVERFLOW.",nomsub); + xabort_c(AbortString); + } + + iass = (int_32 *)malloc(ilong*sizeof(int_32)); /* setara_c(ilong); */ + lcmget_c(iplist, namp, iass); + for (i=0; i<ilong; i++) strncpy ((nomstatic+4*i),(char *) (iass+i), 4); + nomstatic[ilong*4] = ' '; + free(iass); /* rlsara_c(iass); */ + for(i=ilong*4; i>0; i--) { + if(nomstatic[i] != ' ') break; + nomstatic[i] = '\0'; + } + return nomstatic; +} + +void lcmpsl_c(lcm **iplist,int_32 iset,char *hdata) +/* + *---------------------------------------------------------------------- + * + * copy a single c string variable from memory into a list. + * + * input parameters: + * iplist : address of the table. + * iset : position of the block in the list. + * hdata : c string. + * + *---------------------------------------------------------------------- + */ +{ + int_32 i, ilong, *iofset; + ilong = (strlen(hdata) + 4 ) / 4; + iofset = (int_32 *)malloc(ilong*sizeof(int_32)); /* setara_c(ilong); */ + for (i=0; i<ilong; i++) strncpy ((char *)(iofset+i), hdata+4*i, 4); + lcmppl_c(iplist, iset, ilong, 3, iofset); +} + +char * lcmgsl_c(lcm **iplist,int_32 iset) +/* + *----------------------------------------------------------------------- + * + * copy a single c string variable from a list into memory. + * + * input parameters: + * iplist : address of the table. + * iset : position of the block in the list. + * + * output parameter: + * lcmgsd_c : c string. + * + *----------------------------------------------------------------------- + */ +{ + static char nomstatic[133]; + char *nomsub="lcmgsl_c"; + int_32 i, ilong, itylcm, *iass; + lcmlel_c(iplist, iset, &ilong, &itylcm); + if (itylcm != 3) { + sprintf(AbortString,"%s: CHARACTER DATA EXPECTED.",nomsub); + xabort_c(AbortString); + } else if (ilong*4 > 132) { + sprintf(AbortString,"%s: CHARACTER DATA OVERFLOW.",nomsub); + xabort_c(AbortString); + } + + iass = (int_32 *)malloc(ilong*sizeof(int_32)); /* setara_c(ilong); */ + lcmgdl_c(iplist, iset, iass); + for (i=0; i<ilong; i++) strncpy ((nomstatic+4*i),(char *) (iass+i), 4); + nomstatic[ilong*4] = ' '; + free(iass); /* rlsara_c(iass); */ + for(i=ilong*4; i>0; i--) { + if(nomstatic[i] != ' ') break; + nomstatic[i] = '\0'; + } + return nomstatic; +} diff --git a/Ganlib/src/lcmmod.f90 b/Ganlib/src/lcmmod.f90 new file mode 100644 index 0000000..beeef3a --- /dev/null +++ b/Ganlib/src/lcmmod.f90 @@ -0,0 +1,1917 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Fortran-2003 bindings for lcm -- part 2. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +module LCMMOD + use LCMAUX + private + public :: LCMPUT, LCMGET, LCMPDL, LCMGDL + interface LCMPUT + ! store a record in an associative table + MODULE PROCEDURE LCMPUT_I0, LCMPUT_R0, LCMPUT_D0, LCMPUT_L0, LCMPUT_C0, & + LCMPUT_I1, LCMPUT_R1, LCMPUT_D1, LCMPUT_L1, LCMPUT_C1, & + LCMPUT_I2, LCMPUT_R2, LCMPUT_D2, LCMPUT_L2, LCMPUT_C2, & + LCMPUT_I3, LCMPUT_R3, LCMPUT_D3, LCMPUT_L3, LCMPUT_C3, & + LCMPUT_I4, LCMPUT_R4, LCMPUT_D4, LCMPUT_L4, LCMPUT_C4 + end interface + interface LCMGET + ! recover a record from an associative table + MODULE PROCEDURE LCMGET_I0, LCMGET_R0, LCMGET_D0, LCMGET_L0, LCMGET_C0, & + LCMGET_I1, LCMGET_R1, LCMGET_D1, LCMGET_L1, LCMGET_C1, & + LCMGET_I2, LCMGET_R2, LCMGET_D2, LCMGET_L2, LCMGET_C2, & + LCMGET_I3, LCMGET_R3, LCMGET_D3, LCMGET_L3, LCMGET_C3, & + LCMGET_I4, LCMGET_R4, LCMGET_D4, LCMGET_L4, LCMGET_C4 + end interface + interface LCMPDL + ! store a record in an heterogeneous list + MODULE PROCEDURE LCMPDL_I0, LCMPDL_R0, LCMPDL_D0, LCMPDL_L0, LCMPDL_C0, & + LCMPDL_I1, LCMPDL_R1, LCMPDL_D1, LCMPDL_L1, LCMPDL_C1, & + LCMPDL_I2, LCMPDL_R2, LCMPDL_D2, LCMPDL_L2, LCMPDL_C2, & + LCMPDL_I3, LCMPDL_R3, LCMPDL_D3, LCMPDL_L3, LCMPDL_C3 + end interface + interface LCMGDL + ! recover a record from an heterogeneous list + MODULE PROCEDURE LCMGDL_I0, LCMGDL_R0, LCMGDL_D0, LCMGDL_L0, LCMGDL_C0, & + LCMGDL_I1, LCMGDL_R1, LCMGDL_D1, LCMGDL_L1, LCMGDL_C1, & + LCMGDL_I2, LCMGDL_R2, LCMGDL_D2, LCMGDL_L2, LCMGDL_C2, & + LCMGDL_I3, LCMGDL_R3, LCMGDL_D3, LCMGDL_L3, LCMGDL_C3 + end interface +contains +subroutine LCMPUT_I0(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + integer, target :: idata + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if((itype.ne.1).and.(itype.ne.3)) call XABORT('LCMPUT_I0: type 1 or 3 expected.') + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_I0 +! +subroutine LCMPUT_R0(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + real, target :: idata + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.2) call XABORT('LCMPUT_R0: type 2 expected.') + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_R0 +! +subroutine LCMPUT_D0(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + double precision, target :: idata + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.4) call XABORT('LCMPUT_D0: type 4 expected.') + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_D0 +! +subroutine LCMPUT_L0(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + logical, target :: idata + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.5) call XABORT('LCMPUT_L0: type 5 expected.') + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_L0 +! +subroutine LCMPUT_C0(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + complex, target :: idata + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.6) call XABORT('LCMPUT_C0: type 6 expected.') + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_C0 +! +subroutine LCMPUT_I1(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + integer, target, dimension(:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if((itype.ne.1).and.(itype.ne.3)) call XABORT('LCMPUT_I1: type 1 or 3 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_I1 +! +subroutine LCMPUT_R1(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + real, target, dimension(:) :: idata + real, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.2) call XABORT('LCMPUT_R1: type 2 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_R1 +! +subroutine LCMPUT_D1(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + double precision, target, dimension(:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.4) call XABORT('LCMPUT_D1: type 4 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_D1 +! +subroutine LCMPUT_L1(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + logical, target, dimension(:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.5) call XABORT('LCMPUT_L1: type 5 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_L1 +! +subroutine LCMPUT_C1(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + complex, target, dimension(:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.6) call XABORT('LCMPUT_C1: type 6 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_C1 +! +subroutine LCMPUT_I2(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + integer, target, dimension(:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if((itype.ne.1).and.(itype.ne.3)) call XABORT('LCMPUT_I2: type 1 or 3 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_I2 +! +subroutine LCMPUT_R2(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + real, target, dimension(:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.2) call XABORT('LCMPUT_R2: type 2 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_R2 +! +subroutine LCMPUT_D2(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + double precision, target, dimension(:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.4) call XABORT('LCMPUT_D2: type 4 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_D2 +! +subroutine LCMPUT_L2(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + logical, target, dimension(:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.5) call XABORT('LCMPUT_L2: type 5 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_L2 +! +subroutine LCMPUT_C2(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + complex, target, dimension(:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.6) call XABORT('LCMPUT_C2: type 6 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_C2 +! +subroutine LCMPUT_I3(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + integer, target, dimension(:,:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if((itype.ne.1).and.(itype.ne.3)) call XABORT('LCMPUT_I3: type 1 or 3 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_I3 +! +subroutine LCMPUT_R3(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + real, target, dimension(:,:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.2) call XABORT('LCMPUT_R3: type 2 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_R3 +! +subroutine LCMPUT_D3(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + double precision, target, dimension(:,:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.4) call XABORT('LCMPUT_D3: type 4 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_D3 +! +subroutine LCMPUT_L3(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + logical, target, dimension(:,:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.5) call XABORT('LCMPUT_L3: type 5 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_L3 +! +subroutine LCMPUT_C3(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + complex, target, dimension(:,:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.6) call XABORT('LCMPUT_C3: type 6 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_C3 +! +subroutine LCMPUT_I4(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + integer, target, dimension(:,:,:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if((itype.ne.1).and.(itype.ne.3)) call XABORT('LCMPUT_I4: type 1 or 3 expected.') + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_I4 +! +subroutine LCMPUT_R4(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + real, target, dimension(:,:,:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.2) call XABORT('LCMPUT_R4: type 2 expected.') + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_R4 +! +subroutine LCMPUT_D4(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + double precision, target, dimension(:,:,:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.4) call XABORT('LCMPUT_D4: type 4 expected.') + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_D4 +! +subroutine LCMPUT_L4(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + logical, target, dimension(:,:,:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.5) call XABORT('LCMPUT_L4: type 5 expected.') + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_L4 +! +subroutine LCMPUT_C4(iplist, name, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer :: ilong, itype + complex, target, dimension(:,:,:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmput_c (iplist, namp, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + integer(c_int), value :: ilong, itype + type(c_ptr), value :: idata + end subroutine lcmput_c + end interface + if(itype.ne.6) call XABORT('LCMPUT_C4: type 6 expected.') + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmput_c(iplist, name13, ilong, itype, pt_data) +end subroutine LCMPUT_C4 +! +subroutine LCMGET_I0(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer, target :: idata + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_I0 +! +subroutine LCMGET_R0(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + real, target :: idata + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_R0 +! +subroutine LCMGET_D0(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + double precision, target :: idata + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_D0 +! +subroutine LCMGET_L0(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + logical, target :: idata + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_L0 +! +subroutine LCMGET_C0(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + complex, target :: idata + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + pt_data=c_loc(idata) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_C0 +! +subroutine LCMGET_I1(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer, target, dimension(:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_I1 +! +subroutine LCMGET_R1(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + real, target, dimension(:) :: idata + real, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_R1 +! +subroutine LCMGET_D1(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + double precision, target, dimension(:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_D1 +! +subroutine LCMGET_L1(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + logical, target, dimension(:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_L1 +! +subroutine LCMGET_C1(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + complex, target, dimension(:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_C1 +! +subroutine LCMGET_I2(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer, target, dimension(:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_I2 +! +subroutine LCMGET_R2(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + real, target, dimension(:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_R2 +! +subroutine LCMGET_D2(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + double precision, target, dimension(:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_D2 +! +subroutine LCMGET_L2(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + logical, target, dimension(:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_L2 +! +subroutine LCMGET_C2(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + complex, target, dimension(:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_C2 +! +subroutine LCMGET_I3(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer, target, dimension(:,:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_I3 +! +subroutine LCMGET_R3(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + real, target, dimension(:,:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_R3 +! +subroutine LCMGET_D3(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + double precision, target, dimension(:,:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_D3 +! +subroutine LCMGET_L3(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + logical, target, dimension(:,:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_L3 +! +subroutine LCMGET_C3(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + complex, target, dimension(:,:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_C3 +! +subroutine LCMGET_I4(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + integer, target, dimension(:,:,:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_I4 +! +subroutine LCMGET_R4(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + real, target, dimension(:,:,:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_R4 +! +subroutine LCMGET_D4(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + double precision, target, dimension(:,:,:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_D4 +! +subroutine LCMGET_L4(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + logical, target, dimension(:,:,:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_L4 +! +subroutine LCMGET_C4(iplist, name, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + character(len=*),intent(in) :: name + character(kind=c_char), dimension(13) :: name13 + complex, target, dimension(:,:,:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmget_c (iplist, namp, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + character(kind=c_char), dimension(*) :: namp + type(c_ptr), value :: idata + end subroutine lcmget_c + end interface + idata_p => idata(1,1,1,1) + pt_data=c_loc(idata_p) + call STRCUT(name13, name) + call lcmget_c(iplist, name13, pt_data) +end subroutine LCMGET_C4 +! +subroutine LCMPDL_I0(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + integer, target :: idata + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if((itype.ne.1).and.(itype.ne.3)) call XABORT('LCMPDL_I0: type 1 or 3 expected.') + pt_data=c_loc(idata) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_I0 +! +subroutine LCMPDL_R0(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + real, target :: idata + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.2) call XABORT('LCMPDL_R0: type 2 expected.') + pt_data=c_loc(idata) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_R0 +! +subroutine LCMPDL_D0(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + double precision, target :: idata + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.4) call XABORT('LCMPDL_D0: type 4 expected.') + pt_data=c_loc(idata) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_D0 +! +subroutine LCMPDL_L0(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + logical, target :: idata + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.5) call XABORT('LCMPDL_L0: type 5 expected.') + pt_data=c_loc(idata) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_L0 +! +subroutine LCMPDL_C0(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + complex, target :: idata + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.6) call XABORT('LCMPDL_C0: type 6 expected.') + pt_data=c_loc(idata) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_C0 +! +subroutine LCMPDL_I1(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + integer, target, dimension(:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if((itype.ne.1).and.(itype.ne.3)) call XABORT('LCMPDL_I1: type 1 or 3 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_I1 +! +subroutine LCMPDL_R1(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + real, target, dimension(:) :: idata + real, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.2) call XABORT('LCMPDL_R1: type 2 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_R1 +! +subroutine LCMPDL_D1(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + double precision, target, dimension(:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.4) call XABORT('LCMPDL_D1: type 4 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_D1 +! +subroutine LCMPDL_L1(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + logical, target, dimension(:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.5) call XABORT('LCMPDL_L1: type 5 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_L1 +! +subroutine LCMPDL_C1(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + complex, target, dimension(:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.6) call XABORT('LCMPDL_C1: type 6 expected.') + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_C1 +! +subroutine LCMPDL_I2(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + integer, target, dimension(:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if((itype.ne.1).and.(itype.ne.3)) call XABORT('LCMPDL_I2: type 1 or 3 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_I2 +! +subroutine LCMPDL_R2(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + real, target, dimension(:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.2) call XABORT('LCMPDL_R2: type 2 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_R2 +! +subroutine LCMPDL_D2(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + double precision, target, dimension(:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.4) call XABORT('LCMPDL_D2: type 4 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_D2 +! +subroutine LCMPDL_L2(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + logical, target, dimension(:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.5) call XABORT('LCMPDL_L2: type 5 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_L2 +! +subroutine LCMPDL_C2(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + complex, target, dimension(:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.6) call XABORT('LCMPDL_C2: type 6 expected.') + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_C2 +! +subroutine LCMPDL_I3(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + integer, target, dimension(:,:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if((itype.ne.1).and.(itype.ne.3)) call XABORT('LCMPDL_I3: type 1 or 3 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_I3 +! +subroutine LCMPDL_R3(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + real, target, dimension(:,:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.2) call XABORT('LCMPDL_R3: type 2 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_R3 +! +subroutine LCMPDL_D3(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + double precision, target, dimension(:,:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.4) call XABORT('LCMPDL_D3: type 4 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_D3 +! +subroutine LCMPDL_L3(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + logical, target, dimension(:,:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.5) call XABORT('LCMPDL_L3: type 5 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_L3 +! +subroutine LCMPDL_C3(iplist, ipos, ilong, itype, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos, ilong, itype + complex, target, dimension(:,:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmpdl_c (iplist, ipos, ilong, itype, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos, ilong, itype + type(c_ptr), value :: idata + end subroutine lcmpdl_c + end interface + if(itype.ne.6) call XABORT('LCMPDL_C3: type 6 expected.') + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmpdl_c(iplist, ipos-1, ilong, itype, pt_data) +end subroutine LCMPDL_C3 +! +subroutine LCMGDL_I0(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + integer, target :: idata + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + pt_data=c_loc(idata) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_I0 +! +subroutine LCMGDL_R0(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + real, target :: idata + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + pt_data=c_loc(idata) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_R0 +! +subroutine LCMGDL_D0(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + double precision, target :: idata + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + pt_data=c_loc(idata) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_D0 +! +subroutine LCMGDL_L0(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + logical, target :: idata + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + pt_data=c_loc(idata) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_L0 +! +subroutine LCMGDL_C0(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + complex, target :: idata + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + pt_data=c_loc(idata) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_C0 +! +subroutine LCMGDL_I1(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + integer, target, dimension(:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_I1 +! +subroutine LCMGDL_R1(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + real, target, dimension(:) :: idata + real, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_R1 +! +subroutine LCMGDL_D1(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + double precision, target, dimension(:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_D1 +! +subroutine LCMGDL_L1(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + logical, target, dimension(:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_L1 +! +subroutine LCMGDL_C1(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + complex, target, dimension(:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_C1 +! +subroutine LCMGDL_I2(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + integer, target, dimension(:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_I2 +! +subroutine LCMGDL_R2(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + real, target, dimension(:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_R2 +! +subroutine LCMGDL_D2(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + double precision, target, dimension(:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_D2 +! +subroutine LCMGDL_L2(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + logical, target, dimension(:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_L2 +! +subroutine LCMGDL_C2(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + complex, target, dimension(:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_C2 +! +subroutine LCMGDL_I3(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + integer, target, dimension(:,:,:) :: idata + integer, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_I3 +! +subroutine LCMGDL_R3(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + real, target, dimension(:,:,:) :: idata + real, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_R3 +! +subroutine LCMGDL_D3(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + double precision, target, dimension(:,:,:) :: idata + double precision, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_D3 +! +subroutine LCMGDL_L3(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + logical, target, dimension(:,:,:) :: idata + logical, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_L3 +! +subroutine LCMGDL_C3(iplist, ipos, idata) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist, pt_data + integer :: ipos + complex, target, dimension(:,:,:) :: idata + complex, pointer :: idata_p + interface + subroutine lcmgdl_c (iplist, ipos, idata) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr) :: iplist + integer(c_int), value :: ipos + type(c_ptr), value :: idata + end subroutine lcmgdl_c + end interface + idata_p => idata(1,1,1) + pt_data=c_loc(idata_p) + call lcmgdl_c(iplist, ipos-1, pt_data) +end subroutine LCMGDL_C3 +end module LCMMOD diff --git a/Ganlib/src/objpil.c b/Ganlib/src/objpil.c new file mode 100644 index 0000000..5a5902c --- /dev/null +++ b/Ganlib/src/objpil.c @@ -0,0 +1,51 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 15/05/09 */ +/*****************************************/ + +#include <string.h> +#include "cle2000.h" + +int_32 objpil(kdi_file *iunito, FILE *iwrite, int_32 ldatav) +{ + +/* GAN-2000 SYSTEM: R.ROY (12/1999), VERSION 2.1 */ + +/* *OBJPIL* WILL COMPLETE SYNTACTICAL ANALYSIS */ +/* INCLUDING OBJECT CONSISTENCE IN GAN-2000 */ +/* RESULT IS THE OBJECT D.A. UNIT *IUNITO* */ +/* COMPILER COMMENTS ARE WRITTEN ON UNIT *IWRITE* */ +/* EVERYTHING IS CHECKED FOR CORRECT EXECUTION. */ + +/* INPUT: *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */ +/* *IWRITE* IS THE OUTPUT UNIT FOR COMPILER COMMENTS */ +/* *LDATAV* =0/1: PROCEDURE SECTION/DATA SECTION */ + +/* NOTE: *OBJPIL* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */ + + char *nomsub = "objpil"; + char *clistc[] = {"objstk", "objxrf"}; + int_32 iretcd, istepc; + int_32 ret_val = 0; + +/* ADD OBJECTS/MODULES TO CLE-2000 FILES */ + istepc = 0; + iretcd = objstk(iunito, iwrite, ldatav); + if (iretcd != 0) goto L9002; + +/* X-REF OBJECTS/MODULES */ + istepc = 1; + iretcd = objxrf(iunito, iwrite); + if (iretcd != 0) goto L9002; + +L666: + return ret_val; + +L9002: + printf("! %s: ERROR CODE IN >>%s<< ERROR NUMBER (%d)\n", nomsub, clistc[istepc], (int)iretcd); + ret_val = iretcd; + goto L666; + +} /* objpil */ diff --git a/Ganlib/src/objstk.c b/Ganlib/src/objstk.c new file mode 100644 index 0000000..2b85cf2 --- /dev/null +++ b/Ganlib/src/objstk.c @@ -0,0 +1,469 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 12/05/09 */ +/*****************************************/ + +#include <stdlib.h> +#include <string.h> +#include "cle2000.h" +#include "header.h" +#define index_f(A, B) (strstr(A, B) == NULL ? 0 : strstr(A, B) - A + 1) +#define maxdxt 200 /* maximum number of modules */ +#define ndclkw 9 +#define nmodst 15 +#define nmawrd 60 + +int_32 objstk(kdi_file *iunito, FILE *iwrite, int_32 ldatav) +{ + char *nomsub="objstk"; + static char cerror[] = "* GAN-2000 VERS 2.1 * ERROR FOUND FOR THIS LINE"; + static char cl2000[] = "CLE2000(V3)"; + static char alphab[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"; + static char digits[] = "0123456789"; + static char *ckeywd[] = {"INTEGER", "REAL", "STRING", "DOUBLE", "LOGICAL", "EVALUATE", "ECHO", "ELSEIF", + "IF", "WHILE", "UNTIL", "ENDWHILE", "REPEAT", "ELSE", "ENDIF", "THEN", "DO", + "QUIT", "NOT", "ABS", "CHS", "LN", "SIN", "COS", "TAN", "ARCSIN", "ARCCOS", + "ARCTAN", "EXP", "SQRT", "R_TO_I", "D_TO_I", "I_TO_R", "D_TO_R", "I_TO_D", + "R_TO_D", "I_TO_S", "I_TO_S4", "_MIN_", "_MAX_", "_TRIM_"}; + static char *cdclkw[] = {"PROCEDURE", "MODULE", "LINKED_LIST", "XSM_FILE", "SEQ_BINARY", "SEQ_ASCII", + "DIR_ACCESS", "HDF5_FILE", "PARAMETER"}; + +/* GAN-2000 SYSTEM: R.ROY (12/1999), VERSION 2.0 */ + +/* *OBJSTK* FIRST-PASS COMPILE OF THE D.A. UNIT *IUNITO* */ +/* NOW INCLUDING OBJECTS & MODULES */ +/* RESULT IS STILL THE OBJECT D.A. UNIT *IUNITO* */ +/* COMPILER COMMENTS ARE WRITTEN ON UNIT *IWRITE* */ +/* STACK IS BUILT AT THE END OF *IUNITO* */ + +/* USE: MODULE+OBJECT NAMES ARE DEFINED AND ALLOCATED, */ +/* CONSISTENCE OF OBJECTS IN CALL */ +/* STATEMENTS ARE ALSO CHECKED. */ + +/* INPUT: *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */ +/* *IWRITE* IS THE OUTPUT UNIT FOR COMPILER COMMENTS */ +/* *LDATAV* =0/1: PROCEDURE SECTION/DATA SECTION */ + +/* NOTE: *OBJSTK* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */ + + int_32 ret_val = 0; + char cmodul[13], cparin[13], cparav[13], myreco[121], cdatin[121]; + int_32 i, iretcd, nrecor, ninput, nstack, idblst, idatin, iofset, iloop1, jloop2, ilines, + ilevel, indlin, idclin, idefin, iusein; + float_32 adatin; + double_64 ddatin; + int_32 maskck[nmaskc], ipacki[nmaskc]; + int_32 idebwd[nmawrd+1], ifinwd[nmawrd+1], jndlec[nmawrd]; + int_32 ivabeg, ivaend, ilogin, lequal, nobjet, ndatav, imodul, logprv, nembed, nmodul; + int_32 irecor, krecor=0; + +/* READ TOP OF OBJECT FILE */ + iretcd = kdiget_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9023; + strcpy(cparin, header.cparin); + strcpy(myreco, header.cdatin); + nrecor = header.nrecor; + ninput = header.ninput; + nstack = header.nstack; + idblst = header.idblst; + if (strcmp(cparin, cl2000) != 0) goto L9025; + if (idblst > 0) { + printf("%-120s LINE\n", cerror); + printf(" \n"); + } + ivabeg = ninput + nstack; + ivaend = ninput + nstack; + ilogin = 0; + lequal = 0; + nobjet = -1; + ndatav = -1; + imodul = 0; + logprv = 1; + nembed = 0; + nmodul = 0; + +/* *** MAIN LOOP OVER RECORDS (BEGIN) */ + for (irecor = 2; irecor <= ninput; ++irecor) { + int_32 iwords = 1; + int_32 nwords = 1; + int_32 jbiprv = 0; + +/* READ A NEW RECORD */ + iofset = (irecor - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record1.cparin); + strcpy(myreco, record1.myreco); + ilines = record1.ilines; + ilevel = record1.ilevel; + for (i = 0; i < nmaskc; i++) maskck[i] = record1.maskck[i]; + for (i = 0; i < nmaskc; i++) ipacki[i] = record1.ipacki[i]; + +/* RECORDS INSIDE CLE-2000, NOTHING TO DO */ + if (ilevel != 0) goto L100; + +/* RECORDS OUTSIDE CLE-2000, SCRUTINIZE... */ + +/* BEGIN: MASK RECOVERY */ + for (iloop1 = 1; iloop1 <= 120; ++iloop1) { + int_32 jbicur; + jloop2 = (iloop1 + 23) / 24; + jbicur = maskck[jloop2 - 1] % 2; + iwords += jbiprv * (1 - jbicur); + idebwd[nwords - 1] = iloop1; + ifinwd[iwords - 1] = iloop1; + nwords += jbicur * (1 - jbiprv); + jbiprv = jbicur; + maskck[jloop2 - 1] /= 2; + } + --nwords; +/* END: MASK RECOVERY */ + +/* BEGIN: UNPACK JNDLEC WITH TYPES (ITYP-1) */ + for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { + jloop2 = ((iloop1 << 1) + 23) / 24; + jndlec[iloop1 - 1] = ipacki[jloop2 - 1] % 4; + ipacki[jloop2 - 1] /= 4; + } +/* END: UNPACK JNDLEC WITH TYPES (ITYP-1) */ + +/* CHECK ALL DECLARATION STATEMENTS, IF NOT YET FOUND */ + if (logprv) { + krecor = irecor; + if (jndlec[0] == 2 && myreco[idebwd[0]-1] != '\'' && ifinwd[0]-idebwd[0] <= 11) { + strncpy(cparav, &myreco[idebwd[0]-1], ifinwd[0]-idebwd[0]+1); + cparav[ifinwd[0]-idebwd[0]+1] = '\0'; + for (iloop1 = 1; iloop1 <= ndclkw; ++iloop1) { + if (strcmp(cparav, cdclkw[iloop1-1]) == 0) ilogin = iloop1; + } + if (ilogin != 0) { + strcpy(cmodul, cdclkw[ilogin-1]); + imodul = -ilogin; + ++nmodul; + } + } + } + logprv = 0; + +/* SCAN OTHER WORDS */ + for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { + int_32 ileng = ifinwd[iloop1-1] - idebwd[iloop1-1] + 1; + +/* ARE WE IN THE DATA SECTION ? */ + if (ldatav) { + ++ndatav; +/* INSIDE THE DATA SECTION ( ... :: *HERE* ) */ +/* THEN COUNT EMBEDDED MODULES UNTIL MODULE ENDING */ + if (jndlec[iloop1-1] == 2 && myreco[idebwd[iloop1-1]-1] != '\'' + && ifinwd[iloop1-1]-idebwd[iloop1-1] <= 2) { + strncpy(cparav, &myreco[idebwd[iloop1-1]-1], ileng); + cparav[ileng] = '\0'; + if (strcmp(cparav, ":::") == 0) { + ++nembed; + } else if (strcmp(cparav, ";") == 0) { + if (iloop1 != nwords) goto L9010; + if (nembed == 0) { +/* END OF STATEMENT REACHED */ + logprv = 1; + } else { + --nembed; + } + } else if (strcmp(cparav, "::") == 0) { + goto L5002; + } + } + } else { + char clisto[17]; +/* OUTSIDE THE DATA SECTION ( *HERE* :: ... ) */ +/* NOTE: EVERY OBJECT/MODULE MUST BE FIRST DECLARED */ + if (jndlec[iloop1-1] != 2 || myreco[idebwd[iloop1-1]-1] == '\'' + || ifinwd[iloop1-1]-idebwd[iloop1 - 1] > 15) goto L5001; + strncpy(clisto, &myreco[idebwd[iloop1-1]-1], ileng); + clisto[ileng] = '\0'; + if (ifinwd[iloop1-1]-idebwd[iloop1-1] == 1 && strcmp(clisto, ":=") == 0) { + lequal = 1; + } else { +/* REMAININGS: 1 MODULE & OBJECTS ... */ + if (ifinwd[iloop1-1]-idebwd[iloop1-1] > 11) goto L5001; + strncpy(cparav, &myreco[idebwd[iloop1-1]-1], ileng); + cparav[ileng] = '\0'; + if (strcmp(cparav, ";") == 0) { + if (iloop1 != nwords) goto L9010; +/* END OF STATEMENT REACHED " "*/ + logprv = 1; + } else if (strcmp(cparav, "::") == 0) { + ldatav = 1; + } else if (strcmp(cparav, ":::") == 0) { + goto L5002; + } else { +/* USING *CPARAV* VARIABLE, SCAN ALL DECLARED OBJECTS */ + int_32 ilowrc = ivabeg; + int_32 ihigrc = ivaend + 1; +L41: + if (ihigrc - ilowrc <= 1) { + char cc[2]; +/* OBJECT/MODULE NOT FOUND */ + if (ilogin == 0) goto L5004; + ++ivaend; + +/* SHIFT GREATER VALUES */ + if (ihigrc != ivaend) { + for (jloop2 = ivaend - 1; jloop2 >= ihigrc; --jloop2) { + iofset = (jloop2 - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9003; + iofset = jloop2 * lrclen; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } + } + +/* CHECK IF OBJECT/MODULE NAME COMPLIES WITH THE RULES */ + strncpy(&cc[0], &cparav[0], 1); cc[1] = '\0'; + if (index_f(alphab, cc) == 0) { + printf("%s: CHARACTER *%s* IS NOT ALLOWED\n",nomsub, cc); + goto L5001; + } + for (jloop2 = 2; jloop2 <= strlen(cparav); ++jloop2) { + int_32 jin1, jin2, jin3, jin4, jin5; + strncpy(&cc[0], &cparav[jloop2-1], 1); cc[1] = '\0'; + jin1 = index_f(alphab, cc); + jin2 = index_f(digits, cc); + jin3 = index_f(cc, " "); + jin4 = index_f(cc, "."); + jin5 = index_f(cc, ":"); + if (jin1 + jin2 + jin3 + jin4 + jin5 == 0) { + printf("%s: CHARACTER *%1s* IN *%s* IS NOT ALLOWED\n",nomsub, cc, cparav); + goto L5001; + } + } + +/* CHECK IF OBJECT/MODULE NAME IS A KEYWORD */ + for (jloop2 = 1; jloop2 <= 40; ++jloop2) { + if (strcmp(cparav, ckeywd[jloop2-1]) == 0) { + printf("%s: OBJECT *%s* IS A CLE-2000 KEYWORD\n", nomsub, cparav); + goto L5001; + } + } + +/* VALID OBJECT/MODULE NAME, WRITE AT END */ + for (i = 0; i < 120; i++) cdatin[i] = ' '; + cdatin[120] = '\0'; + indlin = -ilogin; + idatin = 0; + adatin = 0.f; + ddatin = 0.; + idclin = ilines; + idefin = 0; + iusein = 0; + for (jloop2 = 0; jloop2 < ndclkw; ++jloop2) { +/* TO ACCEPT DECLARATIONS AS DEFINED MODULES */ + if (strcmp(cparav, cdclkw[jloop2]) == 0) indlin = 2; + } + +/* VALID OBJECT/MODULE NAME, WRITE AT *IHIGRC* */ + iofset = (ihigrc - 1) * lrclen; + strcpy(record2.cparin, cparav); + strcpy(record2.cdatin, cdatin); + record2.indlin = indlin; + record2.idatin = idatin; + record2.adatin = adatin; + record2.ddatin = ddatin; + record2.idclin = idclin; + record2.idefin = idefin; + record2.iusein = iusein; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + ++nobjet; + } else { + int_32 imedrc = (ihigrc + ilowrc) / 2; + iofset = (imedrc - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9003; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idatin = record2.idatin; + adatin = record2.adatin; + ddatin = record2.ddatin; + idclin = record2.idclin; + idefin = record2.idefin; + iusein = record2.iusein; + if (strcmp(cparin, cparav) == 0) { +/* OBJECT/MODULE FOUND */ + if (ilogin != 0) { +/* DECLARATION STATEMENT, VERIFY CONSISTENCY */ +/* IF IT IS THE DECLARATION MODULE NAME */ + if (strcmp(cparav, cdclkw[ilogin-1]) == 0) { + if (indlin != 2) goto L8000; + } else { + if (abs(indlin) != ilogin) goto L8000; + } + } else { + if (abs(indlin) == 1 || abs(indlin) == 2) { + +/* PROC/MODULE NAME IS FOUND */ + strcpy(cmodul, cparav); + imodul = abs(indlin); + ++nmodul; + lequal = 1; + } else { + if (lequal && iusein == 0) { +/* CHANGE FIRST USED LINE FOR OBJECT */ + record2.iusein = ilines; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } else if (!lequal && idefin == 0) { +/* CHANGE FIRST DEFINED LINE FOR OBJECT */ + record2.idefin = ilines; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9001; + } + } + ++nobjet; + } + } else if (strcmp(cparin, cparav) < 0) { + ilowrc = imedrc; + goto L41; + } else { + ihigrc = imedrc; + goto L41; + } + } + } + } + } + } +/* STATEMENT END WAS REACHED, */ +/* WRITE MODULE NAME IN 1ST RECORD OF THIS STATEMENT */ + if (logprv) { + char ctcall[9], ctciox[19], ctcobj[19], ctotcl[121]; + if (nmodul == 0) { +/* NO MODULE FOUND, IMPOSE */ +/* => CMODUL = 'IOX:' (WHEN NO OBJECTS) */ +/* => CMODUL = 'EQU:' (OTHERWISE) */ + if (nobjet == -1) { + strcpy(cmodul, "IOX:"); + } else { + strcpy(cmodul, "EQU:"); + } + nmodul = 1; + imodul = 2; + } else if (nmodul != 1) { + goto L5008; + } + + iofset = (krecor - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record1.cparin); + strcpy(myreco, record1.myreco); + ilines = record1.ilines; + ilevel = record1.ilevel; + for (i = 0; i < nmaskc; i++) maskck[i] = record1.maskck[i]; + for (i = 0; i < nmaskc; i++) ipacki[i] = record1.ipacki[i]; + +/* WITH MODULE NAME, ADD THE NUMBER OF DATA ITEMS (EXCEPT *;*) */ + strcpy(record1.cparin, cmodul); + record1.irecor = ndatav; + iretcd = kdiput_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9023; + if (idblst > 0) { + if (imodul > 0) { + strcpy(ctcall, "CALL"); + } else { + strcpy(ctcall, "DECLARE "); + strcpy(cmodul, " "); + } + if (nobjet == -1) { + strcpy(ctcobj, " WITHOUT OBJ ,"); + } else { + sprintf(ctcobj, " WITH %d OBJ VAL", (int)nobjet); + } + if (ndatav == -1) { + strcpy(ctciox, " WITHOUT I/O"); + } else { + sprintf(ctciox, " WITH %d I/O VAL", (int)nobjet); + } + sprintf(ctotcl, "%8s%12s%12s%18s%18s", ctcall,cdclkw[abs(imodul)-1],cmodul,ctcobj,ctciox); + fprintf(iwrite, "%-120s %7d\n", ctotcl, (int)ilines); + } + +/* RESET THINGS BEFORE NEXT MODULE... */ + nmodul = 0; + lequal = 0; + ldatav = 0; + nobjet = -1; + ndatav = -1; + imodul = 0; + ilogin = 0; + } + +L100: + ; + } +/* *** MAIN LOOP OVER RECORDS (END) */ +/* ALL VARIABLES ARE NOW SORTED AT THE END OF THE OBJECT FILE */ +/* REWRITE TOP OF OBJECT FILE TO UPDATE *NSTACK+/+NRECOR* */ + nobjet = ivaend - ivabeg; + nrecor = ivaend; + header.nrecor = nrecor; + header.nobjet = nobjet; + iretcd = kdiput_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9001; + if (idblst > 0) fprintf(iwrite, " \n"); + +L666: + return ret_val; + +L5000: + printf("%-120s LINE\n", cerror); + printf("%-120s %04d\n", myreco, (int)ilines); + goto L666; +L5001: + printf("! %s: INVALID OBJECT/MODULE NAME IN RECORD\n", nomsub); + ret_val = 5001; + goto L5000; +L5002: + printf("! %s: INVALID EMBEDDED MODULES, REVIEW SYNTAX\n", nomsub); + ret_val = 5002; + goto L5000; +L5004: + printf("! %s: OBJECT/MODULE NOT YET DECLARED *%s*\n", nomsub, cparav); + ret_val = 5004; + goto L5000; +L5008: + printf("! %s: MORE THAN 1 MODULE FOUND\n", nomsub); + ret_val = 5008; + goto L5000; +L8000: + printf("! %s: *%s* NOW WITH TYPE %s\n", nomsub, cparav, cdclkw[ilogin-1]); + ret_val = 8000; + goto L5000; +L9001: + iretcd = -1; + printf("! %s: WRITING RETURN CODE =%d\n", nomsub, (int)iretcd); + ret_val = iretcd; + goto L666; +L9003: + iretcd = -1; + printf("! %s: READING RETURN CODE =%d\n", nomsub, (int)iretcd); + ret_val = iretcd; + goto L666; +L9010: + printf("! %s: UNEXPECTED END OF STATEMENT\n", nomsub); + ret_val = 9010; + goto L5000; +L9023: + iretcd = -1; + printf("! %s: IOSTAT RETURN CODE =%d\n", nomsub, (int)iretcd); + printf("! %s: IMPOSSIBLE TO USE THIS *OBJECT* FILE\n", nomsub); + ret_val = -2; + goto L666; +L9025: + printf("! %s: IMPOSSIBLE TO USE OLD *OBJECT* FILE\n", nomsub); + ret_val = -3; + goto L666; +} /* objstk */ diff --git a/Ganlib/src/objxrf.c b/Ganlib/src/objxrf.c new file mode 100644 index 0000000..2052525 --- /dev/null +++ b/Ganlib/src/objxrf.c @@ -0,0 +1,300 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 11/05/09 */ +/*****************************************/ + +#include <stdlib.h> +#include <string.h> +#include "cle2000.h" +#include "header.h" +#define ndclkw 9 +#define ntotxr 7 +#define nmawrd 60 + +int_32 objxrf(kdi_file *iunito, FILE *iwrite) +{ + char *nomsub = "objxrf"; + static char cl2000[] = "CLE2000(V3)"; + static char ctitdb[] = "* GAN-2000 VERS 2.1 * DEBUG (WARNINGS AND ERRORS)"; + static char ctitxr[] = "* GAN-2000 VERS 2.1 * CROSS REFERENCE LISTING"; + static char *cdclkw[] = {"PROCEDURE", "MODULE", "LINKED_LIST", "XSM_FILE", "SEQ_BINARY", + "SEQ_ASCII", "DIR_ACCESS", "HDF5_FILE", "PARAMETER"}; + static char *ctypes[] = {"PR", "MD", "LL", "XF", "SB", "SA", "DA", "H5", "--"}; + +/* CLE-2000 SYSTEM: R.ROY (11/1999), VERSION 2.1 */ + +/* *OBJXRF* X-REF FOR OBJECTS ON THE D.A. UNIT *IUNITO* */ +/* OUTPUT IS WRITTEN ON UNIT *IWRITE* */ + +/* USE: DRESS UP A LIST OF OBJECTS AND LINES WHERE USED. */ +/* IN DEBUG MODE, ATTEMPT TO LIST POSSIBLE ERRORS. */ + +/* INPUT: *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */ +/* *IWRITE* IS THE OUTPUT UNIT */ + +/* NOTE: *OBJXRF* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */ + + int_32 ret_val = 0; + int_32 i, iretcd, ninput, nstack, ixrlst, idblst, nobjet, indlin, idclin, idefin, iusein, + iofset, ilines, ilevel; + char cparin[13], myreco[121], cdatin[121], cerror[13], cdefst[21], cusest[21], myparm[13]; + int_32 maskck[nmaskc], ipacki[nmaskc]; + int_32 idebwd[nmawrd+1], ifinwd[nmawrd+1], jndlec[nmawrd]; + int_32 lequal=0, istack, linxrf[ntotxr]; + char my_header[38]; + +/* READ TOP OF OBJECT FILE */ + iretcd = kdiget_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9023; + strcpy(cparin, header.cparin); + strcpy(myreco, header.cdatin); + ninput = header.ninput; + nstack = header.nstack; + ixrlst = header.ixrlst; + idblst = header.idblst; + nobjet = header.nobjet; + if (strcmp(cparin, cl2000) != 0) goto L9025; + +/* CASES WHERE THERE ARE NO OBJECTS/MODULE */ + if (nobjet == 0) goto L666; + +/* CASE WHERE DEBUG IS ACTIVE */ + if (idblst > 0) { + int_32 lfirst = 1; + int_32 irecor; + strcpy(cerror, " "); + strcpy(cdefst, " "); + strcpy(cusest, " "); + for (irecor = ninput + nstack + 1; irecor <= ninput + nstack + nobjet; ++irecor) { + iofset = (irecor - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idclin = record2.idclin; + idefin = record2.idefin; + iusein = record2.iusein; + if (abs(indlin) == 1 || abs(indlin) == 2 || abs(indlin) == 8) goto L60; + if (idefin == 0) { + strcpy(cdefst, "NOT DEFINED"); + if (iusein == 0) { + strcpy(cusest, "NOT USED"); + strcpy(cerror, "WARNING"); + } else { + strcpy(cusest, "BEFORE DEFINED"); + strcpy(cerror, "EXTERNAL"); + } + } else if (iusein == 0) { + strcpy(cusest, "NOT USED"); + strcpy(cerror, "WARNING"); + } else { + if (idclin > idefin) { + strcpy(cdefst, "BEFORE DECLARED"); + strcpy(cerror, "ERROR"); + ++ret_val; + } + if (idefin > iusein) { + strcpy(cusest, "BEFORE DEFINED"); + strcpy(cerror, "ERROR"); + ++ret_val; + } + } + if (lfirst && strcmp(cerror, " ") != 0) { + fprintf(iwrite, "\n"); + fprintf(iwrite, "%-72s\n", ctitdb); + fprintf(iwrite, " REPORT-----/OBJECT------/DEFINED-STATUS------/USED-STATUS---------\n"); + lfirst = 0; + } + if (strcmp(cerror, " ") != 0) { + fprintf(iwrite, "%-12s/%-12s/%-20s/%-20s\n", cerror, cparin, cdefst, cusest); + } +L60: + ; + } + if (!lfirst) { + if (ret_val > 0) { + fprintf(iwrite, " REPORT-----> NB. OF ERRORS=%7d\n", (int)ret_val); + fprintf(iwrite, " REPORT-----> MAY STILL EXECUTE WELL...\n"); + } + fprintf(iwrite, " \n"); + } + } + +/* CASE WHERE NO XREF WAS ASKED */ + if (ixrlst <= 0) goto L666; + fprintf(iwrite, "%-72s\n", ctitxr); + fprintf(iwrite, " \n"); + fprintf(iwrite, " OBJECT TYPE LIN_DCL **** FOUND IN LINES (- MEANS NEW EVALUATION) ****\n"); + fprintf(iwrite, " \n"); + +/* *** MAIN LOOP OVER VARIABLES (BEGIN) */ + for (istack = ninput + nstack + 1; istack <= ninput + nstack + nobjet; ++istack) { + int_32 ilogin = 0; + int_32 jlines = 0; + int_32 iuseln = 0; + int_32 idefln = 0; + int_32 nxreft = 0; + int_32 irecor; + + iofset = (istack - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + strcpy(myparm, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idclin = record2.idclin; + idefin = record2.idefin; + iusein = record2.iusein; + +/* IF WE DO NOT WANT TO SEE PROCEDURES */ +/* IF( ABS(INDLIN).EQ.1 ) GO TO 200 */ +/* IF WE DO NOT WANT TO SEE MODULES */ + if (abs(indlin) == 2) goto L200; + +/* PREPARE HEADER FOR VARIABLE *MYPARM* */ + sprintf(my_header, " %-4d %-12s %-2s %04d_", (int)istack, myparm, ctypes[abs(indlin)-1], (int)idclin); + +/* *** MAIN LOOP OVER RECORDS (BEGIN) */ + for (irecor = 2; irecor <= ninput; ++irecor) { + int_32 iloop1, jloop2; + char cparav[13]; + +/* READ A NEW RECORD */ + iofset = (irecor - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record1.cparin); + strcpy(myreco, record1.myreco); + ilines = record1.ilines; + ilevel = record1.ilevel; + for (i = 0; i < nmaskc; i++) maskck[i] = record1.maskck[i]; + for (i = 0; i < nmaskc; i++) ipacki[i] = record1.ipacki[i]; + +/* RECORDS OUTSIDE CLE-2000 */ + if (ilevel == 0) { + int_32 iwords = 1; + int_32 nwords = 1; + int_32 jbiprv = 0; + +/* SKIP OBJECT/MODULE DECLARATIONS */ + if (strcmp(cparin, " ") != 0) { + ilogin = 0; + for (iloop1 = 1; iloop1 <= ndclkw; ++iloop1) { + if (strcmp(cparin, cdclkw[iloop1-1]) == 0) ilogin = iloop1; + } + lequal = 0; + } + if (ilogin != 0) goto L100; + +/* HERE, WE HAVE FOUND A SENTENCE INCLUDING A STACK... */ + +/* BEGIN: MASK RECOVERY */ + for (iloop1 = 1; iloop1 <= 72; ++iloop1) { + int_32 jbicur; + jloop2 = (iloop1 + 23) / 24; + jbicur = maskck[jloop2-1] % 2; + iwords += jbiprv * (1 - jbicur); + idebwd[nwords-1] = iloop1; + ifinwd[iwords-1] = iloop1; + nwords += jbicur * (1 - jbiprv); + jbiprv = jbicur; + maskck[jloop2 - 1] /= 2; + } + --nwords; +/* END: MASK RECOVERY */ + +/* BEGIN: UNPACK JNDLEC WITH TYPES (ITYP-1) */ + for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { + jloop2 = ((iloop1 << 1) + 23) / 24; + jndlec[iloop1-1] = ipacki[jloop2-1] % 4; + ipacki[jloop2-1] /= 4; + } +/* END: UNPACK JNDLEC WITH TYPES (ITYP-1) */ + + for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { + if (jndlec[iloop1-1] == 2 && myreco[idebwd[iloop1-1]-1] != '\'' + && ifinwd[iloop1-1] - idebwd[iloop1-1] <= 11) { + strncpy(cparav, &myreco[idebwd[iloop1-1]-1], ifinwd[iloop1-1]-idebwd[iloop1-1]+1); + cparav[ifinwd[iloop1-1]-idebwd[iloop1-1]+1] = '\0'; + if (strcmp(cparav, ";") == 0 || strcmp(cparav, "::") == 0) { + if (!lequal && idefln != 0) iuseln = idefln; + +/* RESET *ILOGIN* AND LEFT/RIGHT NUMBERS */ + ilogin = -10; + idefln = 0; + goto L55; + } else if (lequal) { + if (strcmp(cparav, myparm) == 0) { +/* USING THIS VARIABLE */ + if (iuseln == 0) iuseln = ilines; + } + } else { + if (strcmp(cparav, ":=") == 0) { + lequal = 1; +/* *:=* SIGN IMPLIES REDEFINITION */ + if (idefln != 0) iuseln = -idefln; + idefln = 0; + } else { +/* KEEP THE DEFINITION LINE UNTIL *:=* OR END */ + if (strcmp(cparav, myparm) == 0) idefln = ilines; + } + } + } + } +L55: + ; + } + +/* HAVE WE FOUND A NEW XREF LINE ? */ + if (iuseln != 0 && iuseln != jlines) { + if (nxreft == ntotxr) { + char xline[81]; + sprintf(&xline[0], "%-24s", my_header); + for (i = 0; i < ntotxr; i++) sprintf(&xline[24 + 8*i], " %04d", (int)linxrf[i]); + fprintf(iwrite, "%-80s\n", xline); + strcpy(my_header, " "); + nxreft = 0; + } + ++nxreft; + linxrf[nxreft-1] = iuseln; + jlines = iuseln; + } + iuseln = 0; + +L100: + ; + } +/* *** MAIN LOOP OVER RECORDS (END) */ + +/* POSSIBLE INCOMPLETE LAST LINE... */ + if (nxreft != 0) { + char xline[81]; + sprintf(&xline[0], "%-24s", my_header); + for (i = 0; i < nxreft; i++) sprintf(&xline[24 + 8*i], " %04d", (int)linxrf[i]); + fprintf(iwrite, "%-80s\n", xline); + } else if (strcmp(my_header, " ") != 0) { + fprintf(iwrite, "%-24s <= WARNING: NEVER DEFINED, NEVER USED... POSSIBLE ERROR\n", my_header); + } +L200: + ; + } +/* *** MAIN LOOP OVER VARIABLES (END) */ + + fprintf(iwrite, " \n"); +L666: + return ret_val; + +L9023: + iretcd = -1; + printf("! %s: IOSTAT RETURN CODE =%d\n", nomsub,(int)iretcd); + printf("! %s: IMPOSSIBLE TO USE THIS *OBJECT* FILE\n", nomsub); + ret_val = -2; + goto L666; +L9025: + printf("! %s: IMPOSSIBLE TO USE OLD *OBJECT* FILE\n", nomsub); + ret_val = -3; + goto L666; +} /* objxrf */ diff --git a/Ganlib/src/redget_c.c b/Ganlib/src/redget_c.c new file mode 100644 index 0000000..2368ec2 --- /dev/null +++ b/Ganlib/src/redget_c.c @@ -0,0 +1,1199 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 24/04/09 */ +/*****************************************/ + +#include <stdlib.h> +#include <string.h> +#include <math.h> +#include "cle2000.h" +#include "header.h" +#define sign(A) (A > 0 ? 1 : (A < 0 ? -1 : 0)) +#define index_f(A, B) (strstr(A, B) == NULL ? 0 : strstr(A, B) - A + 1) +#define nlogkw 15 +#define ndimst 128 +#define ifinal 122 +#define nmawrd 60 + +static kdi_file *iunito = NULL; +static int_32 ivabeg = 0; +static int_32 ivaend = 0; +static int_32 ioulst = 0; +static int_32 ilogin = 0; +static FILE *iwrite = NULL; +static char hwrite[73] = " "; +static int_32 idblst = 0; +static int_32 irecor = 0; +static int_32 ninput = 0; +static int_32 nwords = 0; +static int_32 iwords = 0; +static int_32 nstput = 0; +static int_32 nstlvl = 0; +static int_32 indrgt[ndimst], irclvl[ndimst], irclft[ndimst], ircput[ndimst]; +static int_32 idebwd[nmawrd+1], ifinwd[nmawrd+1], jndlec[nmawrd]; +static char myreco[121]; +static char cl2000[12] = "CLE2000(V3)"; +static int_32 text_len = 72; /* CAUTION: text must be declared as text[73] in the calling function*/ + +static int_32 intstk[ndimst]; +static float_32 relstk[ndimst]; +static char chrstk[ndimst][121]; +static double_64 dblstk[ndimst]; +static int_32 logstk[ndimst]; + +void redget_c(int_32 *ityp, int_32 *nitma, float_32 *flott, char text[73], double_64 *dflot) +{ + static char *clogbg[] = {"INTEGER", "REAL", "STRING", "DOUBLE", "LOGICAL", "EVALUATE", + "ECHO", "ELSEIF", "IF", "WHILE", "UNTIL", "ENDWHILE", "REPEAT", + "ELSE", "ENDIF"}; + static char *clognd[] = {";", ";", ";", ";", ";", ";", ";", "THEN", "THEN", "DO", + ";", ";", "REPEAT", "ELSE", ";"}; + int_32 i, ilines, jlines=0, jlevel=0, jrecor, iretcd, iloop1, lrgtst=0, nstlft=0, imedrc, + iofset, idefkw=0, nstrgt=0; + int_32 maskck[nmaskc], ipacki[nmaskc]; + char cparin[17], cparav[13], chrend[13], cdatav[121], cdatin[121]; + int_32 ilengv, indlec, idatin, indlin; + float_32 adatin; + double_64 ddatin; + char *nomsub="redget_c"; + +/* TAKE ANY LEVEL AS INPUT */ + int_32 ilevel = -1; +/* L01> ***LOOP*** OVER WORDS (BEGIN) */ +L10: + ++iwords; + if (iwords > nwords) { + int_32 jbiprv; +/* L02> ***LOOP*** OVER RECORDS (BEGIN) */ +L20: + ++irecor; + if (irecor > ninput) { + if (ninput == 0) { +/* REDGET IS CLOSED */ + *ityp = 10; + if (idblst > 0 && iwrite != NULL) { + sprintf(myreco,"READER IS CLOSED ON FILE"); + fprintf(iwrite,".|%-120s|.\n",myreco); + } + } else { + int_32 i; + *ityp = 9; + if (idblst > 0 && iwrite != NULL) { + sprintf(myreco,"QUIT \"DEBUG\" "); + fprintf(iwrite,".|%-120s|.\n",myreco); + } + for ( i = 0; i < 120; i++) myreco[i]='-'; + myreco[120]='\0'; fprintf(iwrite,". %s .\n",myreco); + } + return; + } +/* READ A NEW RECORD */ + iofset = (irecor-1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L8000; + strcpy(cparin, record1.cparin); + strcpy(myreco, record1.myreco); + ilines = record1.ilines; + jlevel = record1.ilevel; + jrecor = record1.irecor; + for (i = 0; i < nmaskc; i++) maskck[i] = record1.maskck[i]; + for (i = 0; i < nmaskc; i++) ipacki[i] = record1.ipacki[i]; + if (ilevel >= 0 && jlevel != ilevel) goto L20; + +/* L02> ***LOOP*** OVER RECORDS (ACCEPTED) */ + +/* RECORD IS ACCEPTED, PRINT WHEN REQUESTED */ + if (idblst <= 0 && jlevel == 0) { + if (ioulst > 0 && iwrite != NULL) fprintf(iwrite,"<|%-120s|<%04d\n",myreco,(int)ilines); + } else if (idblst > 0 && iwrite != NULL) { + if (jlevel == 0) { + fprintf(iwrite,"<|%-120s|<%04d\n",myreco,(int)ilines); + } else { + fprintf(iwrite,".|%-120s|.%04d\n",myreco,(int)ilines); + } + } + +/* BEGIN: MASK RECOVERY */ + jbiprv = 0; + iwords=1; + nwords = 1; + for (iloop1=0; iloop1<120; ++iloop1) { + int_32 jloop2 = iloop1/24; + int_32 jbicur = maskck[jloop2] % 2; + iwords += jbiprv * (1-jbicur); + idebwd[nwords-1] = iloop1; + ifinwd[iwords-1] = iloop1; + nwords += jbicur * (1-jbiprv); + jbiprv = jbicur; + maskck[jloop2] /= 2; + } + --nwords; +/* END: MASK RECOVERY */ + +/* THIS IS NOW THE FIRST WORD */ + iwords = 1; + if (jlevel != 0) { +/* L03> THIS IS A NEW *CLE-2000* RECORD (BEGIN) */ + if (strcmp(cparin, " ") != 0) { + +/* L04> TREAT SIGNIFICANT 1ST-WORD OF CLE-2000 STATEMENT (BEGIN) */ + nstlft = 0; + nstrgt = 0; + for (iloop1 = 0; iloop1 < nlogkw; ++iloop1) { + if (strcmp(clogbg[iloop1], cparin) == 0) ilogin = iloop1+1; + } + lrgtst = ilogin >= 7 && ilogin <= 11; + strcpy(chrend, clognd[ilogin-1]); + +/* KEYWORDS: *IF+/+WHILE+/+UNTIL* */ + if (ilogin == 9 || ilogin == 10 || ilogin == 11) { + ++nstlvl; + if (nstlvl > ndimst) goto L9002; + irclvl[nstlvl - 1] = jrecor - 1; + +/* KEYWORDS: *ELSEIF+/+ELSE* */ + } else if (ilogin == 8 || ilogin == 14) { + if (ilevel == -1) { + if (nstlvl == 0) goto L9001; + irecor = irclvl[nstlvl-1]; + nwords = 1; + } else { + ilevel = -1; + } + +/* KEYWORD: *ENDWHILE* */ + } else if (ilogin == 12) { + if (ilevel == -1) { + irecor = jrecor - 1; + nwords = 1; + } else { + ilevel = -1; + } + +/* KEYWORD: *ENDIF* */ + } else if (ilogin == 15) { + ilevel = -1; + if (nstlvl == 0) goto L9001; + --nstlvl; + +/* KEYWORD: *ECHO* */ + } else if (ilogin == 7) { + jlines = ilines; + } + +/* CYCLE ON WORDS WITHOUT UNPACKING (ONE WORD ONLY) */ + if (nwords == iwords) goto L10; + for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { +/* L05> UNPACK INDLEC ONLY IF MORE THAN 1 WORD (BEGIN) */ + int_32 jloop2 = ((iloop1 << 1) + 23) / 24; + jndlec[iloop1-1] = ipacki[jloop2-1] % 4 + 1; + ipacki[jloop2-1] /= 4; +/* L05> UNPACK INDLEC ONLY IF MORE THAN 1 WORD (END) */ + } + +/* L04> TREAT SIGNIFICANT 1ST-WORD OF CLE-2000 STATEMENTS (END) */ +/* RETURN TO NEXT WORD */ + goto L10; + } +/* L03> THIS IS A NEW *CLE-2000* RECORD (END) */ + + } else { +/* L03> RECORD OUTSIDE *CLE-2000* (BEGIN) */ + ilogin = 0; +/* L03> RECORD OUTSIDE *CLE-2000* (END) */ + } + for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { +/* L03> RECORD OUTSIDE *CLE-2000* OR NEW *CLE-2000* RECORD, */ +/* BUT CONTINUATION STATEMENT (BEGIN) THEN, ALWAYS UNPACK INDLEC */ + int_32 jloop2 = ((iloop1 << 1) + 23) / 24; + jndlec[iloop1-1] = ipacki[jloop2-1] % 4 + 1; + ipacki[jloop2-1] /= 4; +/* L03> RECORD OUTSIDE *CLE-2000* OR NEW *CLE-2000* RECORD, */ +/* BUT CONTINUATION STATEMENT (END) */ + } +/* L02> ***LOOP*** OVER RECORDS (END) */ + } +/* L01> ***LOOP*** OVER WORDS (ACCEPTED) */ + +/* DETERMINE NEXT WORD */ + ilengv = ifinwd[iwords-1] - idebwd[iwords-1] + 1; + indlec = jndlec[iwords-1]; + + if (indlec == 3) { + for ( i = 0; i < ilengv; i++) cdatav[i]=myreco[idebwd[iwords-1]+i]; + cdatav[ilengv] = '\0'; + } else if (indlec == 1) { + for ( i = 0; i < ilengv; i++) cdatin[i]=myreco[idebwd[iwords-1]+i]; + cdatin[ilengv] = '\0'; + sscanf(cdatin, "%d", (int *)&idatin); + } else if (indlec == 2) { + for ( i = 0; i < ilengv; i++) cdatin[i]=myreco[idebwd[iwords-1]+i]; + cdatin[ilengv] = '\0'; + sscanf(cdatin, "%e", &adatin); + } else { + int_32 id; + for ( i = 0; i < ilengv; i++) cdatin[i]=myreco[idebwd[iwords-1]+i]; + cdatin[ilengv] = '\0'; + id = index_f(cdatin, "D"); + if (id > 0) cdatin[id-1] = 'E'; + sscanf(cdatin, "%le", &ddatin); + } + if (ilogin == 0) { + +/* L02> WORDS OUTSIDE *CLE2000* STATEMENTS: HIT AND RUN... */ + if (indlec == 3) { + +/* L03> STRING, <<.>> OR >>.<< TREATMENT */ + int_32 lrdput = strncmp(cdatav, ">>", 2) == 0; + if (strncmp(cdatav, "<<", 2) == 0 || lrdput) { + int_32 ilowrc = ivabeg; + int_32 ihigrc = ivaend; + +/* L04> CASES <<.>> OR >>.<< */ +/* GET VARIABLE WITH A BINARY SEARCH IN SORTED FILE */ +/* SET UPPER AND LOWER BOUNDS */ + strcpy(cparin, &cdatav[2]); + memcpy(cparav, cparin, ilengv-4); cparav[ilengv-4] = '\0'; +L11: + imedrc = (ihigrc+ilowrc) / 2; + iofset = (imedrc-1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idatin = record2.idatin; + adatin = record2.adatin; + ddatin = record2.ddatin; + if (iretcd != 0) goto L9023; + if (strcmp(cparin, cparav) == 0) { + if (lrdput) { + int_32 ilengt = min(text_len, 12); +/* KEEP RECORD NUMBER FOR *REDPUT* */ + ++nstput; + if (nstput > ndimst) goto L9004; + ircput[nstput-1] = imedrc; +/* MAKE THE VARIABLE UNDEFINED */ + indlin = -abs(indlin); + record2.indlin = indlin; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; +/* SEND BACK NEGATIVE TYPE AND VARIABLE NAME TO THE APPLICATION */ + *ityp = indlin; + memcpy(text, cparin, ilengt); text[ilengt]='\0'; + } else { + if (indlin <= 0) goto L9008; +/* SEND BACK TYPE AND DEFINED VALUES */ + *ityp = indlin; + if (*ityp == 1 || *ityp == 5) { + *nitma = idatin; + } else if (*ityp == 2) { + *flott = adatin; + } else if (*ityp == 3) { + int_32 ilengt = min(text_len, 120); + *nitma = min(idatin,ilengt); + memcpy(text, cdatin, ilengt); text[ilengt]='\0'; + } else if (*ityp == 4) { + *dflot = ddatin; + } + } + } else if (strcmp(cparin, cparav) < 0) { + ilowrc = imedrc; + goto L11; + } else { + ihigrc = imedrc; + goto L11; + } + } else if (cdatav[0] == '\'') { + int_32 ilengt = min(text_len, 120); + if (ilengv > 2) { + memcpy(cdatin, &cdatav[1], ilengv-2); cdatin[ilengv-2]='\0'; + } + *ityp = 3; + *nitma = min(ilengv-2, ilengt); + memcpy(text, cdatin, ilengt); text[ilengt] = '\0'; + } else { + int_32 ilengt = min(text_len, 120); + *ityp = 3; + *nitma = min(ilengv,ilengt); + memcpy(text, cdatav, ilengt); text[ilengt] = '\0'; + } + } else { +/* L03> OTHER THAN STRING TREATMENT */ + *ityp = indlec; + if (*ityp == 1 || *ityp == 5) { + *nitma = idatin; + } else if (*ityp == 2) { + *flott = adatin; + } else if (*ityp == 4) { + *dflot = ddatin; + } + } + return; + +/* L02> WORDS OUTSIDE *CLE2000* STATEMENTS: END. */ + + } else { + +/* L02> PROCESS *CLE2000* STATEMENTS: DRINK, DRIVE (BEGIN) */ +/* WATCH FOR STRINGS... */ + +/* L03> IF( INDLEC.EQ.3.AND.CDATAV(1:1).EQ.'"' )THEN */ + if (indlec == 3 && cdatav[0] == '"') { + ++nstrgt; + indrgt[nstrgt-1] = indlec; + if (ilengv > 2) { + memcpy(chrstk[nstrgt-1], &cdatav[1], ilengv-2); chrstk[nstrgt-1][ilengv-2] = '\0'; + } + intstk[nstrgt-1] = ilengv-2; + +/* L03> ELSEIF( LRGTST )THEN */ + } else if (lrgtst) { + +/* L04> IF( INDLEC.EQ.3 )THEN */ + if (indlec == 3) { + memcpy(cparav, cdatav, 12); cparav[12] = '\0'; + +/* L05> IF( CPARAV.EQ.CHREND )THEN */ + if (strcmp(cparav, chrend) == 0) { + +/* TRUEWAY LEFT/RIGHT */ +/* KEYWORDS: *int_32+/+REAL+/+STRING+/+DOUBLE+/+LOGICAL+/+EVALUATE* */ + if (ilogin <= 6) { +/* PUT VARIABLE VALUES */ +L25: + indlin = indrgt[nstlft-1]; + imedrc = irclft[nstlft-1]; + iofset = (imedrc-1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + strcpy(cdatin, record2.cdatin); + idatin = record2.idatin; + adatin = record2.adatin; + ddatin = record2.ddatin; + if (indlin == 1) { + idatin = intstk[nstlft-1]; + } else if (indlin == 2) { + adatin = relstk[nstlft-1]; + } else if (indlin == 3) { + strcpy(cdatin, chrstk[nstlft-1]); + idatin = intstk[nstlft-1]; + } else if (indlin == 4) { + ddatin = dblstk[nstlft-1]; + } else if (indlin == 5) { + if (logstk[nstlft - 1]) { + idatin = 1; + } else { + idatin = -1; + } + } + strcpy(record2.cdatin, cdatin); + record2.indlin = indlin; + record2.idatin = idatin; + record2.adatin = adatin; + record2.ddatin = ddatin; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + --nstlft; + if (nstlft != 0) goto L25; + +/* KEYWORD: *ECHO* (PRINTER UTILITY ) */ + } else if (ilogin == 7) { + char cprint[129]; + int_32 ilgtpr=0, idepar=3; + + sprintf(cprint, ">|%-120s|>%04d", " ", (int)jlines); + for (iloop1 = 0; iloop1 < nstrgt; ++iloop1) { + indlin = indrgt[iloop1]; + if (indlin == 1) { + int_32 jloop2, indle2 = abs(intstk[iloop1]); + for (jloop2 = 1; jloop2 <= 12; ++jloop2) { + indle2 /= 10; + if (indle2 == 0) { + ilgtpr = jloop2; + goto L302; + } + } +L302: + if (intstk[iloop1] < 0) ++ilgtpr; + sprintf(cdatin, "%d", (int)intstk[iloop1]); + } else if (indlin == 2) { + ilgtpr = 13; + sprintf(cdatin, "%13.6e", relstk[iloop1]); + } else if (indlin == 3) { + ilgtpr = intstk[iloop1]; + strcpy(cdatin, chrstk[iloop1]); + } else if (indlin == 4) { + ilgtpr = 23; + sprintf(cdatin, "%23.15E", dblstk[iloop1]); + } else if (indlin == 5) { + if (logstk[iloop1]) { + ilgtpr = 6; + const char *src = ".TRUE."; + memcpy(cdatin, src, 6); cdatin[6] = '\0'; + } else { + ilgtpr = 7; + const char *src = ".FALSE."; + memcpy(cdatin, src, 7); cdatin[7] = '\0'; + } + } else if (indlin == -1) { + ilgtpr = 3; + const char *src = "?_I"; + memcpy(cdatin, src, 3); cdatin[3] = '\0'; + } else if (indlin == -2) { + ilgtpr = 3; + const char *src = "?_R"; + memcpy(cdatin, src, 3); cdatin[3] = '\0'; + } else if (indlin == -3) { + ilgtpr = 3; + const char *src = "?_S"; + memcpy(cdatin, src, 3); cdatin[3] = '\0'; + } else if (indlin == -4) { + ilgtpr = 3; + const char *src = "?_D"; + memcpy(cdatin, src, 3); cdatin[3] = '\0'; + } else if (indlin == -5) { + ilgtpr = 3; + const char *src = "?_L"; + memcpy(cdatin, src, 3); cdatin[3] = '\0'; + } else { + goto L9007; + } + if (idepar + ilgtpr >= ifinal) { + if (iwrite != NULL) fprintf(iwrite,"%s\n",cprint); + sprintf(cprint, ">|%-120s|>%04d", " ", (int)jlines); + idepar = 3; + } + memcpy(&cprint[idepar-1], cdatin, ilgtpr); cprint[120+8] = '\0'; + idepar = idepar + ilgtpr + 1; + if (idepar >= ifinal) { + if (iwrite != NULL) fprintf(iwrite,"%s\n",cprint); + sprintf(cprint, ">|%-120s|>%04d", " ", (int)jlines); + idepar = 3; + } + } + if (iwrite != NULL && idepar != 3) fprintf(iwrite,"%s\n",cprint); + fflush(iwrite); + +/* KEYWORDS: *ELSEIF+/+IF* */ + } else if (ilogin == 8 || ilogin == 9) { + if (indrgt[nstrgt-1] != 5) goto L9006; + if (logstk[nstrgt-1]) { + ilevel = -1; + } else { + ilevel = jlevel; + } + +/* KEYWORD: *UNTIL* */ + } else if (ilogin == 11) { + if (nstlvl == 0) goto L9001; + if (indrgt[nstrgt-1] != 5) goto L9006; + if (!logstk[nstrgt-1]) { + irecor = irclvl[nstlvl-1]; + iwords = nwords; + } + --nstlvl; + +/* KEYWORD: *WHILE* */ + } else if (ilogin == 10) { + if (nstlvl == 0) goto L9001; + if (indrgt[nstrgt-1] != 5) goto L9006; + if (!logstk[nstrgt-1]) { + ilevel = jlevel; + irecor = irclvl[nstlvl-1]; + iwords = nwords; + } + --nstlvl; + } + } else { +/* CHECK CONVERSION OPERATIONS */ + if (strcmp(cparav, "R_TO_I") == 0) { + indrgt[nstrgt-1] = sign(indrgt[nstrgt-1]); + intstk[nstrgt-1] = (int_32) relstk[nstrgt-1]; + } else if (strcmp(cparav, "D_TO_I") == 0) { + indrgt[nstrgt-1] = sign(indrgt[nstrgt-1]); + intstk[nstrgt-1] = (int_32) dblstk[nstrgt-1]; + } else if (strcmp(cparav, "I_TO_R") == 0) { + indrgt[nstrgt-1] = 2 * sign(indrgt[nstrgt-1]); + relstk[nstrgt-1] = (float_32) intstk[nstrgt-1]; + } else if (strcmp(cparav, "D_TO_R") == 0) { + indrgt[nstrgt-1] = 2 * sign(indrgt[nstrgt-1]); + relstk[nstrgt-1] = (float_32) dblstk[nstrgt-1]; + } else if (strcmp(cparav, "I_TO_D") == 0) { + indrgt[nstrgt-1] = 4 * sign(indrgt[nstrgt-1]); + dblstk[nstrgt-1] = (double_64) intstk[nstrgt-1]; + } else if (strcmp(cparav, "R_TO_D") == 0) { + indrgt[nstrgt-1] = 4 * sign(indrgt[nstrgt-1]); + dblstk[nstrgt-1] = (double_64) relstk[nstrgt-1]; + } else if (strcmp(cparav, "I_TO_S") == 0) { + indrgt[nstrgt-1] = 3 * sign(indrgt[nstrgt-1]); + if (intstk[nstrgt-1] > 99999999) goto L9013; + if (intstk[nstrgt-1] < -9999999) goto L9014; + sprintf(chrstk[nstrgt-1], "%d", (int)intstk[nstrgt-1]); + intstk[nstrgt-1] = (int)strlen(chrstk[nstrgt-1]); + } else if (strcmp(cparav, "I_TO_S4") == 0) { + indrgt[nstrgt-1] = 3 * sign(indrgt[nstrgt-1]); + if (intstk[nstrgt-1] > 99999999) goto L9013; + if (intstk[nstrgt-1] < -9999999) goto L9014; + sprintf(chrstk[nstrgt-1], "%04d", (int)intstk[nstrgt-1]); + intstk[nstrgt-1] = (int)strlen(chrstk[nstrgt-1]); +/* CHECK UNARY OPERATIONS */ + } else if (strcmp(cparav, "NOT") == 0) { + logstk[nstrgt-1] = !logstk[nstrgt-1]; + } else if (strcmp(cparav, "CHS") == 0) { + if (indrgt[nstrgt-1] == 1) { + intstk[nstrgt-1] = -intstk[nstrgt-1]; + } else if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = -relstk[nstrgt-1]; + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = -dblstk[nstrgt-1]; + } + } else if (strcmp(cparav, "ABS") == 0) { + if (indrgt[nstrgt-1] == 1 && intstk[nstrgt-1] < 0) { + intstk[nstrgt-1] = -intstk[nstrgt-1]; + } else if (indrgt[nstrgt-1] == 2 && relstk[nstrgt-1] < 0.f) { + relstk[nstrgt-1] = -relstk[nstrgt-1]; + } else if (indrgt[nstrgt-1] == 4 && dblstk[nstrgt-1] < 0.) { + dblstk[nstrgt-1] = -dblstk[nstrgt-1]; + } + } else if (strcmp(cparav, "EXP") == 0) { + if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = exp(relstk[nstrgt-1]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = exp(dblstk[nstrgt-1]); + } + } else if (strcmp(cparav, "LN") == 0) { + if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = log(relstk[nstrgt-1]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = log(dblstk[nstrgt-1]); + } + } else if (strcmp(cparav, "SIN") == 0) { + if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = sin(relstk[nstrgt-1]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = sin(dblstk[nstrgt-1]); + } + } else if (strcmp(cparav, "COS") == 0) { + if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = cos(relstk[nstrgt-1]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = cos(dblstk[nstrgt-1]); + } + } else if (strcmp(cparav, "TAN") == 0) { + if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = tan(relstk[nstrgt-1]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = tan(dblstk[nstrgt-1]); + } + } else if (strcmp(cparav, "ARCSIN") == 0) { + if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = asin(relstk[nstrgt-1]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = asin(dblstk[nstrgt-1]); + } + } else if (strcmp(cparav, "ARCCOS") == 0) { + if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = acos(relstk[nstrgt-1]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = acos(dblstk[nstrgt-1]); + } + } else if (strcmp(cparav, "ARCTAN") == 0) { + if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = atan(relstk[nstrgt-1]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = atan(dblstk[nstrgt-1]); + } + } else if (strcmp(cparav, "SQRT") == 0) { + if (indrgt[nstrgt-1] == 2) { + if (relstk[nstrgt-1] < 0.f) { + idefkw = 2; + goto L9009; + } + relstk[nstrgt-1] = sqrt(relstk[nstrgt-1]); + } else if (indrgt[nstrgt-1] == 4) { + if (dblstk[nstrgt-1] < 0.) { + idefkw = 4; + goto L9009; + } + dblstk[nstrgt-1] = sqrt(dblstk[nstrgt-1]); + } + +/* CHECK BINARY OPERATIONS */ + } else if (strcmp(cparav, "_MIN_") == 0) { + --nstrgt; + indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); + if (indrgt[nstrgt-1] == 1) { + intstk[nstrgt-1] = min(intstk[nstrgt-1], intstk[nstrgt]); + } else if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = min(relstk[nstrgt-1], relstk[nstrgt]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = min(dblstk[nstrgt-1], dblstk[nstrgt]); + } + } else if (strcmp(cparav, "_MAX_") == 0) { + --nstrgt; + indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); + if (indrgt[nstrgt-1] == 1) { + intstk[nstrgt-1] = max(intstk[nstrgt-1], intstk[nstrgt]); + } else if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] = max(relstk[nstrgt-1], relstk[nstrgt]); + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] = max(dblstk[nstrgt-1], dblstk[nstrgt]); + } + } else if (strcmp(cparav, "_TRIM_") == 0) { + --nstrgt; + int_32 ndig = intstk[nstrgt]; + if (indrgt[nstrgt-1] == 2) { + int_32 nx = (int_32)floor(log10(relstk[nstrgt-1]))-ndig; + float_32 rrr = relstk[nstrgt-1]*pow(10.0,(float_32)(-nx)); + relstk[nstrgt-1] = floor(rrr)*pow(10.0,(float_32)(nx)); + } else if (indrgt[nstrgt-1] == 4) { + int_32 nx = (int_32)floor(log10(dblstk[nstrgt-1]))-ndig; + double_64 ddd = dblstk[nstrgt-1]*pow(10.0,(double_64)(-nx)); + dblstk[nstrgt-1] = floor(ddd)*pow(10.0,(double_64)(nx)); + } + } else if (strcmp(cparav, "+") == 0) { + --nstrgt; + indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); + if (indrgt[nstrgt-1] == 1) { + intstk[nstrgt-1] += intstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] += relstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 3) { + char cdata1[73], cdata2[73]; + int_32 ileng2 = intstk[nstrgt-1]; + int_32 ileng1 = intstk[nstrgt]; + strcpy(cdata2, chrstk[nstrgt-1]); + strcpy(cdata1, chrstk[nstrgt]); + if (ileng1 == 0) { + if (ileng2 == 0) { + strcpy(chrstk[nstrgt-1], " "); + } else { + strcpy(chrstk[nstrgt-1], cdata2); + } + } else if (ileng2 == 0) { + strcpy(chrstk[nstrgt-1], cdata1); + } else if (ileng1 + ileng2 <= 72) { + strcpy(chrstk[nstrgt-1], cdata2); + strcat(chrstk[nstrgt-1], cdata1); + } else { + printf("%s: STRING IS LONGER THAN 72 CHRS", nomsub); + goto L9012; + } + intstk[nstrgt-1] = ileng1 + ileng2; + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] += dblstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 5) { + logstk[nstrgt-1] = logstk[nstrgt-1] || logstk[nstrgt]; + } + } else if (strcmp(cparav, "-") == 0) { + --nstrgt; + indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); + if (indrgt[nstrgt-1] == 1) { + intstk[nstrgt-1] -= intstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] -= relstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 3) { + char cdata1[73], cdata2[73]; + int_32 ileng2 = intstk[nstrgt-1]; + int_32 ileng1 = intstk[nstrgt]; + if (ileng1 != 0) { + if (ileng2 < ileng1) { + printf("%s: IMPOSSIBLE TO - A SUBSTRING WITH LENGTH LESS THAN STRING", nomsub); + goto L9012; + } + strcpy(cdata2, chrstk[nstrgt-1]); + strcpy(cdata1, chrstk[nstrgt]); + if (strncmp(&cdata2[ileng2-ileng1], cdata1, ileng1) != 0) { + printf("%s: IMPOSSIBLE TO - A SUBSTRING NOT AT THE END OF A STRING", nomsub); + goto L9012; + } else if (ileng1 == ileng2) { + strcpy(chrstk[nstrgt-1], " "); + } else { + memcpy(chrstk[nstrgt-1], cdata2, ileng2-ileng1); + chrstk[nstrgt-1][ileng2-ileng1] = '\0'; + } + intstk[nstrgt-1] = ileng2-ileng1; + } + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] -= dblstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 5) { + logstk[nstrgt-1] = logstk[nstrgt-1] || !logstk[nstrgt]; + } + } else if (strcmp(cparav, "*") == 0) { + --nstrgt; + indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); + if (indrgt[nstrgt-1] == 1) { + intstk[nstrgt-1] *= intstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 2) { + relstk[nstrgt-1] *= relstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 4) { + dblstk[nstrgt-1] *= dblstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 5) { + logstk[nstrgt-1] = logstk[nstrgt-1] && logstk[nstrgt]; + } + } else if (strcmp(cparav, "%") == 0) { + --nstrgt; + indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); + if (indrgt[nstrgt-1] == 1) { + if (intstk[nstrgt] == 0) { + idefkw = 1; + goto L9010; + } + intstk[nstrgt-1] %= intstk[nstrgt]; + } + } else if (strcmp(cparav, "/") == 0) { + --nstrgt; + indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); + if (indrgt[nstrgt-1] == 1) { + if (intstk[nstrgt] == 0) { + idefkw = 1; + goto L9010; + } + intstk[nstrgt-1] /= intstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 2) { + if (relstk[nstrgt] == 0.f) { + idefkw = 2; + goto L9010; + } + relstk[nstrgt-1] /= relstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 4) { + if (dblstk[nstrgt] == 0.) { + idefkw = 4; + goto L9010; + } + dblstk[nstrgt-1] /= dblstk[nstrgt]; + } else if (indrgt[nstrgt-1] == 5) { + logstk[nstrgt-1] = logstk[nstrgt-1] && !logstk[nstrgt]; + } + } else if (strcmp(cparav, "**") == 0) { + --nstrgt; + indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); + if (indrgt[nstrgt-1] == 1) { + if (intstk[nstrgt-1] < 0 && intstk[nstrgt] < 0) { + idefkw = 1; + goto L9011; + } + intstk[nstrgt-1] = pow(intstk[nstrgt-1], intstk[nstrgt]); + } else if (indrgt[nstrgt-1] == 2) { + if (relstk[nstrgt-1] < 0.f && relstk[nstrgt] < 0.f) { + idefkw = 2; + goto L9011; + } + relstk[nstrgt-1] = pow(relstk[nstrgt-1], relstk[nstrgt]); + } else if (indrgt[nstrgt-1] == 4) { + if (dblstk[nstrgt-1] < 0. && dblstk[nstrgt] < 0.) { + idefkw = 4; + goto L9011; + } + dblstk[nstrgt-1] = pow(dblstk[nstrgt-1], dblstk[nstrgt]); + } + } else if (strcmp(cparav, "<") == 0) { + --nstrgt; + indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); + indrgt[nstrgt-1] = 5; + if (indlin == 1) { + logstk[nstrgt-1] = intstk[nstrgt-1] < intstk[nstrgt]; + } else if (indlin == 2) { + logstk[nstrgt-1] = relstk[nstrgt-1] < relstk[nstrgt]; + } else if (indlin == 3) { + logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) < 0; + } else if (indlin == 4) { + logstk[nstrgt-1] = dblstk[nstrgt-1] < dblstk[nstrgt]; + } else { + indrgt[nstrgt-1] = -5; + } + } else if (strcmp(cparav, ">") == 0) { + --nstrgt; + indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); + indrgt[nstrgt-1] = 5; + if (indlin == 1) { + logstk[nstrgt-1] = intstk[nstrgt-1] > intstk[nstrgt]; + } else if (indlin == 2) { + logstk[nstrgt-1] = relstk[nstrgt-1] > relstk[nstrgt]; + } else if (indlin == 3) { + logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) > 0; + } else if (indlin == 4) { + logstk[nstrgt-1] = dblstk[nstrgt-1] > dblstk[nstrgt]; + } else { + indrgt[nstrgt-1] = -5; + } + } else if (strcmp(cparav, "=") == 0) { + --nstrgt; + indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); + indrgt[nstrgt-1] = 5; + if (indlin == 1) { + logstk[nstrgt-1] = intstk[nstrgt-1] == intstk[nstrgt]; + } else if (indlin == 2) { + logstk[nstrgt-1] = relstk[nstrgt-1] == relstk[nstrgt]; + } else if (indlin == 3) { + logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) == 0; + } else if (indlin == 4) { + logstk[nstrgt-1] = dblstk[nstrgt-1] == dblstk[nstrgt]; + } else { + indrgt[nstrgt-1] = -5; + } + } else if (strcmp(cparav, "<=") == 0) { + --nstrgt; + indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); + indrgt[nstrgt-1] = 5; + if (indlin == 1) { + logstk[nstrgt-1] = intstk[nstrgt-1] <= intstk[nstrgt]; + } else if (indlin == 2) { + logstk[nstrgt-1] = relstk[nstrgt-1] <= relstk[nstrgt]; + } else if (indlin == 3) { + logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) <= 0; + } else if (indlin == 4) { + logstk[nstrgt-1] = dblstk[nstrgt-1] <= dblstk[nstrgt]; + } else { + indrgt[nstrgt-1] = -5; + } + } else if (strcmp(cparav, ">=") == 0) { + --nstrgt; + indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); + indrgt[nstrgt-1] = 5; + if (indlin == 1) { + logstk[nstrgt-1] = intstk[nstrgt-1] >= intstk[nstrgt]; + } else if (indlin == 2) { + logstk[nstrgt-1] = relstk[nstrgt-1] >= relstk[nstrgt]; + } else if (indlin == 3) { + logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) >= 0; + } else if (indlin == 4) { + logstk[nstrgt-1] = dblstk[nstrgt-1] >= dblstk[nstrgt]; + } else { + indrgt[nstrgt-1] = -5; + } + } else if (strcmp(cparav, "<>") == 0) { + --nstrgt; + indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); + indrgt[nstrgt-1] = 5; + if (indlin == 1) { + logstk[nstrgt-1] = intstk[nstrgt-1] != intstk[nstrgt]; + } else if (indlin == 2) { + logstk[nstrgt-1] = relstk[nstrgt-1] != relstk[nstrgt]; + } else if (indlin == 3) { + logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) != 0; + } else if (indlin == 4) { + logstk[nstrgt-1] = dblstk[nstrgt-1] != dblstk[nstrgt]; + } else { + indrgt[nstrgt-1] = -5; + } + } else { +/* NO CHANCE, MAN... TRY IT WITH VARIABLES */ + int_32 ilowrc = ivabeg; + int_32 ihigrc = ivaend; +L50: + imedrc = (ihigrc + ilowrc) / 2; + iofset = (imedrc-1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idatin = record2.idatin; + adatin = record2.adatin; + ddatin = record2.ddatin; + if (strcmp(cparin, cparav) == 0) { +/* STACK VARIABLE VALUE */ + ++nstrgt; + indrgt[nstrgt-1] = indlin; + if (indlin == 1) { + intstk[nstrgt-1] = idatin; + } else if (indlin == 2) { + relstk[nstrgt-1] = adatin; + } else if (indlin == 3) { + strcpy(chrstk[nstrgt-1], cdatin); + intstk[nstrgt-1] = idatin; + } else if (indlin == 4) { + dblstk[nstrgt-1] = ddatin; + } else if (indlin == 5) { + logstk[nstrgt-1] = idatin == 1; + } + } else if (strcmp(cparin, cparav) < 0) { + ilowrc = imedrc; + goto L50; + } else { + ihigrc = imedrc; + goto L50; + } + } +/* L05> ENDIF( ON CPARAV ) */ + } + +/* L04> ELSEIF( INDLEC.NE.3 )THEN */ + } else { + ++nstrgt; + indrgt[nstrgt-1] = indlec; + if (indlec == 1) { + intstk[nstrgt-1] = idatin; + } else if (indlec == 2) { + relstk[nstrgt-1] = adatin; + } else if (indlec == 4) { + dblstk[nstrgt-1] = ddatin; + } + +/* L04> ENDIF( ON INDLEC ) */ + } + +/* L03> ELSEIF( .NOT.LRGTST )THEN */ + } else { + strcpy(cparav, cdatav); + if (strcmp(cparav, chrend) == 0) { + lrgtst = 0; + } else if (ilogin <= 6 && strcmp(cparav, ":=") == 0) { + lrgtst = 1; + } else { + int_32 ilowrc = ivabeg; + int_32 ihigrc = ivaend; + + ++nstlft; + +/* FIND RECORD NUMBER FOR VARIABLE *CPARAV* */ +L27: + imedrc = (ihigrc + ilowrc) / 2; + iofset = (imedrc-1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idatin = record2.idatin; + adatin = record2.adatin; + ddatin = record2.ddatin; + if (strcmp(cparin, cparav) == 0) { + irclft[nstlft-1] = imedrc; + } else if (strcmp(cparin, cparav) < 0) { + ilowrc = imedrc; + goto L27; + } else { + ihigrc = imedrc; + goto L27; + } + } +/* L03> ENDIF( ON LRGTST ) */ + } +/* L02> PROCESS *CLE2000* STATEMENTS: AND HIT... (END) */ + } +/* L01> ***LOOP*** OVER WORDS (END) */ + goto L10; + +L8000: + printf("%s: IREC=%d REC=%s\n", nomsub, (int)irecor, myreco); + xabort_c("REDGET: PROBLEM READING *RECORD*, USE DEBUG"); +L9001: + xabort_c("REDGET: EMBEDDED LOGIC LEVEL .LT. 1 (MIN)"); +L9002: + xabort_c("REDGET: EMBEDDED LOGIC LEVEL .GT. 128 (MAX)"); +L9004: + xabort_c("REDGET: NUMBER OF >>.<< ACCUMULATED.GT. 128 (MAX)"); +L9006: + printf("%s: UNDEFINED LOGICAL IN *%s* OPERATION\n", nomsub, clogbg[ilogin-1]); + xabort_c("REDGET: IMPOSSIBLE LOGICAL OPERATION"); +L9007: + xabort_c("REDGET: IMPOSSIBLE TO PRINT VALUE"); +L9008: + printf("%s: VARIABLE *%s* HAS STILL NO VALUE\n", nomsub, cparav); + xabort_c("REDGET: IMPOSSIBLE TO GET VALUE"); +L9009: + printf("%s: *%s* HAS NEGATIVE VALUE\n", nomsub, clogbg[idefkw-1]); + xabort_c("REDGET: IMPOSSIBLE TO TAKE *SQRT*"); +L9010: + printf("%s: *%s* DIVISION BY 0\n", nomsub, clogbg[idefkw-1]); + xabort_c("REDGET: IMPOSSIBLE TO DIVIDE"); +L9011: + printf("%s: *%s* .LT. 0 RAISED TO POWER .LT. 0\n", nomsub, clogbg[idefkw-1]); + xabort_c("REDGET: IMPOSSIBLE TO TAKE POWER"); +L9012: + xabort_c("REDGET: IMPOSSIBLE TO + OR - STRINGS"); +L9013: + xabort_c("REDGET: LONG < 99999999 REQUIRED FOR CONVERSION TO STRING"); +L9014: + xabort_c("REDGET: LONG > -9999999 REQUIRED FOR CONVERSION TO STRING"); + goto L10; +L9023: + printf("%s: IOSTAT RETURN CODE =%d\n", nomsub, (int)iretcd); + xabort_c("REDGET: IMPOSSIBLE TO USE THIS *STACK* FILE"); +} /* redget_c */ + +/* *REDPUT* ENTRY POINT */ +/* TO INPUT VALUES FOR CLE-2000 VARIABLES */ +/* USING THE COMMAND >>.<< */ +/* INPUT VARIABLES: */ +/* *ITYP* TYPE FOR VARIABLE (+1: INT */ +/* +2: REAL */ +/* +3: STRING */ +/* +4: DOUBLE */ +/* +5: LOGICAL ) */ +/* *NITMA* INT VALUE IF *ITYP*.EQ.+1.OR.*ITYP*.EQ.+5 */ +/* *FLOTT* REAL VALUE IF *ITYP*.EQ.+2 */ +/* *TEXT* STRING VALUE IF *ITYP*.EQ.+3 */ +/* *DFLOT* DOUBLE VALUE IF *ITYP*.EQ.+4 */ + +/* NOTE: LOGICAL VALUES ARE GIVEN EITHER BY *TRUE* = *NITMA*.EQ.+1 */ +/* OR BY *FALSE*= *NITMA*.EQ.-1 */ + +void redput_c(int_32 *ityp, int_32 *nitma, float_32 *flott, char *text, double_64 *dflot) +{ + char *nomsub="redput_c"; + char cparin[13], cdatin[121]; + int_32 iretcd, ilengt, indlin, idatin, imedrc, iofset; + float_32 adatin; + double_64 ddatin; + + if (*ityp == 3) { + ilengt = strlen(text); + } else { + ilengt = 0; + } + if (nstput == 0) { + xabort_c("REDPUT: NOTHING TO PUT"); + } else if (ilengt > 72) { + xabort_c("REDPUT: STRING LENGTH RESTRICTED TO 72"); + } else if (*ityp <= 0) { + xabort_c("REDPUT: PLEASE USE *ITYP*.GT.0"); + } else if (irecor == 0 || irecor > ninput) { + xabort_c("REDPUT: READER IS CLOSED OR FILE END"); + } + imedrc = ircput[nstput-1]; + iofset = (imedrc-1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + strcpy(cparin, record2.cparin); + strcpy(cdatin, record2.cdatin); + indlin = record2.indlin; + idatin = record2.idatin; + adatin = record2.adatin; + ddatin = record2.ddatin; + if (indlin >= 0) xabort_c("REDPUT: CANNOT PUT ON A DEFINED VALUE"); + indlin = abs(indlin); + if (indlin != *ityp) xabort_c("REDPUT: INCOMPATIBLE TYPE OF THE VARIABLE"); + if (indlin == 1) { + idatin = *nitma; + } else if (indlin == 2) { + adatin = *flott; + } else if (indlin == 3) { + if (strncmp(text, " ", ilengt) == 0) { +/* ALL BLANK STRING IS CONSIDERED AS NULL-STRING => "" */ + idatin = 0; + } else if (text[0] == '"') { +/* THIS IS A "...." STRING => START "... */ + if (ilengt == 1) { +/* PROVIDES A WAY FOR APPLICATION TO PUT A '"' STRING */ + idatin = 1; + cdatin[0] = text[0]; + } else { +/* LOOK FOR => END ..." */ + idatin = index_f(&text[1], "\"") - 1; + if (idatin < 0) { + if (strcmp(&text[1], " ") == 0) { + idatin = 1; + cdatin[0] = text[0]; + } else { + xabort_c("REDPUT: INVALID STRING \" NEVER ENDS)"); + } + } else if (idatin != 0) { + if (ilengt == idatin + 2) { + memcpy(cdatin, &text[1], idatin); cdatin[idatin] = '\0'; + } else { + if (strcmp(&text[idatin+2], " ") != 0) xabort_c("REDPUT: \".\" + OTHER WORDS"); + memcpy(cdatin, &text[1], idatin); cdatin[idatin] = '\0'; + } + } + } + } else { + memcpy(cdatin, text, ilengt); cdatin[ilengt] = '\0'; + idatin = ilengt; + } + } else if (indlin == 4) { + ddatin = *dflot; + } else if (indlin == 5) { + idatin = *nitma; + if (idatin != -1 && idatin != 1) xabort_c("REDPUT: LOGICAL IS UNDEFINED"); + } else { + xabort_c("REDPUT: UNDEFINED TYPE"); + } + strcpy(record2.cparin, cparin); + strcpy(record2.cdatin, cdatin); + record2.indlin = indlin; + record2.idatin = idatin; + record2.adatin = adatin; + record2.ddatin = ddatin; + iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); + if (iretcd != 0) goto L9023; + +/* ONE LESS TO PUT */ + --nstput; + return; +L9023: + printf("%s: IOSTAT RETURN CODE =%d\n", nomsub, (int)iretcd); + xabort_c("REDPUT: IMPOSSIBLE TO USE THIS *STACK* FILE"); +} /* redput_c */ + +/* *REDOPN* ENTRY POINT */ +/* TO OPEN THE DA-FILE CONTAINING CLE-2000 DATA */ +/* INPUT VARIABLES: */ +/* *IINP1* IS THE CLE-2000 DA-FILE UNIT */ +/* *IOUT1* IS THE OUTPUT FILE UNIT FOR MESSAGES (NORMALLY STDOUT) */ +/* *FILENAME* IS THE OUTPUT FILE NAME FOR MESSAGES */ +/* *NREC* IS THE RECORD NUMBER WHERE WE START READING */ + +void redopn_c(kdi_file *iinp1, FILE *iout1, char *filename, int_32 nrec) +{ + char *nomsub="redopn_c"; + int_32 nstack; + char cparav[13]; + int_32 iretcd; + + iunito = iinp1; + iwrite = iout1; + strcpy(hwrite, filename); + +/* READ TOP OF OBJECT FILE */ + irecor = 1; + iretcd = kdiget_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9023; + strcpy(cparav, header.cparin); + strcpy(myreco, header.cdatin); + ninput = header.ninput; + nstack = header.nstack; + ioulst = header.ioulst; + idblst = header.idblst; + if (strcmp(cparav, cl2000) != 0) goto L9025; + if (nrec != 0) irecor = nrec; + nwords = 0; + iwords = 0; + ivabeg = ninput; + ivaend = ninput + nstack + 1; + return; +L9023: + printf("%s: IOSTAT RETURN CODE =%d\n", nomsub, (int)iretcd); + xabort_c("REDOPN: IMPOSSIBLE TO USE THIS *STACK* FILE"); +L9025: + xabort_c("REDOPN: UNABLE TO OPEN FILE"); +} /* redopn_c */ + +/* *REDCLS* ENTRY POINT */ +/* TO CLOSE THE DA-FILE AT A CURRENT RECORD POSITION */ +/* OUTPUT VARIABLES: */ +/* *IINP1* IS THE CLE-2000 DA-FILE UNIT */ +/* *IOUT1* IS THE OUTPUT FILE UNIT FOR MESSAGES (NORMALLY STDOUT) */ +/* *FILENAME* IS THE OUTPUT FILE NAME FOR MESSAGES */ +/* *NREC* IS THE RECORD NUMBER WHERE WE STOP READING */ + +void redcls_c(kdi_file **iinp1, FILE **iout1, char filename[73], int_32 *nrec) +{ + if (nwords != iwords) xabort_c("REDCLS: RECORD NOT FINISHED => CANNOT CLOSE"); + *nrec = irecor; + *iinp1 = iunito; + *iout1 = iwrite; + strcpy(filename, hwrite); + +/* WE PUT IRECOR=0 TO CLOSE THE READER (SEE START OF *REDGET*) */ + irecor = 0; + ninput = 0; + nwords = 0; + iwords = 0; + return; +} /* redcls_c */ diff --git a/Ganlib/src/setara_c.c b/Ganlib/src/setara_c.c new file mode 100644 index 0000000..1cd3918 --- /dev/null +++ b/Ganlib/src/setara_c.c @@ -0,0 +1,46 @@ +/* + ----------------------------------------------------------------------- + Copyright (C) 2002 Ecole Polytechnique de Montreal + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + DYNAMIC ALLOCATION/LIBERATION OF MEMORY WITH SETARA/RLSARA IN C. + + SETARA PARAMETERS: + LENGTH : NUMBER OF SINGLE PRECISION WORDS TO BE ALLOCATED BY SETARA. + IOF : OFFSET OF THE ALLOCATED SPACE. + + RLSARA PARAMETER: + BASE : FIRST WORD OF THE MEMORY SPACE TO BE DEALLOCATED. + + ----------------------------------------------------------------------- + */ + +#include <stdlib.h> +#include <string.h> +#include <stdio.h> +#include "ganlib.h" + +static char AbortString[80]; + +int_32 * setara_c(int_32 length) +{ + char *nomsub="setara_c"; + int_32 *kaddr; + + kaddr = (int_32 *)malloc(length*sizeof(int_32)); + if (kaddr == 0) { + sprintf(AbortString,"%s: invalid return code %ld length=%d",nomsub,(long)kaddr,(int)length); + xabort_c(AbortString); + } + return kaddr; +} +/* Function rlsara_c */ +void rlsara_c(int_32 *iof) +{ + free(iof); + return; +} diff --git a/Ganlib/src/xabort_c.c b/Ganlib/src/xabort_c.c new file mode 100644 index 0000000..5fa4b1b --- /dev/null +++ b/Ganlib/src/xabort_c.c @@ -0,0 +1,23 @@ + +/*****************************************/ +/* GANLIB API */ +/* AUTHOR: A. Hebert ; 06/05/09 */ +/*****************************************/ + +/* +Copyright (C) 2009 Ecole Polytechnique de Montreal + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. +*/ + +#include <stdlib.h> +#include <stdio.h> + +void xabort_c(char *msg){ + printf(" %s\n",msg); + fflush(stdout); + exit(1); +} diff --git a/Ganlib/src/xsm.h b/Ganlib/src/xsm.h new file mode 100644 index 0000000..234dc1a --- /dev/null +++ b/Ganlib/src/xsm.h @@ -0,0 +1,76 @@ + +/**********************************/ +/* C API for xsm file support */ +/* author: A. Hebert (30/04/2002) */ +/**********************************/ + +/* +Copyright (C) 2002 Ecole Polytechnique de Montreal + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. +*/ + +#define iofmax 30 +#define maxit 100 +#include "kdi.h" + +typedef struct Block1 { /* active directory resident-memory xsm structure */ + int_32 header; /* header (=200 for an xsm file) */ + char hname[73]; /* character*72 name of the xsm file */ + int_32 listlen; /* number of elements in the list */ + int_32 impf; /* type of access (1:modif or 2:read-only) */ + int_32 idir; /* offset of active directory on xsm file */ + struct Block2 *ibloc; /* address of block 2 in memory */ + struct Db1 *icang; /* address of the database handle */ + struct Block1 *father; /* address of the father active directory resident- + memory xsm structure. =0 for root directory. */ + struct Db2 *icang2; /* address of the xsmiof database handle */ +} xsm ; + +typedef struct Block2 { /* active directory resident-memory xsm structure */ + kdi_file *ifile; /* xsm (kdi) file handle */ + int_32 idir; /* offset of active directory on xsm file */ + int_32 modif; /* =1 if the active directory extent have been modified */ + int_32 ioft; /* maximum address on xsm file */ + int_32 nmt; /* exact number of nodes on the active directory extent */ + int_32 link; /* offset of the next directory extent */ + int_32 iroot; /* offset of any parent directory extent */ + char mynam[13]; /* character*12 name of the active directory. ='/' for the root level */ + int_32 iofs[iofmax]; /* offset list (position of the first element of each block + that belong to the active directory extent) */ + int_32 jlon[iofmax]; /* length of each record (jlong=0 for a directory) that belong + to the active directory extent */ + int_32 jtyp[iofmax]; /* type of each block that belong to the active directory extent */ + char cmt[iofmax][13]; /* list of character*12 names of each block (record or + directory) that belong to the active directory extent */ +} block2 ; + +typedef struct Db1{ /* database handle */ + int_32 nad; /* number of addresses in the database */ + int_32 maxad; /* maximum slots in the database */ + xsm **idir; /* address of the array of pointers */ +} db1 ; + +typedef struct Db2{ /* xsmiof database handle */ + int_32 nad; /* number of addresses in the database */ + int_32 maxad; /* maximum slots in the database */ + int_32 ***iref; /* address of the array of pointers addresses */ + int_32 **iofset; /* address of the array of pointers */ + int_32 *lg; /* address of the array of lengths */ +} db2 ; + +void xsmop_c(xsm **, char *, int_32, int_32); +void xsmput_c(xsm **, const char *, int_32, int_32, int_32 *); +void xsmget_c(xsm **, const char *, int_32 *); +void xsmcl_c(xsm **, int_32); +void xsmnxt_c(xsm **, char *); +void xsmlen_c(xsm **, const char *, int_32 *, int_32 *); +void xsminf_c(xsm **, char *, char *, int_32 *, int_32 *, int_32 *); +void xsmsix_c(xsm **, const char *, int_32 iact); +void xsmdid_c(xsm **, const char *, xsm **); +void xsmlid_c(xsm **, const char *, int_32, xsm **); +void xsmgpd_c(xsm **, const char *, int_32 **); +void xsmppd_c(xsm **, const char *, int_32, int_32, int_32 *); diff --git a/Ganlib/src/xsm_c.c b/Ganlib/src/xsm_c.c new file mode 100644 index 0000000..7abbf1f --- /dev/null +++ b/Ganlib/src/xsm_c.c @@ -0,0 +1,1235 @@ + +/**********************************/ +/* C API for xsm file support */ +/* author: A. Hebert (30/04/2002) */ +/**********************************/ + +/* + Copyright (C) 2002 Ecole Polytechnique de Montreal + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + */ + +#include <stdlib.h> +#include <string.h> +#include "xsm.h" + +#define iprim 3 +#define iwrd 3 +#define klong 5+iwrd+(3+iwrd)*iofmax +#if !defined(min) +#define min(A,B) ((A) < (B) ? (A) : (B)) +#endif +#define TRUE 1 /* valeur boolenne TRUE */ +#define FALSE 0 /* valeur boolenne FALSE */ + +static char AbortString[132]; + +/* Table of constant values */ + +static int_32 c__0 = 0; +static int_32 c__1 = 1; +static int_32 c__2 = 2; +static int_32 c__8 = 8; +static char *bl12=" "; + +void xsmkep(db1 *ipkeep, int_32 imode, xsm **iplist) +/* + *----------------------------------------------------------------------- + * + * keep the addresses of the open active directories. + * + * input parameters: + * ipkeep : address of the database handle (always the same). + * imode : =1: add to the database; =2: remove from the database. + * iplist : address of an active directory. + * + * output parameter: + * iplist : last active directory in the database. =0 if the + * database is empty. + * + * database handle structure: + * 0 : number of addresses in the database. + * 1 : maximum slots in the database. + * 2 : address of the database. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmkep"; + int_32 n = ipkeep->nad; + if (imode == 1) { + int_32 i; + xsm **my_parray; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: WRONG HEADER(1).",nomsub); + xabort_c(AbortString); + } else if (ipkeep->nad + 1 > ipkeep->maxad) { + ipkeep->maxad += maxit; + my_parray = (xsm **) malloc((ipkeep->maxad)*sizeof(*my_parray)); + for (i = 0; i < n; ++i) my_parray[i]=ipkeep->idir[i]; + if (n > 0) free(ipkeep->idir); + ipkeep->idir=my_parray; + } + ++ipkeep->nad; + ipkeep->idir[n] = *iplist; + } else if (imode == 2) { + int_32 i, i0=0; + for (i = n; i >= 1; --i) { + if (ipkeep->idir[i-1] == *iplist) { + i0 = i; + goto L30; + } + } + sprintf(AbortString,"%s: UNABLE TO FIND AN ADDRESS.",nomsub); + xabort_c(AbortString); +L30: + for (i = i0; i <= n-1; ++i) + ipkeep->idir[i-1]=ipkeep->idir[i]; + --ipkeep->nad; + if (ipkeep->nad == 0) { + *iplist = NULL; + free(ipkeep->idir); + ipkeep->maxad=0; + ipkeep->idir=NULL; + } else { + *iplist = ipkeep->idir[n-1]; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: WRONG HEADER(2).",nomsub); + xabort_c(AbortString); + } + } + } else { + sprintf(AbortString,"%s: INVALID VALUE OF IMODE.",nomsub); + xabort_c(AbortString); + } + return; +} + +void xsmdir(int_32 *ind, block2 *my_block2) +/* + *----------------------------------------------------------------------- + * + * import or export a directory using the kdi utility. + * + * input parameters: + * ind : =1 for import ; =2 for export. + * my_block2 : address of memory-resident xsm structure (block 2). + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmdir"; + int_32 i,j,irc,ibuf[9],ipos,iofma2,iivec[6*iofmax]; + ipos = my_block2->idir; + if (*ind == 1) { + irc = kdiget_c(my_block2->ifile, ibuf, ipos, c__8); + if (irc != 0) goto L40; + if (strncmp((char*)ibuf,"$$$$",4) != 0) goto L30; + iofma2 = ibuf[1]; + if (iofma2 > iofmax) goto L30; + my_block2->nmt = ibuf[2]; + my_block2->link = ibuf[3]; + my_block2->iroot = ibuf[4]; + strncpy(my_block2->mynam,(char*)&ibuf[5],12); + my_block2->mynam[12]='\0'; + for(i=11; i>0; i--) { + if(my_block2->mynam[i] != ' ') break; + my_block2->mynam[i]='\0'; + } + if (my_block2->nmt == 0) return; + ipos += c__8; + irc = kdiget_c(my_block2->ifile, iivec, ipos, 6*iofma2); + if (irc != 0) goto L40; + for(i=0; i<my_block2->nmt; i++) { + my_block2->iofs[i] = iivec[i]; + my_block2->jlon[i] = iivec[iofma2+i]; + my_block2->jtyp[i] = iivec[2*iofma2+i]; + strncpy(my_block2->cmt[i],(char*)&iivec[3*(iofma2+i)],12); + my_block2->cmt[i][12]='\0'; + for(j=11; j>0; j--) { + if(my_block2->cmt[i][j] != ' ') break; + my_block2->cmt[i][j]='\0'; + } + } + } else if (*ind == 2) { + my_block2->modif = 0; + const char *src = "$$$$"; + memcpy((char*)ibuf,src,strlen(src)); + ibuf[1] = iofmax; + ibuf[2] = my_block2->nmt; + ibuf[3] = my_block2->link; + ibuf[4] = my_block2->iroot; + memcpy((char*)&ibuf[5],bl12,12); + strncpy((char*)&ibuf[5],my_block2->mynam,min(12,strlen(my_block2->mynam))); + irc = kdiput_c(my_block2->ifile, ibuf, ipos, c__8); + if (irc != 0) goto L50; + ipos += c__8; + memset(iivec, 0, 6*iofmax*sizeof(iivec[0])); + for(i=0; i<my_block2->nmt; i++) { + iivec[i] = my_block2->iofs[i]; + iivec[iofmax+i] = my_block2->jlon[i]; + iivec[2*iofmax+i] = my_block2->jtyp[i]; + memcpy((char*)&iivec[3*(iofmax+i)],bl12,12); + strncpy((char*)&iivec[3*(iofmax+i)],my_block2->cmt[i],min(12,strlen(my_block2->cmt[i]))); + } + irc = kdiput_c(my_block2->ifile, iivec, ipos, 6*iofmax); + if (irc != 0) goto L50; + } + return; +/* ABORT ON FATAL ERRORS */ +L30: + sprintf(AbortString,"%s: UNABLE TO RECOVER DIRECTORY.",nomsub); + xabort_c(AbortString); +L40: + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d.",nomsub,(int)irc); + xabort_c(AbortString); +L50: + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d.",nomsub,(int)irc); + xabort_c(AbortString); +} + +void xsmop_c(xsm **iplist, char *namp, int_32 imp, int_32 impx) +/* + *----------------------------------------------------------------------- + * + * open an existing or create a new xsm file. + * + * The xsm database results from the juxtaposition of a hierarchical + * logical structure into a direct access file. The direct access file + * is ANSI-C or Fortran-77 compatible and is managed by kdiget/put/cl. + * xsmop/put/get/len/vec/nxt/cl entries provide a set of methods to + * access a xsm file. + * + * The logical structure of a xsm file is made of a root directory fol- + * lowed by variable-length blocks containing the useful information. + * Each time a directory is full, an extent is automatically created at + * the end of the file, so that the total number of blocks in a direc- + * tory is only limited by the maximum size of the direct access file. + * Any block can contain a sub-directory in order to create a hierar- + * chical structure. + * + * input parameters: + * namp : character name (null terminated) of the xsm file. + * imp : type of access. =0: new file mode; + * =1: modification mode; + * =2: read only mode. + * impx : if impx=0, we suppress printing on xsmop. + * + * output parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the xsm file if imp=1 or imp=2. + * + * The active directory is made of two blocks linked together. A block 1 + * is allocated for each scalar directory or vector directory component. + * Block 2 is unique for a given xsm file; every block 1 is pointing to + * the same block 2. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmop_c"; + int_32 irc,ibuf; + char hbuf[5]; + block2 *my_block2; + db1 *my_db1; + db2 *my_db2; + kdi_file *my_file; + if (imp < 0 || imp > 2) { + sprintf(AbortString,"%s: INVALID ACTION ( %d ) ON XSM FILE '%s'.",nomsub,(int)imp,namp); + xabort_c(AbortString); + } else if (strlen(namp) > 72) { + sprintf(AbortString,"%s: FINENAME '%s' EXCEEDING 72 CHARACTERS.",nomsub,namp); + xabort_c(AbortString); + } + *iplist = (xsm *) malloc(sizeof(**iplist)); + my_block2 = (block2 *) malloc(sizeof(*my_block2)); + + my_db1 = (db1 *) malloc(sizeof(*my_db1)); + my_db1->nad = 0; + my_db1->maxad = 0; + my_db1->idir = NULL; + (*iplist)->icang = my_db1; + + my_db2 = (db2 *) malloc(sizeof(*my_db2)); + my_db2->nad = 0; + my_db2->maxad = 0; + my_db2->iref = NULL; + my_db2->iofset = NULL; + my_db2->lg = NULL; + (*iplist)->icang2 = my_db2; + + (*iplist)->header = 200; + (*iplist)->listlen = -1; + (*iplist)->impf = imp; + (*iplist)->ibloc = my_block2; + (*iplist)->father = NULL; + strcpy((*iplist)->hname,namp); + my_file = (kdi_file *) kdiop_c(namp,imp); + if (my_file == NULL) { + sprintf(AbortString,"%s: UNABLE TO OPEN XSM FILE '%s'.",nomsub,namp); + xabort_c(AbortString); + } + my_block2->ifile = my_file; + if (impx > 1) + printf("%s: KDI FILE OPEN = %ld NAME = '%s' ACTION = %d.\n",nomsub,(long)my_file->fd,namp,(int)imp); + if (imp >= 1) { +/* RECOVER THE ROOT DIRECTORY IF THE XSM FILE ALREADY EXISTS. */ + irc=kdiget_c(my_block2->ifile, &ibuf, c__0, c__1); + if (irc != 0) goto L140; + strncpy(hbuf,(char*)&ibuf,4); + hbuf[4]='\0'; + if (strcmp(hbuf,"$XSM") != 0) { + sprintf(AbortString,"%s: WRONG HEADER ON XSM FILE '%s'.",nomsub,namp); + xabort_c(AbortString); + } + irc=kdiget_c(my_block2->ifile, &(my_block2->ioft), c__1, c__1); + if (irc != 0) goto L140; + irc=kdiget_c(my_block2->ifile, &(my_block2->idir), c__2, c__1); + if (irc != 0) goto L140; + (*iplist)->idir = my_block2->idir; + xsmdir(&c__1,my_block2); + my_block2->modif = 0; + if (impx > 0) { + printf("%s: XSM FILE RECOVERY. FILE = '%s'.\n",nomsub,namp); + printf("%6s HIGHEST ATTAINABLE ADDRESS = %d\n"," ",(int)my_block2->ioft); + printf("%6s ACTIVE DIRECTORY = %s\n"," ",my_block2->mynam); + } + } else { +/* NEW-FILE MODE. */ + (*iplist)->impf = 1; + (*iplist)->idir = iprim; + my_block2->ioft = iprim+klong; + my_block2->idir = iprim; + my_block2->iroot = -1; + my_block2->nmt = 0; + my_block2->link = iprim; + sprintf(my_block2->mynam,"/"); + memcpy((char*)&ibuf,"$XSM",sizeof(ibuf)); + irc=kdiput_c(my_block2->ifile, &ibuf, c__0, c__1); + if (irc != 0) goto L150; + irc=kdiput_c(my_block2->ifile, &(my_block2->ioft), c__1, c__1); + if (irc != 0) goto L150; + irc=kdiput_c(my_block2->ifile, &(my_block2->idir), c__2, c__1); + if (irc != 0) goto L150; + xsmdir(&c__2,my_block2); + my_block2->modif = 1; + } + return; +L140: + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,namp); + xabort_c(AbortString); +L150: + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,namp); + xabort_c(AbortString); +} + +void xsmrep(const char *namt, int_32 *ind, int_32 *idir, block2 *my_block2, int_32 *iii) +/* + *----------------------------------------------------------------------- + * + * find a block (record or directory) position in the active directory + * and related extents. + * + * input parameters: + * namt : character*12 name of the required block. + * ind : =1 search namt ; =2 search and positionning in an empty + * slot of the active directory if namt does not exists. + * idir : offset of active directory on xsm file. + * my_block2 : address of memory-resident xsm structure (block 2). + * + * output parameter: + * iii : return code. =0 if the block named namt does not exists; + * =position in the active directory extent if namt extsts. + * =0 or 1 if namt=' '. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmrep"; + int_32 i, ipos, ipos2, irc, irc2, istart; + char namp[13],nomC[25]; + + if (my_block2->idir != *idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = *idir; + xsmdir(&c__1, my_block2); + } + if (strcmp(namt,"***HANDLE***") == 0) { + sprintf(AbortString,"%s: ***HANDLE*** IS A RESERVED KEYWORD.",nomsub); + xabort_c(AbortString); + } + strcpy(namp,namt); + if (strcmp(namp," ") == 0) strcpy(namp,"***HANDLE***"); + ipos = -1; + if (my_block2->nmt < iofmax) ipos = my_block2->idir; + if (my_block2->nmt == 0) goto L50; + for (i = 1; i <= my_block2->nmt; ++i) { + if (strcmp(namp,my_block2->cmt[i-1]) == 0) { +/* THE BLOCK ALREADY EXISTS. */ + *iii = i; + return; + } + } +/* THE BLOCK NAMP DOES NOT EXISTS IN THE ACTIVE DIRECTORY EXTENT. WE + SEARCH IN OTHER EXTENTS THAT BELONG TO THE ACTIVE DIRECTORY. */ + if (my_block2->idir != my_block2->link) { +/* RECOVER A NEW DIRECTORY EXTENT. */ + istart = my_block2->link; + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = istart; +L30: + xsmdir(&c__1, my_block2); + if (my_block2->nmt < iofmax) ipos = my_block2->idir; + for (i = 1; i <= my_block2->nmt; ++i) { + if (strcmp(namp,my_block2->cmt[i-1]) == 0) { +/* THE BLOCK NAMP WAS FOUND IN THE ACTIVE DIRECTORY EXTENT. */ + *iii = i; + return; + } + } + if (my_block2->link == istart) goto L50; + my_block2->idir = my_block2->link; + goto L30; + } +L50: + *iii = 0; + if (*ind == 1) return; + if (ipos >= 0 && ipos != my_block2->idir) { +/* AN EXTENT WITH AN EMPTY SLOT WAS FOUND. */ + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = ipos; + xsmdir(&c__1, my_block2); + } else if (ipos == -1) { +/* THE ACTIVE DIRECTORY IS FULL. CREATE AN EXTENT. */ + ipos = my_block2->link; + my_block2->link = my_block2->ioft; + if (my_block2->modif == 1) { + xsmdir(&c__2, my_block2); + } else { + ipos2 = my_block2->idir + 3; + irc=kdiput_c(my_block2->ifile, &(my_block2->link), ipos2, c__1); + if (irc != 0) goto L150; + } + my_block2->idir = my_block2->link; + my_block2->link = ipos; + my_block2->ioft += klong; + my_block2->nmt = 0; + } + ++my_block2->nmt; + *iii = my_block2->nmt; + my_block2->modif = 1; + my_block2->jlon[*iii - 1] = 0; + my_block2->jtyp[*iii - 1] = 99; + strcpy(my_block2->cmt[*iii - 1],namp); + return; + +L150: + irc2=kdicl_c(my_block2->ifile, c__1); + strcpy(nomC,(my_block2->ifile)->nom); + if (irc2 != 0) printf("%s: kdicl_c ERROR NB. %d ON XSM FILE '%s'.\n",nomsub,(int)irc2,nomC); + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); +} + +void xsmput_c(xsm **iplist, const char *namp, int_32 ilong, int_32 itype, int_32 *data1) +/* + *----------------------------------------------------------------------- + * + * copy a block from memory into the xsm file. + * + * input parameter: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * ilong : number of information elements stored in the current block. + * itype : type of information elements stored in the current block. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex + * data1 : information elements. dimension data1(ilong) + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmput_c"; + char nomC[13]; + block2 *my_block2; + int_32 iii,irc; + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(1).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (ilong <= 0) { + sprintf(AbortString,"%s: INVALID LENGTH (%d) FOR NODE '%s' IN THE XSM FILE '%.60s'.", + nomsub,(int)ilong,namp,(*iplist)->hname); + xabort_c(AbortString); + } else if (itype <= 0 || itype >= 8) { + sprintf(AbortString,"%s: INVALID TYPE NUMBER (%d) FOR NODE '%s' IN THE XSM FILE '%.60s'.", + nomsub,(int)itype,namp,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__2, &(*iplist)->idir, my_block2, &iii); + my_block2->modif = 1; + int_32 jlong = ilong; + if (itype == 4 || itype == 6) jlong = 2*ilong; + if (jlong > my_block2->jlon[iii-1]) { + my_block2->iofs[iii-1] = my_block2->ioft; + my_block2->ioft += jlong; + } + my_block2->jlon[iii-1] = jlong; + my_block2->jtyp[iii-1] = itype; + irc=kdiput_c(my_block2->ifile, data1, my_block2->iofs[iii-1], jlong); + if (irc != 0) { + strcpy(nomC,(my_block2->ifile)->nom); + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); + } + return; +} +void xsmget_c(xsm **iplist, const char *namp, int_32 *data2) +/* + *----------------------------------------------------------------------- + * + * copy a block from the xsm file into memory. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * + * output parameter: + * data2 : information elements. dimension data2(ilong) + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmget_c"; + char nomC[13]; + block2 *my_block2; + int_32 iii,irc; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii); + if (iii > 0) { + irc=kdiget_c(my_block2->ifile, data2, my_block2->iofs[iii-1], my_block2->jlon[iii-1]); + if (irc != 0) { + strcpy(nomC,(my_block2->ifile)->nom); + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); + } + } else { + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE XSM FILE '%.45s'.", + nomsub,namp,my_block2->mynam,(*iplist)->hname); + xabort_c(AbortString); + } + return; +} + +void xsmcl_c(xsm **iplist, int_32 istatu) +/* + *----------------------------------------------------------------------- + * + * close the xsm file. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * istatu : =1 to keep the file at close ; =2 to destroy it. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmcl_c"; + block2 *my_block2; + int_32 i, irc, iii; + db1 *ipkeep; + db2 *ipkep2; + if ((*iplist)->impf == 2 && istatu == 2) { + sprintf(AbortString,"%s: CANNOT ERASE THE XSM FILE '%.60s' OPEN IN READ-ONLY MODE.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (istatu < 1 || istatu > 2) { + sprintf(AbortString,"%s: INVALID ACTION ( %d ) ON XSM FILE '%s'.", + nomsub,(int)istatu,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + ipkeep = (*iplist)->icang; + if (ipkeep->nad > 0) { + for (i = 1; i <= ipkeep->nad; ++i) free(ipkeep->idir[i-1]); + free(ipkeep->idir); + } + ipkep2 = (*iplist)->icang2; + if (ipkep2->nad > 0) { + for (i = 1; i <= ipkep2->nad; ++i) free(ipkep2->iofset[i-1]); /* rlsara_c() */ + free(ipkep2->iref); + free(ipkep2->iofset); + free(ipkep2->lg); + } + my_block2 = (*iplist)->ibloc; + + if (my_block2->modif == 1) { + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(2).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + xsmdir(&c__2, my_block2); + } + + if (my_block2->idir != (*iplist)->idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + my_block2->idir = (*iplist)->idir; + xsmdir(&c__1, my_block2); + } + if (my_block2->iroot != -1) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS NOT ON ROOT DIRECTORY.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + if (my_block2->idir != iprim) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + my_block2->idir = iprim; + xsmdir(&c__1, my_block2); + } + + irc = kdiget_c(my_block2->ifile, &iii, c__1, c__1); + if (irc != 0) goto L140; + if (my_block2->ioft > iii) { + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(3).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + irc = kdiput_c(my_block2->ifile, &(my_block2->ioft), c__1, c__1); + if (irc != 0) goto L150; + } + irc = kdicl_c(my_block2->ifile, istatu); + if (irc != 0) goto L160; + +/* RELEASE THE XSM FILE HANDLE. */ + free((*iplist)->icang); + free((*iplist)->icang2); + my_block2->ifile = NULL; + free(my_block2); + (*iplist)->header = 0; + free(*iplist); + *iplist = NULL; + return; + +L140: + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,(*iplist)->hname); + xabort_c(AbortString); +L150: + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,(*iplist)->hname); + xabort_c(AbortString); +L160: + sprintf(AbortString,"%s: kdicl_cS ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,(*iplist)->hname); + xabort_c(AbortString); +} + +void xsmnxt_c(xsm **iplist, char *namp) +/* + *----------------------------------------------------------------------- + * + * find the name of the next block stored in the active directory. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of a block. if namp=' ' at input, find + * any name for any block stored in this directory. + * + * output parameters: + * namp : character*12 name of the next block. namp=' ' for an empty + * directory. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmnxt_c"; + block2 *my_block2; + int_32 iii; + + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2 = (*iplist)->ibloc; + if (strcmp(namp," ") == 0) { + if (my_block2->idir != (*iplist)->idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = (*iplist)->idir; + xsmdir(&c__1, my_block2); + } + iii = min(my_block2->nmt,1); + } else { + xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii); + } + if (iii == 0 && strcmp(namp, " ") == 0) { +/* EMPTY DIRECTORY */ + sprintf(AbortString,"%s: THE ACTIVE DIRECTORY '%s' OF THE XSM FILE '%.45s' IS EMPTY.", + nomsub,my_block2->mynam,(*iplist)->hname); + xabort_c(AbortString); + } else if (iii == 0) { + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE XSM FILE '%.45s'.", + nomsub,namp,my_block2->mynam,(*iplist)->hname); + xabort_c(AbortString); + } else if (iii + 1 <= my_block2->nmt) { + strcpy(namp,my_block2->cmt[iii]); + return; + } +/* SWITCH TO THE NEXT DIRECTORY. */ + if (my_block2->idir != my_block2->link) { + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = my_block2->link; +/* RECOVER THE NEXT DIRECTORY. */ + xsmdir(&c__1, my_block2); + } + strcpy(namp,my_block2->cmt[0]); + if (strcmp(namp,"***HANDLE***") == 0) strcpy(namp," "); + return; +} + +void xsmlen_c(xsm **iplist, const char *namp, int_32 *ilong, int_32 *itype) +/* + *----------------------------------------------------------------------- + * + * return the length and type of a block. Return 0 if the block does not + * exists. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * ilong : number of information elements stored in the current block. + * ilong=-1 is returned for a scalar directory. + * ilong=0 if the block does not exists. + * itype : type of information elements stored in the current block. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex 99: undefined + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmlen_c"; + block2 *my_block2; + int_32 iii; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii); + if (iii > 0) { + *ilong = my_block2->jlon[iii-1]; + *itype = my_block2->jtyp[iii-1]; + if (*itype == 4 || *itype == 6) *ilong=*ilong/2; + } else { + *ilong = 0; + *itype = 99; + } + return; +} +void xsminf_c(xsm **iplist, char *namxsm, char *nammy, int_32 *empty, int_32 *ilong, int_32 *access) +/* + *----------------------------------------------------------------------- + * + * recover global informations related to an xsm file. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * + * output parameters: + * namxsm : character*12 name of the xsm file. + * nammy : charecter*12 name of the active directory. + * empty : =.true. if the active directory is empty. + * ilong : =-1: for a table; >0: number of list items. + * access : type of access. =1: object open for modification; + * =2: object in read-only mode. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsminf_c"; + block2 *my_block2; + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + if (my_block2->idir != (*iplist)->idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + my_block2->idir = (*iplist)->idir; + xsmdir(&c__1, my_block2); + } + strcpy(namxsm,(*iplist)->hname); + strcpy(nammy,my_block2->mynam); + + *empty = (my_block2->nmt == 0); + *ilong = (*iplist)->listlen; + *access = (*iplist)->impf; + return; +} + +void xsmsix_c(xsm **iplist, const char *namp, int_32 iact) +/* + *----------------------------------------------------------------------- + * + * move in the scalar hierarchical structure of a xsm file. + * + * input parameters: + * iplist : address of the father/son table. + * namp : character*12 name of the son table if iact=1. + * not used if iact=0 or iact=2. + * iact : type of movement in the hierarchical structure. + * 0: move back to the root directory; + * 1: move to a son vectorial directory; + * 2: move back to the parent directory. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmsix_c"; + block2 *my_block2; + int_32 iii, lenold, idir=0, ityold; + xsm *iofset, *iofpre; + char nomC[13]; + + if (iact < 0 || iact > 2) { + sprintf(AbortString,"%s: INVALID ACTION (%d) ON THE XSM FILE '%.60s'.", + nomsub,(int)iact,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + if (iact == 1) { +/* MOVE TO A SON DIRECTORY. */ + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__2, &(*iplist)->idir, my_block2, &iii); + lenold = my_block2->jlon[iii-1]; + if (lenold == -1) lenold = 1; + ityold = my_block2->jtyp[iii-1]; + if (lenold == 0) { +/* CREATE A NEW SCALAR DIRECTORY EXTENT ON THE XSM FILE. */ + if ((*iplist)->impf == 2) { + printf("new directory name=%s\n",namp); + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(4).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2->jlon[iii-1] = -1; + my_block2->jtyp[iii-1] = 0; + my_block2->iofs[iii-1] = my_block2->ioft; + idir = my_block2->iofs[iii-1]; + my_block2->ioft += klong; + xsmdir(&c__2, my_block2); + my_block2->iroot = my_block2->idir; + strcpy(my_block2->mynam,namp); + my_block2->idir = my_block2->iofs[iii-1]; + my_block2->nmt = 0; + my_block2->link = my_block2->idir; + my_block2->modif = 1; + } else if (lenold == 1 && ityold == 0) { + idir = my_block2->iofs[iii-1]; + } else if (ityold != 0) { + sprintf(AbortString,"%s: BLOCK '%s' IS NOT A DIRECTORY OF THE XSM FILE '%.60s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + iofset = (xsm *) malloc(sizeof(*iofset)); + +/* COPY BLOCK1 */ + iofset->header = (*iplist)->header; + strcpy(iofset->hname,(*iplist)->hname); + iofset->listlen = -1; + iofset->impf = (*iplist)->impf; + iofset->idir = (*iplist)->idir; + iofset->ibloc = (*iplist)->ibloc; + iofset->icang = (*iplist)->icang; + iofset->icang2 = (*iplist)->icang2; + iofset->father = (*iplist)->father; + + xsmkep(iofset->icang, c__1, &iofset); + iofset->idir = idir; + iofset->father = *iplist; + *iplist = iofset; + } else if (iact == 0 || iact == 2) { +/* MOVE BACK TO THE ROOT OR PARENT DIRECTORY. */ +L50: + my_block2 = (*iplist)->ibloc; + if (my_block2->modif == 1) xsmdir(&c__2, my_block2); + if (my_block2->idir != (*iplist)->idir) { +/* SWITCH TO THE CORRECT ACTIVE DIRECTORY (BLOCK 2). */ + my_block2->idir = (*iplist)->idir; + xsmdir(&c__1, my_block2); + } + if (my_block2->iroot == -1) { + if (iact == 0) { + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: WRONG HEADER(1).",nomsub); + xabort_c(AbortString); + } + return; + } + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS ALREADY ON ROOT DIRECTORY.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + strcpy(nomC,my_block2->mynam); + iofset = *iplist; + *iplist = (*iplist)->father; + xsmrep(nomC, &c__1, &(*iplist)->idir, my_block2, &iii); + if (iii == 0) { + sprintf(AbortString,"%s: UNABLE TO STEP DOWN ON FATHER RECORD '%s' FOR XSM FILE '%.60s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + iofpre = iofset; + xsmkep((*iplist)->icang, c__2, &iofpre); + free(iofset); + if (iact == 0 && (*iplist)->idir != iprim) { + goto L50; + } else if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: WRONG HEADER(2).",nomsub); + xabort_c(AbortString); + } + } + return; +} + +void xsmdid_c(xsm **iplist, const char *namp, xsm **jplist) +/* + *----------------------------------------------------------------------- + * + * create/access a daughter associative table in a father table. + * + * input parameters: + * iplist : address of the father table. + * namp : character*12 name of the daughter associative table. + * + * output parameter: + * jplist : address of the daughter associative table. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmdid_c"; + block2 *my_block2; + int_32 iii, lenold, idir=0, ityold; + xsm *iofset; + + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__2, &(*iplist)->idir, my_block2, &iii); + lenold = my_block2->jlon[iii-1]; + ityold = my_block2->jtyp[iii-1]; + if (lenold == 0) { +/* CREATE A NEW SCALAR DIRECTORY EXTENT ON THE XSM FILE. */ + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(5).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2->jlon[iii-1] = -1; + my_block2->jtyp[iii-1] = 0; + my_block2->iofs[iii-1] = my_block2->ioft; + idir = my_block2->iofs[iii-1]; + my_block2->ioft += klong; + xsmdir(&c__2, my_block2); + my_block2->iroot = my_block2->idir; + strcpy(my_block2->mynam,namp); + my_block2->idir = my_block2->iofs[iii-1]; + my_block2->nmt = 0; + my_block2->link = my_block2->idir; + my_block2->modif = 1; + } else if (lenold == -1 && ityold == 0) { + idir = my_block2->iofs[iii-1]; + } else { + sprintf(AbortString,"%s: BLOCK '%s' IS NOT AN ASSOCIATIVE TABLE OF THE XSM FILE '%.60s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + iofset = (xsm *) malloc(sizeof(*iofset)); + *jplist = iofset; + +/* COPY BLOCK1 */ + (*jplist)->header = (*iplist)->header; + strcpy((*jplist)->hname,(*iplist)->hname); + (*jplist)->listlen = -1; + (*jplist)->impf = (*iplist)->impf; + (*jplist)->idir = idir; + (*jplist)->ibloc = (*iplist)->ibloc; + (*jplist)->icang = (*iplist)->icang; + (*jplist)->icang2 = (*iplist)->icang2; + (*jplist)->father = *iplist; + xsmkep((*iplist)->icang, c__1, &iofset); + return; +} + +void xsmlid_c(xsm **iplist, const char *namp, int_32 ilong, xsm **jplist) +/* + *----------------------------------------------------------------------- + * + * create/access the hierarchical structure of a list in a xsm file. + * + * input parameters: + * iplist : address of the father table. + * namp : character*12 name of the daughter list. + * ilong : dimension of the daughter list. + * + * output parameter: + * jplist : address of the daughter list. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmlid_c"; + char nomC[13]; + block2 *my_block2; + int_32 iii, irc, irc2, lenold, idir=0, i, idiold, ityold, iroold, *iivec; + xsm *iofset; + + if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if (ilong <= 0) { + sprintf(AbortString,"%s: INVALID LENGTH (%d) FOR NODE '%s' IN THE XSM FILE '%.60s'.", + nomsub,(int)ilong,namp,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2=(*iplist)->ibloc; + xsmrep(namp, &c__2, &(*iplist)->idir, my_block2, &iii); + lenold = my_block2->jlon[iii-1]; + ityold = my_block2->jtyp[iii-1]; + if ((ilong > lenold && ityold == 10) || lenold == 0) { +/* CREATE ILONG-LENOLD NEW LIST EXTENTS ON THE XSM FILE. */ + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(6).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2->jlon[iii-1] = ilong; + my_block2->jtyp[iii-1] = 10; + idiold = my_block2->iofs[iii-1]; + my_block2->iofs[iii-1] = my_block2->ioft; + idir = my_block2->iofs[iii-1]; + my_block2->ioft += ilong; + iroold = my_block2->idir; + xsmdir(&c__2, my_block2); + iivec = (int_32 *) malloc(ilong * sizeof(*iivec)); + if (lenold > 0) { + irc = kdiget_c(my_block2->ifile, iivec, idiold, lenold); + if (irc != 0) goto L110; + } + for (i = abs(lenold) + 1; i <= ilong; ++i) { + iivec[i-1] = my_block2->ioft; + my_block2->iroot = iroold; + strcpy(my_block2->mynam,namp); + my_block2->nmt = 0; + my_block2->idir = my_block2->ioft; + my_block2->ioft += klong; + my_block2->link = my_block2->idir; + xsmdir(&c__2, my_block2); + } + irc = kdiput_c(my_block2->ifile, iivec, idir, ilong); + if (irc != 0) goto L100; + free(iivec); + } else if (ilong <= lenold && ityold == 10) { + ilong = lenold; + idir = my_block2->iofs[iii-1]; + } else if (ityold != 10) { + sprintf(AbortString,"%s: BLOCK '%s' IS NOT A LIST OF THE XSM FILE '%.60s'.", + nomsub,namp,(*iplist)->hname); + xabort_c(AbortString); + } + iivec = (int_32 *) malloc(ilong * sizeof(*iivec)); + irc = kdiget_c(my_block2->ifile, iivec, idir, ilong); + if (irc != 0) goto L110; + *jplist = (xsm *) malloc(ilong * sizeof(**jplist)); + for (i = 0; i < ilong; ++i) { + iofset = *jplist + i; + +/* COPY BLOCK1 */ + iofset->header = (*iplist)->header; + strcpy(iofset->hname,(*iplist)->hname); + iofset->listlen = 0; + iofset->impf = (*iplist)->impf; + iofset->idir = iivec[i]; + iofset->ibloc = (*iplist)->ibloc; + iofset->icang = (*iplist)->icang; + iofset->icang2 = (*iplist)->icang2; + iofset->father = *iplist; + } + (*jplist)->listlen = ilong; + xsmkep((*iplist)->icang, c__1, jplist); + free(iivec); + return; + +L100: + irc2=kdicl_c(my_block2->ifile, c__1); + strcpy(nomC,(my_block2->ifile)->nom); + if (irc2 != 0) printf("%s: kdicl_c ERROR NB. %d ON XSM FILE '%s'.\n",nomsub,(int)irc2,nomC); + sprintf(AbortString,"%s: kdiput_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); +L110: + irc2=kdicl_c(my_block2->ifile, c__1); + if (irc2 != 0) printf("%s: kdicl_c ERROR NB. %d ON XSM FILE '%s'.\n",nomsub,(int)irc2,nomC); + strcpy(nomC,(my_block2->ifile)->nom); + sprintf(AbortString,"%s: kdiget_c ERROR NB. %d ON XSM FILE '%s'.",nomsub,(int)irc,nomC); + xabort_c(AbortString); +} + +void xsmgpd_c(xsm **iplist, const char *namp, int_32 **iofdum) +/* + *----------------------------------------------------------------------- + * + * get a malloc pointer for an entry in the xsm file. + * + * input parameters: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * + * output parameter: + * iofdum : malloc pointer to the xsm entry named namp. + * + *----------------------------------------------------------------------- + */ +{ + db2 *ipkep2; + int_32 i, i0, ilong, itylcm, n; + xsmlen_c(iplist,namp,&ilong,&itylcm); + if(itylcm == 4 || itylcm == 6) ilong = 2*ilong; + ipkep2 = (*iplist)->icang2; + n = ipkep2->nad; + for (i = n; i >= 1; --i) { + if (ipkep2->iref[i-1] == iofdum) { + i0 = i; + goto L10; + } + } + goto L20; +L10: + if (ilong == ipkep2->lg[i0-1]) { + *iofdum = ipkep2->iofset[i0-1]; + xsmget_c(iplist,namp,*iofdum); + return; + } + free(ipkep2->iofset[i0-1]); /* rlsara_c() */ + for (i = i0; i <= n-1; ++i) { + ipkep2->iref[i-1]=ipkep2->iref[i]; + ipkep2->iofset[i-1]=ipkep2->iofset[i]; + ipkep2->lg[i-1]=ipkep2->lg[i]; + } + --ipkep2->nad; + n = ipkep2->nad; +L20: + *iofdum = (int_32 *)malloc(ilong*sizeof(int_32)); /* setara_c(ilong) */ + xsmget_c(iplist,namp,*iofdum); + if (n + 1 > ipkep2->maxad) { + int_32 ***my_iref, **my_iofset, *my_lg; + ipkep2->maxad += maxit; + my_iref = (int_32 ***) malloc((ipkep2->maxad)*sizeof(*my_iref)); + my_iofset = (int_32 **) malloc((ipkep2->maxad)*sizeof(*my_iofset)); + my_lg = (int_32 *) malloc((ipkep2->maxad)*sizeof(*my_lg)); + for (i = 0; i < n; ++i) { + my_iref[i]=ipkep2->iref[i]; + my_iofset[i]=ipkep2->iofset[i]; + my_lg[i]=ipkep2->lg[i]; + } + if (n > 0) { + free(ipkep2->iref); + free(ipkep2->iofset); + free(ipkep2->lg); + } + ipkep2->iref=my_iref; + ipkep2->iofset=my_iofset; + ipkep2->lg=my_lg; + } + ipkep2->iref[n] = iofdum; + ipkep2->iofset[n] = *iofdum; + ipkep2->lg[n] = ilong; + ++ipkep2->nad; + return; +} + +void xsmppd_c(xsm **iplist, const char *namp, int_32 ilong, int_32 itype, int_32 *iofdum) +/* + *----------------------------------------------------------------------- + * + * add a new malloc pointer entry in the xsm file. + * + * input parameter: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * ilong : number of information elements stored in the current block. + * itype : type of information elements stored in the current block. + * 0: directory 1: integer + * 2: single precision 3: character*4 + * 4: double precision 5: logical + * 6: complex + * iofdum : malloc pointer of the first information element. + * + *----------------------------------------------------------------------- + */ +{ + db2 *ipkep2; + int_32 i, i0, n; + xsmput_c(iplist,namp,ilong,itype,iofdum); + ipkep2 = (*iplist)->icang2; + n = ipkep2->nad; + for (i = n; i >= 1; --i) { + if (ipkep2->iofset[i-1] == iofdum) { + i0 = i; + goto L10; + } + } + goto L20; +L10: + for (i = i0; i <= n-1; ++i) { + ipkep2->iref[i-1]=ipkep2->iref[i]; + ipkep2->iofset[i-1]=ipkep2->iofset[i]; + ipkep2->lg[i-1]=ipkep2->lg[i]; + } + --ipkep2->nad; + if (ipkep2->nad == 0) { + free(ipkep2->iref); + free(ipkep2->iofset); + free(ipkep2->lg); + ipkep2->maxad = 0; + ipkep2->iref = NULL; + ipkep2->iofset = NULL; + ipkep2->lg = NULL; + } +L20: + free(iofdum); /* rlsara_c(iofdum) */ + iofdum = NULL; + return; +} |