generated from erosita/uds
280 lines
8.5 KiB
Fortran
280 lines
8.5 KiB
Fortran
!c===============================================================
|
|
subroutine wimage_simple_i4(filename,image,nxm,nx,ny)
|
|
!c--------------------------------------------------------------
|
|
!c write image to FITS file
|
|
!c
|
|
!c Created: Mon May 16 14:21:02 EDT 1994
|
|
!c--------------------------------------------------------------
|
|
implicit none
|
|
character*(*) filename
|
|
integer nxm,nx,ny
|
|
integer image(nxm,*)
|
|
|
|
integer lnblnk
|
|
integer status,bitpix,naxis,pcount,gcount
|
|
integer naxes(2)
|
|
integer unit
|
|
|
|
status=0
|
|
print 10,filename(:lnblnk(filename))
|
|
10 format(/'Write FITS image to file ',a)
|
|
|
|
call deletefile(filename,status)
|
|
call ftgiou(unit,status)
|
|
|
|
bitpix=32
|
|
naxis=2
|
|
pcount=0
|
|
gcount=1
|
|
naxes(1)=nx
|
|
naxes(2)=ny
|
|
|
|
call ftinit(unit,filename,0,status)
|
|
call ftphpr(unit,.true.,bitpix,naxis,naxes,pcount,gcount,.false.,status)
|
|
call ftpdef(unit,bitpix,naxis,naxes,pcount,gcount,status)
|
|
call ftp2dj(unit,0,nxm,naxes(1),naxes(2),image,status)
|
|
call ftclos(unit,status)
|
|
call ftfiou(unit,status)
|
|
if(status.gt.0) call printerror(status)
|
|
|
|
|
|
return
|
|
end
|
|
!c===============================================================
|
|
subroutine wimage_simple_r4(filename,image,nxm,nx,ny)
|
|
!c--------------------------------------------------------------
|
|
!c write image to FITS file
|
|
!c
|
|
!c Created: Mon May 16 14:21:02 EDT 1994
|
|
!c--------------------------------------------------------------
|
|
implicit none
|
|
character*(*) filename
|
|
integer nxm,nx,ny
|
|
real image(nxm,*)
|
|
|
|
integer lnblnk
|
|
integer status,bitpix,naxis,pcount,gcount
|
|
integer naxes(2)
|
|
integer unit
|
|
|
|
status=0
|
|
print 10,filename(:lnblnk(filename))
|
|
10 format(/'Write FITS image to file ',a)
|
|
|
|
call deletefile(filename,status)
|
|
call ftgiou(unit,status)
|
|
|
|
bitpix=-32
|
|
naxis=2
|
|
pcount=0
|
|
gcount=1
|
|
naxes(1)=nx
|
|
naxes(2)=ny
|
|
|
|
call ftinit(unit,filename,0,status)
|
|
call ftphpr(unit,.true.,bitpix,naxis,naxes,pcount,gcount,.false.,status)
|
|
call ftpdef(unit,bitpix,naxis,naxes,pcount,gcount,status)
|
|
call ftp2de(unit,0,nxm,naxes(1),naxes(2),image,status)
|
|
call ftclos(unit,status)
|
|
call ftfiou(unit,status)
|
|
if(status.gt.0) call printerror(status)
|
|
|
|
|
|
return
|
|
end
|
|
!c===============================================================
|
|
subroutine wimage_simple_r8(filename,image,nxm,nx,ny)
|
|
!c--------------------------------------------------------------
|
|
!c write image to FITS file
|
|
!c
|
|
!c Created: Mon May 16 14:21:02 EDT 1994
|
|
!c--------------------------------------------------------------
|
|
implicit none
|
|
character*(*) filename
|
|
integer nxm,nx,ny
|
|
real*8 image(nxm,*)
|
|
|
|
integer lnblnk
|
|
integer status,bitpix,naxis,pcount,gcount
|
|
integer naxes(2)
|
|
integer unit
|
|
|
|
status=0
|
|
print 10,filename(:lnblnk(filename))
|
|
10 format(/'Write FITS image to file ',a)
|
|
|
|
call deletefile(filename,status)
|
|
call ftgiou(unit,status)
|
|
|
|
bitpix=-64
|
|
naxis=2
|
|
pcount=0
|
|
gcount=1
|
|
naxes(1)=nx
|
|
naxes(2)=ny
|
|
|
|
call ftinit(unit,filename,0,status)
|
|
call ftphpr(unit,.true.,bitpix,naxis,naxes,pcount,gcount,.false.,status)
|
|
call ftpdef(unit,bitpix,naxis,naxes,pcount,gcount,status)
|
|
call ftp2dd(unit,0,nxm,naxes(1),naxes(2),image,status)
|
|
call ftclos(unit,status)
|
|
call ftfiou(unit,status)
|
|
if(status.gt.0) call printerror(status)
|
|
|
|
|
|
return
|
|
end
|
|
!c=============================================================================
|
|
subroutine read_image_r4(fn,image,nxm,mapx,mapy)
|
|
!c-----------------------------------------------------------------------------
|
|
!c read image (real*4)
|
|
!c-----------------------------------------------------------------------------
|
|
implicit none
|
|
character*(*) fn
|
|
integer nxm,mapx,mapy
|
|
real image(nxm,*)
|
|
|
|
character*80 comment
|
|
integer unit,status,block,hdutype,extver,naxis,naxes(4),bitpix
|
|
integer pcount,gcount
|
|
logical anyf,exact,simple,extend
|
|
|
|
status=0
|
|
call ftgiou(unit,status)
|
|
call ftopen(unit,fn,0,block,status)
|
|
|
|
call ftghpr(unit,2,simple,bitpix,naxis,naxes,pcount,gcount,extend,status)
|
|
!print*,' image nx,ny:',naxes(1),naxes(2)
|
|
call ftg2de(unit,0,0.,nxm,naxes(1),naxes(2),image,anyf,status)
|
|
call ftclos(unit,status)
|
|
call ftfiou(unit,status)
|
|
if(status.gt.0) then
|
|
call printerror(status)
|
|
endif
|
|
|
|
mapx=naxes(1)
|
|
mapy=naxes(2)
|
|
|
|
return
|
|
end
|
|
|
|
|
|
subroutine write_image(outfile,flux,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,size_sky,nxm)
|
|
implicit none
|
|
integer nxm
|
|
integer size_sky,i,j
|
|
real*8 xrval,yrval,xrpix,yrpix,xinc,yinc,rot
|
|
real flux(nxm,*)
|
|
|
|
|
|
integer ounit,status,lnblnk
|
|
integer bitpix,naxis,naxes(2),pcount,gcount
|
|
character*200 outfile,errmsg
|
|
|
|
bitpix=-32
|
|
naxis=2
|
|
pcount=0
|
|
gcount=1
|
|
naxes(1)=size_sky
|
|
naxes(2)=size_sky
|
|
|
|
|
|
|
|
status=0
|
|
call ftgiou(ounit,status)
|
|
call ftinit(ounit,outfile,0,status)
|
|
|
|
if(status.eq.103) then
|
|
print*,' Can not create file. File already exist'
|
|
print *,''
|
|
stop
|
|
endif
|
|
call ftphpr(ounit,.true.,bitpix,naxis,naxes,pcount,gcount,.true.,status)
|
|
call ftpdef(ounit,bitpix,naxis,naxes,pcount,gcount,status)
|
|
|
|
call ftpkys(ounit,'CTYPE1','GLON-AIT','X-axis type',status)
|
|
call ftpkys(ounit,'CTYPE2','GLAT-AIT','Y-axis type',status)
|
|
call ftpkyd(ounit,'CRVAL1',xrval,10,'Reference pixel value',status)
|
|
call ftpkyd(ounit,'CRVAL2',yrval,10,'Reference pixel value',status)
|
|
call ftpkyd(ounit,'CRPIX1',xrpix,10,'Reference pixel',status)
|
|
call ftpkyd(ounit,'CRPIX2',yrpix,10,'Reference pixel',status)
|
|
call ftpkyd(ounit,'CDELT1',xinc,10,'Degrees/pixel',status)
|
|
call ftpkyd(ounit,'CDELT2',yinc,10,'Degrees/pixel',status)
|
|
call ftpkyd(ounit,'CROTA1',rot,10,'',status)
|
|
call ftpdat(ounit,status)
|
|
call ftphis(ounit,'Created by R.Krivonos, krivonos@iki.rssi.ru',status)
|
|
|
|
call ftp2de(ounit,0,nxm,size_sky,size_sky,flux,status)
|
|
if (status.ne.0) then
|
|
call ftgerr(status,errmsg)
|
|
print *,errmsg
|
|
endif
|
|
call ftpcks(ounit,status)
|
|
call ftclos(ounit,status)
|
|
call ftfiou(ounit,status)
|
|
if(status.eq.0) then
|
|
print *,'File is written: ',outfile(1:lnblnk(outfile))
|
|
endif
|
|
|
|
end
|
|
|
|
subroutine write_image_xy(outfile,flux,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,size_sky_x,size_sky_y,nxm)
|
|
implicit none
|
|
integer nxm
|
|
integer size_sky_x,size_sky_y,i,j
|
|
real*8 xrval,yrval,xrpix,yrpix,xinc,yinc,rot
|
|
real flux(nxm,*)
|
|
|
|
|
|
integer ounit,status,lnblnk
|
|
integer bitpix,naxis,naxes(2),pcount,gcount
|
|
character*200 outfile,errmsg
|
|
|
|
bitpix=-32
|
|
naxis=2
|
|
pcount=0
|
|
gcount=1
|
|
naxes(1)=size_sky_x
|
|
naxes(2)=size_sky_y
|
|
|
|
|
|
|
|
status=0
|
|
call ftgiou(ounit,status)
|
|
call ftinit(ounit,outfile,0,status)
|
|
|
|
if(status.eq.103) then
|
|
print*,' Can not create file. File already exist'
|
|
print *,''
|
|
stop
|
|
endif
|
|
call ftphpr(ounit,.true.,bitpix,naxis,naxes,pcount,gcount,.true.,status)
|
|
call ftpdef(ounit,bitpix,naxis,naxes,pcount,gcount,status)
|
|
|
|
call ftpkys(ounit,'CTYPE1','GLON-AIT','X-axis type',status)
|
|
call ftpkys(ounit,'CTYPE2','GLAT-AIT','Y-axis type',status)
|
|
call ftpkyd(ounit,'CRVAL1',xrval,10,'Reference pixel value',status)
|
|
call ftpkyd(ounit,'CRVAL2',yrval,10,'Reference pixel value',status)
|
|
call ftpkyd(ounit,'CRPIX1',xrpix,10,'Reference pixel',status)
|
|
call ftpkyd(ounit,'CRPIX2',yrpix,10,'Reference pixel',status)
|
|
call ftpkyd(ounit,'CDELT1',xinc,10,'Degrees/pixel',status)
|
|
call ftpkyd(ounit,'CDELT2',yinc,10,'Degrees/pixel',status)
|
|
call ftpkyd(ounit,'CROTA1',rot,10,'',status)
|
|
call ftpdat(ounit,status)
|
|
call ftphis(ounit,'Created by R.Krivonos',status)
|
|
|
|
call ftp2de(ounit,0,nxm,size_sky_x,size_sky_y,flux,status)
|
|
if (status.ne.0) then
|
|
call ftgerr(status,errmsg)
|
|
print *,errmsg
|
|
endif
|
|
call ftpcks(ounit,status)
|
|
call ftclos(ounit,status)
|
|
call ftfiou(ounit,status)
|
|
if(status.eq.0) then
|
|
print *,'File is written: ',outfile(1:lnblnk(outfile))
|
|
endif
|
|
|
|
end
|
|
|