/*****************************************/ /* CLE-2000 API */ /* AUTHOR OF FORTRAN VERSION: R. Roy */ /* AUTHOR: A. Hebert ; 24/04/09 */ /*****************************************/ #include #include #include #include "cle2000.h" #include "header.h" #define sign(A) (A > 0 ? 1 : (A < 0 ? -1 : 0)) #define index_f(A, B) (strstr(A, B) == NULL ? 0 : strstr(A, B) - A + 1) #define nlogkw 15 #define ndimst 128 #define ifinal 122 #define nmawrd 60 static kdi_file *iunito = NULL; static int_32 ivabeg = 0; static int_32 ivaend = 0; static int_32 ioulst = 0; static int_32 ilogin = 0; static FILE *iwrite = NULL; static char hwrite[73] = " "; static int_32 idblst = 0; static int_32 irecor = 0; static int_32 ninput = 0; static int_32 nwords = 0; static int_32 iwords = 0; static int_32 nstput = 0; static int_32 nstlvl = 0; static int_32 indrgt[ndimst], irclvl[ndimst], irclft[ndimst], ircput[ndimst]; static int_32 idebwd[nmawrd+1], ifinwd[nmawrd+1], jndlec[nmawrd]; static char myreco[121]; static char cl2000[12] = "CLE2000(V3)"; static int_32 text_len = 72; /* CAUTION: text must be declared as text[73] in the calling function*/ static int_32 intstk[ndimst]; static float_32 relstk[ndimst]; static char chrstk[ndimst][121]; static double_64 dblstk[ndimst]; static int_32 logstk[ndimst]; void redget_c(int_32 *ityp, int_32 *nitma, float_32 *flott, char text[73], double_64 *dflot) { static char *clogbg[] = {"INTEGER", "REAL", "STRING", "DOUBLE", "LOGICAL", "EVALUATE", "ECHO", "ELSEIF", "IF", "WHILE", "UNTIL", "ENDWHILE", "REPEAT", "ELSE", "ENDIF"}; static char *clognd[] = {";", ";", ";", ";", ";", ";", ";", "THEN", "THEN", "DO", ";", ";", "REPEAT", "ELSE", ";"}; int_32 i, ilines, jlines=0, jlevel=0, jrecor, iretcd, iloop1, lrgtst=0, nstlft=0, imedrc, iofset, idefkw=0, nstrgt=0; int_32 maskck[nmaskc], ipacki[nmaskc]; char cparin[17], cparav[13], chrend[13], cdatav[121], cdatin[121]; int_32 ilengv, indlec, idatin, indlin; float_32 adatin; double_64 ddatin; char *nomsub="redget_c"; /* TAKE ANY LEVEL AS INPUT */ int_32 ilevel = -1; /* L01> ***LOOP*** OVER WORDS (BEGIN) */ L10: ++iwords; if (iwords > nwords) { int_32 jbiprv; /* L02> ***LOOP*** OVER RECORDS (BEGIN) */ L20: ++irecor; if (irecor > ninput) { if (ninput == 0) { /* REDGET IS CLOSED */ *ityp = 10; if (idblst > 0 && iwrite != NULL) { sprintf(myreco,"READER IS CLOSED ON FILE"); fprintf(iwrite,".|%-120s|.\n",myreco); } } else { int_32 i; *ityp = 9; if (idblst > 0 && iwrite != NULL) { sprintf(myreco,"QUIT \"DEBUG\" "); fprintf(iwrite,".|%-120s|.\n",myreco); } for ( i = 0; i < 120; i++) myreco[i]='-'; myreco[120]='\0'; fprintf(iwrite,". %s .\n",myreco); } return; } /* READ A NEW RECORD */ iofset = (irecor-1) * lrclen; iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); if (iretcd != 0) goto L8000; strcpy(cparin, record1.cparin); strcpy(myreco, record1.myreco); ilines = record1.ilines; jlevel = record1.ilevel; jrecor = record1.irecor; for (i = 0; i < nmaskc; i++) maskck[i] = record1.maskck[i]; for (i = 0; i < nmaskc; i++) ipacki[i] = record1.ipacki[i]; if (ilevel >= 0 && jlevel != ilevel) goto L20; /* L02> ***LOOP*** OVER RECORDS (ACCEPTED) */ /* RECORD IS ACCEPTED, PRINT WHEN REQUESTED */ if (idblst <= 0 && jlevel == 0) { if (ioulst > 0 && iwrite != NULL) fprintf(iwrite,"<|%-120s|<%04d\n",myreco,(int)ilines); } else if (idblst > 0 && iwrite != NULL) { if (jlevel == 0) { fprintf(iwrite,"<|%-120s|<%04d\n",myreco,(int)ilines); } else { fprintf(iwrite,".|%-120s|.%04d\n",myreco,(int)ilines); } } /* BEGIN: MASK RECOVERY */ jbiprv = 0; iwords=1; nwords = 1; for (iloop1=0; iloop1<120; ++iloop1) { int_32 jloop2 = iloop1/24; int_32 jbicur = maskck[jloop2] % 2; iwords += jbiprv * (1-jbicur); idebwd[nwords-1] = iloop1; ifinwd[iwords-1] = iloop1; nwords += jbicur * (1-jbiprv); jbiprv = jbicur; maskck[jloop2] /= 2; } --nwords; /* END: MASK RECOVERY */ /* THIS IS NOW THE FIRST WORD */ iwords = 1; if (jlevel != 0) { /* L03> THIS IS A NEW *CLE-2000* RECORD (BEGIN) */ if (strcmp(cparin, " ") != 0) { /* L04> TREAT SIGNIFICANT 1ST-WORD OF CLE-2000 STATEMENT (BEGIN) */ nstlft = 0; nstrgt = 0; for (iloop1 = 0; iloop1 < nlogkw; ++iloop1) { if (strcmp(clogbg[iloop1], cparin) == 0) ilogin = iloop1+1; } lrgtst = ilogin >= 7 && ilogin <= 11; strcpy(chrend, clognd[ilogin-1]); /* KEYWORDS: *IF+/+WHILE+/+UNTIL* */ if (ilogin == 9 || ilogin == 10 || ilogin == 11) { ++nstlvl; if (nstlvl > ndimst) goto L9002; irclvl[nstlvl - 1] = jrecor - 1; /* KEYWORDS: *ELSEIF+/+ELSE* */ } else if (ilogin == 8 || ilogin == 14) { if (ilevel == -1) { if (nstlvl == 0) goto L9001; irecor = irclvl[nstlvl-1]; nwords = 1; } else { ilevel = -1; } /* KEYWORD: *ENDWHILE* */ } else if (ilogin == 12) { if (ilevel == -1) { irecor = jrecor - 1; nwords = 1; } else { ilevel = -1; } /* KEYWORD: *ENDIF* */ } else if (ilogin == 15) { ilevel = -1; if (nstlvl == 0) goto L9001; --nstlvl; /* KEYWORD: *ECHO* */ } else if (ilogin == 7) { jlines = ilines; } /* CYCLE ON WORDS WITHOUT UNPACKING (ONE WORD ONLY) */ if (nwords == iwords) goto L10; for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { /* L05> UNPACK INDLEC ONLY IF MORE THAN 1 WORD (BEGIN) */ int_32 jloop2 = ((iloop1 << 1) + 23) / 24; jndlec[iloop1-1] = ipacki[jloop2-1] % 4 + 1; ipacki[jloop2-1] /= 4; /* L05> UNPACK INDLEC ONLY IF MORE THAN 1 WORD (END) */ } /* L04> TREAT SIGNIFICANT 1ST-WORD OF CLE-2000 STATEMENTS (END) */ /* RETURN TO NEXT WORD */ goto L10; } /* L03> THIS IS A NEW *CLE-2000* RECORD (END) */ } else { /* L03> RECORD OUTSIDE *CLE-2000* (BEGIN) */ ilogin = 0; /* L03> RECORD OUTSIDE *CLE-2000* (END) */ } for (iloop1 = 1; iloop1 <= nwords; ++iloop1) { /* L03> RECORD OUTSIDE *CLE-2000* OR NEW *CLE-2000* RECORD, */ /* BUT CONTINUATION STATEMENT (BEGIN) THEN, ALWAYS UNPACK INDLEC */ int_32 jloop2 = ((iloop1 << 1) + 23) / 24; jndlec[iloop1-1] = ipacki[jloop2-1] % 4 + 1; ipacki[jloop2-1] /= 4; /* L03> RECORD OUTSIDE *CLE-2000* OR NEW *CLE-2000* RECORD, */ /* BUT CONTINUATION STATEMENT (END) */ } /* L02> ***LOOP*** OVER RECORDS (END) */ } /* L01> ***LOOP*** OVER WORDS (ACCEPTED) */ /* DETERMINE NEXT WORD */ ilengv = ifinwd[iwords-1] - idebwd[iwords-1] + 1; indlec = jndlec[iwords-1]; if (indlec == 3) { for ( i = 0; i < ilengv; i++) cdatav[i]=myreco[idebwd[iwords-1]+i]; cdatav[ilengv] = '\0'; } else if (indlec == 1) { for ( i = 0; i < ilengv; i++) cdatin[i]=myreco[idebwd[iwords-1]+i]; cdatin[ilengv] = '\0'; sscanf(cdatin, "%d", (int *)&idatin); } else if (indlec == 2) { for ( i = 0; i < ilengv; i++) cdatin[i]=myreco[idebwd[iwords-1]+i]; cdatin[ilengv] = '\0'; sscanf(cdatin, "%e", &adatin); } else { int_32 id; for ( i = 0; i < ilengv; i++) cdatin[i]=myreco[idebwd[iwords-1]+i]; cdatin[ilengv] = '\0'; id = index_f(cdatin, "D"); if (id > 0) cdatin[id-1] = 'E'; sscanf(cdatin, "%le", &ddatin); } if (ilogin == 0) { /* L02> WORDS OUTSIDE *CLE2000* STATEMENTS: HIT AND RUN... */ if (indlec == 3) { /* L03> STRING, <<.>> OR >>.<< TREATMENT */ int_32 lrdput = strncmp(cdatav, ">>", 2) == 0; if (strncmp(cdatav, "<<", 2) == 0 || lrdput) { int_32 ilowrc = ivabeg; int_32 ihigrc = ivaend; /* L04> CASES <<.>> OR >>.<< */ /* GET VARIABLE WITH A BINARY SEARCH IN SORTED FILE */ /* SET UPPER AND LOWER BOUNDS */ strcpy(cparin, &cdatav[2]); memcpy(cparav, cparin, ilengv-4); cparav[ilengv-4] = '\0'; L11: imedrc = (ihigrc+ilowrc) / 2; iofset = (imedrc-1) * lrclen; iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); if (iretcd != 0) goto L9023; strcpy(cparin, record2.cparin); strcpy(cdatin, record2.cdatin); indlin = record2.indlin; idatin = record2.idatin; adatin = record2.adatin; ddatin = record2.ddatin; if (iretcd != 0) goto L9023; if (strcmp(cparin, cparav) == 0) { if (lrdput) { int_32 ilengt = min(text_len, 12); /* KEEP RECORD NUMBER FOR *REDPUT* */ ++nstput; if (nstput > ndimst) goto L9004; ircput[nstput-1] = imedrc; /* MAKE THE VARIABLE UNDEFINED */ indlin = -abs(indlin); record2.indlin = indlin; iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); if (iretcd != 0) goto L9023; /* SEND BACK NEGATIVE TYPE AND VARIABLE NAME TO THE APPLICATION */ *ityp = indlin; memcpy(text, cparin, ilengt); text[ilengt]='\0'; } else { if (indlin <= 0) goto L9008; /* SEND BACK TYPE AND DEFINED VALUES */ *ityp = indlin; if (*ityp == 1 || *ityp == 5) { *nitma = idatin; } else if (*ityp == 2) { *flott = adatin; } else if (*ityp == 3) { int_32 ilengt = min(text_len, 120); *nitma = min(idatin,ilengt); memcpy(text, cdatin, ilengt); text[ilengt]='\0'; } else if (*ityp == 4) { *dflot = ddatin; } } } else if (strcmp(cparin, cparav) < 0) { ilowrc = imedrc; goto L11; } else { ihigrc = imedrc; goto L11; } } else if (cdatav[0] == '\'') { int_32 ilengt = min(text_len, 120); if (ilengv > 2) { memcpy(cdatin, &cdatav[1], ilengv-2); cdatin[ilengv-2]='\0'; } *ityp = 3; *nitma = min(ilengv-2, ilengt); memcpy(text, cdatin, ilengt); text[ilengt] = '\0'; } else { int_32 ilengt = min(text_len, 120); *ityp = 3; *nitma = min(ilengv,ilengt); memcpy(text, cdatav, ilengt); text[ilengt] = '\0'; } } else { /* L03> OTHER THAN STRING TREATMENT */ *ityp = indlec; if (*ityp == 1 || *ityp == 5) { *nitma = idatin; } else if (*ityp == 2) { *flott = adatin; } else if (*ityp == 4) { *dflot = ddatin; } } return; /* L02> WORDS OUTSIDE *CLE2000* STATEMENTS: END. */ } else { /* L02> PROCESS *CLE2000* STATEMENTS: DRINK, DRIVE (BEGIN) */ /* WATCH FOR STRINGS... */ /* L03> IF( INDLEC.EQ.3.AND.CDATAV(1:1).EQ.'"' )THEN */ if (indlec == 3 && cdatav[0] == '"') { ++nstrgt; indrgt[nstrgt-1] = indlec; if (ilengv > 2) { memcpy(chrstk[nstrgt-1], &cdatav[1], ilengv-2); chrstk[nstrgt-1][ilengv-2] = '\0'; } intstk[nstrgt-1] = ilengv-2; /* L03> ELSEIF( LRGTST )THEN */ } else if (lrgtst) { /* L04> IF( INDLEC.EQ.3 )THEN */ if (indlec == 3) { memcpy(cparav, cdatav, 12); cparav[12] = '\0'; /* L05> IF( CPARAV.EQ.CHREND )THEN */ if (strcmp(cparav, chrend) == 0) { /* TRUEWAY LEFT/RIGHT */ /* KEYWORDS: *int_32+/+REAL+/+STRING+/+DOUBLE+/+LOGICAL+/+EVALUATE* */ if (ilogin <= 6) { /* PUT VARIABLE VALUES */ L25: indlin = indrgt[nstlft-1]; imedrc = irclft[nstlft-1]; iofset = (imedrc-1) * lrclen; iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); if (iretcd != 0) goto L9023; strcpy(cdatin, record2.cdatin); idatin = record2.idatin; adatin = record2.adatin; ddatin = record2.ddatin; if (indlin == 1) { idatin = intstk[nstlft-1]; } else if (indlin == 2) { adatin = relstk[nstlft-1]; } else if (indlin == 3) { strcpy(cdatin, chrstk[nstlft-1]); idatin = intstk[nstlft-1]; } else if (indlin == 4) { ddatin = dblstk[nstlft-1]; } else if (indlin == 5) { if (logstk[nstlft - 1]) { idatin = 1; } else { idatin = -1; } } strcpy(record2.cdatin, cdatin); record2.indlin = indlin; record2.idatin = idatin; record2.adatin = adatin; record2.ddatin = ddatin; iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); if (iretcd != 0) goto L9023; --nstlft; if (nstlft != 0) goto L25; /* KEYWORD: *ECHO* (PRINTER UTILITY ) */ } else if (ilogin == 7) { char cprint[129]; int_32 ilgtpr=0, idepar=3; sprintf(cprint, ">|%-120s|>%04d", " ", (int)jlines); for (iloop1 = 0; iloop1 < nstrgt; ++iloop1) { indlin = indrgt[iloop1]; if (indlin == 1) { int_32 jloop2, indle2 = abs(intstk[iloop1]); for (jloop2 = 1; jloop2 <= 12; ++jloop2) { indle2 /= 10; if (indle2 == 0) { ilgtpr = jloop2; goto L302; } } L302: if (intstk[iloop1] < 0) ++ilgtpr; sprintf(cdatin, "%d", (int)intstk[iloop1]); } else if (indlin == 2) { ilgtpr = 13; sprintf(cdatin, "%13.6e", relstk[iloop1]); } else if (indlin == 3) { ilgtpr = intstk[iloop1]; strcpy(cdatin, chrstk[iloop1]); } else if (indlin == 4) { ilgtpr = 23; sprintf(cdatin, "%23.15E", dblstk[iloop1]); } else if (indlin == 5) { if (logstk[iloop1]) { ilgtpr = 6; const char *src = ".TRUE."; memcpy(cdatin, src, 6); cdatin[6] = '\0'; } else { ilgtpr = 7; const char *src = ".FALSE."; memcpy(cdatin, src, 7); cdatin[7] = '\0'; } } else if (indlin == -1) { ilgtpr = 3; const char *src = "?_I"; memcpy(cdatin, src, 3); cdatin[3] = '\0'; } else if (indlin == -2) { ilgtpr = 3; const char *src = "?_R"; memcpy(cdatin, src, 3); cdatin[3] = '\0'; } else if (indlin == -3) { ilgtpr = 3; const char *src = "?_S"; memcpy(cdatin, src, 3); cdatin[3] = '\0'; } else if (indlin == -4) { ilgtpr = 3; const char *src = "?_D"; memcpy(cdatin, src, 3); cdatin[3] = '\0'; } else if (indlin == -5) { ilgtpr = 3; const char *src = "?_L"; memcpy(cdatin, src, 3); cdatin[3] = '\0'; } else { goto L9007; } if (idepar + ilgtpr >= ifinal) { if (iwrite != NULL) fprintf(iwrite,"%s\n",cprint); sprintf(cprint, ">|%-120s|>%04d", " ", (int)jlines); idepar = 3; } memcpy(&cprint[idepar-1], cdatin, ilgtpr); cprint[120+8] = '\0'; idepar = idepar + ilgtpr + 1; if (idepar >= ifinal) { if (iwrite != NULL) fprintf(iwrite,"%s\n",cprint); sprintf(cprint, ">|%-120s|>%04d", " ", (int)jlines); idepar = 3; } } if (iwrite != NULL && idepar != 3) fprintf(iwrite,"%s\n",cprint); fflush(iwrite); /* KEYWORDS: *ELSEIF+/+IF* */ } else if (ilogin == 8 || ilogin == 9) { if (indrgt[nstrgt-1] != 5) goto L9006; if (logstk[nstrgt-1]) { ilevel = -1; } else { ilevel = jlevel; } /* KEYWORD: *UNTIL* */ } else if (ilogin == 11) { if (nstlvl == 0) goto L9001; if (indrgt[nstrgt-1] != 5) goto L9006; if (!logstk[nstrgt-1]) { irecor = irclvl[nstlvl-1]; iwords = nwords; } --nstlvl; /* KEYWORD: *WHILE* */ } else if (ilogin == 10) { if (nstlvl == 0) goto L9001; if (indrgt[nstrgt-1] != 5) goto L9006; if (!logstk[nstrgt-1]) { ilevel = jlevel; irecor = irclvl[nstlvl-1]; iwords = nwords; } --nstlvl; } } else { /* CHECK CONVERSION OPERATIONS */ if (strcmp(cparav, "R_TO_I") == 0) { indrgt[nstrgt-1] = sign(indrgt[nstrgt-1]); intstk[nstrgt-1] = (int_32) relstk[nstrgt-1]; } else if (strcmp(cparav, "D_TO_I") == 0) { indrgt[nstrgt-1] = sign(indrgt[nstrgt-1]); intstk[nstrgt-1] = (int_32) dblstk[nstrgt-1]; } else if (strcmp(cparav, "I_TO_R") == 0) { indrgt[nstrgt-1] = 2 * sign(indrgt[nstrgt-1]); relstk[nstrgt-1] = (float_32) intstk[nstrgt-1]; } else if (strcmp(cparav, "D_TO_R") == 0) { indrgt[nstrgt-1] = 2 * sign(indrgt[nstrgt-1]); relstk[nstrgt-1] = (float_32) dblstk[nstrgt-1]; } else if (strcmp(cparav, "I_TO_D") == 0) { indrgt[nstrgt-1] = 4 * sign(indrgt[nstrgt-1]); dblstk[nstrgt-1] = (double_64) intstk[nstrgt-1]; } else if (strcmp(cparav, "R_TO_D") == 0) { indrgt[nstrgt-1] = 4 * sign(indrgt[nstrgt-1]); dblstk[nstrgt-1] = (double_64) relstk[nstrgt-1]; } else if (strcmp(cparav, "I_TO_S") == 0) { indrgt[nstrgt-1] = 3 * sign(indrgt[nstrgt-1]); if (intstk[nstrgt-1] > 99999999) goto L9013; if (intstk[nstrgt-1] < -9999999) goto L9014; sprintf(chrstk[nstrgt-1], "%d", (int)intstk[nstrgt-1]); intstk[nstrgt-1] = (int)strlen(chrstk[nstrgt-1]); } else if (strcmp(cparav, "I_TO_S4") == 0) { indrgt[nstrgt-1] = 3 * sign(indrgt[nstrgt-1]); if (intstk[nstrgt-1] > 99999999) goto L9013; if (intstk[nstrgt-1] < -9999999) goto L9014; sprintf(chrstk[nstrgt-1], "%04d", (int)intstk[nstrgt-1]); intstk[nstrgt-1] = (int)strlen(chrstk[nstrgt-1]); /* CHECK UNARY OPERATIONS */ } else if (strcmp(cparav, "NOT") == 0) { logstk[nstrgt-1] = !logstk[nstrgt-1]; } else if (strcmp(cparav, "CHS") == 0) { if (indrgt[nstrgt-1] == 1) { intstk[nstrgt-1] = -intstk[nstrgt-1]; } else if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = -relstk[nstrgt-1]; } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = -dblstk[nstrgt-1]; } } else if (strcmp(cparav, "ABS") == 0) { if (indrgt[nstrgt-1] == 1 && intstk[nstrgt-1] < 0) { intstk[nstrgt-1] = -intstk[nstrgt-1]; } else if (indrgt[nstrgt-1] == 2 && relstk[nstrgt-1] < 0.f) { relstk[nstrgt-1] = -relstk[nstrgt-1]; } else if (indrgt[nstrgt-1] == 4 && dblstk[nstrgt-1] < 0.) { dblstk[nstrgt-1] = -dblstk[nstrgt-1]; } } else if (strcmp(cparav, "EXP") == 0) { if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = exp(relstk[nstrgt-1]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = exp(dblstk[nstrgt-1]); } } else if (strcmp(cparav, "LN") == 0) { if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = log(relstk[nstrgt-1]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = log(dblstk[nstrgt-1]); } } else if (strcmp(cparav, "SIN") == 0) { if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = sin(relstk[nstrgt-1]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = sin(dblstk[nstrgt-1]); } } else if (strcmp(cparav, "COS") == 0) { if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = cos(relstk[nstrgt-1]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = cos(dblstk[nstrgt-1]); } } else if (strcmp(cparav, "TAN") == 0) { if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = tan(relstk[nstrgt-1]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = tan(dblstk[nstrgt-1]); } } else if (strcmp(cparav, "ARCSIN") == 0) { if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = asin(relstk[nstrgt-1]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = asin(dblstk[nstrgt-1]); } } else if (strcmp(cparav, "ARCCOS") == 0) { if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = acos(relstk[nstrgt-1]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = acos(dblstk[nstrgt-1]); } } else if (strcmp(cparav, "ARCTAN") == 0) { if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = atan(relstk[nstrgt-1]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = atan(dblstk[nstrgt-1]); } } else if (strcmp(cparav, "SQRT") == 0) { if (indrgt[nstrgt-1] == 2) { if (relstk[nstrgt-1] < 0.f) { idefkw = 2; goto L9009; } relstk[nstrgt-1] = sqrt(relstk[nstrgt-1]); } else if (indrgt[nstrgt-1] == 4) { if (dblstk[nstrgt-1] < 0.) { idefkw = 4; goto L9009; } dblstk[nstrgt-1] = sqrt(dblstk[nstrgt-1]); } /* CHECK BINARY OPERATIONS */ } else if (strcmp(cparav, "_MIN_") == 0) { --nstrgt; indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); if (indrgt[nstrgt-1] == 1) { intstk[nstrgt-1] = min(intstk[nstrgt-1], intstk[nstrgt]); } else if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = min(relstk[nstrgt-1], relstk[nstrgt]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = min(dblstk[nstrgt-1], dblstk[nstrgt]); } } else if (strcmp(cparav, "_MAX_") == 0) { --nstrgt; indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); if (indrgt[nstrgt-1] == 1) { intstk[nstrgt-1] = max(intstk[nstrgt-1], intstk[nstrgt]); } else if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] = max(relstk[nstrgt-1], relstk[nstrgt]); } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] = max(dblstk[nstrgt-1], dblstk[nstrgt]); } } else if (strcmp(cparav, "_TRIM_") == 0) { --nstrgt; int_32 ndig = intstk[nstrgt]; if (indrgt[nstrgt-1] == 2) { int_32 nx = (int_32)floor(log10(relstk[nstrgt-1]))-ndig; float_32 rrr = relstk[nstrgt-1]*pow(10.0,(float_32)(-nx)); relstk[nstrgt-1] = floor(rrr)*pow(10.0,(float_32)(nx)); } else if (indrgt[nstrgt-1] == 4) { int_32 nx = (int_32)floor(log10(dblstk[nstrgt-1]))-ndig; double_64 ddd = dblstk[nstrgt-1]*pow(10.0,(double_64)(-nx)); dblstk[nstrgt-1] = floor(ddd)*pow(10.0,(double_64)(nx)); } } else if (strcmp(cparav, "+") == 0) { --nstrgt; indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); if (indrgt[nstrgt-1] == 1) { intstk[nstrgt-1] += intstk[nstrgt]; } else if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] += relstk[nstrgt]; } else if (indrgt[nstrgt-1] == 3) { char cdata1[73], cdata2[73]; int_32 ileng2 = intstk[nstrgt-1]; int_32 ileng1 = intstk[nstrgt]; strcpy(cdata2, chrstk[nstrgt-1]); strcpy(cdata1, chrstk[nstrgt]); if (ileng1 == 0) { if (ileng2 == 0) { strcpy(chrstk[nstrgt-1], " "); } else { strcpy(chrstk[nstrgt-1], cdata2); } } else if (ileng2 == 0) { strcpy(chrstk[nstrgt-1], cdata1); } else if (ileng1 + ileng2 <= 72) { strcpy(chrstk[nstrgt-1], cdata2); strcat(chrstk[nstrgt-1], cdata1); } else { printf("%s: STRING IS LONGER THAN 72 CHRS", nomsub); goto L9012; } intstk[nstrgt-1] = ileng1 + ileng2; } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] += dblstk[nstrgt]; } else if (indrgt[nstrgt-1] == 5) { logstk[nstrgt-1] = logstk[nstrgt-1] || logstk[nstrgt]; } } else if (strcmp(cparav, "-") == 0) { --nstrgt; indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); if (indrgt[nstrgt-1] == 1) { intstk[nstrgt-1] -= intstk[nstrgt]; } else if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] -= relstk[nstrgt]; } else if (indrgt[nstrgt-1] == 3) { char cdata1[73], cdata2[73]; int_32 ileng2 = intstk[nstrgt-1]; int_32 ileng1 = intstk[nstrgt]; if (ileng1 != 0) { if (ileng2 < ileng1) { printf("%s: IMPOSSIBLE TO - A SUBSTRING WITH LENGTH LESS THAN STRING", nomsub); goto L9012; } strcpy(cdata2, chrstk[nstrgt-1]); strcpy(cdata1, chrstk[nstrgt]); if (strncmp(&cdata2[ileng2-ileng1], cdata1, ileng1) != 0) { printf("%s: IMPOSSIBLE TO - A SUBSTRING NOT AT THE END OF A STRING", nomsub); goto L9012; } else if (ileng1 == ileng2) { strcpy(chrstk[nstrgt-1], " "); } else { memcpy(chrstk[nstrgt-1], cdata2, ileng2-ileng1); chrstk[nstrgt-1][ileng2-ileng1] = '\0'; } intstk[nstrgt-1] = ileng2-ileng1; } } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] -= dblstk[nstrgt]; } else if (indrgt[nstrgt-1] == 5) { logstk[nstrgt-1] = logstk[nstrgt-1] || !logstk[nstrgt]; } } else if (strcmp(cparav, "*") == 0) { --nstrgt; indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); if (indrgt[nstrgt-1] == 1) { intstk[nstrgt-1] *= intstk[nstrgt]; } else if (indrgt[nstrgt-1] == 2) { relstk[nstrgt-1] *= relstk[nstrgt]; } else if (indrgt[nstrgt-1] == 4) { dblstk[nstrgt-1] *= dblstk[nstrgt]; } else if (indrgt[nstrgt-1] == 5) { logstk[nstrgt-1] = logstk[nstrgt-1] && logstk[nstrgt]; } } else if (strcmp(cparav, "%") == 0) { --nstrgt; indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); if (indrgt[nstrgt-1] == 1) { if (intstk[nstrgt] == 0) { idefkw = 1; goto L9010; } intstk[nstrgt-1] %= intstk[nstrgt]; } } else if (strcmp(cparav, "/") == 0) { --nstrgt; indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); if (indrgt[nstrgt-1] == 1) { if (intstk[nstrgt] == 0) { idefkw = 1; goto L9010; } intstk[nstrgt-1] /= intstk[nstrgt]; } else if (indrgt[nstrgt-1] == 2) { if (relstk[nstrgt] == 0.f) { idefkw = 2; goto L9010; } relstk[nstrgt-1] /= relstk[nstrgt]; } else if (indrgt[nstrgt-1] == 4) { if (dblstk[nstrgt] == 0.) { idefkw = 4; goto L9010; } dblstk[nstrgt-1] /= dblstk[nstrgt]; } else if (indrgt[nstrgt-1] == 5) { logstk[nstrgt-1] = logstk[nstrgt-1] && !logstk[nstrgt]; } } else if (strcmp(cparav, "**") == 0) { --nstrgt; indrgt[nstrgt-1] = min(indrgt[nstrgt-1], indrgt[nstrgt]); if (indrgt[nstrgt-1] == 1) { if (intstk[nstrgt-1] < 0 && intstk[nstrgt] < 0) { idefkw = 1; goto L9011; } intstk[nstrgt-1] = pow(intstk[nstrgt-1], intstk[nstrgt]); } else if (indrgt[nstrgt-1] == 2) { if (relstk[nstrgt-1] < 0.f && relstk[nstrgt] < 0.f) { idefkw = 2; goto L9011; } relstk[nstrgt-1] = pow(relstk[nstrgt-1], relstk[nstrgt]); } else if (indrgt[nstrgt-1] == 4) { if (dblstk[nstrgt-1] < 0. && dblstk[nstrgt] < 0.) { idefkw = 4; goto L9011; } dblstk[nstrgt-1] = pow(dblstk[nstrgt-1], dblstk[nstrgt]); } } else if (strcmp(cparav, "<") == 0) { --nstrgt; indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); indrgt[nstrgt-1] = 5; if (indlin == 1) { logstk[nstrgt-1] = intstk[nstrgt-1] < intstk[nstrgt]; } else if (indlin == 2) { logstk[nstrgt-1] = relstk[nstrgt-1] < relstk[nstrgt]; } else if (indlin == 3) { logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) < 0; } else if (indlin == 4) { logstk[nstrgt-1] = dblstk[nstrgt-1] < dblstk[nstrgt]; } else { indrgt[nstrgt-1] = -5; } } else if (strcmp(cparav, ">") == 0) { --nstrgt; indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); indrgt[nstrgt-1] = 5; if (indlin == 1) { logstk[nstrgt-1] = intstk[nstrgt-1] > intstk[nstrgt]; } else if (indlin == 2) { logstk[nstrgt-1] = relstk[nstrgt-1] > relstk[nstrgt]; } else if (indlin == 3) { logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) > 0; } else if (indlin == 4) { logstk[nstrgt-1] = dblstk[nstrgt-1] > dblstk[nstrgt]; } else { indrgt[nstrgt-1] = -5; } } else if (strcmp(cparav, "=") == 0) { --nstrgt; indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); indrgt[nstrgt-1] = 5; if (indlin == 1) { logstk[nstrgt-1] = intstk[nstrgt-1] == intstk[nstrgt]; } else if (indlin == 2) { logstk[nstrgt-1] = relstk[nstrgt-1] == relstk[nstrgt]; } else if (indlin == 3) { logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) == 0; } else if (indlin == 4) { logstk[nstrgt-1] = dblstk[nstrgt-1] == dblstk[nstrgt]; } else { indrgt[nstrgt-1] = -5; } } else if (strcmp(cparav, "<=") == 0) { --nstrgt; indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); indrgt[nstrgt-1] = 5; if (indlin == 1) { logstk[nstrgt-1] = intstk[nstrgt-1] <= intstk[nstrgt]; } else if (indlin == 2) { logstk[nstrgt-1] = relstk[nstrgt-1] <= relstk[nstrgt]; } else if (indlin == 3) { logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) <= 0; } else if (indlin == 4) { logstk[nstrgt-1] = dblstk[nstrgt-1] <= dblstk[nstrgt]; } else { indrgt[nstrgt-1] = -5; } } else if (strcmp(cparav, ">=") == 0) { --nstrgt; indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); indrgt[nstrgt-1] = 5; if (indlin == 1) { logstk[nstrgt-1] = intstk[nstrgt-1] >= intstk[nstrgt]; } else if (indlin == 2) { logstk[nstrgt-1] = relstk[nstrgt-1] >= relstk[nstrgt]; } else if (indlin == 3) { logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) >= 0; } else if (indlin == 4) { logstk[nstrgt-1] = dblstk[nstrgt-1] >= dblstk[nstrgt]; } else { indrgt[nstrgt-1] = -5; } } else if (strcmp(cparav, "<>") == 0) { --nstrgt; indlin = min(indrgt[nstrgt-1], indrgt[nstrgt]); indrgt[nstrgt-1] = 5; if (indlin == 1) { logstk[nstrgt-1] = intstk[nstrgt-1] != intstk[nstrgt]; } else if (indlin == 2) { logstk[nstrgt-1] = relstk[nstrgt-1] != relstk[nstrgt]; } else if (indlin == 3) { logstk[nstrgt-1] = strcmp(chrstk[nstrgt-1], chrstk[nstrgt]) != 0; } else if (indlin == 4) { logstk[nstrgt-1] = dblstk[nstrgt-1] != dblstk[nstrgt]; } else { indrgt[nstrgt-1] = -5; } } else { /* NO CHANCE, MAN... TRY IT WITH VARIABLES */ int_32 ilowrc = ivabeg; int_32 ihigrc = ivaend; L50: imedrc = (ihigrc + ilowrc) / 2; iofset = (imedrc-1) * lrclen; iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); if (iretcd != 0) goto L9023; strcpy(cparin, record2.cparin); strcpy(cdatin, record2.cdatin); indlin = record2.indlin; idatin = record2.idatin; adatin = record2.adatin; ddatin = record2.ddatin; if (strcmp(cparin, cparav) == 0) { /* STACK VARIABLE VALUE */ ++nstrgt; indrgt[nstrgt-1] = indlin; if (indlin == 1) { intstk[nstrgt-1] = idatin; } else if (indlin == 2) { relstk[nstrgt-1] = adatin; } else if (indlin == 3) { strcpy(chrstk[nstrgt-1], cdatin); intstk[nstrgt-1] = idatin; } else if (indlin == 4) { dblstk[nstrgt-1] = ddatin; } else if (indlin == 5) { logstk[nstrgt-1] = idatin == 1; } } else if (strcmp(cparin, cparav) < 0) { ilowrc = imedrc; goto L50; } else { ihigrc = imedrc; goto L50; } } /* L05> ENDIF( ON CPARAV ) */ } /* L04> ELSEIF( INDLEC.NE.3 )THEN */ } else { ++nstrgt; indrgt[nstrgt-1] = indlec; if (indlec == 1) { intstk[nstrgt-1] = idatin; } else if (indlec == 2) { relstk[nstrgt-1] = adatin; } else if (indlec == 4) { dblstk[nstrgt-1] = ddatin; } /* L04> ENDIF( ON INDLEC ) */ } /* L03> ELSEIF( .NOT.LRGTST )THEN */ } else { strcpy(cparav, cdatav); if (strcmp(cparav, chrend) == 0) { lrgtst = 0; } else if (ilogin <= 6 && strcmp(cparav, ":=") == 0) { lrgtst = 1; } else { int_32 ilowrc = ivabeg; int_32 ihigrc = ivaend; ++nstlft; /* FIND RECORD NUMBER FOR VARIABLE *CPARAV* */ L27: imedrc = (ihigrc + ilowrc) / 2; iofset = (imedrc-1) * lrclen; iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); if (iretcd != 0) goto L9023; strcpy(cparin, record2.cparin); strcpy(cdatin, record2.cdatin); indlin = record2.indlin; idatin = record2.idatin; adatin = record2.adatin; ddatin = record2.ddatin; if (strcmp(cparin, cparav) == 0) { irclft[nstlft-1] = imedrc; } else if (strcmp(cparin, cparav) < 0) { ilowrc = imedrc; goto L27; } else { ihigrc = imedrc; goto L27; } } /* L03> ENDIF( ON LRGTST ) */ } /* L02> PROCESS *CLE2000* STATEMENTS: AND HIT... (END) */ } /* L01> ***LOOP*** OVER WORDS (END) */ goto L10; L8000: printf("%s: IREC=%d REC=%s\n", nomsub, (int)irecor, myreco); xabort_c("REDGET: PROBLEM READING *RECORD*, USE DEBUG"); L9001: xabort_c("REDGET: EMBEDDED LOGIC LEVEL .LT. 1 (MIN)"); L9002: xabort_c("REDGET: EMBEDDED LOGIC LEVEL .GT. 128 (MAX)"); L9004: xabort_c("REDGET: NUMBER OF >>.<< ACCUMULATED.GT. 128 (MAX)"); L9006: printf("%s: UNDEFINED LOGICAL IN *%s* OPERATION\n", nomsub, clogbg[ilogin-1]); xabort_c("REDGET: IMPOSSIBLE LOGICAL OPERATION"); L9007: xabort_c("REDGET: IMPOSSIBLE TO PRINT VALUE"); L9008: printf("%s: VARIABLE *%s* HAS STILL NO VALUE\n", nomsub, cparav); xabort_c("REDGET: IMPOSSIBLE TO GET VALUE"); L9009: printf("%s: *%s* HAS NEGATIVE VALUE\n", nomsub, clogbg[idefkw-1]); xabort_c("REDGET: IMPOSSIBLE TO TAKE *SQRT*"); L9010: printf("%s: *%s* DIVISION BY 0\n", nomsub, clogbg[idefkw-1]); xabort_c("REDGET: IMPOSSIBLE TO DIVIDE"); L9011: printf("%s: *%s* .LT. 0 RAISED TO POWER .LT. 0\n", nomsub, clogbg[idefkw-1]); xabort_c("REDGET: IMPOSSIBLE TO TAKE POWER"); L9012: xabort_c("REDGET: IMPOSSIBLE TO + OR - STRINGS"); L9013: xabort_c("REDGET: LONG < 99999999 REQUIRED FOR CONVERSION TO STRING"); L9014: xabort_c("REDGET: LONG > -9999999 REQUIRED FOR CONVERSION TO STRING"); goto L10; L9023: printf("%s: IOSTAT RETURN CODE =%d\n", nomsub, (int)iretcd); xabort_c("REDGET: IMPOSSIBLE TO USE THIS *STACK* FILE"); } /* redget_c */ /* *REDPUT* ENTRY POINT */ /* TO INPUT VALUES FOR CLE-2000 VARIABLES */ /* USING THE COMMAND >>.<< */ /* INPUT VARIABLES: */ /* *ITYP* TYPE FOR VARIABLE (+1: INT */ /* +2: REAL */ /* +3: STRING */ /* +4: DOUBLE */ /* +5: LOGICAL ) */ /* *NITMA* INT VALUE IF *ITYP*.EQ.+1.OR.*ITYP*.EQ.+5 */ /* *FLOTT* REAL VALUE IF *ITYP*.EQ.+2 */ /* *TEXT* STRING VALUE IF *ITYP*.EQ.+3 */ /* *DFLOT* DOUBLE VALUE IF *ITYP*.EQ.+4 */ /* NOTE: LOGICAL VALUES ARE GIVEN EITHER BY *TRUE* = *NITMA*.EQ.+1 */ /* OR BY *FALSE*= *NITMA*.EQ.-1 */ void redput_c(int_32 *ityp, int_32 *nitma, float_32 *flott, char *text, double_64 *dflot) { char *nomsub="redput_c"; char cparin[13], cdatin[121]; int_32 iretcd, ilengt, indlin, idatin, imedrc, iofset; float_32 adatin; double_64 ddatin; if (*ityp == 3) { ilengt = strlen(text); } else { ilengt = 0; } if (nstput == 0) { xabort_c("REDPUT: NOTHING TO PUT"); } else if (ilengt > 72) { xabort_c("REDPUT: STRING LENGTH RESTRICTED TO 72"); } else if (*ityp <= 0) { xabort_c("REDPUT: PLEASE USE *ITYP*.GT.0"); } else if (irecor == 0 || irecor > ninput) { xabort_c("REDPUT: READER IS CLOSED OR FILE END"); } imedrc = ircput[nstput-1]; iofset = (imedrc-1) * lrclen; iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); if (iretcd != 0) goto L9023; strcpy(cparin, record2.cparin); strcpy(cdatin, record2.cdatin); indlin = record2.indlin; idatin = record2.idatin; adatin = record2.adatin; ddatin = record2.ddatin; if (indlin >= 0) xabort_c("REDPUT: CANNOT PUT ON A DEFINED VALUE"); indlin = abs(indlin); if (indlin != *ityp) xabort_c("REDPUT: INCOMPATIBLE TYPE OF THE VARIABLE"); if (indlin == 1) { idatin = *nitma; } else if (indlin == 2) { adatin = *flott; } else if (indlin == 3) { if (strncmp(text, " ", ilengt) == 0) { /* ALL BLANK STRING IS CONSIDERED AS NULL-STRING => "" */ idatin = 0; } else if (text[0] == '"') { /* THIS IS A "...." STRING => START "... */ if (ilengt == 1) { /* PROVIDES A WAY FOR APPLICATION TO PUT A '"' STRING */ idatin = 1; cdatin[0] = text[0]; } else { /* LOOK FOR => END ..." */ idatin = index_f(&text[1], "\"") - 1; if (idatin < 0) { if (strcmp(&text[1], " ") == 0) { idatin = 1; cdatin[0] = text[0]; } else { xabort_c("REDPUT: INVALID STRING \" NEVER ENDS)"); } } else if (idatin != 0) { if (ilengt == idatin + 2) { memcpy(cdatin, &text[1], idatin); cdatin[idatin] = '\0'; } else { if (strcmp(&text[idatin+2], " ") != 0) xabort_c("REDPUT: \".\" + OTHER WORDS"); memcpy(cdatin, &text[1], idatin); cdatin[idatin] = '\0'; } } } } else { memcpy(cdatin, text, ilengt); cdatin[ilengt] = '\0'; idatin = ilengt; } } else if (indlin == 4) { ddatin = *dflot; } else if (indlin == 5) { idatin = *nitma; if (idatin != -1 && idatin != 1) xabort_c("REDPUT: LOGICAL IS UNDEFINED"); } else { xabort_c("REDPUT: UNDEFINED TYPE"); } strcpy(record2.cparin, cparin); strcpy(record2.cdatin, cdatin); record2.indlin = indlin; record2.idatin = idatin; record2.adatin = adatin; record2.ddatin = ddatin; iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2)); if (iretcd != 0) goto L9023; /* ONE LESS TO PUT */ --nstput; return; L9023: printf("%s: IOSTAT RETURN CODE =%d\n", nomsub, (int)iretcd); xabort_c("REDPUT: IMPOSSIBLE TO USE THIS *STACK* FILE"); } /* redput_c */ /* *REDOPN* ENTRY POINT */ /* TO OPEN THE DA-FILE CONTAINING CLE-2000 DATA */ /* INPUT VARIABLES: */ /* *IINP1* IS THE CLE-2000 DA-FILE UNIT */ /* *IOUT1* IS THE OUTPUT FILE UNIT FOR MESSAGES (NORMALLY STDOUT) */ /* *FILENAME* IS THE OUTPUT FILE NAME FOR MESSAGES */ /* *NREC* IS THE RECORD NUMBER WHERE WE START READING */ void redopn_c(kdi_file *iinp1, FILE *iout1, char *filename, int_32 nrec) { char *nomsub="redopn_c"; int_32 nstack; char cparav[13]; int_32 iretcd; iunito = iinp1; iwrite = iout1; strcpy(hwrite, filename); /* READ TOP OF OBJECT FILE */ irecor = 1; iretcd = kdiget_c(iunito, (int_32 *)&header, 0, kdisize(header)); if (iretcd != 0) goto L9023; strcpy(cparav, header.cparin); strcpy(myreco, header.cdatin); ninput = header.ninput; nstack = header.nstack; ioulst = header.ioulst; idblst = header.idblst; if (strcmp(cparav, cl2000) != 0) goto L9025; if (nrec != 0) irecor = nrec; nwords = 0; iwords = 0; ivabeg = ninput; ivaend = ninput + nstack + 1; return; L9023: printf("%s: IOSTAT RETURN CODE =%d\n", nomsub, (int)iretcd); xabort_c("REDOPN: IMPOSSIBLE TO USE THIS *STACK* FILE"); L9025: xabort_c("REDOPN: UNABLE TO OPEN FILE"); } /* redopn_c */ /* *REDCLS* ENTRY POINT */ /* TO CLOSE THE DA-FILE AT A CURRENT RECORD POSITION */ /* OUTPUT VARIABLES: */ /* *IINP1* IS THE CLE-2000 DA-FILE UNIT */ /* *IOUT1* IS THE OUTPUT FILE UNIT FOR MESSAGES (NORMALLY STDOUT) */ /* *FILENAME* IS THE OUTPUT FILE NAME FOR MESSAGES */ /* *NREC* IS THE RECORD NUMBER WHERE WE STOP READING */ void redcls_c(kdi_file **iinp1, FILE **iout1, char filename[73], int_32 *nrec) { if (nwords != iwords) xabort_c("REDCLS: RECORD NOT FINISHED => CANNOT CLOSE"); *nrec = irecor; *iinp1 = iunito; *iout1 = iwrite; strcpy(filename, hwrite); /* WE PUT IRECOR=0 TO CLOSE THE READER (SEE START OF *REDGET*) */ irecor = 0; ninput = 0; nwords = 0; iwords = 0; return; } /* redcls_c */