5	SUBROUTINE XXCSET (IDDB,IDSUB,IDPRIM,IC,IW,IB,LS,IR)IC_TITLE  XXCSET Set for new data file (chunk) by reading chunk directory.C_ARGUMENTS!	INTEGER IDDB    ![I]Database ID.%	INTEGER IDSUB   ![I]Sub-database ID.2	INTEGER IDPRIM  ![I]Primary ID of data requested.>	INTEGER*2 IC(*) ![I]Array which serves as XXGP control block.C	INTEGER*2 IW(*) ![I]Array of max. no. of chunks per sub-database. H   	INTEGER*2 IB(*) ![I]Array returned as logical unit of the data file.#	INTEGER LS      ![I]Sector length.)	INTEGER IR      ![I]Returns status code.GC_DESCRIPTION  The subroutine XXCSET.FOR sets parameters for a new data.C file (chunk) by reading the chunk directory.EC Pause for restoration of a tape file (with XGLOAD) where necessary.C#>C   IC serves an XXGP control block for the chunk directory.  .C   Words 1-5 must be set before calling with:C	(1) Unique Fortran unit.;C	(2) Logical unit of directory device. (where applicable) =C       (3-5) 6 character ASCII name of chunk directory file.KC   IB is an integer*2 array of length greater than or equal to 5 in which MC   will be returned the logical unit of the data file (word 2) and its name C   (words 3-5).EC   IB may be used as the XXGP control block for the data file if its=C   length is GE 60 and the fortran unit is placed in word 1.GC   LS is sector length (int*2 words) specified by program.  It will be:C   compared with the file sector length (in file header).9C    Chunk directory structure (A standard XX-type file.)C    standard header (1 SECTOR)+C    Special Header words: 21  Database ID.AC                          22  Data filename kernal (1ST 2 CHAR).7C                          23  Number of sub-databases.OC                          24  Max. number of chunks per sub-database. (MCHUNK)GC                          25  Entry length (INT*2 WORDS) = 3 (LENTRY).BC                          26  Number of sectors per sub-database.EC   Sub-database chunk directories in sub-database order.  Each is anOC   Integer*2 array of mchunk 3-words entries, and starts on a sector boundary.MC         Entry structure:  1st primary id in chunk, (dummy last entry 32767)9C                           2  100*TAPE_ID + file number.1C                           3  Logical unit/flag.OC                             GT 0 logical unit, file on-line (Default LUN = 1)1C                                0 File off-line.5C                               -1 Non-existent file.MC                               -2 Dummy last entry with last primary ID + 1.HC  The chunk directory is maintained by program DBLOAD (Q.V.) which also%C  restores the data files from tape.C#(C_CALLS  XXGP,ASCII  USES COMMON /XXCOM/#C_HISTORY  R.Mehlman  82Aug13  UCLALC REVISED  87JUN19 Robert L. Gurule, USGS Flagstaff, NIMS/VIMS documentationC          modular programming.C_MESSAGES LC   IR is the return code:  0  Normal: File on-line and ready for XXGP init.?C                          >0  System I/O error code from XXGP./C                   -1 TO -20  XXGP error code.;C                         -31  Primary ID not in any chunk.9C                         -32  Non-existent sub-database.:C                         -33  File not a chunk directory.:C                         -34  Unexpected chunk directory.6C                         -35  Unexpected sector size.BC                         -36  User request for early termination.6C                         -37  User request for abort.C_END/      COMMON /XXCOM/ IIN,IOUT,IXX1(28),DATIM(5)F      DATA KDDB,ICNHDR,ICSTYP,ICLS,ICDB,ICKERN,ICNSUB,ICMAX,ICLEN,ICNSG     1    /   0,    26,    27,  33,  41,    42,    43,   44,   45,  46/J!-----Is this a new database?  Yes, init & read header of chunk directory 
!     file      IF (IDDB.NE.KDDB) THEN        KDDB=0+        CALL XXGP(0,IC,LS,0,IW,IR)                 IF (IR.NE.0) GO TO 70&        IF (IC(ICSTYP).NE.-3) GO TO 73&        IF (IDDB.NE.IC(ICDB)) GO TO 74$        IF (LS.NE.IC(ICLS)) GO TO 75        KDDB=IDDB      ENDIF(!-----Does sub-database requested exist?5 20   IF (IDSUB.LE.0.OR.IDSUB.GT.IC(ICNSUB)) GO TO 721!-----Yes, read chunk directory for sub-database.      NSECT=IC(ICNS)      IPTR=1&      ISECT=(IDSUB-1)*NSECT+IC(ICNHDR)      DO 25 I=1,NSECT        ISECT=ISECT+1,        CALL XXGP(1,IC,-1,ISECT,IW(IPTR),IR)        IF (IR.NE.0) GO TO 70 25   IPTR=IPTR+LSD!-----Does requested primary unit precede the first directory entry?#      IF (IDPRIM.LT.IW(1)) GO TO 718!-----No, search for data file entry in chunk directory.      L=IC(ICLEN)      N=IC(ICMAX)!-----Loop on entries.      DO 35 IDCHNK=1,N        J=IDCHNK*L        IDNEXT=IW(J+1)&        IF (IDPRIM.LT.IDNEXT) GO TO 40#        IF (IW(J+3).LT.-1) GO TO 71 35   CONTINUE!-----Search failed.      GO TO 71$!-----Entry found.  is file on-line? 40   J=J-L      LUN=IW(J+3)      IF (LUN) 71,45,50,!-----No, output message and wait for reply. 45   ITPFL=IW(J+2)      ITP=ITPFL/100      IFL=ITPFL-100*ITP0 46   WRITE (IOUT,946) IDDB,IDSUB,IDCHNK,ITP,IFL9 946  FORMAT (' Database',I3,'  Spacecraft',I2,'  Chunk',     1 I4,' must be restored',G     1 ' from tape',I4,'  file',I3/'  enter 0 when ready to continue,',7     2 ' 1 to terminate range early, cntrl-z to abort'))      READ (IIN,947,ERR=46,END=77) IREPLY 947  FORMAT (I1)F!-----What to do?  if continuing, go to reread chunk directory. batch?      IF (IREPLY.NE.0) GO TO 76N!-----Chunk on-line.  return logical unit and constructed filename, mark file !     closed 50   IB(2)=LUN)      CALL ASCII(1000*iDSUB+IDCHNK,IB(3))      IB(3)=IC(ICKERN)
      IB(6)=0
      IR=0 70   RETURN
!-----Errors.,                                             71   IR=-31      WRITE(IOUT,701)- 701  FORMAT(' Primary ID not in any chunk ')      GO TO 80 72   IR=-32      WRITE(IOUT,702)* 702  FORMAT(' Nonexistant sub database ')      GO TO 80 73   IR=-33      WRITE(IOUT,703), 703  FORMAT(' File not a chunk directory ')      GO TO 80 74   IR=-34      WRITE(IOUT,704), 704  FORMAT(' Unexpected chunk directory ')      GO TO 80 75   IR=-35      WRITE(IOUT,705)- 705  FORMAT(' Unexpected sector size ')           GO TO 80 76   IR=-36      WRITE(IOUT,706)> 706  FORMAT(' User request for early termination of a range')      GO TO 80 77   IR=-37      WRITE(IOUT,707)( 707  FORMAT(' User request for abort ') 80   RETURN	      END