integral/ridge
1
0
Fork 0
generated from erosita/uds
Code Issues Pull Requests Packages Projects Releases Wiki Activity

update

Browse Source
This commit is contained in:
Roman Krivonos
2024-11-01 14:56:46 +03:00
parent 2dc9aa6a8d
commit 908e25b200
51 changed files with 338 additions and 432 deletions
Download Patch File Download Diff File Expand all files Collapse all files

279
models/grxe/inc/wimage_simple.f Normal file
View File

@@ -0,0 +1,279 @@
!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