/[PAMELA software]/tracker/ground/source/readraw/readraw_subroutines.f
ViewVC logotype

Annotation of /tracker/ground/source/readraw/readraw_subroutines.f

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (hide annotations) (download) (vendor branch)
Wed Mar 8 15:00:39 2006 UTC (18 years, 9 months ago) by pam-fi
Branch: MAIN, trk-ground
CVS Tags: R3v02, HEAD
Changes since 1.1: +0 -0 lines
First CVS release of tracker ground software (R3v02) 

1 pam-fi 1.1 ***...***...***...***...***...***...***...***...***...***...***...***...***...***...***...***
2     *
3     *
4     *
5     *
6     *
7     *
8     *
9     * 10/9/2005 modified by david fedele to include general variables
10     *
11     ***...***...***...***...***...***...***...***...***...***...***...***...***...***...***...***
12    
13     *.............................................................................
14     subroutine book_level0
15    
16    
17     include '../common/commontracker.f'
18     include '../common/level0.f'
19    
20    
21     c print*,'__________ booking LEVEL0 n-tuple __________'
22    
23     c LEVEL0 ntuple:
24     call HBNT(ntp_level0,'LEVEL0',' ')
25    
26     c*****************************************************
27     cccccc 10/9/2005 modified by david fedele
28     c call HBNAME(ntp_level0,'EVENT',good0
29     call HBNAME(ntp_level0,'GENERAL',good0
30     $ ,'GOOD0:L
31     $ ,NEV0:I'//
32     c*****************************************************
33     cccccc 10/9/2005 modified by david fedele
34     + ' ,WHICH_CALIB:I
35     $ ,SWCODE:I')
36     c*****************************************************
37     call HBNAME(ntp_level0,'CPU',pkt_type
38     $ ,'PKT_TYPE:I
39     $ ,PKT_NUM:I
40     $ ,OBT:I'//
41     c*****************************************************
42     cccccc 10/9/2005 modified by david fedele
43     c $ ,WICH_CALIB:I')
44     + ',CPU_CRC:L')
45     c*****************************************************
46     call HBNAME(ntp_level0,'HEADER',DAQmode !??? aggiustare il 12 con i block...
47     $ ,'DAQMODE(12):I::[0,31]
48     $ ,DSPNUMBER(12):I::[0,12]
49     $ ,DATALENGTH(12):I::[0,4095]
50     $ ,EVENTN(12):I
51     $ ,NCLUST(12):I::[0,7]
52     $ ,CUTC(12):I::[0,7]
53     $ ,CUTCL(12):I::[0,15]
54     $ ,ADDRCLUSTER(12,3):I::[0,1023]
55     $ ,SIGNCLUSTER(12,3):I::[0,4095]
56     $ ,FC(12):I::[0,3]
57     $ ,COMPRESSIONTIME(12):I::[0,255]
58     $ ,FL5(12):I::[0,3]
59     $ ,FL4(12):I::[0,3]
60     $ ,FL3(12):I::[0,3]
61     $ ,FL2(12):I::[0,3]
62     $ ,FL1(12):I::[0,3]
63     $ ,FL6(12):I::[0,3]
64     $ ,CHECKSUM(12):I::[0,255]'//
65     c*****************************************************
66     cccccc 10/9/2005 modified by david fedele
67     + ',CRC(12):L')
68     c*****************************************************
69     call HBNAME(ntp_level0,'DATA',TOTDATAlength
70     $ ,'TOTDATALENGTH:I::[0,49152]
71     $ ,DATATRACKER(TOTDATALENGTH):I::[0,6150]')
72     c $ ,DATATRACKER(TOTDATALENGTH):I')
73    
74     call HBNAME(ntp_level0,'TRAILER',PNUM
75     $ ,'PNUM(12):I::[0,5]
76     $ ,CMDNUM(12):I::[0,9]
77     $ ,BID(12):I::[1,2]
78     $ ,ALARM(12):I::[0,3]
79     $ ,ASWR(12):I::[0,65535]')
80    
81     c------------------------------------------------------
82     c create the routine to access the n-tuple
83     c------------------------------------------------------
84     c OPEN(10,FILE='../common/access_level0.f.temp',STATUS='UNKNOWN')
85     c call HUWFUN(10,ntp_level0,'access_level0',0,'B')
86     c CLOSE(10)
87    
88     return
89     end
90    
91    
92     *.............................................................................
93    
94     c*****************************************************
95     cccccc 10/9/2005 modified by david fedele
96     c$$$ subroutine init_level0
97     c$$$
98     c$$$ include '../common/level0.f'
99     c$$$
100     c$$$
101     c$$$ do i=1, nviews
102     c$$$
103     c$$$ DAQmode(i) = 0
104     c$$$ DSPnumber(i) = 0
105     c$$$ eventn(i) = 0
106     c$$$ nclust(i) = 0
107     c$$$ cutc(i) = 0
108     c$$$ cutcl(i) = 0
109     c$$$ addrcluster(i,1) = 0
110     c$$$ signcluster(i,1) = 0
111     c$$$ addrcluster(i,2) = 0
112     c$$$ signcluster(i,2) = 0
113     c$$$ addrcluster(i,3) = 0
114     c$$$ signcluster(i,3) = 0
115     c$$$ fc(i) = 0
116     c$$$ compressiontime(i) = 0
117     c$$$ fl5(i) = 0
118     c$$$ fl4(i) = 0
119     c$$$ fl3(i) = 0
120     c$$$ fl2(i) = 0
121     c$$$ fl1(i) = 0
122     c$$$ fl6(i) = 0
123     c$$$ checksum(i) = 0
124     c$$$ DATAlength(i) = 0
125     c$$$ pnum(i)= 0
126     c$$$ cmdnum(i)= 0
127     c$$$ bid(i) = 1
128     c$$$ alarm(i)= 0
129     c$$$ aswr(i) = 0
130     c$$$ enddo
131     c$$$
132     c$$$ TOTDATAlength = 0
133     c$$$c good0=.true.
134     c$$$
135     c$$$ return
136     c$$$ end
137     c$$$
138     c$$$*.............................................................................
139     c$$$
140     c$$$ subroutine fill_view(i)
141     c$$$c -----------------------------------------------------
142     c$$$c fill variables related to view i
143     c$$$c which will be stored in the level0 nt-ple
144     c$$$c at the end of loop on views
145     c$$$c ----------------------------------------------------
146     c$$$
147     c$$$ include '../common/commontracker.f'
148     c$$$ include '../common/level0.f'
149     c$$$ include '../common/common_readraw.f'
150     c$$$
151     c$$$ DAQmode(i) = DAQmode_dat
152     c$$$ DSPnumber(i) = DSPnumber_dat
153     c$$$ eventn(i) = eventn_dat
154     c$$$ nclust(i) = nclust_dat
155     c$$$ cutc(i) = cutc_dat
156     c$$$ cutcl(i) = cutcl_dat
157     c$$$ addrcluster(i,1) = addrcluster_dat(1)
158     c$$$ signcluster(i,1) = signcluster_dat(1)
159     c$$$ addrcluster(i,2) = addrcluster_dat(2)
160     c$$$ signcluster(i,2) = signcluster_dat(2)
161     c$$$ addrcluster(i,3) = addrcluster_dat(3)
162     c$$$ signcluster(i,3) = signcluster_dat(3)
163     c$$$ fc(i) = fc_dat
164     c$$$ compressiontime(i) = compressiontime_dat
165     c$$$ fl5(i) = fl5_dat
166     c$$$ fl4(i) = fl4_dat
167     c$$$ fl3(i) = fl3_dat
168     c$$$ fl2(i) = fl2_dat
169     c$$$ fl1(i) = fl1_dat
170     c$$$ fl6(i) = fl6_dat
171     c$$$ checksum(i) = checksum_dat
172     c$$$ DATAlength(i) = datalength_dat
173     c$$$
174     c$$$c -----------------------------------------------------------------------
175     c$$$c filling TRAILER variables
176     c$$$c ----------------------------------------------------------------------
177     c$$$
178     c$$$ pnum(i)= pnum_dat
179     c$$$ cmdnum(i)= cmdnum_dat
180     c$$$ bid(i) = bid_dat
181     c$$$ alarm(i)= alarm_dat
182     c$$$ aswr(i) = aswr_dat
183     c$$$
184     c$$$
185     c$$$ do idat=1,datalength_dat
186     c$$$ id = TOTDATAlength + idat
187     c$$$ datatracker(id) = b_tra(idat)
188     c$$$ enddo
189     c$$$ TOTDATAlength = TOTDATAlength + datalength_dat
190     c$$$
191     c$$$ return
192     c$$$ end
193     c$$$
194     c***********************************************************
195     *.............................................................................
196    
197     subroutine book_histos
198    
199     include '../common/commontracker.f'
200     include '../common/calib.f'
201    
202     character*64 title !histos title
203    
204     c badstrip, pedestal and sigma histograms booking for each view:
205    
206     c print*,' '
207     c print*,'-------- booking histos -------'
208     c print*,' '
209    
210     do i=1,nviews
211     402 format('Online BAD strips, view: ',i2)
212     write(title,402) i
213     c print*,title
214     call HBOOK1(id_hi_bad+i,title,nstrips_view
215     $ ,0.5,nstrips_view+0.5,0.)
216    
217     403 format('Online PEDESTAL values, view: ',i2)
218     write(title,403) i
219     c print*,title
220     call HBOOK1(id_hi_ped+i,title,nstrips_view
221     $ ,0.5,nstrips_view+0.5,0.)
222    
223     404 format('Online SIGMA values, view: ',i2)
224     write(title,404) i
225     c print*,title
226     call HBOOK1(id_hi_sig+i,title,nstrips_view
227     $ ,0.5,nstrips_view+0.5,0.)
228     enddo
229    
230     return
231     end
232    
233     *.............................................................................
234     subroutine fill_histos
235    
236    
237     include '../common/commontracker.f'
238     include '../common/calib.f'
239     include '../common/common_readraw.f'
240    
241     do iview=1,nviews
242     do j=1,nstrips_view
243     call HFILL(id_hi_bad+iview,float(j),0.
244     $ ,float(DSPbad_o(iview,j)))
245     call HFILL(id_hi_ped+iview,float(j),0.,DSPped_o(iview,j))
246     call HFILL(id_hi_sig+iview,float(j),0.,DSPsig_o(iview,j))
247     enddo
248     c print*,'****',DSPsig_o(iview,2000)
249     enddo
250    
251    
252     return
253     end
254    
255    
256    
257     *.............................................................................
258     subroutine book_tof
259    
260    
261     c include '../common/commontracker.f'
262     include '../tof/common_tof.f'
263    
264    
265     c print*,'__________ booking TOF n-tuple __________'
266    
267     c LEVEL0 ntuple:
268     call HBNT(ntp_tof,'TOF',' ')
269    
270     call HBNAME(ntp_tof,'EVENT',good,'GOOD:L,NEV_TRK:I')
271     call HBNAME(ntp_tof,'TRIGGER',trig_evcount
272     $ ,'TRIG_EVCOUNT:I
273     $ ,PMTPL(3):I
274     $ ,TRIGRATE(6):I
275     $ ,DLTIME(2):I
276     $ ,S4CALCOUNT(2):I
277     $ ,PMTCOUNT1(24):I
278     $ ,PMTCOUNT2(24):I
279     $ ,PATTERNBUSY(3):I
280     $ ,PATTERNTRIG(6):I
281     $ ,TRIGCONF:I')
282     call HBNAME(ntp_tof,'TOF',tdcid
283     $ ,'TDCID(12):I
284     $ ,EVCOUNT(12):I
285     $ ,TDCMASK(12):I
286     $ ,ADC(4,12):I
287     $ ,TDC(4,12):I
288     $ ,TEMP1(12):I
289     $ ,TEMP2(12):I')
290    
291    
292     return
293     end
294    
295    
296     *.............................................................................
297     subroutine init_tof
298    
299     include '../tof/common_tof.f'
300    
301    
302     do i=1,12
303     tdcid(i)=0
304     evcount(i)=0
305     tdcmask(i)=0
306     temp1(i)=0
307     temp2(i)=0
308     do j=1,4
309     adc(j,i)=0
310     tdc(j,i)=0
311     enddo
312     enddo
313    
314     return
315     end
316    
317     *.............................................................................
318    
319     c---------------------------------------------------------------------------
320     c add a entry in the calibration list file DW_DATE_NUM_calib.txt, which
321     c contains the list of the calibration file name to be associated to
322     c each event
323     c---------------------------------------------------------------------------
324     subroutine add_calib_entry
325    
326     include '../common/commontracker.f'
327     include '../common/common_readraw.f'
328    
329     111 format(i5,' ',a25)
330    
331     n_cal_list=n_cal_list+1 !calibration file identifier in the calibration list file
332    
333     write(lun_calib_list,111) n_cal_list
334     $ ,file_calib
335    
336    
337     return
338     end
339    
340    
341     ***...***...***...***...***...***...***...***...***...***...***...***...***...***...***...***
342     *
343     *
344     *
345     *
346     *
347     *
348     *
349     *
350     ***...***...***...***...***...***...***...***...***...***...***...***...***...***...***...***
351    
352     c*****************************************************
353     c$$$cccccc 10/9/2005 modified by david fedele
354     c$$$ subroutine search_trk_header(runerror,ffd)
355     c$$$C.............................................................
356     c$$$C Search for a valid tracker DSP header (=>one view)
357     c$$$C and return the type of header
358     c$$$C.............................................................
359     c$$$
360     c$$$ include '../common/commontracker.f'
361     c$$$ include '../common/common_readraw.f'
362     c$$$
363     c$$$ integer ffd !input file descriptor
364     c$$$ integer runerror !readevent error flag
365     c$$$
366     c$$$c--------------------------------------------------
367     c$$$c N.B.13 bit packing is done for each DSP header+datablock,
368     c$$$C so each DSP 13 bit
369     c$$$c first word starts at the beginnig of a 16 bit word
370     c$$$c--------------------------------------------------
371     c$$$ 9100 continue
372     c$$$ runerror=0 !error flag initialization
373     c$$$ checkheader=0
374     c$$$
375     c$$$c--------------------------------------------------
376     c$$$c looks for a DSP header beginning
377     c$$$C (a word beginning with 1110)
378     c$$$c--------------------------------------------------
379     c$$$ call findstart(runerror,ffd)
380     c$$$
381     c$$$ if(runerror.eq.1) goto 200
382     c$$$ if(runerror.eq.-1)then
383     c$$$ runerror=1 !in this case I dont want the
384     c$$$ !the program to crash
385     c$$$ goto 200
386     c$$$ endif
387     c$$$c--------------------------------------------------
388     c$$$c the first word could be a DSP header first word:
389     c$$$C reads 13 8-bit words and
390     c$$$c writes them in 16 13-bit words to check for all
391     c$$$C DSP header features
392     c$$$c--------------------------------------------------
393     c$$$ runerror=0
394     c$$$
395     c$$$ call hunpacker(header,runerror,ffd)
396     c$$$
397     c$$$ if(runerror.eq.1) goto 200
398     c$$$c if(runerror.eq.-1) goto 200
399     c$$$ if(runerror.eq.-1)then
400     c$$$ runerror=1 !in this case I dont want the
401     c$$$ !the program to crash
402     c$$$ goto 200
403     c$$$ endif
404     c$$$c--------------------------------------------------
405     c$$$c extracts and controls header:
406     c$$$c--------------------------------------------------
407     c$$$C last header word must be:
408     c$$$c |0001|1100|0000|0000| for acquisition
409     c$$$c |0001|1111|1111|1111| for calibration
410     c$$$c--------------------------------------------------
411     c$$$ if(iand(header(16),z'ffff').eq.z'1c00') then !last header
412     c$$$ checkheader=2 ! event
413     c$$$ elseif(iand(header(16),z'ffff').eq.z'1fff') then !last header
414     c$$$ checkheader=3 ! calibration packet
415     c$$$ else
416     c$$$ checkheader=1 ! not a valid DSP header
417     c$$$ endif
418     c$$$c--------------------------------------------------
419     c$$$c first header word must be:
420     c$$$c |0001|110x|xxxx|xxxx|
421     c$$$c--------------------------------------------------
422     c$$$ if(iand(header(1),z'fe00').ne.z'1c00')
423     c$$$ $ checkheader=1 !not a valid DSP header
424     c$$$c--------------------------------------------------
425     c$$$c intermediate header words must be:
426     c$$$c |0001|010x|xxxx|xxxx|
427     c$$$c--------------------------------------------------
428     c$$$ do i=2,15
429     c$$$ if(iand(header(i),z'fc00').ne.z'1400')
430     c$$$ $ checkheader=1 !not a valid DSP header
431     c$$$ enddo
432     c$$$c--------------------------------------------------
433     c$$$c if checkheader = 1
434     c$$$c then this is not a DSP header (or some
435     c$$$c noise lurks around) so go a word ahead and
436     c$$$c try again
437     c$$$c--------------------------------------------------
438     c$$$ if(checkheader.eq.1) then
439     c$$$ call skipbyte(ffd)
440     c$$$ goto 9100
441     c$$$ endif
442     c$$$ 200 continue
443     c$$$ end
444     c$$$
445     c$$$*.............................................................
446     c$$$
447     c$$$ subroutine unpack_calibration(runerror,ffd)
448     c$$$*.............................................................
449     c$$$* decode calibration data
450     c$$$* header + data(PED SIG BAD) + trailer
451     c$$$*............................................................
452     c$$$ include '../common/commontracker.f'
453     c$$$ include '../common/common_readraw.f'
454     c$$$ include '../common/calib.f'
455     c$$$
456     c$$$ integer ffd !input file descriptor
457     c$$$ integer runerror !readevent error flag
458     c$$$c buffer temporanei
459     c$$$ integer*2 templ(nstrips_ladder)
460     c$$$ real*4 tempf(nstrips_ladder)
461     c$$$
462     c$$$
463     c$$$ 12 format(z4)
464     c$$$
465     c$$$*-----------------------------------------------------------
466     c$$$* HEADER
467     c$$$* (N.B. during test 2003 the header of calibration packets
468     c$$$* was only partially filled)
469     c$$$*-----------------------------------------------------------
470     c$$$ DAQmode_cal = ishft(iand(header(1),z'03f0'),-4)
471     c$$$ DSPnumber_cal = iand(header(1),z'000f')
472     c$$$ dataword = ior(ishft(iand(header(2),z'03ff')
473     c$$$ $ ,10),iand(header(3),z'03ff'))
474     c$$$ calibrationnumber = ior(ishft(iand(header(4)
475     c$$$ $ ,z'03ff'),10),iand(header(5),z'03ff'))
476     c$$$ ff = ishft(iand(header(15),z'0300'),-8)
477     c$$$ checksum_cal = iand(header(15),z'00ff')
478     c$$$
479     c$$$ runerror=0
480     c$$$ call readtrailer(trailer,runerror,ffd)
481     c$$$c-----------------------------------------------------------
482     c$$$c the cheacksum is a 8-bit word calculated as the
483     c$$$c XOR of the 16-bit data words,
484     c$$$c hence the XOR between the two halfs
485     c$$$C----------------------------------------------------------
486     c$$$ do il=1,3 !loop on ladders
487     c$$$
488     c$$$ call readped(tempf,runerror,ffd)
489     c$$$ do is=1,nstrips_ladder
490     c$$$ iss=is+nstrips_ladder*(il-1)
491     c$$$ DSPped_o(DSPnumber_cal,iss)=tempf(is)
492     c$$$c print*,il,iss,DSPped_o(DSPnumber,iss)
493     c$$$ enddo
494     c$$$
495     c$$$ call readsig(tempf,runerror,ffd)
496     c$$$ do is=1,nstrips_ladder
497     c$$$ iss=is+nstrips_ladder*(il-1)
498     c$$$ DSPsig_o(DSPnumber_cal,iss)=tempf(is)
499     c$$$c print*,DSPsig_o(DSPnumber,iss)
500     c$$$ enddo
501     c$$$
502     c$$$ call readbad(templ,runerror,ffd)
503     c$$$ do is=1,nstrips_ladder
504     c$$$ iss=is+nstrips_ladder*(il-1)
505     c$$$ DSPbad_o(DSPnumber_cal,iss)=templ(is)
506     c$$$c print*,il,is,iss,DSPbad_o(DSPnumber,iss)
507     c$$$ enddo
508     c$$$
509     c$$$C//// CAPIRE PERCHE` NON C'E` LA PAROLA DI FINE LADDER \\\\
510     c$$$c call readeol(word,runerror,ffd)
511     c$$$ 11 format(i1,' ',z4)
512     c$$$ call readtrailer(trailer,runerror,ffd)
513     c$$$
514     c$$$c print*,'fine ladder' !???
515     c$$$
516     c$$$ enddo !end loop on ladders
517     c$$$
518     c$$$ return
519     c$$$ end
520     c$$$*.............................................................
521     c$$$
522     c$$$ subroutine unpack_data(runerror,ffd)
523     c$$$*.............................................................
524     c$$$* decode event data
525     c$$$* header + data + trailer
526     c$$$*............................................................
527     c$$$ include '../common/commontracker.f'
528     c$$$ include '../common/common_readraw.f'
529     c$$$ include '../common/level0.f'
530     c$$$
531     c$$$ integer ffd !input file descriptor
532     c$$$ integer runerror !readevent error flag
533     c$$$ integer l_tra
534     c$$$
535     c$$$
536     c$$$ 12 format(z4)
537     c$$$
538     c$$$*-----------------------------------------------------------
539     c$$$* HEADER
540     c$$$*-----------------------------------------------------------
541     c$$$
542     c$$$ DAQmode_dat = ishft(iand(header(1),z'03f0'),-4)
543     c$$$ DSPnumber_dat = iand(header(1),z'000f')
544     c$$$C ------------------------------------------------------
545     c$$$c words 2 and 3 give tshe number of transmitted 16-bit
546     c$$$c words ( 13 header words + data )
547     c$$$c NB: data are packed from 13-bit to 16-bit words,
548     c$$$c so the stream is complited with zeros in order to have
549     c$$$c a number of bits multiple of 16
550     c$$$ l_tra = ior(ishft(iand(header(2),z'03ff')
551     c$$$ $ ,10),iand(header(3),z'03ff'))
552     c$$$ l_tra=l_tra-13
553     c$$$C ------------------------------------------------------
554     c$$$ eventn_dat = ior(ishft(iand(header(4),z'03ff')
555     c$$$ $ ,10),iand(header(5),z'03ff'))
556     c$$$ nclust_dat = ishft(iand(header(6),z'0380'),-7)
557     c$$$ cutc_dat = ishft(iand(header(6),z'0070'),-4)
558     c$$$ cutcl_dat = iand(header(6),z'000f')
559     c$$$ addrcluster_dat(1) = iand(header(7),z'03ff')
560     c$$$ signcluster_dat(1) = iand(header(8),z'03ff')
561     c$$$ addrcluster_dat(2) = iand(header(9),z'03ff')
562     c$$$ signcluster_dat(2) = iand(header(10),z'03ff')
563     c$$$ addrcluster_dat(3) = iand(header(11),z'03ff')
564     c$$$ signcluster_dat(3) = iand(header(12),z'03ff')
565     c$$$ fc_dat = ishft(iand(header(13),z'0300'),-8)
566     c$$$ compressiontime_dat = iand(header(13),z'00ff')
567     c$$$ fl5_dat = ishft(iand(header(14),z'0300'),-8)
568     c$$$ fl4_dat = ishft(iand(header(14),z'0300'),-6)
569     c$$$ fl3_dat = ishft(iand(header(14),z'0300'),-4)
570     c$$$ fl2_dat = ishft(iand(header(14),z'0300'),-2)
571     c$$$ fl1_dat = iand(header(14),z'0300')
572     c$$$ fl6_dat = ishft(iand(header(15),z'0300'),-8)
573     c$$$ checksum_dat = iand(header(15),z'00ff')
574     c$$$c-----------------------------------------------------------
575     c$$$c the cheacksum is a 8-bit word calculated as the
576     c$$$c XOR of the 16-bit data words,
577     c$$$c hence the XOR between the two halfs
578     c$$$C----------------------------------------------------------
579     c$$$ runerror=0
580     c$$$ call dunpacker(l_tra,b_tra,runerror,ffd)
581     c$$$ nqualcosa = (real(l_tra))/13*16
582     c$$$ xx = b_tra(nqualcosa)
583     c$$$ if (xx.eq.0) nqualcosa=nqualcosa -1
584     c$$$ datalength_dat= nqualcosa
585     c$$$
586     c$$$
587     c$$$
588     c$$$ 11 format(i1,' ',z4)
589     c$$$ call readtrailer(trailer,runerror,ffd)
590     c$$$
591     c$$$***************************************************************
592     c$$$* TRAILER *
593     c$$$***************************************************************
594     c$$$
595     c$$$ pnum_dat=ishft(iand(trailer(1),z'f000'),-12)
596     c$$$ cmdnum_dat=ishft(iand(trailer(1),z'0f00'),-8)
597     c$$$ bid1_dat=ishft(iand(trailer(1),z'00c0'),-6)
598     c$$$ bid2_dat=ishft(iand(trailer(1),z'0030'),-4)
599     c$$$ bid3_dat=ishft(iand(trailer(1),z'000c'),-2)
600     c$$$ bid4_dat=iand(trailer(1),z'0003')
601     c$$$ bid5_dat=ishft(iand(trailer(2),z'c000'),-14)
602     c$$$ bid6_dat=ishft(iand(trailer(2),z'3000'),-12)
603     c$$$ bid7_dat=ishft(iand(trailer(2),z'0c00'),-10)
604     c$$$ alarm_dat=ishft(iand(trailer(2),z'0300'),-8)
605     c$$$ aswr_dat=ior(ishft(iand(trailer(2),z'00ff'),8)
606     c$$$ $ ,ishft(iand(trailer(3),z'ff00'),-8))
607     c$$$ crc_dat=iand(trailer(3),z'00ff')
608     c$$$
609     c$$$ bid_dat_sum = (bid1_dat + bid2_dat + bid3_dat + bid4_dat +
610     c$$$ & bid5_dat + bid6_dat + bid7_dat)
611     c$$$
612     c$$$ bid_dat = bid_dat_sum/7
613     c$$$
614     c$$$ if (bid_dat.ne.1.and.bid_dat.ne.2) then
615     c$$$ write(*,*) '*** *** *** *** *** *** *** *** *** ***'
616     c$$$ write (*,*) 'unpack_data: TRAILER PACKET CORRUPTED'
617     c$$$ write(*,*) '*** *** *** *** *** *** *** *** *** ***'
618     c$$$ endif
619     c$$$ if (mod(bid_dat_sum,7).ne.0) then
620     c$$$ bid_dat = 0
621     c$$$ write(*,*) '*** *** *** *** *** *** *** *** *** ***'
622     c$$$ write (*,*) 'unpack_data: TRAILER PACKET CORRUPTED'
623     c$$$ write(*,*) '*** *** *** *** *** *** *** *** *** ***'
624     c$$$ endif
625     c$$$
626     c$$$ if (alarm_dat.eq.3) then
627     c$$$ write(*,*) '*** *** *** *** *** *** *** *** *** ***'
628     c$$$ write(*,*) 'unpack_data: AQUISITION ALARM'
629     c$$$ write(*,*) '*** *** *** *** *** *** *** *** *** ***'
630     c$$$
631     c$$$ endif
632     c$$$
633     c$$$ if (alarm_dat.ne.3.and.alarm_dat.ne.0) then
634     c$$$ write(*,*) '*** *** *** *** *** *** *** *** *** ***'
635     c$$$ write(*,*) 'unpack_data: TRAILER PACKET CORRUPTED'
636     c$$$ write(*,*) '*** *** *** *** *** *** *** *** *** ***'
637     c$$$
638     c$$$ endif
639     c$$$
640     c$$$
641     c$$$ return
642     c$$$ end
643     c*****************************************************************
644    
645     ***...***...***...***...***...***...***...***...***...***...***...***...***...***...***...***
646     *
647     *
648     *
649     *
650     *
651     *
652     *
653     *
654     ***...***...***...***...***...***...***...***...***...***...***...***...***...***...***...***
655     ****************************************************************
656     *---------------------------------------------------------------
657     * |
658     * |some usefull routine to manipulate strings
659     * |
660     *---------------------------------------------------------------
661     ****************************************************************
662    
663     integer function length(str)
664     c return the string length without the blanks characters
665    
666     implicit integer (k-l)
667     character *(*) str
668    
669     lmax=len(str)
670    
671     c search the last non blank character
672     doi=lmax,1,-1
673     if(str(i:i).ne.' ')then
674     length=i
675     return
676     end if
677     end do
678    
679     length=lmax
680    
681     return
682     end
683    
684    
685    
686     subroutine right(str,nch,res)
687     c return the right string portion
688    
689     implicit integer (k-l)
690     character *(*) str,res
691    
692     l=length(str)
693     res=str(l-nch+1:l)
694    
695     return
696     end
697    
698    
699    
700     subroutine intstr(num,str,l)
701     c translate a integer value into string
702    
703     implicit integer(k-l)
704     character *(*)str
705     character *1 cifra(10)
706     logical segno
707    
708     data cifra /'0','1','2','3','4','5','6','7','8','9'/
709    
710     lun=len(str)
711     if(lun.gt.30)stop
712     segno=.false.
713    
714     c check the number sign
715     if(num.lt.0)then
716     segno=.true.
717     num=abs(num)
718     end if
719    
720     c translate the integer num
721     doj=1,lun
722     n=num/10**(lun-j)
723     num=num-(n*10**(lun-j))
724     str(j:j)=cifra(n+1)
725     end do
726    
727     c if the str length is fixed (l)
728     if(l.ne.0)then
729     call right(str,l,str)
730     str=str(1:l)
731     return
732     end if
733    
734     c else delete zero characters
735     l=lun
736     10 if(str(1:1).ne.'0')goto 20
737     str(1:l-1)=str(2:l)
738     l=l-1
739     goto 10
740    
741     20 if(segno)then
742     str(2:l+1)=str(1:l)
743     str(1:1)='-'
744     str=str(1:l+1)
745     else
746     str=str(1:l)
747     end if
748    
749     return
750     end

  ViewVC Help
Powered by ViewVC 1.1.23