*trigger 128 *oned 0..351 s 4096 1000..1335 s 512 3000 s 1024 3001 s 1024 3002 s 1024 3006 s 4096 3060..3067 s 4096 3100..3115 s 16384 4011 s 1024 4013 s 1024 4015 s 1024 4017 s 1024 *twod 2000..2335 s 512 512 3003 s 512 512 3004 s 512 512 3005 s 512 512 3050..3057 s 512 512 4000..4007 s 512 512 4010 s 512 512 4012 s 512 512 4014 s 512 512 4016 s 512 512 *vars *sort C----67---------------------------------------------------------------72------80 C http://npg.dl.ac.uk/MIDAS/manual/MIDASsortHOWTO/info.pdf SUBROUTINE init IMPLICIT none SAVE C C External functions C EXTERNAL de_1h_al, de_1h_cd2, dtime, elab2ex, gate2d, path_factor EXTERNAL s2order, s2_1_theta, s2_3_theta C INTEGER and, gate2d, int, rshift, s2order C REAL de_1h_al, de_1h_cd2, dtime, elab2ex, float, path_factor, rand REAL s2_1_theta, s2_3_theta 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) !not 3*127? INTEGER maxscalers PARAMETER (maxscalers = 16) 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 channel, counter_old(0:maxscalers-1), data(0:maxadcs-1) INTEGER epics_counter, events, events_old, gate1(18), good_s2_1 INTEGER good_s2_1_back(0:63), good_s2_1_front(0:63), good_s2_2 INTEGER good_s2_2_back(0:63), good_s2_2_front(0:63), i INTEGER*2 i2(2) INTEGER i4, ierr, iflag, ireturn, ix, iy, j, k, l, monitor(0:9) INTEGER monitor_old(0:9), m_adc, m_tdc, scaler(0:maxscalers-1) INTEGER scaler_old(0:maxscalers-1), sc_counter, sector INTEGER sum(0:maxscalers-1), type, w(0:31) C LOGICAL good_s2_1_event, good_s2_2_event, hit(0:maxadcs-1) C REAL c(0:31), de1, de2, dt, e(0:adcs_max-1), e1, e2, ediff REAL epics(0:maxepics-1), event_rate, e_lab, e_x REAL gain(0:maxadcs-1), lt, offset(0:maxadcs-1), pi, r4 REAL rate(0:maxscalers-1), temp, time(2) C C Namelists C NAMELIST /variables/ offset, gain, 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 MIDAS polygon C {{396 96} {404 109} {421 124} {448 144} {475 144} {454 129} {432 113} {416 96}} C !********************************************** DATA gate1 /396, 96,404,109,421,124,448,144,475,144,454,129, + 432,113,416, 96, -1, -1/ C----67---------------------------------------------------------------72------80 WRITE ( 6, * ) ' *** S1284 - sort3 - 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 scalers DO i = 0, maxscalers - 1 scaler( i ) = 0 scaler_old( i ) = 0 counter_old( i ) = 0 rate( i ) = 0.0 ENDDO C Initialise counters sc_counter = 0 epics_counter = 0 events = 0 events_old = 0 channel = 0 DO i = 0, 9 monitor( i ) = 0 monitor_old( i ) = 0 ENDDO OPEN( 1, FILE = '/home/tuda/S1284/calibration/variables.dat', + 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. c If you want to write events in ascii format do it here event number = 'events' 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 c WRITE(6,9060) i, i+15, (data(j),hit(j),j=i,i+15) ENDDO DO i = 1000, 1000+tdcs_max-1, 16 c 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 C IF ( MOD( sc_counter, scaler_prescaler ).EQ.0 ) THEN C WRITE( 6, 9010 ) sc_counter C DO i = 0, maxscalers-1, 4 C WRITE( 6, 9020 ) i, i+3, ( scaler(j), C + 1.0E-03 * rate(j), j = i, i+3 ) C ENDDO C ENDIF j = 0 DO i = 2000, 2000 + ( 2 * maxscalers ) - 1, 2 i2( 1 ) = data( i + 1 ) i2( 2 ) = data( i ) scaler( j ) = i4 j = j + 1 ENDDO C Scalers are reset at the start of each run. C C Note that scalers do not necessarily increase monotonically C from event to event - this probably indicates that the most C frequently changing (least significant) bits are not stable C at readout. IF ( scaler( 2 )+100.LT.counter_old( 2 ) ) THEN DO i = 0, maxscalers - 1 sum( i ) = sum( i ) + counter_old( i ) counter_old( i ) = 0 ENDDO ELSE DO i = 0, maxscalers - 1 counter_old( i ) = scaler( i ) ENDDO ENDIF IF ( scaler( 2 ).LT.scaler_old( 2 ) ) THEN DO i = 0, maxscalers - 1 scaler_old( i ) = 0 ENDDO ENDIF C Update scaler spectra ( 3100 - 3100+maxscalers-1 ) C once per minute using rate(Hz)*1000 IF ( scaler( 2 ) - scaler_old( 2 ).GE.60000 ) THEN dt = FLOAT( scaler( 2 ) - scaler_old( 2 ) ) / 1000.0 DO i = 0, maxscalers - 1 IF ( ( scaler( i ) - scaler_old( i ) ) .LE. 0 ) THEN rate( i ) = 0.0 ELSE rate( i ) = 1000.0 * FLOAT( scaler(i) - scaler_old(i) ) / dt ENDIF CALL set1d( i+3100, MOD(channel, 16384), INT( rate(i)+0.5 ) ) ENDDO DO i = 0, maxscalers - 1 scaler_old( i ) = scaler( i ) ENDDO channel = channel + 1 ENDIF 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 WRITE( 6, 9010 ) epics_counter C----67---------------------------------------------------------------72------80 C Unexpected data type. ELSEIF ( AND( X'00000008', type ).EQ.8 ) THEN RETURN C----67---------------------------------------------------------------72------80 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 Calculate energies and remove ADC/TDC data for energies < 0.25MeV DO i = 0, 127 IF ( hit( i ) ) THEN e( i ) = 0.05 * c(0) * gain(i) * (data(i) - offset(i)) !multiply by 0.05 to change bin size ELSE e( i ) = 0.0 ENDIF ENDDO DO i = 128, 255 IF ( hit( i ) ) THEN e( i ) = 0.005 * c(1) * gain(i) * (data(i) - offset(i)) !multiply by 0.05 to change bin size e(i)=0.1*data(i) ELSE e( i ) = 0.0 ENDIF ENDDO DO i = 0, adcs_max-1 IF ( e( i ) .LE. 0.25 ) THEN e( i ) = 0.0 hit( i ) = .FALSE. hit( i+1000 ) = .FALSE. ENDIF ENDDO C----67---------------------------------------------------------------72------80 C Sort unpacked event data m_adc = 0 m_tdc = 0 C----67---------------------------------------------------------------72------80 C ADCs 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( 10.0 * e( i ) + rand(iflag) ) !multiply by 10 to change bin size CALL inc1d( i, j ) !ADC histogram CALL inc1d( 3000, i ) !channels with hits CALL inc2d( 3003, RSHIFT(j,1), i ) !ADC channel vs ADC histogram channel m_adc = m_adc + 1 ENDIF ENDDO C----67---------------------------------------------------------------72------80 C Multiplicity CALL inc1d( 3006, m_adc ) !multiplicity C----67---------------------------------------------------------------72------80 C Reject pulser events IF ( m_adc.GT.32 ) GOTO 1000 c Reject alpha events c IF ( m_adc.LT.16 ) GOTO 1000 ! use this line to get rid of alpha source C----67---------------------------------------------------------------72------80 C Select good S2-delE events ediff = 0.0 DO i = 0, 47 good_s2_1_front(i) = -1 good_s2_1_back(i) = -1 ENDDO good_s2_1_event = .FALSE. !if good event detected = true good_s2_1 = 0 !counts number of good events DO i = 0, 47 DO j = 48, 63 IF ( hit( i ) .AND. hit( j ) ) THEN ix = INT( 10.0 * e( i ) + rand(iflag) ) !multiply by 10 to change bin size iy = INT( 10.0 * e( j ) + rand(iflag) ) !multiply by 10 to change bin size CALL inc2d( 3050, ix, iy ) ediff = 100.0 * ( e( i ) - e( j ) ) + 2048.0 + rand(iflag) CALL inc1d( 3060, INT( ediff ) ) !front e(i) - back e(j) IF ( ediff.GE.w(0) .AND. ediff.LE.w(1) !set to w(0)=2000, w(1)=2100 + .AND. good_s2_1.LT.47 ) THEN CALL inc2d( 3051, ix, iy ) !good front hit e(i) vs back hit e(j) CALL inc1d( 3061, INT( ediff ) ) !good front e(i) - back e(j) good_s2_1_event = .TRUE. good_s2_1 = good_s2_1 + 1 good_s2_1_front( good_s2_1 - 1 ) = i good_s2_1_back( good_s2_1 - 1 ) = j ENDIF ENDIF ENDDO ENDDO DO i = 0, 63 hit(i) = .FALSE. ENDDO IF ( good_s2_1.GT.0 ) THEN DO i = 0, good_s2_1 - 1 hit( good_s2_1_front(i) ) = .TRUE. hit( good_s2_1_back(i) ) = .TRUE. ENDDO ENDIF C----67---------------------------------------------------------------72------80 C Select good S2-E events ediff = 0.0 DO i = 0, 47 good_s2_2_front(i) = -1 good_s2_2_back(i) = -1 ENDDO good_s2_2_event = .FALSE. good_s2_2 = 0 DO i = 64, 111 DO j = 112, 127 IF ( hit( i ) .AND. hit( j ) ) THEN ix = INT( 10.0 * e( i ) + rand(iflag) ) !multiply by 10 to change bin size iy = INT( 10.0 * e( j ) + rand(iflag) ) !multiply by 10 to change bin size CALL inc2d( 3052, ix, iy ) ediff = 100.0 * ( e( i ) - e( j ) ) + 2048.0 + rand(iflag) CALL inc1d( 3062, INT( ediff ) ) IF ( ediff.GE.w(2) .AND. ediff.LE.w(3) + .AND. good_s2_2.LT.47 ) THEN CALL inc2d( 3053, ix, iy ) CALL inc1d( 3063, INT( ediff ) ) good_s2_2_event = .TRUE. good_s2_2 = good_s2_2 + 1 good_s2_2_front( good_s2_2 - 1 ) = i good_s2_2_back( good_s2_2 - 1 ) = j ENDIF ENDIF ENDDO ENDDO DO i = 64, 127 hit(i) = .FALSE. ENDDO IF ( good_s2_2.GT.0 ) THEN DO i = 0, good_s2_2 - 1 hit( good_s2_2_front(i) ) = .TRUE. hit( good_s2_2_back(i) ) = .TRUE. ENDDO ENDIF C----67---------------------------------------------------------------72------80 C Good S2 multiplicity CALL inc1d( 3006, good_s2_1 + 3000 ) CALL inc1d( 3006, good_s2_2 + 3100 ) C----67---------------------------------------------------------------72------80 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C CHANGE EVERYTHING FROM HERE!!!! C Detector annulus # versus laboratory energy DO i = 0, 47 IF ( hit( i ) ) THEN ix = INT( 10.0 * e( i ) + rand(iflag) ) !multiply by 10 to change bin size iy = s2order( i ) !puts channel number in order of inside to outside strip CALL inc2d( 4000, ix, iy ) !energy vs annulus strip C IF ( good_s2_1.EQ.1 .AND. C + data(i+1000).GE.w(8) .AND. data(i+1000).LE.w(9) ) THEN C CALL inc2d( 4002, ix, iy ) C ENDIF ENDIF ENDDO DO i = 64, 111 IF ( hit( i ) ) THEN ix = INT( 10.0 * e( i ) + rand(iflag) ) !multiply by 10 to change bin size iy = s2order( i - 64 ) CALL inc2d( 4000, ix, iy + 48 ) C IF ( good_s2_2.EQ.1 .AND. C + data(i+1000).GE.w(10) .AND. data(i+1000).LE.w(11) ) THEN C CALL inc2d( 4002, ix, iy + 48 ) C ENDIF ENDIF ENDDO C----67---------------------------------------------------------------72------80 C Select "proton" (change) events (MSL type S2 telescope) de1 = 0.0 IF ( good_s2_1.EQ.1 ) THEN i = good_s2_1_front( 0 ) !0 = good_s2_1-1 ix = i de1 = e(i) !energy of front strip delE ENDIF e1 = 0.0 IF ( good_s2_2.EQ.1 ) THEN i = good_s2_2_front( 0 ) e1 = e(i) !energy of front strip E ENDIF IF ( de1 .GT. 0.2 .AND. e1 .GT. 0.2 ) THEN !threshold 200 keV CALL inc2d( 4010, INT( 5.0*e1+0.5), INT( 5.0*de1+0.5) ) !change c(8) since the current values are for protons !c(9) = 1-5 and stretches spectrum pi = c(9) * ( ( de1 + e1 )**c(8) - ( e1 )**c(8) ) !particle ID function CALL inc1d( 4011, INT( pi + 0.5 ) ) CALL inc2d( 4012, INT( pi + 0.5 ), INT( 5.0*(de1+e1)+0.5) ) !particle ID vs total E e_lab = 0.0 C Select protons IF ( pi.GE.w(17) .AND. pi.LE.w(18) ) THEN !change w(17) and w(18) to select different particles e_lab = de1+e1 !total energy CALL inc1d( 4013, INT( 10.0*(e_lab)+0.5 ) ) C----67---------------------------------------------------------------72------80 C Detector annulus # versus laboratory energy iy = s2order( ix ) ix = INT( 10.0*(e_lab)+0.5 ) !multiply by 10 to change bin size CALL inc2d( 4004, ix, iy ) C e_x = elab2ex( e_lab, s2_1_theta( iy ) ) C ix = INT( 10.0 * e_x + 100.0 + rand(iflag) ) C CALL inc2d( 4005, ix, iy ) ENDIF ENDIF 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 ' WRITE( 6, 9010 ) sc_counter dt = FLOAT( scaler( 2 ) ) / 1000.0 DO i = 0, maxscalers-1 rate( i ) = FLOAT( scaler( i ) ) / dt ENDDO DO i = 0, maxscalers-1, 4 WRITE( 6, 9020 ) i, i+3, ( scaler(j), rate(j), j = i, i+3 ) ENDDO DO i = 0, 9 write( 6, * ) i, monitor(i) ENDDO write( 6, * ) '*** events: ', events 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, ')', 4(i10,1x,'(',F9.2,'/s)') ) 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 = 30) INTEGER epics_gid PARAMETER (epics_gid = 31) 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 C----67---------------------------------------------------------------72------80 FUNCTION s2order( channel ) INTEGER array( 0:63 ), s2order, channel DATA array / + 47, 45, 43, 41, 39, 37, 35, 33, 31, 29, 27, 25, 23, 21, 19, 17, + 15, 13, 11, 9, 7, 5, 3, 1, 0, 2, 4, 6, 8, 10, 12, 14, + 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46, + 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63 / s2order = array( channel ) RETURN C----67---------------------------------------------------------------72------80 END C----67---------------------------------------------------------------72------80 FUNCTION elab2ex( e_4, theta_4 ) REAL e_1, e_4, elab2ex, pi, theta_4, m_1, m_3, m_4, q, q_0 pi = 3.141592654 C 26Mg 25.982593 C 27Mg 26.984341 C 26Al 25.986892 C 27Al 26.981539 C d 2.014102 C p 1.007825 C C 2H(26Mg,27Mg)1H Q= +4.2188 MeV C 2H(26Al,27Al)1H Q= +10.8331 MeV C 4He(44Ti,47V)1H Q= -0.4105 C 4He(18Ne,21Na)1H Q= +2.6373 C 4he(23Na,26Mg)1H Q= +1.8207 m_1 = 22.989769 m_3 = 25.982593 m_4 = 1.007825 e_1 = 13.0 q_0 = 1.8207 theta_4 = theta_4 * pi / 180.0 q = ( (m_1*e_1) + (m_4*e_4) + (m_3*(e_4-e_1)) + - (2.0*SQRT(m_1*m_4*e_1*e_4)*cos(theta_4)) ) / m_3 elab2ex = q_0 - q RETURN C----67---------------------------------------------------------------72------80 END C----67---------------------------------------------------------------72------80 FUNCTION elab2ecm( e_lab, theta_lab ) REAL e_lab, elab2ecm, pi, leda_1_theta, theta_lab, m_1, m_2 C 21Ne C m_1 = 20.993847 C 21Na m_1 = 20.997655 m_2 = 1.007825 pi = 3.141592654 theta_lab = theta_lab * pi / 180.0 elab2ecm = ( e_lab * ( m_1 + m_2 ) ) + / ( 4.0 * m_1 * cos( theta_lab ) * cos( theta_lab ) ) RETURN C----67---------------------------------------------------------------72------80 END C----67---------------------------------------------------------------72------80 FUNCTION s2_1_theta( channel ) REAL array( 0:47 ), s2_1_theta INTEGER channel C Assumes target - s2 distance = 13cm DATA array / + 5.155, 5.369, 5.584, 5.798, 6.012, 6.226, 6.440, 6.653, + 6.867, 7.080, 7.293, 7.506, 7.719, 7.931, 8.143, 8.355, + 8.567, 8.778, 8.989, 9.200, 9.411, 9.622, 9.832, 10.042, + 10.252, 10.461, 10.670, 10.879, 11.087, 11.296, 11.504, 11.711, + 11.919, 12.126, 12.332, 12.539, 12.745, 12.950, 13.156, 13.361, + 13.566, 13.770, 13.974, 14.177, 14.381, 14.584, 14.786, 14.988 / s2_1_theta = array( channel ) RETURN C----67---------------------------------------------------------------72------80 END C----67---------------------------------------------------------------72------80 FUNCTION s2_3_theta( channel ) REAL array( 0:47 ), s2_3_theta INTEGER channel C Assumes target - s2 distance = 13cm DATA array / + 5.155, 5.369, 5.584, 5.798, 6.012, 6.226, 6.440, 6.653, + 6.867, 7.080, 7.293, 7.506, 7.719, 7.931, 8.143, 8.355, + 8.567, 8.778, 8.989, 9.200, 9.411, 9.622, 9.832, 10.042, + 10.252, 10.461, 10.670, 10.879, 11.087, 11.296, 11.504, 11.711, + 11.919, 12.126, 12.332, 12.539, 12.745, 12.950, 13.156, 13.361, + 13.566, 13.770, 13.974, 14.177, 14.381, 14.584, 14.786, 14.988 / s2_3_theta = array( channel ) RETURN C----67---------------------------------------------------------------72------80 END C----67---------------------------------------------------------------72------80 REAL FUNCTION de_1h_al( energy, thickness ) REAL energy, range(200), thickness DATA ( range( i ), i = 1, 200 ) / + 0.0008872,0.0023287,0.0033822,0.0045741,0.0059073,0.0073822, + 0.0089920,0.0107450,0.0126297,0.0146453,0.0167859,0.0190630, + 0.0214603,0.0239843,0.0266211,0.0293863,0.0322645,0.0352832, + 0.0383831,0.0416050,0.0449937,0.0484084,0.0519834,0.0557047, + 0.0594778,0.0633870,0.0674206,0.0715688,0.0758231,0.0801770, + 0.0846256,0.0891660,0.0937994,0.0986364,0.1035250,0.1084790, + 0.1136300,0.1188130,0.1241860,0.1295710,0.1350060,0.1406430, + 0.1464420,0.1522210,0.1581880,0.1641400,0.1702860,0.1765910, + 0.1828390,0.1892830,0.1957100,0.2023370,0.2091010,0.2160020, + 0.2228100,0.2298230,0.2369820,0.2440830,0.2513830,0.2588070, + 0.2663530,0.2740350,0.2815610,0.2893230,0.2972210,0.3052440, + 0.3131780,0.3215530,0.3296420,0.3379600,0.3464230,0.3550220, + 0.3634690,0.3721680,0.3809730,0.3898780,0.3988870,0.4080120, + 0.4172790,0.4262100,0.4353590,0.4445950,0.4539400,0.4634010, + 0.4729890,0.4823870,0.4923400,0.5018110,0.5116440,0.5215760, + 0.5315950,0.5417220,0.5519450,0.5622720,0.5727310,0.5829690, + 0.5938030,0.6041010,0.6148140,0.6255930,0.6364570,0.6474310, + 0.6584650,0.6696090,0.6808240,0.6921530,0.7035990,0.7152120, + 0.7264900,0.7385010,0.7498020,0.7616110,0.7734830,0.7854390, + 0.7974750,0.8095940,0.8217940,0.8340770,0.8464440,0.8589270, + 0.8714720,0.8841320,0.8968860,0.9097940,0.9225160,0.9358620, + 0.9484080,0.9616060,0.9747500,0.9880060,1.0013300,1.0147400, + 1.0282300,1.0418400,1.0554800,1.0692000,1.0830500,1.0969300, + 1.1109400,1.1250300,1.1391500,1.1533999,1.1677400,1.1821700, + 1.1966900,1.2113500,1.2263401,1.2405500,1.2559600,1.2701200, + 1.2852401,1.3001699,1.3153300,1.3304501,1.3456900,1.3609900, + 1.3763601,1.3918900,1.4074000,1.4230100,1.4387701,1.4545100, + 1.4704300,1.4863200,1.5023900,1.5184400,1.5346500,1.5508699, + 1.5672300,1.5836700,1.6001199,1.6167200,1.6333600,1.6500900, + 1.6669300,1.6838599,1.7008600,1.7180200,1.7355300,1.7524199, + 1.7697901,1.7870600,1.8044300,1.8218600,1.8394200,1.8570400, + 1.8747300,1.8925000,1.9103400,1.9282600,1.9462500,1.9643199, + 1.9824600,2.0006700,2.0189500,2.0373099,2.0557499,2.0742500, + 2.0928299,2.1115999 / IF ( energy.LE.0.1 .OR. energy.GE.20.0 ) THEN de_1h_al = 0.0 RETURN ENDIF i = INT( 10.0 * energy ) dr = range( i+1 ) - range( i ) de = energy - FLOAT( 0.1 * i ) r = range( i ) + ( dr * de / 0.1 ) DO j = i, 200 IF ( range( j ).GE.r+thickness ) GOTO 100 ENDDO de_1h_al = 0.0 RETURN 100 CONTINUE de_1h_al = ( 0.1 * ( r+thickness - range( j-1 ) ) + / ( range( j ) - range( j-1 ) ) ) + + ( 0.1 * ( j - 1 ) ) - energy RETURN C----67---------------------------------------------------------------72------80 END C----67---------------------------------------------------------------72------80 REAL FUNCTION de_1h_cd2( energy, thickness ) REAL de, dr, energy, r, range(200), thickness DATA ( range( i ), i = 1, 200 ) / + 0.0011328,0.0026270,0.0041736,0.0060257,0.0081906,0.0106608, + 0.0134454,0.0165291,0.0199199,0.0236069,0.0275698,0.0318529, + 0.0364153,0.0412629,0.0463651,0.0517937,0.0574577,0.0634014, + 0.0695985,0.0761035,0.0828838,0.0898332,0.0971435,0.1046650, + 0.1124030,0.1204590,0.1287940,0.1372680,0.1460420,0.1550740, + 0.1643470,0.1738560,0.1837380,0.1936070,0.2038950,0.2143410, + 0.2249900,0.2360070,0.2471290,0.2584510,0.2701190,0.2819110, + 0.2940390,0.3062670,0.3188310,0.3315030,0.3444880,0.3578110, + 0.3710610,0.3847150,0.3984460,0.4124960,0.4268270,0.4411990, + 0.4558810,0.4708240,0.4858740,0.5011670,0.5166980,0.5325100, + 0.5483490,0.5644740,0.5808220,0.5974340,0.6141600,0.6310800, + 0.6482220,0.6655930,0.6832300,0.7009800,0.7188980,0.7370340, + 0.7553850,0.7739690,0.7928360,0.8117620,0.8308680,0.8501830, + 0.8697050,0.8893000,0.9091240,0.9289590,0.9489430,0.9691650, + 0.9896050,1.0102400,1.0310800,1.0521400,1.0734600,1.0951700, + 1.1166199,1.1384300,1.1604000,1.1825700,1.2049500,1.2275300, + 1.2503400,1.2733200,1.2965500,1.3200400,1.3441000,1.3674099, + 1.3915000,1.4155000,1.4398400,1.4643199,1.4890000,1.5138700, + 1.5389400,1.5642500,1.5897100,1.6154200,1.6421400,1.6676800, + 1.6940900,1.7203500,1.7469500,1.7736599,1.8005900,1.8277600, + 1.8550200,1.8825700,1.9102000,1.9381200,1.9661900,1.9944700, + 2.0228801,2.0515399,2.0804000,2.1108501,2.1392500,2.1689799, + 2.1982701,2.2281599,2.2579200,2.2880199,2.3183100,2.3486800, + 2.3793700,2.4101801,2.4410999,2.4723301,2.5036800,2.5352399, + 2.5668800,2.5988200,2.6309099,2.6631999,2.6956699,2.7283299, + 2.7611699,2.7965400,2.8283000,2.8624401,2.8954301,2.9293900, + 2.9631801,2.9972301,3.0314000,3.0659101,3.1003699,3.1352701, + 3.1700599,3.2051799,3.2405200,3.2760201,3.3115699,3.3474901, + 3.3833499,3.4196301,3.4559700,3.4924099,3.5291901,3.5660801, + 3.6030400,3.6403401,3.6777699,3.7153900,3.7531900,3.7910700, + 3.8292401,3.8715200,3.9072399,3.9476900,3.9852500,4.0250502, + 4.0636301,4.1033201,4.1425500,4.1823702,4.2220802,4.2621498, + 4.3022699,4.3426299,4.3831100,4.4238000,4.4646301,4.5056500, + 4.5468202,4.5883799 / IF ( energy.LE.0.1 .OR. energy.GE.20.0 ) THEN de_1h_cd2 = 0.0 RETURN ENDIF i = INT( 10.0 * energy ) dr = range( i+1 ) - range( i ) de = energy - FLOAT( 0.1 * i ) r = range( i ) + ( dr * de / 0.1 ) DO j = i, 200 IF ( range( j ).GE.r+thickness ) GOTO 100 ENDDO de_1h_cd2 = 0.0 RETURN 100 CONTINUE de_1h_cd2 = ( 0.1 * ( r+thickness - range( j-1 ) ) + / ( range( j ) - range( j-1 ) ) ) + + ( 0.1 * ( j - 1 ) ) - energy RETURN C----67---------------------------------------------------------------72------80 END C----67---------------------------------------------------------------72------80 REAL FUNCTION path_factor( angle ) REAL angle, pi DATA pi / 3.141592654 / path_factor = 1.0 / COS( ( 180.0 - angle ) * pi / 180.0 ) RETURN C----67---------------------------------------------------------------72------80 END C----67---------------------------------------------------------------72------80