C C \ | / C \|/ QUASAR __________________ C ----*---- / | ++++++++++++++++++++++++ C /|\ -< STAR File access | ++++++++++++++++++++++++ C / | \ \_________________| ++++++++++++++++++++++++ C C Version: Mar 01 1993 C C C QUASAR is a fortran program for extracting data from a STAR formatted file. C It is intended to demonstrate a general approach to processing a STAR file. C C Program source and further information is available from the authors: C C Syd Hall Crystallography Centre, University of Western Australia, C Nedlands, Perth 6009, Australia. (syd@crystal.uwa.oz.au) C C Rolf Sievers Institut fuer Anorganische-Chemisches der Universitaet, C Gerhard-Domagk-Str., Bonn, Germany (unc411@dbnrhrz1.bitnet) C C QUASAR reads a list of data names (from the standard input device 5) to C be to extracted from the STAR archive file. This is referred to as the C 'request' list or file. This file also contains the names of the data C blocks to be searched, and the names of the archive and output file (these C are specified as extensions to 'star_arc_' and 'star_out_' respectively). C If the archive and output files are not specified they are assumed to have C the filenames 'STARIN' and 'STAROT'. Requested data items are output in the C order requested. The same data item may be requested up to five times. C The archive file can checked for logical integrity by entering the string C 'star_log' into the request list. No data items will be output in this case. C C QUASAR allows for "wild card" requests for data names. A data name request C containing a trailing underline is a request for all data names matching the C string preceding the underline. The request for '_' will return all data C items in the specified data block. Data names are case insensitive. C Wild card data blocks may be requested as 'data_'. C C QUASAR cannot process the full STAR File data structure but it attempts C to be relatively "passive" when checking nested loop or save frame data. C It will not successfully extract data stored in these data structures. C C .............................Installation notes............................. C C The data COMMON definitions for QUASAR are supplied as a separate sequence C of lines at the rear of this file. These must be removed with an editor C and named as 'quasar.cmn' for insertion by the compiler via the 'include' C command (or your local equivalent). If your compiler does not support this C facility, use the editor to insert the COMMON lines in each subroutine C (and remove the 'include' line!). C C archived data input on device 2 (opened in routine REQIN) C scratch file scratch on device 3 (opened in routine REQIN) C extracted data output on device 4 (opened in routine REQIN) C requested data [STAREQ] input on device 5 ('stdin') [*opened REQIN] C Message device output on device 6 ('stdout') C C <...> signals default file names (see above) C * 'stdin' may need to opened for non-Unix machines (e.g. Vax/VMS) C C*************************************************************************** C C***** PROGRAM QUASAR C include 'quasar.cmn' C VERS='(Mar 01 93)' NREQ=0 WRITE(*,'(/30H STAR File Processor ,A)') VERS WRITE(*,'( 30H ---------------------------- /)') CASE=ICHAR('a')-ICHAR('A') TAB=CHAR(05) IF(CASE.LT.0) GOTO 100 TAB=CHAR(09) C 100 CALL REQIN CALL ADDREQ CALL GETDAT CALL REQOUT C IF(EOFR.EQ.0) GOTO 100 IF(SLOG.EQ.1) WRITE(*,'(31H Checking complete and correct. /)') END C C*************************************************************************** C Input and store the requested item names from device 5. C GETSTR supplies each strings as the variable 'stri' of C length 'nchr'. NTYP=1 for a data name; =2 for units code; C =3 for number data; =4 for char data; =5 for text data. C*************************************************************************** SUBROUTINE REQIN include 'quasar.cmn' C CHARACTER C*1,STARIN*30,STAROT*30 INTEGER I,N C IF(NREQ.GT.0) GOTO 10 STARIN='STARIN' STAROT='STAROT' C*vax OPEN(5,FILE='STAREQ',STATUS='OLD',FORM='FORMATTED') BLOC=' ' EOFR=0 SLOG=0 10 NREQ=0 LINE=0 NWILD=0 DO 15 I=1,10 15 WILD(I)=0 DO 17 I=1,200 CLEN(I)=0 ITEM(I)=0 LOOP(I)=0 SCR1(I)=0 17 SCR2(I)=0 IEOF=0 NSCR=1 JCHR=1 ICHR=80 STRI=' ' C-------------------------------------- get string from request file 20 CALL GETSTR(5) IF(IEOF.NE.0) GOTO 50 IF(NTYP.EQ.1) GOTO 40 C---------------------------------- test if these specify the files IF(STRI(1:8).EQ.'star_arc') STARIN=STRI(10:NCHR) IF(STRI(1:8).EQ.'star_out') STAROT=STRI(10:NCHR) IF(STRI(1:8).NE.'star_log') GOTO 25 SLOG=1 GOTO 30 C----------------------------------ignore commands except 'data_' 25 IF(STRI(1:5).NE.'data_') GOTO 20 BLOK=BLOC BLOC=STRI(1:NCHR) IF(BLOK(1:1).NE.' ') GOTO 60 30 OPEN(2,FILE=STARIN,STATUS='OLD', FORM='FORMATTED') OPEN(3, STATUS='SCRATCH',FORM='FORMATTED', * ACCESS='DIRECT',RECL=80) WRITE(*,'(22H STAR archive file is ,A)') STARIN IF(SLOG.EQ.1) GOTO 35 OPEN(4,FILE=STAROT,STATUS='UNKNOWN',FORM='FORMATTED') WRITE(*,'(22H STAR output file is ,A/)') STAROT GOTO 20 35 WRITE(*,'(/45H Checking archive file for logical integrity./)') GOTO 50 C----------------------------------store data name in request list 40 NREQ=NREQ+1 IF(NCHR.GT.32)CALL ERR(0,'Request dataname > 32 ch',STRI(1:NCHR)) IF(NREQ.GT.200)CALL ERR(1,'Request count >','200') DO 45 N=1,NCHR C=STRI(N:N) IF(C.GE.'A'.AND.C.LE.'Z') STRI(N:N)=CHAR(ICHAR(C)+CASE) 45 CONTINUE NAME(NREQ)=STRI(1:NCHR) IF(STRI(NCHR:NCHR).NE.'_') GOTO 20 CLEN(NREQ)=NCHR NWILD=NWILD+1 IF(NWILD.GT.10)CALL ERR(1,'Wild card count >','10') WILD(NWILD)=NREQ GOTO 20 C 50 EOFR=1 BLOK=BLOC 60 IEOF=0 IF(NREQ.EQ.0.AND.SLOG.EQ.0) * CALL ERR(1,'No data requests? Check request file.',' ') RETURN END C C*************************************************************************** C If there are "wild card" requests extract the data names C that satisfy the requested data name fragment in the input C archive file by a preliminary scan through this file and add C these to the request list. C*************************************************************************** SUBROUTINE ADDREQ include 'quasar.cmn' C INTEGER I,J,K,L,N INTEGER WCNT(10),NDAT CHARACTER C*1,WNAM(10,100)*32,DNAM*40 C IF(SLOG.EQ.1.OR.NWILD.EQ.0) GOTO 500 ICHR=80 NDAT=0 DO 5 I=1,10 5 WCNT(I)=0 C---------------------------------- get string from archive file 10 CALL GETSTR(2) IF(IEOF.NE.0) GOTO 300 IF(NTYP.EQ.3) GOTO 10 IF(NTYP.EQ.1) GOTO 100 IF(NTYP.NE.5) GOTO 70 20 READ(2,'(A)',END=500) IBUF LINE=LINE+1 IF(IBUF(1:1).NE.';') GOTO 20 GO TO 10 C---------------------------------- if 'data' command -- check name 70 IF(STRI(1:5).NE.'data_') GOTO 10 IF(NDAT.GT.0) GOTO 300 75 DNAM=STRI(1:NCHR) IF(BLOK(6:6).EQ.' ') BLOK=DNAM IF(BLOK.EQ.DNAM) GOTO 100 80 ICHR=80 CALL GETSTR(2) IF(IEOF.NE.0) GOTO 300 IF(NTYP.NE.4) GOTO 80 IF(STRI(1:5).NE.'data_') GOTO 80 GOTO 75 C---------------------------------- data name -- test for wild match 100 DO 110 N=1,NCHR C=STRI(N:N) IF(C.GE.'A'.AND.C.LE.'Z') STRI(N:N)=CHAR(ICHAR(C)+CASE) 110 CONTINUE DO 200 I=1,NWILD J=WILD(I) K=CLEN(J) IF(STRI(1:K).NE.NAME(J)(1:K)) GOTO 200 NDAT=NDAT+1 WCNT(I)=WCNT(I)+1 IF(WCNT(I).GT.100)CALL ERR(1,'Wild card name expansion > ','100') WNAM(I,WCNT(I))=STRI(1:NCHR) 200 CONTINUE GOTO 10 C---------------------------------- add the wild names to the request list 300 I=0 J=0 310 J=J+1 IF(J.GT.NREQ) GOTO 400 IF(CLEN(J).EQ.0) GOTO 310 I=I+1 K=WCNT(I)-1 CLEN(J)=0 NREQ=NREQ+K IF(K.GE.0) GOTO 340 DO 330 L=J,NREQ CLEN(L)=CLEN(L+1) 330 NAME(L)=NAME(L+1) GOTO 390 340 DO 360 L=NREQ,J,-1 IF(L.LE.K) GOTO 370 CLEN(L)=CLEN(L-K) 360 NAME(L)=NAME(L-K) 370 DO 380 L=0,K 380 NAME(J+L)=WNAM(I,L+1) 390 J=J+K-1 GOTO 310 400 CONTINUE REWIND(2) IEOF=0 500 ITEM(NREQ+1)=1 RETURN END C C*************************************************************************** C Read the archive file and check data names against the C request list. If present store the data item that follows C on the scratch file and save all pointers to this file. C GETSTR supplies each string 'strg' of length 'nchr'. C NTYP=1 for a data name; =3 for number data; C =4 for char data; =5 for text data. C*************************************************************************** SUBROUTINE GETDAT include 'quasar.cmn' C CHARACTER C*1,TEMP*32,TDEF(3)*4,COUNT*3,DNAM*40 INTEGER I,J,N INTEGER FRST,NCNT INTEGER LCNT,ICNT INTEGER JOOP,KOOP INTEGER IDAT,NDAT INTEGER IREQ,JREQ INTEGER LLIT,LBIG DATA TDEF/'numb','char','text'/ C LCNT=0 ICNT=0 LLIT=0 LBIG=0 JOOP=0 KOOP=0 IDAT=0 NDAT=0 IREQ=0 JREQ=0 ICHR=80 DO 5 I=1,5 DO 5 J=1,2500 RCNT(J)=0 5 REQU(I,J)=0 C---------------------------------- get string from archive file 10 CALL GETSTR(2) IF(IEOF.NE.0) GOTO 300 C---------------------------------- recognise nature of string IF(NTYP.EQ.1) GOTO 100 IF(NTYP.NE.4) GOTO 200 C---------------------------------- if 'loop' command -- start loops IF(STRI(1:5).NE.'loop_') GOTO 60 IF(LLIT.EQ.0.OR.LBIG.EQ.0) GOTO 40 CALL PUTSCR(3,'; ;') 40 CALL PUTSCR(0,' ') IF(JOOP.EQ.0) GOTO 50 IF(MOD(KOOP,JOOP).NE.0) * CALL ERR(1,'Archive data mis-count in loop_',COUNT) 50 LCNT=LCNT+1 WRITE(COUNT,'(I3)') LCNT LLIT=NDAT+1 LBIG=0 ICNT=0 JOOP=0 KOOP=0 GOTO 10 C---------------------------------- if 'data' command -- check name 60 IF(STRI(1:5).EQ.'save_') GOTO 10 IF(STRI(1:5).EQ.'stop_') GOTO 10 IF(STRI(1:7).EQ.'global_') GOTO 10 70 IF(STRI(1:5).NE.'data_') GOTO 200 IF(SLOG.EQ.1) GOTO 10 IF(NDAT.GT.0) GOTO 300 75 DNAM=STRI(1:NCHR) IF(BLOK(6:6).EQ.' ') BLOK=DNAM IF(BLOK.EQ.DNAM) GOTO 10 80 ICHR=80 CALL GETSTR(2) IF(IEOF.NE.0) GOTO 300 IF(NTYP.NE.4) GOTO 80 IF(STRI(1:5).NE.'data_') GOTO 80 GOTO 75 C----------------------------------- is this data name requested? 100 IF(NCHR.GT.32)CALL ERR(0,'Archive data name > 32 chars', * STRI(1:NCHR)) TEMP=STRI(1:NCHR) IF(LLIT.EQ.0.AND.NDAT.NE.IDAT) * CALL ERR(1,'Data structure error before',TEMP) NDAT=NDAT+1 IF(NDAT.GT.2500) CALL ERR(1,'Data item count >','2500') IF(JOOP.EQ.0) GOTO 110 IF(MOD(KOOP,JOOP).NE.0) * CALL ERR(1,'Archive data mis-count in loop_',COUNT) 110 IF(LLIT.EQ.0) GOTO 120 JOOP=JOOP+1 IF(LBIG.EQ.0) GOTO 120 CALL PUTSCR(3,'; ;') LLIT=0 JOOP=0 120 JREQ=0 FRST=NSCR DO 130 N=1,NCHR C=TEMP(N:N) IF(C.GE.'A'.AND.C.LE.'Z') TEMP(N:N)=CHAR(ICHAR(C)+CASE) 130 CONTINUE DO 150 IREQ=1,NREQ IF(TEMP.NE.NAME(IREQ)) GOTO 150 NAME(IREQ)=STRI(1:NCHR) JREQ=JREQ+1 IF(JREQ.GT.5)CALL ERR(1,'Requests for same item exceed','5') REQU(JREQ,NDAT)=IREQ ITEM(IREQ)=NDAT IF(LLIT.GT.0) LOOP(IREQ)=LCNT 150 CONTINUE RCNT(NDAT)=JREQ GOTO 10 C------------------------------------ is this data item requested? 200 IDAT=IDAT+1 LBIG=NDAT IF(LLIT.EQ.0) GOTO 210 KOOP=KOOP+1 IF(IDAT.LE.LBIG) GOTO 210 IDAT=LLIT FRST=0 CALL PUTSCR(1,';') 210 TYPE(IDAT)=TDEF(NTYP-2) IF(IDAT.GT.NDAT)CALL ERR(1,'Data structure error at data item', * STRI(1:NCHR)) NCNT=RCNT(IDAT) IF(NCNT.GT.0) GOTO 240 C---------------------------------- skip unwanted text lines IF(TYPE(IDAT).NE.'text') GOTO 10 230 READ(2,'(A)',END=290) IBUF LINE=LINE+1 IF(IBUF(1:1).NE.';') GOTO 230 GO TO 10 C---------------------------------- store non-loop text lines 240 IF(LLIT.GT.0) GOTO 260 IF(TYPE(IDAT).NE.'text') GOTO 270 CALL PUTSCR(0,' ') DO 242 I=1,NCNT 242 SCR1(REQU(I,IDAT))=NSCR-1 IBUF(1:1)=' ' 244 WRITE(3,'(A)',REC=NSCR) IBUF NSCR=NSCR+1 IF(IBUF(1:1).EQ.';') GOTO 246 READ(2,'(A)',END=290) IBUF LINE=LINE+1 GOTO 244 246 DO 248 I=1,NCNT 248 CLEN(REQU(I,IDAT))=NSCR-1 GOTO 10 C---------------------------------- store loop text lines 260 ICNT=ICNT+1 IF(TYPE(IDAT).NE.'text') GOTO 270 CALL PUTSCR(0,' ') CALL PUTSCR(2,';;') CALL PUTSCR(0,' ') DO 262 I=1,NCNT IF(FRST.GT.0) SCR1(REQU(I,IDAT))=FRST 262 IF(FRST.GT.0) SCR2(REQU(I,IDAT))=ICNT IBUF(1:1)=' ' 264 WRITE(3,'(A)',REC=NSCR) IBUF NSCR=NSCR+1 IF(IBUF(1:1).EQ.';') GOTO 10 READ(2,'(A)',END=290) IBUF LINE=LINE+1 GOTO 264 C---------------------------------- store non-loop non-text item 270 CALL PUTSCR(NCHR,STRI) IF(LLIT.GT.0) GOTO 280 DO 275 I=1,NCNT CLEN(REQU(I,IDAT))=NCHR SCR1(REQU(I,IDAT))=NSCR 275 SCR2(REQU(I,IDAT))=JCHR-NCHR-1 GOTO 10 C---------------------------------- store looped non-text item 280 DO 285 I=1,NCNT IF(FRST.GT.0) SCR1(REQU(I,IDAT))=FRST IF(FRST.GT.0) SCR2(REQU(I,IDAT))=ICNT 285 CLEN(REQU(I,IDAT))=MAX0(CLEN(REQU(I,IDAT)),NCHR) GOTO 10 C---------------------------------- finish scratch & close archive 290 CALL ERR(1,'Terminating ; missing from text near',TEMP) 300 IF(JOOP.EQ.0) GOTO 320 IF(MOD(KOOP,JOOP).NE.0)CALL ERR(1,'Data mis-count in loop_',COUNT) 320 IF(SLOG.EQ.1) GOTO 450 IF(NDAT.EQ.0) CALL ERR(0,'No items in data block ',BLOK) IF(LLIT.EQ.0.OR.LBIG.EQ.0) GOTO 400 CALL PUTSCR(3,'; ;') 400 CALL PUTSCR(0,' ') 450 REWIND(2) RETURN END C C*************************************************************************** C Read the scratch file and output the requested items C to the output file in the order requested. C*************************************************************************** SUBROUTINE REQOUT include 'quasar.cmn' C INTEGER I,J,K,L INTEGER IREQ,NLIN,LCNT,IPNT,NDAT,NCNT C IF(SLOG.EQ.1) GOTO 340 OBUF=' ' IREQ=0 JPOS=0 CALL PUTOUT(0,0,' ') CALL PUTOUT(1,32,BLOK) CALL PUTOUT(0,0,' ') C------------------------------------- loop over request list 10 IREQ=IREQ+1 IF(IREQ.GT.NREQ) GOTO 300 NDAT=ITEM(IREQ) C------------------------------------- signal if item missing IF(NDAT.NE.0) GOTO 50 CALL PUTOUT(1,32,NAME(IREQ)) CALL PUTOUT(40,31,'? # requested item not present') GOTO 10 C------------------------------------- output non-loop text lines 50 IF(LOOP(IREQ).GT.0) GOTO 150 IF(TYPE(NDAT).NE.'text') GOTO 100 CALL PUTOUT(0,0,' ') CALL PUTOUT(1,32,NAME(IREQ)) CALL PUTOUT(1,0,' ') CALL GETSCR(SCR1(IREQ),CLEN(IREQ),-1) GOTO 10 C------------------------------------- output non-loop data items 100 CALL PUTOUT(1,32,NAME(IREQ)) J=CLEN(IREQ) IF(TYPE(NDAT).EQ.'char') GOTO 110 I=60-J GOTO 120 110 I=41 IF(J.GT.40) I=2 120 CALL GETSCR(SCR1(IREQ),SCR2(IREQ),J) CALL PUTOUT(I,J,STRI) GOTO 10 C------------------------------------- output loop item names 150 I=IREQ CALL PUTOUT(0,0,' ') LCNT=LOOP(I) CALL PUTOUT(1,5,'loop_') 155 J=I-1 160 J=J+1 IF(ITEM(J).EQ.0) GOTO 160 IF(LOOP(J).NE.LCNT) GOTO 200 162 DO 165 K=I,J-1 165 LOOP(K)=LCNT 170 CALL PUTOUT(1,32,NAME(I)) IF(ITEM(I).NE.0) GOTO 190 CALL PUTOUT(40,28,'# requested item not present') 190 I=I+1 IF(LOOP(I).EQ.LCNT) GOTO 170 IF(LOOP(J).EQ.LCNT) GOTO 155 C-------------------------------------- locate next set of loop items 200 ICHR=0 NLIN=SCR1(IREQ) 210 CALL GETSCR(NLIN,NCNT,0) IF(NCNT.EQ.0) GOTO 270 I=IREQ IPNT=2 C-------------------------------------- output loop items in order 230 J=SCR2(I) K=CLEN(I) L=LLEN(J) CALL GETSCR(LREC(J),LPOS(J),L) IF(L.GT.0) GOTO 240 IPNT=2 GOTO 260 240 IPNT=IPNT+K+1 IF(IPNT.GT.80) IPNT=K+1 IF(TYPE(ITEM(I)).NE.'char') GOTO 250 CALL PUTOUT(IPNT-K,L,STRI) GOTO 260 250 CALL PUTOUT(IPNT-L,L,STRI) 260 I=I+1 IF(LOOP(I).NE.LCNT) GOTO 210 IF(ITEM(I).NE.0) GOTO 230 IPNT=IPNT+2 IF(IPNT.GT.80) IPNT=2 CALL PUTOUT(IPNT-1,1,'?') GOTO 260 270 CALL PUTOUT(0,0,' ') IREQ=I-1 GOTO 10 300 CALL PUTOUT(0,0,' ') CALL PUTOUT(1,45,'# -----end-of-data-block-----') CALL PUTOUT(0,0,' ') CALL PUTOUT(0,0,' ') IF(EOFR.EQ.0) GOTO 350 C-------------------------------------- end of quasar run CLOSE(4) CLOSE(3) 340 CLOSE(2) 350 RETURN END C C*************************************************************************** C Extract a string of characters delimited by blanks, tabs or quotes. C NTYP=1 data name; =3 number data; =4 character data; =5 text data. C*************************************************************************** SUBROUTINE GETSTR(NDEV) include 'quasar.cmn' INTEGER I INTEGER NDEV CHARACTER C*1,NUM*13 DATA NUM/'0123456789+-.'/ C C---------------------------------- loop over data items in each line 10 ICHR=ICHR+1 IF(ICHR.LE.80) GOTO 30 C---------------------------------- get a new line from device ndev 20 READ(NDEV,'(A)',END=95) IBUF IF(NDEV.EQ.2) LINE=LINE+1 ICHR=1 NTYP=0 C---------------------------------- test for text data IF(IBUF(1:1).NE.';') GOTO 30 NTYP=5 GOTO 100 C---------------------------------- test for delimiter character 30 C=IBUF(ICHR:ICHR) IF(C.EQ.' ') GOTO 10 IF(C.EQ.TAB) GOTO 10 IF(C.EQ.'#') GOTO 20 IF(C.EQ.'''') GOTO 60 IF(C.EQ.'"') GOTO 60 IF(C.EQ.';') CALL ERR(0,'Warning: string starts with ; on line' * ,IBUF(1:ICHR+10)) C---------------------------------- test for data name IF(C.NE.'_') GOTO 40 NTYP=1 GOTO 45 C---------------------------------- test for number or character data 40 NTYP=3 IF(INDEX(NUM,C).EQ.0) NTYP=4 C---------------------------------- get blank-limited char string 45 DO 50 I=ICHR,80 IF(IBUF(I:I).EQ.' ') GOTO 90 IF(IBUF(I:I).EQ.TAB) GOTO 90 50 CONTINUE I=81 GOTO 90 C---------------------------------- get quote-limited char string 60 NTYP=4 DO 70 I=ICHR+1,80 IF(IBUF(I:I).NE.C) GOTO 70 IF(I.EQ.80) GOTO 80 IF(IBUF(I+1:I+1).EQ.' ') GOTO 80 70 CONTINUE CALL ERR(0,'Quoted string in archive not closed',IBUF(ICHR:80)) I=80 IBUF(I:I)=C 80 I=I+1 C---------------------------------- count & store string 90 NCHR=I-ICHR ICHR=I-1 STRI(1:NCHR)=IBUF(I-NCHR:ICHR) GOTO 100 95 IEOF=1 100 RETURN END C C*************************************************************************** C Place items in the direct-access scratch file. C If nstr = 0 the current buffer is flushed. C*************************************************************************** SUBROUTINE PUTSCR(LSTR,STRG) include 'quasar.cmn' CHARACTER*(*) STRG INTEGER LSTR C--------------------------------------- check if current buffer flushed IF(LSTR.EQ.0) GOTO 20 IF(JCHR+LSTR.LE.80) GOTO 50 20 IF(JCHR.EQ.1) GOTO 50 WRITE(3,'(A)',REC=NSCR) OBUF(1:JCHR-2) JCHR=1 NSCR=NSCR+1 C--------------------------------------- add string to output scr buffer 50 IF(LSTR.EQ.0) GOTO 100 OBUF(JCHR:JCHR+LSTR)=STRG(1:LSTR) JCHR=JCHR+LSTR+1 100 RETURN END C C*************************************************************************** C Get items from the scratch file. There are two modes. If ilen C = 0 the 'ipos'th item must be located in free format starting C at record 'irec'. Otherwise an item ilen characters long is C extracted from record 'irec' at character position 'pos'. C*************************************************************************** SUBROUTINE GETSCR(IREC,IPOS,ILEN) include 'quasar.cmn' INTEGER IPOS,ILEN,IREC,JREC,ICNT,I CHARACTER*1 C C------------------------------ extract specific record and position IF(ILEN.LE.0) GOTO 20 READ(3,'(A)',REC=IREC) IBUF STRI(1:ILEN)=IBUF(IPOS:IPOS+ILEN-1) GOTO 150 C------------------------------ extract text lines and output 20 IF(ILEN.EQ.0) GOTO 40 CALL PUTOUT(1,0,' ') DO 30 JREC=IREC+1,IPOS READ(3,'(A)',REC=JREC) IBUF IF(JREC.EQ.IREC+1) IBUF(1:1)=';' 30 WRITE(4,'(A)') IBUF GOTO 150 C------------------------------- extract positions of looped items 40 ICNT=0 READ(3,'(A)',REC=IREC) IBUF 45 ICHR=ICHR+1 IF(ICHR.LE.80) GOTO 55 50 IREC=IREC+1 READ(3,'(A)',REC=IREC) IBUF ICHR=1 55 C=IBUF(ICHR:ICHR) IF(C.EQ.'''') GOTO 65 IF(C.EQ.'"') GOTO 65 IF(C.EQ.' ') GOTO 45 C---------------------------------- find blank string limits DO 60 I=ICHR+1,80 IF(IBUF(I:I).EQ.' ') GOTO 90 60 CONTINUE I=81 GOTO 90 C---------------------------------- find quoted string limits 65 DO 70 I=ICHR+1,80 IF(IBUF(I:I).EQ.C) GOTO 80 70 CONTINUE 80 I=I+1 C---------------------------------- count item & test end of loop 90 ICNT=ICNT+1 IF(C.NE.';') GOTO 110 IF(I.EQ.ICHR+1) GOTO 120 IF(IBUF(1:2).NE.';;')GOTO 110 C---------------------------------- store position of text LREC(ICNT)=IREC 100 IREC=IREC+1 READ(3,'(A)',REC=IREC) IBUF IF(IBUF(1:1).NE.';') GOTO 100 LPOS(ICNT)=IREC LLEN(ICNT)=-1 ICHR=80 GOTO 50 C---------------------------------- store position of string 110 LREC(ICNT)=IREC LPOS(ICNT)=ICHR LLEN(ICNT)=I-ICHR ICHR=I GOTO 45 C---------------------------------- flag end of loop 120 IPOS=ICNT-1 150 RETURN END C C*************************************************************************** C Used to place items in the output buffer. If ipos=1 & ilen=0 the C buffer is flushed if it contains items. If ipos=0 & ilen=0 the buffer C is flushed and an additional blank line is output. C*************************************************************************** SUBROUTINE PUTOUT(IPOS,ILEN,STRG) include 'quasar.cmn' CHARACTER*(*)STRG INTEGER IPOS INTEGER ILEN C IF(IPOS.GT.JPOS) GOTO 20 IF(JPOS.EQ.0) GOTO 10 WRITE(4,'(A)') OBUF(1:JPOS) OBUF(1:JPOS)=' ' JPOS=0 10 IF(IPOS.EQ.0) WRITE(4,'(1X)') 20 IF(ILEN.EQ.0) GOTO 30 JPOS=IPOS+ILEN-1 OBUF(IPOS:JPOS)=STRG(1:ILEN) 30 RETURN END C C*************************************************************************** C Error message generator. Output to device 6 and stop. C*************************************************************************** SUBROUTINE ERR(I,MESS,STRG) include 'quasar.cmn' INTEGER I CHARACTER*(*) MESS,STRG WRITE(*,'(11H Error >>> ,A,2X,A)') MESS,STRG IF(I.EQ.0) RETURN WRITE(*,'(11X,28HFatal error -- archive line ,I5/)') LINE CLOSE(2) CLOSE(3) CLOSE(4) STOP END C C*************************************************************************** C C >>>>>>> QUASAR Common: Description of the array variables. <<<<<<<< C C C For i=1,2500 in the order of data items in the archive file. C C REQU(n,i) : contains request sequence number for each (n) request. C RCNT(i) : contains the number of requests for this item. C TYPE(i) : data type code 'numb', 'char' or 'text' for all items. C C C For j=1,200 in the order of items on the request file. C C NAME(j) : data name of the requested item. C ITEM(j) : sequence number of this item in the archive file. C LOOP(j) : the loop number of looped items, otherwise 0. C CLEN(j) : nchr of non-LOOP items; max char length of LOOP items. C SCR1(j) : scratch record number for non-LOOP items; C first scratch record number for LOOP items. C SCR2(j) : first char position in scratch record for non-LOOP items; C order of items in scratch file LOOP items. C C C For k=1,50 in order of the current LOOP items in scratch file. C C LREC(k) : record number on the scratch file for non-text item. C first record number on the scratch file for text item. C LPOS(k) : char pointer to the scratch record for a non-text item. C last record number on the scratch file for text item. C LLEN(k) : length of string on the scratch record for non-text item. C -1 for text item. C C For l=1,10 in order of wild card data names in the request file. C C WNAM(l,n) : for up to 100 data names per wild card request. C C NTYP =1 for a data name; =3 for number data; C =4 for char data; =5 for text data. C C***************************************************************************