Initial commit from Polytechnique Montreal

1 files changed, 685 insertions, 0 deletions

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 */