	PROGRAM XBIN 		:C_Title  XBIN  Dummy main routine for the binning utility.C_History  R.Mehlman  UCLAIC_DESCription  This dummy main routine initializes the XG system for thisC particular application.*C dimensions for the appropriate database.C_PauseA	PARAMETER (ID1= 20)	!Set to max number of columns to be allowed.=	PARAMETER (ID2= 600)	!This must be 240:480:600 for IR:MW:MI.6	PARAMETER (ID3= 20)	!Number of time ranges in a list.$	INTEGER*2 IA(120, ID1), INDEX( ID2)	EXTERNAL BINUSE	CHARACTER*16 PN3	DATA PN /'XBIN:88MAY20'/	!Latest modification date	INDEX(1)=1	INDEX(2)=2	INDEX(3)=36	MXNVAR = 3	!Set to max number of principal variables.8	CALL XGDATA (IA,ID1, INDEX,ID2, ID3, MXNVAR, PN,BINUSE)	STOP	END$	SUBROUTINE BINUSE (IQ,IA,NLINES,IR)GC_Title  BINUSE  Generalized database binning routine called by  XGDATAC_Arguments*	INTEGER IQ		![I] Determines program flow.D	INTEGER*2 IA(NLINES,*)  ![I] Contains requested database variables.9		                ![I] NLINES = number of lines per page.&	INTEGER IR		![O] Returns status code.C_VARIABLESK        INCLUDE 'RAD$INC:XXSCOM.INC'         !Uses: MTITLE. Modifies: None.F        INCLUDE 'RAD$INC:XXCOM.INC'          !Uses: ILIST,IOUT,J1,J2. =                                             !Modifies: None.	INCLUDE 'RAD$INC:XXDCOM.INC'C						Uses: KDEF, KSCALE. C					        Modifies: None.8	COMMON /XXGCOM/ IXXG1(11),NCOL,NVAR,NCON,NFUN,IXXG16(2)6     1 ,KSN(7),NSPI,INT,LUMPSQ,ICHANGE,IUNIT,IXXG25(6)H     2 ,LKOUT,LFMT,LPROJ,LSKIP,LBORDR,LBLANK,LEXCL,LZSCAL,LZCON,LZMOD	  9     3 ,MINX,MAXX,NX,LPERX,NULLX,MINY,MAXY,NY,LPERY,NULLY/     4 ,IXXG51(10),ICOL, ICON  ,IFUN  ,TITLE(5)FC USES COMMON XXGCOM to pass application routine variables from BININP>C to this routine which controls the binning of all variables.PC_DESCription  The subroutine  BINUSE performs binning of data into discrete twoKC dimensional areas.  Bin shall display data in one of three projections.  PC (Mercator, Polar, or no projection).  Printer plots will be produced which canMC be displayed on any ascii terminal.  Options to control the plotting of theFC data (density plots, dots, blanks, or none) shall be made available.
C  XGDATA.;C_Calls  A2AN  FILL  DATIME  GPAR  GETNI  GETNA  VMS:ERRSET-C  GETCOR  FRECOR( dynamic memory allocation)AC  BINP2(LIMIT2)  LDENS  BPROJ which require some  I*2 arguments.	C  BININPC_Hist	7x  Hugh_H_Kieffer  UCLAC	1978.  R.Mehlman  UCLA,C	87oct19  HHK and  R.Gurule  USGS_FlagstaffC_End	CHARACTER*5 SYM	CHARACTER*6 FMT	LOGICAL LGSEQ,LINIT%	REAL DEF(60),BTITLE(5,2), ATITLE(10)%	REAL BTYPE /4HBIN / , CTYPE /4HCNT /A        INTEGER*2 DESC(16),ICOL(30),ICON(4,10),IFUN(12,5),UNIT(3)5	INTEGER*2 INVAR(3,10),LUNDB,NAMEDB(3),LABEL(3)      /	INTEGER*2 IREF(1),IDEF(120),NAMEF(3),MBIN(5,2)%     2 ,INSUP(10),LFMT2,LEXCL2,KPTIME$	INTEGER*2 KHIST(3) /2H H,2HIS,2HT /(	INTEGER*4 LPARM(10),IRANGE(6),JFCB(256)"	INTEGER*4 NPBIND,IDEF19,KBIN(5,2)*	EQUIVALENCE (DEF,IDEF), (ATITLE,IDEF(91))#     1 ,(LPARM,LKOUT),(IRANGE,IDDB)=     2 ,(NPBIND,INSUP(9)),(IDEF19,IDEF(19)),(BTITLE,IDEF(61))2	EQUIVALENCE (KPTIME,ICON(4,1)),(IXXG16(1),IFGSET);	CHARACTER*1 XYZ(3)/'X','Y','Z'/		       !Axis identifiers.	CHARACTER*6 AKOUN,ABUNI,FNAME	CHARACTER*22 DUM	CHARACTER*32 CPERBINB	CHARACTER*80 STRING /'X,Y for histogram, XYZ for averages also.'/	DATA LCORE /0/$	DATA AKOUN,ABUNI/'NPTS  ','     1'/2	DATA CPERBIN/'Number of points per bin         '/	IR=0	GO TO (100,200,300,400,500),IQ-C_______Fetch the input parameters from  TAE.100	CONTINUE	LINIT=.FALSE.	IFGSET = 1	RETURN0C       Return: code 0 if normal, code 1 to quit C-------Sequence initialization..200	CALL BIN_INP(BTITLE,LPARM,ATITLE,NAMEF,ID)	WRITE(DUM,201)NAMEF201     FORMAT(3A2)	READ(DUM,202)FNAME202     FORMAT(A6)	TYPE*, ' FILE = FNAME',FNAME        IF (LINIT) GOTO 220	IF (NVAR.LT.2) THEN:	  WRITE(IOUT,'(A)') ' Require 2 or 3 principal variables'	  GOTO 295	ENDIF
	LINIT=.TRUE.
	IXPTR=NCOL+1
	IYPTR=NCOL+2
	IZPTR=NCOL+3122	LFMT2=IABS(LFMT)	IF (LFMT2.EQ.0) LFMT2=6C____ Dynamic core allocation.
	NXY=NX*NY#	IF (LBORDR.NE.0) NXY=(NX+2)*(NY+2)	IB23=2
	NCORE=NXY	KXY=0!-------Need room for 3 arrays.	IF (NVAR.GE.3) THEN     		  IB23=3	  NCORE=3*NXY
	  KXY=NXY	ENDIF	IF (NCORE.LE.LCORE) GO TO 130.	IF (LCORE.GT.0) CALL FRECOR(NCORE,IREF,KREF1)	CALL GETCOR(NCORE,IREF,KREF1)	IF (KREF1.NE.0) GO TO 125	WRITE (*,9125)? 9125 FORMAT (' NOT ENOUGH MEMORY--REVISE X,Y AXIS PARAMETERS')
	GO TO 294 125    KREF2=KREF1+KXY	LCORE=NCORE(C------- Request bin or histogram title.	G130	IF (ATITLE(1).EQ.0) THEN            !Is this right to check ATITLE?5	    CALL A2AN (KDEF(1,3),ATITLE,3)  !default titles.!	    CALL FILL (IDEF(94),7, 2H  )0	    IF (NVAR.LE.2) CALL A2AN (KHIST,IDEF(97),3)	    END IF132	CONTINUE	CALL L2L (MINX,KBIN(1,1),10),140	DO K=1,2			!Unscale min and max x and y.
	    DO I=1,2-		KBIN(I+3,K)=KBIN(I,K)*(KDEF(7,I)/KDEF(8,I))		ENDDO+	    DO I=1,5			!Transfer to bin arguments.		MBIN(I,K) = KBIN (I,K)		ENDDO
	    ENDDONC turn off output conversion error messages (print in small bins may overflow)	CALL ERRSET (63,,,,.FALSE.,)                          3C Insert code to be done at start of each sequence.8C sequences lumped together and not first good sequence?*220	IF (LUMPSQ.NE.0 .AND. LINIT) GO TO 299 	CALL A2AN (MTITLE,IDEF(101),20)#C-------Initialize binning routine.'	CALL BINP2(1,MBIN(1,1),MBIN(1,2),ILIST'     1 ,IREF(KREF1),IREF(KREF2),LBORDR)	LINIT = .TRUE.		GOTO 299 294	WRITE(IOUT,*)' ERROR IN BIN'	295	IR=6	
299	RETURN$C------- Data processing of one row.300	CONTINUE	K=0&C-------Loop on points (lines) in row. 	DO 350 J=J1,J27C_______Insert code for each point passing constraints.7C       Point to be skipped if time variable .LT. zero.#	 IF (IA(J,KPTIME).LT.0) GO TO 350		 	  K=K+1	  IA(K,IXPTR)=IA(J,1)	  IA(K,IYPTR)=IA(J,2)	  IA(K,IZPTR)=IA(J,3)350	CONTINUEC------ End point (line) loop.C       Map projections.4	IF (LPROJ.NE.0) CALL BPROJ (IA(1,IXPTR),IA(1,IYPTR)(     & ,IA(1,IXPTR),IA(1,IYPTR),LPROJ,K)&C       Bin and/or count these points.3	ICFLG = 0			!ICFLG = FLAG USED TO PLACE LABELS NOT-	IF(IB23.EQ.3)ICFLG = 1		!DERIVED FROM XGVDEF	4	CALL BINP2(IB23,IA(1,IXPTR),IA(1,IYPTR),IA(1,IZPTR)"     1 ,IREF(KREF1),IREF(KREF2),K)	RETURN#C-------End-of-sequence processing.400	CONTINUE $!-------Insert end of sequence code.M	IF (LUMPSQ.EQ.0) GO TO 510    !if sequences not lumped together, process now	RETURNC-----final processing500	CONTINUE	IF (LUMPSQ.EQ.0) GO TO 570510	CONTINUE5C-----set up for bin display, get default title, etc.
	LEXCL2=LEXCL		DO I=1,5	 INSUP(I)=LPARM(I+5)	ENDDOMC-----print count array if histogram, or if count print out requested on bin.4520	IF (LFMT.LT.0.OR.(NVAR.EQ.2.AND.LFMT.NE.0)) THENA	CALL BINP2(5,IA(1,IXPTR),INSUP,IREF(KREF1),IDEF(91),LFMT2,LSKIP)3	JCOUNT = 4	! set up writing of titles for  Z=COUNT;C+++++++ reusable section for writing plot titles++++++++++HC Translate the variable identification integer into a character symbol,7C extracting storage and print units at the same time. 522     DO J=1,3	           I = ICOL(J)	  IF (J.EQ.JCOUNT-1) I = -10	6	  CALL XGVDEF (2, SYM,I, ISS,IPS,LABEL,UNIT,DESC,FMT)	  I = IPS		        !	  IF (IUNIT.NE.0) I=ISS	        G!-------Patch to create labels for the z-axis when binning or counting.	 IF(ICFLG.EQ.1.AND.J.EQ.3)THEN	  SYM(1:5)= 'CNT  '!	  CALL L2L(%REF(CPERBIN),DESC,8) 	  CALL B2B(%REF(AKOUN),LABEL,6)	  CALL B2B(%REF(ABUNI),UNIT,6)	  ICFLG = 0	 ENDIF1	  WRITE (ILIST,523) XYZ(J),SYM,LABEL,DESC,UNIT,I	ENDDO6523  	FORMAT (X,A1,'-axis = ',A5,' = ',3A2,' = ',16A2,!     &'  UNITs are ',3A2,' *',I6).C    Transfer out, I got here from "averages".	IF (JCOUNT.EQ.0) GOTO 530  .C+++++++++++ end of title section ++++++++++++	ENDIF	IF (NVAR.LE.2) GO TO 530C-----Form averages.,	IF (LZSCAL.EQ.0) LZSCAL=KDEF(7,I)/KDEF(8,I)	IF (LZSCAL.LT.0) LZSCAL=1:	CALL BINP2(4,I,LEXCL2,IREF(KREF2),IREF(KREF1),IREF(KREF2)     1	   ,LZSCAL)C-----Print bin array.	IF (LFMT.NE.0) THEN.	  CALL BINP2(5,IA(1,IXPTR),INSUP,IREF(KREF2)		1 ,IDEF(91),LFMT2,LSKIP)C-----Set up for Z = Averages.	  JCOUNT = 0		  GOTO 522	ENDIF530	IF (LKOUT.EQ.0) GO TO 570'C  Array output.  0 points Binned test.	IF (NPBIND .LE. 0) GO TO 570  BC  Output to array file, If bordered bins, compress to unbordered.?	IF(LBORDR .NE. 0)CALL BINP2(6,IREF(KREF2),IREF(KREF2),I,I,I,I)9C  Set up array header, placing NX, NY, NBANDS into IDEF.	CALL FILL(IDEF,60,0)
	IDEF(1) = NX
	IDEF(2) = NY	IDEF(3) = LKOUT3	IDEF(6) = 11            !Output lun for cube file.	IDEF(7) = ILIST-C  Do we need to worry about exclusion value?C  STOSCL = Storage scale.BC  DEF(6 & 7) = Minumum x in physical value, and delta x bin size.CC  DEF(8 & 9) = Minimum y in physical value, and delta y bin size. C  LEXCL = Exclusion value."C  LKOUT = Number of arrays out.  	IDEF(5) = LEXCL		DO I=1,2	  STOSCL = KDEF(7,I)	  XYMIN = MBIN(4,I)	  DEF(4+2*I) = XYMIN / STOSCL8	  DEF(5+2*I) = (MBIN(5,I) - XYMIN) / (STOSCL*MBIN(3,I))	ENDDO	IDEF19 = NPBINDGC  Keep input user ranges, Spacecraft, Orbit range, sequence range, andC  time ranges.		DO I=1,6	  IDEF(20+I) = IRANGE(I)	ENDDO
             C  Keep input Spot ranges.	DO I=1,4                	  IDEF(33+I) = KSN(I)	ENDDO%C  Place date and time into IDEF(81).	CALL DATIME(IDEF(81))'	IF (NVAR.LE.2.OR.LKOUT.EQ.2) GO TO 5501C-------Write bin array to file. Z scaling units.1C       IDEF(40) = number of planes in this cube.'C       DEF(5) = z axis scaling factor.	DEF(5) = KDEF(7,3) / LZSCAL	ID=1
             C***  INITIALIZE THE CUBE!!!.        CALL CUBEOUT(-1,JFCB,FNAME, IDEF,IRET)C  Jump on error (IRET NE 0).	IF (IRET .NE .0) GO TO 700(	WRITE (IOUT,9550) BTYPE,ID,NAMEF,ATITLE<	IF (ILIST.NE.IOUT) WRITE (ILIST,9550) BTYPE,ID,NAMEF,ATITLEE 9550   FORMAT (1X,A4,'ARRAY, ID',I4,' WRITTEN TO FILE ',3A2,5X,10A4)/ 550    IF (NVAR.GT.2.AND.LKOUT.LE.1) GO TO 570"C-------Write count array to file.'C       DEF(5) = Z Axis scaling factor.
	DEF(5)=1.	IDEF(40)=2	ID=2&	IF (IDA.GT.0.AND.LKOUT.EQ.3) ID=IDA+1-	CALL CUBEOUT(1,IDEF,NAMEF, IREF(KREF1),IRET)	IF (IR.NE.0) GO TO 700(	WRITE (IOUT,9550) CTYPE,ID,NAMEF,ATITLE<	IF (ILIST.NE.IOUT) WRITE (ILIST,9550) CTYPE,ID,NAMEF,ATITLEC-----Bin output complete.570    CONTINUE
       RETURNC_____ Errors.#700	WRITE (IOUT,9700) IRET,ID,IWORKC9700	FORMAT (' GPAR OUTPUT ERROR, CODE',I6,'  ARRAY',I4,'  ROW',I4)	IR=6	RETURN	END