E       SUBROUTINE XGDATA (IA,ID1, INDXG,ID2,MAXL,MXNVA,PROGNM,XGUSER)BC_TITLE  XGDATA  Data access routine for  XX-type database access.C_ARGUMENTSP        PARAMETER (LS=120)    ![I] Number of database rows to fetch at one call.9	INTEGER*2 IA(LS,ID1)  ![I] Requested database variables.:	INTEGER ID1	      ![I] Maximum number of columns allowed.4	INTEGER*2 INDXG(ID2)  ![I] Defines valid databases.@	INTEGER ID2	      ![I] Varies with database, number of columns.7	INTEGER MAXL	      ![I] Number of time ranges in list.6	INTEGER MXNVA	      ![I] Maximum number of variables.-	CHARACTER*16 PROGNM   ![I] Title of program.C	REAL XGUSER	   ![I] Name of user-written program called by XGDATA.C_VARIABLESO      INCLUDE 'RAD$INC:XXCOM.INC/LIST' !Contains orbit and sequence parameters.LC                                      Uses: IOUT, ILIST, IXXC4, KS, NOSPOT,.C				       KVDEF, IDDB, J1, J2, IPARM, DATIM.4C				       Modifies: IDTER1, IDTER2, IDPRIM, IDSEC,-C                                      IDSUB.'      INCLUDE 'RAD$INC:XXGCOM.INC/LIST'.C				       Uses: MXNCOL, NSPOTS, NCOL, NVAR, =C                                      NCON, IFGSET,  KPTCON,2C                                      ICOL, IFUN.GC                                      Modifies: MXNVAR, MXNIAD, IDCON.'      INCLUDE 'RAD$INC:XXDCOM.INC/LIST'0C				       Uses: KDEF, KSCALE.  Modifies: none.&      INCLUDE 'RAD$INC:XXTAE.INC/LIST'KC                                      Uses: IACC, CHARTMP, IDSUB1, LRANGE,JC                                      LPP, NUML, ISMODE.  Modifies: none.EC_DESCRIPTION  The subroutine XGDATA.FOR is a control subroutine for =C XG-type database access, with generalized variables.  It isFC called by a dummy main program; XGDATA calls user subroutine XGUSER.IC The user routine is external, and this subroutine performs most of the @C database functions of controlling the constraints, sending theHC data that passes the constraints to the user routine; it also controlsEC the calling of subroutines which initialize the File Control Block.FC This module calls the user application routine XGUSER 5 times with aEC program control code which dictates the action of the user routine. =C_CALLS  XGUSER  XGINIT  XXGP  XXGMUL  XXDSET  XXCSET  XXSPOT7C	XXGSET  MVINT  ASCII  DATIME  TRANS2 SPOTCHECK XGVDEF#C_COMMONS XXTAE,XXCOM,XXGCOM,XXDCOMOC_HISTORY  85Jul05  Hugh_H_Kieffer  Flagstaff  Use  GET_1 system for user input&C  85Feb11   HHK  Derived from  XXDATAGC  86March11 Robert L. Gurule, USGS Flagstaff, Revised to use the  TAE C            interface.  FC  87JUL1  Robert L. Gurule, Uses logical assignment for include filesHC          NIMS/VIMS documentation standards, and new routine SPOTCHECK.C_END      LOGICAL LSEQ1      CHARACTER*5 MIDUM      CHARACTER*7 FMT      CHARACTER*6 CALLED(13)      CHARACTER*10 PUNIT      CHARACTER*32 LABEL	        CHARACTER*16  PRTFIL1      INTEGER I2COL,KRANGE(6)3      INTEGER*2 IPRIM(120),ISEC(120),IB(60),KTMP(6)*      INTEGER*2 IC(60),NAMEDB(3),NAMECD(3)8      INTEGER*2 LFUCD,LUNCD,LFUDB,KSECT,IBJ1,IBJ2,IOFLAGC      INTEGER*2 IBLR,IBNRPS,IBTYPE,IBIVDF,IBNVDF,IDSUBC,IDP1C,IDP2C      COMMON /XXPCOM/ IPRIM      COMMON /XXSCOM/ ISEC<      EQUIVALENCE (LFUCD,IC(1)),(LUNCD,IC(2)),(NAMECD,IC(3))<     1           ,(LFUDB,IB(1)),(LUNDB,IB(2)),(NAMEDB,IB(3))?     2 ,(KSECT,IB(6)),(IBJ1,IB(7)),(IBJ2,IB(8)),(IOFLAG,IB(10))5     3 ,(IBLR,IB(23)),(IBNRPS,IB(24)),(IBTYPE,IB(25))'     4 ,(IBIVDF,IB(37)),(IBNVDF,IB(38))5     & ,(IDSUBC,IB(52)),(IDP1C,IB(54)),(IDP2C,IB(55)):     5 ,(IDP1,KRANGE(1)),(IDP2,KRANGE(2)),(IDS1,KRANGE(3)):     6 ,(IDS2,KRANGE(4)),(IDT1,KRANGE(5)),(IDT2,KRANGE(6))9	DATA CALLED/'USER_1','USER_2','USER_3','USER_4','USER_5'@     &,    'XXCSET','XXDSET','XXGP  ','XXGMUL','XXGSET','XXGDEF'     &,    'XXSCON','GETN_ '/<      DATA LFUDB,LFUCD,LUNCD,NAMECD /62,61,0,2HDB,2HCD,2H00/@      DATA KSECT,IDSUBC,IDP1C,IDP2C /0,0,0,0/,KEYDB/0/,NSPOTS/7/>      DATA LUNDB/4/,NAMEDB/'  ','  ','  '/,LPP/60/,XSTART/0.0/"!-----	MOVE DIMENSIONS INTO COMMON$      CALL ACTIME('IN',ILIST,5,IERR)      MXNVAR = MXNVA      MXNIAD = ID1L!-----Call user routine to initialize (user may modify col. number's, spots)(!     define arguments and common items. 
  10  ICALL=1/      CALL STINPUT(1)                          +      CALL XGINIT (MAXSUB,NCJ,KDIF,PROGNM)	      CALL STINPUT(2)      CALL XGUSER(1,IA,LS,IR)      IF (IR-1) 5,10,81 5    CONTINUE!-----Save data file name.@      DO I =1,3			   !***WARNING Do not place Namedb or Lundb inE	 NAMEDB(I) = CHARTMP(I)    !equivalence if you do their alignment in<      ENDDO			   !common will create havoc....**************      CALL ASCII(IDDB+100,ISEC)A      NAMECD(3)=ISEC(3)                                          %!-----Initialize loops, print header. 20   KURL=1?      WRITE (ILIST,921)(IDSUB1(L),(LRANGE(I,L),I=1,6),L=1,NUML); 921  FORMAT ('  S/C  ORBIT_RANGE   SEQ_RANGE  TIME_RANGE'/     1 (I4,2X,6I6))      IF (IFGSET.NE.0)THEN        CALL STINPUT(3)		ICALL=10	CALL XXGSET(IR)		IF (IR.EQ.1) GOTO 10	IF (IR.NE.0) GOTO 81	  WRITE (ILIST,946);946	  FORMAT('0LOC    VAR  NAME    DESCRIPTION           ',-     1    'UNIT       STORE PRINT SCALING',/)K!- I2COL Is integer* 4 variable used for compatibility with routine xgvdef.	  DO J=1,NVAR	    I2COL = ICOL(J)A            CALL XGVDEF(2,MIDUM,I2COL,KTMP,KTMP,KTMP,%REF(PUNIT),     1      %REF(LABEL),FMT)@	    WRITE (ILIST,947)J,ICOL(J),(KDEF(IJ,J),IJ=1,3),LABEL(1:20),/     1      PUNIT,(KDEF(JA,J),JA=7,8),KSCALE(J)9947	    FORMAT(1X,I4,I6,2X,3A2,2X,A20,2X,A6,4X,2I6,2X,I6)          ENDDO      ENDIF9!-----Set for col output, spot logic, save col numbers's.      KO=NCOL-KDIF      KSD=NSPOTS      IF (KSD.EQ.0) KSD=1      KSK=10      IF (NCOL+NCJ.GT.MXNCOL .OR. NCOL.GT.MXNIAD?     & .OR. KO+NCJ.GT.MXNIAD .OR. NVDEF+KVDEF-1.GT.MXNIAD) THEN	WRITE(IOUT,925)6925	FORMAT (' TOO MANY COLUMNS FOR EITHER ICOL OR IA')		GOTO 81	      ENDIF!-----Set for new sequence.30      IDSUB = IDSUB1(KURL)$	CALL MVINT(LRANGE(1,KURL),KRANGE,6)        IDTER1=IDT1        IDTER2=IDT2P        IF(IDS1.NE.0 .AND. IDS2.EQ.0)IDS2=99    !Only for N--> end of sequences.?        IF(IDS2.LT.IDS1) IDS2=IDS1   		!Switch min's and max's)"        IF(IDP2.LT.IDP1) IDP2=IDP1H!--     Set beginning sequence to 1, so that it doesn't fetch the entire4!       range when looking for sequences to process."	IF(IDS1.EQ.0.AND.IDS2.NE.0)IDS1=1        IDPRIM=IDP1 32     INSEC=IDS1        LDSEC=-1           IF(INSEC.NE.LDSEC)THEN            LDSEC=INSEC          ELSE            GOTO 45          ENDIF< 41   IF (IACC.EQ.-1.OR.(IDSUB.EQ.IDSUBC.AND.IDPRIM.GE.IDP1C&     1  .AND.IDPRIM.LE.IDP2C))GOTO 415@!-----No, request next chunk.  if not present, wait for restore.
      ICALL=66      CALL XXCSET(IDDB,IDSUB,IDPRIM,IC,INDXG,IB,LS,IR)'      IF(LUNDB.EQ. 10)WRITE (ILIST,920)+ 920  FORMAT ('0 ACCESS = OPTICAL DISK ',/)+      IF(LUNDB.NE.10.AND.XSTART.EQ.0.0)THEN        XSTART=1.0	*        WRITE (ILIST,924)(NAMEDB(K),K=1,3)+ 924    FORMAT ('0 DATABASE FILE = ',3A2,/)      ENDIF      IF (IR+36) 81,77,412 412  IF (IR.NE.0) GO TO 81G!-----New file! Only perform during initialization, or when a new chunk2!     with corresponding headers needs to be read.8 415  IF (KSECT.EQ.0)THEN		!If a new file then KSECT = 0>!-----Yes, initialize (gets file header sector into IA(1-ls)).         ICALL = 8'         CALL XXGP(0,IB,LS,KEYDB,IA,IR)         IF (IR.NE.0) GO TO 81:!-----Set to process data according to file type (1 or -1)         NLINES=LS'         IF (IBTYPE.EQ.-1)NLINES=IBNRPS         NVDEF=IBNVDFO!-----Get record definition sectors into IA tail sectors of IA.  XXGMUL simply J!     gets NVDEF number of contiguous sectors by calling XXGP NVDEF times.-         IF (KVDEF.NE.0 .AND. NVDEF.NE.0)THEN           IVDEF=IBIVDF           ICALL=98           CALL XXGMUL(IB,IVDEF,NVDEF,IA(1,KVDEF),LS,IR)         IF (IR.NE.0) go to 81         ENDIF      ENDIF.!-----Get primary and secondary entries.      
      ICALL=7      A      CALL XXDSET(IDDB,IDSUB,IDPRIM,INSEC,IB,INDXG,IPRIM,ISEC,IR)      IF (IR.EQ.0) GO TO 42%!-----Sequence not found: what to do?      IF (IR.GE.-20) GO TO 81      MR=-IR-20O!-----XXDSET non-standard returns: end of primary, no seq, primary out of file,C!     missing primary, non-directory file, unexpected db or sub-db.                           %      GO TO (75,72,75,43,81,81,75),MR!-----Sequence found. 42   IDSEC=IB(16)#      IF (IDTER2.EQ.0) IDTER2=327674!-----Print log entry for sequence, including title.B      WRITE (IOUT,942) IDSUB,IDPRIM,IDSEC		!RG, always write seq. /     1 ,IDTER1,IDTER2,ISEC(5),(ISEC(I),I=61,80)8 942  FORMAT (' ORBIT',I2,'/',I4,'  SEQ',I3,3I6,2X,20A2)      IF(IDSEC.GT.100)THEN*	 TYPE*, 'Error sequence greater than 100'
	 CONTINUE      ENDIF         J!-----Patch to fix problem when sequence does not exist (ISMODE =1 OR =2).  43  CONTINUE      IF(IR.EQ.-24)THENf0	 GOTO 75			!Goto 75 increment SEQ check against!      ENDIF				!max and continue.                         P!-----First seq: get id info for each column, compute scales, scale constraints.  45    KPTCON = 0        IF(NCON.GT.0)THEN.          DO I =1,NCON			 )            IF(IDCON(4,I).EQ.1)KPTCON=I   	    GOTO 49          ENDDOu
        ENDIF.B!-----Sequence constraints: skip entire sequence if not satisfied.49	ICALL=12 	IR=0 7	IF (IDDB.EQ.1.AND.NCON.NE.0)CALL XXSCON(IDCON,NCON,IR)f	IF (IR.NE.0) GOTO 74R(!-----Set time constraints for sequence.	IF(KPTCON.NE.0)THEN	  IDCON(2,KPTCON)=IDTER1X	  IDCON(3,KPTCON)=IDTER2b
	ENDIF        +!------ Start with first point of sequence. 	ICALL=2	CALL XGUSER(2,IA,LS,IR)C!------Skip sequence on user request (with or w/o end-of-seq proc).i/      IF (IR.GT.0) GO TO (81,74,81,70,81,81),IR @        CALL SPOTCHECK(NCJ,IB,IA,NLINES,ID1,XGUSER,J1,J2,NOSPOT) 70	ICALL=4	CALL XGUSER(4,IA,LS,IR)2!-----Redo sequence or quit early on user request./      IF (IR.GT.0) GO TO (81,45,81,81,77,81),IR
      GOTO 74!-----Missing sequence.) 72   WRITE (IOUT,972) IDSUB,IDPRIM,INSEC= 972  FORMAT (' Sub-Database',I3,'  Orbit',I5,' Sequence',I4,     1 ' is missing.')	?!-----Range input: set for next seq unless end of primary unit. 74   IF (INSEC.EQ.0) GO TO 41      INSEC=INSEC+1!      IF (INSEC.LE.IDS2) GO TO 41B!-----Range input: end of primary unit - set for next unless done. 75   IDPRIM=IDPRIM+1"      IF (IDPRIM.LE.IDP2) GO TO 32E!-----Range input: end of range for subdb - set for next unless done.      KURL = KURL + 1      IF (KURL.LE.NUML)GOTO 30-!-----Call user routine for final processing.
 77   ICALL=5      CALL XGUSER(5,IA,LS,IR)      IF (IR.GT.5) GO TO 81      CALL DATIME(DATIM)>!-----Concatenate file name with .prt and display to the user.(      CALL ADDEXT(PROGNM,PRTFIL1,'PRT')	      IPER = INDEX(PRTFIL1,':')      PRTFIL1(IPER:IPER) = '.'      ?      WRITE (IOUT,977)PRTFIL1(1:IPER-1),DATIM,PRTFIL1(1:IPER+3)7 977  FORMAT (/,' ',A<IPER-1>,' STRIKES AGAIN: ',5A4,//'     .        ,' Print File is ',A16,/)            CALL BEEP (5,3)			H!-----Termination...used to get "lost in space", so let's just kill this!     process now!$      CALL ACTIME('WT',ILIST,5,IERR)!80    STOP '  Normal Termination'!-----errors
88	ICALL = 13	IR = 0!81	WRITE (IOUT,981) CALLED(ICALL)981	FORMAT (' Error in XGDATA:'2     &,' called routine and its return code = ',A)$ 999    STOP ' Abnormal Termination'	      END