Initial commit from Polytechnique Montreal

1 files changed, 772 insertions, 0 deletions

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