source: 1dwg/trunk/fortran/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
37C===============================================================================
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
59100     format(' Run number  : ',a6)
60101     format(' Date of run : ',a20)
61102     format(' Title string: ',a60)
62103     format(' Type of data: ',a9)
63104     format(' Q is:')
64105     format(' I is:')
65106     format(a79)
66107     format(' Xmin: ',e12.5,'     Xmax: ',e12.5)
67108     format(' Ymin: ',e12.5,'     Ymax: ',e12.5)
68109     format(' Number of data points: ',i6)
69110     format(' XML file to read?> ',$)
70111     format(a80,$)
71
72        write(6,*)'EXAMPLE_READ_SASXML'
731       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)
911000     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
113C    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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)
121C    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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
1899999    end
190
191
192C===============================================================================
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        real*4          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
2201000    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
2491       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
2652       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
4473             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
5864          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
6366       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
6537       flag=0
654        goto 8889
655*       END OF FILE ENCOUNTERED
6568886    flag=-3
657        n=0
658        goto 8889
659*       ERROR DURING READ
6608887    flag=-2
661        n=0
662        goto 8889
663*       FILE FORMAT SUSPECT
6648888    flag=-1
665        n=0
666
6678889    close(unit=iunit)
6688890    return
669        end
670
671C===============================================================================
672
673
Note: See TracBrowser for help on using the repository browser.