C*<*<* from sendcif, Sat Mar 20 10:06:56 WST 1993 *>*>*
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  <STARIN> input   on device 2 (opened in routine REQIN)
C  scratch file            scratch on device 3 (opened in routine REQIN)
C  extracted data <STAROT> 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 <QUASAR> 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***************************************************************************
C
C   The lines below MUST be removed before compiling and placed into a file
C   named 'quasar.cmn'. They will be inserted automatically by the 'include'
C   compiler facility. If this facility is unavailable they must be inserted
C   manually using the editor. Note the explanation at the front of the file.
C
C
C       Common file for QUASAR
C
        CHARACTER*80 IBUF,OBUF
        CHARACTER*80 STRI
        CHARACTER*40 BLOK
        CHARACTER*40 BLOC
        CHARACTER*32 VERS
        CHARACTER*1  TAB
C                               up to 2500 data items in archive file
        INTEGER      REQU(5,2500)
        INTEGER      RCNT(2500)
        CHARACTER*4  TYPE(2500)
C                               up to 200 data items in request file
        CHARACTER*32 NAME(200)
        CHARACTER*5  UNIT(200)
        INTEGER      ITEM(200)
        INTEGER      CLEN(200)
        INTEGER      LOOP(200)
        INTEGER      SCR1(200)
        INTEGER      SCR2(200)
C                               up to 50 data requests in a loop
        INTEGER      LREC(50)
        INTEGER      LPOS(50)
        INTEGER      LLEN(50)
C                               up to 10 wild card data name requests
        INTEGER      WILD(10) 
        INTEGER      NWILD
C                               logical integrity test flag
        INTEGER      SLOG
C                               end of file flag (off=0; on=1)
        INTEGER      IEOF
C                               request end of file (off=0; on=1)
        INTEGER      EOFR
C                               current column pointer for GETSTR & GETSCR
        INTEGER      ICHR
C                               current column pointer for PUTSCR
        INTEGER      JCHR
C                               current column pointer for PUTOUT
        INTEGER      JPOS
C                               input string type from GETSTR (see above)
        INTEGER      NTYP
C                               number of scratch file records
        INTEGER      NSCR
C                               number of characters in string
        INTEGER      NCHR
C                               number of requested data items
        INTEGER      NREQ
C                               number of lines input on archive file
        INTEGER      LINE
C                               conversion from upper to lower case  
        INTEGER      CASE
C
        COMMON/QUASI/ REQU,RCNT,CLEN,ITEM,LOOP,SCR1,SCR2,LREC,LPOS,
     *  LLEN,IEOF,ICHR,JCHR,JPOS,NTYP,NSCR,NCHR,NREQ,EOFR,SLOG,WILD,
     *  NWILD,LINE,CASE
C
        COMMON/QUASC/ IBUF,OBUF,STRI,BLOK,TYPE,NAME,UNIT,VERS,TAB,BLOC
C
C-end-of-quasar-end-of-quasar-end-of-quasar-end-of-quasar-end-of-quasar-end





#-------------- CIF file named 'qtest.cif' for testing QUASAR --------------



data_P6122

loop_
_atom_type_symbol
_atom_type_oxidation_number
_atom_type_number_in_cell
_atom_type_scat_dispersion_REAL     #<< capitals to test case insensitivity
_atom_type_scat_dispersion_imag
_atom_type_scat_source
  S  0  6  .319  .557  Int_Tab_Vol_III_p202_Tab._3.3.1a
  O  0  6  .047  .032  Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.
  C  0  20  .017  .009  Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.
  RU  0  1  -.105   3.296  Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.


loop_
_atom_site_label
_atom_site_fract_x
_atom_site_fract_y
_atom_site_fract_z
_atom_site_U_iso_or_equiv
_atom_site_thermal_displace_type
_atom_site_calc_flag
_atom_site_calc_attached_atom
_atom_site_type_symbol
  s  .20200  .79800  .91667  .030(3)  Uij  ?  ?  s
  o  .49800  .49800  .66667  .02520  Uiso  ?  ?  o
  c1  .48800  .09600  .03800  .03170  Uiso  ?  ?  c

loop_
_atom_site_aniso_label
_atom_site_aniso_U_11
_atom_site_aniso_U_22
_atom_site_aniso_U_33
_atom_site_aniso_U_12
_atom_site_aniso_U_13
_atom_site_aniso_U_23
_atom_site_aniso_type_symbol
  s  .035(4)  .025(3)  .025(3)  .013(1)  .00000  .00000  s




#-------------- QUASAR request file 'qtest.req' -----------------------
#               Under unix execute as 'quasar.x <qtest.req'



star_arc_qtest.cif
star_out_qtest.out

data_                           #<< wild card block name -- accepts first

_atom_site_fract_               #<< this requests all fractional coord items
_atom_site_label 
_atom_site_aniso_LABEL          #<< capitals to test case insensitivity
_rubbish_to_see_what_happens    #<< request something that isn't in the CIF
_atom_site_aniso_U_11

data_P6122
_                               #<< this requests all data in this block





#-------------- *alternate* QUASAR request file 'qtest.rq2' ---------------
#               only check the logical integrity of a file
 
 
 
star_arc_qtest.cif
star_log
 
 
 

#-------------- QUASAR output file 'qtest.out' -------------------------
         after entering the request file 'qtest.req'




data_P6122                      


loop_
_atom_site_fract_x              
_atom_site_fract_y              
_atom_site_fract_z              
_atom_site_label                
  .20200 .79800 .91667 s
  .49800 .49800 .66667 o
  .48800 .09600 .03800 c1


loop_
_atom_site_aniso_label          
_rubbish_to_see_what_happens           # requested item not present
_atom_site_aniso_U_11           
  s ? .035(4)


#                 -----end-of-data-block-----



data_P6122                      


loop_
_atom_type_symbol               
_atom_type_oxidation_number     
_atom_type_number_in_cell       
_atom_type_scat_dispersion_REAL 
_atom_type_scat_dispersion_imag 
_atom_type_scat_source          
  S  0  6  .319  .557 Int_Tab_Vol_III_p202_Tab._3.3.1a
  O  0  6  .047  .032 Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.
  C  0 20  .017  .009 Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.
  RU 0  1 -.105 3.296 Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.


loop_
_atom_site_label                
_atom_site_fract_x              
_atom_site_fract_y              
_atom_site_fract_z              
_atom_site_U_iso_or_equiv       
_atom_site_thermal_displace_type
_atom_site_calc_flag            
_atom_site_calc_attached_atom   
_atom_site_type_symbol          
  s  .20200 .79800 .91667 .030(3) Uij  ? ? s
  o  .49800 .49800 .66667  .02520 Uiso ? ? o
  c1 .48800 .09600 .03800  .03170 Uiso ? ? c


loop_
_atom_site_aniso_label          
_atom_site_aniso_U_11           
_atom_site_aniso_U_22           
_atom_site_aniso_U_33           
_atom_site_aniso_U_12           
_atom_site_aniso_U_13           
_atom_site_aniso_U_23           
_atom_site_aniso_type_symbol    
  s .035(4) .025(3) .025(3) .013(1) .00000 .00000 s


#                 -----end-of-data-block-----



#---------------------- END OF TRANSMISSION ------------------------------
