+	SUBROUTINE XXGP (IMODE,IB,ICOL,IROW,IA,IR)7C_TITLE  XXGP Fetch, Open, Close sector-oriented files.C_ARGUMENTS/	INTEGER IMODE    ![I] Operating mode for XXGP.2	INTEGER*2 IB(1)  ![I] 60 plus file control block.B	INTEGER ICOL     ![I] Different meanings see documentation below.I        INTEGER IROW     ![I] Different meanings see documentation below.2	INTEGER*2 IA(1)  ![I] Array for retrieved record.+	INTEGER IR       ![I] Returns status code.1C Mode is 0: initialize file (open, read header). C         1: Get logical record.?C         3: Close file (after put, or if fortran unit needed).JC IB is 60+ word integer*2 file control block (set words 1-5 before init).MC If type 0 file with record length LT 1 sector, length is 60 + sectorlength.C IB(I)$C    1 Fortran unit (defaults to 64)BC    2 Logical unit (lun) - usage depends on local dsopen routine..C      VAX/VMS: Lun = 0 for default directory.KC               Lun = n for device directory defined by logical daN (N=1,9)NC                       (not used on some systems)                            &C  (3-5) File name-6 ascii characters.C    6 Current sector.DC    7 K1: current start (line,subsector) in (row,sector) (type -1).<C    8 K2: current end line/sector in row/sector (type  -1).C    9>C    10 Flag word: bit 0: write enabled  bit 1: file modified.7C   (11-14) from directories, if any (not set by XXGP).AC    11 Start row/record/sector of current sequence (type 0, -1).@C    12 End row/record/sector of current sequence (types 0, -1).;C    13 Start line/subsector of current sequence (type -1).*C    14 End of current sequence (type -1)./C    15 Current primary (orbit) identification.4C    16 Current secondary (sequence) identification.3C    17 Current secondary (sequence) entry pointer.C    18C    19C    203C    21-60 file header words 1-40 (see filorg.doc).JC    61-(sector length+30) buffer for 2 or more type 0 records per sector.C9C   ICOL GT 0  Type 0,-1: Random access by record|sector..C           0  Type 0,-1: Sequential access.  DC        LT 0  Absolute get|put mode: IROW is sector to be accessed.CBC    (for mode 0-init ICOL should be sector length in INT*2 words)7C   IROW (ICOL > 0)  type 0: record  type -1: sector.  AC        (ICOL = 0)  type 0/-1: record/sector, (0: autoincrement)GC        (ICOL < 0)  absolute sector to be accessed (absolute get mode)C>C    File with directories: set irow=0 to initialize sequence.NC    IB(11-14) must be filled with pointers for sequence desired (see XXDSET).CCC_DESCRIPTION  The subroutine XXGP.FOR will GET, OPEN, CLOSE sectorPC oriented files for file types -1 and 0.  Serially reusable (supports multiple JC concurrent file access).  XXGP initializes and modifies the File ControlMC Block at Mode equal to zero.  If the Mode is equal to one, an invocation isAC made to module DSREAD to read a sector of data into array IA.  6C_FILE Reads chunk files, or a special directory file.NC   File Types: 0 ordinary, integral fraction of sector, referenced by record.NC              -1 ordinary, integral fraction of sector, referenced by sector.C>C_CALLS  DSOPEN,DSCLOS,DSREAD,DSWRIT,A2AN,FILL,DATIME,IABS,MODAC_HISTORY  82AUG02  R.Mehlman  UCLA    VAX/VMS FORTRAN 77 VERSIONKC      1/19/83 XXOPEN/CLOS/READ/WRIT CALLS REPLACE BY DSOPEN/CLOS/READ/WRIT;C      9/10/82 SAME SECTOR TEST FIX  11/16/82 TYPE -1 ADDEDCMC Revised for pin software specifications JUNE 22,1987  Changed all variablesNC with J1 and J2 to K1 and K2 so that XXCOM could be included in this routine.C_ENDEC  REF: FILORG.DOC FOR XX FILE DESCRIPTION, TERMINOLOGY AND STRUCTURE	C_CONTROL@!   *** MODE 0 *** (INIT) IROW SHOULD BE PROTECTION KEY, IF ANY)F!   IA IS ARRAY FOR LOGICAL RECORD (MODES 0 and 3: FILE HEADER SECTOR)!,! IR IS RETURN CODE: gt 0  SYSTEM ERROR CODE!                       0  OK>!                      -1  END OF FILE OR SEQUENCE IN GET MODE'!                      -2  ILLEGAL MODE,!                      -3  ILLEGAL FILE TYPE1!                      -4  UNEXPECTED SECTOR SIZE7!                      -5  UNAUTHORIZED READ (NEED KEY)*!                      -6  FILE NOT OPENED8!                      -7  ILLEGAL ROW OR LOGICAL RECORD+!                      -8  ILLEGAL COLUMN  C_END<! *** NEEDS (1) TEST OF 'PUT' CODE                       ***<! ***       (2) MULTI-SECTOR TYPE 0 RECORD CODE          ***<! ***       (3) PARTIAL SECTOR (OR WORD REQUEST) 'GET' ? ***<! ***       (4) 'EXTEND' CODE FOR FILE WITH DIRECTORIES  ***<! ***       (5) TAPE OPTION (HEADER SECTORS IN DISK FILE)***<! ***       (6) FILE TYPES 3 and 4.                      ***      >      DATA IBFU,IBLUN,IBNAM,IBSECT,IBK1,IBK2,IBFLAG,IBHDR,LSAV?     1    /   1,    2,    3,     6,   7,   8,    10,   21,  40/,      DATA IBROW1,IBROW2,IBLIN1,IBLIN2,IBBUF-     1    /    11,    12,    13,    14,   61/>      DATA IBFROW,IBMAX,IBNCOL,IBFLIN,IBTYP,IBNHDR,IBSTYP,IBLS?     1    /    21,   22,    23,    24,   25,    26,    27,  33/      DATA IBLR,IBNRPS     1    /  23,    24/+      DATA IFUD,IHFROW,IHTYP,IHRP,IHWP,IHLS,     1    /  64,     1,    5,   9,  10,  13/       INTEGER BSIZE;      INCLUDE 'RAD$INC:XXCOM.INC/LIST'   !Uses: IOUT,J1,J2.					 !Modifies: NONE.9!-----Mode check, for mode 0 IROW is the protection flag.
      IR=0!      IFU=IB(IBFU)		!Logical unit%      MODE=IABS(IMODE)		!Program mode*      IF (MODE.LT.0.OR.MODE.GT.3) GO TO 72      IF (MODE.GT.0) GO TO 18F!-----Initialization: check fortran unit, initialize flags, open file.      IF (IFU.LE.0)THEN*        IB(IBFU)=IFUD		     !default to 64        IFU=IFUD      ENDIFN      CALL FILL(IB(IBSECT),15,0)     !Fill the first 15 locatins of ib with 0.      LUN=IB(IBLUN)!!---- CHECK FOR TS1000 AND TS20005      IF((IB(IBNAM+1).EQ.'10'.OR.IB(IBNAM+1).EQ.'20')F     1                                   .AND.IB(IBNAM+2).EQ.'00')THEN!      CALL ASSIGN(10,IB(IBNAM),6)$D     TYPE*, ' ORBITER ',IB(IBNAM+1)!      IF(IB(IBNAM+1).EQ.'10')THEN@        INQUIRE(FILE='XG$DAT:TS1000.DAT',RECL=BSIZE,IOSTAT=IERR)&      ELSE IF(IB(IBNAM+1).EQ.'20')THEN@        INQUIRE(FILE='XG$DAT:TS2000.DAT',RECL=BSIZE,IOSTAT=IERR)      ENDIFD     WRITE(IOUT,7099)BSIZE  7099 FORMAT(' RECORD SIZE ',I6)      IF(IERR.EQ.29)THEN3	WRITE(IOUT,7000)0 7000   FORMAT('ERROR UNABLE TO FIND THE FILE ')      ELSE IF(IERR.EQ.30)THEN        WRITE(IOUT,7001)2 7001   FORMAT('** OPEN FAILURE ON DATABASE FILE')      ENDIF      CLOSE(UNIT=10)-!-----IF RECSIZE EQUAL TO 5120 THEN LUN = 10.       IF(BSIZE.EQ.20480)LUN = 10      ENDIF              IF(LUN.EQ.10)THENG        CALL DBSOPEN(IFU,LUN,IB(IBNAM),ICOL,0,0,IR)	!Initialize dsopen.D	TYPE*, ' DBSOPEN IR= ',IR	      ELSE F        CALL DSOPEN(IFU,LUN,IB(IBNAM),ICOL,0,0,IR)	!Initialize dsopen.D	TYPE*, ' DSOPEN IR= ',IR	      ENDIF      IF (IR.NE.0) GO TO 700!-----Read file header, mark control block open.
      ISECT=16      IF(LUN.EQ.10)THEN				!Special open for new chunk+        CALL DBSREAD(IFU,ISECT,IA,ICOL,IR)	
      ELSE)        CALL DSREAD(IFU,ISECT,IA,ICOL,IR)      ENDIF            IF (IR) 71,15,70=!-----Check type, sector length, protection, set access flag.O 15   IF (IABS(IA(IHTYP)).GT.1) GO TO 73        !Legal file size? Error if > 0.F      IF (IA(IHLS).NE.ICOL) GO TO 74		!Check sector length, if invalid 						!length then error of -4,	H!-----IA(IHWP=10) is a write protection flag, if < 0 then there is none,2!     = 0 then write protect no key, >0 write key.N!-----IA(IHRP=9) is read protection flag, if = 0 there is none, else read key.!O!-----IROW is initialized in a data statement in XGDATA (calling routine) to 0.F      IF (IA(IHRP).NE.0 .AND. IROW.NE.IA(IHRP) .AND. IROW.NE.IA(IHWP))%     1 GO TO 75							!Then an error.C!-----Test the write protect flag. if < 0 then set ib(IBFLAG) to 1.B      IF (IA(IHWP).LT.0 .OR. (IA(IHWP).GT.0.AND.IROW.EQ.IA(IHWP)))     1 IB(IBFLAG)=10!-----Save part of file header in control block.      CALL FILL(IA(IHRP),2,0)"      CALL A2AN(IA,IB(IBHDR),LSAV)      GO TO 65O!*********************************END OF MODE 0 (INITIALIZATION) **************"!-----GET/PUT/CLOSE: IS FILE OPEN?E 18   IF (IB(IBSECT).EQ.0) GO TO 76	!If current sector=0 then return.*      LS=IB(IBLS)			!Data item, Unit size.      IF (MODE.EQ.3) GO TO 40>!-----GET/PUT SETUP: CHECK PARAMETERS (IF PUT, IS IT ALLOWED?)1      IF (MODE.EQ.2.AND.IB(IBFLAG).EQ.0) GO TO 79      IF (IROW.LT.0) GO TO 77
      I1=1 !-----Absolute mode.      IF (ICOL.LT.0)THEN        IF (IROW.EQ.0) GO TO 77        ISECT=IROW        N=LS        GO TO 30      ENDIF!-----Type of file.      ITYPE = IB(IBTYP)2      IF(ITYPE.EQ.0)THEN      			!---TYPE 0 FILE           IF (ICOL.GT.0) GO TO 205'        IF (IB(IBSTYP).NE.-1) GO TO 204=!-------File with directories, initialize sequence if IROW=0.        IF (IROW.LE.0) THEN          IROW=IB(IBROW1)!          IF (IROW.LE.0) GO TO 71
        ENDIFD 201    IF (IROW.GT.IB(IBROW2)) GO TO 71	!Check for end of sequence.        GO TO 205D 204    IF (IROW.LE.0)THEN	      !Simple file, initialize if IROW=0.          IROW=1(          IF (MODE.EQ.2) IROW=IB(IBFROW)
        ENDIFP 205    NRPS=IB(IBNRPS)               !Compute sector, origin in buffer, length.'        ISECT=(IROW-1)/NRPS+IB(NHDRS)+1        N=IB(IBLR)        J0=MOD(IROW-1,NRPS)*N2      ELSE IF (ITYPE.EQ.-1)THEN				!Type -1 setup. 208    K2=IB(IBNRPS)1      ELSE IF (ITYPE.EQ.1) THEN				!Type 1 file. 9! 	IF (ICOL.EQ.0.OR.ICOL.GT.IB(IBNCOL)) GO TO 78   !ERROR-!     Simple file get, initialize if irow = 00        IF (MODE.EQ.2.AND.IB(IBSTYP).NE.-1) THEN(          IF (IROW.EQ.0) IROW=IB(IBFROW)          I1=IB(IBK1)			   	          K1=I1          J0=K1-1          N=IB(IBK2)-I1+13          ISECT=(IROW-1)*IB(IBNCOL)+ICOL+IB(IBNHDR)
	  GOTO 309        ELSE 					!IF(MODE.NE.2.AND.IB(IBSTYP).EQ.-1)THEN          K2=LS	ENDIF      ENDIF.      IF ((ITYPE.EQ.-1) .OR. (ITYPE.EQ.1))THEN        K1=1"        IF (IB(IBSTYP).NE.-1) THENO          IF (IROW.EQ.0) IROW=1         !Simple file get, initialize if irow=0.$!-------Check for end of simple fileN!-------Past end of file or sequence - set K2=0 to indicate no-more-data l/219"          ISENSE=(IROW-IB(IBFROW))	  IF(ISENSE.GT.0)THEN            IB(IBK2)=0            GO TO 71	  ELSE IF(ISENSE.LE.0)THEN@            IF(ISENSE.EQ.0)K2=IB(IBFLIN)-1		!End of simple file.            N=LS	    GOTO 20          ENDIF	ENDIF8!-------File with directories, then initialize sequence.G        IF( (IROW.GT.0) .AND. IROW.NE.IB(IBROW1) )THEN   !IB(IBSTYP=-1)	  ISENSE = (IROW-IB(IBROW2))          IF (ISENSE.LT.0)THEN             N = LS	  ELSE IF(ISENSE .EQ. 0)THENA 	    K2=IB(IBLIN2)                             !End of sequence.            IF (K2.LT.K1)THEN               IB(IBK2)=0               GOTO 71            ENDIF            N=LS%          ELSE IF (ISENSE .GT. 0)THEN            IB(IBK2) = 0
	    GO TO 71		  ENDIF        ELSE          IROW=IB(IBROW1)            IF (IROW.LE.0) THEN 	     IB(IBK2)=0             GOTO 71            ELSE8              K1=IB(IBLIN1)		!Check for end of sequence.            ENDIF	  ISENSE = (IROW-IB(IBROW2))          IF (ISENSE.LT.0)THEN             N = LS	  ELSE IF(ISENSE .EQ. 0)THEN4 	    K2=IB(IBLIN2)                !End of sequence.            IF (K2.LT.K1)THEN               IB(IBK2)=0               GOTO 71            ENDIF            N=LS%          ELSE IF (ISENSE .GT. 0)THEN            IB(IBK2) = 0
	    GO TO 71		  ENDIF          ENDIF
        ENDIF'!------Compute sector compute type(-1). 20     IF(ITYPE.EQ.1)THEN3          ISECT=(IROW-1)*IB(IBNCOL)+ICOL+IB(IBNHDR)%        ELSE IF(ITYPE.EQ.-1)THEN		             ISECT=IROW+IB(IBNHDR)	ENDIF-!------Get|put buffering code - full sector?  30   IF (N.EQ.LS) THEN;        IF(MODE.EQ.2)THEN			!Full sector, write users array.	  CALL DSWRIT(IFU,ISECT,IA,LS,IR)	!to buffer.	ELSE8	  IF(LUN.EQ.10)THEN 	   		 !No read sector into user's 9            CALL DBSREAD(IFU,ISECT,IA,LS,IR)       !arrayD	TYPE*, ' DBSREAD IR= ',IR		  ELSE$	    CALL DSREAD(IFU,ISECT,IA,LS,IR)D	TYPE*, ' DSREAD IR= ',IR		  ENDIF,          IF(IR.NE.0)THEN			!Error checking!            IF(IR.LT.0)GOTO 71	    IF(IR.GT.0)GOTO 64	  ENDIF          GOTO 39!	ENDIF                           0      ELSE IF(N.NE.LS)THEN		!No sector not full.,!-------NO, Same as previous sector?                IF(IR.LT.0)GOTO 71			 /        IF(IR.GT.0)GOTO 64			  !Error checking.	IF (ISECT.NE.IB(IBSECT))THEN	  IF(LUN.EQ.10)THEN*		CALL DBSREAD(IFU,ISECT,IB(IBBUF),LS,IR) D	TYPE*, ' DBSREAD IR= ',IR		  ELSE)		CALL DSREAD(IFU,ISECT,IB(IBBUF),LS,IR) D	TYPE*, ' DBSREAD IR= ',IR		  ENDIF	ENDIF	     	IF (MODE.EQ.2)THEN		E          CALL A2AN(IA(I1),IB(IBBUF+J0),N)	  !Yes move logical recordM          CALL DSWRIT(IFU,ISECT,IB(IBBUF),LS,IR)  !from users array to buffer-        ELSE					  !and write buffer to disk.H          CALL A2AN(IB(IBBUF+J0),IA,N)	          !No move logical record-	  GOTO 39				  !from user's array to buffer.
        ENDIF      ENDIF	!-----Set modified flag.      IB(IBFLAG)=3;!-----Update header items in control block where necessary.      KFREE=IB(IBFROW)      IF (ICOL.EQ.0) THEN       	KFREE=KFREE+1
      ELSE; 37     IF (ITYPE.NE.1.OR.ICOL.LT.0.OR.IB(IBSTYP).EQ.-1.OR.     1  IMODE.LT.0) GO TO 39        KFREE=IROW#        IF (K2.EQ.LS) KFREE=KFREE+1        IB(IBFLIN)=MOD(K2,LS)+1      ENDIF 38   IB(IBFROW)=KFREE-!-----Update logical record (type 0, icol=0).  39   IF (ICOL.EQ.0) IROW=IROW+1      GO TO 601!-----Close file, update header if file modified. 40   KEOF=0G!-----Update file header from control block, insert date last modified.       IF (IB(IBFLAG).GE.3) THEN         ISECT=1	IF(LUN.EQ.10)THEN*          CALL DBSREAD(IFU,ISECT,IA,LS,IR)D	TYPE*, ' DBSREAD IR= ',IR			ELSE#	  CALL DSREAD(IFU,ISECT,IA,LS,IR) D	TYPE*, ' DBSREAD IR= ',IR		ENDIF	        IF (IR.NE.0) GO TO 705        IF (IB(IBFROW).GT.IA(IHFROW)) KEOF=IB(IBSECT)        IA(1)=IB(1)        IA(4)=IB(4)        CALL DATIME(IA(81))'        CALL DSWRIT(IFU,ISECT,IA,LS,IR)        IF (IR.NE.0) GO TO 70      ENDIF,!-----Close file, mark control block closed. 45   CALL DSCLOS(IFU,KEOF,IR)      IF (IR.NE.0) GO TO 70
      ISECT=0      GO TO 65!-----Normal termination. 60   IR=0 		!IR=04 64   T1=FLOATJ(K1)	!need to convert from I*4 TO I*2/      T2=FLOATJ(K2)     !So do it the hard way.      IB(IBK1)=IIFIX(T1)      IB(IBK2)=IIFIX(T2) 65   T1=FLOATJ(ISECT)      IB(IBSECT)=IIFIX(T1)      RETURN 70   IF(IR.EQ.30)THEN	WRITE(IOUT,900)+900     FORMAT(' UNABLE TO OPEN THE FILE ')      ELSE IF(IR.EQ.29)THEN	WRITE(IOUT,901)*901     FORMAT(' UNABLE TO FIND THE FILE')      ELSE IF(IR.EQ.24)THEN	WRITE(IOUT,902)+902     FORMAT(' END OF FILE DURING READ ')      ELSE IF(IR.NE.0)THEN	WRITE(IOUT,903)-903     FORMAT(' ERROR DURING READ OR OPEN ')      ENDIF      RETURN
!-----Errors. 71   IR=-1!      WRITE(IOUT,700)8! 700  FORMAT(' END OF FILE OR OR SEQUENCE IN GET MODE')      GO TO 65 72   IR=-2      WRITE(IOUT,701) 701  FORMAT(' ILLEGAL MODE')      GO TO 70 73   IR=-3      WRITE(IOUT,702)" 702  FORMAT(' ILLEGAL FILE TYPE')      GO TO 70 74   IR=-4      WRITE(IOUT,703)' 703  FORMAT(' UNEXPECTED SECTOR SIZE')      GO TO 70 75   IR=-5      WRITE(IOUT,704)- 704  FORMAT(' UNAUTHORIZED READ (NEED KEY)')      GO TO 70 76   IR=-6      WRITE(IOUT,705)  705  FORMAT(' FILE NOT OPENED')      GO TO 70 77   IR=-7!      WRITE(IOUT,706)/! 706  FORMAT(' ILLEGAL ROW OR LOGICAL RECORD')      GO TO 65 78   IR=-8      WRITE(IOUT,707)$ 707  FORMAT('XXGP> ILLEGAL COLUMN')      GO TO 70 79   IR=-9!      WRITE(IOUT,708)=! 708  FORMAT(' UNAUTHORIZED WRITE (NEED KEY) OR READ ONLY.')C      GO TO 65	      END