*DECK,HPA4
      OVCAP.
      SUBROUTINE HPA4 
* 
*            CONTROL ROUTINE FOR OVERLAY ( 4,0 )
*            HPA4 - UPDATE THE SHR HISTORY
* 
*CALL,HPACOM1 
*CALL,HPACOM4                                                            R2FCYB 
                                                                         R2FCYB 
*       TIME PRINT OUT CONTROLLED BY ( X=T) PARAMETER                    R2FCYB 
      IF (FROG(6) .NE. L"T") GO TO 10 
      CP = SECOND ()
      PRINT 9,CP                                                         R2FCYB 
    9 FORMAT ( ' ENTER HPA4 , SECOND = ',F10.3) 
   10 CONTINUE                                                           R2FCYB 
                                                                         R2FCYB 
*       INITIALIZE FILES AND DATA AREAS                                  R2FCYB 
      CALL INIDAT4                                                       R2FCYB 
                                                                         R2FCYB 
*       TEST FOR INPUT DATA REQUEST PRESENT                              R2FCYB 
      IF (FILEP(5) .EQ. 3HOFF) GO TO 400
      CALL MINPUT4                                                       R2FCYB 
*                                                                        R2FCYB 
*      TEST FOR CONFIGURATION DATA IN FCY BUFFER                         R2FCYB 
  400 IF (FCY(1,1) .NE. 0) GO TO 410                                     R2FCYB 
      FCY(1,1) = 50                                                      R2FCYB 
      IF (FCY(2,1).NE. 0) GO TO 410                                      HPA402J
      FCY(2,1) = 51                                                      HPA402J
      IF (FCY(3,1) .NE. 0) GO TO 500                                     HPA402J
  410 CALL STORC4 ('WRITE') 
                                                                         R2FCYB 
*       DELETE CONFIGURATION DATA / SAVE SHR ON SCR1 FOR NEWHF IN OL8 
  500 CALL XOVCAP ('PACK4',0,0) 
      CALL UOVCAP ('PACK4') 
  
*                                                                        R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE CONF4                                                   R2FCYB 
*                                                                        R2FCYB 
**           CONF4  -  PROCESS THE INTERACTIVE INPUT OF HARDWARE         R2FCYB 
*                       SOFTWARE, AND SITE NAME                          R2FCYB 
*                        CONFIGURATION DATA AND STORE IN HISTORY.        R2FCYB 
*                                                                        R2FCYB 
*            CALLED BY - MINPUT4                                         R2FCYB 
*                                                                        R2FCYB 
*            ENTRY CONDITION  - THE INPUT COMMAND IS RELEVANT TO         R2FCYB 
*                     A HARDWARE, SOFTWARE, OR NAME ENTRY.               R2FCYB 
*                       INPUT FIELDS ARE PARSED IN (KC) ARRAY.           R2FCYB 
*            (IST) ARRAY IS SET BY  *MINPUT4*                            R2FCYB 
*                                                                        R2FCYB 
*            DATA AREAS -                                                R2FCYB 
*                  IST (1) = COMMAND POINTER                             R2FCYB 
*                  IST(1) ASSUMES THE VALUES:                            HPA402J
*                      A)  *CALL MODE * AFTER COMPLETING                 HPA402J
*                          A COMMAND FUNCTION                            HPA402J
*                      B)  INTEGER WHICH IS THE ORDINAL NUMBER           HPA402J
*                          OF THE COMMAND BEING EXECUTED                 HPA402J
*                                                                        HPA402J
*                  IST (2) = TYPE POINTER                                R2FCYB 
*                  IST(2) ASSUMES THE VALUES:                            HPA402J
*                     A)  0  WHICH IS THE RESET CONDITION                HPA402J
*                     B)  INTEGER WHICH IS THE ORDINAL NUMBER            HPA402J
*                         OF THE COMMAND OPERAND                         HPA402J
*                                                                        HPA402J
*                  IST (3) = MODE FLAG                                   R2FCYB 
*                  IST(3) ASSUMES THE VALUES:                            HPA402J
*                     A)  *COMMAND*                                      HPA402J
*                     B)  *CONTINUE*                                     HPA402J
*                  (FCY)  ARRAY BUFFER FOR CYBERAMA DATA                 R2FCYB 
*                                                                        R2FCYB 
*              EXIT CONDITION -  CURRENT MESSAGE HAS BEEN PROCESSED.     R2FCYB 
*                                                                        R2FCYB 
*CALL,HPACOM1                                                            R2FCYB 
*CALL,HPACOM4                                                            R2FCYB 
*     TEST FOR WHETHER A COMMAND OR COMMAND FUNCTION IS                  HPA402J
*     BEING PROCESSED:   COMMAND/CONTINUE                                HPA402J
                                                                         HPA402J
                                                                         HPA402J
      IF (COMMAND) GO TO 50                                              HPA402J
                                                                         HPA402J
*                                                                        HPA402J
*     IF IST(2) = 1 (IDENT)    GO TO 120                                 HPA402J
*                 2 (HARDWARE)       750                                 HPA402J
*                 3 (SOFTWARE)       320                                 HPA402J
      GO TO (120,750,320) IST(2)
                                                                         HPA402J
                                                                         HPA402J
*     COMMAND = .TRUE.                                                   HPA402J
*     IST(3) = COMMAND                                                   HPA402J
*                                                                        HPA402J
*     IF IST(2) = 1 (IDENT)    GO TO 100                                 HPA402J
*                 2 (HARDWARE)       200                                 HPA402J
*                 3 (SOFTWARE)       300                                 HPA402J
   50 GO TO (100,200,300) IST(2)
                                                                         R2FCYB 
                                                                         R2FCYB 
  100 CONTINUE                                                           R2FCYB 
*     IST(3) = COMMAND AND IST(2) = 1 (IDENT)                            HPA402J
*     DISPLAY 1ST REQUEST FOR INPUT                                      HPA402J
                                                                         HPA402J
                                                                         R2FCYB 
*          COMMAND RESPONSE                                              R2FCYB 
      PRINT 110                                                          R2FCYB 
  110 FORMAT ( ' ENTER ',/,' CUSTOMER-NAME,LOCATION', 
     .',CPU-TYPE,SERIAL') 
      FCY(1,64) = 5HNAME1                                                R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
*       PROCESS COMMANDED DATA                                           R2FCYB 
                                                                         R2FCYB 
*     IST(3) = CONTINUE AND IST(2) = 1 (IDENT)                           HPA402J
*     DETERMINE IF INPUT FROM 1ST PASS HAS BEEN PROCESSED                HPA402J
*     IF SO, THEN FCY(1,64) = NAME1                                      HPA402J
*     LOAD FCY (1,X) WITH SHR50 FROM KC                                  HPA402J
*     AND DISPLAY 2ND REQUEST FOR IDENT INPUT                            HPA402J
                                                                         HPA402J
  120 IF (FCY(1,64) .EQ. 5HNAME2) GO TO 140                              R2FCYB 
      FCY(1,1) = 50                                                      R2FCYB 
      FCY(1,3) = R"CY"
      IF (FLAGS(25) .NE. 0) FCY(1,4) = R"MMF" 
      IF(FCY(1,8) .EQ. 0) FCY(1,8) = FLAGS(20)
      FCY(1,9) = FLAGS(20)                                               R2FCYB 
                                                                         R2FCYB 
      FCY(1,10) = KC(1)                                                  R2FCYB 
      FCY(1,11) = 1H                                                     R2FCYB 
      FCY(1,12) = KC(2)                                                  R2FCYB 
      FCY(1,13) = KC(3)                                                  R2FCYB 
      FCY(1,14) = KC(4)                                                  R2FCYB 
                                                                         R2FCYB 
      PRINT 130                                                          R2FCYB 
  130 FORMAT (' ENTER',/,' APPLICATION,INDUSTRY-TYPE,', 
     .'INSTALL-DATE,SYSTEM-ID') 
      FCY(1,64) = 5HNAME2                                                R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         HPA402J
*     IF IST(3) = CONTINUE, IST(2) = 1 (IDENT), AND FCY(1,64) = NAME2    HPA402J
*                                                                        HPA402J
*     PROCESS INPUT FROM 2ND IDENT INPUT REQUEST                         HPA402J
                                                                         HPA402J
  140 FCY(1,15) = KC(1)                                                  R2FCYB 
      FCY(1,16) = 1H                                                     R2FCYB 
      FCY(1,17) = KC(2)                                                  R2FCYB 
      FCY(1,18) = KC(3)                                                  R2FCYB 
      FCY(1,19) = KC(4)                                                  R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
*     IF IST(3) = COMMAND AND IST(2) = 2 (HARDWARE)                      HPA402J
*                                                                        HPA402J
*     DISPLAY REQUEST FOR INPUT                                          HPA402J
                                                                         HPA402J
  200 PRINT 210                                                          R2FCYB 
  210 FORMAT (' ENTER ',/,'  PROD.,DESC.,SERIAL,DEGRADE ',
     .'FACTOR,EST,DEVICE TYPE,CH-EQ-UN,SYSTEM ID')
                                                                         R2FCYB 
*        SET POINTERS FOR 51 TYPE STORAGE NODE.                          R2FCYB 
      CALL NODE4 (IST(2))                                                R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
                                                                         HPA402J
*     IF IST(3) = COMMAND AND IST(2) = 3 (SOFTWARE)                      HPA402J
*                                                                        HPA402J
*     DISPLAY REQUEST FOR INPUT                                          HPA402J
                                                                         HPA402J
  300 PRINT 310                                                          R2FCYB 
  310 FORMAT( ' ENTER ',/,' PRODUCT,VERSION,PSR-LEVEL,',
     .'DEGRADE-FACTOR,INSTALL-DATE')
      CALL NODE4 (IST(2))                                                R2FCYB 
      GO TO 900                                                          HPA402J
                                                                         R2FCYB 
*     IF IST(3) = CONTINUE AND IST(2) = 3 (SOFTWARE)                     HPA402J
*                                                                        HPA402J
*     BLANK OUT KC(6)                                                    HPA402J
*     BRANCH TO 750 TO TRANSFER KC TO FCY USING STFCY4                   HPA402J
                                                                         HPA402J
  320 KC(6) = 1H                                                         R2GCYB 
                                                                         R2GCYB 
                                                                         HPA402J
*     IF IST(3) = CONTINUE AND IST(2) = 2 (HARDWARE)
*                                                                        HPA402J
*     TRANSFER KC TO FCY                                                 HPA402J
                                                                         HPA402J
*          STORE THE INPUT IN APPROPRIATE BLOCK IN FCY                   R2FCYB 
  750 CALL STFCY4                                                        R2FCYB 
                                                                         R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE EDIT4                                                   R2FCYB 
*                                                                        R2FCYB 
**       EDIT4  -- TO EDIT (CHANGE,DELETE) ENTRIES IN                    R2FCYB 
*              IN CONFIGURATION RECORDS (FCY).                           R2FCYB 
*                                                                        R2FCYB 
*      CALLED BY  ---   MINPUT4                                          R2FCYB 
*                                                                        R2FCYB 
*            IST(3) = PRESET TO CONTROL FLAGS                            R2FCYB 
*            KC(12) = PARSED INPUT MESSAGE                               R2FCYB 
*            FCY(36,64) = CURRENT BUFFER FOR CONFIG. DATA.               R2FCYB 
*                                                                        R2FCYB 
*CALL HPACOM1                                                            R2FCYB 
*CALL,HPACOM4                                                            R2FCYB 
      DIMENSION FIELD(8)                                                 R2FCYB 
                                                                         R2FCYB 
      DATA PTYPE /2/                                                     R2FCYB 
                                                                         R2FCYB 
      DATA FIELD(1) /1HA /                                               R2FCYB 
      DATA FIELD(2) /1HB /                                               R2FCYB 
      DATA FIELD(3) /1HC /                                               R2FCYB 
      DATA FIELD(4) /1HD /                                               R2FCYB 
      DATA FIELD(5) /1HE /                                               R2FCYB 
      DATA FIELD(6) /1HF /                                               R2FCYB 
      DATA FIELD(7) /1HG /                                               R2FCYB 
      DATA FIELD(8) /1HH /                                               R2FCYB 
                                                                         R2FCYB 
                                                                         HPA402J
*     SET RT WITH COMMAND OPERAND ORDINAL NUMBER                         HPA402J
                                                                         HPA402J
      RT = IST(2)                                                        HPA402J
                                                                         R2FCYB 
      IF (COMMAND) GO TO 80                                              HPA402J
                                                                         R2FCYB 
*       CONVERT ORDINAL TO INTEGER                                       R2FCYB 
      PORD = KC(1)                                                       R2FCYB 
      CALL IVAL4 (PORD)                                                  R2FCYB 
      IF (PORD .NE. 5HERROR) GO TO 20                                    R2FCYB 
*       INVALID INPUT, SEND ERROR MESSAGE                                R2FCYB 
   10 CALL INERR4 (1)                                                    R2GCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
*      JUMP TO DO NAME CHANGE ENTRY                                      R2FCYB 
                                                                         HPA402J
*     IST(3) = CONTINUE                                                  HPA402J
*     IF DELETE COMMAND (IST(1) = 2) BRANCH TO 400                       HPA402J
*     AND IF COMMAND OPERAND IS IDENT (IST(2) = 1) BRANCH TO 120         HPA402J
                                                                         HPA402J
 20   IF (DELETE) GO TO 400                                              HPA402J
      IF (IDENT) GO TO 120                                               HPA402J
                                                                         R2FCYB 
*      CONVERT FIELD CODE TO INTEGER                                     R2FCYB 
      WD = KC(2) .AND. O"77"
      DO 60 F = 1,8                                                      R2FCYB 
      WD = KC(2)                                                         R2FCYB 
      IF (WD .EQ. FIELD(F)) GO TO 320                                    HPA402J
   60 CONTINUE                                                           R2FCYB 
                                                                         R2FCYB 
*         NOT A VALID FIELD CODE                                         R2FCYB 
      CALL INERR4 (2)                                                    R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
                                                                         R2FCYB 
                                                                         HPA402J
*     IST(3) = COMMAND                                                   HPA402J
*     IST(1) .NE. 2 (DELETE)                                             HPA402J
*     BRANCH IF COMMAND OPERAND ORDINAL IS NOT IDENT                     HPA402J
                                                                         HPA402J
 80   IF (DELETE) GO TO 150                                              HPA402J
      IF (.NOT. IDENT) GO TO 200                                         HPA402J
*        COMMAND RESPONSE                                                R2FCYB 
      IF (FCY(1,1) .NE. 50) GO TO 810                                    R2FCYB 
      PRINT 101                                                          R2FCYB 
  101 FORMAT (' ENTER ',/,' ORDINAL#,DATA') 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
                                                                         HPA402J
*     IST(3) = CONTINUE                                                  HPA402J
*     IST(1) .NE. 2 (DELETE)                                             HPA402J
*     IST(2) = 1 (IDENT)                                                 HPA402J
                                                                         HPA402J
*        CHANGE NAME FIELD                                               R2FCYB 
  120 IF (FCY(1,1) .NE. 50) GO TO 810                                    R2FCYB 
      IF (PORD .GT. 8) GO TO 10                                          R2GCYB 
      IF(PORD .LE. 0) GO TO 10
                                                                         R2GCYB 
*        INSERT CURRENT DATE                                             R2GCYB 
      FCY(1,9) = FLAGS(20)                                               R2FCYB 
      IF (PORD .GT. 1) PORD = PORD + 1                                   R2FCYB 
      IF (PORD .GT. 6) PORD = PORD + 1                                   R2FCYB 
      P = TLIM(PTYPE,4) + PORD                                           R2FCYB 
      FCY(1,P) = KC(2)                                                   R2FCYB 
      IF (PORD .NE. 1) GO TO 125                                         R2FCYB 
      IF (KC(3) .NE. 1H ) FCY(1,P+1) = KC(3)                             R2GCYB 
      GO TO 900                                                          R2FCYB 
  125 IF (PORD .NE. 6) GO TO 900                                         R2FCYB 
      IF (KC(3) .NE. 1H ) FCY(1,P+1) = KC(3)                             R2GCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
                                                                         HPA402J
*     IST(3) = COMMAND                                                   HPA402J
*     BRANCH IF COMMAND IS DELETE  (IST(1) = 2)                          HPA402J
                                                                         HPA402J
  150 PRINT 151                                                          R2FCYB 
  151 FORMAT (' ENTER ',/,' ORDINAL#')
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
                                                                         HPA402J
*     IST(3) = COMMAND                                                   HPA402J
*     IST(1) .NE. 2 (DELETE)                                             HPA402J
*     IST(2) .NE. 1 (IDENT)                                              HPA402J
                                                                         HPA402J
*         COMMAND RESPONSE FOR HARDWARE/SOFTWARE CHANGE                  R2FCYB 
  200 PRINT 201                                                          R2FCYB 
  201 FORMAT (' ENTER ',/,' ORDINAL#,FIELD-CODE,DATA')
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
*        LOCATED THE ORDINAL IN (FCY)                                    R2FCYB 
 320  POFF = F - 1                                                       HPA402J
      CALL FORD4 (RT,PORD,X,Y)                                           HPA402J
                                                                         R2FCYB 
*         COMPUTE FIELD POSITION                                         R2FCYB 
      FLOC = Y + POFF                                                    R2FCYB 
      IF (X .EQ. 0) GO TO 800                                            R2FCYB 
                                                                         R2FCYB 
*         ENTER DATA FIELD CHANGE                                        R2FCYB 
      IF(.NOT.HARDWRE) GO TO 380
      IF(F.EQ.1) GO TO 380
      IF(F.LE.3) GO TO 370
      IF(F.NE.4) GO TO 330
      FLOC = FLOC + 1 
      KC(3) = KC(3).AND.MASK(18)
      FCY(X,FLOC) = FCY(X,FLOC).AND.O"0000 0077 7777 7777 7777" 
      GO TO 360 
  330 CONTINUE
      IF(F.NE.5) GO TO 340
      KC(3) = KC(3).AND.MASK(6) 
      KC(3) = SHIFT(KC(3),30) 
      FCY(X,FLOC) = FCY(X,FLOC).AND.MASK(30)
      GO TO 360 
  340 CONTINUE
      IF(F.NE.6) GO TO 350
      FLOC = FLOC - 4 
      GO TO 380 
  350 CONTINUE
      FLOC = FLOC - 2 
      IF(F.NE.7) GO TO 380
      KC(3) = KC(3).AND.MASK(12)
      KC(3) = SHIFT(KC(3),42) 
      FCY(X,FLOC) = FCY(X,FLOC).AND.O"7777 7700 0077 7777 7777" 
  360 CONTINUE
      FCY(X,FLOC) = FCY(X,FLOC).OR.KC(3)
      GO TO 390 
  370 CONTINUE
      FLOC = FLOC + 1 
  380 CONTINUE
      FCY (X,FLOC) = KC(3)                                               R2FCYB 
*                                                                        HPA404T
*         CHANGE CODE                                                    HPA404T
*                                                                        HPA404T
  390 CONTINUE
      FCY(X,Y+6) = IST(1)                                                HPA404T
                                                                         R2FCYB 
*        DATE OF CHANGE                                                  R2FCYB 
      FCY(X,Y+7) = FLAGS(20)                                             R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
*        PERFORM RECORD DELETE                                           R2FCYB 
  400 CALL FORD4 (RT,PORD,X,Y)                                           R2FCYB 
      IF (X .EQ. 0) GO TO 800                                            R2FCYB 
                                                                         R2FCYB 
                                                                         HPA402J
*      FOR A DELETE OPERATION, PLACE THE COMMAND ORDINAL                 HPA402J
*      IN WORD 7 OF THE PROPER BLOCK                                     HPA402J
                                                                         HPA402J
      FCY(X,Y+6) = IST(1)                                                HPA402J
                                                                         HPA402J
                                                                         R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
*         ERROR RETURN                                                   R2FCYB 
  800 CALL INERR4 (103)                                                  R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  810 CALL INERR4 (104)                                                  R2FCYB 
                                                                         R2FCYB 
                                                                         R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE FORD4 (RT,VREC,PB,PR)                                   R2FCYB 
*                                                                        R2FCYB 
**           FORD4  -- FIND A RECORD ORDINAL IN ARRAY (FCY)              R2FCYB 
*                     FOR ENTRY, OR CHANGE, OF CONFIG DATA.              R2FCYB 
*                                                                        R2FCYB 
*            CALLED -- EDIT4                                             R2FCYB 
*                                                                        R2FCYB 
*            ENTRY CONDITION --                                          R2FCYB 
*              RT = RECORD TYPE TO BE PROCESSED (1,2,OR 3)               R2FCYB 
*              VREC = VALUE OF ORDINAL TO BE FOUND.                      R2FCYB 
*                       IF VREC = 0, EMPTY SLOT TO BE FOUND.             R2FCYB 
*                       IF VREC = (N), N = ORDINAL TO FOUND.             R2FCYB 
*              PB,PR = X,Y SUBSCRIPT OF (FCY) TO BE RETURNED.            R2FCYB 
*                                                                        R2FCYB 
*            EXIT CONDITION  --                                          R2FCYB 
*               PB = 0 , ERROR CONDITION - ORDINAL NOT FOUND.            R2FCYB 
*               PB,PR = NN, = FCY ADDRESS LOCATED.                       R2FCYB 
*                                                                        R2FCYB 
      IMPLICIT INTEGER (F-Z)
*CALL,HPACOM4                                                            R2FCYB 
*            RECORD TYPE FLAG                                            R2FCYB 
      PRT = RT + 49                                                      R2FCYB 
*         BLOCK COUNTER                                                  R2FCYB 
      PB = 2                                                             R2FCYB 
*         RECORD COUNTER                                                 R2FCYB 
      KREC = 1                                                           R2FCYB 
*         RECORD ORDINAL - WITHIN BLOCK                                  R2FCYB 
      PR = 1                                                             R2FCYB 
*         RECORD ADDRESS - WITHIN BLOCK                                  R2FCYB 
      RA = TLIM(RT,4)                                                    R2GCYB 
                                                                         R2FCYB 
*        TEST RECORD TYPE OF BLOCK                                       R2FCYB 
  200 IF (FCY(PB,1) .EQ. 0) GO TO 800                                    R2FCYB 
      IF (FCY(PB,1) .EQ. PRT) GO TO 300 
      GO TO 450                                                          R2FCYB 
                                                                         R2FCYB 
  300 IF (FCY(PB,RA) .EQ. 0) GO TO 400                                   R2FCYB 
                                                                         R2FCYB 
*                    **  IF A HITT **                                    R2FCYB 
      IF (KREC. EQ. VREC) GO TO 700                                      R2FCYB 
      GO TO 420                                                          R2FCYB 
                                                                         R2FCYB 
*         TEST IF EMPTY SLOT NEEDED                                      R2FCYB 
  400 IF (VREC .EQ. 0) GO TO 700                                         R2FCYB 
      IF (KREC .EQ. VREC) GO TO 800                                      R2FCYB 
                                                                         R2FCYB 
*      ADVANCE BLOCK RECORD COUNT                                        R2FCYB 
  420 KREC = KREC + 1                                                    R2FCYB 
      PR = PR + 1                                                        R2GCYB 
      IF (PR .GT. TLIM(RT,2) ) GO TO 450                                 R2FCYB 
      RA = RA + TLIM(RT,3)                                               R2FCYB 
      GO TO 300                                                          R2FCYB 
                                                                         R2FCYB 
*        STEP BLOCK COUNTER                                              R2FCYB 
  450 PB = PB + 1                                                        R2FCYB 
      IF (PB .GT. TLIM(RT,1) ) GO TO 800                                 R2FCYB 
      RA = TLIM(RT,4)                                                    R2FCYB 
      PR = 1                                                             R2FCYB 
      GO TO 200                                                          R2FCYB 
                                                                         R2FCYB 
*         SET ORDINAL ADDRESS                                            R2FCYB 
  700 PR = RA                                                            R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  800 PB = 0                                                             R2FCYB 
                                                                         R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE IBLANK (IWRD)
* 
**        DESCRIPTION 
*         ----------- 
*         SUBROUTINE IBLANK FILLS ZERO BYTES (ONE BYTE IS 
*         6 BITS LONG) IN ONE CPU WORD WITH SPACE.
* 
*         ENTRY CONDITIONS
*         ----------------
*         IWRD - ONE CPU WORD WHOSE ZERO BYTES ARE TO BE FILLED 
*                WITH SPACE.
* 
*         EXIT CONDITIONS 
*         --------------- 
*         IWRD - ONE CPU WORD WHOSE ZERO BYTES WERE FILLED
*                WITH SPACE.
* 
      DO 1 J=1,10 
      IF ((IWRD .AND. O"77") .EQ. 0) IWRD = IWRD .OR. O"55" 
    1 IWRD = SHIFT(IWRD,6)
      RETURN
      END 
      SUBROUTINE INERR4 (P)                                              R2FCYB 
*                                                                        R2FCYB 
**         INERR4 - PROCESS ERROR MESSAGE WHEN INVALID DATA              R2FCYB 
*                   ENCOUNTERED BY INTERACTIVE INPUT EDITOR.             R2FCYB 
*                                                                        R2FCYB 
*          ENTRY CONDITION -    PARAMETER (P) POINTS TO ERROR CONDI.     R2FCYB 
*                  IF (P) = 10 ,OR LESS, POINTS TO ILLEGAL DATA          R2FCYB 
*                  FIELD IN ARRAY (KC).                                  R2FCYB 
*                  IF (P) = 101 , OR MORE, POINTS TO AN ERROR MESSAGE    R2FCYB 
*                  IN ARRAY (MESS).                                      R2FCYB 
*                                                                        R2FCYB 
*           EXIT CONDITION - MESAGE PRINTED.                             R2FCYB 
*                                                                        R2FCYB 
      IMPLICIT INTEGER (F-Z)
*CALL,HPACOM4                                                            R2FCYB 
      DIMENSION MES(3,8),PBUF(3)                                         R2FCYB 
      DATA (MES(N,1),N=1,3,1) / 
     .10H IDENT  AR,10HRAY  EXCEE,10HDED       /
      DATA (MES(N,2),N=1,3,1)/10H FCY ARRAY,10H EXCEEDED ,10H          /
                                                                         R2FCYB 
      DATA (MES(N,3),N=1,3,1)/10H ORDINAL N,10HOT FOUND  ,10H          /
                                                                         R2FCYB 
      DATA (MES(N,4),N=1,3,1) / 
     .10H NO SITE I,10HD. DATA IN,10H FILE.    /
                                                                         R2FCYB 
                                                                         R2FCYB 
      IF (P .GT. 100) GO TO 300                                          R2FCYB 
      PRINT 101, KC(P)                                                   R2FCYB 
  101 FORMAT (2X, ' INVALID INPUT FIELD ( ',A10,1H) ) 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  300 M = P-100                                                          R2FCYB 
      DO 305 K = 1,3                                                     R2FCYB 
  305 PBUF(K) = MES(K,M)                                                 R2FCYB 
      PRINT 200,PBUF(1),PBUF(2),PBUF(3)                                  R2FCYB 
  200 FORMAT (3A10)                                                      R2FCYB 
                                                                         R2FCYB 
*           PERFORM ERROR PROCESSING, AND ABORT IF NEEDED.               R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE INIDAT4                                                 R2FCYB 
*                                                                        R2FCYB 
**         INIDAT4  -- INITIALIZE DATA FILES AND DATA AREAS              R2FCYB 
*                      THAT ARE USED IN OVERLAY HPA4.                    R2FCYB 
*                                                                        R2FCYB 
*CALL,HPACOM1                                                            R2FCYB 
*CALL,HPACOM4                                                            R2FCYB 
                                                                         R2FCYB 
                                                                         R2FCYB 
*      TLIM (1,N) = (50) SITE DESCRIPTION BLOCK                          R2FCYB 
*       TLIM (2,N) = (51) HARDWARE BLOCK                                 R2FCYB 
*       TLIM (3,N) = (52) SOFTWARE BLOCK                                 R2FCYB 
                                                                         R2FCYB 
*       TLIM (N,1) = BLOCK QUANTITY LIMIT, IN FCY BUFFER.                R2FCYB 
*       TLIM (N,2) = RECORDS, PER BLOCK LIMIT.                           R2FCYB 
*       TLIM (N,3) = RECORD LENGTH.                                      R2FCYB 
*       TLIM (N,4) = RECORD START POINTER.                               R2FCYB 
                                                                         R2FCYB 
      DATA TLIM (1,1) /1/                                                R2FCYB 
      DATA TLIM (1,2) /1/                                                R2FCYB 
      DATA TLIM (1,3) /10/                                               R2FCYB 
      DATA TLIM (1,4) /10/                                               R2FCYB 
      DATA TLIM(2,1) /60/ 
      DATA TLIM (2,2) /7/                                                R2FCYB 
      DATA TLIM (2,3) /8/                                                R2FCYB 
      DATA TLIM (2,4) /9/                                                R2FCYB 
      DATA TLIM (3,1) /24/                                               R2FCYB 
      DATA TLIM (3,2) /7/                                                R2FCYB 
      DATA TLIM (3,3) /8/                                                R2FCYB 
      DATA TLIM (3,4) /9/                                                R2FCYB 
*          FCY BLOCK LIMIT                                               R2FCYB 
      DATA LIMFCY /54/
                                                                         HPA402J
*     INITIALIZE THE LOGICAL VARIABLES                                   HPA402J
                                                                         HPA402J
      ADD = .FALSE.                                                      HPA402J
      DELETE = .FALSE.                                                   HPA402J
      CHANGE = .FALSE.                                                   HPA402J
      INSERT = .FALSE.                                                   HPA402J
      LIST = .FALSE.                                                     HPA402J
      END4 = .FALSE.                                                     HPA402J
      IDENT = .FALSE.                                                    HPA402J
      HARDWRE = .FALSE.                                                  HPA402J
      SOFTWRE = .FALSE.                                                  HPA402J
      CALLMDE = .TRUE.                                                   HPA402J
      COMMAND = .TRUE.                                                   HPA402J
      DATA = .FALSE.                                                     HPA402J
                                                                         HPA402J
                                                                         R2FCYB 
*        CLEAR  (FL) POINTERS ,-- SEE DESCRIPTION IN (NODE4)             R2FCYB 
      DO 10 I = 1,8                                                      R2FCYB 
      DO 10 I2 = 1,4                                                     R2FCYB 
   10 POS(I,I2) = 0                                                      R2FCYB 
                                                                         R2FCYB 
      DO 20 K = 1,64                                                     R2FCYB 
      IFLD(K) = 0                                                        R2FCYB 
   20 CONTINUE
                                                                         R2FCYB 
*        INITIALIZE FILES                                                R2FCYB 
      CALL RMREWND (SCR2) 
      CALL RMREWND (OLD)
*                                                                        R2FCYB 
                                                                         R2FCYB 
*         CURRENT DISPLAY CODE DATE                                      R2FCYB 
      FLAGS(20) = IDATIM(1) 
                                                                         R2FCYB 
*    GET CURRENT JULIAN DATE FOR UPDATE OF 30 DAY HISTORY                R2FCYB 
      JD = IDATIM(3)
      JDAY = JD .AND. O"77 7777"
      FLAGS(21) = JD                                                     R2FCYB 
      JDAY = JDAY .OR. O"5555 5555 5555 5500 0000"
      DECODE (10,25 ,JDAY) FLAGS(23)                                     R2FCYB 
   25  FORMAT (I10)                                                      R2FCYB 
      JYR = SHIFT(JD,-18)                                                R2FCYB 
      JYR = JYR .AND. O"7777" 
      JYR = JYR .OR. O"5555 5555 5555 5555 0000"
      DECODE(10,25,JYR) JYRI                                             R2FCYB 
      JYRI = JYRI - 70                                                   R2FCYB 
      FLAGS(22) = JYRI                                                   R2FCYB 
      FLAGS(23) = FLAGS(23) .OR. (SHIFT(JYRI,9) )                        R2FCYB 
                                                                         R2FCYB 
      CALL RMREAD (OLD,IFLD,LENGTH) 
                                                                         R2FCYB 
                                                                         R2FCYB 
*        CLEAR SHR-CONFIG ARRAY FOR INPUT                                R2FCYB 
      DO 110 K = 1,64 
      DO 110 K2 = 1,LIMFCY                                               R2FCYB 
  110 FCY(K2,K) = 0                                                      R2FCYB 
                                                                         R2FCYB 
      DO 115 K = 1,8                                                     R2FCYB 
      IST(K) = 0                                                         R2FCYB 
      INP(K) = 0                                                         R2FCYB 
      KC(K) = 0                                                          R2FCYB 
  115 CONTINUE                                                           R2FCYB 
  
*        IF MULTI-MAINFRAME, READ HARDWARE CONFIGURATION BLOCK
      IF (FLAGS(25) .NE. 0) GO TO 200 
                                                                         R2FCYB 
*        LOAD FCY RECORDS FROM (OLD), IF ANY                             R2FCYB 
      IF (IFLD(1) .LT. 50) GO TO 900                                     R2FCYB 
                                                                         R2FCYB 
*        READ THE FCY BLOCKS                                             R2FCYB 
  200 CONTINUE
      CALL STORC4 ('READ')
                                                                         R2FCYB 
                                                                         R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE INSERT4                                                 HPA402J
*CALL,HPACOM1                                                            HPA402J
*CALL HPACOM4                                                            HPA402J
                                                                         HPA402J
      INTEGER AFWA,ASHR,ABLK                                             HPA402J
                                                                         HPA402J
**********************************************************************   HPA402J
**********************************************************************   HPA402J
                                                                         HPA402J
                                                                         HPA402J
      ENTRY INSRTA                                                       HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     ENTRY POINT FOR REQUESTING OPERATOR TO ENTER ORDINAL NUMBER        HPA402J
*     OF ITEM TO INSERT AFTER.                                           HPA402J
                                                                         HPA402J
      PRINT 1                                                            HPA402J
 1    FORMAT (' ENTER',/,' ORDINAL NUMBER') 
      RETURN                                                             HPA402J
                                                                         HPA402J
                                                                         HPA402J
*********************************************************************    HPA402J
********************************************************************     HPA402J
                                                                         HPA402J
                                                                         HPA402J
      ENTRY INSRTB                                                       HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     ENTRY POINT TO PROCESS THE OPERATOR RESPONSE TO ORDINAL NUMBER     HPA402J
*     REQUEST                                                            HPA402J
*                                                                        HPA402J
*     KC(1) CONTAINS THE RESPONSE TO ENTER ORDINAL NUMBER                HPA402J
*     CONVERT THE DISPLAY CODE TO A DECIMAL INTEGER                      HPA402J
                                                                         HPA402J
      IORD= KC(1)                                                        HPA402J
      CALL IVAL4 (IORD)                                                  HPA402J
      IF (IORD .EQ. 5HERROR) RETURN                                      HPA402J
                                                                         HPA402J
*     DETERMINE RELATIVE SHR IN FCY FOR INSERT                           HPA402J
*     RSHR ::= RELATIVE SHR                                              HPA402J
*     RBLK ::= RELATIVE BLOCK IN SHR TO INSERT AFTER                     HPA402J
                                                                         HPA402J
      RSHR = IORD/7                                                      HPA402J
      RBLK = (IORD - (7 * RSHR))                                         HPA402J
                                                                         HPA402J
*     DISPLAY REQUEST FOR INPUT OF DATA                                  HPA402J
                                                                         HPA402J
      IF (SOFTWRE) GO TO 50                                              HPA402J
                                                                         HPA402J
      PRINT 3                                                            HPA402J
    3 FORMAT (' ENTER ',/,'  PROD.,DESC.,SERIAL,DEGRADE ',
     .'FACTOR,EST,DEVICE TYPE,CH-EQ-UN,SYSTEM ID')
                                                                         HPA402J
      RETURN                                                             HPA402J
                                                                         HPA402J
 50   PRINT 4                                                            HPA402J
 4    FORMAT (' ENTER ',/,' PRODUCT,VERSION,PSR-LEVEL,',
     .'DEGRADE-FACTOR,INSTALL-DATE')
                                                                         HPA402J
      RETURN                                                             HPA402J
                                                                         HPA402J
                                                                         HPA402J
**********************************************************************   HPA402J
**********************************************************************   HPA402J
                                                                         HPA402J
                                                                         HPA402J
      ENTRY INSRTC                                                       HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     FIND FIRST LOCATION IN FCY OF SOFTWARE SHR-S                       HPA402J
                                                                         HPA402J
      DO 200 I = 3, LIMFCY                                               HPA402J
      IF (FCY(I,1) .EQ. 52) GO TO 220                                    HPA402J
 200  CONTINUE                                                           HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     IF A SHR52 IS NOT LOCATED, SET POS(3,1) TO NEXT BLOCK              HPA402J
*     AFTER LAST 51                                                      HPA402J
                                                                         HPA402J
      DO 210 I = 2, LIMFCY                                               HPA402J
      IF (FCY(I,1) .NE. 51) GO TO 215                                    HPA402J
 210  CONTINUE                                                           HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     IF FCY IS FULL, EXIT WITH MESSAGE, AND SET IST(1) TO *CALL MODE *  HPA402J
                                                                         HPA402J
      GO TO 800                                                          HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     SINCE THERE AREN-T ANY SHR52-S, CREATE ONE                         HPA402J
*     TO SIMPLIFY HOUSEKEEPING LATER.                                    HPA402J
                                                                         HPA402J
 215  FCY(I,1) = 52                                                      HPA402J
      FCY(I,3) = R"CY"
      IF (FLAGS(25) .NE. 0)FCY(I,4) = R"MMF"
      FCY(I,6) = 0                                                       HPA402J
      POS(3,1) = I                                                       HPA402J
      POS(3,2) = 9                                                       HPA402J
      POS(3,3) = TLIM(3,4)                                               HPA402J
      FRST52 = I                                                         HPA402J
      GO TO 230                                                          HPA402J
*     FRST52 ::= ORDINAL NUMBER OF FIRST SHR52 IN FCY                    HPA402J
*     LAST52 ::= ORDINAL NUMBER OF LAST SHR52 IN FCY                     HPA402J
*     LAST51 ::= IMPLICTLY = FRST52 - 1                                  HPA402J
                                                                         HPA402J
 220  FRST52 = I                                                         HPA402J
                                                                         HPA402J
*     FIND LAST SHR52                                                    HPA402J
                                                                         HPA402J
      DO 225 I = FRST52, LIMFCY                                          HPA402J
      IF (FCY(I,1) .NE. 52) GO TO 230                                    HPA402J
 225  CONTINUE                                                           HPA402J
                                                                         HPA402J
*     NO MORE ROOM                                                       HPA402J
      GO TO 800                                                          HPA402J
                                                                         HPA402J
*     SET ACTUAL SHR ADDRESS FOR INSERT                                  HPA402J
 230  LAST52 = I - 1                                                     HPA402J
      ABLK = RBLK + 1                                                    HPA402J
      IF (SOFTWRE) GO TO 235                                             HPA402J
      GO TO 240                                                          HPA402J
                                                                         HPA402J
 235  ASHR = RSHR + FRST52                                               HPA402J
      LASTSHR = LAST52                                                   HPA402J
      GO TO 245                                                          HPA402J
 240  ASHR = RSHR + 2                                                    HPA402J
      LASTSHR = FRST52 - 1                                               HPA402J
 245  IF (ABLK .LE. 7) GO TO 250                                         HPA402J
      ASHR = ASHR + 1                                                    HPA402J
      ABLK = 1                                                           HPA402J
 250  IF (FCY(ASHR,1) .EQ. FCY(ASHR + 1, 1)) GO TO 251                   HPA402J
      NEXTSHR = LASTSHR                                                  HPA402J
      GO TO 254                                                          HPA402J
                                                                         HPA402J
*     THE LAST SHR OF A TYPE HAS TO HAVE ANOTHER SHR CREATED             HPA402J
                                                                         HPA402J
 251  NEXTSHR = ASHR + 1                                                 HPA402J
                                                                         HPA402J
*     AFWA ::= ORDINAL NUMBER OF 1ST FIELD IN ABLK WITHIN ASHR           HPA402J
                                                                         HPA402J
 254  AFWA = (ABLK * 8) + 1                                              HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     LOOK FOR ANY EMPTY BLOCKS IN ASHR                                  HPA402J
                                                                         HPA402J
      DO 255 I = AFWA,57,8                                               HPA402J
      IF (FCY(ASHR,I)  .EQ.  0) GO TO 324                                HPA402J
 255  CONTINUE                                                           HPA402J
*      THE BLOCK TO BE INSERTED INTO IS FULL.                            HPA402J
                                                                         HPA402J
*     LOOK FOR ANY EMPTY BLOCKS IN REMAINING SHR-S.                      HPA402J
                                                                         HPA402J
                                                                         HPA402J
                                                                         HPA402J
      DO 260 K = NEXTSHR, LASTSHR                                        HPA402J
      DO 260 I = 9, 57, 8                                                HPA402J
      IF (FCY(K,I) .EQ. 0) GO TO 300                                     HPA402J
 260  CONTINUE                                                           HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     NO BLANK BLOCKS IN REMAINING SHR-S                                 HPA402J
*     SPLIT THE ACTUAL SHR AT THE INSERT POINT                           HPA402J
                                                                         HPA402J
*         FIRST:  RIGHT SHIFT THE SHR-S.                                 HPA402J
                                                                         HPA402J
      IF (NEXTSHR .EQ. LASTSHR) NEXTSHR = NEXTSHR + 1                    HPA402J
      IF (LAST52 .EQ. LIMFCY) GO TO 800                                  HPA402J
      OLDXX = LAST52                                                     HPA403J
 264  NEWXX = OLDXX + 1                                                  HPA403J
      DO 265 I = 1, 64                                                   HPA402J
      FCY(NEWXX, I) = FCY(OLDXX, I)                                      HPA403J
 265  CONTINUE                                                           HPA402J
      OLDXX = OLDXX - 1                                                  HPA403J
      IF (OLDXX .GE. NEXTSHR) GO TO 264                                  HPA403J
                                                                         HPA402J
*         SECOND:  ZERO OUT THE THE NOW EMPTY SHR (NEXTSHR)              HPA402J
                                                                         HPA402J
      DO 270 I = 1, 64                                                   HPA402J
      FCY(NEXTSHR,I) = 0                                                 HPA402J
 270  CONTINUE                                                           HPA402J
                                                                         HPA402J
                                                                         HPA402J
*         THIRD:  CREATE NEW SHR BLOCK                                   HPA402J
                                                                         HPA402J
      FCY(NEXTSHR,1) = IST(2) + 49                                       HPA402J
      FCY(NEXTSHR,3) = R"CY"
      IF (FLAGS(25) .NE. 0) FCY(NEXTSHR,4) = R"MMF" 
      FCY(NEXTSHR,6) = 1                                                 HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     FOURTH:  MOVE BLOCK FROM BOTTOM OF PRECEEDING SHR TO TOP           HPA402J
*              OF NEW SHR                                                HPA402J
                                                                         HPA402J
      J = 9                                                              HPA402J
      DO 275 I =AFWA, 64                                                 HPA402J
      FCY(NEXTSHR,J) = FCY(ASHR,I)                                       HPA402J
      J = J + 1                                                          HPA402J
 275  CONTINUE                                                           HPA402J
                                                                         HPA402J
                                                                         HPA402J
                                                                         HPA402J
*         FIFTH:  ZERO OUT BOTTOM OF ASHR.                               HPA402J
                                                                         HPA402J
      DO 280 I = AFWA, 64                                                HPA402J
      FCY(ASHR,I) = 0                                                    HPA402J
 280  CONTINUE                                                           HPA402J
                                                                         HPA402J
                                                                         HPA402J
*         SIXTH:  CHANGE THE RECORD COUNTS                               HPA402J
                                                                         HPA402J
      FCY(ASHR,6) =   1                                                  HPA402J
      GO TO 340                                                          HPA402J
                                                                         HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     AN EMPTY BLOCK WAS DETECTED IN THE SHR-S                           HPA402J
*                                                                        HPA402J
*     I CONTAINS THE FWA OF THE EMPTY BLOCK                              HPA402J
*     K CONTAINS THE ACTUAL FCY COLUMN NUMBER                            HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     TEST WHETHER THE FIRST BLOCK IS EMPTY                              HPA402J
                                                                         HPA402J
 300  IF (I .EQ. 9) GO TO 310                                            HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     MOVE THE BLOCKS DOWN TO FREE-UP THE 1ST BLOCK                      HPA402J
                                                                         HPA402J
      J = I - 1                                                          HPA402J
 305  FCY(K,J + 8) = FCY(K,J)                                            HPA402J
      J = J - 1                                                          HPA402J
      IF (J .GE. 9) GO TO 305                                            HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     RIGHT JUSTIFY THE PRECEDING BLOCKS                                 HPA402J
                                                                         HPA402J
 310  LASTSHR = K                                                        HPA402J
 314  L = K - 1                                                          HPA402J
      DO 315 I = 9, 16                                                   HPA402J
      J = I + 48                                                         HPA402J
      FCY(K,I) = FCY(L,J)                                                HPA402J
 315  CONTINUE                                                           HPA402J
      IF (L .EQ. ASHR) GO TO 324                                         HPA402J
      I = 56                                                             HPA402J
 316  J = I + 8                                                          HPA402J
      FCY(L,J) = FCY(L,I)                                                HPA402J
      I = I - 1                                                          HPA402J
      IF (I .GE. 9) GO TO 316                                            HPA402J
      K = K - 1                                                          HPA402J
      GO TO 314                                                          HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     TEST FOR LAST BLOCK IN ASHR                                        HPA402J
                                                                         HPA402J
 324  IF (AFWA .EQ. 57) GO TO 330                                        HPA402J
                                                                         HPA402J
*     MOVE THE BLOCKS IN ASHR DOWN 1 BLOCK                               HPA402J
                                                                         HPA402J
      I = 56                                                             HPA402J
                                                                         HPA402J
                                                                         HPA402J
 326  J = I + 8                                                          HPA402J
      FCY(ASHR,J) = FCY(ASHR,I)                                          HPA402J
      I = I - 1                                                          HPA402J
      IF (I .GE. AFWA) GO TO 326                                         HPA402J
                                                                         HPA402J
                                                                         HPA402J
 330  J = AFWA + 7                                                       HPA402J
      DO 335 I = AFWA, J                                                 HPA402J
      FCY(ASHR,I) = 0                                                    HPA402J
 335  CONTINUE                                                           HPA402J
                                                                         HPA402J
 340  L = AFWA                                                           HPA402J
      DO 400 I = 1, 8                                                    HPA402J
      FCY(ASHR,L) = KC(I)                                                HPA402J
      L = L + 1                                                          HPA402J
 400  CONTINUE                                                           HPA402J
                                                                         HPA402J
      FCY(ASHR,AFWA + 6) = IST(1)                                        HPA402J
      FCY(ASHR,AFWA + 7) = FLAGS(20)                                     HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     IS THIS THE LAST BLOCK OF THIS SHR?                                HPA402J
*     IF IT IS, DETERMINE IF IT IS THE LAST SHR.                         HPA402J
                                                                         HPA402J
      IF (AFWA .LE. 57) GO TO 434                                        HPA402J
                                                                         HPA402J
*     THE LAST BLOCK IS FILLED, NOW FIND OUT IF IS THE LAST SHR          HPA402J
                                                                         HPA402J
      IF (FCY(ASHR,1) .EQ. FCY(ASHR + 1,1)) GO TO 434                    HPA402J
                                                                         HPA402J
*     THE LAST BLOCK OF THE LAST SHR IS FILLED, SO CREATE A NEW ONE      HPA402J
                                                                         HPA402J
      IF (SOFTWRE) GO TO 425                                             HPA402J
                                                                         HPA402J
*     SPLIST FCY TO INSERT A NEW SHR51                                   HPA402J
                                                                         HPA402J
*     K = ASHR + 1                                                       HPA402J
      DO 410 J = K, LIMFCY                                               HPA402J
      IF (FCY(J,1) .EQ. 0) GO TO 415                                     HPA402J
 410  CONTINUE                                                           HPA402J
                                                                         HPA402J
 415  OLDXX = J - 1                                                      HPA403J
 416  NEWXX = OLDXX - 1                                                  HPA403J
      DO 420 I = 1, 64                                                   HPA402J
      FCY(NEWXX, I) = FCY(OLDXX, I)                                      HPA403J
 420  CONTINUE                                                           HPA402J
      OLDXX = OLDXX - 1                                                  HPA403J
      IF (OLDXX .GT. ASHR) GO TO 416                                     HPA403J
                                                                         HPA402J
 425  K = ASHR + 1                                                       HPA402J
      DO 430 I = 1, 64                                                   HPA402J
      FCY(K,I) = 0                                                       HPA402J
 430  CONTINUE                                                           HPA402J
      FCY(K,1) = IST(2) + 49                                             HPA402J
      FCY(K,3) = R"CY"
                                                                         HPA402J
 434  DO 435 K = 2, LIMFCY                                               HPA402J
      IF (FCY(K,1) .NE. 51) GO TO 440                                    HPA402J
 435  CONTINUE                                                           HPA402J
                                                                         HPA402J
*     FIND LAST SHR51                                                    HPA402J
                                                                         HPA402J
440   POS(2,1) = K - 1                                                   HPA402J
      L = K - 1                                                          HPA402J
      DO 445 I = 9, 57, 8                                                HPA402J
      IF (FCY(L,I) .EQ. 0) GO TO 450                                     HPA402J
 445  CONTINUE                                                           HPA402J
                                                                         HPA402J
 450  J = (I - 1) / 8                                                    HPA402J
      FCY(L,6) = ABLK + 1                                                HPA402J
      POS(2,1) = L                                                       HPA402J
      POS(2,2) = J                                                       HPA402J
      POS(2,3) = TLIM(2,4)                                               HPA402J
                                                                         HPA402J
*     DETERMINE LAST SHR52 AND LAST BLOCK                                HPA402J
                                                                         HPA402J
      J = J + 1                                                          HPA402J
      DO 455 K = J, LIMFCY                                               HPA402J
      IF (FCY(K,1) .EQ. 0) GO TO 460                                     HPA402J
 455  CONTINUE                                                           HPA402J
      K = LIMFCY + 1                                                     HPA402J
 460  K = K - 1                                                          HPA402J
      DO 465 I = 9, 57, 8                                                HPA402J
      IF (FCY(K,I) .EQ. 0) GO TO 470                                     HPA402J
 465  CONTINUE                                                           HPA402J
                                                                         HPA402J
      I = 57                                                             HPA402J
                                                                         HPA402J
 470  POS(3,1) = K                                                       HPA402J
      POS(3,2) = I                                                       HPA402J
      POS(3,3) = TLIM(3,4)                                               HPA402J
                                                                         HPA402J
      RBLK = RBLK + 1                                                    HPA402J
      IF (RBLK .LT. 8) RETURN                                            HPA402J
      RBLK = 1
      RSHR = RSHR + 1                                                    HPA402J
      IF(RSHR.EQ.24)GO TO 800                                            HPA402J
                                                                         HPA402J
      RETURN                                                             HPA402J
                                                                         HPA402J
 800  PRINT 2                                                            HPA402J
 2    FORMAT (' NO MORE ROOM FOR CONFIGURATION DATA ')
      CALLMDE = .TRUE.                                                   HPA402J
      COMMAND = .TRUE.                                                   HPA402J
      DATA = .FALSE.                                                     HPA402J
      IST(2) = 1                                                         HPA402J
      IST(1) = 1                                                         HPA402J
      IST(3) = 7HCOMMAND                                                 HPA402J
      RETURN                                                             HPA402J
                                                                         HPA402J
      END                                                                HPA402J
      SUBROUTINE IVAL4 (WORD)                                            R2FCYB 
*                                                                        R2FCYB 
**        DESCRIPTION                                                    R2FCYB 
*         -----------                                                    R2FCYB 
*         SUBROUTINE IVAL4CHECKS IF THE GIVEN ONE CPU WORD               R2FCYB 
*         CONTAINS ONLY THE DISPLAY CODED NUMERICS.                      R2FCYB 
*         IF SO, DECODE IT TO DECIMAL INTEGER,                           R2FCYB 
*         ELSE SET THE ERROR FLAG OF 5HERROR.                            R2FCYB 
*                                                                        R2FCYB 
*         ENTRY CONDITIONS                                               R2FCYB 
*         ----------------                                               R2FCYB 
*         WORD - ONE CPU WORD WHICH CONTAINS DIAPLAY CODED               R2FCYB 
*                NUMERICS.                                               R2FCYB 
*                                                                        R2FCYB 
*         EXIT CONDITIONS                                                R2FCYB 
*         ---------------                                                R2FCYB 
*         WORD - DECODED DECIMAL INTEGER IF WORD HAD VALID DATA,         R2FCYB 
*                OR "ERROR" IF WORD HAD CONTAINED OTHER THAN
*                DISPLAY CODED NUMERICS.
*                                                                        R2FCYB 
*         DATA AREAS                                                     R2FCYB 
*         ----------                                                     R2FCYB 
*         VARIABLES USED ARE ALL LOCAL TO SUBROUTINE.                    R2FCYB 
*                                                                        R2FCYB 
*         CALLED BY                                                      R2FCYB 
*         ---------                                                      R2FCYB 
*          CONF4,EDIT4,INSRTB,LIST4,STORC4
*                                                                        R2FCYB 
      IMPLICIT INTEGER(F-Z)                                              R2FCYB 
                                                                         R2FCYB 
*         SHIFT AND TEST EACH CHAR. FOR VALUE BETWEEN 33B TO 44B .       R2FCYB 
                                                                         R2FCYB 
      TEMP=WORD                                                          R2FCYB 
      IF (TEMP .EQ. 0) GO TO 900                                         R2FCYB 
                                                                         R2FCYB 
      DO 10 K = 1,11                                                     R2FCYB 
      IT = TEMP .AND. O"77000000000000000000" 
      IF (IT .EQ. O"55000000000000000000") GO TO 50 
                                                                         R2FCYB 
      TEMP = SHIFT(TEMP,6)
      ITC = TEMP .AND. O"77"
      IF (ITC .EQ. 0) TEMP = TEMP .OR. O"55"
      IF (ITC .EQ. 0) GO TO 10                                           R2FCYB 
      IF (ITC .LT. O"33" ) GO TO 100
      IF (ITC .GT. O"44") GO TO 100 
   10 CONTINUE                                                           R2FCYB 
                                                                         R2FCYB 
   50 DECODE (10,51,TEMP) WORD                                           R2FCYB 
   51 FORMAT ( I10 )                                                     R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
*     SET ERROR FLAG IF NON-INTEGER CHARACTER                            R2FCYB 
                                                                         R2FCYB 
  100 WORD = 5HERROR                                                     R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE LIST4                                                   R2FCYB 
*                                                                        R2FCYB 
**         LIST4  -- PRINT CONFIG AND DETAIL REPORTS                     R2FCYB 
*                                                                        R2FCYB 
*          CALLED BY  -- MINPUT4                                         R2FCYB 
*                                                                        R2FCYB 
*          DATA AREAS -- SHR FILE FROM OLDHF, OF NEWHF.                  R2FCYB 
*                                                                        R2FCYB 
*          ENTRY CONDITION -- SHR (5X) TYPE RECORDS ARE CONTAINED        R2FCYB 
*                             IN -FCY- BUFFER AREA.                      R2FCYB 
*                                                                        R2FCYB 
*          EXIT CONDITION -- REQUESTED LIST PRINTED, OR INFORMATIVE      R2FCYB 
*                            MESSAGE IF NO DATA FOUND.                   R2FCYB 
*                            SHR FILE MAY BE REPOSITIONED TO UNDETERMINE R2FCYB 
*                            AREA IF FILE WAS READ BY THIS ROUTINE.      R2FCYB 
*                                                                        R2FCYB 
*CALL,HPACOM1                                                            R2FCYB 
*CALL,HPACOM4                                                            R2FCYB 
                                                                         R2FCYB 
      LINE = 1                                                           R2FCYB 
*           SET PRINT POINTERS                                           R2FCYB 
*       SET FIRST PRINT ORDINAL TO PARAMETER, OR DEFAULT.                R2FCYB 
      FQTY = 1                                                           R2FCYB 
      LQTY = 7777                                                        R2FCYB 
      IF (KC(3) .EQ. 1H ) GO TO 20                                       R2FCYB 
      IF (KC(3) .EQ. 0) GO TO 20                                         R2FCYB 
                                                                         R2FCYB 
*           CONVERT PARAMETER TO INTEGER                                 R2FCYB 
      NUM = KC(3)                                                        R2FCYB 
      CALL IVAL4 (NUM)                                                   R2FCYB 
      IF (NUM .EQ. 5HERROR) GO TO 800                                    R2FCYB 
      FQTY = NUM                                                         R2FCYB 
      IF (FQTY .GT. 0) GO TO 10                                          R2FCYB 
      CALL INERR4 (3)                                                    R2FCYB 
      GO TO 900                                                          R2FCYB 
*                                                                        R2FCYB 
*           SET LAST PRINT ORDNAL TO PARAM OR DEFAULT.                   R2FCYB 
   10 IF (KC(4) .EQ. 0) GO TO 20                                         R2FCYB 
      IF (KC(4) .EQ. 1H ) GO TO 20                                       R2FCYB 
      NUM = KC(4)                                                        R2FCYB 
      CALL IVAL4 (NUM)                                                   R2FCYB 
      IF (NUM .EQ. 5HERROR) GO TO 810                                    R2FCYB 
      LQTY = NUM                                                         R2FCYB 
      IF (LQTY .LE. 0) GO TO 15                                          R2FCYB 
      LQTY = FQTY + LQTY                                                 R2FCYB 
      GO TO 20                                                           R2FCYB 
                                                                         R2FCYB 
   15 CALL INERR4 (4)                                                    R2FCYB 
      GO TO 900                                                          R2FCYB 
*                                                                        R2FCYB 
                                                                         HPA402J
*      RT IS SET TO THE COMMAND OPERAND ORDINAL NUMBER                   HPA402J
*                                                                        HPA402J
*      WHERE IST(2) = 1 DENOTES IDENT                                    HPA402J
*                     2         HARDWARE                                 HPA402J
*                     3         SOFTWARE                                 HPA402J
                                                                         HPA402J
 20   RT = IST(2)                                                        HPA402J
      HCF(1) = RT                                                        R2FCYB 
      SCODE = RT +49                                                     R2FCYB 
      IHDR = 4
*                                                                        R2FCYB 
*          SKIP HEADER IF (X =BF ) PARAMETER                             R2FCYB 
      IF (FROG(6) .NE. 3HOFF) GO TO 80                                   R2FCYB 
      CALL HEADER                                                        R2FCYB 
                                                                         R2FCYB 
      HCF(2) = FCY(1,13)                                                 R2FCYB 
      HCF(3) = FCY(1,14)                                                 R2FCYB 
      IF (HCF(2) .EQ. 0) HCF(2) = 1H                                     R2FCYB 
      IF (HCF(3) .EQ. 0) HCF(3) = 1H                                     R2FCYB 
                                                                         R2FCYB 
   80 CALL PRHEAD4                                                       R2FCYB 
                                                                         R2FCYB 
*      GO TO LINE PROCESSOR                                              R2FCYB 
                                                                         HPA402J
*     BRANCH LIST FOR RT (IST(2))                                        HPA402J
*                                                                        HPA402J
*     IF IST(2) = 1 (IDENT)     GO TO 100                                HPA402J
*                 2 (HARDWARE)        200                                HPA402J
*                 3 (SOFTWARE)        200                                HPA402J
      IF (RT .GT. 1) GO TO 200
                                                                         R2FCYB 
*        PROCESS SITE IDENTIFICATION DATA                                R2FCYB 
                                                                         R2FCYB 
      IF (FCY(1,9) .EQ. 0) GO TO 120
       FCY(1,11) = FCY(1,16) = 10H
      PRINT 105, (FCY(1,I),I=10,19)                                      R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  105 FORMAT (/'  1. CUSTOMER NAME',16X,2A10, 
     ./,'  2. LOCATION (STATE OR COUNTRY)',2X,A10,
     ./,'  3. CPU-TYPE',21X,A10,
     ./,'  4. CPU SERIAL',19X,A10,
     ./,'  5. APPLICATION',18X,2A10,
     ./,'  6. INDUSTRY TYPE',16X,A10, 
     ./,'  7. INSTALL DATE',17X,A10,
     ./,'  8. SYSTEM ID',20X,A10) 
*                                                                        R2FCYB 
  120 PRINT 121                                                          R2FCYB 
  121 FORMAT ( /,' NO SITE ID. DATA IN FILE ',/)
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
*        PROCESS HARDWARE CONFIG. DATA                                   R2FCYB 
                                                                         R2FCYB 
*       FIND (5X) TYPE RECORD, IF ANY                                    R2FCYB 
  200 DO 210 K = 2,LIMFCY                                                R2FCYB 
      IF (FCY(K,1) .EQ. SCODE) GO TO 250                                 R2FCYB 
      IF (FCY(K,1) .EQ. 0) GO TO 220                                     R2FCYB 
  210 CONTINUE                                                           R2FCYB 
                                                                         R2FCYB 
*        NO SHR(5X) FOUND                                                R2FCYB 
  220 IF (SCODE .EQ. 52) GO TO 230                                       R2FCYB 
      PRINT 225                                                          R2FCYB 
  225 FORMAT (/,'  NO HARDWARE CONFIG. DATA IN FILE ',/,
     .' ................................. ')
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  230 PRINT 231                                                          R2FCYB 
  231 FORMAT (/,'  NO SOFTWARE CONFIG. DATA IN FILE',/, 
     .'   ...................................... ') 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
*       SET POINTERS FOR 5X BLOCK                                        R2FCYB 
  250 PB = K                                                             R2FCYB 
      PRK = 1                                                            R2FCYB 
      ORD = 1                                                            R2FCYB 
*       RECORD START POINTER                                             R2FCYB 
      PRS = TLIM(RT,4)                                                   R2FCYB 
                                                                         R2FCYB 
*       RECORD LENGTH                                                    R2FCYB 
      PRL = TLIM(RT,3)                                                   R2FCYB 
*            PROCESS THE LINE                                            R2FCYB 
  255 IF (LQTY .GT. 7777) GO TO 258                                      R2FCYB 
      IF(FCY(PB,PRS) .EQ. 0) GO TO 710                                   R2FCYB 
                                                                         R2FCYB 
*       ENTER ORDINAL NUMBER                                             R2FCYB 
  258 PL(1) = ORD                                                        R2FCYB 
                                                                         R2FCYB 
*             DATE LAST ADD-CHANGE                                       R2FCYB 
      PL(8) = FCY(PB,PRS+7)                                              R2FCYB 
*                                                                        R2FCYB 
                                                                         R2FCYB 
*     DETAIL FOR HARDWARE / SOFTWARE REPORT                              R2FCYB 
      DO 260 K = 1,6                                                     R2FCYB 
      PL(K+1) = FCY(PB,PRS+K-1)                                          R2FCYB 
      CALL IBLANK (PL(K+1) )                                             R2FCYB 
  260 CONTINUE                                                           R2FCYB 
      IF (FCY(PB,PRS+6) .EQ. 2)  GO TO 710                               HPA402J
      PL(1) = ORD 
      IF (ORD .LT. FQTY) GO TO 710                                       R2GCYB 
      IF (ORD .GE. LQTY) GO TO 710                                       R2FCYB 
                                                                         R2FCYB 
      IF(.NOT.HARDWRE) GO TO 707
      PL(3) = FCY(PB,PRS+2) 
      PL(4) = FCY(PB,PRS+3) 
      PL(5) = FCY(PB,PRS+4).AND.MASK(18)
      PL(5) = PL(5).OR.O"0000 0055 5555 5555 5555"
      PL(6) = FCY(PB,PRS+4).AND.O"0000 0000 0077 0000 0000" 
      PL(6) = SHIFT(PL(6),6).OR.O"5555 5555 0055 5555 5555" 
      PL(7) = PL(8) 
      CALL PRINT4 (RT,7)
  
      PL(1) = 0 
      PL(2) = FCY(PB,PRS+1) 
      PL(5) = SHIFT(FCY(PB,PRS+4),18).AND.MASK(12)
      PL(5) = PL(5).OR.O"0000 5555 5555 5555 5555"
      PL(6) = FCY(PB,PRS+5) 
      CALL PRINT4(RT,6) 
      GO TO 710 
  707 CONTINUE
      CALL PRINT4 (RT,8)
  
  710 ORD = ORD + 1                                                      R2FCYB 
      PRK = PRK + 1                                                      R2GCYB 
      PRS = PRS + PRL                                                    R2FCYB 
      IF (PRK .LE. TLIM(RT,2)) GO TO 255                                 R2FCYB 
      PRK = 1                                                            R2FCYB 
      PRS = TLIM(RT,4)                                                   R2FCYB 
  730 PB = PB + 1                                                        R2FCYB 
      IF (PB .GT. LIMFCY) GO TO 900                                      R2FCYB 
      IF (FCY(PB,1) .EQ. 0) GO TO 900                                    R2FCYB 
      IF (FCY(PB,1) .NE. SCODE) GO TO 730                                R2FCYB 
      GO TO 255                                                          R2FCYB 
                                                                         R2FCYB 
                                                                         R2FCYB 
  800 CALL INERR4 (3)                                                    R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  810 CALL INERR4 (4)                                                    R2FCYB 
                                                                         R2FCYB 
 900      CALLMDE = .TRUE.                                               HPA402J
      RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE MINPUT4                                                 R2FCYB 
*                                                                        R2FCYB 
                                                                         R2FCYB 
**        DESCRIPTION                                                    R2FCYB 
*         ------------                                                   R2FCYB 
*           MINPUT4 - WHEN USER INPUT IS PRESENT, READ INPUT MESSAGE,    R2FCYB 
*          (1) IDENTIFY INPUT COMMANDS, TEST FOR PARAMETER ERROR         R2FCYB 
*           (2) INPUT DATA IS USED TO ENTER, OR MODIFY,                  R2FCYB 
*                 DATA KEPT ON HISTORY FILE.                             R2FCYB 
*                                                                        R2FCYB 
*         ENTRY CONDITIONS                                               R2FCYB 
*         ----------------                                               R2FCYB 
*         INPUT FILE ( CARD FILE, OR TERMINAL) HAS BEEN ASSIGNED AND     R2FCYB 
*         POSITIONED, READY FOR READ OF A RECORD.                        R2FCYB 
*                                                                        R2FCYB 
*         EXIT CONDITIONS                                                R2FCYB 
*         ---------------                                                R2FCYB 
*         INPUT COMMANDS ARE READ AND PROCESSED, UNTIL EOF OR            R2FCYB 
*         ( END ) MESSAGE IS ENCOUNTERED.                                R2FCYB 
*         COMMANDS HAVE BEEN DECODED AND USED TO MODIFY APPROPRIATE      R2FCYB 
*         DATA ARRAYS ( TRU, ETC.)                                       R2FCYB 
*                                                                        R2FCYB 
*         DATA AREAS                                                     R2FCYB 
*         ----------                                                     R2FCYB 
*             IST (3)  INPUT COMMAND POINTERS                            R2FCYB 
*             FCY (36,64) = CONFIGURATION DATA BUFFER.                   R2FCYB 
*         INP (8) - BUFFER FOR IN PUT RECORD.                            R2FCYB 
*         KC (10) - TEMP. STORAGE OF INPUT FIELDS WHILE PROCESSING.      R2FCYB 
*             KP (12)  OVERFLOW STORE ,INPUT WORD OVER 10 CHAR.          R2FCYB 
*                                                                        R2FCYB 
*                                                                        R2FCYB 
*         CALLED BY                                                      R2FCYB 
*         ---------                                                      R2FCYB 
*          HPA4                                                          R2FCYB 
*           ( IF *I* SPECIFIED ON CONTROL CARD )                         R2FCYB 
*                                                                        R2FCYB 
*         ROUTINES CALLED                                                R2FCYB 
*         ----------------                                               R2FCYB 
*         LISTL - LIST TRIGGER LEVEL DATA, IF CALLED BY *LISTL* COMMAND. R2FCYB 
*                                                                        R2FCYB 
*                                                                        R2FCYB 
      IMPLICIT INTEGER (F-Z)
*CALL,HPACOM4                                                            R2FCYB 
  
      DIMENSION TCOM(24), TPAR(40)
                                                                         R2FCYB 
*             COMMAND TABLE                                              R2FCYB 
      DATA TCOM(1) /3HADD /                                              R2FCYB 
      DATA TCOM(2) /6HDELETE /                                           R2FCYB 
      DATA TCOM(3) /6HCHANGE /                                           R2FCYB 
      DATA TCOM(4) /6HINSERT /                                           HPA402J
      DATA TCOM(5) /4HLIST /                                             HPA402J
      DATA TCOM(6) /3HEND /                                              R2FCYB 
                                                                         R2FCYB 
*                                                                        R2FCYB 
*             TYPE TABLE /                                               R2FCYB 
      DATA TPAR(1) /5HIDENT /                                            R2FCYB 
      DATA TPAR(2) /8HHARDWARE /                                         R2FCYB 
      DATA TPAR(3) /8HSOFTWARE /                                         R2FCYB 
                                                                         R2FCYB 
*        ABBREVIATED TYPE TABLE                                          R2FCYB 
      DATA TPAR(21) /1HI /                                               R2FCYB 
      DATA TPAR(22) /1HH /                                               R2FCYB 
      DATA TPAR(23) /1HS /                                               R2FCYB 
                                                                         R2FCYB 
      LIMCOM = 10                                                        HPA401J
      LIMTYP = 5                                                         HPA402J
      MESS = 1                                                           R2FCYB 
      CALLMDE = .TRUE.                                                   HPA402J
      IST(1) = 1                                                         HPA402J
      IST(2) = 1                                                         HPA402J
      IST(3) = 7HCOMMAND                                                 HPA402J
      DATA = .FALSE.                                                     HPA402J
      COMMAND = .TRUE.                                                   HPA402J
                                                                         R2FCYB 
      PRINT 5                                                            R2FCYB 
                                                                         R2FCYB 
*       READ INPUT RECORD                                                R2FCYB 
      READ (5,15,END=10000) INP 
10000 IF (EOF(5)) 7,20,7
    7 PRINT 8                                                            R2FCYB 
    8 FORMAT (/,  '  .... HPA CARD ERROR .... ',/,
     .'   -I- PARAMETER USED , NO INPUT FOUND , OR ',/, 
     .'       INPUT FILE NOT CONNECTED.',/) 
    5 FORMAT (2X,'-- ENTER INPUT --',/,' /')
      RETURN                                                             R2FCYB 
   10 PRINT 11                                                           R2FCYB 
   11 FORMAT (' /') 
                                                                         R2FCYB 
      DO 12 K = 1,8                                                      R2FCYB 
   12 INP(K) = 0                                                         R2FCYB 
                                                                         R2FCYB 
      READ (5,15,END=10001) INP 
   15 FORMAT (BZ,8A10)
10001  IF(EOF(5)) 900,20,900
                                                                         R2FCYB 
   20 CALL PARS4                                                         R2FCYB 
                                                                         R2FCYB 
*         TEST INPUT MESSAGE WITH COMMAND TABLE                          R2FCYB 
*     IF KC(1) MATCHES A COMMAND IN TCOM,                                HPA402J
*     SET IST(1) WITH THE ORDINAL NUMBER OF THE COMMAND                  HPA402J
                                                                         HPA402J
      DO 100 K = 1,LIMCOM                                                R2FCYB 
      IF (KC(1) .NE. TCOM(K) ) GO TO 100                                 R2FCYB 
      GO TO 120                                                          HPA402J
  100 CONTINUE                                                           R2FCYB 
                                                                         R2FCYB 
                                                                         HPA402J
*     IF KC(1) DID NOT MATCH WITH TCOM,                                  HPA402J
*     THEN IST(1) CONTAINS A COMMAND ORDINAL                             HPA402J
      IF (.NOT. CALLMDE) GO TO 300                                       HPA402J
                                                                         R2FCYB 
*           COMMAND NOT FOUND                                            R2FCYB 
      CALL INERR4 (MESS)                                                 HPA402J
      GO TO 10                                                           R2FCYB 
                                                                         HPA402J
*     RESET PREVIOUS CONDITIONS                                          HPA402J
                                                                         HPA402J
 120  GO TO (131,132,133,134,135,136) IST(1)
                                                                         HPA402J
 131  ADD     = .FALSE. 
      GO TO 150 
 132  DELETE  = .FALSE. 
      GO TO 150 
 133  CHANGE  = .FALSE. 
      GO TO 150 
 134  INSERT  = .FALSE. 
      GO TO 150 
 135  LIST    = .FALSE. 
      GO TO 150 
 136  END4    = .FALSE. 
      GO TO 150 
                                                                         HPA402J
                                                                         HPA402J
*     SET CURRENT CONDITION                                              HPA402J
                                                                         HPA402J
 150  IST(1) = K                                                         HPA402J
      CALLMDE = .FALSE.                                                  HPA402J
      GO TO (161,162,163,164,165,166) IST(1)
                                                                         HPA402J
 161  ADD    = .TRUE. 
      GO TO 190 
 162  DELETE = .TRUE. 
      GO TO 190 
 163  CHANGE = .TRUE. 
      GO TO 190 
 164  INSERT = .TRUE. 
      GO TO 190 
 165  LIST   = .TRUE. 
      GO TO 190 
 166  END4   = .TRUE. 
      RETURN
                                                                         HPA402J
                                                                         HPA402J
*     IST(1) NOW CONTAINS THE ORDINAL NUMBER OF THE COMMAND              HPA402J
*     AND THE LOGICAL NAME IS SET.                                       HPA402J
                                                                         HPA402J
                                                                         R2FCYB 
                                                                         R2FCYB 
                                                                         HPA402J
 190  IST(3) = 7HCOMMAND                                                 HPA402J
      COMMAND = .TRUE.                                                   HPA402J
      CALLMDE = .FALSE.                                                  HPA402J
      DATA = .FALSE.
      DO 195 K2 = 1, LIMTYP                                              HPA402J
      IF (KC(2) .NE. TPAR(K2 + 20)) GO TO 192                            HPA402J
      GO TO 200                                                          HPA402J
 192  IF (KC(2) .NE. TPAR(K2)) GO TO 195                                 HPA402J
      GO TO 200 
 195  CONTINUE                                                           HPA402J
                                                                         HPA402J
                                                                         R2FCYB 
*         TYPE NOT FOUND                                                 R2FCYB 
                                                                         HPA402J
*     AN ERROR HAS OCCURED, BRANCH TO 799 TO DISPLAY ERROR MESSAGE       HPA402J
                                                                         HPA402J
      GO TO 799                                                          HPA402J
                                                                         R2FCYB 
*          LIST COMMAND                                                  R2FCYB 
                                                                         HPA402J
*     RESET PREVIOUS COMMAND FUNCTION                                    HPA402J
                                                                         HPA402J
 200  GO TO (211,212,213) IST(2)
                                                                         HPA402J
                                                                         HPA402J
 211  IDENT   = .FALSE. 
      GO TO 220 
 212  HARDWRE = .FALSE. 
      GO TO 220 
 213  SOFTWRE = .FALSE. 
      GO TO 220 
                                                                         HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     SET CURRENT CONDITION                                              HPA402J
                                                                         HPA402J
 220  IST(2) = K2                                                        HPA402J
      GO TO (231,232,233) IST(2)
                                                                         HPA402J
 231  IDENT   = .TRUE.
      GO TO 250 
 232  HARDWRE = .TRUE.
      GO TO 250 
 233  SOFTWRE = .TRUE.
      GO TO 250 
  
 250  IF (ADD) GO TO 420
      IF (DELETE .AND. IDENT) GO TO 799 
      IF (DELETE) GO TO 410 
      IF (CHANGE) GO TO 410                                              HPA402J
      IF (INSERT .AND. IDENT) GO TO 799 
      IF (INSERT .AND. DATA) GO TO 480                                   HPA402J
      IF (INSERT) GO TO 460 
      IF (LIST) GO TO 400                                                HPA402J
                                                                         HPA402J
                                                                         HPA402J
 300  IST(3) = 8HCONTINUE                                                HPA402J
      COMMAND = .FALSE.                                                  HPA402J
      IF (ADD) GO TO 420                                                 HPA402J
      IF (DELETE .AND. IDENT) GO TO 799 
      IF (DELETE) GO TO 410                                              HPA402J
      IF (CHANGE) GO TO 410                                              HPA402J
      IF (INSERT .AND. IDENT) GO TO 799 
      IF (INSERT .AND. DATA) GO TO 480
      IF (INSERT) GO TO 470 
                                                                         HPA402J
 400  CALL LIST4                                                         HPA402J
      GO TO 10                                                           HPA402J
                                                                         R2FCYB 
                                                                         R2FCYB 
 410  CALL EDIT4                                                         HPA402J
      GO TO 10                                                           HPA402J
                                                                         R2FCYB 
 420  CALL CONF4                                                         HPA402J
      GO TO 10                                                           HPA402J
                                                                         R2FCYB 
                                                                         HPA402J
*     IST(3) = COMMAND                                                   HPA402J
*     IST(1) = 4                                                         HPA402J
                                                                         HPA402J
 460  CALL INSRTA                                                        HPA402J
      GO TO 10                                                           HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     IST(3) = CONTINUE                                                  HPA402J
*     IST(1) = 4                                                         HPA402J
                                                                         HPA402J
 470  CALL INSRTB                                                        HPA402J
      DATA = .TRUE.                                                      HPA402J
      GO TO 10                                                           HPA402J
                                                                         HPA402J
                                                                         HPA402J
 480  CALL INSRTC                                                        HPA402J
      GO TO 10                                                           HPA402J
                                                                         HPA402J
 799  MESS = 2                                                           HPA402J
      CALL INERR4 (MESS)                                                 HPA402J
                                                                         HPA402J
*     FROM A PREVIOUS PASS, OR IT CONTAINS *CALL MODE *.                 HPA402J
*     CONTINUE PROCESSING IF IST(1) CONTAINS A NUMBER,                   HPA402J
*     OTHERWISE, DISPLAY AN ERROR MESSAGE AND LOOP BACK.                 HPA402J
                                                                         HPA402J
      CALLMDE = .TRUE.                                                   HPA402J
      CALL INERR4 (2) 
      GO TO 10                                                           HPA402J
                                                                         R2FCYB 
                                                                         R2FCYB 
*        END OF INPUT PROCESSING                                         R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE NODE4 (P)                                               R2FCYB 
*                                                                        R2FCYB 
**        NODE4 -- FIND THE NEXT AVAILABLE STORAGE NODE FOR              R2FCYB 
*                  PACKING OF INTERACTAIVE SHR INPUT DATA.               R2FCYB 
*                                                                        R2FCYB 
*        CALLED BY -- CONF4                                              R2FCYB 
*                                                                        R2FCYB 
*        ENTRY CONDITION  -- PARAMETER (P) INDICATES THE SHR             R2FCYB 
*                RECORD TYPE TO BE STORED.                               R2FCYB 
*               AND 5X TYPE DATA FROM OLDHF HAS BEEN READ AND            R2FCYB 
*               COPIED INTO STORAGE BUFFER (FCY).                        R2FCYB 
*                                                                        R2FCYB 
*       DATA AREAS -- ARRAY FCY(25,64) = TEMPORARY STORAGE FOR           R2FCYB 
*                     HOLDING INTEACTIVE SHR DATA WHILE PROCESSING.      R2FCYB 
*                     ARRAY POS(8,4) = FLAGS TO CONTROL DATA HANDLING.   R2FCYB 
*                      POS(2,1) = CURRENT 51 BLOCK AVAILABLE FOR STORE.  R2FCYB 
*                      POS(2,2) = CURRENT 51 RECORD AVAILABLE FOR STORE. R2FCYB 
*                      POS(2,3) = CURRENT 51 RECORD FWA                  R2FCYB 
*                      POS(3,1) = CURRENT 52 BLOCK AVAILABLE FOR STORE.  R2FCYB 
*                      POS(3,2) CURRENT 52 RECORD ORDINAL AVIALABLE FOR  R2FCYB 
*                       POS(3,3) CURRENT 52 RECORD FWA                   R2FCYB 
*                      TLIM(10,4) = DATA FIELD LIMITS FOR 5X RECORDS.    R2FCYB 
*                                   ( DEFINED IN INIDAT4).               R2FCYB 
*                                                                        R2FCYB 
*              EXIT CONDITION  -- FLAGS ARE SET TO POINT TO THE NEXT     R2FCYB 
*                    EMPTY NODE OF TYPE SPECIFIED BY (P).                R2FCYB 
*                    IF A NEW SHR BLOCK IS ASSIGNED, PRESET THE SHR      R2FCYB 
*                    CODE OF WORD 1 TO THE CONTENTS OF (P) AND ENTER     R2FCYB 
*                    THE CURRENT DATE INFO.                              R2FCYB 
*CALL,HPACOM1                                                            R2FCYB 
*CALL,HPACOM4                                                            R2FCYB 
*     FL BLOCK POINTER                                                   R2FCYB 
      FLB = P                                                            R2FCYB 
      RT = FLB + 49                                                      R2FCYB 
                                                                         R2FCYB 
      IF (POS(FLB,1) .EQ. 0) GO TO 5                                     R2FCYB 
      PRB = POS(FLB,1)                                                   R2FCYB 
      GO TO 150                                                          R2FCYB 
                                                                         R2FCYB 
 5    PRB = P                                                            HPA402J
*        TEST IF INITIAL RB AVAILABLE                                    R2FCYB 
      IF (FCY(PRB,1) .EQ. 0) GO TO 50                                    R2FCYB 
                                                                         R2FCYB 
*        FIND AVAILABLE RB                                               R2FCYB 
      DO 20 K = 2,LIMFCY                                                 R2FCYB 
      IF (FCY(K,1) .EQ. 0) GO TO 30                                      R2FCYB 
      IF (FCY(K,1) .NE. RT) GO TO 20                                     R2FCYB 
                                                                         R2FCYB 
*         TEST FOR SPACE IN THIS RB                                      R2FCYB 
      IF (FCY(K,6) .LT. TLIM(FLB,2)) GO TO 140                           R2FCYB 
   20 CONTINUE                                                           R2FCYB 
                                                                         R2FCYB 
      GO TO 300                                                          R2FCYB 
                                                                         R2FCYB 
                                                                         R2FCYB 
   30 PRB = K                                                            R2FCYB 
*        BLOCK ORDINAL POINTER  (ORDINAL 1 IS RESERVED FOR               R2FCYB 
*             SHR 50 ).                                                  R2FCYB 
   50 POS(FLB,1) = PRB                                                   R2FCYB 
      FCY(PRB,1) = RT                                                    R2FCYB 
      FCY(PRB,3) = R"CY"
      IF (FLAGS(25) .NE. 0) FCY(PRB,4) = R"MMF" 
*        RECORD ORDINAL POINTER                                          R2FCYB 
      POS(FLB,2) = 1                                                     R2FCYB 
*          RECORD FWA POINTER                                            R2FCYB 
      POS(FLB,3) = TLIM(FLB,4)                                           R2FCYB 
      FCY(PRB,6) = 0                                                     R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  140 PRB = K                                                            R2FCYB 
  145 POS(FLB,1) = PRB                                                   R2FCYB 
      POS(FLB,2) = 1                                                     R2FCYB 
      POS(FLB,3) = TLIM(FLB,4)                                           R2FCYB 
                                                                         R2FCYB 
*         TEST IF CURRENT NODE IS EMPTY                                  R2FCYB 
  150 FWA = POS(FLB,3)                                                   R2FCYB 
      IF (FWA .EQ. 0) FWA = TLIM(FLB,4)                                  R2FCYB 
  160 IF (FCY(PRB,FWA) .EQ. 0) GO TO 800                                 R2FCYB 
                                                                         R2FCYB 
*       STEP RECORD COUNTER                                              R2FCYB 
      PRB = POS(FLB,1)                                                   R2FCYB 
      POS(FLB,2) = POS(FLB,2) + 1                                        R2FCYB 
*       STEP RECORD FWA                                                  R2FCYB 
      FWA = FWA + TLIM(FLB,3)                                            R2FCYB 
                                                                         R2FCYB 
*        TEST IF BLOCK FULL                                              R2FCYB 
      IF (POS(FLB,2) .LE.TLIM(FLB,2)) GO TO 160                          R2FCYB 
*        STEP BLOCK ORDINAL                                              R2FCYB 
      PRB = PRB + 1 
                                                                         R2FCYB 
*      TEST IF RB USED                                                   R2FCYB 
      IF (FCY(PRB,1) .EQ. 0) GO TO 50                                    R2FCYB 
      IF (PRB .GT. TLIM(FLB,1) ) GO TO 300                               R2FCYB 
      IF (FCY(PRB,1) .EQ. RT) GO TO 145                                  HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     FIND LAST SHR52                                                    HPA402J
                                                                         HPA402J
      DO 215 I = PRB,LIMFCY                                              HPA402J
      IF (FCY(I,1) .EQ. 0) GO TO 220                                     HPA402J
 215  CONTINUE                                                           HPA402J
                                                                         HPA402J
*     NO MORE ROOM                                                       HPA402J
                                                                         HPA402J
      GO TO 300                                                          HPA402J
                                                                         HPA402J
                                                                         HPA402J
*     SHIFT THE SHR-S RIGHT ONE COLUMN                                   HPA402J
                                                                         HPA402J
 220  OLDXX = I - 1                                                      HPA403J
 221  NEWXX = OLDXX + 1                                                  HPA403J
      DO 225 I = 1, 64                                                   HPA402J
      FCY(NEWXX, I) = FCY(OLDXX, I)                                      HPA403J
 225  CONTINUE                                                           HPA402J
      OLDXX = OLDXX - 1                                                  HPA403J
      IF (OLDXX .GE. PRB) GO TO 221                                      HPA403J
                                                                         HPA402J
*     CLEAR OUT FCY(PRB,N)                                               HPA402J
                                                                         HPA402J
      DO 230 I = 1, 64                                                   HPA402J
      FCY(PRB,I) = 0                                                     HPA402J
 230  CONTINUE                                                           HPA402J
      DO 235 I = 3, LIMFCY                                               HPA402J
      IF (FCY(I,1) .EQ. 52) GO TO 240                                    HPA402J
 235  CONTINUE                                                           HPA402J
                                                                         HPA402J
 240  DO 245 J = I, LIMFCY                                               HPA402J
      IF (FCY(J,1) .EQ. 0) GO TO 250                                     HPA402J
 245  CONTINUE                                                           HPA402J
                                                                         HPA402J
 250  POS(3,1) = J - 1                                                   HPA402J
      GO TO 50                                                           HPA402J
                                                                         R2FCYB 
*        FCY ARRAY FULL                                                  R2FCYB 
  300 PRINT 310                                                          R2FCYB 
  310 FORMAT ('  FCY BUFFER FULL . . . . . .. ')
                                                                         R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  800 POS(FLB,3) = FWA                                                   R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE PARS4                                                   R2FCYB 
*                                                                        R2FCYB 
**           PARS4 - ROUTINE TO PARSE DATA FROM INTERACTIVE EDITOR       R2FCYB 
*                    INPUT STATEMENTS.                                   R2FCYB 
*                                                                        R2FCYB 
*            ENTRY CONDITION - INPUT STATEMENT IS CONTAINED IN           R2FCYB 
*                              THE COMMON ARRAY (INP)                    R2FCYB 
*                                                                        R2FCYB 
*            EXIT CONDITION -  FIELDS HAVE BEEN PARSED IN ARRAY (KC)     R2FCYB 
*                                                                        R2FCYB 
*            CALLED BY = MINPUT4                                         R2FCYB 
*                                                                        R2FCYB 
* *************************************************************          R2FCYB 
*                                                                        R2FCYB 
      IMPLICIT INTEGER (F-Z)
*CALL,HPACOM4                                                            R2FCYB 
      IF (INP(1) .EQ. 3HEND) GO TO 800                                   R2FCYB 
                                                                         R2FCYB 
*       CLEAR (KC) BUFFER                                                R2FCYB 
      DO 25 J = 1,12                                                     R2FCYB 
   25 KC(J) = 1H                                                         R2FCYB 
                                                                         R2FCYB 
*         PARSE THE FIELDS, PLACE IN (KC)                                R2FCYB 
*         FIELD COUNTER                                                  R2FCYB 
                                                                         R2FCYB 
      F = 1                                                              R2FCYB 
*         INPUT WORD COUNTER                                             R2FCYB 
                                                                         R2FCYB 
       WI=1                                                              R2FCYB 
                                                                         R2FCYB 
*         CHARACTER COUNTER                                              R2FCYB 
                                                                         R2FCYB 
       WC=1                                                              R2FCYB 
      W2 = 1                                                             R2FCYB 
      TEMP = 0                                                           R2FCYB 
      WCHAR = 0                                                          R2FCYB 
*        STORAGE OF PREVIOUS CHAR.                                       R2FCYB 
      PTEMP = TEMP                                                       R2FCYB 
      TEMP = 0                                                           R2FCYB 
      TEMP1 = 0                                                          R2FCYB 
                                                                         R2FCYB 
*         SHIFT CHAR. TO LOW POS.                                        R2FCYB 
                                                                         R2FCYB 
  100 INP(WI)=SHIFT(INP(WI),6)                                           R2FCYB 
      PTEMP = TEMP                                                       R2FCYB 
      TEMP=INP(WI).AND.O"77"
                                                                         R2FCYB 
*         TEST COMMA ( DELIMITER )                                       R2FCYB 
                                                                         R2FCYB 
      IF (TEMP .EQ. O"56") GO TO 180
*            TEST ( = ) SIGN  DELIMITER                                  R2FCYB 
      IF (TEMP .EQ. O"54") GO TO 200
                                                                         R2FCYB 
*          TEST SPACE DELIMITER                                          R2FCYB 
      IF (TEMP .EQ. O"55") GO TO 160
                                                                         R2FCYB 
*            TEST TERMINATOR ( PERIOD,ZERO,OR DOUBLE SPACE)              R2FCYB 
      IF (TEMP .EQ. 0) GO TO 300                                         R2FCYB 
  140 TEMP1 = SHIFT(TEMP1,6)                                             R2FCYB 
      TEMP1=TEMP1.OR.TEMP                                                R2FCYB 
      WCHAR = WCHAR + 1                                                  R2FCYB 
                                                                         R2FCYB 
*         STEP TO NEXT CHAR. AND TEST END OF WORD                        R2FCYB 
                                                                         R2FCYB 
  150 W2 = W2 + 1                                                        R2FCYB 
  155 WC = WC + 1                                                        R2FCYB 
      IF(WC.EQ.11) WC=1                                                  R2FCYB 
      IF(WC.EQ.1) WI=WI+1                                                R2FCYB 
      IF(WI.GT.8) GO TO 300                                              R2FCYB 
      IF (W2 .EQ. 11) GO TO 200                                          R2FCYB 
      GO TO 100                                                          R2FCYB 
                                                                         R2FCYB 
*       TEST FOR DOUBLE SPACE TERMINATOR                                 R2FCYB 
  160 IF (PTEMP .EQ. O"55") GO TO 300 
      GO TO 140                                                          R2FCYB 
                                                                         R2FCYB 
*         STORE DATA FIELD                                               R2FCYB 
                                                                         R2FCYB 
  180 IF (W2 .EQ. 11) GO TO 205                                          R2FCYB 
      IF (PTEMP .NE. O"56") GO TO 200 
                                                                         R2FCYB 
*     ENTER BLANK PARAMETER                                              R2FCYB 
      KC(F) = 1H                                                         R2FCYB 
      F = F+1                                                            R2FCYB 
      GO TO 155                                                          R2FCYB 
                                                                         R2FCYB 
  200 SH = 6*(10-WCHAR)                                                  R2FCYB 
      WCHAR = 0                                                          R2FCYB 
      KC(F) = SHIFT(TEMP1,SH)                                            R2FCYB 
*           SAVE DELIMITER TYPE                                          R2FCYB 
      CALL IBLANK(KC(F))                                                 R2FCYB 
      IF (W2 .LT. 12) GO TO 210                                          R2FCYB 
  205 W2 = 1                                                             R2FCYB 
      F = F - 1                                                          R2FCYB 
  210 F = F + 1                                                          R2FCYB 
      KC(F) = 0                                                          R2FCYB 
      TEMP1 = 0                                                          R2FCYB 
      IF (W2 .LT. 11) W2 = 0                                             R2FCYB 
      IF (W2 .EQ. 11) GO TO 100                                          R2FCYB 
      GO TO 150                                                          R2FCYB 
*      END OF THE COMMAND                                                R2FCYB 
*         PROCESS THE COMMAND                                            R2FCYB 
                                                                         R2FCYB 
  300 SH = 6*(10-WCHAR)                                                  R2FCYB 
      KC(F) = SHIFT(TEMP1,SH)                                            R2FCYB 
      CALL IBLANK (KC(F))                                                R2FCYB 
      KC(12) = WI                                                        R2FCYB 
                                                                         R2FCYB 
      IF(.NOT.HARDWRE) GO TO 900
      KC(5) = KC(5).AND.MASK(18)
      KC(6) = KC(6).AND.MASK(12)
      KC(5) = KC(5).OR.(SHIFT(KC(6),42))
      KC(8) = KC(8).AND.MASK(6) 
      KC(5) = KC(5).OR.(SHIFT(KC(8),30))
      KC(6) = KC(7) 
      KC(7) = KC(8) = O"5555 5555 5555 5555 5555" 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  800 KC(1) = 3HEND                                                      R2FCYB 
                                                                         R2FCYB 
                                                                         R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE PRHEAD4                                                 R2FCYB 
*                                                                        R2FCYB 
**          PRHEAD4 -- PRINT SUBHEADERS FOR HPA4.                        R2FCYB 
*                                                                        R2FCYB 
**          ENTRY CONDITION  --  HCF(1) POINT TO DESIRED HEADING.        R2FCYB 
*                                                                        R2FCYB 
*           CALLED BY -- LIST4                                           R2FCYB 
*                                                                        R2FCYB 
*CALL,HPACOM1                                                            R2FCYB 
                                                                         R2FCYB 
      LINE = LINE + 1                                                    R2FCYB 
      GO TO (10,20,30,40,50) HCF(1) 
                                                                         R2FCYB 
   10 PRINT 11                                                           R2FCYB 
   11 FORMAT (2X,'  SITE IDENTIFICATION REPORT')
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
   20 IF (FROG(6) .NE. 3HOFF) GO TO 24                                   R2FCYB 
      PRINT 21,HCF(2),HCF(3)                                             R2FCYB 
   21 FORMAT (4X,'HARDWARE CONFIGURATION REPORT', 
     .' - ',A10,'SN ',A10,/)
                                                                         R2FCYB 
   24 PRINT 25                                                           R2FCYB 
   25 FORMAT ( ' NO. PRODUCT  SERIAL NO. DEG.FACT.  EST    ', 
     .'SYS.ID.  LAST ENTRY')
      PRINT 26
   26 FORMAT ( ' ------(A)-------(B)-------(C)------(D)------(E)---') 
      PRINT 27
   27 FORMAT ( '     DESCRIP.',21X,'DEV.TYPE CH-EQ-UN') 
      PRINT 28
   28 FORMAT ( ' ------(F)--------------------------(G)------(H)---') 
      LINE = LINE + 2 
      GO TO 850 
                                                                         R2FCYB 
   30 IF (FROG(6) .NE. 3HOFF) GO TO 34                                   R2FCYB 
      PRINT 31,HCF(2),HCF(3)                                             R2FCYB 
   31 FORMAT (4X,'SOFTWARE CONFIGURATION REPORT', 
     .' - ',A10,'SN ',A10,/)
                                                                         R2FCYB 
   34 PRINT 35                                                           R2FCYB 
   35 FORMAT (27X,'PSR     DEGRADE   INSTALL   LAST ',
     ./,'  NO.  PRODUCT  VERSION    LEVEL   FACTOR     DATE     ENTRY') 
      GO TO 700                                                          R2FCYB 
                                                                         R2FCYB 
   40 CONTINUE                                                           R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
   50 CONTINUE
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  700 PRINT 710                                                          R2FCYB 
  710 FORMAT (' --------(A)------(B)-------(C)------(D)', 
     .'------(E)----------------')
      GO TO 850                                                          R2FCYB 
                                                                         R2FCYB 
                                                                         R2FCYB 
  850 LINE = LINE + 1                                                    R2FCYB 
                                                                         R2FCYB 
  900 LINE = LINE + 1                                                    R2FCYB 
      RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE PRINT4 (LT,NW)                                          R2FCYB 
                                                                         R2FCYB 
*                                                                        R2FCYB 
**         PRINT4  -- PRINT DATA LINES FOR HPA4.                         R2FCYB 
*                                                                        R2FCYB 
*          CALLED BY -- LIST4                                            R2FCYB 
*                                                                        R2FCYB 
*          ENTRY CONDITION                                               R2FCYB 
*                 (PL) BUFFER CONTAINS DATA TO BE PRINTED.               R2FCYB 
*                 LT = FORMAT STATEMENT TO BE USED.                      R2FCYB 
*                 NW = NUMBER WORDS TO BE PRINTED.                       R2FCYB 
*                                                                        R2FCYB 
*CALL,HPACOM1                                                            R2FCYB 
                                                                         R2FCYB 
      DIMENSION IFORM (5, 3),  FMT (5)
                                                                         R2FCYB 
*      FORMAT FOR HARDWARE CONFIG REPORT                                 R2FCYB 
      DATA (IFORM(I,2), I=1,5,1) /
     .10H(1X,I3.0,1,10HX,A8,1X,A1,10H0,3X,A3,6X,10H,A3,4X,A8,,10HA9)
     .   /
*                                                                        R2FCYB 
*      FORMAT FOR SOFTWARE CONFIG REPORT                                 R2FCYB 
      DATA (IFORM(I,3), I=1,4,1) /
     .10H(1X,I3,3X,,10HA10,2A10,A,10H3,4X,A9,A1,10H,R10)     /
                                                                         R2FCYB 
*         ************************************************               R2FCYB 
                                                                         R2FCYB 
      LINE = LINE + 1                                                    R2FCYB 
      DO 8 J = 1,5
      FMT(J) = IFORM(J,LT)
    8 CONTINUE
      PRINT FMT,(PL(J),J=1,NW)
                                                                         R2FCYB 
      DO 50 K = 1,NW                                                     R2FCYB 
   50 PL(K) = 1H                                                         R2FCYB 
      IF (LINE .GT. PLF) GO TO 200                                       R2FCYB 
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  200 LINE = 1                                                           R2FCYB 
      IF (FROG(6) .NE. 3HOFF) GO TO 210                                  R2FCYB 
      CALL HEADER                                                        R2FCYB 
  210 CALL PRHEAD4                                                       R2FCYB 
                                                                         R2FCYB 
  900 RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE STFCY4                                                  R2FCYB 
*                                                                        R2FCYB 
*            STFCY4  -- STORE AN INPUT RECORD FROM (KC) ARRAY            R2FCYB 
*                      INTO THE (FCY) BUFFER FOR FOR NEWHF.              R2FCYB 
*                                                                        R2FCYB 
*            CALLED BY -- CONF4                                          R2FCYB 
*                                                                        R2FCYB 
*            ENTRY CONDITION -- INPUT MESSAGE IN (KC) ARRAY.             R2FCYB 
*                                                                        R2FCYB 
*                POINTERS SET IN (TLIM),AND (POS) ARRAYS. SEE DEFINES    R2FCYB 
*                                                         IN INIDAT4.    R2FCYB 
*                                                                        R2FCYB 
*             EXIT CONDITION -- DATA HAS BEEN VERIFIED, IF NEEDED, AND   R2FCYB 
*                               AND PLACED IN FCY BUFFER.                R2FCYB 
*                                                                        R2FCYB 
*CALL,HPACOM1                                                            R2FCYB 
*CALL,HPACOM4                                                            R2FCYB 
*     GET POINTERS                                                       R2FCYB 
                                                                         R2FCYB 
*         CURRENT RECORD TYPE                                            R2FCYB 
      RT = IST(2)                                                        R2FCYB 
                                                                         R2FCYB 
*         WORD COUNT                                                     R2FCYB 
      WC = TLIM(RT,3)                                                    R2FCYB 
*          PRESENT BLOCK ORDINAL                                         R2FCYB 
      PB = POS(RT,1)                                                     R2FCYB 
*        RECORD FWA POINTER                                              R2FCYB 
      WP = POS(RT,3)                                                     R2FCYB 
*                                                                        R2FCYB 
                                                                         R2FCYB 
      WST = WC - 1                                                       R2FCYB 
                                                                         R2FCYB 
*          STORE IN (FCY)                                                R2FCYB 
      DO 100 K = 1,WST
      FCY (PB,WP+K-1) = KC(K)                                            R2FCYB 
  100 CONTINUE                                                           R2FCYB 
                                                                         R2FCYB 
*         STEP SLOT COUNTER                                              R2FCYB 
                                                                         R2FCYB 
      FCY (PB,6) = FCY(PB,6) + 1                                         R2FCYB 
                                                                         R2FCYB 
*      INSERT ENTRY DATE                                                 R2FCYB 
      FCY(PB,WP+7) = FLAGS(20)                                           R2FCYB 
                                                                         HPA402J
*     INSERT THE COMMAND ORDINAL IN WORD 7 OF THE BLOCK                  HPA402J
                                                                         HPA402J
      IF (IST(1) .LE. 4) FCY(PB,WP+6) = IST(1)                           HPA402J
                                                                         HPA402J
                                                                         R2FCYB 
                                                                         R2FCYB 
*          LOCATE TO NEXT EMPTY SLOT                                     R2FCYB 
      CALL NODE4 (RT)                                                    R2FCYB 
                                                                         R2FCYB 
      RETURN                                                             R2FCYB 
      END                                                                R2FCYB 
      SUBROUTINE STORC4 (P)                                              R2FCYB 
*                                                                        R2FCYB 
**       STORC4 --  TRANSFER A BLOCK OF DATA FROM OLDHF                  R2FCYB 
*                   FILE TO CONFIG HOLDING ARRAY (FCY), OR               R2FCYB 
*                   WRITE FROM (FCY) TO NEWHF.                           R2FCYB 
*                                                                        R2FCYB 
*        CALLED BY -- INIDAT4, HPA4                                      R2FCYB 
*                                                                        R2FCYB 
*        ENTRY CONDITION --  PARAMETER (P) POINTS TO PROCESS TO BE       R2FCYB 
*                       PERFORMED, (4HREAD, OR 5HWRITE),                 R2FCYB 
*                                                                        R2FCYB 
*CALL,HPACOM1                                                            R2FCYB 
*CALL,HPACOM4                                                            R2FCYB 
*                                                                        R2FCYB 
      PB = 1                                                             R2FCYB 
                                                                         R2FCYB 
      IF (P .EQ. 5HWRITE) GO TO 400                                      R2FCYB 
                                                                         R2FCYB 
*         FCY BLOCK POINTER                                              R2FCYB 
      PB = 2                                                             R2FCYB 
      IF (FILEP(OLD) .EQ. 3HOFF) GO TO 700
                                                                         R2FCYB 
      IF ((IFLD(4) .EQ. 0) .AND. (FLAGS(25) .NE. 0)) PRINT 30 
      IF ((IFLD(4) .EQ. R"MMF") .AND. (FLAGS(25) .EQ. 0)) PRINT 40
   30 FORMAT (' SHR NOT IN MULTI-MAINFRAME FORMAT - STORC4')
   40 FORMAT (' SHR IN MULTI-MAINFRAME FORMAT - STORC4')
                                                                         R2FCYB 
      DO 110 K = 1,64                                                    R2FCYB 
  110 FCY(1,K) = IFLD(K)                                                 R2FCYB 
      GO TO 150                                                          R2FCYB 
                                                                         R2FCYB 
*        READ IN ( 5X ) TYPE BLOCKS                                      R2FCYB 
  150 CALL RMREAD (OLD,IFLD,LENGTH) 
      IF (FEOF(OLD) .EQ. 3HYES) GO TO 800 
  
      IF (IFLD(1) .LT. 50) GO TO 800
                                                                         R2FCYB 
      DO 165 K = 1,64                                                    R2FCYB 
  165 FCY(PB,K) = IFLD(K)                                                R2FCYB 
                                                                         R2FCYB 
      PB = PB + 1                                                        R2FCYB 
      IF (PB .LT. LIMFCY) GO TO 150 
                                                                         R2FCYB 
      PRINT 168                                                          R2FCYB 
  168 FORMAT ( /,'  -- STORC4 -- , ...FCY OVERFLOW .... ',/)
      GO TO 900                                                          R2FCYB 
                                                                         R2FCYB 
  400 PTYPE = 50                                                         R2FCYB 
      IF (FCY(PB,1) .EQ. PTYPE) GO TO 420                                R2FCYB 
      IF (FCY(2,1) .EQ. 0) GO TO 450                                     R2FCYB 
      FCY(1,1) = PTYPE                                                   R2FCYB 
420   FCY(1,3) = R"CY"
      IF(FLAGS(25) .NE. 0) FCY(1,4) = R"MMF"
                                                                         R2FCYB 
      DO 425 K = 1,64 
  425 NFLD(K) = FCY(PB,K) 
      CALL RMWRITE (SCR2,NFLD,64) 
                                                                         R2FCYB 
  430 PB = PB + 1                                                        R2FCYB 
      IF (PB .GT. LIMFCY)  GO TO 450
      IF (FCY(PB,1) .EQ. 0) GO TO 450                                    R2FCYB 
      IF (FCY(PB,1) .GT. 99) GO TO 430                                   R2FCYB 
      GO TO 420                                                          R2FCYB 
                                                                         R2FCYB 
  450 CALL RMFILEM (SCR2) 
      GO TO 900 
  
  700 PRINT 701 
  701 FORMAT (' OLDHF NOT AVAILABLE FOR SHR UPDATE - STORC4') 
                                                                         R2FCYB 
*                                                                        R2FCYB 
  800 DO 810 K = 1,64 
  810 IFLD(K) = 0                                                        R2FCYB 
                                                                         R2FCYB 
  900 RETURN                                                             R2GCYB 
      END                                                                R2FCYB 
      OVCAP.
      SUBROUTINE PACK4
* 
*         SUBROUTINE *PACK4* DELETES SELECTED RECORDS FROM SHR CONFIGURA
*         DATA.  THE EDITED RECORDS ARE TRANSFERRED FROM SCR2 TO SCR1.
* 
*CALL HPACOM1 
  
*     INITIALIZE
      SHR51 = 2HNO
      SHR52 = 2HNO
      IEOF = 2HNO 
      PPTR = 1
      DO 6 I = 1,64 
    6 IFLD(I) = NFLD(I) = 0 
  
      CALL RMREWND (SCR1) 
      CALL RMREWND (SCR2) 
  
*     SEARCH FOR SHR50 - IDENT RECORD 
      CALL RMREAD (SCR2,NFLD,LENGTH)
      IF (FEOF(SCR2) .EQ. 3HYES) GO TO 900
      IF (NFLD(1) .NE. 50) GO TO 55 
  
*     SHR50 DETECTED
      PAR = 2H50
      CALL PACKX4 (PAR,PPTR)
  
   50 CALL RMREAD (SCR2,NFLD,LENGTH)
      IF (FEOF(SCR2) .EQ. 3HYES) GO TO 900
  
*     SAVE IFLD WORDS 1 - 8 
   55 DO 57 I = 1,8 
   57 IFLD(I) = NFLD(I) 
  
      IF (NFLD(1) .EQ. 51) GO TO 200
      IF (NFLD(1) .EQ. 52) GO TO 300
      GO TO 50
  
*     SHR51 DETECTED
  200 PAR = 2H51
  210 PSWITCH = 2H21
      IF ((PPTR + 8) .GT. 57) GO TO 230 
  215 PPTR = PPTR + 8 
      IF (NFLD(PPTR) .EQ. 0) GO TO 210
      NDEL = NFLD(PPTR + 6) .AND. O"7"
      IF (NDEL .NE. 2) CALL PACKX4 (PAR,PPTR) 
      SHR51 = 3HYES 
  221 PSWITCH = 3H22
      IF ((PPTR + 8) .GT. 57) GO TO 230 
  224 IF (NFLD(PPTR + 8) .EQ. NFLD(PPTR)) GO TO 226 
      GO TO 210 
  
  226 PPTR = PPTR + 8 
      NDEL = NFLD(PPTR + 6) .AND. O"7"
      IF (NDEL .NE. 2) CALL PACKX4 (PAR,PPTR) 
      GO TO 221 
  
  230 CALL RMREAD (SCR2,NFLD,LENGTH)
      IF (FEOF(SCR2) .EQ. 3HYES) GO TO 245
      PPTR = 1
      IF (NFLD(1) .NE. 51) GO TO 250
      IF (PSWITCH .EQ. 2H21) GO TO 215
      GO TO 224 
  
  245 IEOF = 3HYES
  250 PAR = 3HE51 
      CALL PACKX4 (PAR,PPTR)
      IF (IEOF .EQ. 3HYES) GO TO 900
      PPTR = 1
      GO TO 55
  
*     SHR52 DETECTED
  300 PAR = 2H52
  310 IF ((PPTR + 8) .GT. 57) GO TO 330 
      PPTR = PPTR + 8 
      IF (NFLD(PPTR) .EQ. 0) GO TO 310
      NDEL = NFLD(PPTR + 6) .AND. O"7"
      IF (NDEL .NE. 2) CALL PACKX4 (PAR,PPTR) 
      SHR52 = 3HYES 
      GO TO 310 
  
  330 CALL RMREAD (SCR2,NFLD,LENGTH)
      IF (FEOF(SCR2) .EQ. 3HYES) GO TO 350
      PPTR = 1
      IF (NFLD(1) .EQ. 52) GO TO 310
  350 PAR = 3HE52 
      CALL PACKX4 (PAR,PPTR)
  
*     CONCLUDE SCR1 
  900 CALL RMFILEM (SCR1) 
      CALL RMREWND (SCR1) 
  
      RETURN
      END 
      SUBROUTINE PACKX4 (PAR,PPTR)
  
*CALL HPACOM1 
  
      DATA IPTR /9/, ISLTCNT /0/
  
*     PROCESS SHRXX 
      IF (PAR .EQ. 2H51) GO TO 20 
      IF (PAR .EQ. 2H52) GO TO 20 
      IF (PAR .EQ. 2H50) GO TO 50 
      IF (PAR .EQ. 3HE51) GO TO 40
      IF (PAR .EQ. 3HE52) GO TO 40
  
*     PROCESS SHR51 AND SHR52 RECORDS 
*     MOVE DATA FROM NFLD TO IFLD 
   20 Q = PPTR + 7
      DO 22 I = PPTR,Q
      IFLD(IPTR) = NFLD(I)
   22 IPTR = IPTR + 1 
      ISLTCNT = ISLTCNT + 1 
  
*     CHECK IF IFLD FULL
      IF (IPTR .EQ. 65) GO TO 40
      GO TO 900 
  
*     PROCESS END SHRE51 AND SHRE52 RECORDS 
*     IFLD IS FULL - WRITE IT AND RESET IPTR
   40 IPTR = 9
      IFLD(6) = ISLTCNT 
      ISLTCNT = 0 
      IFLD(7) = FLAGS(20) 
      CALL RMWRITE (SCR1,IFLD,64) 
  
  
*     CLEAR IFLD PORTION
      DO 42 I = 9,64
   42 IFLD(I) = 0 
      GO TO 900 
  
*     PROCESS SHR50 - WRITE JUST NFLD 
   50 NFLD(7) = FLAGS(20) 
      ISLTCNT = 0 
      CALL RMWRITE (SCR1,NFLD,64) 
  
  900 CONTINUE
  
      RETURN
      END 
