From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Donjon/src/DSET.f | 165 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 165 insertions(+) create mode 100644 Donjon/src/DSET.f (limited to 'Donjon/src/DSET.f') 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 -- cgit v1.2.3