      SUBROUTINE XXGSET (IR)FC_TITLE XXGSET Set up variables, functions and constraints for arrays.C_ARGUMENTS%	INTEGER IR  ![O] Return status code.'C                     0 = Format error.'C                     1 = Undef column.'C	              2 = Undefined function.%C	              3 = Too many columns.-C                     4 = Too many functions.&C                     5 = User quit.  1C                     6 = Input Variable problem.1C                     7 = Constraint input error.HC_DESCRIPTION  The subroutine XXGSET will request and set up variables, LC functions, and constraints for the XGDATA system.  XXGSET initializes all NC arrays to be used for the manipulation of data and constraints. Initializes IC variables for SPOT dependent databases, determines the total number of JC variables, preset and user input, and creates pointers for user created C function variables.3C_CALLS  XXCPTR  XXFSET  XXAPTR  FILL  MIN0  XGVDEFC_COMMONS  XXCOM  XXGCOM XXTAEOC_HISTORY 82Jun29  R.Mehlman  UCLA  ICOL made  INT*2, seq constraint pass-thru.	C 1/3/82.?C 85Feb11  Hugh_H_Kieffer  Allow preset of principal variables.C HC 87Jul20  Robert L. Gurule, USGS Flastaff, convert to TAE and NIMS/VIMSC          Documentation.C_VARB      INCLUDE 'RAD$INC:XXCOM.INC/LIST'		!Contains declarations for"!						database specific paramters!						Uses: IOUT, ILIST.!						Modifies: none.B      INCLUDE 'RAD$INC:XXTAE.INC/LIST'		!Contains declarations for!!						parameters accessed by TAE!						Uses: INCON:!						Modifies: None.D      INCLUDE 'RAD$INC:XXGCOM.INC/LIST'		!Contains many database or "!						program dependent variables&!						many are initialized by program&!						XGINIT.  Uses: MAXCOL, MAXNCOL,&!						MXNCON, MXNFUN, MXNARG, NSPOTS,!!						NCOLP, NCOL, NVAR, IUNIT, !						LUMPSEQ."!						Modifies: NCON, NCOL, NVAR,!						NFUN, KSPOTS, ICOL,!						IDCON, IFUN.J      INCLUDE 'RAD$INC:XXDCOM.INC/LIST'	        !Scaling factors in print,!						storage units.!						Uses: KDEF!						Modifies: KSCALEC_PAUSE						      CHARACTER*32 LABELH      CHARACTER*6 VUNITS                    !Six byte units of variables;      CHARACTER*5 MIDUM		            !dummy character name.3      CHARACTER*7 FMT                       !Format      INTEGER*4 INV(10)      		      INTEGER*2 ISS,IPS,KTMP(6)      INTEGER XXCPTR      LOGICAL LINIT /.FALSE./      LOGICAL LREAD1/.FALSE./      DATA NCONSV /0/,NT/0/ 2    CONTINUE8!-----Determine instrument type and the number of spots.      IF (NSPOTS.NE.0)THEN        NCOL=0        NFUN=0  11  ENDIF8      IF (LINIT .AND. LREAD1 .AND. ICOL(1).EQ.0) GOTO 20O!-----First set of 10: Initialize column/constraint/function arrays and counts.!     Set column arrays.        IF(LREAD1)THEN#	  CALL FILL (IFUN,MXNFUN*MXNARG,0)	  LREAD1 = .FALSE.	ENDIF(!-------Loop on items input in this set.M!       Determine the total number of variables set by presetting and entered!       by the user.
	DO 16 K=1,30$	  IF ( K.LE.NCOLP) THEN	           )	    IF (ICOL(K).GT.MAXCOL) GO TO 181    	  ELSE&            IF (ICOL(K).EQ.0) GO TO 16
	    NCOL = K	  ENDIF	  IF (ICOL(K).LT.0) THEN8	   CALL XXFSET(-ICOL(K),K,IR)		!Function or Difference.	  IF (IR.NE.0) GO TO 19
        ENDIF 16	CONTINUEGC-----End of input items, find col/arg pointers of any function entriesNC     this is done after all vars processed so vars are 1st ncol ICOL entries.      NVAR=NCOL)!-----Fill icol with (mxncol-ncol) zeros.,      CALL FILL (ICOL(NCOL+1),MXNCOL-NCOL,0)A!-----If the number of function code(s) > 0 call XXAPTR for each.      IF (NFUN.EQ.0) GO TO 176      DO 175 KFUN=1,NFUN        CALL XXAPTR(KFUN,IR)        IF (IR.NE.0) GO TO 19 175  CONTINUE 176  NCOLV=NCOL      GO TO 20C-----Input errors.
 181  IR=1      GO TO 19
 182  IR=0 19   WRITE (IOUT,919) IR? 919  FORMAT (' VARIABLE INPUT ERROR, CODE',I3,', START AGAIN')      GO TO 71  20  LINIT=.TRUE.5C-----Request constraint triples, check for validity.      K = 0   21 K=K+1      KVAR = INCON(1,K)      NCONSV = NCON     &C-----No more constraints, print them.      IF(NCONSV.EQ.0)K=NCONSV      IF (K.GT.0)THEN	WRITE (ILIST,930) 9  930    FORMAT ('0  CONSTRAINTS: VAR',32X,'MIN   MAX',/)D!------Print out the constraints along with their mins and maximums.	DO I=1,NCONSV	  ID1 = INCON(1,I)E       CALL XGVDEF(2,MIDUM,ID1,ISS,IPS,KTMP,%REF(VUNITS),%REF(LABEL),     1 FMT)        XR = ISS           RMIN = INCON(2,I) / XR           RMAX = INCON(3,I) / XR"	  WRITE(ILIST,932)LABEL,RMIN,RMAX#  932     FORMAT(' ',15X,A32,2F6.1)	ENDDO	      ENDIFCC-----Set up permanent constraint array, replace col/ids with ptrs.!      CALL FILL(IDCON,4*MXNCON,0)      NCOL=NCOLV      NCON=0	      K=0JC-----Set up automatic time constraint (min and max set at seq init time).      KVAR=1      KMIN=0      KMAX=32767      GO TO 32IC-----Process input constraint (pass along sequence constraint unaltered) 31   KVAR = INCON(1,K)      KMIN = INCON(2,K)      KMAX = INCON(3,K)"      IF (KVAR.GT.1000) GO TO 368 2C-----Search icol, add if not there.  get pointer. 32   KPTR = XXCPTR(KVAR)      IF (KPTR.GT.0) GO TO 35      IR = -KPTR      GO TO 36 35   IF (KVAR.GT.0) GO TO 37C-----Function or difference       CALL XXFSET(-KVAR,KPTR,IR)      IF (IR.NE.0) GO TO 36      CALL XXAPTR(NFUN,IR)      IF (IR.EQ.0) GO TO 37$C-----Error, start constraints over. 36   WRITE (IOUT,936) IR2 936  FORMAT (' CONSTRAINT SETUP ERROR, CODE ',I2)      GO TO 72 368  KPTR=KVAR(C-----Create permanent constraint entry. 37   NCON=NCON+1       IF(NCON.EQ.1)THEN 	DO  IK=1,NCOL	  KCOL = ICOL(IK)2	  CALL XGVDEF(2,MIDUM,KCOL,KDEF(7,IK),KDEF(8,IK),0     6    KDEF(1,IK),KDEF(4,IK),%REF(LABEL),FMT)	  KSCALE(IK) = KDEF(8,IK)	ENDDO      ENDIF        IDCON(1,NCON)=KVAR        IDCON(2,NCON)=KMIN        IDCON(3,NCON)=KMAX        IDCON(4,NCON)=KPTR
        K=K+1D	TYPE*, KVAR,KMIN,KMAX,KPTR      IF (K.LE.NCONSV) GO TO 31 C-----All constraints processed.
 70   IR=0      RETURN
 71   IR=6      RETURN
 72   IR=7      RETURN,C-----Forget it, go back for new data range.
 75   IR=1      RETURN	      END&      SUBROUTINE XXFSET (KFUN,KPTR,IR)GC_TITLE  XXFSET Set up user function or difference entry in IFUN array.C_ARGUMENTSA	INTEGER KFUN  ![I] Magnitude of input variable or constraint ID.?	INTEGER KPTR  ![I] Points to ICOL entry of column or function.(	INTEGER IR    ![O] Returns status code.C                  IR = 0 OK,-C                       2 Undefined function,-C                       4 Too many functions,-C                       5 User chickened out.BC_DESCRIPTION  The subroutine XXFSET sets up a user function or a (C difference entry in  the IFUN array.  C_CALLS  XXFARG  STINPUTC_HISTORY  85Feb11  HHKC_PAUSEC XXCOM.INC 84JUL23J      INCLUDE 'RAD$INC:XXGCOM.INC/LIST'	     !Contains database or program(!					     dependent variables, many are%!					     initialized by XGINIT.    0!	   				     Uses: MXNFUN. Modifies: IFUN, NFUNI      INCLUDE 'RAD$INC:XXCOM.INC/LIST'	     !Contains database dependent #!					     variables.  Uses: IOUT. !					     Modifies: none.      INTEGER*2 IFN(10)"      IF (NFUN.GE.MXNFUN) GO TO 74      NFUN=NFUN+1      IF (KFUN.GE.200) THEN        IFUN(2,NFUN) = 0        IFUN(3,NFUN) = KFUN/100,        IFUN(4,NFUN) = KFUN-100*IFUN(3,NFUN)        IFUN(5,NFUN) = 0N!----Fetch function defining integer, **NOTE** This is only a stub, if a user H!    by accident should enter principal variables of the form 10 * (userJ!    defined parameter, identified by a unique integer) then the parameter8!    may require additional parameter input (done here).H!    This user defined function is hard coded into XXFVAL.  This sectionA!    will probably be scrapped sometime in the future for an more!    easily implemented system.$      ELSE IF(KFUN.GE.100)THEN              KFUN = KFUN - 100	CALL STINPUT(4)   	DO K=3,12         	   IFUN(K+2,NFUN) = IFN(K)   	ENDDO			           ENDIF               C-----Difference.P      IF(KFUN .LT. 200)THEN               !Fetch the arguments for the function.)        CALL XXFARG(KFUN,IFUN(3,NFUN),IR)	IF(IR.NE.0)GOTO 72        IFUN(2,NFUN)=KFUN      ENDIF 40   CONTINUE      IFUN(1,NFUN) = KPTR 70   IR = 0      RETURN
C-----errors.
 72   IR=2      GO TO 79
 74   IR=4      GO TO 79
 75   IR=5      GO TO 79 78   IR=-IPTR 79   NFUN=NFUN-1      RETURN	      END!      SUBROUTINE XXAPTR (KFUN,IR)FC_TITLE  XXAPTR  Process function argument columns for the IFUN entry.C_ARGUMENTS)	INTEGER KFUN   ![I] Index to IFUN array.(	INTEGER IR     ![O] Return status code.DC_DESCRIPTION  The subroutine XXAPTR will process function argument 6C columns for the IFUN entry, add to  ICOL if they are-C not found, and replace IFUN with pointers. ,C_CALLS  XXCPTRtC_HISTORY  85Feb11  HHKUC_PAUSEJ      INCLUDE 'RAD$INC:XXGCOM.INC/LIST'      !Contains database or program(!					     dependent variables, many are!!					     initialized by XGINIT. *!     Uses: MXNARG, IFUN.  Modifies: none.      INTEGER XXCPTR      DO 45 I=1, MXNARGs        IARG=IFUN(I+2,KFUN)         IPTR=XXCPTR(IARG)         IF (IPTR) 71,70,42 42     IFUN(I+2,KFUN)=IPTR  45   CONTINUE
 70   IR=0      RETURN 71   IR=-IPTR      RETURN	      END $      INTEGER FUNCTION XXCPTR (KCOL)ICC_TITLE  XXCPTR  Integer function XXCPTR will find a column ID number in FC the ICOL array, and add it to ICOL if it is not found.  ICOL is usedHC by the system to store the column pointers for the requested database C variables, and constraints.tCC_ARGUMENTSBC      INTEGER KCOL    ![I] Column on which to find the column ID.MCC_DESCRIPTION  The integer function XXCPTR will find a column identificationGC number in the ICOL array, and will add it if not found.  The function2C value is a pointer to a position in the array.  CC_HISTORY  85Feb11  HHKKCC_MESSAGES  Error code: 0 zero col, -1 undefined col, -3 too many columns.CC_VARIABLESJ      INCLUDE 'RAD$INC:XXGCOM.INC/LIST'      !Contains database or program(!					     dependent variables, many are!!					     initialized by XGINIT.-!     					Uses:  MAXCOL. Modifies: ICOL,NCOLCC_END				      IF (KCOL.EQ.0) GO TO 70"      IF (KCOL.GT.MAXCOL) GO TO 71!-----Search loop.      DO 5 I=1,NCOL%        IF (KCOL.EQ.ICOL(I)) GO TO 10 5    CONTINUE	         .!-----End search loop - not found, add column."      IF (NCOl.GE.MXNCOL) GO TO 73      NCOL=NCOL+1      ICOL(NCOL)=KCOL      XXCPTR=NCOL      RETURN!-----FOUND 10   XXCPTR=I      RETURN 70   XXCPTR=0      RETURN 71   XXCPTR=-1      RETURN 73   XXCPTR=-3      RETURN	      END