C---------------------------------------------------------------------- C- C- PARSE_MISC routines C- C- Purpose and Methods : A collection of routines used by the C- PARSE_SECTION routine. C- C- Created 27-JUN-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- C C C SUBROUTINE PARSE_END_WITH( UNIT_NUM, EMPTY_WITH, & ORDER_VAR, ERROR ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Parses an END_WITH statement. Checks to see if there C- is a WITH to match the END_WITH by seeing if there are any variables C- left on the stack. If there is, the top variable is pulled off the C- stack and the routine returns after parsing the END_OF_LINE at the end C- of the statement. C- C- Inputs : C- UNIT_NUM The IO unit number C- EMPTY_WITH Whether there was no assignment in this WITH block C- ORDER_VAR (*MODIFIED*) The stack of variables C- C- Outputs : C- ERROR The error status. .TRUE. on error C- C- Controls: none C- C- Created 27-JUN-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.PARAMS' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.INC' C C Argument declarations C INTEGER UNIT_NUM INTEGER ORDER_VAR(STACK_PTR) LOGICAL EMPTY_WITH LOGICAL ERROR C C Local variables C INTEGER POSITION C ERROR = .FALSE. C C C no corresponding WITH C IF ( ORDER_VAR(STACK_PTR) .LT. 1 ) THEN ERROR = .TRUE. CALL MESSAGE_OUT(MES_NO_WITH, 0, ' ') CALL FINISH_SECTION( UNIT_NUM ) GOTO 999 ENDIF C C remove variable from stack, and continue loop C CALL PULL_VAR( ORDER_VAR, POSITION) C C check for a with statement without an assignment C IF (DIAGNOSTICS .AND. EMPTY_WITH) THEN CALL MESSAGE_OUT(MES_EMPTY_WITH, 0, ' ') ENDIF C C Should be followed by an END_OF_LINE C CALL PARSE_EOL( UNIT_NUM, ERROR) IF (ERROR) GOTO 999 C 999 RETURN END C C C SUBROUTINE PARSE_END_SECTION( UNIT_NUM, EMPTY_SECTION, & ORDER_VAR, ERROR ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Parses an END_SECTION statement. Checks that there C- are no unclosed WITH statements by checking that there are no variables C- left on the stack ORDER_VAR. If diagnostics are on, it prints a message C- about an empty section if it is appropriate. C- C- Inputs : C- UNIT_NUM The IO unit number C- EMPTY_SECTION Tells whether to print a message about empty sections C- ORDER_VAR The stack of variables C- C- Outputs : C- ERROR Error status. .TRUE. on error C- C- Controls: none C- C- Created 28-JUN-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.PARAMS' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.INC' C C Argument declarations C INTEGER UNIT_NUM LOGICAL EMPTY_SECTION INTEGER ORDER_VAR(1:STACK_PTR) LOGICAL ERROR C C parse an END_SECTION. there must be no unclosed WITH statements C ERROR = .FALSE. IF ( ORDER_VAR(STACK_PTR) .NE. 0 ) THEN ERROR = .TRUE. CALL MESSAGE_OUT(MES_NO_ENDWITH, 0, ' ') CALL FINISH_SECTION( UNIT_NUM ) GOTO 999 ENDIF C C if DIAGNOSTICS is on, check to see if no assignments were made in the C section C IF (DIAGNOSTICS .AND. EMPTY_SECTION) THEN CALL MESSAGE_OUT(MES_EMPTY_SECTION, 0, ' ') ENDIF C C Should be followed by an END_OF_LINE C CALL PARSE_EOL(UNIT_NUM, ERROR) IF (ERROR) GOTO 999 C 999 RETURN END C C C SUBROUTINE PARSE_EOL( UNIT_NUM, ERROR ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Gets the next token from the input stream. If it is C- not an END_OF_LINE, print an error message and finish off the section. C- C- Inputs : UNIT_NUM The IO unit number C- Outputs : ERROR Error status. .TRUE. on error. C- Controls: none C- C- Created 28-JUN-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.PARAMS' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.INC' C C Argument declarations C INTEGER UNIT_NUM LOGICAL ERROR C C Local variables C INTEGER TOKEN CHARACTER*20 STRING_VALUE REAL NUMBER_VALUE C C C CALL CHECK_NEXT_TOKEN( UNIT_NUM, T_END_OF_LINE, TOKEN, & STRING_VALUE, NUMBER_VALUE, ERROR, & CHECK_TOKEN ) IF (ERROR) THEN CALL MESSAGE_OUT(MES_EXPECT_EOL, 0, STRING_VALUE) CALL FINISH_SECTION( UNIT_NUM ) GOTO 999 ENDIF C 999 RETURN END C C C SUBROUTINE VARIABLE_VALID( VARIABLE, SECTION_INDEX, VALID ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Check if a variable is valid in a given section. C- C- Inputs : VARIABLE the varible to check validity C- SECTION_INDEX the index that tells what array elements C- describe this section C- Outputs : VALID .TRUE. if the variable is valid, .FALSE. C- otherwise. C- Controls: none C- C- Created 6-JUL-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' C C Argument declarations C INTEGER VARIABLE INTEGER SECTION_INDEX LOGICAL VALID C C Local variables C INTEGER POSITION C C Call VARIABLE_INDEX. If POSITION is non-zero, the variable is valid. C CALL VARIABLE_INDEX( VARIABLE, SECTION_INDEX, POSITION ) IF (POSITION .EQ. 0) THEN VALID = .FALSE. ELSE VALID = .TRUE. ENDIF C 999 RETURN END C C C SUBROUTINE TRANSFORM_RANGE( SECTION_INDEX, RANGE_PROM, & RANGE_CHANNEL, RANGE_LOOKUP, RANGE_SIGN_ETA, RANGE_PHI, & RANGE_MAGN_ETA, RANGE_PAGE, RANGE_INDEX, RANGE_BIN, RANGE_ARRAY, & ERROR ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Places the ranges into RANG_ARRAY in the order given C- by VARIABLE_ORDER( *, SECTION_INDEX). At the same time, it merges CHANNEL C- and LOOKUP, and checks to see if the their ranges are valid as specified. C- It then fills all dummy ranges with 1. C- C- Inputs : C- SECTION_INDEX The index into the arrays that describe the sections. C- C- RANGE_PROM Bits set in these variables indicate the range each C- RANGE_CHANNEL variable is active over. Only those active in the C- RANGE_LOOKUP current section are accessed. C- RANGE_SIGN_ETA C- RANGE_PHI C- RANGE_MAGN_ETA C- RANGE_PAGE C- RANGE_INDEX C- RANGE_BIN C- C- Outputs : C- RANGE_ARRAY The array holding the ranges in the order used by the C- common block arrays. C- ERROR Error status. .TRUE. on error C- C- Controls: none C- C- Created 6-JUL-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.PARAMS' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.INC' INTEGER JBIT EXTERNAL JBIT C C Argument declarations C INTEGER SECTION_INDEX INTEGER RANGE_PROM INTEGER RANGE_CHANNEL INTEGER RANGE_LOOKUP INTEGER RANGE_SIGN_ETA INTEGER RANGE_PHI INTEGER RANGE_MAGN_ETA INTEGER RANGE_PAGE INTEGER RANGE_INDEX INTEGER RANGE_BIN INTEGER RANGE_ARRAY(1:MAX_NUM_DIMENSIONS) LOGICAL ERROR C C Local declarations C INTEGER COUNT C C Loop through the VARIABLE_ORDER array. If VARIABLE_ORDER(COUNT) is the C token of a variable, assign that variable's range to C RANGE_ARRAY(COUNT). Merge COUNT and LOOKUP if they need to be assigned. C If VARIABLE_ORDER(COUNT,SECTION_INDEX) is T_DUMMY, C ERROR = .FALSE. DO COUNT = 1, MAX_NUM_DIMENSIONS IF (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. T_DUMMY) THEN RANGE_ARRAY(COUNT) = 1 C ELSEIF (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. T_PROM) THEN RANGE_ARRAY(COUNT) = RANGE_PROM C ELSEIF (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. & T_SIGN_ETA) THEN RANGE_ARRAY(COUNT) = RANGE_SIGN_ETA C ELSEIF (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. T_PHI) THEN RANGE_ARRAY(COUNT) = RANGE_PHI C ELSEIF (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. & T_MAGN_ETA) THEN RANGE_ARRAY(COUNT) = RANGE_MAGN_ETA C ELSEIF (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. T_PAGE) THEN RANGE_ARRAY(COUNT) = RANGE_PAGE C ELSEIF (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. T_INDEX) THEN RANGE_ARRAY(COUNT) = RANGE_INDEX C ELSEIF (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. T_BIN) THEN RANGE_ARRAY(COUNT) = RANGE_BIN C ELSEIF (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. T_CHANNEL) THEN RANGE_ARRAY(COUNT) = RANGE_CHANNEL C ELSEIF ((VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. T_TOT ) .OR. & (VARIABLE_ORDER(COUNT,SECTION_INDEX) .EQ. T_LOOKUP)) THEN RANGE_ARRAY(COUNT) = 0 C C&IF VAXVMS,VAXELN IF (BTEST(RANGE_CHANNEL, EM_TOWER-1)) THEN IF (BTEST(RANGE_LOOKUP, ET_LOOKUP-1)) THEN RANGE_ARRAY(COUNT) = IBSET(RANGE_ARRAY(COUNT), & EM_ET_QUANT-1) ENDIF C IF (BTEST(RANGE_LOOKUP, L2_LOOKUP-1)) THEN RANGE_ARRAY(COUNT) = IBSET(RANGE_ARRAY(COUNT), & EM_L2_QUANT-1) ENDIF ENDIF C IF (BTEST( RANGE_CHANNEL, HD_TOWER-1 )) THEN IF (BTEST( RANGE_LOOKUP, ET_LOOKUP-1)) THEN RANGE_ARRAY(COUNT) = IBSET(RANGE_ARRAY(COUNT), & HD_ET_QUANT-1 ) ENDIF C IF (BTEST(RANGE_LOOKUP, L2_LOOKUP-1 )) THEN RANGE_ARRAY(COUNT) = IBSET(RANGE_ARRAY(COUNT), & HD_L2_QUANT-1 ) ENDIF ENDIF C IF (BTEST(RANGE_CHANNEL, TOT_TOWER-1)) THEN IF (BTEST(RANGE_LOOKUP, ET_LOOKUP-1)) THEN RANGE_ARRAY(COUNT) = IBSET( RANGE_ARRAY(COUNT), & TOT_ET_QUANT-1) ENDIF C IF (BTEST(RANGE_LOOKUP, L2_LOOKUP-1)) THEN RANGE_ARRAY(COUNT) = IBSET( RANGE_ARRAY(COUNT), & TOT_L2_QUANT-1) ENDIF C IF (BTEST(RANGE_LOOKUP, PX_LOOKUP-1)) THEN RANGE_ARRAY(COUNT) = IBSET( RANGE_ARRAY(COUNT), & PX_QUANT-1 ) ENDIF C IF (BTEST(RANGE_LOOKUP, PY_LOOKUP-1)) THEN RANGE_ARRAY(COUNT) = IBSET( RANGE_ARRAY(COUNT), & PY_QUANT -1) ENDIF C ENDIF C&ELSE C& IF (JBIT( RANGE_CHANNEL, EM_TOWER) .EQ. 1) THEN C& IF (JBIT( RANGE_LOOKUP, ET_LOOKUP) .EQ. 1) THEN C& CALL SBIT1( RANGE_ARRAY(COUNT), EM_ET_QUANT ) C& ENDIF C&C C& IF (JBIT(RANGE_LOOKUP, L2_LOOKUP ) .EQ. 1) THEN C& CALL SBIT1( RANGE_ARRAY(COUNT), EM_L2_QUANT ) C& ENDIF C& ENDIF C&C C& IF (JBIT( RANGE_CHANNEL, HD_TOWER ) .EQ. 1) THEN C& IF (JBIT( RANGE_LOOKUP, ET_LOOKUP) .EQ. 1) THEN C& CALL SBIT1( RANGE_ARRAY(COUNT), HD_ET_QUANT ) C& ENDIF C&C C& IF (JBIT(RANGE_LOOKUP, L2_LOOKUP ) .EQ. 1) THEN C& CALL SBIT1( RANGE_ARRAY(COUNT), HD_L2_QUANT ) C& ENDIF C& ENDIF C&C C& IF (JBIT(RANGE_CHANNEL, TOT_TOWER) .EQ. 1) THEN C& IF (JBIT(RANGE_LOOKUP, ET_LOOKUP) .EQ. 1) THEN C& CALL SBIT1( RANGE_ARRAY(COUNT), TOT_ET_QUANT) C& ENDIF C&C C& IF (JBIT(RANGE_LOOKUP, L2_LOOKUP) .EQ. 1) THEN C& CALL SBIT1( RANGE_ARRAY(COUNT), TOT_L2_QUANT) C& ENDIF C&C C& IF (JBIT(RANGE_LOOKUP, PX_LOOKUP) .EQ. 1) THEN C& CALL SBIT1( RANGE_ARRAY(COUNT), PX_QUANT) C& ENDIF C&C C& IF (JBIT(RANGE_LOOKUP, PY_LOOKUP) .EQ. 1) THEN C& CALL SBIT1( RANGE_ARRAY(COUNT), PY_QUANT) C& ENDIF C&C C& ENDIF C&ENDIF C ELSE CALL MESSAGE_OUT(MES_PROG_TRANSRANGE, 0, 0) ERROR = .TRUE. GOTO 999 ENDIF C END DO C 999 RETURN END C C C SUBROUTINE LIST_CHECK_SPECIFIED( SECTION_INDEX, ORDER_VAR, ERROR ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Check if all non-integer variables have been C- specified, and that at least one variable remains to be specified. C- C- Inputs : SECTION_INDEX The index into the arrays describing each C- section. C- ORDER_VAR The stack of specified variables. C- Outputs : ERROR Error status. .TRUE. on error C- Controls: none C- C- Created 9-JUL-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declartions C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' C C Argument declarations C INTEGER SECTION_INDEX INTEGER ORDER_VAR(1:STACK_PTR) LOGICAL ERROR C C Local declarations C LOGICAL VALID INTEGER POSITION C C Check that there remains at least one variable to specify. C ERROR = .FALSE. IF (ORDER_VAR(STACK_PTR) .GT. & NUM_ACTIVE_VARIABLES(SECTION_INDEX) - 1) THEN CALL MESSAGE_OUT(MES_LIST_SPECALL, SECTION_INDEX, ' ') ERROR = .TRUE. GOTO 999 ENDIF C C Check that all the non-integer variables have been specified. Call C VARIABLE_VALID for each non-integer variable. If it is valid in the C current section, call POS_VAR to check that it has been specified. C CALL VARIABLE_VALID( T_CHANNEL, SECTION_INDEX, VALID ) IF (VALID) THEN CALL POS_VAR( T_CHANNEL, ORDER_VAR, POSITION ) IF ( POSITION .EQ. 0 ) THEN CALL MESSAGE_OUT(MES_LIST_NOTSPEC, SECTION_INDEX, ' ') ERROR = .TRUE. GOTO 999 ENDIF ENDIF C CALL VARIABLE_VALID( T_LOOKUP, SECTION_INDEX, VALID ) IF (VALID) THEN CALL POS_VAR( T_LOOKUP, ORDER_VAR, POSITION ) IF ( POSITION .EQ. 0 ) THEN CALL MESSAGE_OUT(MES_LIST_NOTSPEC, SECTION_INDEX, ' ') ERROR = .TRUE. GOTO 999 ENDIF ENDIF C CALL VARIABLE_VALID( T_PROM, SECTION_INDEX, VALID ) IF (VALID) THEN CALL POS_VAR( T_PROM, ORDER_VAR, POSITION ) IF ( POSITION .EQ. 0 ) THEN CALL MESSAGE_OUT(MES_LIST_NOTSPEC, SECTION_INDEX, ' ') ERROR = .TRUE. GOTO 999 ENDIF ENDIF C CALL VARIABLE_VALID( T_SIGN_ETA, SECTION_INDEX, VALID ) IF (VALID) THEN CALL POS_VAR( T_SIGN_ETA, ORDER_VAR, POSITION ) IF ( POSITION .EQ. 0 ) THEN CALL MESSAGE_OUT(MES_LIST_NOTSPEC, SECTION_INDEX, ' ') ERROR = .TRUE. GOTO 999 ENDIF ENDIF C 999 RETURN END C C C SUBROUTINE PARSE_REMAINING_VARIABLES( UNIT_NUM, SECTION_INDEX, & ORDER_VAR, RANGE_PROM, RANGE_SIGN_ETA, RANGE_PHI, & RANGE_MAGN_ETA, RANGE_PAGE, RANGE_INDEX, RANGE_BIN, ERROR ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Parses the remaining variables in a LIST statement. C- Adds the variables to the stack, and puts the ranges in the appropriate C- variables. When it returns, this routine, will have parsed the file up to C- and including the EOL at the end of the LIST statement. C- C- Inputs : C- UNIT_NUM The IO unit number C- SECTION_INDEX The index into the arrays describing each section C- C- Outputs : C- ORDER_VAR The stack of specified variables C- RANGE_PROM These are integers whose bits indicate the ranges each C- RANGE_SIGN_ETA of these variables vary over. C- RANGE_PHI C- RANGE_MAGN_ETA C- RANGE_PAGE C- RANGE_INDEX C- RANGE_BIN C- ERROR Error status. .TRUE. on error. C- C- Controls: none C- C- Created 9-JUL-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.PARAMS' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.INC' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' C C Argument declarations C INTEGER UNIT_NUM INTEGER SECTION_INDEX INTEGER ORDER_VAR(1:STACK_PTR) INTEGER RANGE_PROM INTEGER RANGE_SIGN_ETA INTEGER RANGE_PHI INTEGER RANGE_MAGN_ETA INTEGER RANGE_PAGE INTEGER RANGE_INDEX INTEGER RANGE_BIN LOGICAL ERROR C C Local variables C LOGICAL VALID INTEGER POSITION INTEGER TOKEN CHARACTER*20 STRING_VALUE REAL NUMBER_VALUE C C Loop over each variable until EOL is reached C ERROR = .FALSE. DO WHILE (.TRUE.) C C Get the next variable or END OF LINE C CALL CHECK_NEXT_TOKEN( UNIT_NUM, C_VARIABLE_NL, TOKEN, & STRING_VALUE, NUMBER_VALUE, ERROR, CHECK_CLASS) IF (ERROR) THEN CALL MESSAGE_OUT(MES_EXPECT_VAREN, SECTION_INDEX, & STRING_VALUE) CALL FINISH_SECTION(UNIT_NUM) GOTO 999 ENDIF C C If token is END_OF_LINE, can exit loop C IF (TOKEN .EQ. T_END_OF_LINE) GOTO 2000 C C See if the variable is valid in this section C CALL VARIABLE_VALID( TOKEN, SECTION_INDEX, VALID) IF (VALID .EQ. .FALSE.) THEN CALL MESSAGE_OUT(MES_NOT_VARVALID, SECTION_INDEX, & STRING_VALUE) ERROR = .TRUE. CALL FINISH_SECTION( UNIT_NUM ) GOTO 999 ENDIF C C Check that the variable hasn't already been specified C CALL POS_VAR( TOKEN, ORDER_VAR, POSITION ) IF ( POSITION .NE. 0 ) THEN CALL MESSAGE_OUT(MES_VARSPEC, SECTION_INDEX, STRING_VALUE) ERROR = .TRUE. CALL FINISH_SECTION( UNIT_NUM ) GOTO 999 ENDIF C C Add variable to stack C CALL PUSH_VAR( TOKEN, ORDER_VAR ) C C Build range depending on the variable C IF ( TOKEN .EQ. T_PHI ) THEN CALL BUILD_RANGE_LIST( UNIT_NUM, PHI_MIN, PHI_MAX, PHI_MIN, & RANGE_PHI, ERROR ) IF (ERROR) GOTO 999 C ELSEIF ( TOKEN .EQ. T_MAGN_ETA ) THEN CALL BUILD_RANGE_LIST( UNIT_NUM, ETA_MIN, ETA_MAX, ETA_MIN, & RANGE_MAGN_ETA, ERROR ) IF (ERROR) GOTO 999 C ELSEIF ( TOKEN .EQ. T_PAGE ) THEN CALL BUILD_RANGE_LIST( UNIT_NUM, PAGE_NUM_MIN, PAGE_NUM_MAX, & PAGE_NUM_MIN, RANGE_PAGE, ERROR ) IF (ERROR) GOTO 999 C ELSEIF ( TOKEN .EQ. T_INDEX ) THEN CALL BUILD_RANGE_LIST( UNIT_NUM, PAGE_INDEX_MIN, & PAGE_INDEX_MAX, PAGE_INDEX_MIN, RANGE_INDEX, ERROR ) IF (ERROR) GOTO 999 C ELSEIF ( TOKEN .EQ. T_BIN ) THEN CALL BUILD_RANGE_LIST( UNIT_NUM, L0_BIN_MIN, L0_BIN_MAX, & L0_BIN_MIN, RANGE_BIN, ERROR ) IF (ERROR) GOTO 999 C ELSE CALL MESSAGE_OUT(MES_PROG_PARREMVAR, SECTION_INDEX, ' ') ERROR = .TRUE. GOTO 999 ENDIF C END DO C 2000 CONTINUE C C All the variables have been parsed, and the end of line C 999 RETURN END C C C SUBROUTINE BUILD_SECOND_STACK(SECTION_INDEX, ORDER_VAR, & ORDER_LIST) C---------------------------------------------------------------------- C- C- Purpose and Methods : Builds a second stack for use in assigning the C- values from a LIST statement to the common block array. ORDER_LIST is a C- stack of indicies into WIDTHS and RANGE_ARRAY, in the order which the C- variables need to vary in the list assignment routine. The order is: C- C- Dummy Variables ^ Up in stack. C- Other Variables | Faster speed of variation. C- List Variables | C- C- Inputs : SECTION_INDEX The index into the arrays that describe each C- section C- ORDER_VAR The stack of specified variables C- Outputs : ORDER_LIST The stack of indicies into WIDTHS and C- RANGE_ARRAY C- Controls: none C- C- Created 10-JUL-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' C C Argument declarations C INTEGER SECTION_INDEX INTEGER ORDER_VAR(1:STACK_PTR) INTEGER ORDER_LIST(1:STACK_PTR) C C Local variables C INTEGER SPEED INTEGER POSITION C ORDER_LIST(STACK_PTR) = 0 ORDER_LIST(STACK_LIST) = ORDER_VAR(STACK_LIST) C C Loop through the variable stack and put the list variables onto the C second stack. CHANNEL and LOOKUP shouldn't be in this part of the C stack. C DO SPEED = ORDER_VAR(STACK_PTR) - ORDER_VAR(STACK_LIST) + 1, & ORDER_VAR(STACK_PTR) C CALL VARIABLE_INDEX(ORDER_VAR(SPEED), SECTION_INDEX, POSITION) IF (POSITION .EQ. 0) THEN C C If execution reaches the next statement, then an invalid variable has C been placed on the variable stack, and that shouldn't happen. C CALL MESSAGE_OUT(MES_PROG_BUILDSS, SECTION_INDEX, ' ') GOTO 999 ENDIF C CALL PUSH_VAR(POSITION, ORDER_LIST) C END DO C C Place non-list variables on the stack C DO SPEED = 1, ORDER_VAR(STACK_PTR) - ORDER_VAR(STACK_LIST) IF (ORDER_VAR(SPEED) .NE. T_LOOKUP) THEN CALL VARIABLE_INDEX( ORDER_VAR(SPEED), SECTION_INDEX, & POSITION) IF (POSITION .EQ. 0) THEN CALL MESSAGE_OUT(MES_PROG_BUILDSS, SECTION_INDEX, ' ') GOTO 999 ENDIF CALL PUSH_VAR( POSITION, ORDER_LIST) ENDIF END DO C C Place dummy variables on the stack C DO SPEED = ORDER_LIST(STACK_PTR) + 1, MAX_NUM_DIMENSIONS CALL PUSH_VAR( SPEED, ORDER_LIST) END DO C 999 RETURN END C C C SUBROUTINE VARIABLE_INDEX( VARIABLE, SECTION_INDEX, POSITION) C---------------------------------------------------------------------- C- C- Purpose and Methods : Finds the position the given variable is located in C- VARIABLE_ORDER(xxx, SECTION_INDEX). If the variable is not found, the C- position returned is 0. C- C- Inputs : VARIABLE The variable being checked for. C- SECTION_INDEX The index indicating the current section C- Outputs : POSITION The position VARIABLE is located at. C- Controls: none C- C- Created 10-JUL-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' C C Argument declarations C INTEGER VARIABLE INTEGER SECTION_INDEX INTEGER POSITION C C Loop through the VARIABLE_ORDER array for C this section and see if the token matches any of the valid variables. C If T_LOOKUP is found in VARIABLE_ORDER, then both CHANNEL and LOOKUP C are vaild in this section, and the six lookup quantities are valid. If C T_TOT is found in VARIABLE_ORDER, then both CHANNEL and LOOKUP are valid C in this section, and eight lookup quantities are valid. If T_DUMMY is C found in VARIABLE_ORDER, then all the possible valid variables have C been checked against. C DO POSITION = 1, MAX_NUM_DIMENSIONS C IF (VARIABLE_ORDER(POSITION, SECTION_INDEX) .EQ. T_DUMMY) THEN GOTO 1000 ENDIF C IF (VARIABLE .EQ. VARIABLE_ORDER(POSITION, SECTION_INDEX)) THEN GOTO 999 ENDIF C IF ((VARIABLE_ORDER(POSITION, SECTION_INDEX) .EQ. T_LOOKUP) & .AND. ( VARIABLE .EQ. T_CHANNEL ) ) THEN GOTO 999 ENDIF C IF ((VARIABLE_ORDER(POSITION, SECTION_INDEX) .EQ. T_TOT) .AND. & (( VARIABLE .EQ. T_CHANNEL ) .OR. ( VARIABLE .EQ. T_LOOKUP))) & THEN GOTO 999 ENDIF END DO C C If execution gets here, the variable read in was not matched against C any of the valid variables. C 1000 CONTINUE POSITION = 0 C 999 RETURN END C C C SUBROUTINE PARSE_WITH( UNIT_NUM, ORDER_VAR, SECTION_INDEX, RANGE, & ERROR ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Parses a WITH statement. Checks that there are C- still variables left to specify. Gets the variable, adds it C- to the stack, and builds the range associated with it. When this C- routine returns, it will have parsed everything upto and including the C- END_OF_LINE. C- C- Inputs : C- UNIT_NUM The IO unit number. C- SECTION_INDEX Tells which section currently in C- ORDER_VAR (*MODIFIED*) The stack of variables found. It is used to C- check if a variable has already been specified, and the C- new variable from the current WITH statement is added C- to this stack. C- C- Outputs : C- RANGE Bits set in this integer indicate the range the C- variable is active over. C- ERROR Error status. .TRUE. on error. C- C- Controls: none C- C- Created 26-JUN-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.PARAMS' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.INC' C C argument declarations C INTEGER UNIT_NUM INTEGER SECTION_INDEX INTEGER ORDER_VAR(1:STACK_PTR) INTEGER HOLDS(1:MAX_NUM_VARIABLES) INTEGER RANGE LOGICAL ERROR C C local variables C INTEGER TOKEN CHARACTER*20 STRING_VALUE REAL NUMBER_VALUE INTEGER POSITION LOGICAL VALID C C C Can only be NUM_ACTIVE_VARIABLES nested WITH statements in this section C ERROR = .FALSE. IF ( ORDER_VAR(STACK_PTR) .GE. & NUM_ACTIVE_VARIABLES( SECTION_INDEX ) ) THEN ERROR = .TRUE. CALL MESSAGE_OUT(MES_MANY_VAR, SECTION_INDEX, ' ') CALL FINISH_SECTION(UNIT_NUM) GOTO 999 ENDIF C C Get the variable C CALL CHECK_NEXT_TOKEN( UNIT_NUM, C_VARIABLE, TOKEN, & STRING_VALUE, NUMBER_VALUE, ERROR, & CHECK_CLASS ) IF (ERROR) THEN CALL MESSAGE_OUT(MES_EXPECT_VAR, SECTION_INDEX, ' ') CALL FINISH_SECTION( UNIT_NUM, STRING_VALUE ) GOTO 999 ENDIF C C See if it is a valid variable C CALL VARIABLE_VALID( TOKEN, SECTION_INDEX, VALID ) C C Check for no match. If no match was made, print an error message, skip C the rest of the section, and return C 2000 CONTINUE IF (VALID .EQ. .FALSE.) THEN ERROR = .TRUE. CALL MESSAGE_OUT(MES_NOT_VARVALID, SECTION_INDEX, ' ') CALL FINISH_SECTION( UNIT_NUM ) GOTO 999 ENDIF C C See if the variable has already been specified C CALL POS_VAR( TOKEN, ORDER_VAR, POSITION) IF (POSITION .NE. 0) THEN ERROR = .TRUE. CALL MESSAGE_OUT(MES_VARSPEC, SECTION_INDEX, ' ') CALL FINISH_SECTION( UNIT_NUM ) GOTO 999 ENDIF C C Variable is valid, so add to stack and parse the rest of the C statement. C CALL PUSH_VAR(TOKEN, ORDER_VAR) C IF (TOKEN .EQ. T_CHANNEL) THEN CALL BUILD_RANGE_CHANNEL( UNIT_NUM, RANGE, ERROR) IF (ERROR) GOTO 999 C ELSEIF (TOKEN .EQ. T_LOOKUP) THEN CALL BUILD_RANGE_LOOKUP( UNIT_NUM, RANGE, ERROR) IF (ERROR) GOTO 999 C ELSEIF (TOKEN .EQ. T_PROM) THEN CALL BUILD_RANGE_PROM( UNIT_NUM, RANGE, ERROR) IF (ERROR) GOTO 999 C ELSEIF (TOKEN .EQ. T_SIGN_ETA) THEN CALL BUILD_RANGE_SIGN_ETA( UNIT_NUM, RANGE, ERROR) IF (ERROR) GOTO 999 C ELSEIF (TOKEN .EQ. T_PHI) THEN CALL BUILD_RANGE_INTEGER( UNIT_NUM, PHI_MIN, PHI_MAX, & PHI_MIN, RANGE, ERROR) IF (ERROR) GOTO 999 C ELSEIF ( TOKEN .EQ. T_MAGN_ETA ) THEN CALL BUILD_RANGE_INTEGER( UNIT_NUM, ETA_MIN, ETA_MAX, & ETA_MIN, RANGE, ERROR) IF (ERROR) GOTO 999 C ELSEIF ( TOKEN .EQ. T_INDEX ) THEN CALL BUILD_RANGE_INTEGER( UNIT_NUM, PAGE_INDEX_MIN, & PAGE_INDEX_MAX, PAGE_INDEX_MIN, RANGE, ERROR ) IF (ERROR) GOTO 999 C ELSEIF ( TOKEN .EQ. T_PAGE ) THEN CALL BUILD_RANGE_INTEGER( UNIT_NUM, PAGE_NUM_MIN, PAGE_NUM_MAX, & PAGE_NUM_MIN, RANGE, ERROR ) IF (ERROR) GOTO 999 C ELSEIF ( TOKEN .EQ. T_BIN ) THEN CALL BUILD_RANGE_INTEGER( UNIT_NUM, L0_BIN_MIN, L0_BIN_MAX, & L0_BIN_MIN, RANGE, ERROR) C ELSE CALL MESSAGE_OUT(MES_PROG_PARSEWITH, SECTION_INDEX, ' ') ERROR = .TRUE. GOTO 999 ENDIF C C BUILD_RANGE has already parsed the END_OF_LINE, so can just C repeat loop now C 999 RETURN END C C C SUBROUTINE CHECK_CHANNEL_LOOKUP( SECTION_INDEX, ORDER_VAR, & RANGE_CHANNEL, RANGE_LOOKUP, ERROR ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Checks for invalid ranges of channel and lookup for C- the specified section, and checks for illegal combinations of CHANNEL and C- LOOKUP. C- C- Inputs : C- SECTION_INDEX The index into the arrays describing each section C- ORDER_VAR The stack of currently specified variables C- RANGE_CHANNEL The range specified for CHANNEL C- RANGE_LOOKUP The range specified for LOOKUP C- C- Outputs : C- ERROR Error status. .TRUE. on error. C- C- Controls: none C- C- Created 12-JUL-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.PARAMS' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.INC' INTEGER JBIT EXTERNAL JBIT C C Argument declarations C INTEGER SECTION_INDEX INTEGER ORDER_VAR(1:STACK_PTR) INTEGER RANGE_CHANNEL INTEGER RANGE_LOOKUP LOGICAL ERROR C C Local variables C LOGICAL VALID INTEGER POSITION C C Either only CHANNEL is specified, only LOOKUP, or both. C Check for invalid ranges by section. C CALL POS_VAR( T_CHANNEL, ORDER_VAR, POSITION) IF ( POSITION .NE. 0) THEN C C Channel is specified C CALL POS_VAR( T_LOOKUP, ORDER_VAR, POSITION) IF (POSITION .NE. 0) THEN C C Lookup is specified C CALL VARIABLE_VALID( T_TOT, SECTION_INDEX, VALID) C Only need to check for TOT ET or TOT L2 if TOT is not valid IF (VALID .EQ. .FALSE.) THEN C Specifying TOT ET or TOT L2 C&IF VAXVMS,VAXELN IF (BTEST(RANGE_CHANNEL, TOT_TOWER-1)) THEN IF (BTEST(RANGE_LOOKUP, L2_LOOKUP-1)) THEN C&ELSE C& IF (JBIT( RANGE_CHANNEL, TOT_TOWER) .EQ. 1) THEN C& IF (JBIT( RANGE_LOOKUP, L2_LOOKUP) .EQ. 1) THEN C&ENDIF CALL MESSAGE_OUT(MES_CHANNEL_LOOKUP, SECTION_INDEX, & 'CHANNEL TOT and LOOKUP L2' ) ERROR = .TRUE. ENDIF C&IF VAXVMS,VAXELN IF (BTEST(RANGE_LOOKUP, ET_LOOKUP-1)) THEN C&ELSE C& IF (JBIT( RANGE_LOOKUP, ET_LOOKUP ) .EQ. 1) THEN C&ENDIF CALL MESSAGE_OUT(MES_CHANNEL_LOOKUP, SECTION_INDEX, & 'CHANNEL TOT and LOOKUP ET' ) ERROR = .TRUE. ENDIF ENDIF ENDIF C C Look for EM PX, EM PY, HD PX, or HD PY C C&IF VAXVMS,VAXELN IF (BTEST(RANGE_CHANNEL, EM_TOWER-1)) THEN IF (BTEST(RANGE_LOOKUP, PX_LOOKUP-1)) THEN C&ELSE C& IF (JBIT( RANGE_CHANNEL, EM_TOWER) .EQ. 1) THEN C& IF (JBIT( RANGE_LOOKUP, PX_LOOKUP) .EQ. 1)THEN C&ENDIF CALL MESSAGE_OUT(MES_CHANNEL_LOOKUP, SECTION_INDEX, & 'CHANNEL EM and LOOKUP ET' ) ERROR = .TRUE. ENDIF C&IF VAXVMS,VAXELN IF (BTEST(RANGE_LOOKUP, PY_LOOKUP-1)) THEN C&ELSE C& IF (JBIT( RANGE_LOOKUP, PY_LOOKUP) .EQ. 1) THEN C&ENDIF CALL MESSAGE_OUT(MES_CHANNEL_LOOKUP, SECTION_INDEX, & 'CHANNEL EM and LOOKUP PY') ENDIF ENDIF C C&IF VAXVMS,VAXELN IF (BTEST( RANGE_CHANNEL, HD_TOWER-1)) THEN IF (BTEST(RANGE_LOOKUP, PX_LOOKUP-1)) THEN C&ELSE C& IF (JBIT( RANGE_CHANNEL, HD_TOWER) .EQ. 1) THEN C& IF (JBIT( RANGE_LOOKUP, PX_LOOKUP) .EQ. 1) THEN C&ENDIF CALL MESSAGE_OUT(MES_CHANNEL_LOOKUP, SECTION_INDEX, & 'CHANNEL HD and LOOKUP PX') ERROR = .TRUE. ENDIF C&IF VAXVMS,VAXELN IF (BTEST( RANGE_LOOKUP, PY_LOOKUP-1)) THEN C&ELSE C& IF (JBIT( RANGE_LOOKUP, PY_LOOKUP) .EQ. 1) THEN C&ENDIF CALL MESSAGE_OUT(MES_CHANNEL_LOOKUP, SECTION_INDEX, & 'CHANNEL HD and LOOKUP PY') ERROR = .TRUE. ENDIF ENDIF C ELSE C C CHANNEL is specified, but LOOKUP isn't C C C If LOOKUP is not valid and the section is not TOWER_GEOMETRY_[RZ], then C CHANNEL TOT is illegal C CALL VARIABLE_VALID( T_LOOKUP, SECTION_INDEX, VALID) IF ((VALID .EQ. .FALSE.) .AND. & (INDEX_TO_SECTION(SECTION_INDEX) .NE. T_TOWER_GEOMETRY_R) & .AND. & (INDEX_TO_SECTION(SECTION_INDEX) .NE. T_TOWER_GEOMETRY_Z)) & THEN C&IF VAXVMS,VAXELN IF (BTEST( RANGE_CHANNEL, TOT_TOWER-1)) THEN C&ELSE C& IF (JBIT( RANGE_CHANNEL, TOT_TOWER) .EQ. 1) THEN C&ENDIF CALL MESSAGE_OUT(MES_CHANNEL_TOT, SECTION_INDEX, ' ') ERROR = .TRUE. ENDIF ENDIF ENDIF ENDIF C C If LOOKUP is specified, but CHANNEL isn't, there is no need to check. C 999 RETURN END C C C SUBROUTINE ENUMERATED_TO_REAL( ENUMERATED, VALUE ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Convert the token of an enumerated value to a C- numeric value. C- C- Inputs : ENUMERATED the token of the enumerated value C- Outputs : VALUE the numeric value that the enumerated value C- represents C- Controls: none C- C- Created 3-AUG-1990 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE C- C---------------------------------------------------------------------- IMPLICIT NONE C---------------------------------------------------------------------- C C Global declarations C INCLUDE 'D0$LEVEL1:PARSE_TOKENS.PARAMS' INCLUDE 'D0$LEVEL1:PARSE_TOKENS.INC' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.PARAMS' INCLUDE 'D0$LEVEL1:LEVEL1_LOOKUP.INC' C C Argument declarations C INTEGER ENUMERATED REAL VALUE C IF (ENUMERATED .EQ. T_DEPOSITED_ENERGY) THEN VALUE = DEPOSITED_ENERGY ELSEIF (ENUMERATED .EQ. T_TRANSVERSE_ENERGY) THEN VALUE = TRANSVERSE_ENERGY ELSE VALUE = 0 ENDIF C 999 RETURN END