Initial commit

gen/make_help.f

@@ -0,0 +1,161 @@
+	subroutine out_html(lun, str)
+
+! lun = 0: put into buffer
+! lun != 0: write buffer to lun
+
+	integer lun
+	character str*(*)
+	integer l/0/
+	save l
+	character*1024 line
+	save line
+
+	integer ls
+
+	if (lun .eq. 0) then
+	  ls=len(str)
+	  if (l .ge. len(line)) then
+	    l=len(line)-1
+	  endif
+	  if (l+ls .gt. len(line)) then
+	    ls=1
+	  endif 
+	  line(l+1:l+ls)=str
+	  l=l+ls
+	else
+	  write(lun, '(a)') line(1:l)
+	  l=0
+	endif
+	end
+	
+	subroutine make_help(lunin)
+	
+	integer lunin
+	integer lunout
+	integer htmlout
+	character line*132, tab*1, upcase*64
+	integer l, iostat, i, fmt, p
+	
+	tab=char(9)
+	lunout=2
+	htmlout=3
+	if (lunout .eq. lunin) then
+	  print *,'lun mismatch'
+	  stop 'error in MAKE_HELP'
+	endif
+	call sys_open(lunout, 'fit_help.f', 'wo', iostat)
+	if (iostat .ne. 0) then
+	  print *,'cannot write fit_help.f'
+	  stop 'error in MAKE_HELP'
+	endif
+	call sys_open(htmlout, 'fit_help.html', 'wo', iostat)
+	if (iostat .ne. 0) then
+	  print *,'cannot write fit_help.html'
+	  stop 'error in MAKE_HELP'
+	endif
+
+	write(lunout,'(a,9(/,a))')
+	1 '! DO NOT EDIT this subroutine.'
+	1,'! It is automatically created with: make_custom fit.help'
+	1,tab//'subroutine fit_help(topic)'
+	1,tab//'character topic*(*), topup*64'
+	1,tab//'integer l'
+	1,tab//'topup(1:1)='' '''
+	1,tab//'call str_upcase(topup(2:), topic)'
+	1,tab//'call str_trim(topup, topup, l)'
+	1,tab//'if (topup .eq. '' '') then'
+	1,tab//'  print 1'
+
+	write(htmlout, '(a)') '<pre>FIT HELP'
+	fmt=1
+1	read(lunin, '(a)',err=99,end=99) line
+	if (line(1:1) .eq. '=') then
+	  if (fmt .ne. 1) write(lunout,'(a)') tab//'1)'
+	  do i=1,len(line)
+	    if (line(i:i) .eq. '=') line(i:i)=' '
+	  enddo
+	  call str_trim(line, line, l)
+	  call str_upcase(line(1:l), line(1:l))
+	  i=1
+          do while (i.lt.l)
+            if (line(i:l) .ne. ' ') then
+              do while (line(i:i) .eq. ' ')
+                i=i+1
+              enddo
+	      p=i
+              do while (line(i:i) .gt. ' ')
+                i=i+1
+              enddo
+	      call out_html(0, '<a name="')
+	      call out_html(0,line(p:i-1))
+	      call out_html(0, '"></a>')
+	    endif
+	  enddo
+	  call out_html(htmlout, ' ')
+	  call out_html(0, '<hr>')
+	  call out_html(htmlout, ' ')
+	  write(lunout,'(a)') tab//'elseif (index('
+	  if (l .gt. 60) then
+	    write(lunout,'(3a/3a)')
+	1     tab//'1'' ',line(1:60),''''
+	1     ,tab//'1//''',line(61:l),''''
+	  else
+	    write(lunout,'(3a)') tab//'1'' ',line(1:l),''''
+	  endif
+	  write(lunout,'(a)') tab//'1 ,topup(1:l)) .ne. 0) then'
+	  write(lunout,'(a,i4/i4,a)')
+	1   tab//'print ',fmt,fmt,tab//'format ('
+	  fmt=fmt+1
+	else
+	  call str_trim(line, line(1:len(line)-1), l)
+	  p=0
+	  i=index(line(p+1:l+1), '"')
+	  do while (i .ne. 0)
+	    if (i .gt. 1) then
+	      call out_html(0, line(p+1:p+i-1))
+	    endif
+	    p=p+i
+	    i=index(line(p+1:l+1), '"')
+            if (i .eq. 0) then
+	      call out_html(htmlout, ' ')
+	      print *,'ERROR'
+	      write(htmlout, '(a)') 'ERROR'
+	      close(htmlout)
+	    else if (i .gt. 1) then
+	      call str_upcase(upcase, line(p+1:p+i-1))
+	      call out_html(0, '<a href="#')
+	      call out_html(0,upcase(1:i-1))
+	      call out_html(0,'">')
+	      call out_html(0,line(p+1:p+i-1))
+	      call out_html(0,'</a>')
+	    endif
+	    p=p+i
+	    i=index(line(p+1:l+1), '"')
+	  enddo
+	  call out_html(0, line(p+1:l+1))
+	  call out_html(htmlout, ' ')
+	  p=0
+20	  i=index(line(p+1:), '''')
+	  if (i .ne. 0) then
+	    p=p+i
+	    line(p+1:l+1)=line(p:l)
+	    p=p+2
+	    l=l+1
+	    goto 20
+	  endif
+	  if (l .gt. 60) then
+	    write(lunout, '(3a/3a)')
+	1 tab//'1/'' ',line(1:60),''''
+	1,tab//'1,''',line(61:l),''''
+	  else
+	    write(lunout,'(3a)')
+	1 tab//'1/'' ',line(1:l),''''
+	  endif
+	endif
+	goto 1
+99	write(lunout,'(a/a/a)') tab//'1)',tab//'endif',tab//'end'
+	write(htmlout, '(a)') '</pre>'
+	close(lunin)
+	close(lunout)
+	close(htmlout)
+	end