From 02868d641588210bb3a70616830173495caf25fa Mon Sep 17 00:00:00 2001 From: HEBERT Alain Date: Mon, 29 Dec 2025 09:00:16 -0500 Subject: Resolve "Implement xsmdel in XSM file API" --- Dragon/src/XDRLXS.f | 5 ++-- Ganlib/data/testgan2.x2m | 9 +++++- Ganlib/src/DRVUTL.f | 4 +-- Ganlib/src/lcm_c.c | 5 ++-- Ganlib/src/xsm.h | 1 + Ganlib/src/xsm_c.c | 71 ++++++++++++++++++++++++++++++++++++++++++++++-- doc/IGE332/chapter1.tex | 6 ++-- 7 files changed, 86 insertions(+), 15 deletions(-) diff --git a/Dragon/src/XDRLXS.f b/Dragon/src/XDRLXS.f index 08e416a..aac4747 100644 --- a/Dragon/src/XDRLXS.f +++ b/Dragon/src/XDRLXS.f @@ -66,13 +66,12 @@ *---- * SAVE LOCAL DEFAULT XS IF REQUIRED *---- -! CALL LCMLEN(IPLIB,'H-FACTOR',ILENG,ITYLCM) -! IF(ILENG.NE.0) CALL LCMDEL(IPLIB,'H-FACTOR') + CALL LCMLEN(IPLIB,'H-FACTOR',ILENG,ITYLCM) + IF(ILENG.NE.0) CALL LCMDEL(IPLIB,'H-FACTOR') DO 100 IXSR=1,NPROC *---- * FIND IF XS NOT ALL 0.0 *---- - IF(NAMDXS(IXSR).EQ.'H-FACTOR') GO TO 115 DO 110 IG=1,NGROUP IF(XSREC(IG,IXSR).NE.0.0) GO TO 115 110 CONTINUE diff --git a/Ganlib/data/testgan2.x2m b/Ganlib/data/testgan2.x2m index 4de50fa..c9ef50f 100644 --- a/Ganlib/data/testgan2.x2m +++ b/Ganlib/data/testgan2.x2m @@ -3,7 +3,8 @@ *---- LINKED_LIST TOTO FLUX MACRO GROUP ; SEQ_ASCII Macrolib FLUX2 ; -MODULE DELETE: GREP: END: ; +XSM_FILE FLUX3 ; +MODULE DELETE: GREP: UTL: END: ; PROCEDURE TESTproc assertS ; REAL value ; * @@ -13,10 +14,16 @@ GREP: GROUP :: GETVAL NTOT0 2 >>value<< ; ECHO "value=" value ; * FLUX2 := TESTproc MACRO :: 1.703945 ; +FLUX3 := FLUX2 ; FLUX := FLUX2 :: EDIT 99 ; FLUX2 := DELETE: FLUX2 ; assertS FLUX :: 'K-EFFECTIVE' 1 1.703945 ; * +UTL: FLUX3 :: DIR ; +FLUX3 := UTL: FLUX3 :: DEL SIGNATURE ; +FLUX3 := UTL: FLUX3 :: DEL DOUBLE-INFO ; +UTL: FLUX3 :: DIR ; +* ECHO "test TEST completed" ; END: ; QUIT "XREF" . diff --git a/Ganlib/src/DRVUTL.f b/Ganlib/src/DRVUTL.f index 36d171c..dc4a98d 100644 --- a/Ganlib/src/DRVUTL.f +++ b/Ganlib/src/DRVUTL.f @@ -417,10 +417,9 @@ * DELETE A BLOCK. IF(IND.EQ.2) CALL XABORT('DRVUTL: DEL IS A FORBIDDEN OPERATION' 1 //' IN READ-ONLY MODE.') - IF(ITYPE.GT.1) CALL XABORT('DRVUTL: DEL CAN ONLY BE USED WITH ' - 1 //'LINKED-LISTS.') CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(IMPX.GT.0) WRITE (6,170) NAMT CALL LCMDEL(IPLIST,NAMT) ELSE IF(TEXT4.EQ.'STAT') THEN * COMPARE TWO BLOCKS STORED ON LCM OR XSM. @@ -689,6 +688,7 @@ ENDIF GO TO 10 * + 170 FORMAT (/17H DRVUTL: DELETE ',A12,2H'.) 180 FORMAT (/36H DRVUTL: PERFORM UTILITY ACTIONS ON ,A11,9H OPEN IN , 1 A9,29H MODE WITH ACTIVE DIRECTORY ',A12,2H'./9X,9HLCM NAME=,A) 190 FORMAT (/27H DRVUTL: STEP UP TO LEVEL ',A12,2H'.) diff --git a/Ganlib/src/lcm_c.c b/Ganlib/src/lcm_c.c index ee4a83a..7530cde 100644 --- a/Ganlib/src/lcm_c.c +++ b/Ganlib/src/lcm_c.c @@ -1666,9 +1666,8 @@ void lcmdel_c(lcm **iplist,const char *namp) xabort_c(AbortString); } else if ((*iplist)->header == 200) { /* USE A XSM FILE. */ - sprintf(AbortString,"%s: UNABLE TO DELETE RECORD '%s' FROM AN XSM FILE.", - nomsub,(*iplist)->hname); - xabort_c(AbortString); + xsmdel_c((xsm **)iplist,namp); + return; } else if ((*iplist)->imode == 0) { sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.", nomsub,(*iplist)->hname); diff --git a/Ganlib/src/xsm.h b/Ganlib/src/xsm.h index 234dc1a..38110fc 100644 --- a/Ganlib/src/xsm.h +++ b/Ganlib/src/xsm.h @@ -65,6 +65,7 @@ typedef struct Db2{ /* xsmiof database handle */ void xsmop_c(xsm **, char *, int_32, int_32); void xsmput_c(xsm **, const char *, int_32, int_32, int_32 *); void xsmget_c(xsm **, const char *, int_32 *); +void xsmdel_c(xsm **, const char *); void xsmcl_c(xsm **, int_32); void xsmnxt_c(xsm **, char *); void xsmlen_c(xsm **, const char *, int_32 *, int_32 *); diff --git a/Ganlib/src/xsm_c.c b/Ganlib/src/xsm_c.c index 7abbf1f..1577fff 100644 --- a/Ganlib/src/xsm_c.c +++ b/Ganlib/src/xsm_c.c @@ -362,6 +362,9 @@ void xsmrep(const char *namt, int_32 *ind, int_32 *idir, block2 *my_block2, int_ if (strcmp(namt,"***HANDLE***") == 0) { sprintf(AbortString,"%s: ***HANDLE*** IS A RESERVED KEYWORD.",nomsub); xabort_c(AbortString); + } else if (strcmp(namt,"***DEL***") == 0) { + sprintf(AbortString,"%s: ***DEL*** IS A RESERVED KEYWORD.",nomsub); + xabort_c(AbortString); } strcpy(namp,namt); if (strcmp(namp," ") == 0) strcpy(namp,"***HANDLE***"); @@ -496,6 +499,7 @@ void xsmput_c(xsm **iplist, const char *namp, int_32 ilong, int_32 itype, int_32 } return; } + void xsmget_c(xsm **iplist, const char *namp, int_32 *data2) /* *----------------------------------------------------------------------- @@ -538,6 +542,47 @@ void xsmget_c(xsm **iplist, const char *namp, int_32 *data2) return; } +void xsmdel_c(xsm **iplist, const char *namp) +/* + *----------------------------------------------------------------------- + * + * delete a block in the xsm file. + * + * input parameter: + * iplist : address of the handle to the xsm file. + * namp : character*12 name of the current block. + * + *----------------------------------------------------------------------- + */ +{ + char *nomsub="xsmdel_c"; + char nomC[13] = "***DEL***"; + block2 *my_block2; + int_32 iii; + if ((*iplist)->impf == 2) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(1).", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } else if ((*iplist)->header != 200) { + sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.", + nomsub,(*iplist)->hname); + xabort_c(AbortString); + } + my_block2 = (*iplist)->ibloc; + xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii); + if (iii > 0) { + my_block2->modif = 1; + my_block2->jlon[iii - 1] = 0; + my_block2->jtyp[iii - 1] = 98; + strcpy(my_block2->cmt[iii - 1],nomC); + } else { + sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE XSM FILE '%.45s'.", + nomsub,namp,my_block2->mynam,(*iplist)->hname); + xabort_c(AbortString); + } + return; +} + void xsmcl_c(xsm **iplist, int_32 istatu) /* *----------------------------------------------------------------------- @@ -682,9 +727,15 @@ void xsmnxt_c(xsm **iplist, char *namp) } else { xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii); } + int_32 icount=0; + L10: icount++; + if (icount >= 10000) { + sprintf(AbortString,"%s: PATHOLOGICAL CASE.",nomsub); + xabort_c(AbortString); + } if (iii == 0 && strcmp(namp, " ") == 0) { /* EMPTY DIRECTORY */ - sprintf(AbortString,"%s: THE ACTIVE DIRECTORY '%s' OF THE XSM FILE '%.45s' IS EMPTY.", + sprintf(AbortString,"%s: THE ACTIVE DIRECTORY '%s' OF THE XSM FILE '%.45s' IS EMPTY(1).", nomsub,my_block2->mynam,(*iplist)->hname); xabort_c(AbortString); } else if (iii == 0) { @@ -693,6 +744,11 @@ void xsmnxt_c(xsm **iplist, char *namp) xabort_c(AbortString); } else if (iii + 1 <= my_block2->nmt) { strcpy(namp,my_block2->cmt[iii]); + if (strcmp(namp,"***DEL***") == 0) { + if (iii + 1 == my_block2->nmt) my_block2->nmt--; + iii++; + goto L10; + } return; } /* SWITCH TO THE NEXT DIRECTORY. */ @@ -702,8 +758,19 @@ void xsmnxt_c(xsm **iplist, char *namp) /* RECOVER THE NEXT DIRECTORY. */ xsmdir(&c__1, my_block2); } - strcpy(namp,my_block2->cmt[0]); + iii=0; + strcpy(namp,my_block2->cmt[iii]); if (strcmp(namp,"***HANDLE***") == 0) strcpy(namp," "); + if (strcmp(namp,"***DEL***") == 0) { + if (my_block2->nmt <= 1) { + sprintf(AbortString,"%s: THE ACTIVE DIRECTORY '%s' OF THE XSM FILE '%.45s' IS EMPTY(2).", + nomsub,my_block2->mynam,(*iplist)->hname); + xabort_c(AbortString); + } + if (iii + 1 == my_block2->nmt) my_block2->nmt--; + iii++; + goto L10; + } return; } diff --git a/doc/IGE332/chapter1.tex b/doc/IGE332/chapter1.tex index 5e8a5ef..28070a4 100644 --- a/doc/IGE332/chapter1.tex +++ b/doc/IGE332/chapter1.tex @@ -860,8 +860,7 @@ refpush(iplist,iofset); \subsubsection{lcmdel\_c\index{lcmdel\_c}} -Function used to erase an information block or a daughter heterogeneous list stored in a memory-resident associative table. -Function {\tt lcmdel\_c} {\sl cannot} be used with persistent LCM objects. +Function used to erase an information block or a daughter heterogeneous list stored in a LCM object. \begin{verbatim} @@ -4222,8 +4221,7 @@ by {\tt IOFSET} must be initialized before the call to {\tt LCMPPD}. \\ \subsubsection{LCMDEL\index{LCMDEL}} -Subroutine used to erase an information block or a daughter heterogeneous list stored in a memory-resident associative table. -Subroutine {\tt LCMDEL} {\sl cannot} be used with persistent LCM objects. +Subroutine used to erase an information block or a daughter heterogeneous list stored in a LCM object. \begin{verbatim} -- cgit v1.2.3