Initial commit
This commit is contained in:
725
gen/cho_deb.f
Normal file
725
gen/cho_deb.f
Normal file
@ -0,0 +1,725 @@
|
||||
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
|
||||
Reference in New Issue
Block a user