module globals
integer, parameter :: maxentries=15000
integer, parameter :: maxnamelen=200
integer, parameter :: maxlangs=150
character (len=30) :: filename = 'spice_large.incl'
character (len=20) :: langs(maxlangs)
logical            :: mclass(maxlangs)
character (len=3)  :: codes(maxlangs)
character (len=200):: misslangs = ' '
integer            :: nlangs
integer :: longestname = 0
end module globals

program index
use globals
!use f90_unix_proc
implicit none
character (len=maxnamelen) :: names(maxentries,5) 
integer :: nentries,i,j

   open (1,file='spice_large.txt',status='old')
   open (2,file='x.x',status='unknown')
   open (3,file=filename,status='unknown', recl=500)
   open (4,file='spice_large.engl',status='unknown')
   open (5,file='spice_large.germ',status='unknown')
   open (16,file='langs.txt',status='old')

   call load_langs (16)
   close (16)
   call load_names (names,nentries)
   call sort_names (names,nentries)
   call writ_names (names,nentries)
!   print*,'Changing character references'
!   call system ('./spice_large.csh')
end program index

subroutine load_names (names,nentries)
! Reads data file and puts its contetnts in _names(i,{1,2,3})_
! names(i,1) = Anchor   (e.g., Myristica_fragrans)
! names(i,2) = Name     (e.g., Muskatnuß)
! names(i,3) = Language (e.g., German)
! names(i,4) is unused here, but will later become the 
!            sort key   (e.g., muskatnus) (see routine create_sort_key)
! names(i,5) = Plant identity, normally empty
use globals
implicit none
character (len=maxnamelen) :: names(maxentries,5) 
integer :: nentries, istat, nspices, pos
character (len=maxnamelen) :: anchor, name, language
character (len=maxnamelen) :: line

   nentries=1
   nspices=0

   do
      read (1,iostat=istat,fmt='(a)') line
      if (istat /= 0) exit
      if (line(1:1) == '*' .or. line ==' ') cycle
      if (line(1:1) /= ' ') then
         anchor=line
         nspices=nspices+1
       else
         pos=index(line,'|')
         if (pos /= 0) then
            names(nentries, 5) = line(pos+1:)
            line=line(:pos-1)
          else
            names(nentries, 5) = ' '
         endif
         call get_name_and_lang(line(2:),name,language)
         names(nentries,1)=anchor
         names(nentries,2)=name
         if (len_trim(name) > longestname) longestname = len_trim(name)
         names(nentries,3)=language
         nentries=nentries+1
         if (nentries > maxentries) then
            print*,'Memory overflow: Increase MAXENTRIES!'
            stop
         endif
      endif
   enddo
   close (1)
   nentries=nentries-1
   print '(tr1,i5,a,i3,a)',  nentries,' entries sucessfully read (', &
 &                            nspices,' anchors)'
   return
end subroutine load_names

subroutine get_name_and_lang (source,name,lang)
! Separates name and language, input _source_, output _name_ and _lang_
! Separator is either first comma or any semicolon not involved in HTML
! character notation.
use globals
implicit none
character (len=*) :: source,name,lang
character (len=maxnamelen) :: lang1,l
character (len=100) :: cut_word
logical :: semicolon, ampersand, comma, first
integer :: pos, i
character (len=1) :: char
logical :: found

   ampersand = .false.
   semicolon = .false.
   comma     = .false.
   pos       = 0

   do i=1,len_trim(source)
      char=source(i:i)
      if (char == '&') then
         if (ampersand) then
            print*,'double ampersand error'
            print*,source
            stop
          else 
            ampersand=.true.
         endif
       else if (char == ';') then
         if (ampersand) then
            ampersand = .false.
          else
            semicolon = .true.
            pos=i
            exit 
         endif
       else if (char == ',') then
         if (.not.comma) then
            comma = .true.
            pos=i
         endif
      endif
   enddo

   if (pos == 0) then
      print*,'Unstructured record error:'
      print*,source
      stop
   endif

   name=source(:pos-1)
   lang=source(pos+1:)
   do while (lang(1:1) == ' ')
      lang=lang(2:)
   enddo

   lang1=lang
   found=.false.
   do
       l=cut_word(lang1)
       if (l==' ') exit
       do i=1,nlangs
          found = found .or. (l == langs(i))
          if (found) exit
       enddo
       if (.not.found) then
          if (index(misslangs, trim(l)//' ') == 0) then
             misslangs = trim(misslangs) // ' ' // l
             print*,'WARNING: Unknown language: ',trim(l)
          endif
       endif
   enddo


   if (index(lang,',')>0) then
       lang=trim(lang) // ','
       first=.true.
       do i=1,nlangs
          if (index(lang,trim(langs(i))//',') >0 ) then
             if (first) then
                lang1=langs(i)
                first=.false.
              else
                lang1=trim(lang1) // ', ' // langs(i)
             endif
          endif
       enddo
       lang=lang1
   endif
   return
end subroutine get_name_and_lang
      
subroutine sort_names(names,nentries)
! Creates sort key from _names(i,2)_ to _names(i,4)_ and sorts ascendingly
use globals
implicit none
character (len=maxnamelen) :: names(maxentries,5),foo
integer :: nentries,i,j,k,ptr

   call create_sort_key(names,nentries)
   do i=1,nentries-1      ! straight selection sort
      ptr=i
      do j=i+1,nentries
         if (names(j,4) < names(ptr,4)) ptr=j
      enddo
      do k=1,5
         foo=names(i,k)
         names(i,k)=names(ptr,k)
         names(ptr,k)=foo
      enddo
   enddo

   if (.false.) then
   do i=1,nentries
      if (names(i,4)(1:1) == 'w') then
         print '(2(tr2,a20))', names(i,2),names(i,4)
      endif
   enddo
   endif
         
   print*,'Entries sorted'
end subroutine sort_names

subroutine create_sort_key(names,nentries)
! names(i,4)= new sort key: lowercase, blanks removed, _&abc;_ resolved to _a_
! special cases: _&szlig_ resolved to _ss_
!                _&eth_ resolved to _d_
!                _&schwa resolved to _e_
!                _&XYlig;_ resolved to _XY_
! 
use globals
implicit none
character (len=maxnamelen) :: names(maxentries,5)
integer :: nentries,i,j,k,inte,ce_start
character (len=maxnamelen) :: name,sort
character (len=16) :: equiv_char, ce_sequence
character (len=1) :: char
logical :: ampersand

   do i=1,nentries
      name=names(i,2)
      sort=' '
      ampersand=.false.  !  inside an html entity
      do j=1,len_trim(name)
         char=name(j:j)
         if (char=='-' .or. char==' ') char=' '
         if (char=='''') char=' '
         inte=ichar(char)
         if (inte >= ichar("A") .and. inte <= ichar("Z")) then
            char=achar(inte - (ichar("A") - ichar("a")))
          else
            if ( sort == ' ' .and. char /= '&' .and. .not. ampersand ) then
               print*,'Non-capital (',char,'): ', trim(name)
            endif         
         endif
         if (ampersand) then
            if (char == ';') then
               ampersand=.false.
               ce_sequence = name(ce_start:j)
               do k=1, len_trim (ce_sequence)
                  char=ce_sequence(k:k)
                  inte=ichar(char)
                  if (inte >= ichar("A") .and. inte <= ichar("Z")) then
                     ce_sequence(k:k)=achar(inte - (ichar("A") - ichar("a")))
                  endif
               enddo
               if (ce_sequence == '&szlig;') then
                  equiv_char='ss'
                else if (ce_sequence == '&schwa;' .or. ce_sequence == '&SCHWA;') then
                  equiv_char='e'
                else if (ce_sequence == '&eth;') then
                  equiv_char='d'
                else if (ce_sequence == '&thorn;') then
                  equiv_char='th'
                else if (ce_sequence(4:) == 'lig;') then
                  equiv_char=ce_sequence(2:3)
               endif
               sort = trim(sort) // trim(equiv_char) 
            endif
          else
            if (char == '&') then
               ampersand=.true.
               ce_start=j
               equiv_char=name(j+1:j+1)
               inte=ichar(equiv_char(1:1))
               if (inte >= ichar("A") .and. inte <= ichar("Z")) then
                  equiv_char=achar(inte - (ichar("A") - ichar("a")))
                else
                  if (sort == ' ') then
                     print*,'Non-capital entity: ', trim(name)
                  endif         
               endif
             else
               sort = trim(sort) // char
            endif
         endif
      enddo
      names(i,4)=sort
   enddo           
   do i=1,nentries
!      print '(i7,tr2,2a35)',i,names(i,2),names(i,4)
   enddo
   return
end subroutine create_sort_key

subroutine writ_names (names,nentries)
! Punches the sorted names
use globals
implicit none
character (len=maxnamelen) :: names(maxentries,5)
character (len=maxnamelen) :: last_name, last_anchor
character (len=maxnamelen) :: current_anchor, current_name, current_lang, current_bot, current_entry
character (len=1) :: init,oldinit(3)
character (len=13) :: makelink, link1, link2, link3
character (len=99) :: makelang, langspec
character (len=300) :: langhandle
integer :: i,nentries,j,k
integer :: countla=0, countde=0, counten=0
logical :: first


   oldinit=achar(ichar("A")-1)
   last_anchor=' '
   last_name=' '

   do k=1,3
      do i=ichar("A"), ichar("Z")
         write (2+k,'(5a)') ' <A class=int onClick="position(''init_'//achar(i)//''');return false" href="#init_',achar(i),'">',achar(i),&
 &                     '</A> &nbsp;'
      enddo
      write (2+k,'(tr1,A)') ' <P><HR><P>'
   enddo


   first=.true.
   do i=1,nentries
      init=names(i,2)(1:1)
      if (init == "&") init=names(i,2)(2:2)
      do k=1,3
         if (init /= oldinit(k)) then
            do j=ichar(oldinit(k))+1,ichar(init)
               if (.not. first) write (k+2,*) '</DIV>'
               write (k+2,'(/,8a,/)') &
 &                 '<H2><A class=bland name="init_',achar(j),'">&mdash; </A>', &
 &                  '<A class=int onClick="position(''top_of_index'');return false" href="#top_of_index">',achar(j),'</A> &mdash;</H2>'
               write (k+2,*) '<DIV class=idxlist>'
            enddo
            oldinit(k)=init
         endif
      enddo
      first=.false.
      do j=i+1,nentries
         if (names(i,4) /= names(j,4)) exit
         if ((names(i,1) == names(j,1))  .and.     &
 &           (names(i,2) == names(j,2))  .and.     &
 &           (names(i,5) == names(j,5))) then
            print*,'Spurious double entry: ', trim(names(i,2)), "   ",'(',trim(names(i,1)),')'
         endif
      enddo
      last_anchor = trim(names(i,1)) // names(i,5)
      last_name   = names(i,2)
      if (names(i,5) == ' ') then
         current_anchor=names(i,1)
         current_name=names(i,2)
         current_lang=names(i,3)
         current_bot=names(i,1)
         current_entry=trim(names(i,2)) // '</A>'
       else if (names(i,5)(1:1) == '|') then
         current_anchor=names(i,1)
         current_name=names(i,2)
         current_lang=names(i,3)
         current_bot=names(i,5)(3:)
         current_entry=trim(names(i,2)) // '</A>'
       else
         current_anchor=names(i,1)
         current_name=names(i,2)
         current_lang=names(i,3)
         current_bot=names(i,5)(2:)
         current_entry='(' // trim(names(i,2)) // ')</A>'
      endif
      langspec=' ' // makelang(current_lang)
      link1=makelink(current_anchor)
      write (2,'(tr1,13a)') '\tabline {',trim(current_bot),'} {', &
    &                      trim(current_name),'} {',trim(current_lang),'}' 
      write (3,'(20a)') '<P',trim(langspec),'><A href="',link1,'">', &
    &                   trim(current_entry(:longestname+4)) , &
    &                   ' ',trim(langhandle(current_lang))
!      write (3,'(20a)') '<P><A href="',link1,'" ', &
!    &                   trim(langspec), '>', &
!    &                   trim(current_entry(:longestname+4)) , &
!    &                   ' (',trim(current_lang),')'
      if (index(current_lang,'English') /= 0) then
         counten=counten+1
         write (4,'(5a)') &
    &       '  <A href="',link1,'"> ', trim(current_entry)
      endif
      if (index(current_lang,'German') /= 0) then
         countde=countde+1
         write (5,'(5a)') &
    &       '  <A href="',link1,'"> ', trim(current_entry)
      endif
      if (current_lang == 'Latin [bot.]') then
         do k=4,5
            write (k,'(5a)') &
    &   '  <BOT><A href="',link1,'"> ', trim(current_entry),'</BOT>' 
         enddo
         countla=countla+1
      endif
   enddo
   do k=1,3
      write (k+2,*) '</DIV>'
   enddo
   print*,'Entries successfully written to ',trim(filename)
   close (3)
   close (2)
   write (4,'(tr1,a,i5,a)') '<DIV id=counten style="display:none">',counten,'</DIV>'
   write (5,'(tr1,a,i5,a)') '<DIV id=countde style="display:none">',countde,'</DIV>'
   write (4,'(tr1,a,i5,a)') '<DIV id=countla style="display:none">',countla,'</DIV>'
   write (5,'(tr1,a,i5,a)') '<DIV id=countla style="display:none">',countla,'</DIV>'
   close (4)
   close (5)

end subroutine writ_names

character (len=300) function langhandle (lang)
character (len=*) :: lang
if (lang == "Latin [bot.]") then
   langhandle="bot."
else if (lang == "Latin [pharm.]") then
   langhandle="pharm."
else
   langhandle=lang
endif
end function
 

character (len=13) function makelink(name)
   character (len=*) :: name
   integer :: pos,i

   pos=-1
   do i=1,len_trim(name)
      if (name(i:i)=='_') then
         pos=i
         exit
      endif
   enddo
   if (pos == -1 ) then
      if (name /= "Silphion" ) then
         print*,'No _ found in ',trim(name)
         makelink=trim(name(:8)) // '.html'
       else
         makelink="Silphion.html"
      endif
    else
      makelink=name(1:4) // '_' // name(pos+1:pos+3) // '.html'
   endif

end function makelink

subroutine load_langs (ifile)
use globals
implicit none
integer :: ifile, istat, i,j,jj
character (len=4) :: c
character (len=80) :: l
character (len=80) :: line

   i=0
   do
      read (ifile,'(a)',iostat=istat) line
      if (istat /= 0) then
         nlangs=i
         exit
      endif
      i=i+1
      if (line(1:1) == ' ') then
         codes(i)=' '
         read (line,*) langs(i)
       else
         read (line,*) codes(i)
         langs(i)=line(len_trim(codes(i))+1:)
         do while (langs(i)(1:1) == ' ')
            langs(i)=langs(i)(2:)
         enddo
      endif
   enddo

   do i=1,nlangs
      l=langs(i)
      c=codes(i)
      jj=i
      do j=i+1,nlangs
         if (langs(j)<l) then
            l=langs(j)
            c=codes(j)
            jj=j
         endif
      enddo
      langs(jj)=langs(i)
      codes(jj)=codes(i)
      langs(i)=l
      codes(i)=c
      mclass(i)= (c/=' ') .and. (c/='fr') .and. (c/='de') .and. (c/='en') .and. (c/='la')
      if (l=='Latin') mclass(i)=.true.
   enddo

!   print '(tr1,a3,tr1,l1,tr1,a)', (codes(i),mclass(i),langs(i),i=1,nlangs)

end subroutine load_langs

character (len=99) function makelang(lang)
use globals
implicit none
character (len=*) :: lang
character (len=maxnamelen) :: lang1
character (len=100) :: codelist,l,cut_word
integer :: i
logical :: first,mc


   first=.true.
   lang1=lang
   l=' '

   makelang=' '
   first=.true.
   mc=.false.
   do 
      l=cut_word (lang1)
!      print*,'Try word ... ',trim(l)
      do i=1,nlangs
!         if (l == 'Old Greek') print*,i,trim(langs(i))
         if (.not. mclass(i)) cycle
         if ((trim(langs(i)) == trim(l)) .and. mclass(i)) then
            if (codes(i) /= ' ') then
               mc = mc .or. mclass(i)
               if (first) then
                  codelist = codes(i)
                  first=.false.
                  makelang='x='//codelist
                else
                  codelist = trim(codelist) // ' ' // codes(i)
                  makelang='x="'//trim(codelist)//'"'
               endif
!               print*,'Found: ',trim(codes(i))
               exit
            endif
         endif
      enddo
      if (lang1 == ' ') exit
   enddo
   if (.not. mc) makelang=' '

!   print '(tr1,10a)','makelang: ``',trim(lang),"'' converted to ``",trim(makelang),"''"

      
end function makelang

character (len=100) function cut_word(l)
character(len=*) :: l
integer :: i

!!print*,'cut_word: l=',l
i=index(l,',')
if (i == 0) then
   cut_word=l
   l=' '
else
   cut_word = l(:i-1)
   l=l(i+1:)
   if (l /= ' ') then
      do while (l(1:1) == ' ')
         l=l(2:)
      enddo
   endif
endif

!print*,'cut_wort: ``',trim(cut_word),"'' cut, returned ",trim(l)
end function