162 lines
3.7 KiB
Fortran
162 lines
3.7 KiB
Fortran
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
|