/* FILE X$ANAL.PPL for one 8-fold adc readout*/
X$ANAL:@PROCEDURE(P_BUFFER,P_EVENT) RETURNS(BIN FIXED(31));
@INCLUDE $MACRO(DCL_PROC);
@INCLUDE $MACRO(S$MESS);
@INCLUDE $MACRO($MACRO);
@INCLUDE $MACRO(U$PRTCL);
@INCLUDE $MACRO(SA$VE10_1);
@INCLUDE $MACRO(SA$VES10_1);
@INCLUDE $MACRO(SA$BUFHE);
@INCLUDE $MACRO(U$RANDOM);
@INCLUDE $MACRO('PAR.TXT');
/*@INCLUDE $MACRO(S_OUT);*/
@DCL_MSG(XIO_NOOUTPUT);
DCL P_EVENT                              POINTER;
DCL P_PAR                                POINTER STATIC;
DCL P_BUFFER                             POINTER;
DCL (ADC_E(8), Q(8), SUM_E)              BIN FIXED(15);
DCL (PHI, X0, Y0, AE, BE, RMIN, RMAX,     EMEV, HELP, PI, C1, C2, XE, YE)     BIN FLOAT(24);
DCL (EELE, VELE, X, Y, Z1, Z2, Z,     ALPHA, VPAR, VSENK, ERG)            BIN FLOAT(24);
DCL (ENERGY, Q_CAL(3))                   BIN FLOAT(24);
DCL (I, N)                               BIN FIXED(15) STATIC;
DCL L_INCR                               BIN FIXED(15) STATIC INIT(1);
DCL (X_INCR, E_INCR, C_INCR)             BIN FLOAT (24);
DCL (B_SUM_E, B_TEST)                    BIT(1) ALIGNED;
DCL (FLAG_E, FLAG_FRAG)                  BIT(1) ALIGNED;
DCL TRUE                                 BIT(1) STATIC INIT('1'B);
DCL FALSE                                BIT(1) STATIC INIT('0'B);
DCL 1 PATTERN_WORD                       UNION,     2 PATTERN_BIT(32)                   BIT(1),     2 B_PATTERN                         BIT(32),     2 I_PATTERN                         BIN FIXED(31);

@ON_ANY_W(U_CLEANUP);
STS$VALUE=1;
P_SA$BUFHE=P_BUFFER;
P_SA$VE10_1=P_EVENT;
P_SA$VES10_1=ADDR(IA$VE10_1(1));

do I=1 to 8;  
   ADC_E(I) = IA$VES10_1(i*2);  
   if((ADC_E(I) < 10) & (ADC_E(I) > 3840)) then ADC_E(I) = 5;  
   $accu1(L,DB,$SPECTRUM,ADC,I,1,1,ADC_E(I));
end;
ENERGY=ADC_E(5);

/* sortiere adc-werte in zu verwertende spektren */

do I=1 to 3;  
   $accu1(L,DB,$SPECTRUM,Q_E,I,L_INCR,1,ADC_E(I));
end;

FLAG_FRAG = FALSE;
$accu(L,DB,$SPECTRUM,E_E,L_INCR,1,ENERGY);
FLAG_E = FALSE;
I_PATTERN = 0;

/* nachsehen ob ereignisse im adc-fenster liegen, bzw. ob ein segment fehlt */
do I=1 to 3;  
   if ( ADC_E(I)>10 & ADC_E(I)<3840) then PATTERN_BIT(I) = TRUE;
end;
if I_PATTERN = 7 then FLAG_E = TRUE;
$accu(L,DB,$SPECTRUM,PAT_E,L_INCR,1,I_PATTERN);

/* so, jetzt wird das ortsbild berechnet */

do I=1 to 3;  
   Q(I) = PAR.R.Q_CAL(I) * (ADC_E(I)+U$RANDOM(1.0)-0.5);  
end;

SUM_E = 0;
do I=1 to 3;  
   SUM_E = SUM_E + Q(I);  
end;

if (FLAG_E & (ENERGY>0)) then do;  
   FLAG_E = FALSE;  
   $accu(L,DB,$SPECTRUM,qsum_e,L_INCR,1,SUM_E/3);  
   $cond(WC,DB,$CONDITION,c_sum_e,B_SUM_E,1,SUM_E/3);  
   if B_SUM_E then do;    
      FLAG_E = TRUE;    
      XE = (1000.0 * Q(1))/SUM_E;    
      YE = (1000.0 * Q(2))/SUM_E;    
      PHI  = PAR.R.PHI;    
      X0   = PAR.R.X0;    
      Y0   = PAR.R.Y0;    
      AE   = PAR.R.AE;    
      BE   = PAR.R.BE;    
      RMIN = PAR.R.RMIN;    
      RMAX = PAR.R.RMAX;    
      EMEV = PAR.R.EMEV;    
      HELP = XE;    
      PI   = 3.1416;    
      if( (X0^=0.0) & (Y0^=0.0)) then do;      
         XE = cosd(PHI) * (XE-X0) + sind(PHI) * (YE-Y0) + X0;      
	 YE = - sind(PHI) * (HELP-X0) + cosd(PHI) * (YE-Y0) + Y0;      
      end;    
      EELE = (AE * ENERGY + BE)/27.21;    
      if (EELE>0.0) then VELE = sqrt(2*EELE);      
                    else VELE = 0.0;    
      if ((X0^=0.0) & (Y0^=0.0)) then do;      
         X = XE - X0;      
	 Y = YE - Y0;      
	 Z1 = X*X;      
	 Z2 = Y*Y;      
	 Z = sqrt(abs(Z1+Z2));      
	 if ((Z>=RMIN) & (Z<=RMAX)) then do;
	    if(X=0.0) then X=0.001;        
	    ALPHA = atan(Y/abs(X));        
	    if ((Y>=0.0) & (X<0.0)) then ALPHA = ALPHA - PI;        
	    if ((Y<=0.0) & (X<0.0)) then ALPHA = ALPHA + PI;        
	 end;      
	 VPAR  = VELE * cos(ALPHA);      
	 VSENK = VELE * sin(ALPHA);      
	 ERG   = (VELE**2/2.0) * 27.21;      
      end;    
      if (VELE^=0) then X_INCR = 2.0/VELE;      
                   else X_INCR = 0.0;    
      if ((ERG^=0) & (EELE>0)) then E_INCR = 1.0/EELE;      
                               else E_INCR = 0.0;    
      if (ERG^=0) then C_INCR = 1.0;      
                  else C_INCR = 0.0;    
      $accu(L,DB,$SPECTRUM,X_E,L_INCR,1,XE);    
      $accu(L,DB,$SPECTRUM,Y_E,L_INCR,1,YE);    
      $accu(L,DB,$SPECTRUM,XY_E,L_INCR,2,XE,YE);    
      $accu(R,DB,$SPECTRUM,XY,L_INCR,2,ALPHA,Z);    
/* Hier kommen die anderen Spektren hin ... */    
      if((X0^=0.0) & (Y0^=0.0) & (VELE>0.0)) then do;      
         $accu(R,DB,$SPECTRUM,THETA_V,X_INCR,2,ALPHA,VELE);
	 $accu(R,DB,$SPECTRUM,VX_VY,X_INCR,2,VPAR,VSENK);      
         $accu(R,DB,$SPECTRUM,THETA_E,E_INCR,2,ALPHA,ERG);      
      end;    
   end;  
end;
@RET(STS$value);
/****************************************************/
/* Initialization to locate all used Data Elements  */
/****************************************************/
$XANAL:ENTRY RETURNS(BIN FIXED(31));
@INCLUDE $MACRO($SECDEF);
PUT EDIT ('ANALYSE fuer 1 adc')(A);
/*************************/
/***  GOOSY Spectra  *****/
/*************************/
$loc1(SPEC,DB,$SPECTRUM,ADC,1,8,W);
if ^STS$SUCCESS then @ret(STS$VALUE);
$loc1(SPEC,DB,$SPECTRUM,Q_E,1,3,W);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,E_E,W);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,PAT_E,W);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,QSUM_E,W);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,X_E,W);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,Y_E,W);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,XY_E,W);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,XY,W,R);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,VX_VY,W,R);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,THETA_E,W,R);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(SPEC,DB,$SPECTRUM,THETA_V,W,R);
if ^STS$SUCCESS then @ret(STS$VALUE);$loc(DE,DB,DATA,PAR,W);
if ^STS$SUCCESS then @ret(STS$VALUE);P_PAR=P$_DB_DATA_PAR;
/***************************/
/***   GOOSY Condtions  ****/
/***************************/
$loc(COND,DB,$CONDITION,C_SUM_E,W);
if ^STS$SUCCESS then @ret(STS$VALUE);
$loc(COND,DB,$CONDITION,C_TEST,W);
if ^STS$SUCCESS then @ret(STS$VALUE);
@RET(STS$value);
/*************************************************/
/* This routine is called in case of an error    */
/*************************************************/
U_CLEANUP:PROCEDURE;END U_CLEANUP;
END X$ANAL;