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)') '
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, '') endif enddo call out_html(htmlout, ' ') call out_html(0, '' close(lunin) close(lunout) close(htmlout) end
') 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, '') call out_html(0,line(p+1:p+i-1)) call out_html(0,'') 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)') '