C
C **** PROGRAM INDIC3
C
C      Create an index of the categories and data items in a dictionary.
C
C      Version 6:  Feb 2007
C
      include 'indic.cmn'
C
      CASE=ICHAR('a')-ICHAR('A')
      TAB=CHAR(05)
      IF(CASE.LT.0) GOTO 100
      TAB=CHAR(09)
Cdbug write(6,'(4I5)') ICHAR('a'),ICHAR('A'),ICHAR('z'),ICHAR('Z')
C
100   CALL INDX
C
      END
C
C
C***************************************************************************
C
      CHARACTER*60 FUNCTION LCASE(ICASE,N)

      INTEGER N
      CHARACTER*60 ICASE
      CHARACTER*1 A

      LCASE=' '
      DO 100 I = 1,N 
      A = ICASE(I:I)
      IF(A.EQ.' ') GOTO 150
      J = ICHAR(A)
      IF(J.LT.65.OR.J.GT.90) GOTO 100
      A=CHAR(J+32)
100   LCASE(I:I)=A
150   CONTINUE
      END
C
C***************************************************************************
C
      SUBROUTINE INDX
      include 'indic.cmn'
      INTEGER I,J,N,FLAG
      CHARACTER*60 HEAD,CATEG,LCASE,NAME1,NAME2,LSTRG,SPACE
      CHARACTER*60 NAME(100)                
	  CHARACTER*2 JJ(2)
	  DATA JJ/'no','  '/
C
      FLAG=0
      NSAV=0
      NCAT=0
      NLEV=0
      ICHR=80
      PNAM(1)=' '
	  SPACE=' '
	  DO 1 I=1,200
1     CLAS(I)=' '
C
10    CALL GETSTR 
      IF(IEOF .eq. 1) GOTO 600 
C
      IF(ITYP.EQ.'val') GOTO 100

      IF(STRI(1:17).EQ.'_definition.scope')     FLAG=1
      IF(STRI(1:14).EQ.'_definition.id')        FLAG=2
      IF(STRI(1:19).EQ.'_category.parent_id')   FLAG=3
      IF(STRI(1:15).EQ.'_name.object_id')       FLAG=4
      IF(STRI(1:17).EQ.'_definition.class')     FLAG=5
      IF(STRI(1:17).EQ.'_name.category_id')     FLAG=6
      IF(STRI(1:21).EQ.'_category.parent_join') FLAG=7
      IF(STRI(1:21).EQ.'_category_key.generic') FLAG=8
      IF(STRI(1:21).EQ.'_category_key.primiti') FLAG=8
      GOTO 10
C
100   IF(FLAG.EQ.0) GOTO 10
      LSTRG=LCASE(STRI(1:NCHR),NCHR)
C
C ------------------------------------ definition scope
      IF(FLAG.NE.1) GOTO 130
      NAME1=LSTRG
      IF(NAME1(1:10).EQ.'dictionary') CATF=1
      IF(NAME1(1: 8).EQ.'category')   CATF=2
      IF(CATF.EQ.0) GOTO 500
      NCAT=NCAT+1 
      SCAT(NSAV)=NCAT
      CNAM(NCAT)=NAME2
	  KSAV(NCAT)=NSAV
      IF(NCAT.GT.1) GOTO 500
      HEAD=NAME2
      LEVN(1)=0
      FAMN(1)=0
      GOTO 500
C
C ------------------------------------ definition id
130   IF(FLAG.NE.2) GOTO 160
      NAME2=LSTRG
      GOTO 500
C
C ------------------------------------ parent category id
160   IF(FLAG.NE.3) GOTO 170
      IF(CATF.EQ.0) GOTO 170
      PNAM(NCAT)=LSTRG
      GOTO 500
C
C ------------------------------------ object id  
170   IF(FLAG.NE.4) GOTO 180
      DO 172 I=1,60
      IF(SNAM(NSAV)(I:I).EQ.'.') GOTO 175
172   CONTINUE
175   IF(STRI(1:NCHR-1).EQ.SNAM(NSAV)(I+1:I+NCHR-1)) GOTO 500
      WRITE(6,'(a,a)') " Inconsistent object id for ", SNAM(NSAV)
C
C ------------------------------------ definition class
180   IF(FLAG.NE.5) GOTO 190
      IF(CLAS(NCAT).EQ.' ') CLAS(NCAT)=LSTRG(1:4)
	  JOIN(NCAT)=1
      IF(CLAS(NCAT).NE.'list') GOTO 500
	  JOIN(NCAT)=0
      GOTO 500
C
C ------------------------------------ category id
190   IF(FLAG.NE.6) GOTO 200
      CATEG=LSTRG
      SCAT(NSAV)=NCAT
      NAME1=LCASE(SNAM(NSAV),60)
      IF(NAME1.EQ.NAME2) GOTO 500
      WRITE(6,'(5(a,1x))') " Inconsistent tag for ", SNAM(NSAV),
     * STRI,NAME1,NAME2
      GOTO 500
C
C ------------------------------------ parent join flag
200   IF(FLAG.NE.7) GOTO 210
      IF(LSTRG(1:3).EQ.'yes') JOIN(NCAT)=1
	  GOTO 500
C
C ------------------------------------ category key id
210   IF(FLAG.NE.8) GOTO 500
      IF(CLAS(NCAT).EQ.'list') GOTO 500
      WRITE(6,'(2(a,1x))') " Def class & key inconsistent ",SNAM(NSAV)
	  GOTO 500
C
C --------------------------------------------------------------
500   CONTINUE

Cdbug write(6,'(4i3,5x,4(a,1x))') NSAV,NCAT,FLAG,JOIN(NCAT),
Cdbug* SNAM(NSAV)(1:30), CLAS(NCAT), ITYP, STRI(1:NCHR)
      FLAG=0
      GOTO 10
C
600   CONTINUE
Cdbug  write(6,'(2i5,5x,a,5x,a30,a30)') (I,JOIN(I),CLAS(I),
Cdbug* CNAM(I),PNAM(I),I=1,NCAT)
Cdbug  write(6,'(2i5,5x,a35)') (I,SCAT(I),SNAM(I),I=1,NSAV)
C
C
C--------------------------- determine the nest level and family
C
      NFAM=0
	  JSAV(1)=KSAV(1)
C                      loop nest levels
      DO 650 K=1,100  
C                      loop over stored categories  
      DO 640 J=2,NCAT
      NAME2=PNAM(J)
      IF(FAMN(J).GT.0)            GOTO 640
C                      loop over stored categories  
      DO 630 I=1,NCAT
      IF(CNAM(I).NE.NAME2)        GOTO 630
      JSAV(J)=KSAV(I)
	  CATN(J)=I
      IF(NAME2.NE.HEAD)           GOTO 620
      NFAM=NFAM+1
      FAMN(J)=NFAM
      LEVN(J)=1
      GOTO 650
620   IF(LEVN(I).EQ.0.AND.I.GT.1) GOTO 640
      FAMN(J)=FAMN(I)
      LEVN(J)=LEVN(I)+1
      GOTO 650
630   CONTINUE
      WRITE(6,'(a,a)') " Parent category not found? ", NAME2
      STOP
640   CONTINUE
650   CONTINUE
Cdbug  write(6,'(5i5,5x,a,5x,a30,a30)') (I,JOIN(I),KSAV(I),JSAV(I),
Cdbug* CATN(I), CLAS(I), CNAM(I), PNAM(I), I=1,NCAT)
C
C------------------------- reorder the index map by hierarchy
      ORDR(1)=1
	  M=1
C                  Loop over families
      DO 690 I=1,100
C                  Loop over nest levels
      DO 680 J=1,100
C                  Loop over categories
      DO 660 K=1,NCAT
	  IF(ORDR(K).NE.0) GOTO 660
	  IF(FAMN(K).NE.I) GOTO 660
	  IF(LEVN(K).NE.J) GOTO 660
	  M=M+1
	  NAME1=CNAM(K)
	  ORDR(K)=M
	  GOTO 662
660   CONTINUE
C                 follow the threads of this tag   
662   IR=1
665   IT=1
	  NAME(IT)=NAME1
666   L=M
C
667   DO 670 N=1,NCAT
	  IF(ORDR(N).NE.0)        GOTO 670
	  IF(NAME(IT).NE.PNAM(N)) GOTO 670
	  IF(IR.EQ.0)             GOTO 668
	  IL=SLEN(JSAV(N))-1
      IF(PNAM(N)(1:IL).NE.CNAM(N)(1:IL)) GOTO 670
668   M=M+1
	  ORDR(N)=M
	  IT=IT+1
	  NAME(IT)=CNAM(N)
	  GOTO 675
670   CONTINUE
C
675   IF(M.EQ.NCAT) GOTO 690
      IF(M.GT.L)    GOTO 666
677   IT=IT-1
	  IF(IT.EQ.0)   GOTO 678
	  NAME1=NAME(IT)
	  GOTO 666
678   IF(IR.EQ.0)   GOTO 680
      IR=0
	  GOTO 665
680   CONTINUE
690   CONTINUE
C
C --------print the category summary
C
      Write(6,'(/15x,a//2a/)')"  SUMMARY OF CATEGORY HIERARCHY",
     *   "  Lev Fam Ord   Category                      Parent",
     *   "                       Scope   Join"
      WRITE(6,'(2i4,i5,3x,a30,a30,a4,a5)')(LEVN(I),FAMN(I),ORDR(I),
     * CNAM(I), PNAM(I), CLAS(I), JJ(JOIN(I)+1), I=1,NCAT)
 
C
C---------------- drop levels for joined categories
      DO 700 I=1,10
	  DO 700 J=1,NCAT
	  IF(LEVN(J).NE.I) GOTO 700
	  N=LEVN(CATN(J))
	  IF(JOIN(J).EQ.0) N=N+1
	  LEVN(J)=N
700   CONTINUE
C
C --------print the hierarchy
C
      WRITE(6,'(//2(15x,a/))') 
     *   '  ITEM HIERARCHY - INDENTS SHOW LIST NESTING'
     * , '  (sets & joined lists same level as parents)'
C
C                        loop over thread order
      DO 800 IT=1,NCAT
C                        loop over categories     
      DO 750 I=1,NCAT
	  IF(IT.NE.ORDR(I))    GOTO 750
	  ISAV=KSAV(I)
	  M=ISAV
      L=LEVN(I)
	  IF(JOIN(I).GT.0) L=LEVN(CATN(I))
	  L=L*10+1
710   J=SLEN(ISAV)
      K=SLEN(JSAV(I))
      IF(ISAV.GT.M)        GOTO 720
      WRITE(6,'(1x)')
	  IF(CLAS(I).EQ.'set') GOTO 730
      WRITE(6,'(5a)') SPACE(1:L), SNAM(ISAV)(2:J), '  (parent: ',
     * PNAM(I)(1:K),')'
	  GOTO 730
720   WRITE(6,'(2a)') SPACE(1:L),SNAM(ISAV)(2:J)
730   ISAV=ISAV+1
	  IF(SCAT(ISAV).NE.I) GOTO 750
      GOTO 710
750   CONTINUE
800   CONTINUE
C
      RETURN
      END
C
C***************************************************************************
C
      SUBROUTINE GETSTR
      include 'indic.cmn'
C
      INTEGER       I
      CHARACTER C*1
C
10    ICHR=ICHR+1
      ITYP='val'
      IF(ICHR.LE.80)     GOTO 30
C
20    READ(5,'(A)',END=95) IBUF
      ITYP='val'
      IF(IBUF(1:1).NE.';') GOTO 25
22    READ(5,'(A)',END=95) IBUF
      IF(IBUF(1:1).NE.';') GOTO 22
25    ICHR=1
      ITYP='val'
C
      IF(IBUF(1:5).NE.'save_') GOTO 30
      NSAV=NSAV+1
      CATF=0
      DO 27 I=5,64
      IF(IBUF(I:I).EQ.' ') GOTO 28
27    CONTINUE
28    SLEN(NSAV)=I-5
      SNAM(NSAV)=IBUF(5:I+4)
      GOTO 20
C
30    C=IBUF(ICHR:ICHR)
      IF(C.NE.'_')       GOTO 40
      ITYP='tag'
      GOTO 45
40    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

45    DO 50 I=ICHR,80
      IF(IBUF(I:I).EQ.' ')       GOTO 55
      IF(IBUF(I:I).EQ.TAB)       GOTO 55
50    CONTINUE
55    LCHR=I
      NCHR=I-ICHR
      ICHR=LCHR
      GOTO 90 
C
60    ICHR=ICHR+1
      DO 70 I=ICHR,80
      IF(IBUF(I:I).EQ.C)         GOTO 80
70    CONTINUE
80    LCHR=I
      NCHR=I-ICHR
      ICHR=LCHR+1

90    STRI(1:NCHR)=IBUF(LCHR-NCHR:LCHR-1)
Cdbug write(6,'(3I3,2a)')LCHR,NCHR,ICHR,IBUF(1:LCHR),STRI(1:NCHR)
      GOTO 100
95    IEOF=1
100   RETURN
      END
