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

60
models/grxe/inc/constants.inc Normal file
View File

@@ -0,0 +1,60 @@
c physical constants
c MG; Mon Nov 11 16:28:45 MSK 1996
c------ pi
real*8 pi,pi2,rg,gr
parameter (pi=3.14159265358979312d00,pi2=pi+pi,rg=180d0/pi,gr=1d0/rg)
c------ physical constants
real*8 sigthomson
parameter(sigthomson=6.65246d-25)
real*8 clight
parameter(clight=2.99792458d10)
real*8 mproton,melectron
parameter(mproton=1.6726231d-24,melectron=9.1093897d-28)
real*8 echarge
parameter(echarge=4.8032068d-10)
real*8 sigsb
parameter(sigsb=5.67051d-5)
real*8 kboltzmann
parameter(kboltzmann=1.380658d-16)
real*8 ggrav
parameter(ggrav=6.67259d-8)
real*8 hplanck
parameter(hplanck=6.6260755d-27)
real*8 msun
parameter (msun=1.9891d33)
real*8 rsun
parameter (rsun=6.9599d10)
real*8 lsun
parameter (lsun=3.845d33)
c------ units conversions
c...... energy
real*8 kev2erg
parameter(kev2erg=1.602177d-9)
real*8 kev2hz
parameter(kev2hz=2.417965d17)
real*8 kev2kelvin
parameter(kev2kelvin=1.16048d7)
real*8 jy2erg
parameter(jy2erg=1d-23)
c...... flux
c flux[erg/s/cm^2/Hz] = ergcms_anstr2ergcms_hz_0 * lambda[Anstr]^2 * flux[erg/s/cm^2/A]
real*8 ergcms_anstr2ergcms_hz_0
parameter(ergcms_anstr2ergcms_hz_0=3.33d-19)
c...... lenth
real*8 pc2cm,kpc2cm,mpc2cm
parameter(pc2cm=3.085678d18,kpc2cm=1e3*pc2cm,mpc2cm=1e6*pc2cm)
c...... time
real*8 yr2sec
parameter(yr2sec=3.15576d7)

21
models/grxe/inc/crab.f Normal file
View File

@@ -0,0 +1,21 @@
!c==========================================================================
subroutine printerror(status)
!c--------------------------------------------------------------------------
!c print error message (for fitsio routines)
!c--------------------------------------------------------------------------
implicit none
integer status
character errtext*30,errmessage*80
if(status.le.0) return
call ftgerr(status,errtext)
print *,'FITSIO Error Status =',status,': ',errtext
call ftgmsg(errmessage)
do while (errmessage .ne. ' ')
print *,errmessage
call ftgmsg(errmessage)
end do
!c if(status.ne.0) stop
return
end

21
models/grxe/inc/crabmodel.f Normal file
View File

@@ -0,0 +1,21 @@
!c==========================================================================
subroutine crabmodel(status)
!c--------------------------------------------------------------------------
!c print error message (for fitsio routines)
!c--------------------------------------------------------------------------
implicit none
integer status
character errtext*30,errmessage*80
if(status.le.0) return
call ftgerr(status,errtext)
print *,'FITSIO Error Status =',status,': ',errtext
call ftgmsg(errmessage)
do while (errmessage .ne. ' ')
print *,errmessage
call ftgmsg(errmessage)
end do
!c if(status.ne.0) stop
return
end

20
models/grxe/inc/deletefile.f Normal file
View File

@@ -0,0 +1,20 @@
!c=========================================================================
subroutine deletefile(filename,status)
!c-------------------------------------------------------------------------
!c delete fits file
!c-------------------------------------------------------------------------
implicit none
integer status
character*(*) filename
integer access,i,unlink
if(access(filename,'w').eq.0) then
i=unlink(filename)
endif
return
end

137
models/grxe/inc/ibis_eresp.f Normal file
View File

@@ -0,0 +1,137 @@
!c===============================================================
subroutine ibis_eresp(filename,crval1,crval2,crpix1,crpix2,cdelt1,cdelt2,crota2,erange,image,skyexp0,nxm,nx,ny,fast,status)
!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,erange,n,m
logical anyf
integer lnblnk,fast
integer bitpix,pcount
real*8 norma0,norma1,slope0,slope1,dist,e1,e2,texp
real*8 crval1,crval2,crpix1,crpix2,cdelt1,cdelt2,crota2
integer naxes(3),naxis,gcount,extend
integer unit,status,block,extver,hdutype,simple
character*400 comment
integer nmapm,nmapx,nmapy
parameter(nmapm=2000)
real skyexp(nmapm,nmapm)
real skyexp0(nmapm,nmapm)
real image(nmapm,nmapm)
status=0
norma1=0.0
slope1=1.0
if(erange .eq. -1) then
norma0=0.0
slope0=1.0
else if(erange .eq. 1) then
norma0=0.48859433
slope0=1.3304603
norma1=0.083260782
slope1=0.68063210
else if(erange .eq. 2) then
norma0=0.21444822
slope0=1.7809195
norma1=0.045216999
slope1=1.3624652
else if(erange .eq. 3) then
norma0=0.097560597
slope0=1.0071800
else if(erange .eq. 9) then
norma0=0.32660987
slope0=1.7066450
norma1=0.24734285
slope1=0.17543571
else if(erange .eq. 10) then
norma0=0.10310040
slope0=1.3237412
else if(erange .eq. 8) then
norma0=-0.079264878
slope0=0.91217010
else if(erange .eq. 13) then
norma0=-0.035629722
slope0=1.3605498
else if(erange .ge. 4 .and. erange .le. 7) then
norma0=0.0
slope0=1.0
else if(erange .eq. 11 .or. erange .eq. 12 .or. erange .eq. 14 .or. erange .eq. 15) then
norma0=0.0
slope0=1.0
else
print*,'No such energy interval ',erange
stop
endif
call ftgiou(unit,status)
call ftopen(unit,filename,0,block,status)
if(status.ne.0) then
print*,'Bad file, skip it'
call ftclos(unit,status)
call ftfiou(unit,status)
return
endif
extver=0
hdutype=-1
call ftghpr(unit,2,simple,bitpix,naxis,naxes,pcount,gcount,extend,status)
!call ftg2de(unit,0,0.,nmapm,naxes(1),naxes(2),skydld,anyf,status)
call FTGKYd(unit,'EXPOSURE ',texp,comment,status)
call ftgkyd(unit,'E1 ',e1,comment,status)
call ftgkyd(unit,'E2 ',e2,comment,status)
call ftgkyd(unit,'CRPIX1 ',crpix1,comment,status)
call ftgkyd(unit,'CRPIX2 ',crpix2,comment,status)
call ftgkyd(unit,'CRVAL1 ',crval1,comment,status)
call ftgkyd(unit,'CRVAL2 ',crval2,comment,status)
call ftgkyd(unit,'CDELT1 ',cdelt1,comment,status)
call ftgkyd(unit,'CDELT2 ',cdelt2,comment,status)
call ftgkyd(unit,'CROTA2 ',crota2,comment,status)
!call ftmnhd(unit,hdutype,'skyerr',extver,status)
!call ftg2de(unit,0,0.,nmapm,naxes(1),naxes(2),skyerr,anyf,status)
if(fast .eq. 0) then
call ftmnhd(unit,hdutype,'skyexp',extver,status)
call ftg2de(unit,0,0.,nmapm,naxes(1),naxes(2),skyexp,anyf,status)
skyexp0=skyexp
else
skyexp=skyexp0
endif
nmapx=naxes(1)
nmapy=naxes(2)
call ftclos(unit,status)
call ftfiou(unit,status)
if(status.gt.0) then
return
endif
!
! Np = (skyexp(n,m)/texp/(e2-e1)) number of open pixels visible from given direction
!
do n=1,nmapy
do m=1,nmapx
skyexp(n,m)=skyexp(n,m)/texp/(e2-e1) ! (Np)
enddo
enddo
do n=1,nmapx
do m=1,nmapy
! pixel offset
dist=dsqrt((DBLE(n)-DBLE(ny)/2.0)**2+(DBLE(m)-DBLE(nx)/2.0)**2)
dist=dist*cdelt1
image(n,m)=skyexp(n,m)*(1.0+norma0*EXP(-dist/slope0))*(1.0+norma1*EXP(-dist/slope1)) ! Crab fit
enddo
enddo
nx=nmapx
ny=nmapy
return
end

21
models/grxe/inc/printerror.f Normal file
View File

@@ -0,0 +1,21 @@
!c==========================================================================
subroutine printerror(status)
!c--------------------------------------------------------------------------
!c print error message (for fitsio routines)
!c--------------------------------------------------------------------------
implicit none
integer status
character errtext*30,errmessage*80
if(status.le.0) return
call ftgerr(status,errtext)
print *,'FITSIO Error Status =',status,': ',errtext
call ftgmsg(errmessage)
do while (errmessage .ne. ' ')
print *,errmessage
call ftgmsg(errmessage)
end do
!c if(status.ne.0) stop
return
end

110
models/grxe/inc/read_co.f Normal file
View File

@@ -0,0 +1,110 @@
!c===============================================================
subroutine read_co(dglon,dglat,dflux,tnrows)
!c--------------------------------------------------------------
!c write image to FITS file
!c
!c Created: Mon May 16 14:21:02 EDT 1994
!c--------------------------------------------------------------
implicit none
character filename*40
integer nxm,nx,ny,erange,n,m
logical anyf
logical exact,anynull
integer lnblnk
integer bitpix,pcount
real*8 norma0,norma1,slope0,slope1,dist,e1,e2,texp
real*8 crval1,crval2,crpix1,crpix2,cdelt1,cdelt2,crota2
integer naxes(3),naxis,gcount,extend
integer unit,status,block,extver,hdutype,simple
character*400 comment
integer nmapm,nmapx,nmapy
parameter(nmapm=2000)
integer nhdu,tnrows,tncols
integer ixc,iyc,ival
real skyexp(nmapm,nmapm)
real skydld(nmapm,nmapm)
real skyerr(nmapm,nmapm)
real image(nmapm,nmapm)
! cobe
integer TROWMAX,ipixno,irezid,istddev,iglat,iglon,iraw,isum,isel
parameter (TROWMAX=500000)
integer dpixno(TROWMAX),idx,sel(TROWMAX)
real dflux(TROWMAX),dglat(TROWMAX),dglon(TROWMAX)
real*8 dl,db
real dflux_49(TROWMAX)
integer*4 mask(TROWMAX)
call ftgiou(unit,status)
call ftopen(unit,'/afs/mpa/home/krivonos/results/latscan/CO/comap_list.fits',0,block,status)
if(status.ne.0) then
print*,'Bad file, skip it'
call ftclos(unit,status)
call ftfiou(unit,status)
status=0
call exit(0)
endif
call FTGHDN(unit,nhdu)
call ftmahd(unit,2,hdutype,status)
call FTGHDN(unit,nhdu)
call FTGNRW(unit,tnrows, status)
call FTGNCL(unit,tncols, status)
if(tnrows.gt.trowmax) then
print*,'Too many points',tnrows,trowmax
call ftclos(unit,status)
call ftfiou(unit,status)
stop
endif
exact=.false.
call ftgcno(unit,exact,'XCOORD',ixc,status)
call ftgcno(unit,exact,'YCOORD',iyc,status)
call ftgcno(unit,exact,'VALUE',ival,status)
do iraw=1,tnrows
call ftgcve(unit,ixc,iraw,1,1,0,dglon(iraw),anynull,status)
call ftgcve(unit,iyc,iraw,1,1,0,dglat(iraw),anynull,status)
call ftgcve(unit,ival,iraw,1,1,0.,dflux(iraw),anynull,status)
end do
call ftclos(unit,status)
call ftfiou(unit,status)
if(status.gt.0) then
print*,'Too many errors',tnrows,trowmax
call ftclos(unit,status)
call ftfiou(unit,status)
call exit(0)
endif
do iraw=1,tnrows
if (isnan(dflux(iraw))) then
!if(abs(Nint(dflux(iraw))) .eq. 32768) then
print*,dglon(iraw),dglat(iraw),dflux(iraw)
dflux(iraw)=0.0
endif
enddo
! modify coordinates
do iraw=1,tnrows
if(dglon(iraw) .gt. 180.0) then
dglon(iraw)=dglon(iraw)-360.0
endif
enddo
!RAW MAP
!do iraw=1,tnrows
! print*,dglon(iraw),dglat(iraw),dflux(iraw)
!enddo
!stop
return
end

219
models/grxe/inc/read_cobe.f Normal file
View File

@@ -0,0 +1,219 @@
!c===============================================================
subroutine read_cobe(dglon,dglat,dflux_49,tnrows)
!c--------------------------------------------------------------
!c write image to FITS file
!c
!c Created: Mon May 16 14:21:02 EDT 1994
!c--------------------------------------------------------------
implicit none
character filename*40
integer nxm,nx,ny,erange,n,m
logical anyf
logical exact,anynull
integer lnblnk
integer bitpix,pcount
real*8 norma0,norma1,slope0,slope1,dist,e1,e2,texp
real*8 crval1,crval2,crpix1,crpix2,cdelt1,cdelt2,crota2
integer naxes(3),naxis,gcount,extend
integer unit,status,block,extver,hdutype,simple
character*400 comment
integer nmapm,nmapx,nmapy
parameter(nmapm=2000)
integer nhdu,tnrows,tncols
real skyexp(nmapm,nmapm)
real skydld(nmapm,nmapm)
real skyerr(nmapm,nmapm)
real image(nmapm,nmapm)
! cobe
integer TROWMAX,ipixno,irezid,istddev,iglat,iglon,iraw,isum,isel
parameter (TROWMAX=500000)
integer dpixno(TROWMAX),idx,sel(TROWMAX)
real dflux(TROWMAX),dglat(TROWMAX),dglon(TROWMAX)
real*8 dl,db
real dflux_49(TROWMAX),dflux_49_orig(TROWMAX),dflux_12(TROWMAX)
real dratio(TROWMAX)
integer*4 mask(TROWMAX)
! read DIRBE flux 4.9 microns (Resid)
! The sum of the selected column is 90891.360
! The mean of the selected column is 0.23114868
! The standard deviation of the selected column is 0.76384730
! The minimum of selected column is 3.64903696E-02
! The maximum of selected column is 110.34200
! The number of points used in calculation is 393216
!
! Expected value 0.0823
!
call ftgiou(unit,status)
call ftopen(unit,'/afs/mpa/project/integral/results/latscan/COBE/DIRBE_BAND04_ZSMA.FITS',0,block,status)
!call ftopen(unit,'/afs/mpa/project/integral/results/latscan/COBE/DIRBE_BAND3A_ZSMA.FITS',0,block,status)
if(status.ne.0) then
print*,'Bad file, skip it'
call ftclos(unit,status)
call ftfiou(unit,status)
status=0
call exit(0)
endif
call FTGHDN(unit,nhdu)
call ftmahd(unit,2,hdutype,status)
call FTGHDN(unit,nhdu)
call FTGNRW(unit,tnrows, status)
call FTGNCL(unit,tncols, status)
if(tnrows.gt.trowmax) then
print*,'Too many points',tnrows,trowmax
call ftclos(unit,status)
call ftfiou(unit,status)
stop
endif
exact=.false.
call ftgcno(unit,exact,'pixel_no',ipixno,status)
call ftgcno(unit,exact,'resid',irezid,status)
do iraw=1,tnrows
call ftgcvj(unit,ipixno,iraw,1,1,0,dpixno(iraw),anynull,status)
call ftgcve(unit,irezid,iraw,1,1,0.,dflux_49(iraw),anynull,status)
end do
call ftclos(unit,status)
call ftfiou(unit,status)
if(status.gt.0) then
call exit(0)
endif
!
! Read DIRBE flux 1.25 microns
!
! The sum of the selected column is 194936.15
! The mean of the selected column is 0.49574827
! The standard deviation of the selected column is 1.3725306
! The minimum of selected column is 2.56427769E-02
! The maximum of selected column is 215.81805
! The number of points used in calculation is 393216
!
! Expected value: 0.0775
!
call ftgiou(unit,status)
call ftopen(unit,'/afs/mpa/project/integral/results/latscan/COBE/DIRBE_BAND1A_ZSMA.FITS',0,block,status)
if(status.ne.0) then
print*,'Bad file, skip it'
call ftclos(unit,status)
call ftfiou(unit,status)
status=0
call exit(0)
endif
call FTGHDN(unit,nhdu)
call ftmahd(unit,2,hdutype,status)
call FTGHDN(unit,nhdu)
call FTGNRW(unit,tnrows, status)
call FTGNCL(unit,tncols, status)
if(tnrows.gt.trowmax) then
print*,'Too many points',tnrows,trowmax
call ftclos(unit,status)
call ftfiou(unit,status)
stop
endif
exact=.false.
call ftgcno(unit,exact,'pixel_no',ipixno,status)
call ftgcno(unit,exact,'resid',irezid,status)
do iraw=1,tnrows
call ftgcvj(unit,ipixno,iraw,1,1,0,dpixno(iraw),anynull,status)
call ftgcve(unit,irezid,iraw,1,1,0.,dflux_12(iraw),anynull,status)
end do
call ftclos(unit,status)
call ftfiou(unit,status)
if(status.gt.0) then
call exit(0)
endif
! read DIRBE coordinates
call ftgiou(unit,status)
call ftopen(unit,'/afs/mpa/project/integral/results/latscan/COBE/DIRBE_SKYMAP_INFO.FITS',0,block,status)
if(status.ne.0) then
print*,'Bad file, skip it'
call ftclos(unit,status)
call ftfiou(unit,status)
status=0
call exit(0)
endif
call FTGHDN(unit,nhdu)
call ftmahd(unit,2,hdutype,status)
call FTGHDN(unit,nhdu)
call FTGNRW(unit,tnrows, status)
call FTGNCL(unit,tncols, status)
if(tnrows.gt.trowmax) then
print*,'Too many points',tnrows,trowmax
call ftclos(unit,status)
call ftfiou(unit,status)
stop
endif
exact=.false.
call ftgcno(unit,exact,'QSPIXEL',ipixno,status)
call ftgcno(unit,exact,'GLON-CSC',iglon,status)
call ftgcno(unit,exact,'GLAT-CSC',iglat,status)
do iraw=1,tnrows
call ftgcvj(unit,ipixno,iraw,1,1,0,dpixno(iraw),anynull,status)
call ftgcve(unit,iglon,iraw,1,1,0.,dglon(iraw),anynull,status)
call ftgcve(unit,iglat,iraw,1,1,0.,dglat(iraw),anynull,status)
end do
call ftclos(unit,status)
call ftfiou(unit,status)
if(status.gt.0) then
call exit(0)
endif
! modify coordinates
do iraw=1,tnrows
if(dglon(iraw) .gt. 180.0) then
dglon(iraw)=dglon(iraw)-360.0
endif
enddo
! substruct background
do iraw=1,tnrows
dflux_12(iraw)=dflux_12(iraw)-0.07
dflux_49(iraw)=dflux_49(iraw)-0.08
enddo
! correction for absorbtion
do iraw=1,tnrows
dratio(iraw)=0.0
if(dflux_49(iraw).gt.0.5.and.dflux_49(iraw).lt.50.0.and.dflux_12(iraw).gt. 0.8 .and. dflux_12(iraw).lt.20.0) then
dratio(iraw)=dflux_12(iraw)/dflux_49(iraw)/3.5
else
dflux_49(iraw)=0.0
dflux_12(iraw)=0.0
dratio(iraw)=0.0
endif
enddo
do iraw=1,tnrows
if(dratio(iraw) .gt. 0.0 .and. dratio(iraw) .lt. 1.0) then
dratio(iraw)=(dratio(iraw))**(-0.25)
dflux_49(iraw)=dratio(iraw)*dflux_49(iraw)
else
dflux_49(iraw)=0.0
endif
enddo
do iraw=1,tnrows
if(abs(dglat(iraw)).gt.7.0) then
dflux_49(iraw)=0.0
endif
enddo
return
end

104
models/grxe/inc/read_modelrxte.f Normal file
View File

@@ -0,0 +1,104 @@
!c===============================================================
subroutine read_modelrxte(dglon,dglat,dflux,tnrows)
!c--------------------------------------------------------------
!c write image to FITS file
!c
!c Created: Mon May 16 14:21:02 EDT 1994
!c--------------------------------------------------------------
! see details /afs/mpa/project/integral/results/latscan/f90/modelrxte.f
implicit none
character filename*40
integer nxm,nx,ny,erange,n,m
logical anyf
logical exact,anynull
integer lnblnk
integer bitpix,pcount
real*8 norma0,norma1,slope0,slope1,dist,e1,e2,texp
real*8 crval1,crval2,crpix1,crpix2,cdelt1,cdelt2,crota2
integer naxes(3),naxis,gcount,extend
integer unit,status,block,extver,hdutype,simple
character*400 comment,fn
integer nmapm,nmapx,nmapy
parameter(nmapm=2000)
integer nhdu,tnrows,tncols
integer ixc,iyc,ival
real skyexp(nmapm,nmapm)
real skydld(nmapm,nmapm)
real skyerr(nmapm,nmapm)
real image(nmapm,nmapm)
integer lfblnk
! cobe
integer TROWMAX,ipixno,irezid,istddev,iglat,iglon,iraw,isum,isel
parameter (TROWMAX=3000000)
integer dpixno(TROWMAX),idx,sel(TROWMAX)
real dflux(TROWMAX),dglat(TROWMAX),dglon(TROWMAX)
real*8 dl,db
!real dflux_49(TROWMAX)
integer*4 mask(TROWMAX)
status=0
!fn='/afs/mpa/project/integral/results/latscan/f90/modelrxte_hires.bintab.fits'
fn='/afs/mpa/project/integral/results/latscan/f90/modelrxte_ait_wide.bintab.fits'
print*,'Read file',fn(:lfblnk(fn))
call ftgiou(unit,status)
call ftopen(unit,fn,0,block,status)
if(status.ne.0) then
print*,'Bad file, skip it'
call ftclos(unit,status)
call ftfiou(unit,status)
status=0
call exit(0)
endif
call FTGHDN(unit,nhdu)
call ftmahd(unit,2,hdutype,status)
call FTGHDN(unit,nhdu)
call FTGNRW(unit,tnrows, status)
call FTGNCL(unit,tncols, status)
if(tnrows.gt.trowmax) then
print*,'Too many points',tnrows,trowmax
call ftclos(unit,status)
call ftfiou(unit,status)
stop
endif
exact=.false.
call ftgcno(unit,exact,'GLON',ixc,status)
call ftgcno(unit,exact,'GLAT',iyc,status)
call ftgcno(unit,exact,'VALUE',ival,status)
do iraw=1,tnrows
call ftgcve(unit,ixc,iraw,1,1,0,dglon(iraw),anynull,status)
call ftgcve(unit,iyc,iraw,1,1,0,dglat(iraw),anynull,status)
call ftgcve(unit,ival,iraw,1,1,0.,dflux(iraw),anynull,status)
end do
call ftclos(unit,status)
call ftfiou(unit,status)
if(status.gt.0) then
print*,'Too many errors',tnrows,trowmax
call ftclos(unit,status)
call ftfiou(unit,status)
call exit(0)
endif
do iraw=1,tnrows
if (isnan(dflux(iraw))) then
!if(abs(Nint(dflux(iraw))) .eq. 32768) then
print*,dglon(iraw),dglat(iraw),dflux(iraw)
dflux(iraw)=0.0
endif
enddo
! modify coordinates
do iraw=1,tnrows
if(dglon(iraw) .gt. 180.0) then
dglon(iraw)=dglon(iraw)-360.0
endif
enddo
return
end

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