PAASS
Software suite to Acquire and Analyze Data from Pixie16
scanor.f
Go to the documentation of this file.
1 C$PROG SCANOR - SCANOR - Supports VME-clock & user-data-files UDF's
2 C
3 C ******************************************************************
4 C From WT Milner, JR Beene, et al at HRIBF - last modified 02/12/05
5 C ******************************************************************
6 C
7  IMPLICIT NONE
8 C
9 C
10 C ------------------------------------------------------------------
11  common/lll/ mssg(28),namprog(2),logut,logup,lisflg,msgf
12  INTEGER*4 MSSG,NAMPROG,LOGUT,LOGUP
13  CHARACTER*4 LISFLG,MSGF
14  CHARACTER*112 CMSSG
15  equivalence(cmssg,mssg)
16 C ------------------------------------------------------------------
17  common/ml01/ iwd(20),lwd(2,40),ityp(40),nf,nter
18  INTEGER*4 IWD, LWD, ITYP, NF,NTER
19 C ------------------------------------------------------------------
20  common/ml02/ iwdraw(20)
21  INTEGER*4 IWDRAW
22 C ------------------------------------------------------------------
23  common/sc01/ namcmd(20)
24  INTEGER*4 NAMCMD
25  CHARACTER*4 CNAMCMD(20)
26  equivalence(cnamcmd,namcmd)
27 C ------------------------------------------------------------------
28  common/sc03/ luc(10)
29  INTEGER*4 LUC
30 C ------------------------------------------------------------------
31  common/sc04/ jcnf,ihedn,mbfl
32  INTEGER*4 IHEDN,MBFL
33  CHARACTER*4 JCNF
34 C ------------------------------------------------------------------
35  common/sc05/ nhwh,lstl,lnby,maxip,nskip,iswab,lform
36  INTEGER*4 NHWH,LSTL,LNBY,MAXIP,NSKIP
37  CHARACTER*4 ISWAB,LFORM
38 C ------------------------------------------------------------------
39  common/sc12/ mem_style,shmid
40  CHARACTER*80 MEM_STYLE
41  INTEGER*4 SHMID
42 C ------------------------------------------------------------------
43  common/sc13/ lcon,lcmd,lin,lban,lhep
44  INTEGER*4 LCON,LCMD,LIN,LBAN,LHEP
45 C ------------------------------------------------------------------
46  common/sc14/ nbred,nbtop,icnf
47  INTEGER*4 NBRED,NBTOP
48  CHARACTER*4 ICNF
49 C ------------------------------------------------------------------
50  common/sc16/ indir(8192),intyp,inreci,luinf
51  INTEGER*4 INDIR, INRECI,LUINF
52  CHARACTER*4 INTYP
53 C ------------------------------------------------------------------
54  common/sc25/ cnams !CNAMS contains SHM filename
55  CHARACTER*80 CNAMS
56 C ------------------------------------------------------------------
57  common/orphas/ strbufevt,numbufevts,buf_num,lastevt,sumevts,
58  & beginevt
59 C
60  REAL*8 STRBUFEVT,NUMBUFEVTS,BUF_NUM,LASTEVT,SUMEVTS,
61  & beginevt
62 C ------------------------------------------------------------------
63  INTEGER*4 NAMCMDS(20)
64 C
65  INTEGER*4 RETN,IERR,STAT,I
66 C
67  INTEGER*4 NSEC,ISTAT,KIND,KERR
68 C
69  REAL*4 XV
70 C
71  CHARACTER*4 IDONE,KMD,KOM
72 C
73  equivalence(kmd,lwd(1,1)),(kom,iwd(1))
74 C
75  INTEGER*4 LUT,LUH,LUD
76  equivalence(lut,luc(1)),
77  & (luh,luc(6)),
78  & (lud,luc(9))
79 C
80  character*4 cnamcmds(20), ciwd(20)
81  equivalence(cnamcmds, namcmds), (ciwd,iwd)
82  DATA cnamcmds,ciwd/40*' '/
83 C
84  SAVE
85 C
86 C ------------------------------------------------------------------
87 C Initialize things
88 C ------------------------------------------------------------------
89 C Start the c++ unpacker interface CRT!
90  CALL startup()
91 C
92  CALL comset !Init some COMMON
93 C
94  CALL scanornit !Init for SCANOR
95 C
96 CX CALL SCANORMSG !Display "its NEW" message
97 C
98  GO TO 100
99 C
100 C ------------------------------------------------------------------
101 C Test "continue flags", switch input file/dev, etc
102 C ------------------------------------------------------------------
103 C
104 C !We get here via Ctrl/c
105  20 icnf='YES ' !Set "continue flag"
106  WRITE(cmssg,25)nbred
107  25 FORMAT('NUMBER OF BUFFERS PROCESSED =',i8)
108  CALL messlog(logut,logup)
109 C
110  IF(intyp.EQ.'SHM ') THEN !If SHM, report
111  CALL messlog(logut,logup)
112  WRITE(cmssg,26)
113  CALL messlog(logut,logup)
114  WRITE(cmssg,28)lastevt-beginevt, !#events sent
115  & sumevts, !#events seen
116  & lastevt-beginevt-sumevts !#events lost
117  CALL messlog(logut,logup)
118  ENDIF
119 C
120  26 FORMAT(' Total Events Seen Events Lost Events')
121  28 FORMAT(3f14.0)
122 C
123  CALL messlog(logut,logup)
124 
125  GO TO 50 !Switch to VDT input
126 C
127  30 lin=lcon
128  WRITE(cmssg,35)
129  CALL messlog(logut,logup)
130  35 FORMAT('Error reading cmd-file or cmd-file not assigned')
131  GO TO 100
132 C
133  40 WRITE(cmssg,45)
134  CALL messlog(logut,logup)
135  45 FORMAT('END OF COMMAND FILE')
136 C
137 C !We get here via ERROR
138  50 lin=lcon !Switch to VDT input
139  DO 52 i=1,20
140  cnamcmd(i)=' '
141  52 CONTINUE
142  cnamcmd(1)='CON:'
143  GO TO 100
144 C
145  55 IF(lin.NE.lcon) GO TO 1000 !Test for VDT input
146  backspace lcmd !Backspace cmd-file
147 C
148  60 lin=lcmd !Switch to cmd-file input
149  DO 65 i=1,6 !Restore cmd-file name
150  namcmd(i)=namcmds(i)
151  65 CONTINUE
152  GO TO 100
153 C
154  70 CALL nuinp(lcmd,ierr) !Define new cmd-file
155  DO 75 i=1,20 !Save file-name for later
156  namcmds(i)=namcmd(i)
157  75 CONTINUE
158 C
159  100 IF(lin.EQ.lcon) WRITE(logut,105) !Issue prompt if in VDT mode
160  105 FORMAT(' SCANOR->',$)
161  msgf=' '
162 C
163 C ------------------------------------------------------------------
164 C Read in and process the next command from LU "LIN"
165 C ------------------------------------------------------------------
166 C
167  READ(lin,110,err=30,end=40)iwd !Read next command from LIN
168  110 FORMAT(20a4)
169 C
170  WRITE(cmssg,115)(iwd(i),i=1,12),(namcmd(i),i=1,5)
171  IF(lin.NE.lcon) CALL messlog(logut,logup)
172  IF(lin.EQ.lcon) CALL messlog(0,logup)
173  115 FORMAT(12a4,' - FROM ',5a4)
174 C
175  CALL caseup1(iwd)
176 C
177  DO 120 i=1,20
178  iwdraw(i)=iwd(i)
179  120 CONTINUE
180 C
181  IF(kom.EQ.'CMDF') GO TO 70
182  IF(kom.EQ.'CMD ') GO TO 70
183  IF(kom.EQ.'CCON') GO TO 50
184  IF(kom.EQ.'CLCM') GO TO 55
185  IF(kom.EQ.'CCMD') GO TO 60
186 C
187  CALL caseup(iwd)
188 C
189  CALL gread(iwd,lwd,ityp,nf,1,80,nter)
190 C
191  IF(kmd.EQ.' ') GO TO 100 !Ignore blanks
192 C
193  CALL cmpsetup(idone,retn) !Check & do setup cmds
194  IF(idone.EQ.'YES ') THEN
195  IF(retn.EQ.50) GO TO 50
196  GO TO 100
197  ENDIF
198 C
199  CALL cmpinput(idone,retn) !Do tape, ldf, ipc open/close
200  IF(idone.EQ.'YES ') THEN !record-positions, reads, etc
201  IF(retn.EQ.50) GO TO 50
202  GO TO 100
203  ENDIF
204 C
205  CALL cmpread(idone,retn) !Check for read/display records
206  IF(idone.EQ.'YES ') THEN
207  IF(retn.EQ.50) GO TO 50
208  GO TO 100
209  ENDIF
210 C
211  IF(nter.NE.0) GO TO 1000
212 C
213  IF(kmd.EQ.'ZERO') GO TO 200
214  IF(kmd.EQ.'Z ') GO TO 210
215  IF(kmd.EQ.'SUM ') GO TO 220
216 C
217  IF(kmd.EQ.'WAIT') GO TO 230
218 C
219  IF(kmd.EQ.'GO ') GO TO 250
220  IF(kmd.EQ.'GOEN') GO TO 250
221 C
222  IF(kmd.EQ.'END ') GO TO 300
223  IF(kmd.EQ.'HUP ') GO TO 320
224  IF(kmd.EQ.'KILL') GO TO 340
225 C
226  GO TO 1000
227 C
228 C ------------------------------------------------------------------
229 C Zero the histogram file and reset all pointers
230 C ------------------------------------------------------------------
231 C
232  200 CALL hisnit(luh,'ZOT ')
233  icnf='NO '
234  jcnf='NO '
235  nbred=0
236  GO TO 100
237 C
238 C ------------------------------------------------------------------
239 C Zero individual histograms
240 C ------------------------------------------------------------------
241 C
242  210 CALL zottum(iwd)
243  GO TO 100
244 C
245 C ------------------------------------------------------------------
246 C Display/log histogram sumsd
247 C ------------------------------------------------------------------
248 C
249  220 CALL hissum_vm
250  GO TO 100
251 C
252 C ------------------------------------------------------------------
253 C Wait for a specified number of seconds
254 C ------------------------------------------------------------------
255 C
256  230 CALL milv(lwd(1,2),nsec,xv,kind,kerr)
257  IF(kerr.NE.0) GO TO 1000
258  IF(nsec.LT.1) nsec=1
259  IF(nsec.GT.300) nsec=300
260  CALL wait(nsec,2,istat)
261  GO TO 100
262 C
263 C ------------------------------------------------------------------
264 C Read and process records until you hit an abnormal condition
265 C ------------------------------------------------------------------
266 C
267  250 CALL doscan(retn)
268 C
269  IF(msgf.NE.' ') GO TO 20
270  IF(retn.EQ.0) GO TO 100
271  IF(retn.EQ.20) GO TO 20
272  IF(retn.EQ.50) GO TO 50
273  GO TO 50
274 C
275 C ------------------------------------------------------------------
276 C Process - END command
277 C ------------------------------------------------------------------
278 C
279  300 IF(lut.LT.0) GO TO 320 !END - Tape not open
280  kmd='CLOT' !END - Dismount no-unload
281  CALL tapopen(ierr)
282 C
283 C ------------------------------------------------------------------
284 C Windup - Windup - Windup - Windup - Windup - Windup - Windup
285 C ------------------------------------------------------------------
286 C
287  320 CALL hisnit(luh,'HUP ')
288  IF(kmd.EQ.'HUP ') GO TO 100
289 C
290  340 continue
291 * 340 OPEN(UNIT = 21, !Open & delete SHM-file
292 * & FILE = CNAMS,
293 * & STATUS = 'UNKNOWN',
294 * & IOSTAT = STAT)
295 C
296  IF((mem_style(1:5).NE.'LOCAL')) THEN !Test for & delete
297  CALL mmap_close(ierr) !shared memory segment
298 * CALL SHM_DELETE(SHMID, IERR) !shared memory segment
299 * CLOSE(UNIT=21,STATUS='DELETE')
300  ENDIF
301 C
302 CX IF(INTYP.EQ.'SHM ') THEN !Test for SHM assigned
303 CX CALL CLOSEIPC() !Detach from SHM and
304 CX ENDIF
305 C
306 C Cleanup the c++ portion CRT!
307  CALL cleanup()
308  write(6,*)"Exiting Scanor..."
309  stop
310 C
311 C ------------------------------------------------------------------
312 C List/log error messages
313 C ------------------------------------------------------------------
314 C
315  1000 WRITE(cmssg,1005)
316  CALL messlog(logut,logup)
317  1005 FORMAT('Syntax error or illegal command - ignored')
318  GO TO 50
319 C
320  END
messlog
subroutine messlog(LUA, LUB)
Definition: messlog.f:8