Initial commit from Polytechnique Montreal

1 files changed, 711 insertions, 0 deletions

diff --git a/Ganlib/src/DRVUTL.f b/Ganlib/src/DRVUTL.f
new file mode 100644
index 0000000..36d171c
--- /dev/null
+++ b/Ganlib/src/DRVUTL.f
@@ -0,0 +1,711 @@
+*DECK DRVUTL
+      SUBROUTINE DRVUTL(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* standard utility module for linked list or xsm files.
+*
+*Copyright:
+* Copyright (C) 1988 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s): R. Roy
+*
+*Parameters: input/output
+* NENTRY  number of LCM objects or files used by the operator.
+* HENTRY  name of each LCM object or file:
+*         HENTRY(1): read-only or modification type(VECTOR).
+* IENTRY  type of each LCM object or file:
+*         =1 LCM memory object; =2 XSM file; =3 sequential binary file;
+*         =4 sequential ascii file.
+* JENTRY  access of each LCM object or file:
+*         =0 the LCM object or file is created;
+*         =1 the LCM object or file is open for modifications;
+*         =2 the LCM object or file is open in read-only mode.
+* KENTRY  LCM object address or file unit number.
+*
+* List of utility actions:
+*   IMPR : print a block.
+*   COPY : copy a block or a directory.
+*   CREA : create a block.
+*   DEL  : delete a block.
+*   STAT : compare two blocks.
+*   ADD  : add two floating point blocks or directories component by
+*          component.
+*   MULT : multiply the floating point components of a block or
+*          directory by a constant.
+*   SADD : add the floating point components of a block or directory
+*          by a constant.
+*   STEP : change of directory level.
+*   DIR  : print the active directory content.
+*   DUMP : dump the active and son directories on the printer.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER :: NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+      TYPE(C_PTR) :: KENTRY(NENTRY)
+      CHARACTER :: HENTRY(NENTRY)*12
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER, PARAMETER :: MAXLEV=50
+      TYPE(C_PTR) :: IPLIST,IPLIS1,IPKEEP(MAXLEV)
+      CHARACTER :: TEXT4*4,NAMT*12,NAMT2*12,NAMMY*12,NAMLCM*72,
+     1             CTYP(3)*11,CENT(3)*9,HSMG*131,TEXT12*12
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IARA
+      REAL, ALLOCATABLE, DIMENSION(:) :: ARA,ARA2
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DARA
+      CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: HARA
+      COMPLEX, ALLOCATABLE, DIMENSION(:) :: CARA
+      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LARA
+      DOUBLE PRECISION :: DFLOTT
+      LOGICAL :: EMPTY,LCM
+      DATA (CTYP(ITY),ITY=1,3)/'CLE_2000','LINKED_LIST','XSM_FILE'/
+      DATA (CENT(ITY),ITY=1,3)/'CREATE','IN_OUT','READ-ONLY'/
+      SAVE CTYP,CENT
+*----
+*  PARAMETER VALIDATION.
+*----
+      IF(NENTRY.EQ.0) CALL XABORT('DRVUTL: PARAMETER EXPECTED.')
+      TEXT12=HENTRY(1)
+      IF(JENTRY(1).EQ.0) THEN
+         IF(IENTRY(1).GT.2) CALL XABORT('DRVUTL: THE UTILITY MODULE WO'
+     1   //'RKS ONLY WITH LINKED LISTS AND XSM FILES ('//TEXT12//').')
+      ELSE IF(JENTRY(1).EQ.1) THEN
+         IF(IENTRY(1).GT.2) CALL XABORT('DRVUTL: THE UTILITY MODULE WO'
+     1   //'RKS ONLY WITH LINKED LISTS AND XSM FILES ('//TEXT12//').')
+      ELSE IF(JENTRY(1).EQ.2) THEN
+         IF(IENTRY(1).GT.2) CALL XABORT('DRVUTL: THE UTILITY MODULE WO'
+     1   //'RKS ONLY WITH LINKED LISTS AND XSM FILES ('//TEXT12//').')
+      ENDIF
+      IND=JENTRY(1)
+      ITYPE=IENTRY(1)
+      IPLIST=KENTRY(1)
+      IPKEEP(1)=IPLIST
+      ILEV=1
+      FLUSH(6)
+*----
+*  SET EDITION FLAG.
+*----
+      IMPX=1
+      CALL REDGET(INDIC,NITMA,DPREC,TEXT4,DFLOTT)
+      IF(INDIC.EQ.10) RETURN
+      IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+      IF(TEXT4.EQ.'EDIT') THEN
+        CALL REDGET(ITYP,IMPX,FLOTT,TEXT12,DFLOTT)
+        IF(ITYP.NE.1) CALL XABORT('DRVUTL: NO INTEGER AFTER *EDIT*.')
+      ELSE
+        GO TO 20
+      ENDIF
+      CALL LCMINF(IPLIST,NAMLCM,NAMMY,EMPTY,ILONG,LCM)
+      IF(IMPX.GT.0) WRITE(6,180) CTYP(ITYPE+1),CENT(IND+1),NAMMY,NAMLCM
+*----
+*  PERFORM SOME UTILITY ACTIONS.
+*----
+   10 CALL REDGET(INDIC,NITMA,DPREC,TEXT4,DFLOTT)
+      IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+   20 IF(TEXT4.EQ.'IMPR') THEN
+*       PRINT A LCM OR XSM BLOCK.
+        CALL REDGET(INDPRT,ISET,FLOTT,NAMT,DFLOTT)
+        IF(INDPRT.EQ.1) THEN
+          CALL LCMLEL(IPLIST,ISET,ILONG,ITYBLK)
+          IF(ILONG.EQ.0) THEN
+            WRITE (6,245) ISET
+            CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+            GO TO 10
+          ENDIF
+        ELSE IF(INDPRT.EQ.3) THEN
+          CALL LCMLEN(IPLIST,NAMT,ILONG,ITYBLK)
+          IF(ILONG.EQ.0) THEN
+            WRITE (6,250) NAMT
+            CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+            GO TO 10
+          ENDIF
+        ELSE
+          CALL XABORT('DRVUTL: BLOCK-NAME OR LIST INDEX EXPECTED.')
+        ENDIF
+        IF(ITYBLK.EQ.10) CALL XABORT('DRVUTL: '//NAMT//' IS A LIST OF'
+     1  //' ARRAYS. USE A STEP UP KEYWORD TO ACCESS THE LIST.')
+        IF((ITYBLK.EQ.1).OR.(ITYBLK.EQ.3).OR.(ITYBLK.EQ.5)) THEN
+          ALLOCATE(IARA(ILONG))
+          IF(INDPRT.EQ.1) THEN
+            CALL LCMGDL(IPLIST,ISET,IARA)
+          ELSE IF(INDPRT.EQ.3) THEN
+            CALL LCMGET(IPLIST,NAMT,IARA)
+          ENDIF
+        ELSE IF(ITYBLK.EQ.2) THEN
+          ALLOCATE(ARA(ILONG))
+          IF(INDPRT.EQ.1) THEN
+            CALL LCMGDL(IPLIST,ISET,ARA)
+          ELSE IF(INDPRT.EQ.3) THEN
+            CALL LCMGET(IPLIST,NAMT,ARA)
+          ENDIF
+        ELSE IF(ITYBLK.EQ.4) THEN
+          ALLOCATE(DARA(ILONG))
+          IF(INDPRT.EQ.1) THEN
+            CALL LCMGDL(IPLIST,ISET,DARA)
+          ELSE IF(INDPRT.EQ.3) THEN
+            CALL LCMGET(IPLIST,NAMT,DARA)
+          ENDIF
+        ELSE IF(ITYBLK.EQ.6) THEN
+          ALLOCATE(CARA(ILONG))
+          IF(INDPRT.EQ.1) THEN
+            CALL LCMGDL(IPLIST,ISET,CARA)
+          ELSE IF(INDPRT.EQ.3) THEN
+            CALL LCMGET(IPLIST,NAMT,CARA)
+          ENDIF
+        ELSE
+          CALL XABORT('DRVUTL: IMPR TYPE NOT SUPPORTED.')
+        ENDIF
+        CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+        LL=99999999
+        IF(INDIC.EQ.1) THEN
+          LL=NITMA
+        ELSE IF(INDIC.NE.3) THEN
+          CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+        ELSE IF(TEXT4.NE.'*') THEN
+          CALL XABORT('DRVUTL: CHARACTER * EXPECTED.')
+        ENDIF
+        ICONT=0
+        IMAX=MIN0(LL,ILONG)
+        IF(ITYBLK.EQ.1) THEN
+          DO I=1,ILONG
+            IF(IARA(I).NE.0) ICONT=ICONT+1
+          ENDDO
+        ELSE IF(ITYBLK.EQ.2) THEN
+          DO I=1,ILONG
+            IF(ARA(I).NE.0.0) ICONT=ICONT+1
+          ENDDO
+        ELSE IF(ITYBLK.EQ.4) THEN
+          DO I=1,ILONG
+            IF(DARA(I).NE.0.0D0) ICONT=ICONT+1
+          ENDDO
+          IMAX=MIN0(LL,ILONG)
+        ELSE IF(ITYBLK.EQ.6) THEN
+          DO I=1,ILONG
+            IF(CARA(I).NE.0.0) ICONT=ICONT+1
+          ENDDO
+          IMAX=MIN0(LL,ILONG)
+        ENDIF
+        IF(INDPRT.EQ.1) THEN
+          WRITE (6,225) ISET,ILONG,ICONT
+        ELSE IF(INDPRT.EQ.3) THEN
+          WRITE (6,230) NAMT,ILONG,ICONT
+        ENDIF
+        IF((IMAX.GT.0).AND.(ITYBLK.EQ.1)) THEN
+          WRITE (6,'(1X,13I10)') (IARA(I),I=1,IMAX)
+        ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.2)) THEN
+          WRITE (6,'(1X,1P,10E13.4)') (ARA(I),I=1,IMAX)
+        ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.3)) THEN
+          WRITE (6,'(1X,32A4)') (IARA(I),I=1,IMAX)
+        ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.4)) THEN
+          WRITE(6,'(1X,1P,6D21.12)') (DARA(I),I=1,IMAX)
+        ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.5)) THEN
+          WRITE(6,'(1X,65L2)') (IARA(I),I=1,IMAX)
+        ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.6)) THEN
+          WRITE(6,'(1X,1P,4(2H (,E13.4,1H,,E13.4,1H)))')
+     1    (REAL(CARA(I)),AIMAG(CARA(I)),I=1,IMAX)
+        ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.0)) THEN
+          WRITE (6,240) NAMT
+        ENDIF
+        WRITE (6,'(/)')
+        IF((ITYBLK.EQ.1).OR.(ITYBLK.EQ.3).OR.(ITYBLK.EQ.5)) THEN
+          DEALLOCATE(IARA)
+        ELSE IF(ITYBLK.EQ.2) THEN
+          DEALLOCATE(ARA)
+        ELSE IF(ITYBLK.EQ.4) THEN
+          DEALLOCATE(DARA)
+        ELSE IF(ITYBLK.EQ.6) THEN
+          DEALLOCATE(CARA)
+        ENDIF
+      ELSE IF(TEXT4.EQ.'ERAS') THEN
+*       ERASE THE CONTENTS OF THE LCM OR XSM OBJECT.
+        IF(IND.EQ.2) CALL XABORT('DRVUTL: ERAS IS A FORBIDDEN OPERATIO'
+     1  //'N IN READ-ONLY MODE.')
+        CALL LCMINF(IPLIST,NAMLCM,NAMMY,EMPTY,ILONG,LCM)
+        IF(LCM) THEN
+          MEDIUM=1
+        ELSE
+          MEDIUM=2
+        ENDIF
+        CALL LCMCL(IPLIST,3)
+        CALL LCMOP(IPLIST,NAMLCM,1,MEDIUM,IMPX)
+      ELSE IF(TEXT4.EQ.'COPY') THEN
+*       COPY AND NAME A BLOCK OR DIRECTORY ON LCM OR XSM.
+        IF(IND.EQ.2) CALL XABORT('DRVUTL: COPY IS A FORBIDDEN OPERATIO'
+     1  //'N IN READ-ONLY MODE.')
+        CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT)
+        IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+        CALL REDGET(INDIC,NITMA,FLOTT,NAMT2,DFLOTT)
+        IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+        CALL LCMLEN(IPLIST,NAMT,ILONG,ITYBLK)
+        IF(ILONG.EQ.-1) THEN
+*         COPY A COMPLETE DIRECTORY.
+          CALL LCMSIX(IPLIST,NAMT,1)
+          NUNIT=KDROPN('DUMMYSQ',0,2,0)
+          IF(NUNIT.LE.0) CALL XABORT('DRVUTL: KDROPN FAILURE.')
+          CALL LCMEXP(IPLIST,0,NUNIT,1,1)
+          REWIND(NUNIT)
+          CALL LCMSIX(IPLIST,' ',2)
+          CALL LCMSIX(IPLIST,NAMT2,1)
+          CALL LCMEXP(IPLIST,0,NUNIT,1,2)
+          IRC=KDRCLS(NUNIT,2)
+          IF(IRC.LT.0) CALL XABORT('DRVUTL: KDRCLS FAILURE.')
+          CALL LCMSIX(IPLIST,' ',2)
+        ELSE IF(ILONG.GT.0) THEN
+*         COPY A SINGLE RECORD.
+          IF((ITYBLK.EQ.4).OR.(ITYBLK.EQ.6)) THEN
+            ALLOCATE(ARA(2*ILONG))
+              CALL LCMGET(IPLIST,NAMT,ARA)
+              CALL LCMPUT(IPLIST,NAMT2,ILONG,ITYBLK,ARA)
+            DEALLOCATE(ARA)
+          ELSEIF(ITYBLK.EQ.2) THEN
+            ALLOCATE(ARA(ILONG))
+              CALL LCMGET(IPLIST,NAMT,ARA)
+              CALL LCMPUT(IPLIST,NAMT2,ILONG,ITYBLK,ARA)
+            DEALLOCATE(ARA)
+          ELSE
+            ALLOCATE(IARA(ILONG))
+              CALL LCMGET(IPLIST,NAMT,IARA)
+              CALL LCMPUT(IPLIST,NAMT2,ILONG,ITYBLK,IARA)
+            DEALLOCATE(IARA)
+          ENDIF
+        ELSE IF(ILONG.EQ.0) THEN
+          CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT STORED ON LCM O'
+     1    //'R XSM.')
+        ENDIF
+      ELSE IF(TEXT4.EQ.'CREA') THEN
+        IF(IND.EQ.2) CALL XABORT('DRVUTL: CREA IS A FORBIDDEN OPERATIO'
+     1  //'N IN READ-ONLY MODE.')
+        CALL REDGET(NTYPE,ISET,FLOTT,NAMT,DFLOTT)
+        INDICO=0
+        IF(NTYPE.EQ.1) THEN
+          CALL LCMLEL(IPLIST,ISET,ILONG0,INDICO)
+        ELSE IF(NTYPE.EQ.3) THEN
+          CALL LCMLEN(IPLIST,NAMT,ILONG0,INDICO)
+        ELSE
+          CALL XABORT('DRVUTL: INTEGER OR CHARACTER DATA EXPECTED.')
+        ENDIF
+        CALL REDGET(INDIC,ILONG2,FLOTT,TEXT4,DFLOTT)
+        IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTED.')
+        ILONG1=1
+   30   CALL REDGET(INDIC,ILONG,FLOTT,TEXT4,DFLOTT)
+        IF(INDIC.EQ.1) THEN
+          IF(ILONG0.EQ.0) CALL XABORT('DRVUTL: LOWER INDEX NOT EXPEC'
+     1    //'TED.')
+          ILONG1=ILONG2
+          ILONG2=ILONG
+          GO TO 30
+        ELSE IF((INDIC.NE.3).OR.(TEXT4.NE.'=')) THEN
+           CALL XABORT('DRVUTL: = SIGN EXPECTED.')
+        ENDIF
+        CALL REDGET(INDIC,NITMA,FLOAT,TEXT4,DFLOTT)
+        IF(INDICO.EQ.99) THEN
+           INDICO=INDIC
+        ELSE IF(INDIC.NE.INDICO) THEN
+           CALL XABORT('DRVUTL: INCONSISTENT DATA TYPE(1).')
+        ENDIF
+        IF(INDIC.EQ.1) THEN
+          ALLOCATE(IARA(MAX(ILONG2,ILONG0)))
+          IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN
+            CALL LCMGDL(IPLIST,ISET,IARA)
+          ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN
+            CALL LCMGET(IPLIST,NAMT,IARA)
+          ENDIF
+          IARA(ILONG1)=NITMA
+        ELSE IF(INDIC.EQ.2) THEN
+          ALLOCATE(ARA(MAX(ILONG2,ILONG0)))
+          IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN
+            CALL LCMGDL(IPLIST,ISET,ARA)
+          ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN
+            CALL LCMGET(IPLIST,NAMT,ARA)
+          ENDIF
+          ARA(ILONG1)=FLOAT
+        ELSE IF(INDIC.EQ.3) THEN
+          ALLOCATE(HARA(MAX(ILONG2,ILONG0)))
+          IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN
+            CALL LCMGLC(IPLIST,ISET,4,MAX(ILONG2,ILONG0),HARA)
+          ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN
+            CALL LCMGTC(IPLIST,NAMT,4,MAX(ILONG2,ILONG0),HARA)
+          ENDIF
+          HARA(ILONG1)=TEXT4
+        ELSE IF(INDIC.EQ.4) THEN
+          ALLOCATE(DARA(MAX(ILONG2,ILONG0)))
+          IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN
+            CALL LCMGDL(IPLIST,ISET,DARA)
+          ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN
+            CALL LCMGET(IPLIST,NAMT,DARA)
+          ENDIF
+          DARA(ILONG1)=DFLOTT
+        ELSE IF(INDIC.EQ.5) THEN
+          ALLOCATE(LARA(MAX(ILONG2,ILONG0)))
+          IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN
+            CALL LCMGDL(IPLIST,ISET,LARA)
+          ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN
+            CALL LCMGET(IPLIST,NAMT,LARA)
+          ENDIF
+          IF (NITMA.EQ.1) THEN 
+            LARA(ILONG1)=.TRUE.
+          ELSE
+            LARA(ILONG1)=.FALSE.
+          ENDIF
+        ENDIF
+        DO I=ILONG1+1,ILONG2
+          CALL REDGET(INDIC,NITMA,FLOAT,TEXT4,DFLOTT)
+          IF(INDIC.NE.INDICO) THEN
+            CALL XABORT('DRVUTL: INCONSISTENT DATA TYPE(2).')
+          ELSE IF(INDIC.EQ.1) THEN
+            IARA(I)=NITMA
+          ELSE IF(INDIC.EQ.2) THEN
+            ARA(I)=FLOAT
+          ELSE IF(INDIC.EQ.3) THEN
+            HARA(I)=TEXT4
+          ELSE IF(INDIC.EQ.4) THEN
+            DARA(I)=DFLOTT
+          ELSE IF(INDIC.EQ.5) THEN
+            IF (NITMA.EQ.1) THEN 
+              LARA(I)=.TRUE.
+            ELSE
+              LARA(I)=.FALSE.
+            ENDIF
+          ENDIF
+        ENDDO
+        IF(NTYPE.EQ.1) THEN
+          IF(INDICO.EQ.1) THEN
+            CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,IARA)
+            DEALLOCATE(IARA)
+          ELSE IF(INDICO.EQ.2) THEN
+            CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,ARA)
+            DEALLOCATE(ARA)
+          ELSE IF(INDICO.EQ.3) THEN
+            CALL LCMPLC(IPLIST,ISET,4,MAX(ILONG2,ILONG0),HARA)
+            DEALLOCATE(HARA)
+          ELSE IF(INDICO.EQ.4) THEN
+            CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,DARA)
+            DEALLOCATE(DARA)
+          ELSE IF(INDICO.EQ.5) THEN
+            CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,LARA)
+            DEALLOCATE(LARA)
+          ENDIF
+        ELSE IF(NTYPE.EQ.3) THEN
+          IF(INDICO.EQ.1) THEN
+            CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,IARA)
+            DEALLOCATE(IARA)
+          ELSE IF(INDICO.EQ.2) THEN
+            CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,ARA)
+            DEALLOCATE(ARA)
+          ELSE IF(INDICO.EQ.3) THEN
+            CALL LCMPTC(IPLIST,NAMT,4,MAX(ILONG2,ILONG0),HARA)
+            DEALLOCATE(HARA)
+          ELSE IF(INDICO.EQ.4) THEN
+            CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,DARA)
+            DEALLOCATE(DARA)
+          ELSE IF(INDICO.EQ.5) THEN
+            CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,LARA)
+            DEALLOCATE(LARA)
+          ENDIF
+        ENDIF
+      ELSE IF(TEXT4.EQ.'DEL') THEN
+*       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.')
+        CALL LCMDEL(IPLIST,NAMT)
+      ELSE IF(TEXT4.EQ.'STAT') THEN
+*       COMPARE TWO BLOCKS STORED ON LCM OR XSM.
+*       READ RELATIVE OR ABSOLUTE ERROR.
+        CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+        IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+*       RECOVERY OF THE FIRST BLOCK.
+        CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT)
+        IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+        CALL LCMLEN(IPLIST,NAMT,ILONG1,IT1BLK)
+        IF(IT1BLK.NE.2) CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT OF'
+     1  //' REAL TYPE.')
+        ALLOCATE(ARA(ILONG1))
+        CALL LCMGET(IPLIST,NAMT,ARA)
+*       RECOVERY OF THE SECOND BLOCK.
+        CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT)
+        IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+        CALL LCMLEN(IPLIST,NAMT,ILONG2,IT2BLK)
+        IF(ILONG2.NE.ILONG1) THEN
+          CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT LENGTH.')
+        ELSE IF(IT1BLK.NE.IT2BLK) THEN
+          CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT TYPES.')
+        ENDIF
+        ALLOCATE(ARA2(ILONG2))
+        CALL LCMGET(IPLIST,NAMT,ARA2)
+*       COMPARE THE TWO BLOCKS.
+        EPSMAX=0.0
+        EPSAVG=0.0
+        IF(TEXT4(1:3).EQ.'REL') THEN
+          WRITE (6,200) 'RELATIVE'
+          DO I=1,ILONG1
+            IF(ARA2(I).NE.0.0) THEN
+              ABSEP=ABS((ARA(I)-ARA2(I))/ARA2(I))
+            ELSE
+              ABSEP=0.0
+            ENDIF
+            IF(EPSMAX.LT.ABSEP) THEN
+              EPSMAX=ABSEP
+              INGRO=I
+            ENDIF
+            EPSAVG=EPSAVG+ABSEP
+          ENDDO
+          EPSMAX=100.0*EPSMAX
+          EPSAVG=100.0*EPSAVG/REAL(ILONG1)
+          WRITE (6,210) ILONG1,EPSMAX,INGRO,EPSAVG
+        ELSE IF(TEXT4(1:3).EQ.'ABS') THEN
+          WRITE (6,200) 'ABSOLUTE'
+          DO I=1,ILONG1
+            ABSEP=ABS(ARA(I)-ARA2(I))
+            IF(EPSMAX.LT.ABSEP) THEN
+              EPSMAX=ABSEP
+              INGRO=I
+            ENDIF
+            EPSAVG=EPSAVG+ABSEP
+          ENDDO
+          EPSAVG=EPSAVG/REAL(ILONG1)
+          WRITE (6,220) ILONG1,EPSMAX,INGRO,EPSAVG
+        ELSE
+          CALL XABORT('DRVUTL: CHOOSE RELATIVE OR ABSOLUTE')
+        ENDIF
+        DEALLOCATE(ARA2,ARA)
+*----
+*  transfer EPSMAX and EPSAVG to output variables if required
+*----
+        CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+        IF(INDIC .EQ. 3 ) GO TO 20
+        IF(INDIC .NE. -2) CALL XABORT('DRVUTL: Output variable for ' 
+     1  //'maximum error is not a real number')
+        CALL REDPUT(-INDIC,NITMA,EPSMAX,TEXT4,DFLOTT)
+        CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+        IF(INDIC .EQ. 3 ) GO TO 20
+        IF(INDIC .NE. -2) CALL XABORT('DRVUTL: Output variable for ' 
+     1  //'average error is not a real number')
+        CALL REDPUT(-INDIC,NITMA,EPSAVG,TEXT4,DFLOTT)
+      ELSE IF(TEXT4.EQ.'ADD') THEN
+*       ADD TWO BLOCKS OR DIRECTORIES STORED ON LCM OR XSM.
+*       RECOVERY OF THE FIRST BLOCK.
+        IF(IND.EQ.2) CALL XABORT('DRVUTL: ADD IS A FORBIDDEN OPERATIO'
+     1  //'N IN READ-ONLY MODE.')
+        CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT)
+        IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+        CALL REDGET(INDIC,NITMA,FLOTT,NAMT2,DFLOTT)
+        IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+        CALL LCMLEN(IPLIST,NAMT,ILONG1,IT1BLK)
+        IF(ILONG1.EQ.-1) THEN
+*          ADD TWO DIRECTORIES.
+           NUNIT=KDROPN('DUMMYSQ',0,2,0)
+           IF(NUNIT.LE.0) CALL XABORT('DRVUTL: KDROPN FAILURE.')
+           CALL LCMEXP(IPLIST,0,NUNIT,1,1)
+           REWIND(NUNIT)
+           CALL LCMOP(IPLIS1,'DUMMYDA',0,1,0)
+           CALL LCMEXP(IPLIS1,0,NUNIT,1,2)
+           IRC=KDRCLS(NUNIT,2)
+           IF(IRC.LT.0) CALL XABORT('DRVUTL: KDRCLS FAILURE.')
+           CALL LCMSIX(IPLIS1,NAMT,1)
+           CALL LCMSIX(IPLIST,NAMT2,1)
+           CALL LCMADD(IPLIS1,IPLIST)
+           CALL LCMSIX(IPLIS1,' ',2)
+           CALL LCMSIX(IPLIST,' ',2)
+           CALL LCMCL(IPLIS1,2)
+        ELSE IF(ILONG1.GT.0) THEN
+*          ADD TWO RECORDS.
+           IF(IT1BLK.NE.2) CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT'
+     1     //' OF REAL TYPE.')
+           CALL LCMLEN(IPLIST,NAMT2,ILONG2,IT2BLK)
+           IF(ILONG2.NE.ILONG1) THEN
+             CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT LENGTH'
+     1       //'S.')
+           ELSE IF(IT1BLK.NE.IT2BLK) THEN
+             CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT TYPES.')
+           ENDIF
+           ALLOCATE(ARA(ILONG1))
+           CALL LCMGET(IPLIST,NAMT,ARA)
+           ALLOCATE(ARA(ILONG2))
+           CALL LCMGET(IPLIST,NAMT,ARA2)
+           ARA2(:ILONG2)=ARA(:ILONG2)+ARA2(:ILONG2)
+           CALL LCMPUT(IPLIST,NAMT2,ILONG2,IT1BLK,ARA2)
+           DEALLOCATE(ARA2)
+           DEALLOCATE(ARA)
+        ELSE IF(ILONG1.EQ.0) THEN
+           CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT STORED.')
+        ENDIF
+      ELSE IF((TEXT4.EQ.'MULT').OR.(TEXT4.EQ.'SADD')) THEN
+*       MULTIPLY AN LCM OR XSM BLOCK OR DIRECTORY BY A CONSTANT.
+*       RECOVERY OF A BLOCK OR DIRECTORY.
+        IF(IND.EQ.2) CALL XABORT('DRVUTL: MULT IS A FORBIDDEN OPERATIO'
+     1  //'N IN READ-ONLY MODE.')
+        CALL REDGET(NTYPE,ISET,FLOTT,NAMT,DFLOTT)
+        IF(NTYPE.EQ.1) THEN
+          CALL LCMLEL(IPLIST,ISET,ILONG1,ITYBLK)
+        ELSE IF(NTYPE.EQ.3) THEN
+          CALL LCMLEN(IPLIST,NAMT,ILONG1,ITYBLK)
+        ELSE
+          CALL XABORT('DRVUTL: INTEGER OR CHARACTER DATA EXPECTED.')
+        ENDIF
+*       READ A NUMBER.
+        CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT)
+        IF(INDIC.EQ.3) CALL XABORT('DRVUTL: INTEGER OR REAL NUMBER EX'
+     1  //'PECTED.')
+        IF(INDIC.EQ.1) FLOTT=REAL(NITMA)
+        CALL LCMLEN(IPLIST,NAMT,ILONG1,ITYBLK)
+        IF(ILONG1.EQ.-1) THEN
+*         MULTIPLY A DIRECTORY FLOATTING CONTENT BY A REAL NUMBER.
+          IF(NTYPE.EQ.1) THEN
+            IPLIS1=LCMDIL(IPLIST,ISET)
+          ELSE IF(NTYPE.EQ.3) THEN
+            IPLIS1=LCMDID(IPLIST,NAMT)
+          ENDIF
+          CALL LCMULT(IPLIS1,FLOTT)
+        ELSE IF(ILONG1.GT.0) THEN
+*         MULTIPLY A REAL RECORD BY A REAL NUMBER.
+          IF(ITYBLK.NE.2) CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT'
+     1    //' OF REAL TYPE.')
+          ALLOCATE(ARA(ILONG1))
+          IF(NTYPE.EQ.1) THEN
+            CALL LCMGDL(IPLIST,ISET,ARA)
+          ELSE IF(NTYPE.EQ.3) THEN
+            CALL LCMGET(IPLIST,NAMT,ARA)
+          ENDIF
+          IF(TEXT4.EQ.'MULT') THEN
+            ARA(:ILONG1)=ARA(:ILONG1)*FLOTT
+          ELSE IF(TEXT4.EQ.'SADD') THEN
+            ARA(:ILONG1)=ARA(:ILONG1)+FLOTT
+          ENDIF
+          IF(NTYPE.EQ.1) THEN
+            CALL LCMPDL(IPLIST,ISET,ILONG1,ITYBLK,ARA)
+          ELSE IF(NTYPE.EQ.3) THEN
+            CALL LCMPUT(IPLIST,NAMT,ILONG1,ITYBLK,ARA)
+          ENDIF
+          DEALLOCATE(ARA)
+        ELSE IF(ILONG1.EQ.0) THEN
+          CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT STORED.')
+        ENDIF
+      ELSE IF(TEXT4.EQ.'STEP') THEN
+*       CHANGE THE HIERARCHICAL LEVEL ON THE LCM OR XSM FILE.
+        CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+        IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+        IF(TEXT4.EQ.'UP') THEN
+          CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT)
+          IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+          IF(IMPX.GT.0) WRITE (6,190) NAMT
+          ILEV=ILEV+1
+          IF(ILEV.GT.MAXLEV) CALL XABORT('DRVUTL: MAXLEV OVERFLOW.')
+          CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+          IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+          IF(TEXT4.NE.'NEW') THEN
+            IPLIST=LCMGID(IPLIST,NAMT)
+            IPKEEP(ILEV)=IPLIST
+            GO TO 20
+          ELSE
+            CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+            IF((INDIC.EQ.3).AND.(TEXT4.EQ.'DICT')) THEN
+              IPLIST=LCMDID(IPLIST,NAMT)
+              IPKEEP(ILEV)=IPLIST
+            ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'LIST')) THEN
+              CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+              IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTE'
+     1        //'D.')
+              IPLIST=LCMLID(IPLIST,NAMT,NITMA)
+              IPKEEP(ILEV)=IPLIST
+            ELSE
+              CALL XABORT('DRVUTL: DICT OR LIST KEYWORD EXPECTED.')
+            ENDIF
+          ENDIF
+        ELSE IF(TEXT4.EQ.'AT') THEN
+          CALL REDGET(INDIC,ISET,FLOTT,NAMT,DFLOTT)
+          IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTED.')
+          IF(IMPX.GT.0) WRITE (6,195) ISET
+          ILEV=ILEV+1
+          IF(ILEV.GT.MAXLEV) CALL XABORT('DRVUTL: MAXLEV OVERFLOW.')
+          CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+          IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+          IF(TEXT4.NE.'NEW') THEN
+            IPLIST=LCMGIL(IPLIST,ISET)
+            IPKEEP(ILEV)=IPLIST
+            GO TO 20
+          ELSE
+            CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+            IF((INDIC.EQ.3).AND.(TEXT4.EQ.'DICT')) THEN
+              IPLIST=LCMDIL(IPLIST,ISET)
+              IPKEEP(ILEV)=IPLIST
+            ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'LIST')) THEN
+              CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+              IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTE'
+     1        //'D.')
+              IPLIST=LCMLIL(IPLIST,ISET,NITMA)
+              IPKEEP(ILEV)=IPLIST
+            ELSE
+              CALL XABORT('DRVUTL: DICT OR LIST KEYWORD EXPECTED.')
+            ENDIF
+          ENDIF
+        ELSE IF(TEXT4.EQ.'DOWN') THEN
+          IF(IMPX.GT.0) WRITE (6,'(/29H DRVUTL: STEP DOWN TO PARENT ,
+     1    6HLEVEL.)')
+          ILEV=ILEV-1
+          IF(ILEV.LT.1) CALL XABORT('DRVUTL: TOO MANY STEPS DOWN.')
+          IPLIST=IPKEEP(ILEV)
+        ELSE IF(TEXT4.EQ.'ROOT') THEN
+          IF(IMPX.GT.0) WRITE (6,'(/29H DRVUTL: STEP DOWN TO ROOT LE,
+     1    4HVEL.)')
+          ILEV=1
+          IPLIST=IPKEEP(1)
+        ENDIF
+      ELSE IF(TEXT4.EQ.'DIR') THEN
+*       PRINT THE DIRECTORY OF THE ACTIVE LEVEL.
+        CALL LCMLIB(IPLIST)
+      ELSE IF(TEXT4.EQ.'VAL') THEN
+*       VALIDATE A LCM OBJECT.
+        CALL LCMVAL(IPLIST,' ')
+      ELSE IF(TEXT4.EQ.'NAN') THEN
+*       CHECK FOR NAN IN LCM OBJECT.
+        CALL LCMNAN(IPLIST)
+      ELSE IF(TEXT4.EQ.'DUMP') THEN
+*       DUMP THE ACTIVE AND SON DIRECTORIES ON THE PRINTER.
+        CALL LCMEXP(IPLIST,0,6,2,1)
+      ELSE IF(TEXT4.EQ.';') THEN
+        IF(IMPX.GT.0) THEN
+          CALL LCMINF(IPLIST,NAMLCM,NAMMY,EMPTY,ILONG,LCM)
+          WRITE(6,260) NAMMY
+        ENDIF
+        RETURN
+      ELSE
+        WRITE(HSMG,'(8HDRVUTL: ,A4,30H IS AN INVALID UTILITY ACTION.)
+     1  ') TEXT4
+        CALL XABORT(HSMG)
+      ENDIF
+      GO TO 10
+*
+  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'.)
+  195 FORMAT (/27H DRVUTL: STEP AT COMPONENT ,I5,1H.)
+  200 FORMAT (/17H DRVUTL: COMPARE ,A8,26H ERRORS OF THE TWO BLOCKS:/)
+  210 FORMAT (/5H LEN=,I6,5X,7HEPSMAX=,F8.2,15H % IN COMPONENT,I6/16X,
+     1 7HEPSAVG=,F8.2,2H %)
+  220 FORMAT (/5H LEN=,I6,5X,7HEPSMAX=,E12.5,13H IN COMPONENT,I6/16X,
+     1 7HEPSAVG=,E12.5)
+  225 FORMAT (/29H DRVUTL: CONTENT OF COMPONENT,I6,5X,8HLENGTH =,I10,
+     1 5X,26HNUMBER OF NON ZERO TERMS =,I10/)
+  230 FORMAT (/27H DRVUTL: CONTENT OF BLOCK ',A12,1H',5X,8HLENGTH =,
+     1 I10,5X,26HNUMBER OF NON ZERO TERMS =,I10/)
+  240 FORMAT (/16H DRVUTL: BLOCK ',A12,21H' IS OF UNKNOWN TYPE./)
+  245 FORMAT (/18H DRVUTL: COMPONENT,I6,27H IS NOT STORED ON THE CURRE,
+     1 20HNT LCM OR XSM LEVEL./)
+  250 FORMAT (/16H DRVUTL: BLOCK ',A12,28H' IS NOT STORED ON THE CURRE,
+     1 20HNT LCM OR XSM LEVEL./)
+  260 FORMAT (/40H DRVUTL: LEAVING WITH ACTIVE DIRECTORY ',A12,2H'.)
+      END