FTN4 SUBROUTINE LEVEL(LU1,DCB1,ROOT,BUF1,LVLWD,IERR) +,92069-16210 REV.2013 790322 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18210 C RELOC: 92069-16210 C C C****************************************************************: C C C************************************************* C LEVEL RETURNS 0 IN IERR IF THE LEVEL WORD IN THE ROOT FILE NAMR C EQUALS THE LEVEL WORD IN LVLWD. OTHERWISE, LEVEL RETURNS -211 C IN IERR. C C START= THE NUMBER OF THE FIRST RECORD IN THE ROOT FILE C PAST THE OVERHEAD RECORDS. C DBLFG= OFFSET FROM START WHERE LEVEL FLAG IS LOCATED. C DBLVL= OFFSET FROM START WHERE FIRST LEVEL WORD SITS. C****************************************************** INTEGER LU1,DCB1(1),ROOT(1),BUF1(1),LVLWD(1),IERR INTEGER DBLFG,THREE,DBLVL INTEGER START INTEGER BLANK(3) DATA DBLFG/14/,THREE/3/,DBLVL/15/ DATA BLANK/2H ,2H ,2H / C******************************************************* C FIND RECORD NUMBER OF START. C CALL EREAD(DCB1,IERR,BUF1,256,LEN,DBLEI(1)) CALL DBER2(LU1,IERR,ROOT,6HLEVEL ,2HXX) IF (IERR .LT. 0) RETURN START=BUF1 C******************************************************** C RETURN IERR = 0 IF NO LEVEL WORDS DEFINED IN SCHEMA. C CALL EREAD(DCB1,IERR,BUF1,256,LEN,DBLEI(START)) CALL DBER2(LU1,IERR,ROOT,6HLEVEL ,2HXX) IF (IERR .LT. 0) RETURN IF (BUF1(DBLFG) .EQ. -1) GO TO 9999 C******************************************************** C GET THE INDEX OF HIGHEST LEVEL WORD INTO J C DO 10 J=14,0,-1 IHIGH = DBLVL+THREE*J CALL COMP(LU1,BLANK,BUF1(IHIGH),3,IERR) IF (IERR .LT. 0) GO TO 9000 10 CONTINUE C******************************************************** C INDEX OF HIGHEST LEVEL WORD IS IN J. COMPARE WITH LVLWD. C 9000 CONTINUE CALL COMP(LU1,LVLWD,BUF1(IHIGH),3,IERR) IF (IERR .EQ. 0) GO TO 9999 IERR=-211 CALL REIO(2,LU1,16H BAD LEVEL WORD.,-16) CALL DBER2(LU1,IERR,6HXXXXXX,6HLEVEL ,2HXX) RETURN C******************************************************** C LEVEL WORD IS GOOD. C 9999 IERR=0 RETURN END