summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Dragon/src/XDRLXS.f5
-rw-r--r--Ganlib/data/testgan2.x2m9
-rw-r--r--Ganlib/src/DRVUTL.f4
-rw-r--r--Ganlib/src/lcm_c.c5
-rw-r--r--Ganlib/src/xsm.h1
-rw-r--r--Ganlib/src/xsm_c.c71
-rw-r--r--doc/IGE332/chapter1.tex6
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}
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 08:09:15 +0000