Initial commit from Polytechnique Montreal

1 files changed, 725 insertions, 0 deletions

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;
+}