From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Ganlib/src/kdrprm.c | 994 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 994 insertions(+) create mode 100644 Ganlib/src/kdrprm.c (limited to 'Ganlib/src/kdrprm.c') 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 +#include +#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 */ -- cgit v1.2.3