SUBROUTINE ASSIGN_LIST( UNIT_NUM, SECTION_INDEX, RANGE_BITS, & ORDER_LIST, FIRST_ITEM_INTEGER, FIRST_ITEM_REAL, REDEFINED, & ERROR ) C---------------------------------------------------------------------- C- C- Purpose and Methods : Assigns values from the file to elements of the C- item. Parses everything up to and including the end of line following the C- END_LIST statement. C- C- Inputs : C- UNIT_NUM The IO unit number C- SECTION_INDEX The index into the arrays describing each section C- RANGE_BITS The array of ranges each variable is valid over C- ORDER_LIST The stack indicating the order the dimensions vary C- C- Outputs : C- FIRST_ITEM_INTEGER The first member of the item, used for integer C- assignments C- FIRST_ITEM_REAL The first member of the itme, used for real C- assignments C- REDEFINED Is there an assignment made to a member that has C- already been assigned to. If DIAGNOSTICS is .FALSE., C- this variable is never accessed. C- ERROR Error status. .TRUE. on error. C- 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' INTEGER JBIT EXTERNAL JBIT C C Argument declarations C INTEGER UNIT_NUM INTEGER SECTION_INDEX INTEGER RANGE_BITS(1:MAX_NUM_DIMENSIONS) INTEGER ORDER_LIST(1:STACK_PTR) INTEGER FIRST_ITEM_INTEGER(1:*) REAL FIRST_ITEM_REAL(1:*) LOGICAL REDEFINED LOGICAL ERROR C C Local variables C INTEGER COUNTS(1:5) INTEGER COUNT INTEGER NUM_FULL_DIMEN INTEGER REORDER(1:STACK_PTR) LOGICAL GET_NEXT INTEGER POSITION LOGICAL RANGE_ARRAY(1:MAX_NUM_DIMENSIONS, 32) LOGICAL NO_ASSIGNMENT C C ORDER_LIST maps varying speed to array dimension ( 1..5 ) C REORDER maps array dimension to varying speed C INTEGER TOKEN CHARACTER*20 STRING_VALUE REAL NUMBER_VALUE C C make another stack, the inverse of ORDER_LIST C REORDER(STACK_PTR) = 0 REORDER(STACK_LIST) = ORDER_LIST(STACK_LIST) DO COUNT = 1, 5 CALL POS_VAR( COUNT, ORDER_LIST, POSITION ) CALL PUSH_VAR( POSITION, REORDER ) END DO C C Count how many dimensions are empty C DO COUNT = 5, 1, -1 IF (WIDTHS(COUNT, SECTION_INDEX) .NE. 1) THEN NUM_FULL_DIMEN = COUNT GOTO 4000 ENDIF END DO NUM_FULL_DIMEN = 0 4000 CONTINUE C C Transform RANGE_BITS to RANGE_ARRAY C DO POSITION = 1, 32 DO COUNT = 1, MAX_NUM_DIMENSIONS C&IF VAXVMS,VAXELN IF (BTEST(RANGE_BITS(ORDER_LIST(COUNT)), POSITION-1)) THEN C&ELSE C& IF (JBIT(RANGE_BITS(ORDER_LIST(COUNT)), POSITION) .EQ. 1) THEN C&ENDIF RANGE_ARRAY(COUNT, POSITION) = .TRUE. ELSE RANGE_ARRAY(COUNT, POSITION) = .FALSE. ENDIF END DO END DO C C loop through the variables. Check if all non-list variables = 1, if so, C get next number from file. exit loop when all numbers have been read in. C IF (DIAGNOSTICS) REDEFINED = .FALSE. C C need to simulate DO loops with WHILE loops because the indicies need to C be array elements, and FORTRAN doesn't seem to allow DO loops with C array elements as indicies C COUNTS(1) = 1 DO WHILE (COUNTS(1) .LE. WIDTHS(ORDER_LIST(1), SECTION_INDEX) ) COUNTS(2) = 1 DO WHILE (COUNTS(2) .LE. WIDTHS(ORDER_LIST(2), SECTION_INDEX) ) COUNTS(3) = 1 DO WHILE (COUNTS(3) .LE. & WIDTHS(ORDER_LIST(3), SECTION_INDEX) ) COUNTS(4) = 1 DO WHILE (COUNTS(4) .LE. & WIDTHS(ORDER_LIST(4), SECTION_INDEX) ) COUNTS(5) = 1 DO WHILE (COUNTS(5) .LE. & WIDTHS(ORDER_LIST(5), SECTION_INDEX) ) C C only check if it is time to get the next item if the current values for C all the list variables are active C NO_ASSIGNMENT = .FALSE. DO COUNT = 1, ORDER_LIST(STACK_LIST) IF ( RANGE_ARRAY(COUNT, COUNTS(COUNT)) & .NEQV. .TRUE.) THEN NO_ASSIGNMENT = .TRUE. GOTO 1000 ! Exit loop ENDIF END DO 1000 CONTINUE IF (NO_ASSIGNMENT) GOTO 3000 C GET_NEXT = .TRUE. DO COUNT = ORDER_LIST(STACK_LIST) + 1, NUM_FULL_DIMEN IF (COUNTS(COUNT) .NE. 1 ) THEN GET_NEXT = .FALSE. GOTO 2000 ! Exit loop ENDIF END DO 2000 CONTINUE C IF (GET_NEXT) THEN CALL CHECK_NEXT_TOKEN( UNIT_NUM, T_NUMBER, TOKEN, & STRING_VALUE, NUMBER_VALUE, ERROR, & CHECK_TOKEN + IGNORE_EOL ) IF (ERROR) THEN CALL MESSAGE_OUT(MES_EXPECTED_NUMBER, SECTION_INDEX, & STRING_VALUE ) CALL FINISH_SECTION( UNIT_NUM ) GOTO 999 ENDIF ENDIF C C no assignment will be made if none of the non-list variables are active C NO_ASSIGNMENT = .FALSE. DO COUNT = ORDER_LIST(STACK_LIST) + 1, NUM_FULL_DIMEN IF (RANGE_ARRAY(COUNT, COUNTS(COUNT) ) & .NEQV. .TRUE. ) THEN NO_ASSIGNMENT = .TRUE. GOTO 2500 ENDIF END DO 2500 CONTINUE IF (NO_ASSIGNMENT) GOTO 3000 C C check for reassignment if DIAGNOSTICS are on C POSITION = (COUNTS(REORDER(1)) -1) + & WIDTHS(1, SECTION_INDEX) * & (COUNTS(REORDER(2)) -1) + & WIDTHS(1, SECTION_INDEX) * & WIDTHS(2, SECTION_INDEX) * & (COUNTS(REORDER(3)) -1) + & WIDTHS(1, SECTION_INDEX) * & WIDTHS(2, SECTION_INDEX) * & WIDTHS(3, SECTION_INDEX) * & (COUNTS(REORDER(4)) -1) + & WIDTHS(1, SECTION_INDEX) * & WIDTHS(2, SECTION_INDEX) * & WIDTHS(3, SECTION_INDEX) * & WIDTHS(4, SECTION_INDEX) * & (COUNTS(REORDER(5)) -1) + 1 C IF (DIAGNOSTICS) THEN IF (DATA_TYPE(SECTION_INDEX) .EQ. DATA_INTEGER) THEN IF (FIRST_ITEM_INTEGER( POSITION ) .NE. & MIN_INTEGER) THEN REDEFINED = .TRUE. ENDIF ELSE IF (FIRST_ITEM_REAL( POSITION ) .NE. MIN_REAL) THEN REDEFINED = .TRUE. ENDIF ENDIF ENDIF C C assign the value C IF (DATA_TYPE(SECTION_INDEX) .EQ. DATA_INTEGER) THEN FIRST_ITEM_INTEGER( POSITION ) = NUMBER_VALUE ELSE FIRST_ITEM_REAL( POSITION ) = NUMBER_VALUE ENDIF C C repeat the loop C 3000 CONTINUE COUNTS(5) = COUNTS(5) + 1 END DO COUNTS(4) = COUNTS(4) + 1 END DO COUNTS(3) = COUNTS(3) + 1 END DO COUNTS(2) = COUNTS(2) + 1 END DO COUNTS(1) = COUNTS(1) + 1 END DO C C next should be END_OF_LINE C CALL PARSE_EOL( UNIT_NUM, ERROR) IF (ERROR) GOTO 999 C C next should be END_LIST C CALL CHECK_NEXT_TOKEN( UNIT_NUM, T_END_LIST, TOKEN, & STRING_VALUE, NUMBER_VALUE, ERROR, CHECK_TOKEN + & IGNORE_EOL ) IF (ERROR) THEN CALL MESSAGE_OUT(MES_EXPECT_END_LIST, SECTION_INDEX, & STRING_VALUE) CALL FINISH_SECTION( UNIT_NUM ) GOTO 999 ENDIF C C next should be END_OF_LINE C CALL PARSE_EOL( UNIT_NUM, ERROR ) IF (ERROR) GOTO 999 C C C 999 RETURN END