Initial commit from Polytechnique Montreal

1 files changed, 165 insertions, 0 deletions

diff --git a/Donjon/src/DSET.f b/Donjon/src/DSET.f
new file mode 100644
index 0000000..7c30e46
--- /dev/null
+++ b/Donjon/src/DSET.f
@@ -0,0 +1,165 @@
+*DECK DSET
+      SUBROUTINE DSET(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Set new parameters for the user-selected devices and/or for the
+* groups of devices.
+*
+*Copyright:
+* Copyright (C) 2007 Ecole Polytechnique de Montreal.
+*
+*Author(s): 
+* D. Sekki
+*
+*Parameters: input
+* NENTRY  number of data structures transfered to this module.
+* HENTRY  name of the data structures.
+* IENTRY  data structure type where:
+*         IENTRY=1 for LCM memory object;
+*         IENTRY=2 for XSM file;
+*         IENTRY=3 for sequential binary file;
+*         IENTRY=4 for sequential ASCII file.
+* JENTRY  access permission for the data structure where:
+*         JENTRY=0 for a data structure in creation mode;
+*         JENTRY=1 for a data structure in modifications mode;
+*         JENTRY=2 for a data structure in read-only mode.
+* KENTRY  data structure pointer.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER      NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+      TYPE(C_PTR)  KENTRY(NENTRY)
+      CHARACTER    HENTRY(NENTRY)*12
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER(NSTATE=40,IOUT=6)
+      INTEGER ISTATE(NSTATE),RGRP
+      DOUBLE PRECISION DFLOT
+      CHARACTER TEXT*12,HSIGN*12
+      LOGICAL LROD
+      TYPE(C_PTR) IPDEV
+*----
+*  PARAMETER VALIDATION
+*----
+      IF(NENTRY.GT.1) CALL XABORT('@DSET: ONE PARAMETER ALLOWED.')
+      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('@DSET:'
+     1 //' LCM OBJECT EXPECTED AT LHS.')
+      CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_DEVICE') THEN
+        TEXT=HENTRY(1)
+        CALL XABORT('@DSET: SIGNATURE OF '//TEXT//' IS '//HSIGN//
+     1  '. L_DEVICE EXPECTED.')
+      ENDIF
+      IF(JENTRY(1).NE.1) CALL XABORT('@DSET: MODIFICATION MODE EX'
+     1 //'PECTED FOR L_DEVICE.')
+      IPDEV=KENTRY(1)
+*----
+*  RECOVER INFORMATION
+*----
+      CALL LCMGET(IPDEV,'STATE-VECTOR',ISTATE)
+      IGEO=ISTATE(1)
+      IF(IGEO.NE.7) CALL XABORT('@DSET: ONLY 3D-CARTESIAN GEOMETRY ALL'
+     1 //'OWED.')
+      NROD=ISTATE(2)
+      RGRP=ISTATE(3)
+      NLZC=ISTATE(4)
+      LGRP=ISTATE(5)
+      IMODE=ISTATE(6)
+      IF((IMODE.EQ.0).AND.(NROD.GT.0)) CALL XABORT('@DSET: IMODE NOT S'
+     1 //'ET.')
+*     READ PRINTING INDEX
+      CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+      IF(ITYP.NE.3) CALL XABORT('@DSET: CHARACTER DATA EXPECTED.')
+      IF(TEXT.NE.'EDIT') CALL XABORT('@DSET: KEYWORD EDIT EXPECTED.')
+      CALL REDGET(ITYP,IMPX,FLOT,TEXT,DFLOT)
+      IF(ITYP.NE.1) CALL XABORT('@DSET: INTEGER FOR EDIT EXPECTED.')
+      NDEV=0
+      NGRP=0
+   10 NDEV=NDEV+1
+      CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+*----
+*  ROD OPTION
+*----
+      IF(TEXT.EQ.'ROD') THEN
+        CALL REDGET(ITYP,ID,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.1) CALL XABORT('@DSET: INTEGER ROD-ID NUMB'
+     1   //'ER EXPECTED.')
+        IF((ID.GT.NROD).OR.(ID.EQ.0)) THEN
+          WRITE(IOUT,*)'@DSET: READ CURRENT ROD-ID #',ID
+          CALL XABORT('@DSET: WRONG ROD-ID NUMBER.')
+        ENDIF
+        IF(IMPX.GT.0) WRITE(IOUT,1000)ID
+        LROD=.TRUE.
+        CALL DSET1D(IPDEV,IMODE,ID,LROD,IMPX)
+*----
+*  LZC OPTION
+*----
+      ELSEIF(TEXT.EQ.'LZC') THEN
+        CALL REDGET(ITYP,ID,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.1)CALL XABORT('@DSET: INTEGER LZC-ID NUMB'
+     1   //'ER EXPECTED.')
+        IF((ID.GT.NLZC).OR.(ID.EQ.0)) THEN
+          WRITE(IOUT,*)'@DSET: READ CURRENT LZC-ID #',ID
+          CALL XABORT('@DSET: WRONG LZC-ID NUMBER.')
+        ENDIF
+        IF(IMPX.GT.0) WRITE(IOUT,1001)ID
+        LROD=.FALSE.
+        CALL DSET1D(IPDEV,IMODE,ID,LROD,IMPX)
+*----
+*  ROD-GROUP OPTION
+*----
+      ELSEIF(TEXT.EQ.'ROD-GROUP') THEN
+        CALL REDGET(ITYP,IGRP,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.1)CALL XABORT('@DSET: INTEGER GROUP-ID NUM'
+     1   //'BER EXPECTED.')
+        IF((IGRP.GT.RGRP).OR.(IGRP.LE.0)) THEN
+          WRITE(IOUT,*)'@DSET: READ CURRENT GROUP-ID #',IGRP
+          CALL XABORT('@DSET: WRONG ROD GROUP-ID NUMBER.')
+        ENDIF
+        IF(IMPX.GT.0) WRITE(IOUT,1002)IGRP
+        LROD=.TRUE.
+        CALL DSETGR(IPDEV,IMODE,IGRP,NDGR,LROD,IMPX)
+        NDEV=NDEV+NDGR-1
+        NGRP=NGRP+1
+*----
+*  LZC-GROUP OPTION
+*----
+      ELSEIF(TEXT.EQ.'LZC-GROUP') THEN
+        CALL REDGET(ITYP,IGRP,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.1)CALL XABORT('@DSET: INTEGER GROUP-ID NUM'
+     1   //'BER EXPECTED.')
+        IF((IGRP.GT.LGRP).OR.(IGRP.LE.0)) THEN
+          WRITE(IOUT,*)'@DSET: READ CURRENT GROUP-ID #',IGRP
+          CALL XABORT('@DSET: WRONG LZC GROUP-ID NUMBER.')
+        ENDIF
+        IF(IMPX.GT.0) WRITE(IOUT,1003)IGRP
+        LROD=.FALSE.
+        CALL DSETGR(IPDEV,IMODE,IGRP,NDGR,LROD,IMPX)
+        NDEV=NDEV+NDGR-1
+        NGRP=NGRP+1
+*
+      ELSEIF(TEXT.EQ.';') THEN
+        GOTO 20
+      ELSE
+        CALL XABORT('@DSET: WRONG KEYWORD '//TEXT)
+      ENDIF
+      GOTO 10
+   20 IF(IMPX.GT.0) WRITE(IOUT,1004)NGRP,NDEV-1
+      IF(IMPX.GT.4) CALL LCMLIB(IPDEV)
+      RETURN
+*
+ 1000 FORMAT(/5X,'DSET: ** SETING PARAMETERS FOR ROD #',I3.3)
+ 1001 FORMAT(/5X,'DSET: ** SETING PARAMETERS FOR LZC #',I2.2)
+ 1002 FORMAT(/5X,'DSET: ** SETING PARAMETERS FOR ROD-GROUP #',I2.2)
+ 1003 FORMAT(/5X,'DSET: ** SETING PARAMETERS FOR LZC-GROUP #',I2.2)
+ 1004 FORMAT(/5X,'--------------------------------------'/
+     1        5X,'TOTAL NUMBER OF UPDATED GROUPS  :',I4/
+     2        5X,'TOTAL NUMBER OF UPDATED DEVICES :',I4/)
+      END