726 lines
18 KiB
Fortran
726 lines
18 KiB
Fortran
subroutine cho_inq(arg, gdev, pps, cols, rows)
|
|
|
|
implicit none
|
|
|
|
character arg*(*), pps*(*), gdev*(*)
|
|
integer cols, rows
|
|
|
|
character str*80, old1*80, old2*80, line*80
|
|
character typ*2, home*128, host*80, system*16
|
|
integer c,r,i,l,id,tim,cnt,inter,n,j
|
|
integer iostat
|
|
logical homeflag
|
|
|
|
cols=0
|
|
rows=0
|
|
call pgqndt(n)
|
|
str=' '
|
|
pps=' '
|
|
gdev=' '
|
|
r=0
|
|
|
|
call sys_remote_host(host, typ)
|
|
if (typ .eq. 'XW') then
|
|
gdev='XWINDOW'
|
|
goto 30
|
|
endif
|
|
if (typ .eq. 'LO') goto 90 ! local without XWINDOW
|
|
call sys_check_system(system)
|
|
if (system .ne. 'TRU64') goto 90 ! on linux no other devices supported
|
|
|
|
! remote login without XWINDOW
|
|
if (arg .ne. ' ') then
|
|
cnt=5
|
|
call str_trim(str, arg, l)
|
|
goto 21
|
|
endif
|
|
cnt=0
|
|
20 cnt=cnt+1
|
|
if (cnt .eq. 2) then
|
|
old1=str
|
|
elseif (cnt .eq. 3) then
|
|
if (str .eq. old1) goto 80
|
|
print *,'Please do not touch the keyboard!',char(7)
|
|
call sys_wait(1.0)
|
|
old2=str
|
|
elseif (cnt .eq. 4) then
|
|
if (str .eq. old1 .or. str .eq. old2) goto 80
|
|
print *,'Do not touch the keyboard, please !!!',char(7)
|
|
call sys_wait(2.0)
|
|
elseif (cnt .gt. 4) then
|
|
goto 90
|
|
endif
|
|
r=0
|
|
c=0
|
|
|
|
print '(X,A,$)', ' '
|
|
call sys_rd_tmo(char(5),str,l)
|
|
c print *,str(1:max(1,l))
|
|
|
|
21 if (l .gt. 2 .and. str(1:2) .eq. '_ ') then
|
|
i=index(str(1:l),',')
|
|
if (i .ne. 0) then
|
|
if (i .le. 3 .or. i .ge. l) goto 20
|
|
r=-1
|
|
read(str(i+1:l), *, err=22,end=22) r,c
|
|
22 if (r .lt. 0) goto 20
|
|
if (r .eq. 58) print *,'terinq_debug: r=58'
|
|
l=i-1
|
|
endif
|
|
i=index(str(1:l),';')
|
|
if (i .eq. 0) then
|
|
gdev=str(3:l)
|
|
else
|
|
if (i .gt. 3) gdev=str(3:i-1)
|
|
if (i .lt. l) pps=str(i+1:l)
|
|
endif
|
|
|
|
goto 60
|
|
|
|
endif
|
|
|
|
|
|
30 cnt=10 ! exit anyway
|
|
|
|
call cho_load(host, gdev, pps)
|
|
|
|
60 if (gdev .ne. ' ') then
|
|
do i=1,n
|
|
call pgqdt(i, str, l, line, j, inter)
|
|
if (l .gt. 0 .and. inter .eq. 1) then
|
|
if (str(2:) .eq. gdev) goto 70
|
|
endif
|
|
enddo
|
|
if (gdev .eq. 'VT240') then
|
|
gdev='VT125'
|
|
else if (gdev .eq. 'VMAC') then ! if VMAC not installed, do not ask again
|
|
gdev=' '
|
|
cnt=10
|
|
else
|
|
gdev=' '
|
|
endif
|
|
70 continue
|
|
endif
|
|
|
|
80 if (r .eq. 58 .or. rows .eq. 58) then
|
|
print *,'terinq_debug:',r,rows
|
|
endif
|
|
if (r .gt. 3 .and. r .lt. 100) then
|
|
rows=r
|
|
endif
|
|
if (c .ge. 40 .and. c .le. 255) then
|
|
cols=c
|
|
endif
|
|
if (gdev .eq. ' ' .and. cnt .le. 4) goto 20 ! try again
|
|
90 call cho_vpp_cups(pps)
|
|
end
|
|
|
|
|
|
subroutine cho_load(host, gdev, pps)
|
|
!
|
|
! load graphic device GDEV and print destination PPS from the line
|
|
! starting with HOME from preferences file
|
|
!
|
|
character*(*) host, gdev, pps
|
|
|
|
integer lun, l, j, ld, iostat
|
|
character line*80, home*80
|
|
|
|
call sys_get_lun(lun)
|
|
call sys_home(home)
|
|
call str_trim(home, home, l)
|
|
call str_trim(host, host, ld)
|
|
|
|
call sys_open(lun, home(1:l)//'terinq.pref', 'r', iostat)
|
|
if (iostat .ne. 0) goto 29
|
|
|
|
25 read(lun, '(a)',end=27,err=27) line
|
|
l=index(line,':')
|
|
if (l .gt. 1) then
|
|
c print *,'host: "',host(1:ld),'"'
|
|
if (index(line(1:l-1), host(1:ld)) .ne. 0) then
|
|
j=index(line(l+1:),';')
|
|
if (gdev .eq. ' ') then
|
|
if (j .eq. 0) then
|
|
gdev=line(l+1:)
|
|
elseif (j .gt. 1) then
|
|
gdev=line(l+1:l+j-1)
|
|
endif
|
|
endif
|
|
if (pps .eq. ' ') then
|
|
if (j .gt. 0 .and. l+j .le. len(line)) then
|
|
pps=line(l+j+1:)
|
|
endif
|
|
endif
|
|
close(lun)
|
|
goto 29
|
|
endif
|
|
endif
|
|
goto 25
|
|
27 close(lun)
|
|
29 call sys_free_lun(lun)
|
|
end
|
|
|
|
|
|
subroutine cho_save(host, devdest)
|
|
|
|
character host*(*), devdest*(*) ! no trailing blanks, please
|
|
integer lun, lun1
|
|
|
|
character home*128, line*128
|
|
logical done
|
|
integer l,ll,lh,iostat
|
|
|
|
call sys_get_lun(lun)
|
|
call sys_home(home)
|
|
call str_trim(home, home, lh)
|
|
|
|
done=.false.
|
|
|
|
call sys_get_lun(lun1)
|
|
call sys_open(lun1, home(1:lh)//'terinq.pref1', 'w', iostat)
|
|
if (iostat .ne. 0) goto 91
|
|
|
|
call sys_open(lun, home(1:lh)//'terinq.pref', 'r', iostat)
|
|
if (iostat .ne. 0) goto 12
|
|
|
|
10 read(lun, '(a)',end=11,err=11) line
|
|
l=index(line,':')
|
|
if (l .gt. 1) then
|
|
if (index(line(1:l), host) .ne. 0) then
|
|
done=.true.
|
|
write(lun1, '(2a)') line(1:l),devdest
|
|
goto 10
|
|
endif
|
|
endif
|
|
call cho_vpp_cups(line)
|
|
call str_trim(line, line, ll)
|
|
write(lun1, '(a)') line(1:ll)
|
|
goto 10
|
|
11 close(lun)
|
|
12 if (.not. done) then
|
|
write(lun1, '(3a)') host,':',devdest
|
|
endif
|
|
27 close(lun1)
|
|
91 call sys_free_lun(lun)
|
|
call sys_free_lun(lun1)
|
|
call sys_rename_file(home(1:lh)//'terinq.pref1'
|
|
1,home(1:lh)//'terinq.pref')
|
|
end
|
|
|
|
|
|
subroutine cho_choose(ask) !!
|
|
|
|
character ask*1 ! ' ': info only
|
|
! '?': ask for all parameters
|
|
! 'G' ask for graphic device, if not defined
|
|
! 'P' ask for printer device, if not defined
|
|
|
|
character popt*1, pan*8, file*48, pcmd*48, gdev*8, pdev*8
|
|
character dest*32, host*64
|
|
save popt, pan, file, pcmd, gdev, pdev, dest, host
|
|
|
|
character ans*80, typ*8, desc*64, gdesc*64, pdesc*64
|
|
character pdev2*8, dev0*8, cfg*64
|
|
integer i, j, l, m, n, inter, crit, la, h, v, ipan, lc
|
|
integer lun/0/, lunr/0/
|
|
logical savepref, quit, init/.true./, initg/.true./
|
|
integer n_names, i_gdev, i_popt, i_pan, i_file
|
|
integer i_pcmd, i_pdev, i_dest
|
|
parameter (n_names=7, i_gdev=1, i_popt=2, i_pan=3, i_file=4
|
|
1 , i_pcmd=5, i_pdev=6, i_dest=7)
|
|
character names(n_names)*16
|
|
data names(i_gdev)/'CHOOSER_GDEV'/
|
|
data names(i_popt)/'CHOOSER_POPT'/
|
|
data names(i_pan )/'CHOOSER_PAN' /
|
|
data names(i_file)/'CHOOSER_FILE'/
|
|
data names(i_pcmd)/'CHOOSER_PCMD'/
|
|
data names(i_pdev)/'CHOOSER_PDEV'/
|
|
data names(i_dest)/'CHOOSER_DEST'/
|
|
|
|
character opt(4)*34/
|
|
1 'F write one file per page'
|
|
1,'A write all pages on one file'
|
|
1,'L send plots later to printer'
|
|
1,'I send immediately to printer'/
|
|
|
|
savepref=.false.
|
|
call pgqndt(n)
|
|
|
|
if (init) then
|
|
init=.false.
|
|
|
|
call sys_loadenv
|
|
|
|
call sys_getenv(names(i_gdev), gdev)
|
|
call sys_getenv(names(i_popt), popt)
|
|
call sys_getenv(names(i_pan ), pan)
|
|
call sys_getenv(names(i_file), file)
|
|
call sys_getenv(names(i_pcmd), pcmd)
|
|
call sys_getenv(names(i_pdev), pdev)
|
|
call sys_getenv(names(i_dest), dest)
|
|
|
|
if (pan .eq. ' ') then
|
|
pan='1'
|
|
call sys_setenv(names(i_pan ), pan)
|
|
endif
|
|
if (file .eq. ' ') then
|
|
file='posts.dat'
|
|
call sys_setenv(names(i_file), file)
|
|
endif
|
|
if (popt .eq. ' ') then
|
|
popt='L'
|
|
call sys_setenv(names(i_popt), popt)
|
|
endif
|
|
if (pdev .eq. ' ') then
|
|
pdev='PS'
|
|
call sys_setenv(names(i_pdev), pdev)
|
|
endif
|
|
endif
|
|
if (ask .eq. 'G') then
|
|
if (initg) then
|
|
initg=.false.
|
|
if (gdev .eq. ' ') then
|
|
call cho_inq(' ', gdev, dest, i, j)
|
|
call sys_setenv(names(i_gdev), gdev)
|
|
call sys_setenv(names(i_dest), dest)
|
|
endif
|
|
call sys_setenv('PGPLOT_DEV', '/'//gdev)
|
|
endif
|
|
endif
|
|
|
|
ans=' '
|
|
if (ask .eq. 'G') then
|
|
if (gdev .ne. ' ') goto 99
|
|
ans='G'
|
|
elseif (ask .eq. 'P') then
|
|
if (popt .eq. 'A' .or. popt .eq. 'F') then
|
|
if (file .ne. ' ') goto 99
|
|
ans='F'
|
|
else
|
|
i=index(pcmd, '*')
|
|
if (i .ne. 0) then
|
|
if (dest .ne. ' ') goto 99
|
|
call str_trim(pcmd, pcmd, l)
|
|
print *,'Print command: ',pcmd(1:l)
|
|
ans='D'
|
|
else
|
|
if (pcmd .ne. ' ') goto 99
|
|
ans='C'
|
|
endif
|
|
endif
|
|
endif
|
|
|
|
20 continue
|
|
|
|
gdesc='unknown'
|
|
pdesc='unknown'
|
|
read(pan, *, err=21,end=21) ipan
|
|
21 call cho_calc_pan(ipan, h, v)
|
|
if (v .gt. h) then
|
|
if (pdev(1:1) .ne. 'V' .and. pdev(2:2) .ne. 'V') then
|
|
pdev2=pdev(1:1)//'V'//pdev(2:)
|
|
pdev='V'//pdev
|
|
endif
|
|
else
|
|
if (pdev(1:1) .eq. 'V') then
|
|
pdev=pdev(2:)
|
|
elseif (pdev(2:2) .eq. 'V') then
|
|
pdev=pdev(1:1)//pdev(3:)
|
|
endif
|
|
pdev2=' '
|
|
endif
|
|
do i=1,n
|
|
call pgqdt(i, typ, l, desc, m, inter)
|
|
if (l .gt. 0) then
|
|
if (inter .eq. 1) then
|
|
if (gdev .eq. typ(2:) .or.
|
|
1 gdev .eq. 'VT240' .and. typ(2:) .eq. 'VT125') then
|
|
gdesc=typ(2:l)//' '//desc
|
|
endif
|
|
elseif (pdev .eq. typ(2:)) then
|
|
pdesc=typ(2:l)//' '//desc
|
|
elseif (pdev2 .eq. typ(2:)) then
|
|
pdev=pdev2
|
|
pdesc=typ(2:l)//' '//desc
|
|
endif
|
|
endif
|
|
enddo
|
|
call sys_setenv(names(i_pdev), pdev)
|
|
|
|
if (ask .eq. ' ') then ! info only
|
|
call str_trim(gdesc, gdesc, l)
|
|
print *,'Display device type: ',gdesc(1:l)
|
|
call str_trim(pdesc, pdesc, l)
|
|
print *,'Printer device type: ',pdesc(1:l)
|
|
if (popt .eq. 'F' .or. popt .eq. 'A') then
|
|
call str_trim(file, file, l)
|
|
if (popt .eq. 'F') then
|
|
print *,'one file per page, filename: ', file(1:l),'_n'
|
|
else
|
|
print *,'all pages on one page. filename: ', file(1:l)
|
|
endif
|
|
else
|
|
call str_trim(pcmd, pcmd, l)
|
|
call str_trim(dest, dest, i)
|
|
if (pcmd .eq. ' ') then
|
|
print *,'print command undefined'
|
|
elseif (dest .eq. ' ' .and. index(pcmd,'*') .ne. 0) then
|
|
print *,'print destination undefined'
|
|
elseif (dest .ne. ' ' .and. index(pcmd,'*') .eq. 0) then
|
|
print *,'print destination ignored'
|
|
1,' (print command does not contain *)'
|
|
elseif (popt .eq. 'L') then
|
|
print *,'print later on ',dest(1:i)
|
|
1 ,' with command: ', pcmd(1:l)
|
|
else
|
|
print *,'print immediately on ',dest(1:i)
|
|
1 ,' with command: ', pcmd(1:l)
|
|
endif
|
|
endif
|
|
if (pan .ne. '1') then
|
|
print *,pan,' graphs per page'
|
|
else
|
|
print *,'one graph per page'
|
|
endif
|
|
print *
|
|
goto 99
|
|
endif
|
|
|
|
if (ans .eq. ' ') then
|
|
print *, 'Option Description Actual State'
|
|
print '(X,79(''-''))'
|
|
call str_trim(gdesc, gdesc, l)
|
|
l=min(l,42)
|
|
print *, ' G change display device type '//gdesc(1:l)
|
|
call str_trim(pdesc, pdesc, l)
|
|
l=min(l,42)
|
|
print *, ' P change printer device type '//pdesc(1:l)
|
|
|
|
print *
|
|
if (popt .eq. 'F') then
|
|
print *,' ',opt(2),' every page will be written to'
|
|
print *,' ',opt(3),' a separate file'
|
|
print *,' ',opt(4)
|
|
elseif (popt .eq. 'A') then
|
|
print *,' ',opt(1),' all pages will be written to one'
|
|
print *,' ',opt(3),' large file'
|
|
print *,' ',opt(4)
|
|
elseif (popt .eq. 'L') then
|
|
print *,' ',opt(1),' all pages will be sent on exit to'
|
|
print *,' ',opt(2),' the selected printer'
|
|
print *,' ',opt(4),' (select F or A to write on a file)'
|
|
elseif (popt .eq. 'I') then
|
|
print *,' ',opt(1),' every page will be sent immediately'
|
|
print *,' ',opt(2),' to the selected printer'
|
|
print *,' ',opt(3),' (select F or A to write on a file)'
|
|
endif
|
|
! i=index('FALI',popt)
|
|
|
|
! do j=1,4
|
|
! if (j .ne. i) then
|
|
! print *,' ',opt(j)
|
|
! endif
|
|
! enddo
|
|
print *
|
|
|
|
if (popt .eq. 'F' .or. popt .eq. 'A') then
|
|
call str_trim(file, file, l)
|
|
print *, ' N change print file name ',file(1:l)
|
|
else
|
|
call str_trim(pcmd, pcmd, l)
|
|
print *, ' C change print command ',pcmd(1:l)
|
|
call str_trim(dest, dest, l)
|
|
print *, ' D change print destination ',dest(1:l)
|
|
endif
|
|
print '(x,2a)'
|
|
1 , ' 1...99 number of graphs per page ',pan
|
|
print *
|
|
print '(x,a,$)'
|
|
1 ,'Enter option or <RET> to continue: '
|
|
ans=' '
|
|
read(*,'(a)',end=40,err=40) ans
|
|
endif
|
|
|
|
40 if (ans .eq. ' ') then
|
|
if (popt .eq. 'L' .or. popt .eq. 'I') then
|
|
if (pcmd .ne. ' ') then
|
|
if (index(pcmd,'*') .eq. 0) then
|
|
if (dest .eq. ' ') goto 99
|
|
print *
|
|
print *,'Print destination ignored'
|
|
1,' (print command does not contain *)'
|
|
goto 99
|
|
else
|
|
if (dest .ne. ' ') goto 99
|
|
print *
|
|
print *,'Print destination undefined'
|
|
endif
|
|
else
|
|
print *
|
|
print *,'Print command undefined'
|
|
endif
|
|
call str_trim(file, file, l)
|
|
if (popt .eq. 'L') then
|
|
popt='A'
|
|
print *, 'Save all pages on: ',file(1:l)
|
|
else
|
|
popt='F'
|
|
print *, 'Save pages on: ',file(1:l),'_n'
|
|
endif
|
|
print *
|
|
call sys_setenv('CHOOSER_POPT', popt)
|
|
endif
|
|
goto 99
|
|
endif
|
|
call str_upcase(ans(1:1), ans(1:1))
|
|
if (ans(1:1) .eq. 'G') then
|
|
41 if (ans(2:) .eq. ' ') then
|
|
print *
|
|
do i=1,n
|
|
call pgqdt(i, typ, l, desc, m, inter)
|
|
if (l .gt. 0 .and. inter .eq. 1) then
|
|
m=max(1,m)
|
|
print *,typ(2:),' ',desc(1:m)
|
|
endif
|
|
enddo
|
|
endif
|
|
print *
|
|
call cho_get_arg('Display device type: ', ans)
|
|
call str_upcase(ans, ans)
|
|
call str_trim(ans, ans, la)
|
|
if (la .gt. 7) la=7
|
|
if (ans .ne. ' ' .and. gdev(1:la) .ne. ans(1:la)) then
|
|
dev0=' '
|
|
do i=1,n
|
|
call pgqdt(i, typ, l, desc, m, inter)
|
|
if (l .gt. 0 .and. inter .eq. 1) then
|
|
if (typ(2:) .eq. ans) then
|
|
dev0=ans
|
|
goto 411
|
|
endif
|
|
if (typ(2:la+1) .eq. ans(1:la)) then
|
|
if (dev0 .ne. ' ') then
|
|
print *,'Ambiguous device type: ',ans(1:la)
|
|
ans=' '
|
|
goto 41
|
|
endif
|
|
dev0=typ(2:)
|
|
endif
|
|
endif
|
|
enddo
|
|
if (dev0 .eq. ' ') then
|
|
print *,'Unknown display device: ',ans(1:la)
|
|
ans=' '
|
|
goto 41
|
|
endif
|
|
411 gdev=dev0
|
|
call sys_setenv(names(i_gdev), gdev)
|
|
call sys_setenv('PGPLOT_DEV', '/'//gdev)
|
|
savepref=.true.
|
|
endif
|
|
elseif (ans(1:1) .eq. 'P') then
|
|
42 if (ans(2:) .eq. ' ') then
|
|
print *
|
|
do i=1,n
|
|
call pgqdt(i, typ, l, desc, m, inter)
|
|
if (l .gt. 0 .and. inter .eq. 0) then
|
|
m=max(1,m)
|
|
print *,typ(2:),' ',desc(1:m)
|
|
endif
|
|
enddo
|
|
endif
|
|
print *
|
|
call cho_get_arg('Printer device type: ', ans)
|
|
call str_upcase(ans, ans)
|
|
call str_trim(ans, ans, la)
|
|
if (ans .ne. ' ' .and. pdev(1:la) .ne. ans(1:la)) then
|
|
dev0=' '
|
|
do i=1,n
|
|
call pgqdt(i, typ, l, desc, m, inter)
|
|
if (l .gt. 0 .and. inter .eq. 0) then
|
|
if (typ(2:) .eq. ans) then
|
|
dev0=ans
|
|
goto 421
|
|
endif
|
|
if (typ(2:la+1) .eq. ans(1:la)) then
|
|
if (dev0 .ne. ' ') then
|
|
print *,'Ambiguous device type: ',ans(1:la)
|
|
ans=' '
|
|
goto 42
|
|
endif
|
|
dev0=typ(2:)
|
|
endif
|
|
endif
|
|
enddo
|
|
if (dev0 .eq. ' ') then
|
|
print *,'Unknown printer device: ',ans(1:la)
|
|
ans=' '
|
|
goto 42
|
|
endif
|
|
421 pdev=dev0
|
|
if (index(pdev, 'PS') .eq. 0) then ! non postscript variants
|
|
popt='F'
|
|
call sys_setenv(names(i_popt), popt)
|
|
file='?'
|
|
call sys_setenv(names(i_file), file)
|
|
endif
|
|
call sys_setenv(names(i_pdev), pdev)
|
|
endif
|
|
elseif (ans(1:1) .eq. 'N') then
|
|
call cho_get_arg('File Name: ', ans)
|
|
if (ans .ne. ' ' .and. ans .ne. file) then
|
|
file=ans
|
|
call sys_setenv(names(i_file), file)
|
|
endif
|
|
elseif (ans(1:1) .eq. 'C') then
|
|
print *
|
|
print *
|
|
1 ,'Note: the print command should contain * (asterisk)'
|
|
1 ,'as a placeholder for the print destination'
|
|
print *
|
|
call cho_get_arg('Print Command: ', ans)
|
|
if (ans .ne. ' ' .and. ans .ne. pcmd) then
|
|
pcmd=ans
|
|
call sys_setenv(names(i_pcmd), pcmd)
|
|
endif
|
|
elseif (ans(1:1) .eq. 'D') then
|
|
call cho_get_arg('Print destination: ', ans)
|
|
if (ans .ne. ' ' .and. ans .ne. dest) then
|
|
call str_trim(ans, ans, i)
|
|
if (i .lt. 3) then
|
|
print *,ans(1:i),' is an illegal destination'
|
|
else
|
|
dest=ans
|
|
call sys_setenv(names(i_dest), dest)
|
|
savepref=.true.
|
|
endif
|
|
endif
|
|
else
|
|
i=index('FALI',ans(1:1))
|
|
if (i .ne. 0) then
|
|
if (popt .ne. ans(1:1)) then
|
|
popt=ans(1:1)
|
|
call sys_setenv(names(i_popt), popt)
|
|
endif
|
|
else
|
|
read(ans, '(bn,i8)', err=50,end=50) i
|
|
if (i .gt. 0 .and. i .le. 99) then
|
|
call cho_calc_pan(i, h, v)
|
|
i=h*v
|
|
if (i .ne. ipan) then
|
|
if (i .le. 9) then
|
|
write(pan, '(i1)') i
|
|
else
|
|
write(pan, '(i2)') i
|
|
endif
|
|
call sys_setenv(names(i_pan ), pan)
|
|
endif
|
|
else
|
|
print *,'unknown option'
|
|
endif
|
|
endif
|
|
endif
|
|
50 ans=' '
|
|
goto 20
|
|
|
|
99 call sys_saveenv
|
|
if (savepref) then
|
|
call sys_getenv('CHOOSER_TERINQ', ans)
|
|
if (ans(1:1) .ne. '1') goto 999 ! save only if terinq used
|
|
if (gdev .ne. 'XWINDOW' .and. gdev .ne. 'XSERVE') then
|
|
call str_trim(cfg,gdev,lc)
|
|
else
|
|
lc=0
|
|
endif
|
|
print *
|
|
if (lc .gt. 0) then
|
|
print *,'Graphic device: ',cfg(1:lc)
|
|
endif
|
|
call str_append(cfg,lc,';')
|
|
call str_trim(pdev, pdev, l)
|
|
if (index('VCPS VPS ',pdev(1:l+1)) .ne. 0) then
|
|
if (dest .ne. ' ') then
|
|
print *,'Printer destination: ',dest
|
|
call str_append(cfg,lc,dest)
|
|
call str_trim(cfg,cfg(1:lc),lc)
|
|
endif
|
|
endif
|
|
if (lc .gt. 1) then
|
|
call sys_remote_host(host, typ)
|
|
call str_trim(host,host,l)
|
|
print '(x,3a,$)','Save this for next session from '
|
|
1 ,host(1:l),'? [N/y]: '
|
|
read(*,'(a)',end=999,err=999) ans
|
|
call str_upcase(ans(1:1), ans(1:1))
|
|
if (ans(1:1) .eq. 'Y') then
|
|
call str_trim(host, host, l)
|
|
print *,'saved'
|
|
call cho_save(host(1:l),cfg(1:lc))
|
|
endif
|
|
endif
|
|
endif
|
|
999 end
|
|
|
|
|
|
subroutine cho_get_arg(prompt, ans)
|
|
|
|
character prompt*(*), ans*(*)
|
|
|
|
integer i
|
|
if (ans(2:) .ne. ' ') then
|
|
i=2
|
|
10 if (ans(i:i) .eq. ' ') then
|
|
i=i+1
|
|
goto 10
|
|
endif
|
|
ans=ans(i:)
|
|
else
|
|
print '(x,a,$)',prompt
|
|
ans=' '
|
|
read(*,'(a)',end=9,err=9) ans
|
|
endif
|
|
9 end
|
|
|
|
|
|
subroutine cho_calc_pan(p, h, v)
|
|
|
|
! calculate h, v from number of panels p, in order that h*v~=p or h*v*2~=p
|
|
|
|
integer p
|
|
integer h,v
|
|
|
|
if (p .le. 1) goto 9
|
|
|
|
v=nint(sqrt(p*1.0))
|
|
h=nint(sqrt(p*0.5))
|
|
if (abs(v*v-p) .lt. abs(h*h*2-p)) then
|
|
h=v
|
|
else
|
|
v=h*2
|
|
endif
|
|
return
|
|
|
|
9 h=1
|
|
v=1
|
|
end
|
|
|
|
|
|
|
|
subroutine cho_vpp_cups(str)
|
|
|
|
character str*(*)
|
|
character up*80
|
|
integer i
|
|
|
|
call str_upcase(up, str)
|
|
i=index(up,'PSW')
|
|
if (i .gt. 0) then
|
|
if (up(i:i+4) .eq. 'PSW18') str(i:)='WHGA_138_1'
|
|
if (up(i:i+4) .eq. 'PSW21') str(i:)='SINQ_LHO_1'
|
|
if (up(i:i+4) .eq. 'PSW22') str(i:)='WHGA_243_1'
|
|
if (up(i:i+4) .eq. 'PSW24') str(i:)='SINQ_LHW_1'
|
|
if (up(i:i+4) .eq. 'PSW25') str(i:)='SINQ_THO_1'
|
|
end if
|
|
end
|