!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