C++*********************************************************************
C
C LISTDC.F                                          REWRITTEN DEC 89 AL
C                             OPENDOC PARAMETERS  DEC 2000 ARDEAN LEITH
C                             INCORE SUPPORT      JUL 2003 ARDEAN LEITH
C
C **********************************************************************
C=* FROM: SPIDER - MODULAR IMAGE PROCESSING SYSTEM.   AUTHOR: J.FRANK  *
C=* Copyright (C) 1985-2005  Health Research Inc.                      *
C=*                                                                    *
C=* HEALTH RESEARCH INCORPORATED (HRI),                                *   
C=* ONE UNIVERSITY PLACE, RENSSELAER, NY 12144-3455.                   *
C=*                                                                    *
C=* Email:  spider@wadsworth.org                                       *
C=*                                                                    *
C=* This program is free software; you can redistribute it and/or      *
C=* modify it under the terms of the GNU General Public License as     *
C=* published by the Free Software Foundation; either version 2 of the *
C=* License, or (at your option) any later version.                    *
C=*                                                                    *
C=* This program is distributed in the hope that it will be useful,    *
C=* but WITHOUT ANY WARRANTY; without even the implied warranty of     *
C=* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU  *
C=* General Public License for more details.                           *
C=*                                                                    *
C=* You should have received a copy of the GNU General Public License  *
C=* along with this program; if not, write to the                      *
C=* Free Software Foundation, Inc.,                                    *
C=* 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.      *
C=*                                                                    *
C **********************************************************************
C
C  LISTDC(FCHAR,DOCNAM,DUM,NDOCT,ISEQ)
C
C  PURPOSE:       LIST DOCUMENT FILE TO RESULTS FILE OR TERMINAL 
C                 WITH HEADINGS
C
C  PARAMETERS:    FCHAR     80 CHARACTER LINE STARTING WITH LD   (SENT)
C                 DOCNAM    DOCUMENT FILE NAME WITH EXTENSION    (SENT)
C                 DUM       UNUSED
C                 NDOCT      LOGICAL UNIT NUMBER                  (SENT)
C                 ISEQ      INDICATES WHETHER THE FILE HAS 
C                           SEQUENTIAL(ISEQ=1)
C                           OR RANDOM (ISEQ=0) KEY ORDER         (SENT)
C
C  NOTE:          ALLOWABLE LENGTH OF EACH HEADING IS 8.
C
C--*********************************************************************

	SUBROUTINE LISTDC(FCHAR,DOCNAM,DUM,NDOCT,ISEQ)

	COMMON /UNITS/LUN,NIN,NOUT,NECHO,IFOUND,NPROC,NDAT
        COMMON /COMMUN/ RECLIN,HEADE,DLIST

	DIMENSION       DLIST(10)
        CHARACTER * (*) DOCNAM,FCHAR
        CHARACTER(LEN=80) :: RECLIN,HEADE,DOC
        CHARACTER(LEN=1) :: NULL
	LOGICAL :: EX,ADDEXT,ISOLDFILE,GETNAME,APPEND,MESSAGE,NEWFILE

	DATA MAXHD/8/

        NULL = CHAR(0)

	NDEV = NDAT
C       DEFAULT PRINTING DEVICE IS LP

        HEADE = ' ' // NULL

C       OPEN THE DOC FILE
        DOC  = DOCNAM
        CALL OPENDOC(DOC, .FALSE., NLET, NDOCT,NDOC, .FALSE., .TRUE.,
     &               'DOCUMENT',.FALSE., .FALSE., NEWFILE, IRTFLG)
        IF (IRTFLG .NE. 0) RETURN
        IF (NDOC .LE. 0) THEN
           CALL ERRT(101,'OPERATION CAN NOT LIST INCORE DOC FILE.',NE)
           RETURN
        ENDIF 

C       INDXF KEEPS TRACK OF POSITION IN LD LINE
C       INDXH IS THE NUMBER OF HEADINGS 

	INDXH = 0
	INDXF = 3
	IF (FCHAR(4:4) .EQ. 'T') THEN
            INDXF = 5
            NDEV  = NOUT
        ENDIF

10	LEN=0
C       SEARCH FOR A ' CHARACTER IN THE OPERATION STRING

11	INDXF = INDXF + 1
        IF (FCHAR(INDXF:INDXF) .NE. CHAR(39)) THEN
C          CONTINUE UNTIL ' FOUND OR END OF STRING
           IF (INDXF .LT. 80) GOTO 11

        ELSE
C          START OF A NEW HEADING
           INDXH = INDXH + 1
           IF (INDXH .GT. MAXHD) THEN
              WRITE(NOUT,*) ' *** SYNTAX ERROR, TOO MANY HEADINGS'
              CLOSE(NDOC)
              RETURN
           ENDIF
           INDXF = INDXF + 1
C          ITEMP IS PRESENT POINTER TO STRING LOCATION
           ITEMP = INDXF

30	   IF (FCHAR(ITEMP:ITEMP) .EQ. CHAR(39)) THEN
C            REACHED END OF THIS HEADING
             IF (LEN .GT. 8) LEN = 8
             IGO = (INDXH - 1) * 10 + 1
             HEADE(IGO:IGO+9) = FCHAR(INDXF:INDXF+LEN-1)
             INDXF = ITEMP
             IF (INDXF .LT. 80) GOTO 10

           ELSE
C            STILL IN PRESENT HEADING
             LEN   = LEN + 1
             ITEMP = ITEMP + 1
             GOTO 30
           ENDIF
        ENDIF

C       FINISHED WITH ALL HEADINGS
        IF (INDXH .EQ. 0) THEN
           WRITE(NOUT,*) '*** DEFAULTS TO 2 COLUMNS WITHOUT HEADINGS'
           INDXH = 2
        ENDIF
	READ(NDOC,175,END=300) RECLIN

	WRITE(NDEV,70) RECLIN(1:80)
70	FORMAT(//1X,A)

	WRITE(NDEV,75) HEADE (1:10),HEADE(11:20),HEADE(21:30),
     &                 HEADE(31:40),HEADE(41:50),HEADE(51:60),
     &                 HEADE(61:70),HEADE(71:80)
75	FORMAT(/,'  KEY   ',8(A10,1X)/)

	NFIRST = 0
	MIN    = 1000000
	MAX    = 1

150	READ(NDOC,175,END=300) RECLIN
175	FORMAT(A)

	IF (RECLIN(2:2) .EQ. ';') GOTO 150
        IF (RECLIN(5:5) . EQ. ' ') THEN
           READ (RECLIN(:4),180) NKEY
180	   FORMAT(I4)
        ELSE
           READ (RECLIN(:5),680) NKEY
680	   FORMAT(I5)
        ENDIF

        IF (NKEY .NE. -99) THEN
C          NOT A CONTINUATION LINE            
           IF (NKEY .LT. MIN) MIN = NKEY
           IF (NKEY .GT. MAX) MAX = NKEY
        ENDIF
	GOTO 150


300	REWIND NDOC
	IF (FCHAR(5:5) .EQ. 'T') LERR = -1
   
C       NOPEN=1 MEANS DOCUMENT FILE IS ALREADY ASSIGNED (FOR UNSAV)
C       NOPEN<0 MEANS DO NOT WRITE ERROR MESSAGES FROM UNSAV


	DO I = MIN,MAX
           NOPEN  = -1
           CALL UNSAV(DOCNAM,NOPEN,NDOC,I,DLIST,INDXH,LERR,ISEQ)
           IF (LERR .NE. 0. AND. NFIRST .EQ. 0) GOTO 8200
           IF (LERR .EQ. 0) THEN
             NFIRST=1
             WRITE(NDEV,400) I,(DLIST(K),K=1,INDXH)
400	     FORMAT(I5,2X,8(F10.6,1X))
           ENDIF
        ENDDO

        WRITE(NOUT,*) ' '

8200	CLOSE(NDOC)
        RETURN

	END