mirror of
https://github.com/saitohirga/WSJT-X.git
synced 2025-10-29 20:10:28 -04:00
337 lines
8.1 KiB
Fortran
337 lines
8.1 KiB
Fortran
|
subroutine imopen(plotfile)
|
||
|
|
character*(*) plotfile
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
|
||
|
|
lu=80
|
||
|
|
open(lu,file=plotfile,status='unknown')
|
||
|
|
write(lu,1000)
|
||
|
|
1000 format('%!PS-Adobe-2.0'/ &
|
||
|
|
'/rightshow { dup stringwidth pop neg 0 rmoveto show } def'/ &
|
||
|
|
'/centershow { dup stringwidth pop neg 2 div ', &
|
||
|
|
'0 rmoveto show } def'/ &
|
||
|
|
'/lt { lineto } def'/'%%Page: 1 1')
|
||
|
|
npage=1
|
||
|
|
|
||
|
|
return
|
||
|
|
end subroutine imopen
|
||
|
|
|
||
|
|
subroutine impalette(palette)
|
||
|
|
character*(*) palette
|
||
|
|
integer r(0:8),g(0:8),b(0:8)
|
||
|
|
integer rr,gg,bb
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
common/imcom2/rr(0:255),gg(0:255),bb(0:255)
|
||
|
|
|
||
|
|
if(palette.eq.'afmhot') then
|
||
|
|
do i=0,255
|
||
|
|
j=255-i
|
||
|
|
rr(i)=min(255,2*j)
|
||
|
|
gg(i)=max(0,min(255,2*j-128))
|
||
|
|
bb(i)=max(0,min(255,2*j-256))
|
||
|
|
enddo
|
||
|
|
else if(palette.eq.'hot') then
|
||
|
|
do i=0,255
|
||
|
|
j=255-i
|
||
|
|
rr(i)=min(255,3*j)
|
||
|
|
gg(i)=max(0,min(255,3*j-256))
|
||
|
|
bb(i)=max(0,min(255,3*j-512))
|
||
|
|
enddo
|
||
|
|
else
|
||
|
|
open(11,file="Palettes/"//palette,status="old")
|
||
|
|
do j=0,8
|
||
|
|
read(11,*) r(j),g(j),b(j)
|
||
|
|
enddo
|
||
|
|
close(11)
|
||
|
|
do i=0,255
|
||
|
|
j0=i/32
|
||
|
|
j1=j0+1
|
||
|
|
k=i-32*j0
|
||
|
|
rr(i)=r(j0) + int((k*(r(j1)-r(j0)))/31 + 0.5)
|
||
|
|
gg(i)=g(j0) + int((k*(g(j1)-g(j0)))/31 + 0.5)
|
||
|
|
bb(i)=b(j0) + int((k*(b(j1)-b(j0)))/31 + 0.5)
|
||
|
|
enddo
|
||
|
|
|
||
|
|
endif
|
||
|
|
|
||
|
|
return
|
||
|
|
end subroutine impalette
|
||
|
|
|
||
|
|
subroutine imclose
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
write(lu,1000)
|
||
|
|
1000 format('showpage'/'%%Trailer')
|
||
|
|
close(lu)
|
||
|
|
return
|
||
|
|
end subroutine imclose
|
||
|
|
|
||
|
|
subroutine imnewpage
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
npage=npage+1
|
||
|
|
write(lu,1000) npage,npage
|
||
|
|
1000 format('showpage'/'%%Page:',2i4)
|
||
|
|
return
|
||
|
|
end subroutine imnewpage
|
||
|
|
|
||
|
|
subroutine imxline(x,y,dx)
|
||
|
|
! Draw a line from (x,y) to (x+dx,y) integer r,g,b
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
write(lu,1000) 72.0*x,72.0*y,72.0*dx
|
||
|
|
1000 format('newpath',2f7.1,' moveto',f7.1,' 0 rlineto stroke')
|
||
|
|
return
|
||
|
|
end subroutine imxline
|
||
|
|
|
||
|
|
subroutine imyline(x,y,dy)
|
||
|
|
! Draw a line from (x,y) to (x,y+dy)
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
write(lu,1000) 72.0*x,72.0*y,72.0*dy
|
||
|
|
1000 format('newpath',2f7.1,' moveto 0',f7.1,' rlineto stroke')
|
||
|
|
return
|
||
|
|
end subroutine imyline
|
||
|
|
|
||
|
|
subroutine imwidth(width)
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
write(lu,1000) width
|
||
|
|
1000 format(f7.1,' setlinewidth')
|
||
|
|
return
|
||
|
|
end subroutine imwidth
|
||
|
|
|
||
|
|
subroutine imfont(fontname,npoints)
|
||
|
|
character*(*) fontname
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
write(lu,1000) fontname,npoints
|
||
|
|
1000 format('/',a,' findfont',i4,' scalefont setfont')
|
||
|
|
return
|
||
|
|
end subroutine imfont
|
||
|
|
|
||
|
|
subroutine imstring(string,x,y,just,ndeg)
|
||
|
|
character*(*) string
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
write(lu,1000) 72.0*x,72.0*y,ndeg,string
|
||
|
|
1000 format(2f7.1,' moveto',i4,' rotate'/'(',a,')')
|
||
|
|
if(just.eq.1) write(lu,*) 'rightshow'
|
||
|
|
if(just.eq.2) write(lu,*) 'centershow'
|
||
|
|
if(just.eq.3) write(lu,*) 'show'
|
||
|
|
write(lu,1010) -ndeg
|
||
|
|
1010 format(i4,' rotate'/)
|
||
|
|
return
|
||
|
|
end subroutine imstring
|
||
|
|
|
||
|
|
subroutine imr4mat(z,IP,JP,imax,jmax,zz1,zz2,x,y,dx,dy,nbox)
|
||
|
|
real z(IP,JP)
|
||
|
|
integer idat(2048)
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
|
||
|
|
z1=zz1
|
||
|
|
z2=zz2
|
||
|
|
if(z1.eq.0.0 .and. z2.eq.0.0) then
|
||
|
|
z1=z(1,1)
|
||
|
|
z2=z1
|
||
|
|
do i=1,imax
|
||
|
|
do j=1,jmax
|
||
|
|
z1=min(z(i,j),z1)
|
||
|
|
z2=max(z(i,j),z2)
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
scale=255.99/(z2-z1)
|
||
|
|
|
||
|
|
write(lu,1002) 72.0*x,72.0*y,72.0*dx,72.0*dy
|
||
|
|
1002 format(2f7.1,' translate',2f7.1,' scale')
|
||
|
|
write(lu,*) imax,jmax,8,' [',imax,0,0,jmax,0,0,']'
|
||
|
|
write(lu,*) '{<'
|
||
|
|
|
||
|
|
do j=1,jmax
|
||
|
|
do i=1,imax
|
||
|
|
idat(i)=scale*(z(i,j)-z1)
|
||
|
|
idat(i)=max(idat(i),0)
|
||
|
|
idat(i)=min(idat(i),255)
|
||
|
|
idat(i)=255-idat(i)
|
||
|
|
enddo
|
||
|
|
write(lu,1004) (idat(i),i=1,imax)
|
||
|
|
1004 format(30z2.2)
|
||
|
|
enddo
|
||
|
|
write(lu,*) '>} image'
|
||
|
|
write(lu,1006) 1.0/(72.0*dx),1.0/(72.0*dy),-72.0*x,-72.0*y
|
||
|
|
1006 format(2f9.6,' scale',2f7.1,' translate')
|
||
|
|
|
||
|
|
if(nbox.ne.0) then
|
||
|
|
write(lu,1010) 72.0*x,72.0*y,72.0*dx,72.0*dy,-72*dx
|
||
|
|
1010 format('newpath',2f7.1,' moveto',f7.1,' 0 rlineto 0', &
|
||
|
|
f7.1,' rlineto',f7.1,' 0 rlineto closepath stroke')
|
||
|
|
endif
|
||
|
|
|
||
|
|
return
|
||
|
|
end subroutine imr4mat
|
||
|
|
|
||
|
|
subroutine imr4mat_color(z,IP,JP,imax,jmax,zz1,zz2,x,y,dx,dy,nbox)
|
||
|
|
real z(IP,JP)
|
||
|
|
integer idat(2048,3)
|
||
|
|
integer rr,gg,bb
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
common/imcom2/rr(0:255),gg(0:255),bb(0:255)
|
||
|
|
|
||
|
|
z1=zz1
|
||
|
|
z2=zz2
|
||
|
|
if(z1.eq.0.0 .and. z2.eq.0.0) then
|
||
|
|
z1=z(1,1)
|
||
|
|
z2=z1
|
||
|
|
do i=1,imax
|
||
|
|
do j=1,jmax
|
||
|
|
z1=min(z(i,j),z1)
|
||
|
|
z2=max(z(i,j),z2)
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
scale=255.99/(z2-z1)
|
||
|
|
|
||
|
|
write(lu,1002) 72.0*x,72.0*y,72.0*dx,72.0*dy
|
||
|
|
1002 format(2f7.1,' translate',2f7.1,' scale')
|
||
|
|
write(lu,1003) imax,jmax,8,imax,0,0,jmax,0,0
|
||
|
|
1003 format(3i5,' [',6i4,']')
|
||
|
|
write(lu,1004) imax
|
||
|
|
1004 format('{currentfile 3',i4,' mul string readhexstring pop} bind'/ &
|
||
|
|
'false 3 colorimage')
|
||
|
|
|
||
|
|
do j=1,jmax
|
||
|
|
do i=1,imax
|
||
|
|
n=scale*(z(i,j)-z1)
|
||
|
|
n=max(n,0)
|
||
|
|
n=min(n,255)
|
||
|
|
idat(i,1)=rr(n)
|
||
|
|
idat(i,2)=gg(n)
|
||
|
|
idat(i,3)=bb(n)
|
||
|
|
enddo
|
||
|
|
write(lu,1005) (idat(i,1),idat(i,2),idat(i,3),i=1,imax)
|
||
|
|
1005 format(30z2.2)
|
||
|
|
enddo
|
||
|
|
|
||
|
|
write(lu,1006) 1.0/(72.0*dx),1.0/(72.0*dy),-72.0*x,-72.0*y
|
||
|
|
1006 format(2f9.6,' scale',2f7.1,' translate')
|
||
|
|
|
||
|
|
if(nbox.ne.0) then
|
||
|
|
write(lu,1010) 72.0*x,72.0*y,72.0*dx,72.0*dy,-72*dx
|
||
|
|
1010 format('newpath',2f7.1,' moveto',f7.1,' 0 rlineto 0', &
|
||
|
|
f7.1,' rlineto',f7.1,' 0 rlineto closepath stroke')
|
||
|
|
endif
|
||
|
|
|
||
|
|
return
|
||
|
|
end subroutine imr4mat_color
|
||
|
|
|
||
|
|
subroutine imr4pro(p,imax,yy1,yy2,x,y,dx,dy,nbox)
|
||
|
|
real p(imax)
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
|
||
|
|
y1=yy1
|
||
|
|
y2=yy2
|
||
|
|
if(y1.eq.0.0 .and. y2.eq.0.0) then
|
||
|
|
y1=p(1)
|
||
|
|
y2=y1
|
||
|
|
do i=1,imax
|
||
|
|
y1=min(p(i),y1)
|
||
|
|
y2=max(p(i),y2)
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
|
||
|
|
xscale=72.0*dx/imax
|
||
|
|
xoff=72.0*x
|
||
|
|
yscale=72.0*dy
|
||
|
|
if(y1.ne.y2) yscale=yscale/(y2-y1)
|
||
|
|
yoff=72.0*y
|
||
|
|
|
||
|
|
write(lu,*) '1.416 setmiterlimit'
|
||
|
|
write(lu,1002) xoff+0.5*xscale,yoff+yscale*(p(1)-y1)
|
||
|
|
1002 format('newpath',2f7.1,' moveto')
|
||
|
|
|
||
|
|
do i=2,imax
|
||
|
|
write(lu,1004) xoff+(i-0.5)*xscale,yoff+yscale*(p(i)-y1)
|
||
|
|
1004 format(2f6.1,' lt')
|
||
|
|
enddo
|
||
|
|
write(lu,*) 'stroke'
|
||
|
|
|
||
|
|
if(nbox.ne.0) then
|
||
|
|
write(lu,1010) xoff,yoff,72.0*dx,72.0*dy,-72*dx
|
||
|
|
1010 format('newpath',2f7.1,' moveto',f7.1,' 0 rlineto 0', &
|
||
|
|
f7.1,' rlineto',f7.1,' 0 rlineto closepath stroke')
|
||
|
|
endif
|
||
|
|
|
||
|
|
return
|
||
|
|
end subroutine imr4pro
|
||
|
|
|
||
|
|
subroutine imline(x1,y1,x2,y2)
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
write(lu,1000) 72*x1,72*y1,72*x2,72*y2
|
||
|
|
1000 format('newpath',2f7.1,' moveto',2f7.1,' lineto stroke')
|
||
|
|
return
|
||
|
|
end subroutine imline
|
||
|
|
|
||
|
|
subroutine imcircle(x,y,radius,shade)
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
write(lu,1000) shade
|
||
|
|
1000 format(f7.1,' setgray')
|
||
|
|
write(lu,1002) 72*x,72*y,72*radius
|
||
|
|
1002 format('newpath',3f7.1,' 0 360 arc fill')
|
||
|
|
write(lu,1000) 0.0
|
||
|
|
write(lu,1004) 72*x,72*y,72*radius
|
||
|
|
1004 format('newpath',3f7.1,' 0 360 arc stroke')
|
||
|
|
return
|
||
|
|
end subroutine imcircle
|
||
|
|
|
||
|
|
subroutine imtriangle(x,y,rr,shade)
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
write(lu,1000) shade
|
||
|
|
1000 format(f7.1,' setgray')
|
||
|
|
write(lu,1002) 72*x,72*(y+rr)
|
||
|
|
1002 format('newpath',2f7.1,' moveto ')
|
||
|
|
write(lu,1004) 72*(x-rr),72*(y-rr)
|
||
|
|
1004 format(2f7.1,' lineto ')
|
||
|
|
write(lu,1004) 72*(x+rr),72*(y-rr)
|
||
|
|
write(lu,*) 'closepath fill 0 setgray'
|
||
|
|
write(lu,1002) 72*x,72*(y+rr)
|
||
|
|
write(lu,1004) 72*(x-rr),72*(y-rr)
|
||
|
|
write(lu,1004) 72*(x+rr),72*(y-rr)
|
||
|
|
write(lu,*) 'closepath stroke'
|
||
|
|
|
||
|
|
return
|
||
|
|
end subroutine imtriangle
|
||
|
|
|
||
|
|
subroutine imr4prov(p,jmax,xx1,xx2,x,y,dx,dy,nbox)
|
||
|
|
real p(jmax)
|
||
|
|
common/imcom/ lu,npage
|
||
|
|
|
||
|
|
x1=xx1
|
||
|
|
x2=xx2
|
||
|
|
if(x1.eq.0.0 .and. x2.eq.0.0) then
|
||
|
|
x1=p(1)
|
||
|
|
x2=x1
|
||
|
|
do j=1,jmax
|
||
|
|
x1=min(p(j),x1)
|
||
|
|
x2=max(p(j),x2)
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
|
||
|
|
xscale=72.0*dx
|
||
|
|
xoff=72.0*x
|
||
|
|
if(x1.ne.x2) xscale=xscale/(x2-x1)
|
||
|
|
|
||
|
|
yscale=72.0*dy/jmax
|
||
|
|
yoff=72.0*y
|
||
|
|
|
||
|
|
write(lu,*) '1.416 setmiterlimit'
|
||
|
|
write(lu,1002) xoff+xscale*(x2-p(1)),yoff+0.5*yscale
|
||
|
|
1002 format('newpath',2f7.1,' moveto')
|
||
|
|
|
||
|
|
do j=2,jmax
|
||
|
|
write(lu,1004) xoff+xscale*(x2-p(j)),yoff+(j-0.5)*yscale
|
||
|
|
1004 format(2f6.1,' lt')
|
||
|
|
enddo
|
||
|
|
write(lu,*) 'stroke'
|
||
|
|
|
||
|
|
if(nbox.ne.0) then
|
||
|
|
write(lu,1010) xoff,yoff,72.0*dx,72.0*dy,-72*dx
|
||
|
|
1010 format('newpath',2f7.1,' moveto',f7.1,' 0 rlineto 0', &
|
||
|
|
f7.1,' rlineto',f7.1,' 0 rlineto closepath stroke')
|
||
|
|
endif
|
||
|
|
|
||
|
|
return
|
||
|
|
end subroutine imr4prov
|