summaryrefslogtreecommitdiff
path: root/Donjon/src/DEVGET.f
diff options
context:
space:
mode:
Diffstat (limited to 'Donjon/src/DEVGET.f')
-rw-r--r--Donjon/src/DEVGET.f279
1 files changed, 279 insertions, 0 deletions
diff --git a/Donjon/src/DEVGET.f b/Donjon/src/DEVGET.f
new file mode 100644
index 0000000..9744aaf
--- /dev/null
+++ b/Donjon/src/DEVGET.f
@@ -0,0 +1,279 @@
+*DECK DEVGET
+ SUBROUTINE DEVGET(JPDEV,NROD,LIMIT,IMODE,IMPX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Read the specification for a given rod from the input file.
+*
+*Copyright:
+* Copyright (C) 2007 Ecole Polytechnique de Montreal.
+*
+*Author(s):
+* D. Sekki and A. Hebert
+*
+*Parameters: input
+* JPDEV pointer to LCM list object with device information.
+* NROD total number of rods.
+* LIMIT full-core limits.
+* IMODE type of rod movement.
+* IMPX printing index (=0 for no print).
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) JPDEV
+ INTEGER NROD,IMODE,IMPX
+ REAL LIMIT(6)
+*----
+* LOCAL VARIABLES
+*----
+ PARAMETER(IOUT=6,MAXPRT=10)
+ INTEGER DMIX(2,MAXPRT)
+ REAL MAXPOS(6,MAXPRT),RODPOS(6,MAXPRT),LENG(2),LEVEL
+ DOUBLE PRECISION DFLOT
+ CHARACTER TEXT*12,RNAME*12,AXIS,FROM*2,HSMG*131
+ TYPE(C_PTR) KPDEV
+*----
+* ROD INDEX
+*----
+ CALL REDGET(ITYP,ID,FLOT,TEXT,DFLOT)
+ IF(ITYP.NE.1) CALL XABORT('@DEVGET: INTEGER ROD-ID EXPECTED.')
+ IF(ID.LE.0) CALL XABORT('@DEVGET: POSITIVE ROD-ID EXPECTED.')
+ IF(ID.GT.NROD)THEN
+ WRITE(IOUT,*)'@DEVGET: READ CURRENT ROD-ID #',ID
+ WRITE(IOUT,*)'@DEVGET: GIVEN TOTAL NUMBER OF RODS:',NROD
+ CALL XABORT('@DEVGET: WRONG INPUT OF ROD-ID NUMBER. GREATER'
+ 1 //' THAN THE TOTAL NUMBER OF RODS.')
+ ENDIF
+ CALL LCMLEL(JPDEV,ID,ILONG,ITYLCM)
+ IF(ILONG.NE.0) THEN
+ WRITE(HSMG,'(18H@DEVGET: ROD INDEX,I5,16H ALREADY EXISTS.)') ID
+ CALL XABORT(HSMG)
+ ENDIF
+ IF(IMPX.GT.1) WRITE(IOUT,1000) ID
+ KPDEV=LCMDIL(JPDEV,ID)
+*----
+* READ ROD-SPECIFIC DATA
+*----
+ IAXIS=0
+ NPART=0
+ ITOP=0
+ LEVEL=-999.0
+ SPEED=-999.0
+ TIME=-999.0
+ RNAME='NOT_DEFINED'
+ LENG(1)=MAX(LIMIT(2),LIMIT(4),LIMIT(6))
+ LENG(2)=MIN(LIMIT(1),LIMIT(3),LIMIT(5))
+ 10 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+ IF(ITYP.NE.3) CALL XABORT('@DEVGET: CHARECTER NAME EXPECTED.')
+ IF(TEXT.EQ.'ROD-NAME') THEN
+ CALL REDGET(ITYP,NITMA,FLOT,RNAME,DFLOT)
+ IF(ITYP.NE.3)CALL XABORT('@DEVGET: ROD NAME EXPECTED.')
+ ELSE IF(TEXT.EQ.'LEVEL') THEN
+ CALL REDGET(ITYP,NITMA,LEVEL,TEXT,DFLOT)
+ IF(ITYP.NE.2) CALL XABORT('@DEVGET: REAL LEVEL EXPECTED.')
+ IF(LEVEL.GT.1.0) CALL XABORT('@DEVGET: WRONG LEVEL VALUE > 1.')
+ IF(LEVEL.LT.0.0) CALL XABORT('@DEVGET: WRONG LEVEL VALUE < 0.')
+ ELSE IF(TEXT.EQ.'TIME') THEN
+ CALL REDGET(ITYP,NITMA,TIME,TEXT,DFLOT)
+ IF(ITYP.NE.2) CALL XABORT('@DEVGET: REAL FOR TIME EXPECTED.')
+ IF(TIME.LT.0.0) CALL XABORT('@DEVGET: WRONG TIME VALUE < 0.')
+ ELSE IF(TEXT.EQ.'SPEED') THEN
+ CALL REDGET(ITYP,NITMA,SPEED,TEXT,DFLOT)
+ IF(ITYP.NE.2) CALL XABORT('@DEVGET: REAL FOR SPEED EXPECTED.')
+ IF(SPEED.LT.0.0) CALL XABORT('@DEVGET: WRONG SPEED VALUE < 0.')
+ ELSE IF(TEXT.EQ.'AXIS') THEN
+ CALL REDGET(ITYP,NITMA,FLOT,AXIS,DFLOT)
+ IF(ITYP.NE.3)CALL XABORT('@DEVGET: AXIS NAME EXPECTED.')
+ IF(AXIS.EQ.'X') THEN
+ IAXIS=1
+ ELSE IF(AXIS.EQ.'Y') THEN
+ IAXIS=2
+ ELSE IF(AXIS.EQ.'Z') THEN
+ IAXIS=3
+ ELSE
+ CALL XABORT('@DEVGET: X, Y OR Z EXPECTED FOR AXIS.')
+ ENDIF
+ ELSE IF(TEXT.EQ.'FROM') THEN
+ CALL REDGET(ITYP,NITMA,FLOT,FROM,DFLOT)
+ IF(FROM.EQ.'H+')THEN
+ ITOP=1
+ ELSEIF(FROM.EQ.'H-')THEN
+ ITOP=-1
+ ELSE
+ CALL XABORT('@DEVGET: KEYWORD H+ OR H- EXPECTED.')
+ ENDIF
+ ELSE IF(TEXT.EQ.'MAXPOS') THEN
+ NPART=NPART+1
+ IF(NPART.GT.MAXPRT) CALL XABORT('@DEVGET: MAXPRT OVERFLOW.')
+ DO I=1,6
+ CALL REDGET(ITYP,NITMA,MAXPOS(I,NPART),TEXT,DFLOT)
+ IF(ITYP.NE.2) CALL XABORT('@DEVGET: REAL POSITION EXPECTED.')
+ ENDDO
+ IF(MAXPOS(2,NPART).LT.MAXPOS(1,NPART)) THEN
+ CALL XABORT('@DEVGET: WRONG X ROD COORDINATES: X- > X+')
+ ELSE IF(MAXPOS(1,NPART).LT.LIMIT(1)) THEN
+ CALL XABORT('@DEVGET: WRONG X- VALUE.')
+ ELSE IF(MAXPOS(2,NPART).GT.LIMIT(2)) THEN
+ CALL XABORT('@DEVGET: WRONG X+ VALUE.')
+ ELSE IF(MAXPOS(4,NPART).LT.MAXPOS(3,NPART)) THEN
+ CALL XABORT('@DEVGET: WRONG Y ROD COORDINATES: Y- > Y+')
+ ELSE IF(MAXPOS(3,NPART).LT.LIMIT(3)) THEN
+ CALL XABORT('@DEVGET: WRONG Y- VALUE.')
+ ELSE IF(MAXPOS(4,NPART).GT.LIMIT(4)) THEN
+ CALL XABORT('@DEVGET: WRONG Y+ VALUE.')
+ ELSE IF(MAXPOS(6,NPART).LT.MAXPOS(5,NPART)) THEN
+ CALL XABORT('@DEVGET: WRONG Z ROD COORDINATES: Z- > Z+')
+ ELSE IF(MAXPOS(5,NPART).LT.LIMIT(5)) THEN
+ CALL XABORT('@DEVGET: WRONG Z- VALUE.')
+ ELSE IF(MAXPOS(6,NPART).GT.LIMIT(6)) THEN
+ CALL XABORT('@DEVGET: WRONG Z+ VALUE.')
+ ENDIF
+ IF(IAXIS.EQ.0) THEN
+ WRITE(HSMG,'(33H@DEVGET: MISSING AXIS DATA IN ROD,I5)') ID
+ CALL XABORT(HSMG)
+ ELSE IF(IAXIS.EQ.1) THEN
+ LENG(1)=MIN(LENG(1),MAXPOS(1,NPART))
+ LENG(2)=MAX(LENG(2),MAXPOS(2,NPART))
+ ELSE IF(IAXIS.EQ.2) THEN
+ LENG(1)=MIN(LENG(1),MAXPOS(3,NPART))
+ LENG(2)=MAX(LENG(2),MAXPOS(4,NPART))
+ ELSE IF(IAXIS.EQ.3) THEN
+ LENG(1)=MIN(LENG(1),MAXPOS(5,NPART))
+ LENG(2)=MAX(LENG(2),MAXPOS(6,NPART))
+ ENDIF
+*
+ CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+ IF(TEXT.NE.'DMIX') THEN
+ WRITE(HSMG,'(30H@DEVGET: DMIX EXPECTED FOR ROD,I5)') ID
+ CALL XABORT(HSMG)
+ ENDIF
+ DO I=1,2
+ CALL REDGET(ITYP,DMIX(I,NPART),FLOT,TEXT,DFLOT)
+ IF(ITYP.NE.1) CALL XABORT('@DEVGET: INTEGER DMIX EXPECTED.')
+ ENDDO
+ ELSE IF(TEXT.EQ.'ENDROD') THEN
+ GO TO 20
+ ELSE
+ WRITE(HSMG,'(26H@DEVGET: INVALID KEYWORD (,A,9H) FOR ROD,I5)')
+ 1 TEXT,ID
+ CALL XABORT(HSMG)
+ ENDIF
+ GO TO 10
+*----
+* VALIDATE ROD POSITION
+*----
+ 20 IF(IMPX.GT.1) THEN
+ DO 25 IPART=1,NPART
+ WRITE(IOUT,1001) RNAME,IPART,MAXPOS(1,IPART),MAXPOS(3,IPART),
+ 1 MAXPOS(5,IPART),MAXPOS(2,IPART),MAXPOS(4,IPART),MAXPOS(6,IPART)
+ 25 CONTINUE
+ ENDIF
+ EPS=1.0E-4*(LENG(2)-LENG(1))
+ DO 30 IPART=1,NPART-1
+ IF(IAXIS.EQ.1) THEN
+ IF((ABS(MAXPOS(1,IPART)-MAXPOS(2,IPART+1)).GT.EPS).AND.
+ 1 (ABS(MAXPOS(2,IPART)-MAXPOS(1,IPART+1)).GT.EPS)) THEN
+ WRITE(HSMG,1008) IPART,ID
+ CALL XABORT(HSMG)
+ ENDIF
+ ELSE IF(IAXIS.EQ.2) THEN
+ IF((ABS(MAXPOS(3,IPART)-MAXPOS(4,IPART+1)).GT.EPS).AND.
+ 1 (ABS(MAXPOS(4,IPART)-MAXPOS(3,IPART+1)).GT.EPS)) THEN
+ WRITE(HSMG,1008) IPART,ID
+ CALL XABORT(HSMG)
+ ENDIF
+ ELSE IF(IAXIS.EQ.3) THEN
+ IF((ABS(MAXPOS(5,IPART)-MAXPOS(6,IPART+1)).GT.EPS).AND.
+ 1 (ABS(MAXPOS(6,IPART)-MAXPOS(5,IPART+1)).GT.EPS)) THEN
+ WRITE(HSMG,1008) IPART,ID
+ CALL XABORT(HSMG)
+ ENDIF
+ ENDIF
+ 30 CONTINUE
+*----
+* SET CURRENT ROD POSITION
+*----
+ IF(NPART.EQ.0) THEN
+ WRITE(HSMG,'(35H@DEVGET: MISSING MAXPOS DATA IN ROD,I5)') ID
+ CALL XABORT(HSMG)
+ ELSE IF(ITOP.EQ.0) THEN
+ WRITE(HSMG,'(33H@DEVGET: MISSING FROM DATA IN ROD,I5)') ID
+ CALL XABORT(HSMG)
+ ENDIF
+ IF(LEVEL.GE.0.0) THEN
+ DO 45 IPART=1,NPART
+ DO 40 I=1,6
+ RODPOS(I,IPART)=MAXPOS(I,IPART)
+ 40 CONTINUE
+ 45 CONTINUE
+ IF(IMODE.EQ.1) THEN
+* FADING ROD
+ DELH=LEVEL*(LENG(2)-LENG(1))
+ ELSE IF(IMODE.EQ.2) THEN
+* MOVING ROD
+ IF(ITOP.EQ.-1) THEN
+ DELH=LEVEL*(LENG(2)-LIMIT(1))+LIMIT(1)
+ ELSE IF(ITOP.EQ.1) THEN
+ DELH=LIMIT(2)-LEVEL*(LIMIT(2)-LENG(1))
+ ENDIF
+ DELH=MIN(LIMIT(2),MAX(LIMIT(1),DELH))
+ IF(IMPX.GT.3) THEN
+ WRITE(IOUT,*) ' ADJ ',NXSEQ,' LEVEL ',LEVEL*100.,
+ 1 '% OF INSERTION'
+ WRITE(IOUT,*) ' NEW POSITION (L_sup)= ',DELH
+ ENDIF
+ ENDIF
+ CALL MOVCHK(0,IMODE,NPART,IAXIS,ITOP,DELH,LENG,RODPOS)
+ ENDIF
+*----
+* STORE ROD DATA
+*----
+ CALL LCMPUT(KPDEV,'ROD-ID',1,1,ID)
+ CALL LCMPUT(KPDEV,'ROD-PARTS',1,1,NPART)
+ CALL LCMPTC(KPDEV,'ROD-NAME',12,RNAME)
+ CALL LCMPUT(KPDEV,'FROM',1,1,ITOP)
+ CALL LCMPUT(KPDEV,'AXIS',1,1,IAXIS)
+ CALL LCMPUT(KPDEV,'LENGTH',2,2,LENG)
+ IF(LEVEL.GE.0.0) CALL LCMPUT(KPDEV,'LEVEL',1,2,LEVEL)
+ IF(SPEED.GE.0.0) CALL LCMPUT(KPDEV,'SPEED',1,2,SPEED)
+ IF(TIME.GE.0.0) CALL LCMPUT(KPDEV,'TIME',1,2,TIME)
+ IF(LEVEL.GE.0.0) CALL LCMPUT(KPDEV,'MAX-POS',6*NPART,2,MAXPOS)
+ CALL LCMPUT(KPDEV,'ROD-POS',6*NPART,2,RODPOS)
+ CALL LCMPUT(KPDEV,'ROD-MIX',2*NPART,1,DMIX)
+*
+ IF(IMPX.GT.1) THEN
+ DO 50 IPART=1,NPART
+ WRITE(IOUT,1002) RNAME,IPART,RODPOS(1,IPART),RODPOS(3,IPART),
+ 1 RODPOS(5,IPART),RODPOS(2,IPART),RODPOS(4,IPART),RODPOS(6,IPART)
+ 50 CONTINUE
+ WRITE(IOUT,1003) LENG(2)-LENG(1),FROM,AXIS
+ IF(LEVEL.GE.0.0) WRITE(IOUT,1004) LEVEL
+ IF(SPEED.GE.0.0) WRITE(IOUT,1005) SPEED
+ IF(TIME.GE.0.0) WRITE(IOUT,1006) TIME
+ WRITE(IOUT,1007)
+ ENDIF
+ RETURN
+*
+ 1000 FORMAT(/3X,'DEVGET: =>',2X,'ROD #',I3.3)
+ 1001 FORMAT(/5X,'ROD NAME',1X,'=>',1X,A,'(PART',I5,')'/
+ 1 5X,'FULL-INSERTED ROD POSITION :',
+ 2 4X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4/
+ 3 37X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4/5X,80(1H-))
+ 1002 FORMAT(/5X,'ROD NAME',1X,'=>',1X,A,'(PART',I5,')'/
+ 1 5X,'CURRENT ROD POSITION :',
+ 1 5X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4/
+ 2 32X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4/5X,80(1H-))
+ 1003 FORMAT(5X,'ROD LENGTH =',F9.4/
+ 1 5X,'INSERTION FROM : ',A2,5X,'MOVEMENT AXIS : ',A1)
+ 1004 FORMAT(5X,'INSERTION LEVEL =',F8.4)
+ 1005 FORMAT(5X,'INSERTION SPEED =',1P,E11.4)
+ 1006 FORMAT(5X,'INSERTION TIME =',1P,E11.4)
+ 1007 FORMAT(5X,80(1H-)/5X,80(1H-))
+ 1008 FORMAT(39H@DEVGET: INCORRECT ROD POSITION IN PART,I5,
+ 1 7H OF ROD,I5)
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 14:49:29 +0000