C This is Pawn.for to be used with Pawn.Kumac to make some operations
C  easier in PAW. It was put together by Gerry Lynch in June 1995. 
C The controling routine PAWN is at the end.

C
C   AVX  ***************************************************
C
      Subroutine AVX(ID2,FITERR)
*----------------------------------------------------------------------
*-
*-   Purpose and Methods : Simulates the DISPLAY function AVX, more or less...
*-
*-   Returned value  : 
*-   Inputs  : id2 = id of existing 2D histogram 
*-   Controls: fiterr = 0 --> use HBOOK errors (e.g. sqrt(N)) in gaussian fit
*-             fiterr = 1 --> use equal errors in fit (de-emphasize tails)
*-
*-   Created  17-AUG-1993   Ed Oltman
*-
      INTEGER ID2,IDA,IDS,FITERR
      INTEGER   NX,NY,N1,N2,IDW,IX,IY,DOF,WT
      REAL      AY(1000),AV(1000),AVE(1000),SD(1000),SDE(1000),AYE(1000)
      REAL      XMI,XMA,YMI,YMA,SIG(3),C,A,S,SUM,CHI2
      CHARACTER*80 TITL,titl1
      REAL      HIJ
      LOGICAL   HEXIST
*----------------------------------------------------------------------
      IF (.NOT. HEXIST(ID2)) THEN
          CALL HRIN(ID2,0,0)
      ENDIF
      CALL HGIVE(ID2,TITL,NX,XMI,XMA,NY,YMI,YMA,N1,N2)
      IF(NX.LE.0) GO TO 999
      IF(NY.LE.0) THEN
         WRITE(*,*) ' AVX needs a 2-D Histogram'
         GO to 999
      End If
      IF (NX .GT. 1000 .OR. NY .GT. 1000) THEN
        WRITE(*,*) ' AVX: HISTOS TOO BIG: MAX = ',1000
        WRITE(*,*) '      NX,NY = ',NX,NY
        goto 999
      ENDIF
      IDA = ID2 + 10000
 10   IF (HEXIST(IDA)) Then
        IDA = IDA + 1
	Go To 10
      End If
      Ids = Ida+1           
 20       IF (HEXIST(IDS)) Then
          Ids = Ids + 1
          GO to 20
      End If
      Write(6,*) '    AVX in histogram',Ida
      Write(6,*) '    SGX in histogram',Ids
      titl1 = 'AVX '//titl(1:74)
      CALL HBOOK1(IDA,titl1,NX,XMI,XMA,0)
      titl1 = 'SGX '//titl(1:74)
      CALL HBOOK1(IDS,titl1,NX,XMI,XMA,0)
    1 IDW = 12321
      IF(HEXIST(IDW)) THEN
        IDW = IDW + 1
        GO TO 1
      ENDIF
      CALL HBOOK1(IDW,'I WORK FOR AVX$',NY,YMI,YMA,0)
      WT = 2
      IF (FITERR .NE. 0) WT = 101
      Write(6,*) '    SGX FITERR, WT =',FITERR,WT
      CALL VZERO(AV ,NX)
      CALL VZERO(AVE,NX)
      CALL VZERO(SD ,NX)
      CALL VZERO(SDE,NX)
      DO IX = 1,NX
        SUM = 0.
        DOF = -3
        DO IY = 1,NY
          AY(IY) = HIJ(ID2,IX,IY)
          AYE(IY) = SQRT(AY(IY))
          IF(AYE(IY) .EQ. 0 ) AYE(IY) = 1.
          SUM = SUM + AY(IY)
          IF (AY(IY) .GT. 0) DOF = DOF + 1
        ENDDO
        IF (SUM .GT. 9.) THEN
          CALL HPAK  (IDW,AY)
          CALL HPAKE (IDW,AYE)
          CALL VZERO(SIG,3)
          CALL HFITGA(IDW,C,A,S,CHI2,WT,SIG)
          AV (IX) = A
          AVE(IX) = SIG(2)
          SD (IX) = S
          SDE(IX) = SIG(3)
        ENDIF
      ENDDO
      CALL HDELET(IDW)
      CALL HPAK (IDA,AV )    
      CALL HPAKE(IDA,AVE)
      CALL HPAK (IDS,SD )
      CALL HPAKE(IDS,SDE)
  999 RETURN
      END
C
C   AVY  ***************************************************
C
      Subroutine AVY(ID2,FITERR)
*----------------------------------------------------------------------
*-
*-   Purpose and Methods : Simulates the DISPLAY function AVX, more or less...
*-
*-   Returned value  : 
*-   Inputs  : id2 = id of existing 2D histogram 
*-   Controls: fiterr = 0 --> use HBOOK errors (e.g. sqrt(N)) in gaussian fit
*-             fiterr = 1 --> use equal errors in fit (de-emphasize tails)
*-
*-   Created  21-june-1995 bu Gerry Lynch by modifying  Ed Oltman's AVX
*-
      INTEGER ID2,IDA,IDS,FITERR
      INTEGER   NX,NY,N1,N2,IDW,IX,IY,DOF,WT
      REAL      AX(1000),AV(1000),AVE(1000),SD(1000),SDE(1000)
      REAL      XMI,XMA,YMI,YMA,SIG(3),C,A,S,SUM,CHI2
      CHARACTER*80 TITL,titl1
      REAL      HIJ
      LOGICAL   HEXIST
*----------------------------------------------------------------------
      IF (.NOT. HEXIST(ID2)) THEN
          CALL HRIN(ID2,0,0)
      ENDIF
      CALL HGIVE(ID2,TITL,NX,XMI,XMA,NY,YMI,YMA,N1,N2)
      IF(NX.LE.0) GO TO 999
      IF(NY.LE.0) THEN
         WRITE(*,*) ' AVY needs a 2-D Histogram'
         GO to 999
      End If
      IF (NX .GT. 1000 .OR. NY .GT. 1000) THEN
        WRITE(*,*) ' AVY: HISTOS TOO BIG: MAX = ',1000
        WRITE(*,*) '      NX,NY = ',NX,NY
        goto 999
      ENDIF
      IDA = ID2 + 10000
 10   IF (HEXIST(IDA)) Then
        IDA = IDA + 1
	Go To 10
      End If
      Ids = Ida+1           
 20       IF (HEXIST(IDS)) Then
          Ids = Ids + 1
          GO to 20
      End If
      Write(6,*) '    AVY in histogram',Ida
      Write(6,*) '    SGY in histogram',Ids
      titl1 = 'AVY '//titl(1:74)
      CALL HBOOK1(IDA,titl1,NY,YMI,YMA,0)
      titl1 = 'SGY '//titl(1:74)
      CALL HBOOK1(IDS,titl1,NY,YMI,YMA,0)
    1 IDW = 12321
      IF(HEXIST(IDW)) THEN
        IDW = IDW + 1
        GO TO 1
      ENDIF
      CALL HBOOK1(IDW,'I WORK FOR REGY$',NX,XMI,XMA,0)
      WT = 2
      IF (FITERR .NE. 0) WT = 101
      CALL VZERO(AV ,NY)
      CALL VZERO(AVE,NY)
      CALL VZERO(SD ,NY)
      CALL VZERO(SDE,NY)
      DO IY = 1,NY
        SUM = 0.
        DOF = -3
        DO IX = 1,NX
          AX(IX) = HIJ(ID2,IX,IY)
          SUM = SUM + AX(IX)
          IF (AX(IX) .GT. 0) DOF = DOF + 1
        ENDDO
        IF (SUM .GT. 9.) THEN
          CALL HPAK  (IDW,AX)
          CALL VZERO(SIG,3)
          CALL HFITGA(IDW,C,A,S,CHI2,WT,SIG)
          AV (IY) = A
          AVE(IY) = SIG(2)
          SD (IY) = S
          SDE(IY) = SIG(3)
        ENDIF
      ENDDO
      CALL HDELET(IDW)
      CALL HPAK (IDA,AV )    
      CALL HPAKE(IDA,AVE)
      CALL HPAK (IDS,SD )
      CALL HPAKE(IDS,SDE)
  999 RETURN
      END
C
C  BLOW **************************************************
C
	SUBROUTINE BLOW(IWHICH,XXMIN,XXMAX)
	REAL Y(1000), DY(1000)
	CHARACTER*72 TIT
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF
C
C  CALL HGIVE, CHECK LIMITS
C
	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        If(NX.LE.0) RETURN
	IF (NY .NE. 0) THEN
	   PRINT *,'USE BLO2 FOR 2-DIM HISTOGRAM'
	   RETURN
	END IF
	IF (XXMAX .LT. XXMIN) THEN
	   PRINT *,'ILLEGAL LIMITS'
	   RETURN
	END IF
	IF (XXMIN .GT. XMA .OR. XXMAX .LT. XMI) THEN
	   PRINT *,'ILLEGAL LIMITS'
	   RETURN
	END IF
C
C GET NEW TITLE, NEW ID
C
	DO I=67,1,-1
	      K = I+5
	      TIT(K:K) = TIT(I:I)
	END DO
	TIT(1:5) = 'BLO  '
        NEWID = IWHICH + 10000
21      IF(HEXIST(NEWID)) THEN
            NEWID = NEWID + 1
            GO TO 21
        END IF
	PRINT *,'NEW HISTOGRAM ID ',NEWID
C
C NOW DO THE BLO
C
	XBIN = (XMA-XMI)/FLOAT(NX)
	DO I=1,NX+1
	   XLOW = XMI + XBIN*(I-1)
	   IF (XLOW .GT. XXMIN) THEN
	      I1 = I-1
	      IF (I1 .EQ. 0) I1=1
	      GOTO 502
	   END IF
	END DO
502	I2 = NX
	DO I=1,NX
	   XLOW = XMI + XBIN*(I-1)
	   IF ((XLOW+0.001*XBIN) .GT. XXMAX) THEN
	      I2 = I-1
	      IF (I2 .EQ. 0) I2=1
	      GOTO 503
	   END IF
	END DO
503	NNX = I2-I1+1
	X1 = XMI + (I1-1)*XBIN
	X2 = X1 + NNX*XBIN
	   CALL HBOOK1(NEWID,TIT,NNX,X1,X2,0)
	   Ipake=0
	   DO J=1,NNX
	      I = J+I1-1
	      Y(J) = HI(IWHICH,I)
	      DY(J) = HIE(IWHICH,I)
C   This is a crude test see if the errors are Sqrt(N)
	      If(Y(J).Ne.0) Then
		Test = DY(J)**2/Y(J) -1.
		If(Abs(Test).Gt.0.01) Ipake=1
	      End If
	   END DO
	   CALL HPAK(NEWID,Y)
	   If(Ipake.Eq.1) CALL HPAKE(NEWID,DY)
	RETURN
        
	END
C
C   BLO2  ****************************************************
C
	SUBROUTINE BLO2(IWHICH,XXMIN,XXMAX,YYMIN,YYMAX)
	REAL Z(200000)
	CHARACTER*72 TIT
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF

	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        If(NX.LE.0) RETURN
	IF (NY .EQ. 0) THEN
	   PRINT *,' USE BLO FOR 1-DIM HISTOGRAM'
	   RETURN
	END IF
	IF (XXMAX .LT. XXMIN .OR. YYMAX .LT. YYMIN) THEN
	   PRINT *,' ILLEGAL LIMITS'
	   RETURN
	END IF
	IF (XXMIN .GT. XMA .OR. XXMAX .LT. XMI) THEN
	   PRINT *,' ILLEGAL X LIMITS'
	   RETURN
	END IF
	   IF (YYMIN .GT. YMA .OR. YYMAX .LT. YMI) THEN
	      PRINT *,' ILLEGAL Y LIMITS'
	      RETURN
	   END IF
C
C GET NEW TITLE, NEW ID
C
	DO I=67,1,-1
	      K = I+5
	      TIT(K:K) = TIT(I:I)
	END DO
	TIT(1:5) = 'BLO  '
	NEWID = IWHICH + 10000
21      IF(HEXIST(NEWID)) THEN
            NEWID = NEWID + 1
            GO TO 21
        END IF
	PRINT *,' NEW HISTOGRAM ID ',NEWID
C
C NOW DO THE BLO
C
	XBIN = (XMA-XMI)/FLOAT(NX)
	DO I=1,NX+1
	   XLOW = XMI + XBIN*(I-1)
	   IF (XLOW .GT. XXMIN) THEN
	      I1 = I-1
	      IF (I1 .EQ. 0) I1=1
	      GOTO 502
	   END IF
	END DO
502	I2 = NX
	DO I=1,NX
	   XLOW = XMI + XBIN*(I-1)
	   IF ((XLOW+0.001*XBIN) .GT. XXMAX) THEN
	      I2 = I-1
	      IF (I2 .EQ. 0) I2=1
	      GOTO 503
	   END IF
	END DO
503	NNX = I2-I1+1
	X1 = XMI + (I1-1)*XBIN
	X2 = X1 + NNX*XBIN
	   YBIN = (YMA-YMI)/FLOAT(NY)
	   DO J=1,NY+1
	      YLOW = YMI + YBIN*(J-1)
	      IF (YLOW .GT. YYMIN) THEN
	         J1 = J-1
	         IF (J1 .EQ. 0) J1=1
	         GOTO 512
	      END IF
	   END DO
512	   J2 = NY
	   DO J=1,NY
	      YLOW = YMI + YBIN*(J-1)
	      IF ((YLOW+0.001*YBIN) .GT. YYMAX) THEN
	         J2 = J-1
	         IF (J2 .EQ. 0) J2=1
	         GOTO 513
	      END IF
	   END DO
513	   NNY = J2-J1+1
	   Y1 = YMI + (J1-1)*YBIN
	   Y2 = Y1 + NNY*YBIN
	   CALL HBOOK2(NEWID,TIT,NNX,X1,X2,NNY,Y1,Y2,0.)
	   DO II=1,NNX
	      I = II+I1-1
	      Do JJ=1,NNY
                 J = JJ+J1-1   
                 K = II + NNX*(JJ-1)
	         Z(K) = HIJ(IWHICH,I,J)
              END DO
	   END DO
	   CALL HPAK(NEWID,Z)

	RETURN
	END
C
C    CHBN *****************************************************
C
	SUBROUTINE CHBN(IWHICH,FX)
	REAL Y(1000), DYS(1000), DY(1000),  SW(1000), SYW(1000)
	INTEGER FX,IWHICH
	CHARACTER*72 TIT
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF
C
C  CALL HGIVE, GET NEW ID 
C
	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        If(NX.LE.0) RETURN
	IF (NY .NE. 0) THEN
	   PRINT *,'USE CHBN2 FOR 2 DIMENSIONAL HISTOGRAM'
	   RETURN
	END IF
	DO I=67,1,-1
	      K = I+5
	      TIT(K:K) = TIT(I:I)
	END DO
	TIT(1:5) = 'CHBN '
	NEWID = IWHICH + 10000
21      IF(HEXIST(NEWID)) THEN
            NEWID = NEWID + 1
            GO TO 21
        END IF
	PRINT *,'NEW HISTOGRAM ID ',NEWID
C
C CHANGE BIN SIZE OF IWHICH, FACTOR IFX-IFY
C
	NEWNX = NX/FX
	NEWNX = MAX(NEWNX,1)
	CALL HBOOK1(NEWID,TIT,NEWNX,XMI,XMA,0.)
	   Ipake=0
	   DO J=1,Newnx
	      Y(J)=0.
              Syw(J) = 0.
              Sw(J) = 0.
	      Dys(J) = 0.
              Do K=1,Fx
                 I = K + (J-1)*Fx
                 YI = HI(IWHICH,I)
                 Y(J) = Y(J) + YI
                 DYSI =  HIE(Iwhich,I)**2
                 Dys(J) = Dys(J) + DYSI
                 If(DysI.Ne.0) Then
                    Syw(J) = Syw(J) + YI/DysI
		    Sw(J)  = Sw(J) + 1.0/DysI
                 End If
              End Do
C   This is a crude test see if the errors are Sqrt(N)
	      If(Y(J).Ne.0) Then
		Test = DYS(J)/Y(J) -1.
		If(Abs(Test).Gt.0.01) Ipake=1
	      End If
	   END DO
           IF(Ipake.eq.1) Then
	     DO J=1,Newnx
               If(SW(J).GT.0) Then
                 Y(J) = SYW(J)/SW(J)
                 DY(J) = Sqrt(1.0/SW(J))
	       ELse
                 Y(J)=0
                 DY(J)=0
               END IF
             END DO
             CALL HPAKE(NEWID,DY)
           END IF   
	   CALL HPAK(NEWID,Y)
	RETURN
	END
C
C   CHBN2  ************************************************
C
	SUBROUTINE CHBN2(IWHICH,FX,FY)
	INTEGER FX,FY
	CHARACTER*72 TIT
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF
C
C  CALL HGIVE, GET NEW ID 
C
	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        If(NX.LE.0) RETURN
	IF (NY .EQ. 0) THEN
	   PRINT *,'USE CHBN FOR 1 DIMENSIONAL HISTOGRAM'
	END IF
	DO I=67,1,-1
	      K = I+5
	      TIT(K:K) = TIT(I:I)
	END DO
	TIT(1:5) = 'CHBN '
	NEWID = IWHICH + 10000
21      IF(HEXIST(NEWID)) THEN
            NEWID = NEWID + 1
            GO TO 21
        END IF
	PRINT *,'NEW HISTOGRAM ID ',NEWID
C
C CHANGE BIN SIZE OF IWHICH, FACTOR IFX-IFY
C
	NEWNX = NX/FX
	XBIN = (XMA-XMI)/FLOAT(NX)
	NEWNX = MAX(NEWNX,1)
	XMANEW = XMI + NEWNX*XBIN*FX
	NEWNY = NY/FY
	YBIN = (YMA-YMI)/FLOAT(NY)
	NEWNY = MAX(NEWNY,1)
	YMANEW = YMI + NEWNY*YBIN*FY
	CALL HBOOK2(NEWID,TIT,NEWNX,XMI,XMA,NEWNY,YMI,YMA,0.)
	DO I=1,NX
	      X = XMI + XBIN/2. + (I-1)*XBIN
	      DO J=1,NY
		 VARIAB = HIJ(IWHICH,I,J)
	         Y = YMI + YBIN/2  + (J-1)*YBIN
	         CALL HFILL(NEWID,X,Y,VARIAB)
	      END DO
	END DO
	RETURN
	END 

C
C   CHTI  ********************************************************
C

	SUBROUTINE CHTI(IWHICH)
	CHARACTER*72 TIT
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF
	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        If(NX.LE.0) RETURN
	PRINT *,'ENTER NEW TITLE'
	READ(5,1000)TIT
1000	FORMAT(A)
	NEWID = IWHICH + 10000
21      IF(HEXIST(NEWID)) THEN
            NEWID = NEWID + 1
            GO TO 21
        END IF
	CALL HCOPY(IWHICH,NEWID,TIT)
	CALL HDELET(IWHICH)
	CALL HCOPY(NEWID,IWHICH,TIT)
	CALL HDELET(NEWID)
	RETURN
	END
C
C*** MED  ****************************************************
C
	subroutine Med(ID1)
	integer id1,noent
	integer	nx,ny,nwt,loc
	real    xmi,xma,ymi,yma
	real	sum,sum2,cont2(0:1000)
	logical HEXIST
	character*80 chtitl
 	
        IF (.NOT. HEXIST(Id1)) THEN
            CALL HRIN(Id1,0,0)
        ENDIF

	call hgive(id1,chtitl,nx,xmi,xma,ny,ymi,yma,nwt,loc)
	if (nx .le. 0) return
	if (ny .gt. 0) return 
        PRINT *,' ',CHTITL

	call hnoent(id1,noent)
	if (noent .eq. 0) return
        print *,' Ids ',id1
	xbin = (xma-xmi)/nx	    

	sum = 0	
	do i = 1, nx
  print *, 'Sum hi=', Sum, hi(id1,i)
	    sum = sum + hi(id1,i)
	end do    

	sum2 = 0	
	Imed = 0
        Isigp = 0
        Isigm=0
	do i = 1, nx 
	    sum2 = sum2 + hi(id1,i)
	    cont2(i) = SUM2/sum
	    If (cont2(i) .ge. 0.5 .and. Imed .eq. 0) Then
		Imed = i
	    End If
	    If (cont2(i) .ge. 0.84 .and. Isigp .eq. 0) Then		
                Isigp = i
            End If
            If(cont2(i) .gt. 0.16 .and. Isigm .eq. 0) Then
                Isigm = i
	    End If                 
	end do

c Find the Median:
	Xmed = xmi + (Imed) * xbin 
     &     - (cont2(Imed)-0.5)/(cont2(Imed)-Cont2(Imed-1))*xbin
	Print *,' Median value ',Imed,Xmed
	Xsigp = xmi + (Isigp) * xbin
     &     - (cont2(Isigp)-0.84)/(cont2(Isigp)-Cont2(Isigp-1))*xbin
	Print *,' +1Sig value ',ISigp,Xsigp
	Xsigm = xmi + (Isigm) * xbin
     &     - (cont2(Isigm)-0.16)/(cont2(Isigm)-Cont2(Isigm-1))*xbin
	Print *,' -1Sig value ',ISigm,Xsigm
c
	Sigma = (xsigp - xsigm)/2.
	Print *,' Median value ',Xmed,'+/-',Sigma
c
	return
	end
C
C*** MEAN  ****************************************************
C
	Subroutine Mean(ID1,ALim,BLim)
C calculated a mean within percent limits
	integer id1,noent
        real ALim, BLim
	integer	nx,ny,nwt,loc
	real    xmi,xma,ymi,yma
        real    xbin,x,avg
	real	Sum,Sum2,Sum3,Sum4,Sumsv
	logical HEXIST
	character*80 chtitl

        IF (.NOT. HEXIST(Id1)) THEN
            CALL HRIN(Id1,0,0)
        ENDIF
   
	call hgive(id1,chtitl,nx,xmi,xma,ny,ymi,yma,nwt,loc)
	if (nx .le. 0) return
	if (ny .gt. 0) return 
        PRINT *,' ',CHTITL

	call hnoent(id1,noent)
	if (noent .eq. 0) return
        print *,' Ids ',id1
	xbin = (xma-xmi)/nx	    
	sum = 0.
	do i = 1, nx
	    Sum = Sum + hi(id1,i)
	end do    
        en1 = Sum*ALim
        en2 = Sum*BLim
    
	Sum2 = 0.
        Sum3 = 0.
        Sum4 = 0.
        Sumsv = 0.
	do i = 1, nx
            x = xmi + (i - 0.5) *  xbin 
	    Sum2 = Sum2 + hi(id1,i)           
            wt=1.
            if((Sum2 .le. en1) .or. (Sumsv .ge. en2))  Then 
               wt=0.
            else if(Sumsv .lt. en1) wt = (Sum2-en1)/(Sum2-Sumsv)
            else if(Sum2  .gt. en2) wt = (en2-Sumsv)/(Sum2-Sumsv)
            end if
            Sum3 = Sum3 + wt*hi(id1,i)
            Sum4 = Sum4 + x*wt*hi(id1,i)
            SumSv = Sum2
         end do
         avg = Sum4 / Sum3
         Print *, ' mean from ',ALim,' to ',BLim, ' = ',Avg
C
	return
	end

C
C   PDEF  *******************************************************
C

	SUBROUTINE PDEF(IWHICH)
	CHARACTER*72 TIT
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF
C
C  CALL HGIVE 
C
	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        If(NX.LE.0) RETURN
	Write(6,20) Iwhich, TIT
 20     Format( ' Hist',I8,2x,A66)
        Write(6,21) Nx, XMI, XMA
	If(NY.Ne.0) Then
           Write(6,21) Ny, YMI, YMA
        End If
 21     Format(I11,' channels, from ',E12.4, ' to ',E12.4)
	RETURN
	END
C
C   PROX  ****************************************************************
C
	SUBROUTINE PROX(IWHICH)
	CHARACTER*72 TIT
	REAL CONTEN(1000)
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF
C
C  CALL HGIVE, GET NEW ID IF NEEDED
C
	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        IF (NX .EQ. 0) RETURN
	IF (NY .EQ. 0) THEN
	   PRINT *,'NOT VALID FOR 1-DIMENSIONAL HISTOGRAM'
	   RETURN
	END IF
	DO I=67,1,-1
	      K = I+5
	      TIT(K:K) = TIT(I:I)
	END DO
	TIT(1:5) = 'PROX '
	NEWID = IWHICH + 10000
21      IF(HEXIST(NEWID)) THEN
            NEWID = NEWID + 1
            GO TO 21
        END IF
	PRINT *,'NEW HISTOGRAM ID ',NEWID
C
C BOOK NEW HIST AND DO THE INTEGRAL OF THE OLD
C
	CALL HBOOK1(NEWID,TIT,NX,XMI,XMA,0.)
	DO I=1,NX
	   SUM = 0.
	   DO J=1,NY
	      VARIAB = HIJ(IWHICH,I,J)
	      SUM = SUM + VARIAB
	   END DO
	   CONTEN(I) = SUM
	END DO
	CALL HPAK(NEWID,CONTEN)
	RETURN
	END
C
C   PROY  ***************************************************************
C
	SUBROUTINE PROY(IWHICH)
	CHARACTER*72 TIT
	REAL CONTEN(1000)
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF
C
C  CALL HGIVE, GET NEW ID IF NEEDED
C
	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        If(NX.LE.0) RETURN
	IF (NY .EQ. 0) THEN
	   PRINT *,'NOT VALID FOR 1-DIMENSIONAL HISTOGRAM'
	   RETURN
	END IF
	DO I=67,1,-1
	      K = I+5
	      TIT(K:K) = TIT(I:I)
	END DO
	TIT(1:5) = 'PROY '
	NEWID = IWHICH + 10000
21      IF(HEXIST(NEWID)) THEN
            NEWID = NEWID + 1
            GO TO 21
        END IF
	PRINT *,'NEW HISTOGRAM ID ',NEWID
C
C BOOK NEW HIST AND DO THE PROJECTION
C
	CALL HBOOK1(NEWID,TIT,NY,YMI,YMA,0.)
	DO J=1,NY
	   SUM = 0.
	   DO I=1,NX
	      VARIAB = HIJ(IWHICH,I,J)
	      SUM = SUM + VARIAB
	   END DO
	   CONTEN(J) = SUM
	END DO
	CALL HPAK(NEWID,CONTEN)
	RETURN
	END
C
C   REGX  *****************************************************************	
C
      Subroutine REGX(ID2)
*----------------------------------------------------------------------
*-
*-   Purpose and Methods : Simulates the DISPLAY function REGX, more or less...
*-
*-   Returned value  : 
*-   Input  : id2 = id of existing 2D histogram 

*-   Created  12-Jun-1995   Gerry Lynch  - with Ed Oltmans' AVX as a guide
*-
      INTEGER ID2,IDA,IDS
      INTEGER   NX,NY,N1,N2,IDW,IX,IY,DOF
      REAL      AY(1000),AV(1000),AVE(1000),SD(1000),SDE(1000)
      REAL      Cv,Cs,DCV,DCS,BSIY
      CHARACTER*80 TITL,titl1
      REAL      HIJ
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(ID2)) THEN
            CALL HRIN(ID2,0,0)
        ENDIF
      CALL HGIVE(ID2,TITL,NX,XMI,XMA,NY,YMI,YMA,N1,N2)
      If(NX.LE.0) GOTO 999
      IF(NY.LE.0) THEN
         WRITE(*,*) ' REGX needs a 2-D Histogram'
         GO to 999
      End If
      IF (NX .GT. 1000 .OR. NY .GT. 1000) THEN
        WRITE(*,*) ' REGX: HISTOS TOO BIG: MAX = ',1000
        WRITE(*,*) '      NX,NY = ',NX,NY
        goto 999
      ENDIF
      IDA = ID2 + 10000
 10   IF (HEXIST(IDA)) Then
        IDA = IDA + 1
	Go To 10
      End If
      Ids = Ida+1           
 20       IF (HEXIST(IDS)) Then
          Ids = Ids + 1
          GO to 20
      End If
      Write(6,*) '    REGX in histogram',Ida
      Write(6,*) '    SDX in histogram',Ids
      titl1 = 'RGX '//titl(1:74)
      CALL HBOOK1(IDA,titl1,NX,XMI,XMA,0)
      titl1 = 'SDX '//titl(1:74)
      CALL HBOOK1(IDS,titl1,NX,XMI,XMA,0)
    1 IDW = 12321
      IF(HEXIST(IDW)) THEN
        IDW = IDW + 1
        GO TO 1
      ENDIF
      CALL HBOOK1(IDW,'I WORK FOR REGX$',NY,YMI,YMA,0)
       BSIY = (YMA-YMI)/NY
      CALL VZERO(AV ,NX)
      CALL VZERO(AVE,NX)
      CALL VZERO(SD ,NX)
      CALL VZERO(SDE,NX)
      DO IX = 1,NX
        Cs=0.
        Cv=0.
        SUM=0.
        Dcv = 0.
        Dcs = 0.
	DOF = -3
        Do IY=1,Ny
           Ay(Iy) = HIJ(ID2,IX,IY)
           Cv=Cv+AY(IY)*IY
           Cs=Cs+AY(IY)*IY*IY
           SUM=SUM+AY(IY)
           IF (AY(IY) .GT. 0) DOF = DOF + 1
        End Do
        IF (SUM .GT. 3.) THEN
           Cv=Cv/Sum
           Cs=Cs-SUM*Cv**2
           Cv=(Cv-.5)*Bsiy+YMI
           If(Cs.Le.0.)Then
	      Cs=0
              Dcs=0
              Dcv = 0.00001*Cv
	   Else
              Cs = Bsiy*Sqrt(Cs/Max(SUM-1.0,1.0))
              Dcv = Cs/Sqrt(SUM)
              Dcs = Dcv/1.4142
	  End If
          AV (IX) = Cv
          AVE(IX) = Dcv
          SD (IX) = Cs
          SDE(IX) = Dcs
        ENDIF
      ENDDO
      CALL HDELET(IDW)
      CALL HPAK (IDA,AV )    
      CALL HPAKE(IDA,AVE)
      CALL HPAK (IDS,SD )
      CALL HPAKE(IDS,SDE)
  999 RETURN
      END
C
C   REGY  *****************************************************************	
C
      Subroutine REGY(ID2)
*----------------------------------------------------------------------
*-
*-   Purpose and Methods : Simulates the DISPLAY function REGX, more or less...
*-
*-   Returned value  : 
*-   Input  : id2 = id of existing 2D histogram 

*-   Created  21-Jun-1995   Gerry Lynch  - by modifying REGX
*-
      INTEGER ID2,IDA,IDS
      INTEGER   NX,NY,N1,N2,IDW,IX,IY,DOF
      REAL      AX(1000),AV(1000),AVE(1000),SD(1000),SDE(1000)
      REAL      Cv,Cs,DCV,DCS,BSIX
      CHARACTER*80 TITL,titl1
      REAL      HIJ
      LOGICAL   HEXIST
*----------------------------------------------------------------------
      IF (.NOT. HEXIST(ID2)) THEN
          CALL HRIN(ID2,0,0)
      ENDIF

      CALL HGIVE(ID2,TITL,NX,XMI,XMA,NY,YMI,YMA,N1,N2)
      If(NX.LE.0) GOTO 999
      IF(NY.LE.0) THEN
         WRITE(*,*) ' REGY needs a 2-D Histogram'
         GO to 999
      End If
      IF (NX .GT. 1000 .OR. NY .GT. 1000) THEN
        WRITE(*,*) ' REGY: HISTOS TOO BIG: MAX = ',1000
        WRITE(*,*) '      NX,NY = ',NX,NY
        goto 999
      ENDIF
      IDA = ID2 + 10000
 10   IF (HEXIST(IDA)) Then
        IDA = IDA + 1
	Go To 10
      End If
      Ids = Ida+1           
 20       IF (HEXIST(IDS)) Then
          Ids = Ids + 1
          GO to 20
      End If
      Write(6,*) '    REGY in histogram',Ida
      Write(6,*) '    SDY in histogram',Ids
      titl1 = 'RGY '//titl(1:74)
      CALL HBOOK1(IDA,titl1,NY,YMI,YMA,0)
      titl1 = 'SDY '//titl(1:74)
      CALL HBOOK1(IDS,titl1,NY,YMI,YMA,0)
    1 IDW = 12321
      IF(HEXIST(IDW)) THEN
        IDW = IDW + 1
        GO TO 1
      ENDIF
      CALL HBOOK1(IDW,'I WORK FOR REGY$',NY,YMI,YMA,0)
      BSIX = (XMA-XMI)/NX
      CALL VZERO(AV ,NY)
      CALL VZERO(AVE,NY)
      CALL VZERO(SD ,NY)
      CALL VZERO(SDE,NY)
      DO IY = 1,NY
        Cs=0.
        Cv=0.
        SUM=0.
        Dcv = 0.
        Dcs = 0.
	DOF = -3
        Do IX=1,NX
           AX(IX) = HIJ(ID2,IX,IY)
           Cv=Cv+AX(IX)*IX
           Cs=Cs+AX(IX)*IX*IX
           SUM=SUM+AX(IX)
           IF (AX(IX) .GT. 0) DOF = DOF + 1
        End Do
        IF (SUM .GT. 3.) THEN
           Cv=Cv/Sum
           Cs=Cs-SUM*Cv**2
           Cv=(Cv-.5)*Bsix+XMI
           If(Cs.Le.0.)Then
              Cv=0
	      Cs=0
	   Else
              Cs = Bsix*Sqrt(Cs/Max(SUM-1.0,1.0))
              Dcv = Cs/Sqrt(SUM)
              Dcs = Dcv/1.4142
	  End If
          AV (IY) = Cv
          AVE(IY) = Dcv
          SD (IY) = Cs
          SDE(IY) = Dcs
        ENDIF
      ENDDO
      CALL HDELET(IDW)
      CALL HPAK (IDA,AV )    
      CALL HPAKE(IDA,AVE)
      CALL HPAK (IDS,SD )
      CALL HPAKE(IDS,SDE)
  999 RETURN
      END
C
C   SCAL  *******************************************************
C
	SUBROUTINE SCAL(IWHICH,FACTOR)
	CHARACTER*72 TIT
	REAL CONTEN(1000), ERRORS(1000)
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF
C
C  CALL HGIVE, GET NEW ID 
C
	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        If(NX.LE.0) RETURN
	DO I=67,1,-1
	      K = I+5
	      TIT(K:K) = TIT(I:I)
	END DO
	TIT(1:5) = 'SCAL '
	NEWID = IWHICH + 10000
21      IF(HEXIST(NEWID)) THEN
            NEWID = NEWID + 1
            GO TO 21
        END IF
C
C BOOK NEW HIST
C
	PRINT *,'NEW HISTOGRAM',NEWID
	CALL HCOPY(IWHICH,NEWID,TIT)
	CALL HRESET(NEWID,TIT)
	SUM = 0.
	IF (NY.EQ.0) THEN
	   DO I=1,NX
	      VARIAB = HI(IWHICH,I)
	      CONTEN(I) = FACTOR*VARIAB
              ERROR = HIE(IWHICH,I)
              ERRORS(I) = FACTOR*ERROR
	   END DO
10	   CALL HPAK(NEWID,CONTEN)
           CALL HPAKE(NEWID,ERRORS)
	ELSE
	   XBIN = (XMA-XMI)/NX
	   YBIN = (YMA-YMI)/NY
	   DO I=1,NX
	      X = XMI + 0.5*XBIN + (I-1)*XBIN
	      DO J=1,NY
		 VARIAB = HIJ(IWHICH,I,J)
		 CALL HFILL(NEWID,X,Y,FACTOR*VARIAB)
	      END DO
	   END DO
	END IF
20	RETURN
	END
C
C   SOM  *****************************************************************
C
	SUBROUTINE SOM(IWHICH)
	CHARACTER*72 TIT
	REAL CONTEN(1000)
        LOGICAL   HEXIST
*----------------------------------------------------------------------
        IF (.NOT. HEXIST(IWHICH)) THEN
            CALL HRIN(IWHICH,0,0)
        ENDIF
C
C  CALL HGIVE, GET NEW ID IF NEEDED
C
	CALL HGIVE(IWHICH,TIT,NX,XMI,XMA,NY,YMI,YMA,NWT,IAD)
        If(NX.LE.0) RETURN
	DO I=67,1,-1
	      K = I+5
	      TIT(K:K) = TIT(I:I)
	END DO
	TIT(1:5) = 'SOM  '
	NEWID = IWHICH + 10000
21      IF(HEXIST(NEWID)) THEN
            NEWID = NEWID + 1
            GO TO 21
        END IF
	IF (NY .NE. 0) THEN
	   PRINT *,'SOM NOT VALID ON 2D'
	   RETURN
	END IF
	PRINT *,'NEW HISTOGRAM ID ',NEWID
C
C BOOK NEW HIST AND DO THE INTEGRAL OF THE OLD
C
	CALL HCOPY(IWHICH,NEWID,TIT)
	CALL HRESET(NEWID,TIT)
	SUM = 0.
	SUM = HI(IWHICH,0)	
	DO I=1,NX
	   VARIAB = HI(IWHICH,I)
	   SUM = SUM + VARIAB
	   CONTEN(I) = SUM
	END DO
	CONTEN(NX) = SUM + HI(IWHICH,NX+1)
	CALL HPAK(NEWID,CONTEN)
	RETURN
	END
 
	Subroutine Pawn(Operation,Ihin,Par)
 
	Character*10 Operation
	Real Par(10)
	Integer Ihin

	If(Operation.Eq.'AVX'.Or.Operation.eq.'avx'.or.
     &     Operation.Eq.'Avx') Then
           Call Avx(Ihin,Par(1))
	Else If(Operation.Eq.'AVY'.Or.Operation.eq.'avy'.or.
     &     Operation.Eq.'Avy') Then
           Call Avy(Ihin,Par(1))
	Else If(Operation.Eq.'BLOW'.Or.Operation.eq.'blow'.or.
     &     Operation.Eq.'Blow') Then
           Call Blow(Ihin,Par(1),Par(2))
	Else If(Operation.Eq.'BLO2'.Or.Operation.eq.'blo2'.or.
     &     Operation.Eq.'Blo2') Then
           Call Blo2(Ihin,Par(1),Par(2),Par(3),Par(4))
	Else If(Operation.Eq.'CHBN'.Or.Operation.eq.'chbn'.or.
     &     Operation.Eq.'Chbn') Then
           Call Chbn(Ihin,Par(1))
	Else If(Operation.Eq.'CHBN2'.Or.Operation.eq.'chbn2'.or.
     &     Operation.Eq.'Chbn2') Then
           Call Chbn2(Ihin,Par(1),Par(2))
	Else If(Operation.Eq.'CHTI'.Or.Operation.eq.'chti'.or.
     &     Operation.Eq.'Chti') Then
           Call Chti(Ihin)
	Else If(Operation.Eq.'PDEF'.Or.Operation.eq.'pdef'.or.
     &     Operation.Eq.'Pdef') Then
           Call Pdef(Ihin)
	Else If(Operation.Eq.'MED'.Or.Operation.eq.'med'.or.
     &     Operation.Eq.'Med') Then
           Call Med(Ihin)
	Else If(Operation.Eq.'MEAN'.Or.Operation.eq.'med'.or.
     &     Operation.Eq.'Mean') Then
           Call Mean(Ihin,Par(1),Par(2))
	Else If(Operation.Eq.'PROX'.Or.Operation.eq.'prox'.or.
     &     Operation.Eq.'Prox') Then
           Call Prox(Ihin)
	Else If(Operation.Eq.'PROY'.Or.Operation.eq.'proy'.or.
     &     Operation.Eq.'Proy') Then
           Call Proy(Ihin)
	Else If(Operation.Eq.'REGX'.Or.Operation.eq.'regx'.or.
     &     Operation.Eq.'Regx') Then
           Call Regx(Ihin)
	Else If(Operation.Eq.'REGY'.Or.Operation.eq.'regy'.or.
     &     Operation.Eq.'Regy') Then
           Call Regy(Ihin)
	Else If(Operation.Eq.'SCAL'.Or.Operation.eq.'scal'.or.
     &     Operation.Eq.'Scal') Then
           Call SCAL(Ihin,Par(1))
	Else If(Operation.Eq.'SOM'.Or.Operation.eq.'som'.or.
     &     Operation.Eq.'Som') Then
	   Call Som(Ihin)
     	Else
	    write(6,*) 'Operation', Operation, 'is not defined'
	End If
	Return
	End