Context Navigation

SASXML_G77.F @ 53

Last change on this file since 53 was 53, checked in by prjemian, 13 years ago
From Steve King (ISIS): "attached is a piece of FORTRAN that reads every SASXML file I’ve thrown at it so far"
File size: 19.8 KB

Line
1	*
2	*
3	* F77 SUBROUTINE XMLIP2 TO READ CANSAS SASXML V1.0 1D TREATED DATA FILES
4	* AND EXAMPLE IMPLEMENTATION PROGRAM EXAMPLE_READ_SASXML
5	*
6	* READS UP TO 4 NUMERICAL FIELDS (Q, I, (Idev, (Qdev)))
7	* ALSO READS THE FOLLOWING META DATA FIELDS:
8	* <SASentry>
9	* <run>
10	* <title>
11	* </SASentry>
12	* <SASprocess>
13	* <date>
14	* <wavelength_min>
15	* <wavelength_max>
16	* <term name="radius_min">
17	* <term name="radius_max">
18	* <term name="sector_width">
19	* <term name="scale_factor">
20	* </SASprocess>
21	* <SASprocessnote>
22	* <name="data_mode">
23	* <SASprocessnote>
24	*
25	* ALSO PARSES THE UNITS OF Q FOR A X-AXIS TITLE
26	* ALSO PARSES THE UNITS OF I FOR A Y-AXIS TITLE
27	*
28	* (C)2008, S M KING, ISIS, RAL, UK
29	*
30	* THIS CODE MAY BE REDISTRIBUTED AND REUSED WITHOUT RESTRICTION PROVIDED
31	* AN ACKNOWLEDGEMENT TO THE ORIGINAL AUTHOR IS RETAINED
32	*
33	* ALSO SEE:
34	* http://www.smallangles.net/wgwiki/index.php/cansas1d_documentation
35
36
37	C===============================================================================
38
39
40	program example_read_sasxml
41
42	real*4 x(16384),y(16384),e(16384),f(16384)
43	real*4 x_mn,x_mx,y_mn,y_mx
44	real*4 meta(6)
45	real*4 lambda_min,lambda_max
46	real*4 phi_min,phi_max
47	real*4 r_min,r_max
48	real*4 scale
49	integer*4 id,len_recl,n
50	integer*4 ipflag,ipflag2
51	character*6 run
52	character*9 mode
53	character*20 date
54	character*60 title
55	character*79 xtit,ytit
56	character*80 filnam
57
58
59	100 format(' Run number : ',a6)
60	101 format(' Date of run : ',a20)
61	102 format(' Title string: ',a60)
62	103 format(' Type of data: ',a9)
63	104 format(' Q is:')
64	105 format(' I is:')
65	106 format(a79)
66	107 format(' Xmin: ',e12.5,' Xmax: ',e12.5)
67	108 format(' Ymin: ',e12.5,' Ymax: ',e12.5)
68	109 format(' Number of data points: ',i6)
69	110 format(' XML file to read?> ',$)
70	111 format(a80,$)
71
72	write(6,*)'EXAMPLE_READ_SASXML'
73	1 write(6,110)
74	read(5,111,err=1)filnam
75	write(6,*)' '
76
77	* INPUT UNIT ID
78	id=4
79
80	* ERROR FLAGS
81	ipflag=1
82	ipflag2=1
83
84	* MAX INPUT RECORD (IE, LINE) LENGTH
85	* CHARACTER INPUT FORMAT STATEMENT IN SUBROUTINE XMLIP2 SHOULD BE
86	* SET TO MATCH
87	len_recl=200
88
89	* G77 NOT VERY HAPPY ABOUT READONLY CONTROL STATEMENT
90	*1000 OPEN(UNIT=id,FILE=filnam,RECL=len_recl,STATUS='old',READONLY,ERR=9999)
91	1000 OPEN(UNIT=id,FILE=filnam,RECL=len_recl,STATUS='old',ERR=9999)
92
93	if (ipflag2.eq.1) then
94	write(6,*)'Reading canSAS SASXML-compliant file'
95	write(6,*)' '
96	else
97	write(6,*)' '
98	write(6,*)'Extracting next entry'
99	write(6,*)' '
100	end if
101
102	* NUMBER OF DATA POINTS
103	n=0
104	* MIN X VALUE
105	x_mn=0.
106	* MAX X VALUE
107	x_mx=0.
108	* MIN Y VALUE
109	y_mn=0.
110	* MAX X VALUE
111	y_mx=0.
112
113	C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
114	CALL XMLIP2
115	& (id,n,len_recl,
116	& x,y,e,f,
117	& title,date,run,
118	& xtit,ytit,
119	& x_mn,x_mx,y_mn,y_mx,
120	& meta,mode,ipflag,ipflag2)
121	C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
122
123	* LIMIT DATA TO ARRAY BOUNDS - CHANGE BOUNDS AS REQUIRED
124	if (n.gt.16384) n=16384
125
126	* ERROR CODES
127	if (ipflag.ne.0) then
128	if (ipflag.eq.-1) then
129	write(6,*)'ERROR[-1]: Is XML data block formatted correctly?'
130	else if (ipflag.eq.-2) then
131	write(6,*)'ERROR[-2]: Cannot read more of this file'
132	else if (ipflag.eq.-3) then
133	write(6,*)'ERROR[-3]: End of file encountered'
134	else if ((ipflag.eq.-4).or.(n.eq.0)) then
135	write(6,*)'ERROR[-4]: No data read from file'
136	else if ((ipflag.ne.1).and.(ipflag2.gt.1)) then
137	write(6,*)'ERROR: IPFLAG has an unexpected value'
138	write(6,*)'IPFLAG: ',ipflag
139	write(6,*)'IPFLAG2: ',ipflag2
140	end if
141	end if
142
143	* TYPE DATA VALUES TO SCREEN
144	do i=1,n
145	write(6,*)x(i),y(i),e(i),f(i)
146	end do
147
148	* INTERPRET META DATA
149	if (ipflag.ge.0) then
150	* WAVELENGTH RANGE
151	if (meta(1).le.0.22) then
152	lambda_min=meta(1)*10.
153	lambda_max=meta(2)*10.
154	else
155	lambda_min=meta(1)
156	lambda_max=meta(2)
157	end if
158	* RADIAL INTEGRATION LIMITS
159	r_min=meta(3)
160	r_max=meta(4)
161	* AZIMUTHAL ANGLE RANGE
162	phi_min=meta(5)*-1
163	phi_max=meta(5)
164	* INTENSITY SCALE FACTOR
165	scale=meta(6)
166
167	* TYPE META DATA TO SCREEN
168	write(6,*)' '
169	write(6,*)'XML data has been input'
170	write(6,*)' '
171	write(6,100)run
172	write(6,101)date
173	write(6,102)title
174	write(6,103)mode
175	write(6,104)
176	write(6,106)xtit
177	write(6,105)
178	write(6,106)ytit
179	write(6,107)x_mn,x_mx
180	write(6,108)y_mn,y_mx
181	write(6,109)n
182	end if
183
184	close(unit=id)
185
186	* GO LOOK FOR ANOTHER SASENTRY IN THE FILE
187	if (ipflag.gt.0) goto 1000
188
189	9999 end
190
191
192	C===============================================================================
193
194	SUBROUTINE XMLIP2
195	& (IUNIT,N,IRECL,
196	& A,B,C,D,TITLE,DATE,RUN,XTIT,YTIT,XMIN,XMAX,YMIN,YMAX,METAVAL,DATA_MODE,
197	& FLAG,FLAG2)
198	integer iunit,n,irecl,flag,flag2
199	real*4 metaval(6),xmin,xmax,ymin,ymax
200	real4 a(),b(),c(),d(16384)
201	character*79 xtit,ytit
202	character*6 run
203	character*20 date
204	character*60 title
205
206	* CHANGED FIELD1 FROM CHAR*8 TO HANDLE ILL DATA
207	character*9 field1
208	character*12 field2
209	character*9 field3,field4,data_mode
210
211	integer nchars,ipos,jpos,kpos(7),lpos(7),mpos(7),npos(7)
212	integer len_line
213
214	logical got_title,got_run,got_date,got_mode,on_entry
215	logical got_lmin,got_lmax,got_rmin,got_rmax,next_data
216	logical got_sector,got_scale,read_entry,next_entry
217	logical found_data,read_data,got_data,found_endroot
218
219	character*200 line,line2
220	1000 format(a200)
221
222	on_entry=.true.
223	got_title=.false.
224	got_run=.false.
225	got_date=.false.
226	got_lmin=.false.
227	got_lmin=.false.
228	got_rmin=.false.
229	got_rmax=.false.
230	got_sector=.false.
231	got_scale=.false.
232	got_mode=.false.
233	got_data=.false.
234	read_data=.false.
235	found_data=.false.
236	next_data=.false.
237	read_entry=.false.
238	next_entry=.false.
239	found_endroot=.false.
240
241	n=1
242
243	xtit='
244	& '
245
246	ytit='
247	& '
248
249	1 line='
250	&
251	&
252	& '
253
254	* USE FLAG2 TO COUNT LINE NUMBER OF FILE WITH </SASentry>
255	* SO CAN SKIP BETWEEN ENTRIES IN EXTENDED FILES
256	if ((on_entry).and.(flag2.gt.1)) then
257	do i=1,flag2
258	read(unit=iunit,fmt=1000,err=8887,end=8886)line
259	* WRITE(6,'(i6,a80)')flag2,line(1:80)
260	end do
261	on_entry=.false.
262	* WRITE(6,*)'Skipped previous entry...'
263	end if
264
265	2 read(unit=iunit,fmt=1000,err=8887,end=8886)line
266	* WRITE(6,'(i6,a80)')flag2,line(1:80)
267	ipos=0
268	jpos=0
269
270	* GET THE TITLE STRING
271	if (.not.got_title) then
272	ipos=index(line(1:200),'<Title>')
273	jpos=index(line(1:200),'</Title>')
274	title(1:60)=
275	& ' '
276	if ((ipos.gt.0).and.(jpos.gt.0)) then
277	nchars=(jpos-1)-(ipos+7)+1
278	if (nchars.le.26) then
279	title(1:nchars)=line(ipos+7:jpos-1)
280	else
281	title(1:26)=line(ipos+7:ipos+7+26)
282	end if
283	got_title=.true.
284	* WRITE(6,*)TITLE(1:60)
285	end if
286	end if
287
288	* GET THE RUN NUMBER
289	if (.not.got_run) then
290	ipos=index(line(1:200),'<Run>')
291	jpos=index(line(1:200),'</Run>')
292	run(1:6)=' '
293	if ((ipos.gt.0).and.(jpos.gt.0)) then
294	nchars=(jpos-2)-(ipos+5)+1
295	if (nchars.le.6) then
296	run(1:nchars)=line(ipos+5:jpos-2)
297	else
298	run(1:6)=line(ipos+5:ipos+5+6)
299	end if
300	* WRITE(6,*)RUN(1:6)
301	got_run=.true.
302	end if
303	end if
304
305	* GET THE DATE
306	if (.not.got_date) then
307	ipos=index(line(1:200),'<date>')
308	jpos=index(line(1:200),'</date>')
309	date(1:20)=' '
310	if ((ipos.gt.0).and.(jpos.gt.0)) then
311	nchars=(jpos-2)-(ipos+7)+1
312	if (nchars.le.20) then
313	date(1:nchars)=line(ipos+7:jpos-2)
314	else
315	date(1:20)=line(ipos+7:ipos+7+20)
316	end if
317	* WRITE(6,*)DATE(1:20)
318	got_date=.true.
319	end if
320	end if
321
322	* GET THE MIN WAVELENGTH
323	* FIRST ASSUME IT'S IN NM
324	if (.not.got_lmin) then
325	ipos=index(line(1:200),'<wavelength_min unit="nm">')
326	jpos=index(line(1:200),'</wavelength_min>')
327	metaval(1)=0.0
328	if ((ipos.gt.0).and.(jpos.gt.0)) then
329	read(line(ipos+26:jpos-2),'(f5.2)')metaval(1)
330	* WRITE(6,*)METAVAL(1)
331	got_lmin=.true.
332	end if
333	end if
334
335	* OTHERWISE SEE IF IT'S IN ANGSTROMS
336	if (.not.got_lmin) then
337	ipos=index(line(1:200),'<wavelength_min unit="A">')
338	jpos=index(line(1:200),'</wavelength_min>')
339	metaval(1)=0.0
340	if ((ipos.gt.0).and.(jpos.gt.0)) then
341	read(line(ipos+25:jpos-2),'(f5.2)')metaval(1)
342	* WRITE(6,*)METAVAL(1)
343	got_lmin=.true.
344	end if
345	end if
346
347	* GET THE MAX WAVELENGTH
348	* FIRST ASSUME IT'S IN NM
349	if (.not.got_lmax) then
350	ipos=index(line(1:200),'<wavelength_max unit="nm">')
351	jpos=index(line(1:200),'</wavelength_max>')
352	metaval(2)=0.0
353	if ((ipos.gt.0).and.(jpos.gt.0)) then
354	read(line(ipos+26:jpos-2),'(f5.2)')metaval(2)
355	* WRITE(6,*)METAVAL(2)
356	got_lmax=.true.
357	end if
358	end if
359
360	* OTHERWISE SEE IF IT'S IN ANGSTROMS
361	if (.not.got_lmax) then
362	ipos=index(line(1:200),'<wavelength_max unit="A">')
363	jpos=index(line(1:200),'</wavelength_max>')
364	metaval(2)=0.0
365	if ((ipos.gt.0).and.(jpos.gt.0)) then
366	read(line(ipos+25:jpos-2),'(f5.2)')metaval(2)
367	* WRITE(6,*)METAVAL(2)
368	got_lmax=.true.
369	end if
370	end if
371
372	* GET THE INTENSITY SCALE FACTOR
373	if (.not.got_scale) then
374	ipos=index(line(1:200),'<term name="scale_factor" unit="a.u.">')
375	jpos=index(line(1:200),'</term>')
376	metaval(6)=0.0
377	if ((ipos.gt.0).and.(jpos.gt.0)) then
378	read(line(ipos+38:jpos-2),'(f7.4)')metaval(6)
379	* WRITE(6,*)METAVAL(6)
380	got_scale=.true.
381	end if
382	end if
383
384	* GET THE MIN RADIUS OF RADIAL AVERAGING
385	if (.not.got_rmin) then
386	ipos=index(line(1:200),'<term name="radius_min" unit="mm">')
387	jpos=index(line(1:200),'</term>')
388	metaval(3)=0.0
389	if ((ipos.gt.0).and.(jpos.gt.0)) then
390	read(line(ipos+34:jpos-2),'(f6.1)')metaval(3)
391	* WRITE(6,*)METAVAL(3)
392	got_rmin=.true.
393	end if
394	end if
395
396	* GET THE MAX RADIUS OF RADIAL AVERAGING
397	if (.not.got_rmax) then
398	ipos=index(line(1:200),'<term name="radius_max" unit="mm">')
399	jpos=index(line(1:200),'</term>')
400	metaval(4)=0.0
401	if ((ipos.gt.0).and.(jpos.gt.0)) then
402	read(line(ipos+34:jpos-2),'(f6.1)')metaval(4)
403	* WRITE(6,*)METAVAL(4)
404	got_rmax=.true.
405	end if
406	end if
407
408	* GET THE ANGULAR RANGE OF RADIAL AVERAGING
409	if (.not.got_sector) then
410	ipos=index(line(1:200),'<term name="sector_width" unit="degree">')
411	jpos=index(line(1:200),'</term>')
412	metaval(5)=0.0
413	if ((ipos.gt.0).and.(jpos.gt.0)) then
414	read(line(ipos+40:jpos-2),'(f6.1)')metaval(5)
415	* WRITE(6,*)METAVAL(5)
416	got_sector=.true.
417	end if
418	end if
419
420	* GET THE DATA MODE
421	if (.not.got_mode) then
422	ipos=index(line(1:200),'<SASprocessnote name="data_mode">')
423	jpos=index(line(1:200),'</SASprocessnote>')
424	data_mode(1:9)=' '
425	if ((ipos.gt.0).and.(jpos.gt.0)) then
426	nchars=(jpos-1)-(ipos+33)+1
427	if (nchars.le.9) then
428	data_mode(1:nchars)=line(ipos+33:jpos-1)
429	else
430	data_mode(1:9)=line(ipos+34:ipos+34+9)
431	end if
432	* WRITE(6,*)DATA_MODE(1:9)
433	got_mode=.true.
434	end if
435	end if
436
437	* GET DATA IF NOT ALREADY DONE SO
438	if ((.not.found_data).and.(.not.read_data)) then
439	* FIRST TEST FOR START OF DATA BLOCK
440	ipos=index(line(1:200),'<SASdata')
441	if (ipos.gt.0) found_data=.true.
442	if (ipos.gt.0) flag2=flag2+1
443	if (found_data) then
444	* IF FOUND DATA BLOCK, READ NEXT LINE WHICH SHOULD BE DATA...
445	* WRITE(6,*)'Found data block...'
446
447	3 read(unit=iunit,fmt=1000,err=4,end=8886)line
448	* WRITE(6,'(i6,a80)')flag2,line(1:80)
449
450	* BUT TEST FOR END OF DATA BLOCK
451	ipos=0
452	ipos=index(line(1:200),'</SASdata>')
453	if (ipos.gt.0) read_data=.true.
454	* STOP READING DATA IF REACHED END OF DATA BLOCK
455	if (read_data) goto 4
456	* OTHERWISE GRAB THE DATA VALUES
457	a(n)=0.
458	b(n)=0.
459	c(n)=0.
460	d(n)=0.
461	ipos=0
462	jpos=0
463	ipos=index(line(1:200),'<Idata>')
464	jpos=index(line(1:200),'</Idata>')
465	* CHECK IT'S A VALID DATA RECORD
466	if ((ipos.gt.0).and.(jpos.gt.0)) then
467	len_line=jpos-ipos+1
468	line2='
469	&
470	&
471	& '
472	line2(1:len_line)=line(ipos:jpos)
473	* FIRST THE X DATA...
474	* NB: SASXML STANDARD ALLOWS UP TO 6 COLUMNS OF DATA
475	* SO KPOS, LPOS, MPOS & NPOS HELP DEFINE THE SUBSTRINGS OF THE
476	* IDATA STRING THAT DEFINE THE DATA TYPE (Q, I, ETC), IT'S
477	* UNITS, AND ITS NUMERIC VALUE, WHILST ARRAY INDICIES 2-7
478	* REPRESENT DATA COLUMNS 1-6
479	do i=1,7
480	kpos(i)=0
481	lpos(i)=0
482	mpos(i)=0
483	npos(i)=0
484	end do
485	do i=2,7
486	kpos(i)=index(line2(1+npos(i-1):len_line),'><')+npos(i-1)
487	lpos(i)=index(line2(1+npos(i-1):len_line),'unit')+npos(i-1)
488	mpos(i)=index(line2(1+npos(i-1):len_line),'">')+npos(i-1)
489	npos(i)=index(line2(1+npos(i-1):len_line),'</')+npos(i-1)
490	end do
491
492	* CONSTRUCT AXIS TITLES
493	xtit(1:79)=line2(kpos(2)+2:lpos(2)-2)//
494	& ' ('//line2(lpos(2)+6:mpos(2)-1)//')'
495	ytit(1:79)=line2(kpos(3)+2:lpos(3)-2)//
496	& ' ('//line2(lpos(3)+6:mpos(3)-1)//')'
497
498	* READ AND CONVERT THE DATA VALUE FIELDS
499	* kpos='><'
500	* lpos='unit'
501	* mpos='">'
502	* npos='</'
503
504	if ((line2(mpos(2)+2:mpos(2)+2).eq.' ').and.
505	& (line2(npos(2)-1:npos(2)-1).eq.' ')) then
506	field1=line2(mpos(2)+2:npos(2)-2)
507	read(field1,*)a(n)
508	else if ((line2(mpos(2)+2:mpos(2)+2).eq.' ').and.
509	& (line2(npos(2)-1:npos(2)-1).ne.' ')) then
510	field1=line2(mpos(2)+2:npos(2)-1)
511	read(field1,*)a(n)
512	else if ((line2(mpos(2)+2:mpos(2)+2).ne.' ').and.
513	& (line2(npos(2)-1:npos(2)-1).eq.' ')) then
514	field1=line2(mpos(2)+2:npos(2)-2)
515	read(field1,*)a(n)
516	else
517	field1=line2(mpos(2)+2:npos(2)-1)
518	read(field1,*)a(n)
519	end if
520
521	if ((line2(mpos(3)+2:mpos(3)+2).eq.' ').and.
522	& (line2(npos(3)-1:npos(3)-1).eq.' ')) then
523	field2=line2(mpos(3)+2:npos(3)-2)
524	read(field2,*)b(n)
525	else if ((line2(mpos(3)+2:mpos(3)+2).eq.' ').and.
526	& (line2(npos(3)-1:npos(3)-1).ne.' ')) then
527	field2=line2(mpos(3)+2:npos(3)-1)
528	read(field2,*)b(n)
529	else if ((line2(mpos(3)+2:mpos(3)+2).ne.' ').and.
530	& (line2(npos(3)-1:npos(3)-1).eq.' ')) then
531	field2=line2(mpos(3)+2:npos(3)-2)
532	read(field2,*)b(n)
533	else
534	field2=line2(mpos(3)+2:npos(3)-1)
535	read(field2,*)b(n)
536	end if
537
538	* CHECK FOR 3RD COLUMN
539	if (lpos(4).gt.kpos(4)) then
540	if ((line2(mpos(4)+2:mpos(4)+2).eq.' ').and.
541	& (line2(npos(4)-1:npos(4)-1).eq.' ')) then
542	field3=line2(mpos(4)+2:npos(4)-2)
543	read(field3,*)c(n)
544	else if ((line2(mpos(4)+2:mpos(4)+2).eq.' ').and.
545	& (line2(npos(4)-1:npos(4)-1).ne.' ')) then
546	field3=line2(mpos(4)+2:npos(4)-1)
547	read(field3,*)c(n)
548	else if ((line2(mpos(4)+2:mpos(4)+2).ne.' ').and.
549	& (line2(npos(4)-1:npos(4)-1).eq.' ')) then
550	field3=line2(mpos(4)+2:npos(4)-2)
551	read(field3,*)c(n)
552	else
553	field3=line2(mpos(4)+2:npos(4)-1)
554	read(field3,*)c(n)
555	end if
556	end if
557
558	* CHECK FOR 4TH COLUMN
559	if (lpos(5).gt.kpos(5)) then
560	if ((line2(mpos(5)+2:mpos(5)+2).eq.' ').and.
561	& (line2(npos(5)-1:npos(5)-1).eq.' ')) then
562	field4=line2(mpos(5)+2:npos(5)-2)
563	read(field4,*)d(n)
564	else if ((line2(mpos(5)+2:mpos(5)+2).eq.' ').and.
565	& (line2(npos(5)-1:npos(5)-1).ne.' ')) then
566	field4=line2(mpos(5)+2:npos(5)-1)
567	read(field4,*)d(n)
568	else if ((line2(mpos(5)+2:mpos(5)+2).ne.' ').and.
569	& (line2(npos(5)-1:npos(5)-1).eq.' ')) then
570	field4=line2(mpos(5)+2:npos(5)-2)
571	read(field4,*)d(n)
572	else
573	field4=line2(mpos(5)+2:npos(5)-1)
574	read(field4,*)d(n)
575	end if
576	end if
577
578	* WRITE(6,*)FIELD1,FIELD2,FIELD3,FIELD4
579	* WRITE(6,*)A(N),B(N),C(N),D(N)
580
581	n=n+1
582	end if
583	flag2=flag2+1
584	goto 3
585
586	4 end if
587
588	* IF (READ_DATA) WRITE(6,*)'Finished reading data block...'
589
590	end if
591
592	* CHECK TO SEE IF REACHED END OF THE DATA ENTRY
593	if (.not.read_entry) then
594	ipos=index(line(1:200),'</SASentry>')
595	if (ipos.gt.0) read_entry=.true.
596	if (ipos.gt.0) flag2=flag2+1
597	end if
598
599	* IF (READ_ENTRY) WRITE(6,*)'Finished reading an entry...'
600
601	* CHECK TO SEE IF THERE IS ANOTHER DATA BLOCK
602	if ((read_data).and.(.not.read_entry)) then
603	ipos=index(line(1:200),'<SASdata')
604	if (ipos.gt.0) next_data=.true.
605	* if (ipos.gt.0) flag2=flag2+1
606	end if
607
608	* IF (NEXT_DATA) WRITE(6,*) 'Reading another data block in this entry...'
609
610	* FIND MAX & MIN X VALUES & INTENSITIES
611	* if (read_entry) then
612	if ((read_entry).or.(next_data)) then
613	n=n-1
614	ymax=-1.E38
615	ymin=1.E38
616	do i=1,n
617	if (b(i).gt.ymax) ymax=b(i)
618	if (b(i).lt.ymin) ymin=b(i)
619	end do
620
621	xmax=-1.E38
622	xmin=1.E38
623	do i=1,n
624	if (a(i).gt.xmax) xmax=a(i)
625	if (a(i).lt.xmin) xmin=a(i)
626	end do
627	end if
628
629	* CHECK TO SEE IF THERE IS ANOTHER ENTRY
630	if (read_entry) then
631	read(unit=iunit,fmt=1000,err=6,end=8886)line
632	* WRITE(6,'(i6,a80)')flag2,line(1:80)
633	ipos=index(line(1:200),'<SASentry')
634	if (ipos.gt.0) next_entry=.true.
635	if (ipos.gt.0) flag2=flag2+1
636	6 end if
637
638	* CHECK TO SEE IF REACHED LAST LINE OF THE FILE
639	if (.not.found_endroot) then
640	ipos=index(line(1:200),'</SASroot>')
641	if (ipos.gt.0) found_endroot=.true.
642	if (ipos.gt.0) flag2=flag2+1
643	end if
644
645	if (found_endroot) goto 7
646
647	* GO READ ANOTHER ANOTHER LINE FROM THE FILE
648	if ((.not.read_entry).and.(.not.next_entry).and.(.not.next_data)) flag2=flag2+1
649	if ((.not.read_entry).and.(.not.next_entry).and.(.not.next_data)) goto 1
650
651	goto 8889
652	* SUCCESSFUL READ OF FILE
653	7 flag=0
654	goto 8889
655	* END OF FILE ENCOUNTERED
656	8886 flag=-3
657	n=0
658	goto 8889
659	* ERROR DURING READ
660	8887 flag=-2
661	n=0
662	goto 8889
663	* FILE FORMAT SUSPECT
664	8888 flag=-1
665	n=0
666
667	8889 close(unit=iunit)
668	8890 return
669	end
670
671	C===============================================================================
672
673

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format