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/DSET1D.f | 245 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 245 insertions(+) create mode 100644 Donjon/src/DSET1D.f (limited to 'Donjon/src/DSET1D.f') diff --git a/Donjon/src/DSET1D.f b/Donjon/src/DSET1D.f new file mode 100644 index 0000000..80e5727 --- /dev/null +++ b/Donjon/src/DSET1D.f @@ -0,0 +1,245 @@ +*DECK DSET1D + SUBROUTINE DSET1D(IPDEV,IMODE,ID,LROD,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Modify some parameters for a specified device. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal. +* +*Author(s): +* D. Sekki +* +*Parameters: input +* IPDEV pointer to device information. +* IMODE type of displacement: =1 for FADE; =2 for MOVE (DONJON3-type +* movement). +* ID identification number of a specified device. +* LROD flag for the device type: +* =.true. if rod-type device; =.false. if lzc-type device. +* IMPX printing index (=0 for no print). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDEV + INTEGER IMODE,ID,IMPX + LOGICAL LROD +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6,MAXPRT=10) + REAL RODPOS(6,MAXPRT),MAXPOS(6,MAXPRT),EMTPOS(6),FULPOS(6), + 1 LENG(2),LVOLD,LVNEW,LIMIT(6) + DOUBLE PRECISION DFLOT + CHARACTER TEXT*12,NXSEQ*12 + TYPE(C_PTR) JPDEV,KPDEV +*---- +* READ OPTION +*---- + ILEVEL=0 + ISPEED=0 + ISTIME=0 + 10 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.3)CALL XABORT('@DSET1D: CHARACTER DATA EXPECTED.') + IF(TEXT.EQ.'LEVEL')THEN + IF(ILEVEL.EQ.1)CALL XABORT('@DSET1D: LEVEL ALREADY DEFINED.') + CALL REDGET(ITYP,NITMA,LVNEW,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@DSET1D: REAL FOR LEVEL EXPECTED.') + IF(LVNEW.GT.1.)CALL XABORT('@DSET1D: WRONG LEVEL VALUE > 1.') + IF(LVNEW.LT.0.)CALL XABORT('@DSET1D: WRONG LEVEL VALUE < 0.') + ILEVEL=1 + ELSEIF(TEXT.EQ.'SPEED')THEN + IF(ISPEED.EQ.1)CALL XABORT('@DSET1D: SPEED ALREADY DEFINED.') + CALL REDGET(ITYP,NITMA,SPNEW,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@DSET1D: REAL FOR SPEED EXPECTED.') + IF(SPNEW.LT.0.)CALL XABORT('@DSET1D: WRONG SPEED VALUE < 0.') + ISPEED=1 + ELSEIF(TEXT.EQ.'TIME')THEN + IF(ISTIME.EQ.1)CALL XABORT('@DSET1D: TIME ALREADY DEFINED.') + CALL REDGET(ITYP,NITMA,TMNEW,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@DSET1D: REAL FOR TIME EXPECTED.') + IF(TMNEW.LT.0.)CALL XABORT('@DSET1D: WRONG TIME VALUE < 0.') + ISTIME=1 + ELSEIF(TEXT.EQ.'END')THEN + GOTO 20 + ELSE + WRITE(IOUT,*)'@DSET1D: INVALID KEYWORD ',TEXT + CALL XABORT('@DSET1D: OPTION OR END EXPECTED.') + ENDIF + GOTO 10 +*---- +* RECOVER DEVICE +*---- + 20 IF(LROD)THEN + CALL LCMGET(IPDEV,'CORE-LIMITS',LIMIT) + JPDEV=LCMGID(IPDEV,'DEV_ROD') + KPDEV=LCMGIL(JPDEV,ID) + CALL LCMGTC(KPDEV,'ROD-NAME',12,TEXT) + IF(IMPX.GT.0) WRITE(IOUT,1011) ID,TEXT + ELSE + JPDEV=LCMGID(IPDEV,'DEV_LZC') + KPDEV=LCMGIL(JPDEV,ID) + IF(IMPX.GT.0) WRITE(IOUT,1012) ID + ENDIF + IF((ILEVEL.NE.0).AND.LROD) THEN +*---- +* UPDATE ROD POSITION +*---- +* RECOVER OLD ROD PARAMETERS + CALL LCMGET(KPDEV,'ROD-PARTS',NPART) + CALL LCMGET(KPDEV,'LENGTH',LENG) + CALL LCMGET(KPDEV,'AXIS',IAXIS) + CALL LCMGET(KPDEV,'FROM',ITOP) + CALL LCMLEN(KPDEV,'LEVEL',ILONG,ITYLCM) + CALL LCMGTC(KPDEV,'ROD-NAME',12,NXSEQ) + IF((ILONG.GT.0).AND.(IMPX.GT.2)) THEN + CALL LCMGET(KPDEV,'ROD-POS',RODPOS) + CALL LCMGET(KPDEV,'LEVEL',LVOLD) + WRITE(IOUT,1000) LVOLD + DO 30 IPART=1,NPART + WRITE(IOUT,1001) IPART,RODPOS(1,IPART),RODPOS(3,IPART), + 1 RODPOS(5,IPART),RODPOS(2,IPART),RODPOS(4,IPART), + 2 RODPOS(6,IPART) + 30 CONTINUE + ENDIF +* MODIFY ROD POSITION + IF(IMPX.GT.1) WRITE(IOUT,1002) LVNEW + IF(IMODE.EQ.1) THEN +* FADING ROD + DELH=LVNEW*(LENG(2)-LENG(1)) + ELSE IF(IMODE.EQ.2) THEN +* MOVING ROD + IF(ITOP.EQ.-1) THEN + DELH=LVNEW*(LENG(2)-LIMIT(1))+LIMIT(1) + ELSE IF(ITOP.EQ.1) THEN + DELH=LIMIT(2)-LVNEW*(LIMIT(2)-LENG(1)) + ENDIF + DELH=MIN(LIMIT(2),MAX(LIMIT(1),DELH)) + IF(IMPX.GT.3) THEN + WRITE(IOUT,*) ' ADJ ',NXSEQ,' LEVEL ',LVNEW*100., + 1 '% OF INSERTION' + WRITE(IOUT,*) ' NEW POSITION (L_sup)= ',DELH + ENDIF + ENDIF + CALL LCMGET(KPDEV,'MAX-POS',RODPOS) + CALL MOVCHK(IMPX,IMODE,NPART,IAXIS,ITOP,DELH,LENG,RODPOS) +* STORE NEW PARAMETERS + CALL LCMPUT(KPDEV,'ROD-POS',6*NPART,2,RODPOS) + CALL LCMPUT(KPDEV,'LEVEL',1,2,LVNEW) +*---- +* UPDATE LZC POSITION +*---- + ELSE IF(ILEVEL.NE.0) THEN +* RECOVER OLD LZC PARAMETERS + CALL LCMGET(KPDEV,'MAX-POS',MAXPOS) + CALL LCMGET(KPDEV,'EMPTY-POS',EMTPOS) + CALL LCMGET(KPDEV,'FULL-POS',FULPOS) + CALL LCMGET(KPDEV,'HEIGHT',HEIGHT) + CALL LCMGET(KPDEV,'LEVEL',LVOLD) + CALL LCMGET(KPDEV,'AXIS',IAXIS) + IF(IMPX.GT.1) WRITE(IOUT,1005) LVOLD,EMTPOS(1),EMTPOS(3), + 1 EMTPOS(5),EMTPOS(2),EMTPOS(4),EMTPOS(6),FULPOS(1), + 2 FULPOS(3),FULPOS(5),FULPOS(2),FULPOS(4),FULPOS(6) +* MODIFY LZC POSITION + DELH=LVNEW*HEIGHT + IF(IAXIS.EQ.1) THEN + FULPOS(1)=MAXPOS(2,1)-DELH + EMTPOS(2)=FULPOS(1) + ELSEIF(IAXIS.EQ.2) THEN + FULPOS(3)=MAXPOS(4,1)-DELH + EMTPOS(4)=FULPOS(3) + ELSEIF(IAXIS.EQ.3) THEN + FULPOS(5)=MAXPOS(6,1)-DELH + EMTPOS(6)=FULPOS(5) + ENDIF +* STORE NEW PARAMETERS + CALL LCMPUT(KPDEV,'LEVEL',1,2,LVNEW) + CALL LCMPUT(KPDEV,'EMPTY-POS',6,2,EMTPOS) + CALL LCMPUT(KPDEV,'FULL-POS',6,2,FULPOS) + IF(IMPX.GT.1) WRITE(IOUT,1006) LVNEW,EMTPOS(1),EMTPOS(3), + 1 EMTPOS(5),EMTPOS(2),EMTPOS(4),EMTPOS(6),FULPOS(1), + 2 FULPOS(3),FULPOS(5),FULPOS(2),FULPOS(4),FULPOS(6) + ENDIF +*---- +* UPDATE SPEED +*---- + IF((ISPEED.NE.0).AND.LROD) THEN + CALL LCMLEN(KPDEV,'SPEED',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPDEV,'SPEED',SPOLD) + IF(IMPX.GE.2) WRITE(IOUT,1007) SPOLD,SPNEW + ELSE + IF(IMPX.GE.2) WRITE(IOUT,1008) SPNEW + ENDIF + CALL LCMPUT(KPDEV,'SPEED',1,2,SPNEW) + ELSE IF(ISPEED.NE.0) THEN + CALL LCMLEN(KPDEV,'RATE',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPDEV,'RATE',SPOLD) + IF(IMPX.GE.2) WRITE(IOUT,1007) SPOLD,SPNEW + ELSE + IF(IMPX.GE.2) WRITE(IOUT,1008) SPNEW + ENDIF + CALL LCMPUT(KPDEV,'RATE',1,2,SPNEW) + ENDIF +*---- +* UPDATE TIME +*---- + IF(ISTIME.NE.0) THEN + CALL LCMLEN(KPDEV,'TIME',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + CALL LCMGET(KPDEV,'TIME',TMOLD) + IF(IMPX.GE.2) WRITE(IOUT,1009) TMOLD,TMNEW + ELSE + IF(IMPX.GE.2) WRITE(IOUT,1010) TMNEW + ENDIF + CALL LCMPUT(KPDEV,'TIME',1,2,TMNEW) + ENDIF + RETURN +* + 1000 FORMAT( + 1 /5X,'DSET1D: PREVIOUS INSERTION LEVEL =',F8.4) + 1001 FORMAT( + 1 /5X,'DSET1D: PART =',I5/ + 2 5X,'PREVIOUS ROD POSITION :'/ + 3 5X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4/ + 4 5X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4) + 1002 FORMAT( + 1 /5X,'DSET1D: NEW INSERTION LEVEL =',F8.4) + 1005 FORMAT( + 1 /5X,'PREVIOUS LZC LEVEL =',F8.4/ + 2 5X,'PREVIOUS EMPTY-PART POSITION :'/ + 3 5X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4/ + 4 5X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4/ + 5 5X,'PREVIOUS FULL-PART POSITION :'/ + 6 5X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4/ + 7 5X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4/) + 1006 FORMAT( + 1 /5X,'NEW LZC LEVEL =',F8.4/ + 2 5X,'NEW EMPTY-PART POSITION :'/ + 3 5X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4/ + 4 5X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4/ + 5 5X,'NEW FULL-PART POSITION :'/ + 6 5X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4/ + 7 5X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4/) + 1007 FORMAT(/5X,'** SETING DEVICE SPEED **', + 1 /5X,'PREVIOUS SPEED:',F10.4 + 2 /5X,'NEW SPEED:',F10.4/) + 1008 FORMAT(/5X,'** SETING DEVICE SPEED **', + 1 /5X,'PREVIOUS SPEED: (UNDEFINED)' + 2 /5X,'NEW SPEED:',F10.4/) + 1009 FORMAT(/5X,'** SETING DEVICE TIME **', + 1 /5X,'PREVIOUS TIME:',F10.4 + 2 /5X,'NEW TIME:',F10.4/) + 1010 FORMAT(/5X,'** SETING DEVICE TIME **', + 1 /5X,'PREVIOUS TIME: (UNDEFINED)' + 2 /5X,'NEW TIME:',F10.4/) + 1011 FORMAT(/5X,' => ROD #',I3.3,4X,'ROD-NAME:',1X,A) + 1012 FORMAT(/5X,' => LZC #',I2.2) + END -- cgit v1.2.3