*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