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/DEVGET.f | 279 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 279 insertions(+) create mode 100644 Donjon/src/DEVGET.f (limited to 'Donjon/src/DEVGET.f') 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 -- cgit v1.2.3