C      SUBROUTINE XXDSET (IDDB,IDSUB,IDPRIM,IDSEC,IB,INDEX,IP,IS,IR)PC_TITLE  XXDSET  Set file control block to access data sequence in XG-Type file.C_ARGUMENTS*      INTEGER*4 IDDB     ![I] Database id.-      INTEGER*4 IDSUB 	 ![I] Sub-database id.,      INTEGER*4 IDPRIM 	 ![I] Is primary id.N      INTEGER*4 IDSEC 	 ![I] Secondary id: GT. 0 search mode access requested.9      			 !Secondary unit 0 sequential mode - access all =      			 !secondary units.  In primary unit, one per call.        			 !get return code.3                	 !CODE -21 When primary unit done.C      INTEGER*2 IB(1) 	 ![I] Is File Control Block(FCB) previously *      			 !initialized in XGDATA and XXGP.>      INTEGER*2 INDEX(1) ![I] Array for index sectors of file.>      INTEGER*2 IP(1)	 ![I] Array for primary directory entry.=      INTEGER*2 IS(1)    ![I] Array for secondary directory. 2      INTEGER IR         ![O] Status return code. JC_DESCRIPTION  The subroutine XXDSET.FOR will access a sequence directory GC indices in an XG-type file with directories.  The first time a chunk JC directory is read it will read the INDEX to the orbit directory.  Every IC time after that the program will read one sequence per call untill the LC counter exceeds the number of sequences in that particular orbit: At that KC time a return code of -21 is returned to the calling program, indicating KC that there are no more valid sequences in that orbit.  It will fetch all NC requested sequence indices within an orbit, (primary and secondary entries) NC including pointers to the actual data location on disk.  If it is the first NC access of the file, it will get an index. Mode 0 call to XXGP (IB(6-20)     "C zeroed).                        GC *** This version assumes primary and secondary directory entries are C  one sector long. ***4C File control block structure reference: FILORG.DOC
C_MESSAGESFC  IR is return code: 0  OK - ready to process data in secondary unit.8C	           GT 0  SYSTEM I/O error code passed by XXGP.'C     	   	     -1  to -20 XXGP errors.-C                    -21 End of primary unit.AC                    -22 Requested secondary unit does not exist.EC                    -23 Requested primary unit out of range of file.LC                    -24 Requested primary unit in range but does not exist.1C                    -25 File has no directories.=C                    -26 Unexpected database or sub-database.?C_FILES Chunk files are read, File Control Block IB is updated.C_CALLS XXGP,A2AN,XXGMULC_COMMONS XXCOMNC_HIST 82OCT19 R. Mehlman, mod to support multi-sector indexes (calls XXGMUL).2C R.Mehlman  82DEC12 IDDB,IDSUB ADDED 8/31/82     DC Robert L. Gurule, USGS Flagstaff modified for NIMS/VIMS standards.C_END   2      DATA IBROW1,IBKPID,IBKSID,IBKPTR,IBSTYP,IBLS3     1    /    11,    15,    16,    17,    27,  33/;      DATA IBIND1,IBNIND,IBP1,IBS1,IBDB,IBSUB,IBPID1,IBPID2<     1    /    42,    43,  45,  48,  51,   52,    54,    55/      DATA IPS1,IPS2,ISID     1    /   1,   2,  10/      DATA IOUT/5/E!----First time for this file? If this is a new chunk being read then6!    read the INDEX to the orbit directory, else skip.7      IF (IB(IBROW1).EQ.0)THEN 		!-----Yes, read index.&        IF (IB(IBSTYP).NE.-1) GO TO 756        ISECT=IB(IBIND1)		!Starting sector to be read.5        NSECT=IB(IBNIND)		!Number of sectors to read.6        LS=IB(IBLS)			!Length of each sector to fetch./        CALL XXGMUL(IB,ISECT,NSECT,INDEX,LS,IR)        IF (IR.NE.0) GO TO 70      ENDIF:!-----Is this the right file for this database and sub-db?:      IF (IDDB.NE.IB(IBDB).OR.IDSUB.NE.IB(IBSUB)) GO TO 76P!-----New primary id?  in range? Is orbit fetched valid for chunk we're working !     with?(      IF (IDPRIM.EQ.IB(IBKPID)) GO TO 30<!-----Became initialized in XXGP mode - during call to A2AN.@      IF (IDPRIM.LT.IB(IBPID1).OR.IDPRIM.GT.IB(IBPID2)) GO TO 73!-----Yes, get primary entry.      IDSTRT=IB(IBPID1)"      KPPTR=INDEX(IDPRIM-IDSTRT+1)=!-----(-1) in call to XXGP indicates a fetch of desired data.      IF (KPPTR.EQ.0) GO TO 74/      CALL XXGP(1,IB,-1,KPPTR+IB(IBP1)-1,IP,IR)'!-----If IR ne zero goto error section.      IF (IR.NE.0) GO TO 702      IB(IBKPID)=IDPRIM                                 GO TO 35!-----New secondary id?' 30   IF (IDSEC.EQ.IB(IBKSID)) GO TO 50      IF (IDSEC.LT.0) GO TO 72.!-----No, get current secondary entry pointer.      KSPTR=IB(IBKPTR)K!-----Go get next secondary entry if requested or if not past requested id.5      IF (IDSEC.EQ.0.OR.IDSEC.GT.IB(IBKSID)) GO TO 403!-----Begin primary unit with first secondary unit. 35   IB(IBKSID)=-1      KSPTR=IP(IPS1)      GO TO 45B!-----Increment pointer, this is next sequence to be searched for. 40   KSPTR=KSPTR+1L!-----End of primary unit? IPS2 pointer to valid last sequence, IPS2 pointerL!     to valid beginning sequence.  Are we at the end of the valid sequencesI!     to be accessed?  If so set return code to -21, increment next orbit)!     id to be fetched and call me again.&      IF (KSPTR.GT.IP(IPS2)) GO TO 71	K!-----No, there are more sequences to be fetched, get secondary (sequence) !     entry./ 45   CALL XXGP(1,IB,-1,KSPTR+IB(IBS1)-1,IS,IR)      IF (IR.NE.0) GO TO 70E!-----If in search mode, and secondary id not yet found, go for next.4      IF (IDSEC.GT.0.AND.IS(ISID).NE.IDSEC) GO TO 40K!-----Save current pointer and id, transfer data pointers to control block.      IB(IBKPTR)=KSPTR      IB(IBKSID)=IS(ISID)       CALL A2AN(IS,IB(IBROW1),4)!-----Normal termination.
 50   IR=0 70   RETURN!-----Abnormal termination. 71   IF (IDSEC.GT.0) GO TO 79      IB(IBKPID)=-1      IR=-21      WRITE(IOUT,701)0 701  FORMAT(' No more sequences in this orbit')      GO TO 80 72   IR=-22      WRITE(IOUT,702)0 702  FORMAT(' Requested orbit does not exist.')      GO TO 80 73   IR=-23      WRITE(IOUT,703)9 703  FORMAT(' Requested orbit(s) out of range of file.')      GO TO 80 74   IR=-24      WRITE(IOUT,704)IDPRIMD 704  FORMAT(' Requested orbit ',I4,' in range but does not exist.')      GO TO 80 75   IR=-25      WRITE(IOUT,705)) 705  FORMAT(' File has no directories.')      GO TO 80 76   IR=-26      WRITE(IOUT,706)5 706  FORMAT(' Unexpected database or sub-database.')
      GOTO 80 79   IR=-27L      !IF IR = -27, User requested N--> end of sequences, no more sequences. 80   RETURN	      END