*trigger 128 *oned 0..351 s 4096 *twod *vars *sort C----67---------------------------------------------------------------72------80 SUBROUTINE init IMPLICIT none SAVE C C External functions C EXTERNAL dtime C INTEGER int, rshift, s2order C REAL dtime, float, rand C C Parameter variables C INTEGER maxadcs PARAMETER (maxadcs = 2200) INTEGER adcs_max PARAMETER (adcs_max = 11*32) INTEGER tdcs_max PARAMETER (tdcs_max = 3*112) INTEGER maxscalers PARAMETER (maxscalers = 32) INTEGER maxepics PARAMETER (maxepics = 64) INTEGER event_prescaler PARAMETER (event_prescaler = 1000000) INTEGER scaler_prescaler PARAMETER (scaler_prescaler = 1000000) INTEGER epics_prescaler PARAMETER (epics_prescaler = 1000000) C LOGICAL csm PARAMETER (csm = .true.) C C Local variables C INTEGER data(0:maxadcs-1), epics_counter, events, events_old, i INTEGER*2 i2(2) INTEGER i4, ierr, iflag, ireturn, j, k, m_adc, sc_counter, type INTEGER w(0:31) C LOGICAL hit(0:maxadcs-1) C REAL c(0:31), gain(0:maxadcs-1), offset(0:maxadcs-1), r4, rate REAL time(2) C C Namelists C NAMELIST /variables/ gain, offset, c, w C C Common variables C INTEGER*2 adc_data(0:maxadcs-1) C COMMON /fdata/ adc_data C C Common variables C INTEGER*2 adcs(0:maxadcs-1) C COMMON /fid/ adcs C C Common variables C INTEGER noadcs C COMMON /fmult/ noadcs C EQUIVALENCE ( i4, i2( 1 ) ) C C----67---------------------------------------------------------------72------80 WRITE ( 6, * ) ' *** S1284 - sort - November 2013' WRITE ( 6, * ) ' *** Entry init commences' C Initialise arrays for unpacked event data. DO i = 0, maxadcs - 1 data( i ) = 0 hit( i ) = .FALSE. ENDDO C Initialise gains/offsets DO i = 0, maxadcs - 1 gain( i ) = 1.0 offset( i ) = 0.0 ENDDO C Initialise constants/1D windows DO i = 0, 31 c( i ) = 1.0 w( i ) = 0 ENDDO C Initialise counters sc_counter = 0 epics_counter = 0 events = 0 events_old = 0 C Read program variables via NAMELIST I/O OPEN( 1, FILE = '', + IOSTAT = ierr ) IF ( ierr.NE.0 ) THEN WRITE( 6, * ) ' *** OPEN I/O error:', ierr RETURN ENDIF READ( 1, NML = variables, IOSTAT = ierr ) IF ( ierr.NE.0 ) THEN WRITE( 6, * ) ' *** READ I/O error:', ierr ENDIF CLOSE( 1, IOSTAT = ierr ) IF ( ierr.NE.0 ) THEN WRITE( 6, * ) ' *** CLOSE I/O error:', ierr RETURN ENDIF C Display program variables DO i = 0, adcs_max-1, 8 WRITE( 6, 9001 ) i, i+7, ( gain( j ), j = i, i+7 ) ENDDO DO i = 0, adcs_max-1, 8 WRITE( 6, 9002 ) i, i+7, ( offset( j ), j = i, i+7 ) ENDDO DO i = 1000, 1000+tdcs_max-1, 8 WRITE( 6, 9002 ) i, i+7, ( offset( j ), j = i, i+7 ) ENDDO DO i = 0, 31, 8 WRITE( 6, 9003 ) i, i+7, ( c( j ), j = i, i+7 ) ENDDO DO i = 0, 31, 8 WRITE( 6, 9004 ) i, i+7, ( w( j ), j = i, i+7 ) ENDDO WRITE ( 6, * ) ' *** Entry init ends' RETURN C----67---------------------------------------------------------------72------80 ENTRY sortin events = events + 1 IF ( MOD( events, event_prescaler ).EQ.0 ) THEN rate = FLOAT( events - events_old ) / dtime(time) WRITE( 6, * ) ' *** event:', events, ' (', rate,' events/s)' events_old = events ENDIF C Convert Eurogam type 0 ID to (a more) logical channel number. C ADC data channels 0-999 C TDC data channels 1000-1999 C Scaler data channels 2000-2099 C EPICS data channels 2100-2199 call egid2logical( noadcs, adcs, adc_data, type, csm ) C----67---------------------------------------------------------------72------80 C Event data. IF ( MOD( events, event_prescaler ).EQ.0 ) THEN WRITE( 6, * ) ' *** Packed event:', events, ' noadcs:', noadcs DO i = 0, noadcs - 1 WRITE( 6, 9050 ) adcs( i ), adc_data( i ) ENDDO ENDIF C Unpack event data from packed data arrays. DO i = 0, noadcs - 1 IF ( adcs( i ).GE.0 .AND. adcs( i ).LT.maxadcs ) THEN data( adcs( i ) ) = adc_data( i ) hit( adcs( i ) ) = .TRUE. ENDIF ENDDO IF ( MOD( events, event_prescaler ).EQ.0 ) THEN WRITE( 6, * ) ' *** Unpacked event:', events DO i = 0, adcs_max-1, 16 WRITE(6,9060) i, i+15, (data(j),hit(j),j=i,i+15) ENDDO DO i = 1000, 1000+tdcs_max-1, 16 WRITE(6,9060) i, i+15, (data(j),hit(j),j=i,i+15) ENDDO ENDIF C----67---------------------------------------------------------------72------80 C Scaler data. IF ( AND( X'00000002', type ).EQ.2 ) THEN sc_counter = sc_counter + 1 C----67---------------------------------------------------------------72------80 C EPICS data. ELSEIF ( AND( X'00000004', type ).EQ.4 ) THEN epics_counter = epics_counter + 1 C----67---------------------------------------------------------------72------80 C Unexpected data type. ELSEIF ( AND( X'00000008', type ).EQ.8 ) THEN RETURN C If event does not contain any ADC/TDC data return. ELSEIF ( AND( X'00000001', type ).NE.1 ) THEN RETURN ENDIF C----67---------------------------------------------------------------72------80 C Sort unpacked event data m_adc = 0 C----67---------------------------------------------------------------72------80 C ADCs DO i = 0, adcs_max-1 IF ( hit( i ) ) THEN m_adc = m_adc + 1 ENDIF ENDDO c IF ( m_adc.GT.16 ) GOTO 1000 C IF ( m_adc.LT.16 ) GOTO 1000 ! use this line to get rid of alpha source DO i = 0, adcs_max - 1 IF ( hit( i ) ) THEN j = INT( c(0) * gain(i) * (data(i) - offset(i)) + rand(iflag) ) CALL inc1d( i, j ) ENDIF ENDDO C----67---------------------------------------------------------------72------80 C Re-initialise unpacked data arrays using the packed data arrays. C Note: assumes packed data arrays are not modified by event. 1000 CONTINUE DO i = 0, noadcs - 1 data( adcs( i ) ) = 0 hit( adcs( i ) ) = .FALSE. ENDDO RETURN C----67---------------------------------------------------------------72------80 ENTRY finish WRITE ( 6, * ) ' *** Entry finish ' RETURN C----67---------------------------------------------------------------72------80 9001 FORMAT( ' gain(', i4, '-', i4, ')', 8f8.5 ) 9002 FORMAT( ' offset(', i4, '-', i4, ')', 8f8.2 ) 9003 FORMAT( ' c(', i4, '-', i4, ')', 8f8.3 ) 9004 FORMAT( ' w(', i4, '-', i4, ')', 8i8 ) 9010 FORMAT(/' *** scaler event: ', i10 ) 9020 FORMAT( ' scaler(', i2, '-', i2, ')', 8(1x,i10) ) 9030 FORMAT(/' *** epics event:', i10 ) 9040 FORMAT( ' epics(', i2, '-', i2, ')', 8(1x,g13.6) ) 9050 FORMAT( 2(1x,i4) ) 9060 FORMAT( 2(1x,i4), 16(1x,i4,1x,l1) ) C----67---------------------------------------------------------------72------80 END C----67---------------------------------------------------------------72------80 SUBROUTINE egid2logical( noadcs, adcs, adc_data, type, csm ) C Set logical argument csm true if TDCs are operated in common C stop (emulation) mode. IMPLICIT none C INTEGER and, rshift C C Parameter variables C INTEGER maxadcs PARAMETER (maxadcs = 2200) C Eurogam type 0 group IDs are defined in file /MIDAS/TUDA/tcl/GroupDefn.tcl INTEGER min_adc_gid PARAMETER (min_adc_gid = 1) INTEGER max_adc_gid PARAMETER (max_adc_gid = 19) INTEGER min_tdc_gid PARAMETER (min_tdc_gid = 20) INTEGER max_tdc_gid PARAMETER (max_tdc_gid = 29) INTEGER scaler_gid PARAMETER (scaler_gid = 31) INTEGER epics_gid PARAMETER (epics_gid = 30) C C Argument variables C INTEGER*2 adcs(0:maxadcs-1), adc_data(0:maxadcs-1) INTEGER noadcs, type C LOGICAL csm C C Local variables C INTEGER channel, data0, data1, data2, data3, data4, gid, i, item INTEGER tdc0, tdc1, tdc2, tdc3, tdc4 C----67---------------------------------------------------------------72------80 type = 0 DO 100 i = 0, noadcs - 1 gid = AND( X'000000ff', adcs( i ) ) item = AND( X'0000003f', RSHIFT( adcs( i ), 8 ) ) IF ( ( gid.GE.min_ADC_gid .AND. gid.LE.max_ADC_gid ) + .OR. + ( gid.GE.min_TDC_gid .AND. gid.LE.max_TDC_gid ) ) THEN type = IBSET( type, 0 ) ENDIF IF ( gid.GE.min_ADC_gid .AND. gid.LE.max_ADC_gid ) THEN channel = 32 * ( gid - min_ADC_gid ) + item ELSEIF( gid.GE.min_TDC_gid .AND. gid.LE.max_TDC_gid ) THEN C Each CAEN V767 TDC module is assigned two group IDs C for channels 0-63 and 64-127. channel = 64 * ( gid - min_TDC_gid ) + item C First sixteen channels of each CAEN V767 TDC module are unused in common C stop mode. IF ( csm ) THEN channel = channel - 16 * ( 1 + ( gid - min_TDC_gid ) / 2 ) ENDIF channel = channel + 1000 ELSEIF( gid.EQ.scaler_gid) THEN channel = item + 2000 type = IBSET( type, 1 ) ELSEIF( gid.EQ.EPICS_gid ) THEN channel = item + 2100 type = IBSET( type, 2 ) ELSE WRITE( 6, 9000 ) gid type = IBSET( type, 3 ) RETURN ENDIF adcs( i ) = channel 100 CONTINUE IF (type.NE.0 ) RETURN IF ( csm ) RETURN C Search for CAEN V767 channel 0 data tdc0 = -1 tdc1 = -1 tdc2 = -1 tdc3 = -1 tdc4 = -1 DO 110 i = 0, noadcs - 1 IF ( adcs( i ).EQ.1000 ) THEN tdc0 = i data0 = adc_data( i ) adcs( i ) = 3000 ENDIF IF ( adcs( i ).EQ.1128 ) THEN tdc1 = i data1 = adc_data( i ) adcs( i ) = 3128 ENDIF IF ( adcs( i ).EQ.1256 ) THEN tdc2 = i data2 = adc_data( i ) adcs( i ) = 3256 ENDIF IF ( adcs( i ).EQ.1384 ) THEN tdc3 = i data3 = adc_data( i ) adcs( i ) = 3384 ENDIF IF ( adcs( i ).EQ.1512 ) THEN tdc4 = i data4 = adc_data( i ) adcs( i ) = 3512 ENDIF 110 CONTINUE DO 120 i = 0, noadcs - 1 IF ( tdc0.LT.0 .AND. + ( adcs(i).GE.1016 .OR. adcs(i).LE.1127 ) ) THEN adcs( i ) = adcs( i ) + 2000 ENDIF IF ( tdc1.LT.0 .AND. + ( adcs(i).GE.1144 .OR. adcs(i).LE.1255 ) ) THEN adcs( i ) = adcs( i ) + 2000 ENDIF IF ( tdc2.LT.0 .AND. + ( adcs(i).GE.1272 .OR. adcs(i).LE.1383 ) ) THEN adcs( i ) = adcs( i ) + 2000 ENDIF IF ( tdc3.LT.0 .AND. + ( adcs(i).GE.1400 .OR. adcs(i).LE.1511 ) ) THEN adcs( i ) = adcs( i ) + 2000 ENDIF IF ( tdc4.LT.0 .AND. + ( adcs(i).GE.1528 .OR. adcs(i).LE.1639 ) ) THEN adcs( i ) = adcs( i ) + 2000 ENDIF 120 CONTINUE C Calculate common stop TDC values DO 130 i = 0, noadcs - 1 IF ( tdc0.GE.0 .AND. + ( adcs(i).GE.1016 .OR. adcs(i).LE.1127 ) ) THEN adc_data( i ) = adc_data( i ) - data0 adcs( i ) = adcs( i ) - 16 ENDIF IF ( tdc1.GE.0 .AND. + ( adcs(i).GE.1144 .OR. adcs(i).LE.1255 ) ) THEN adc_data( i ) = adc_data( i ) - data1 adcs( i ) = adcs( i ) - 32 ENDIF IF ( tdc2.GE.0 .AND. + ( adcs(i).GE.1272 .OR. adcs(i).LE.1383 ) ) THEN adc_data( i ) = adc_data( i ) - data2 adcs( i ) = adcs( i ) - 48 ENDIF IF ( tdc3.GE.0 .AND. + ( adcs(i).GE.1400 .OR. adcs(i).LE.1511 ) ) THEN adc_data( i ) = adc_data( i ) - data3 adcs( i ) = adcs( i ) - 64 ENDIF IF ( tdc4.GE.0 .AND. + ( adcs(i).GE.1528 .OR. adcs(i).LE.1639 ) ) THEN adc_data( i ) = adc_data( i ) - data4 adcs( i ) = adcs( i ) - 80 ENDIF 130 CONTINUE RETURN C----67---------------------------------------------------------------72------80 9000 FORMAT( '*** ERROR: egid2logical: unexpected GID: ', i10 ) C----67---------------------------------------------------------------72------80 END