summaryrefslogtreecommitdiff
path: root/Donjon/src/DSET1D.f
diff options
context:
space:
mode:
Diffstat (limited to 'Donjon/src/DSET1D.f')
-rw-r--r--Donjon/src/DSET1D.f245
1 files changed, 245 insertions, 0 deletions
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
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 19:01:27 +0000