c-------------------------------------------------------------- c c ******************************* c ******************************* c ***** ***** c ***** ***** c ***** img2stk ***** c ***** ***** c ***** ***** c ******************************* c ******************************* c c The stacking routine will take a list of images, and c a list of MAT files and will combine the images into c a single stacked mosaic image. The input file will c be called "IN.img2sam" and will have 3 columns, like: c c > 01 j90a01czq_Wi4.fits 4 c > 02 j90a01d0q_Wi4.fits 4 c > 03 j90a01dfq_Wi4.fits 4 c c The first column is the image number, the second the c 4096x4096 int*4 WFC image, and the 3rd column tells c us which filter to use in the inverse transformation. c c The way it makes the mosaic image is to go through the c destination image pixel by pixel. It determines which c location in each of the NIMs images corresponds to that c location, then it lists the pixel values at those points. c It takes these NIMs "samples" for the destination-pixel c value and does some sigma clipping on them to remove c CRs and sometimes even to remove some diffraction spikes c and bled columns if enough of the images are taken at c different orientations. c c Jay Anderson c jay@eeyore.rice.edu c Aug 17, 2004 c c-------------------------------------------------------------- c 2025.02.24 -- renamed from img2sam_STDGDC to img2stk c-------------------------------------------------------------- c 2025.02.22 -- modify to read in the x2y2 from other MAT c columns; this allows the initial matching c to be done with hst1pass pushed output UV c-------------------------------------------------------------- c 2018.10.09 -- modify to use STDGDC only c-------------------------------------------------------------- #define _LINUX_ .true. #define _SKIPPX_ .false. #define _LOFLAG_ -1 c------------------------------------ c max number of images possible; feel c free to make this large, only 1-D arrays c pre-allocated c #define _NIMMAX_ 99 c------------------------------------ c max number of stars in each mat field c #define _NMATMX_ 119999 program img2stk implicit none real*8 vc_list(999), vc_bar, vc_sig real*8 vi_list(999), vi_bar, vi_sig real, dimension(:,:,:), allocatable :: pixnima real fx, fy integer iii, jjj integer DETDIMX integer DETDIMY integer PIXDIMX integer PIXDIMY real, dimension(:,:), allocatable :: pixr real, dimension(:,:), allocatable :: pixe real, dimension(:,:), allocatable :: pixc_v ! pix correlated value real, dimension(:,:), allocatable :: pixi_v ! pix imdep value integer*2, dimension(:,:), allocatable :: pixc_n integer*2, dimension(:,:), allocatable :: pixi_n byte, dimension(:,:), allocatable :: pixb real, dimension(:), allocatable :: dlist real dbar, dsig integer ND, NDs, NDu integer NIM, NIMs character*200 FILENAME_NIM(_NIMMAX_) character*200 FILEOUT character*200 FILE_PRE real*8 XOFF_META real*8 YOFF_META real*8 XOFF(_NIMMAX_), YOFF(_NIMMAX_) real*8 AG(_NIMMAX_), BG(_NIMMAX_), CG(_NIMMAX_), DG(_NIMMAX_) real*8 GA(_NIMMAX_), GB(_NIMMAX_), GC(_NIMMAX_), GD(_NIMMAX_) real*8 Xo(_NIMMAX_), Yo(_NIMMAX_), Wo(_NIMMAX_), Zo(_NIMMAX_) real*8 DELTA real*8 xc, yc, xgc, ygc real*8 xr, yr, xx, yy, xi, yi integer i, j integer ii,jj integer ir,jr real*8 bar,sig,bar1,bar2 integer NCs ,NCu integer NIs ,NIu integer n character*3 FIX real*8 xmap , ymap real*8 xmast, ymast real*8 xref, yref integer hist(1001), h real DSKY_NIM(_NIMMAX_), SSKY_NIM(_NIMMAX_) real EXPT_NIM(_NIMMAX_) real FRAT_NIM(_NIMMAX_) integer uuu_NIM(_NIMMAX_) real*8 DX_NIM(_NIMMAX_) real*8 DY_NIM(_NIMMAX_) integer IMIN, IMAX integer JMIN, JMAX integer IMIN_NIM(_NIMMAX_), IMAX_NIM(_NIMMAX_) integer JMIN_NIM(_NIMMAX_), JMAX_NIM(_NIMMAX_) real*8 x1(_NMATMX_), y1(_NMATMX_), m1(_NMATMX_) real*8 x2(_NMATMX_), y2(_NMATMX_), m2(_NMATMX_) real dm(_NMATMX_), dmbar, dmsig integer NMATs, NMATu integer NSAT integer NCOR real*8 xrr, yrr real*8 xcc, ycc real*8 dmc character*70 HDR(25) common/HDR/HDR integer iargc character*80 STRING80 character*80 INPUT_FILE logical DOBLOT logical DOBLOTX character*80 MATFILE_NIM(_NIMMAX_) character*80 MATFILEu character*200 STRING200 character*400 STRING400 character*200 FILE_STDGDC character*200 FILE_INPUT character*200 MAT_TYPE character*06 NAME_INST integer NIT, NITs real DSKYu real EXPTo real EXPTu character*80 ARGLIST(5) integer NITi integer NITf integer strlen real*8 CRPIX1,CRPIX2,CRVAL1,CRVAL2 real*8 CD1_1, CD1_2, CD2_1, CD2_2 real*8 CRPIX1u,CRPIX2u,CRVAL1u,CRVAL2u real*8 CD1_1u, CD1_2u, CD2_1u, CD2_2u real*8 MAS_PER_PIX real*8 LTV1, LTV2 real*8 LTM1_1,LTM1_2,LTM2_1,LTM2_2 real*8 XR_BDRY(4), XC_BDRY(4), XM_BDRY(4), XM_MAX, XM_MIN real*8 YR_BDRY(4), YC_BDRY(4), YM_BDRY(4), YM_MAX, YM_MIN real*8 XM_MINu, XM_MAXu real*8 YM_MINu, YM_MAXu real*8 XMo real*8 YMo integer LOOPs integer LOOPu integer LOOPx character*20 STRING_SIZE real*8 RESCALE character*40 LABEL40 integer nLAB character*5 NITSTRING5 character*10 OUTPUT logical DOSLIM real LOFLAG_USE integer X1_COL_NIM(_NIMMAX_) integer Y1_COL_NIM(_NIMMAX_) integer M1_COL_NIM(_NIMMAX_) integer X2_COL_NIM(_NIMMAX_) integer Y2_COL_NIM(_NIMMAX_) integer M2_COL_NIM(_NIMMAX_) logical DO_GDC_X2Y2_NIM(_NIMMAX_) integer NCOL, NCOLs character*20 char20_ncol(50) LOFLAG_USE = _LOFLAG_ DOSLIM = .true. LOOPs = 0 LOOPu = 0 LOOPx = 0 888 continue EXPTo = -1 ! use matfiles LABEL40 = 'IMG2SAM_STDGDC_STACK' nLAB = 20 DOBLOT = .false. DOBLOTX = .false. OUTPUT='ALL' open(66,file='img2stk.log',status='unknown') do NIM = 1, _NIMMAX_ AG(NIM) = 0. BG(NIM) = 0. CG(NIM) = 0. DG(NIM) = 0. GA(NIM) = 0. GB(NIM) = 0. GC(NIM) = 0. GD(NIM) = 0. Xo(NIM) = 0. Yo(NIM) = 0. Wo(NIM) = 0. Zo(NIM) = 0. enddo if (iargc().ne.1) then print*,' ' print*,'img2tk takes one argument: ' print*,' ' print*,' the input file: IN.img2stk ' print*,' ' print*,' This file must contain these first two lines: ' print*,' ' print*,' STDGDC=STDGDC_WFC3UV_F438W.fits ' print*,' INST=(WFC3IR/WFC3UV/ACSWFC/ACSHRC/ACSSBC ' print*,' NIRCAM/MIRI) ' print*,' [NITi=1] ' print*,' [NITf=1] ' print*,' [MATTYPE=NUM] (STEM is another option) ' print*,' [EXPTo=-1] reference exposure time ' print*,' (if = 0, will do no normalizn) ' print*,' (if = -1, will use matfiles; default)' print*,' (if = >0, will norm w/indiv exptimes)' print*,' [WCS(Xo,Yo,RAo,DECo,MAS_PER_PIX)] ' print*,' (info to output in stack header) ' print*,' [SIZE=(AUTO,4000x4000)] AUTO is default ' print*,' AUTO (default) finds boundaries; ' print*,' pops image coords ' print*,' [RESCALE=1.0] rescales coord system; ' print*,' 2.0 = supersampled x2 ' print*,' pops image coords ' print*,' [DOSLIM+] (default) ' print*,' [LABEL=NGC5139_F606W] ' print*,' up to 40 characters, no spaces! ' print*,' 0001 idho21hyq_flt.fits [DSKY=0.0] [EXPT=]' print*,' .... .................. ......... ............' print*,' .... .................. [MAT=MAT.001] (UVXY) ' print*,' .... .................. ......... ............' print*,' .... .................. [MAT_x20y21m22=MAT.001 ' print*,' .... .................. ......... ............' print*,' .... .................. ......... ............' print*,' ' print*,' ' stop endif call getarg(1,FILE_INPUT) 166 format('#--------------------------------------------------') write(66,'('' '')') write(66,166) write(66,'(''# INPUT FILE: '',80a)') . FILE_INPUT(1:strlen(FILE_INPUT)) write(66,166) write(66,'('' '')') write(*,'('' '')') write(*,166) write(*,'(''# INPUT FILE: '',80a)') . FILE_INPUT(1:strlen(FILE_INPUT)) write(*,166) write(*,'('' '')') c-------------------------------------------------- c c read in the basic info: image names and filter info c and the transformations from the indiv frame (x2,y2) c into the master frame (x1,y1) c FILE_STDGDC = 'NULL' NAME_INST = 'NULL' MAT_TYPE = 'NUM' CRPIX1 = 0.0d0 CRPIX2 = 0.0d0 CRVAL1 = 0.0d0 CRVAL2 = 0.0d0 MAS_PER_PIX = 50.00d0 NITi = 1 NITf = 1 RESCALE = 1.000 STRING_SIZE = 'AUTO' XOFF_META = 0.000 YOFF_META = 0.000 do NIM = 1, _NIMMAX_ FILENAME_NIM(NIM) = 'NONE' UUU_NIM(NIM) = 0 enddo print*,' ' print*,'OPENING INPUT FILE: ',FILE_INPUT print*,' ' NIMs = 0 open(10,file=FILE_INPUT,status='old') print*,'LOOPu: ',LOOPu call flush(66) 773 read(10,'(a200)',end=1) STRING200 write(66,'(a200)') STRING200 write( *,'(a200)') STRING200 if (STRING200(1:1).eq.'#') goto 773 if (STRING200(1:3).eq.'END') goto 1 if (STRING200(1:7).eq.'STDGDC=') then FILE_STDGDC = STRING200(8:200) print*,'FILE_STDGDC: ',FILE_STDGDC goto 773 endif if (STRING200(1:7).eq.'LOFLAG=') then read(STRING200(8:20),*) LOFLAG_USE print*,'STRING200: ',STRING200(1:20) print*,' LOFLAG: ',LOFLAG_USE goto 773 endif if (STRING200(1:6).eq.'LOOPs=') then read(STRING200(7:10),*) LOOPs if (LOOPu.eq.0) then LOOPu = 1 LOOPx = 1 endif print*,'LOOPu: ',LOOPu goto 773 endif if (STRING200(1:4).eq.'LOOP') then read(STRING200(5:7),*) LOOPx print*,'LOOPx: ',LOOPx,LOOPu,LOOPs goto 773 endif print*,'LOOP: ',LOOPu,LOOPx,LOOPs if (LOOPx.ne.LOOPu) goto 773 if (STRING200(1:5).eq.'SLIM+') then DOSLIM = .true. goto 773 endif if (STRING200(1:5).eq.'SLIM-') then DOSLIM = .false. goto 773 endif if (STRING200(1:7).eq.'OUTPUT=') then OUTPUT=STRING200(8:20) goto 773 endif if (STRING200(1:5).eq.'INST=') then NAME_INST = STRING200(6:11) DETDIMX = 0 DETDIMY = 0 if (NAME_INST.eq.'GENERI') then if (STRING200(12:13).ne.'C(') then print*,' ' print*,'The new format for specifying a generic ' print*,'image is: ' print*,' ' print*,' INST=GENERIC(500,500) ' print*,' ' stop endif do i = 14,200 if (STRING200(i:i).eq.',') STRING200(i:i) = ' ' if (STRING200(i:i).eq.')') STRING200(i:i) = ' ' enddo read(STRING200(14:200),*) DETDIMX, DETDIMY print*,' ' print*,'GENERIC INSTRUMENT' print*,' DETDIMX: ',DETDIMX print*,' DETDIMY: ',DETDIMY print*,' ' goto 773 endif if (NAME_INST.eq.'WFC3IX') then DETDIMX = 1014 DETDIMY = 1014 goto 773 endif if (NAME_INST.eq.'WFC3IR') then DETDIMX = 1014 DETDIMY = 1014 goto 773 endif if (NAME_INST.eq.'WFC3UV') then DETDIMX = 4096 DETDIMY = 4096 goto 773 endif if (NAME_INST.eq.'ACSWFC') then DETDIMX = 4096 DETDIMY = 4096 goto 773 endif if (NAME_INST.eq.'ACSHRC') then DETDIMX = 1024 DETDIMY = 1024 goto 773 endif if (NAME_INST.eq.'ACSSBC') then DETDIMX = 1024 DETDIMY = 1024 goto 773 endif if (NAME_INST.eq.'NRCSWC') then DETDIMX = 8192 DETDIMY = 4096 goto 773 endif if (NAME_INST.eq.'NIRCAM') then DETDIMX = 2048 DETDIMY = 2048 goto 773 endif if (NAME_INST.eq.'MIRI ') then DETDIMX = 1032 DETDIMY = 1024 goto 773 endif print*,' ' print*,' ' print*,'AT THE MOMENT, THE INSTRUMENT NAME ' print*,'MUST BE WFC3UV, WFC3IR, ACSWFC, ACSHRC, ' print*,'OR ACSSBC ' print*,' ' stop endif if (STRING200(1:5).eq.'NITi=') then read(STRING200(6:200),*) NITi goto 773 endif if (STRING200(1:5).eq.'NITf=') then read(STRING200(6:200),*) NITf goto 773 endif if (STRING200(1:6).eq.'EXPTo=') then read(STRING200(7:200),*) EXPTo goto 773 endif if (STRING200(1:8).eq.'MATTYPE=') then MAT_TYPE = STRING200(9:200) if (MAT_TYPE(1:3).ne.'NUM'.and. . MAT_TYPE(1:4).ne.'STEM') then print*,'MAT_TYPE: ',MAT_TYPE print*,'must be either "NUM" or "STEM" ' stop endif goto 773 endif if (STRING200(1:5).eq.'WCS=(') then print*,'READ IN WCS...' print*,'STRING200: ',STRING200(5:200) do i = 1, 200 if (STRING200(i:i).eq.'(') STRING200(i:i) = ' ' if (STRING200(i:i).eq.')') STRING200(i:i) = ' ' if (STRING200(i:i).eq.',') STRING200(i:i) = ' ' enddo print*,'STRING200: ',STRING200(5:200) read(STRING200(5:200),*) CRPIX1,CRPIX2,CRVAL1, CRVAL2, . MAS_PER_PIX CD1_1 = -1.388888904E-05*(MAS_PER_PIX/50) CD1_2 = 0.000000000E-05*(MAS_PER_PIX/50) CD2_1 = 0.000000000E-05*(MAS_PER_PIX/50) CD2_2 = 1.388888904E-05*(MAS_PER_PIX/50) CRPIX1u = (CRPIX1-XOFF_META)*RESCALE CRPIX2u = (CRPIX2-YOFF_META)*RESCALE CRVAL1u = CRVAL1 CRVAL2u = CRVAL2 CD1_1u = -1.388888904E-05*(MAS_PER_PIX/50)/RESCALE CD1_2u = 0.000000000E-05*(MAS_PER_PIX/50)/RESCALE CD2_1u = 0.000000000E-05*(MAS_PER_PIX/50)/RESCALE CD2_2u = 1.388888904E-05*(MAS_PER_PIX/50)/RESCALE print*,'SET WCS...' print*,' CD1_1 : ',CD1_1 print*,' CD1_1u: ',CD1_1u goto 773 endif if (STRING200(1:6).eq.'LABEL=') then LABEL40 = STRING200(7:46) nLAB = 0 do i = 40, 2, -1 if (LABEL40(i:i).eq.' ') nLAB = i-1 enddo if (nLAB.eq.0) then print*,'ERROR IN LABEL: ' print*,' LABEL40: ',LABEL40 stop endif goto 773 endif if (STRING200(1:5).eq.'SIZE=') then STRING_SIZE = STRING200(6:25) goto 773 endif if (STRING200(1:8).eq.'RESCALE=') then read(STRING200(9:200),*) RESCALE goto 773 endif if (STRING200(01:10).eq.'XOFF_META=') then read(STRING200(11:200),*) XOFF_META goto 773 endif if (STRING200(01:10).eq.'YOFF_META=') then read(STRING200(11:200),*) YOFF_META goto 773 endif if (STRING200(1:1).lt.'0'.and.STRING200(1:1).gt.'9') then print*,'ERROR IN INPUT FILE CARD: ' print*,'CARD: ' print*,STRING200 stop endif c c at this point, we know it's an image c DSKYu = 0. EXPTu = 0. ARGLIST(1) = 'NONE' ARGLIST(2) = 'NONE' ARGLIST(3) = 'NONE' ARGLIST(4) = 'NONE' ARGLIST(5) = 'NONE' read(STRING200,*) NIM,FILEOUT read(STRING200,*,end=556) NIM,FILEOUT,(ARGLIST(i),i=1,1) read(STRING200,*,end=556) NIM,FILEOUT,(ARGLIST(i),i=1,2) read(STRING200,*,end=556) NIM,FILEOUT,(ARGLIST(i),i=1,3) read(STRING200,*,end=556) NIM,FILEOUT,(ARGLIST(i),i=1,4) read(STRING200,*,end=556) NIM,FILEOUT,(ARGLIST(i),i=1,5) 556 continue IMIN_NIM(NIM)=-999 IMAX_NIM(NIM)=9999 JMIN_NIM(NIM)=-999 JMAX_NIM(NIM)=9999 MATFILE_NIM(NIM) = 'NONE' print*,'---> ' print*,'---> ',STRING200 print*,'---> ' do i = 1, 5 if (ARGLIST(i)(1:5).eq.'DSKY=') then read(ARGLIST(i)(5:40),*) DSKYu goto 444 endif if (ARGLIST(i)(1:5).eq.'EXPT=') then read(ARGLIST(i)(6:40),*) EXPTu goto 444 endif if (ARGLIST(i)(1:4).eq.'MAT=') then X1_COL_NIM(NIM) = 1 Y1_COL_NIM(NIM) = 2 M1_COL_NIM(NIM) = 5 X2_COL_NIM(NIM) = 3 Y2_COL_NIM(NIM) = 4 M2_COL_NIM(NIM) = 6 DO_GDC_X2Y2_NIM(NIM) = .false. MATFILE_NIM(NIM) = ARGLIST(i)(5:80) goto 444 endif if (ARGLIST(i)(1:5).eq.'MAT_x') then if (ARGLIST(i)(01:05).ne.'MAT_x'.or. . ARGLIST(i)(08:08).ne.'y' .or. . ARGLIST(i)(11:11).ne.'m' .or. . ARGLIST(i)(14:14).ne.'=') then print*,' ' write(*,'(a200)') STRING200 print*,'ARGLIST(i): i = ',i print*,' ARG = ',ARGLIST(i) print*,' ' print*,'Proper format: MAT_x12y13m14=MAT.NNN ' print*,' ' stop endif X1_COL_NIM(NIM) = 1 Y1_COL_NIM(NIM) = 2 M1_COL_NIM(NIM) = 5 read(ARGLIST(i)(06:07),*) X2_COL_NIM(NIM) read(ARGLIST(i)(09:10),*) Y2_COL_NIM(NIM) read(ARGLIST(i)(12:13),*) M2_COL_NIM(NIM) DO_GDC_X2Y2_NIM(NIM) = .true. MATFILE_NIM(NIM) = ARGLIST(i)(15:80) !print*,'----> ' !print*,' ARGLIST(i): ',ARGLIST(i) !print*,' X2_COL: ',X2_COL_NIM(NIM) !print*,' Y2_COL: ',Y2_COL_NIM(NIM) !print*,' M2_COL: ',M2_COL_NIM(NIM) !print*,' MATFILE: ',MATFILE_NIM(NIM) goto 444 endif if (ARGLIST(i)(1:5).eq.'DXDY=') then MATFILE_NIM(NIM) = 'DXDY' read(ARGLIST(i)(6:80),*) DX_NIM(NIM), DY_NIM(NIM) goto 444 endif if (ARGLIST(i)(1:1).eq.'x') then read(ARGLIST(i)(2:80),*) IMIN_NIM(NIM), IMAX_NIM(NIM) goto 444 endif if (ARGLIST(i)(1:1).eq.'y') then read(ARGLIST(i)(2:80),*) JMIN_NIM(NIM), JMAX_NIM(NIM) goto 444 endif if (ARGLIST(i)(1:4).eq.'NONE') goto 444 print*,'ERROR IN EXTRA INFO ON CARD: ' print*,STRING200 print*,' i: ',i,ARGLIST(i) 444 continue enddo if (NIM.gt.NIMs) NIMs = NIM FILENAME_NIM(NIM) = FILEOUT UUU_NIM(NIM) = 1 EXPT_NIM(NIM) = EXPTu DSKY_NIM(NIM) = DSKYu goto 773 1 continue call flush(66) close(10) write(66,'('' '')') write(66,166) write(66,'(''# BASIC PARAMERS '')') write(66,166) write(66,'('' '')') write(66,'('' NIMs : '',i4)') NIMs write(66,'('' NITi : '',i4)') NITi write(66,'('' NITf : '',i4)') NITf write(66,'('' EXPTo : '',f8.2)') EXPTo write(66,'('' STDGDC: '',200a)')FILE_STDGDC(1:strlen(FILE_STDGDC)) write(66,'(''MATTYPE: '',80a)') MAT_TYPE(1:strlen(MAT_TYPE)) write(66,'('' SIZE: '',20a)') STRING_SIZE write(66,'(''RESCALE: '',f8.2)') RESCALE write(66,'('' WCS_XY: '',2i8)') int(CRPIX1+0.5), int(CRPIX2+0.5) write(66,'('' WCS_RD: '',2f15.8)') CRVAL1, CRVAL2 write(66,'('' mas/px: '', f08.3)') MAS_PER_PIX write(66,'('' '')') call flush(66) write( *,'('' '')') write( *,166) write( *,'(''# BASIC PARAMERS '')') write( *,166) write( *,'('' '')') write( *,'('' NIMs : '',i4)') NIMs write( *,'('' NITi : '',i4)') NITi write( *,'('' NITf : '',i4)') NITf write( *,'('' EXPTo : '',f8.2)') EXPTo write( *,'('' STDGDC: '',200a)')FILE_STDGDC(1:strlen(FILE_STDGDC)) write( *,'(''MATTYPE: '',80a)') MAT_TYPE(1:strlen(MAT_TYPE)) write( *,'('' SIZE: '',20a)') STRING_SIZE write( *,'(''RESCALE: '',f8.2)') RESCALE write( *,'('' WCS_XY: '',2i8)') int(CRPIX1+0.5), int(CRPIX2+0.5) write( *,'('' WCS_RD: '',2f15.8)') CRVAL1, CRVAL2 write( *,'('' mas/px: '', f08.3)') MAS_PER_PIX write( *,'('' XOFF__: '', f08.3)') MAS_PER_PIX write( *,'('' YOFF__: '', f08.3)') MAS_PER_PIX write( *,'('' '')') print*,' ' print*,' NIMs: ',NIMs print*,' ' write(66,'('' '')') write(66,166) write(66,'(''# ALLOCATE SPACE... '')') write(66,166) write(66,'('' '')') call flush(66) write( *,'('' '')') write( *,166) write( *,'(''# ALLOCATE SPACE... '')') write( *,166) write( *,'('' '')') allocate(pixr(DETDIMX,DETDIMY)) allocate(pixe(DETDIMX,DETDIMY)) allocate(pixnima(DETDIMX,DETDIMY,NIMs)) allocate(dlist(DETDIMX*DETDIMY)) write(66,'('' '')') write(66,166) write(66,'(''# TRANSFORMATION INFO... '')') write(66,166) write(66,'('' '')') call flush(66) write( *,'('' '')') write( *,166) write( *,'(''# TRANSFORMATION INFO... '')') write( *,166) write( *,'('' '')') XM_MINu = 99999 XM_MAXu = -9999 YM_MINu = 99999 YM_MAXu = -9999 write(66,123) write(66,133) write(66,123) call flush(66) write(*,123) write(*,133) write(*,123) do NIM = 1, NIMs if (FILENAME_NIM(NIM)(1:4).eq.'NONE') goto 3333 MATFILEu = MATFILE_NIM(NIM) if (MATFILEu.eq.'DXDY') then GA(NIM) = 1. GB(NIM) = 0. GC(NIM) = 0. GD(NIM) = 1. AG(NIM) = 1. BG(NIM) = 0. CG(NIM) = 0. DG(NIM) = 1. XOFF(NIM) = DX_NIM(NIM) YOFF(NIM) = DX_NIM(NIM) Xo(NIM) = 0.00 Yo(NIM) = 0.00 Wo(NIM) = DX_NIM(NIM) Zo(NIM) = DY_NIM(NIM) dbar = 1.00 dsig = 0.00 EXPT_NIM(NIM) = 1.0 FRAT_NIM(NIM) = 1.0 goto 777 endif if (MATFILEu.eq.'NONE') then if (MAT_TYPE(1:3).eq.'NUM') then write(MATFILEu,'(''MAT.'',i3.3)') NIM endif if (MAT_TYPE(1:4).eq.'STEM') then do i = 1, 80 if (FILEOUT(i:i+4).eq.'.fits') then MATFILEu = FILEOUT(1:i-1) // 'mat' endif enddo endif endif open(11,file=MATFILEu,status='old') NMATs = 0 NCOLs = max(X1_COL_NIM(NIM),Y1_COL_NIM(NIM),M1_COL_NIM(NIM), . X2_COL_NIM(NIM),Y2_COL_NIM(NIM),M2_COL_NIM(NIM)) print*,'NIM: ',NIM,NCOLs 3 continue read(11,'(a400)',end=4) STRING400 print*,'NIM: ',NIM,STRING400 if (STRING400(1:1).eq.'#') goto 3 NMATs = NMATs + 1 read(STRING400,*) (char20_ncol(NCOL),NCOL=1,NCOLs) print*,'NIM: ',NIM,1,char20_ncol(X1_COL_NIM(NIM)) read(char20_ncol(X1_COL_NIM(NIM)),*) x1(NMATs) read(char20_ncol(Y1_COL_NIM(NIM)),*) y1(NMATs) read(char20_ncol(M1_COL_NIM(NIM)),*) m1(NMATs) print*,'NIM: ',NIM,3,char20_ncol(X2_COL_NIM(NIM)) read(char20_ncol(X2_COL_NIM(NIM)),*) x2(NMATs) read(char20_ncol(Y2_COL_NIM(NIM)),*) y2(NMATs) read(char20_ncol(M2_COL_NIM(NIM)),*) m2(NMATs) if (DO_GDC_X2Y2_NIM(NIM)) then print*,'---> DO_GDC...',FILE_STDGDC xrr = x2(NMATs) yrr = y2(NMATs) call xryr2xcyc_stdgc(xrr,yrr,xcc,ycc,FILE_STDGDC) call xryr2mc_stdgc(xrr,yrr,dmc,FILE_STDGDC) x2(NMATs) = xcc y2(NMATs) = ycc m2(NMATs) = m2(NMATs+1) + dmc endif x1(NMATs) = x1(NMATs) - XOFF_META y1(NMATs) = y1(NMATs) - YOFF_META dm(NMATs) = m1(NMATs)-m2(NMATs) if (NMATs.gt._NMATMX_) then print*,'Increase _NMATMX_ ',(_NMATMX_) stop endif goto 3 4 continue print*,'NIM: ',NIM,NMATs GA(NIM) = 0. GB(NIM) = 0. GC(NIM) = 0. GD(NIM) = 0. call glob_fit6nrDP(x1,y1,x2,y2,NMATs, . AG(NIM),BG(NIM),CG(NIM),DG(NIM), . Xo(NIM),Yo(NIM),Wo(NIM),Zo(NIM)) DELTA = AG(NIM)*DG(NIM)-CG(NIM)*BG(NIM) GA(NIM) = DG(NIM)/DELTA GB(NIM) = -BG(NIM)/DELTA GC(NIM) = -CG(NIM)/DELTA GD(NIM) = AG(NIM)/DELTA XOFF(NIM) = GA(NIM)*(0507-Wo(NIM)) . + GB(NIM)*(0507-Zo(NIM)) . + Xo(NIM)-0507 YOFF(NIM) = GC(NIM)*(0507-Wo(NIM)) . + GD(NIM)*(0507-Zo(NIM)) . + Yo(NIM)-0507 call barsigg(dm,NMATs,dbar,dsig,NMATu) c EXPT_NIM(NIM) = 1.00 c if (NAME_INST.ne.'NRCSWC'.and. c . NAME_INST.ne.'NIRCAM') then c call query_hdr_r4(FILENAME_NIM(NIM),'EXPTIME ', c . EXPT_NIM(NIM)) c endif c EXPT_NIM(NIM) = 1.00 c if (NAME_INST.ne.'MIRI '.and. c . NAME_INST.ne.'MIRI ') then c call query_hdr_r4(FILENAME_NIM(NIM),'EFFEXPTM', c . EXPT_NIM(NIM)) c endif FRAT_NIM(NIM) = 1.0000d0 if (EXPTo.gt.0) then FRAT_NIM(NIM) = EXPTo/EXPT_NIM(NIM) endif if (EXPTo.eq.-1) then FRAT_NIM(NIM) = 10**(dbar/2.5) endif XR_BDRY(1) = 0001.0 YR_BDRY(1) = 0001.0 XR_BDRY(2) = 0001.0 YR_BDRY(2) = DETDIMY XR_BDRY(3) = DETDIMX YR_BDRY(3) = DETDIMY XR_BDRY(4) = DETDIMX YR_BDRY(4) = 0001.0 do i = 1, 4 call xryr2xcyc_stdgc(XR_BDRY(i),YR_BDRY(i), . XC_BDRY(i),YC_BDRY(i), . FILE_STDGDC) XM_BDRY(i) = Xo(NIM) + GA(NIM)*(XC_BDRY(i)-Wo(NIM)) . + GB(NIM)*(YC_BDRY(i)-Zo(NIM)) YM_BDRY(i) = Yo(NIM) + GC(NIM)*(XC_BDRY(i)-Wo(NIM)) . + GD(NIM)*(YC_BDRY(i)-Zo(NIM)) enddo XM_MIN = min(XM_BDRY(1),XM_BDRY(2),XM_BDRY(3),XM_BDRY(4)) XM_MAX = max(XM_BDRY(1),XM_BDRY(2),XM_BDRY(3),XM_BDRY(4)) YM_MIN = min(YM_BDRY(1),YM_BDRY(2),YM_BDRY(3),YM_BDRY(4)) YM_MAX = max(YM_BDRY(1),YM_BDRY(2),YM_BDRY(3),YM_BDRY(4)) XM_MINu = min(XM_MINu,XM_MIN) XM_MAXu = max(XM_MAXu,XM_MAX) YM_MINu = min(YM_MINu,YM_MIN) YM_MAXu = max(YM_MAXu,YM_MAX) 777 continue write(66,113) NIM,NMATs,AG(NIM),BG(NIM),CG(NIM),DG(NIM), . XOFF(NIM),YOFF(NIM),dbar,dsig, . EXPT_NIM(NIM),FRAT_NIM(NIM), . int(XM_MIN+0.5),int(XM_MAX+0.5), . int(XM_MIN+0.5),int(YM_MAX+0.5), . FILENAME_NIM(NIM)(1:strlen(FILENAME_NIM(NIM))) call flush(66) write( *,113) NIM,NMATs,AG(NIM),BG(NIM),CG(NIM),DG(NIM), . XOFF(NIM),YOFF(NIM),dbar,dsig, . EXPT_NIM(NIM),FRAT_NIM(NIM), . int(XM_MIN+0.5),int(XM_MAX+0.5), . int(YM_MIN+0.5),int(YM_MAX+0.5), . FILENAME_NIM(NIM)(1:strlen(FILENAME_NIM(NIM))) 113 format(1x,i3.3,1x,i5,4(1x,f9.6),2(1x,f8.2),1x,f7.3,1x,f5.3, . 1x,f6.1,1x,f6.4, . 1x,i5,1x,i5,1x,i5,1x,i5, . 1x,60a) if (NAME_INST.eq.'WFC3IX') then do j = 0001, DETDIMY do i = 0001, DETDIMX pixr(i,j) = -10000 enddo enddo call readfits_r4(FILENAME_NIM(NIM),pixr,1014,1014) do j = 0001, DETDIMY do i = 0001, DETDIMX pixnima(i,j,NIM) = pixr(i,j)*FRAT_NIM(NIM) enddo enddo endif if (NAME_INST.eq.'WFC3IR') then do j = 0001, DETDIMY do i = 0001, DETDIMX pixr(i,j) = -10000 enddo enddo call read_wfc3ir_flt_full_simpl(FILENAME_NIM(NIM),pixr) do j = 0001, DETDIMY do i = 0001, DETDIMX pixnima(i,j,NIM) = pixr(i,j)*FRAT_NIM(NIM) enddo enddo endif if (NAME_INST.eq.'WFC3UV') then do j = 0001, DETDIMY do i = 0001, DETDIMX pixr(i,j) = -10000 enddo enddo call read_wfc3uv_flt_smpl(FILENAME_NIM(NIM),pixr) do j = 0001, DETDIMY do i = 0001, DETDIMX pixnima(i,j,NIM) = pixr(i,j)*FRAT_NIM(NIM) enddo enddo endif if (NAME_INST.eq.'ACSWFC') then do j = 0001, DETDIMY do i = 0001, DETDIMX pixr(i,j) = -10000 enddo enddo call read_acswfc_flt_smpl(FILENAME_NIM(NIM),pixr) do j = 0001, DETDIMY do i = 0001, DETDIMX pixnima(i,j,NIM) = pixr(i,j)*FRAT_NIM(NIM) enddo enddo endif if (NAME_INST.eq.'MIRI ') then do j = 0001, DETDIMY do i = 0001, DETDIMX pixr(i,j) = -10000 enddo enddo call readfits_r4(FILENAME_NIM(NIM),pixr,DETDIMX,DETDIMY) do j = 0001, DETDIMY do i = 0001, DETDIMX if (isnan(pixr(i,j))) pixr(i,j) = -750 enddo enddo do j = 0001, DETDIMY do i = 0001, DETDIMX pixnima(i,j,NIM) = pixr(i,j)*FRAT_NIM(NIM) enddo enddo do j = 0001, DETDIMY do i = 0001, 0362 pixnima(i,j,NIM) = -750 enddo enddo endif if (NAME_INST.eq.'NRCSWC'.or. . NAME_INST.eq.'NIRCAM') then do j = 0001, DETDIMY do i = 0001, DETDIMX pixr(i,j) = -10000 enddo enddo call readfits_r4(FILENAME_NIM(NIM),pixr,DETDIMX,DETDIMY) do j = 0001, DETDIMY do i = 0001, DETDIMX pixnima(i,j,NIM) = pixr(i,j)*FRAT_NIM(NIM) if (pixr(i,j).eq.0) pixnima(i,j,NIM) = -999 enddo enddo do j = 0001, DETDIMY do i = 0001, DETDIMX if (i.lt.IMIN_NIM(NIM).or. . i.gt.IMAX_NIM(NIM).or. . j.lt.JMIN_NIM(NIM).or. . j.gt.JMAX_NIM(NIM)) pixnima(i,j,NIM) = -999 enddo enddo endif if (NAME_INST.eq.'ACSHRC') then do j = 0001, DETDIMY do i = 0001, DETDIMX pixr(i,j) = -10000 enddo enddo call read_acshrc_flt_smpl(FILENAME_NIM(NIM),pixr) do j = 0001, DETDIMY do i = 0001, DETDIMX pixnima(i,j,NIM) = pixr(i,j)*FRAT_NIM(NIM) enddo enddo endif if (NAME_INST.eq.'ACSSBC') then do j = 0001, DETDIMY do i = 0001, DETDIMX pixr(i,j) = -10000 enddo enddo call readfits_r4e(FILENAME_NIM(NIM),pixr,1024,1024,1) do j = 0001, DETDIMY do i = 0001, DETDIMX pixnima(i,j,NIM) = pixr(i,j)*FRAT_NIM(NIM) enddo enddo endif 3333 continue enddo!NIM 123 format('#...', . 1x,'.....', . 1x,'.........', . 1x,'.........', . 1x,'.........', . 1x,'.........', . 1x,'........', . 1x,'........', . 1x,'.......', . 1x,'.....', . 1x,'......', . 1x,'......', . 1x,'.....', . 1x,'.....', . 1x,'.....', . 1x,'.....', . 1x,'........................................') 133 format('#NIM', . 1x,'NMATs', . 1x,' AG(NIM)', . 1x,' BG(NIM)', . 1x,' CG(NIM)', . 1x,' DG(NIM)', . 1x,' XOFF', . 1x,' YOFF', . 1x,' MBAR', . 1x,' SBAR', . 1x,' EXPT', . 1x,' FRAT', . 1x,' IMIN', . 1x,' IMAX', . 1x,' JMIN', . 1x,' JMAX', . 1x,'FILENAME_NIM(NIM) ') 143 format('#',3x,1x,5x,4(1x,9x),2(1x,8x),1x,7x,1x,5x, . 1x,6x,1x,6x, . 1x,i5,1x,i5,1x,i5,1x,i5) write(*,123) write(*,133) write(*,123) write(*,143) int(XM_MINu+0.5),int(XM_MAXu+0.5), . int(YM_MINu+0.5),int(YM_MAXu+0.5) write(*,123) write(66,123) write(66,133) write(66,123) write(66,143) int(XM_MINu+0.5),int(XM_MAXu+0.5), . int(YM_MINu+0.5),int(YM_MAXu+0.5) write(66,123) write(66,'('' '')') write(66,166) write(66,'('' '')') call flush(66) if (STRING_SIZE(1:4).eq.'AUTO') then XMo = int(XM_MINu-3 + 0.5) YMo = int(YM_MINu-3 + 0.5) PIXDIMX = (XM_MAXu-XMo+3)*RESCALE PIXDIMY = (YM_MAXu-YMo+3)*RESCALE LTV1 = (-XMo)*RESCALE LTV2 = (-YMo)*RESCALE LTM1_1 = RESCALE LTM1_2 = 0.00 LTM2_1 = 0.00 LTM2_2 = RESCALE CRPIX1u = RESCALE*(CRPIX1-XMo) CRPIX2u = RESCALE*(CRPIX2-YMo) CRVAL1u = CRVAL1 CRVAL2u = CRVAL2 CD1_1u = CD1_1/RESCALE CD1_2u = CD1_2/RESCALE CD2_1u = CD2_1/RESCALE CD2_2u = CD2_2/RESCALE print*,'STRING_SIZE.eq.AUTO...' print*,' CD1_1 : ',CD1_1 print*,' CD1_1u: ',CD1_1u else j = 0 do i = 1, 20 if (STRING_SIZE(i:i).eq.'x') j = i enddo if (j.eq.0) then print*,' ' print*,' STRING_SIZE: ',STRING_SIZE print*,' ' print*,' --> no "x"... need 4000x4000, etc ' print*,' ' stop endif read(STRING_SIZE(01:j-1),*) PIXDIMX read(STRING_SIZE(j+1:20),*) PIXDIMY XMo = 0 YMo = 0 LTV1 = (1.0-RESCALE) LTV2 = (1.0-RESCALE) c------------------------------------------ LTV1 = 0.000 LTV2 = 0.000 LTV1 = (-XOFF_META)*RESCALE LTV2 = (-YOFF_META)*RESCALE c------------------------------------------ LTM1_1 = RESCALE LTM1_2 = 0.00 LTM2_1 = 0.00 LTM2_2 = RESCALE endif print*,'ALLOCATE...' allocate(pixc_v(PIXDIMX,PIXDIMY)) allocate(pixi_v(PIXDIMX,PIXDIMY)) allocate(pixc_n(PIXDIMX,PIXDIMY)) allocate(pixi_n(PIXDIMX,PIXDIMY)) write(HDR(01),'(f10.3)') CRPIX1 write(HDR(02),'(f10.3)') CRPIX2 write(HDR(03),'(f15.9)') CRVAL1 write(HDR(04),'(f15.9)') CRVAL2 HDR(05) = "'RA---TAN'" ! CTYPE1 HDR(06) = "'DEC--TAN'" ! CTYPE2 write(HDR(07),'(e15.8)') CD1_1 write(HDR(08),'(e15.8)') CD1_2 write(HDR(09),'(e15.8)') CD2_1 write(HDR(10),'(e15.8)') CD2_2 write(66,'('' '')') write(66,166) write(66,'('' '')') write(66,'('' STR_SIZE: '',a20)') STRING_SIZE write(66,'('' SIZE: '',i5,''x'',i5)') PIXDIMX, PIXDIMY write(66,'('' '')') write(66,'('' CRPIX1: '',a20)') HDR(01) write(66,'('' CRPIX2: '',a20)') HDR(02) write(66,'('' '')') write(66,'('' CRVAL1: '',a20)') HDR(03) write(66,'('' CRVAL2: '',a20)') HDR(04) write(66,'('' '')') write(66,'('' TRANS1: '',a20)') HDR(05) write(66,'('' TRANS2: '',a20)') HDR(06) write(66,'('' '')') write(66,'('' CD1_1: '',a20)') HDR(07) write(66,'('' CD1_2: '',a20)') HDR(08) write(66,'('' CD2_1: '',a20)') HDR(09) write(66,'('' CD2_2: '',a20)') HDR(10) write(66,'('' '')') write(66,166) write(66,'('' '')') call flush(66) write(*,'('' '')') write(*,166) write(*,'('' '')') write(*,'('' STR_SIZE: '',a20)') STRING_SIZE write(*,'('' SIZE: '',i5,''x'',i5)') PIXDIMX, PIXDIMY write(*,'('' '')') write(*,'('' CRPIX1: '',a20)') HDR(01) write(*,'('' CRPIX2: '',a20)') HDR(02) write(*,'('' '')') write(*,'('' CRVAL1: '',a20)') HDR(03) write(*,'('' CRVAL2: '',a20)') HDR(04) write(*,'('' '')') write(*,'('' TRANS1: '',a20)') HDR(05) write(*,'('' TRANS2: '',a20)') HDR(06) write(*,'('' '')') write(*,'('' CD1_1: '',a20)') HDR(07) write(*,'('' CD1_2: '',a20)') HDR(08) write(*,'('' CD2_1: '',a20)') HDR(09) write(*,'('' CD2_2: '',a20)') HDR(10) write(*,'('' '')') write(*,166) write(*,'('' '')') print*,'INTERNAL SIZES...' print*,' CD1_1 : ',CD1_1 print*,' CD1_1u: ',CD1_1u c--------------------------------------------------------------------- if (NITi.ge.2) then ! read in the stacked image... print*,' ' print*,'NITi.ge.2 --- NITi: ',NITi print*,' ' write(NITSTRING5,'(''NIT'',i2.2)') NITi-1 FILEOUT = LABEL40(1:nLAB) // '_STK_COREL' . // '_' // NITSTRING5 . // '.fits' print*,'READ IN PREVIOUS COREL OUTPUT: ',FILEOUT call readfits_r4(FILEOUT,pixc_v,PIXDIMX,PIXDIMY) FILEOUT = LABEL40(1:nLAB) // '_NUM_COREL' . // '_' // NITSTRING5 . // '.fits' if (NIMs.gt.125) . call readfits_i2(FILEOUT,pixc_n,PIXDIMX,PIXDIMY) if (NIMs.le.125) then allocate(pixb(PIXDIMX,PIXDIMY)) call readfits_b1(FILEOUT,pixb,PIXDIMX,PIXDIMY) do i = 0001, PIXDIMX do j = 0001, PIXDIMY pixc_n(i,j) = pixb(i,j) enddo enddo deallocate(pixb) endif endif print*,' ' print*,'INTERNAL LIMITS: ' print*,' ' do NIM = 1, NIMs IMIN = 99999 IMAX = -99999 JMIN = 99999 JMAX = -99999 do j = 0001,DETDIMY do i = 0001,DETDIMX if (pixnima(i,j,NIM).gt.-100) then if (i.gt.IMAX) IMAX = i if (i.lt.IMIN) IMIN = i if (j.gt.JMAX) JMAX = j if (j.lt.JMIN) JMIN = j endif enddo enddo write(*,'(i4,1x,2i6,1x,2i6)') NIM, IMIN, IMAX, JMIN, JMAX enddo do NIT = NITi, NITf if (NIT.ge.2) then ! determine sky offset for each observation do NIM = 1, NIMs NDs = 0 do j = 0001,DETDIMY do i = 0001,DETDIMX pixe(i,j) = -100.0 pixr(i,j) = -100.0 xx = i yy = j call xryr2xcyc_stdgc(xx,yy,xi,yi,FILE_STDGDC) xc = Xo(NIM) + GA(NIM)*(xi-Wo(NIM)) . + GB(NIM)*(yi-Zo(NIM)) yc = Yo(NIM) + GC(NIM)*(xi-Wo(NIM)) . + GD(NIM)*(yi-Zo(NIM)) xref = (RESCALE)*(xc-XMo) yref = (RESCALE)*(yc-YMo) ii = int(xref+0.5) jj = int(yref+0.5) if (ii.ge.1.and.ii.le.PIXDIMX.and. . jj.ge.1.and.jj.le.PIXDIMY) then pixe(i,j) = pixc_v(ii,jj) if (pixe(i,j).lt.250.and. . pixe(i,j).gt.LOFLAG_USE.and. . pixc_n(ii,jj).gt.2) then NDs = NDs + 1 if (NDs.gt.DETDIMX*DETDIMY) . stop 'NDs.gt.DETDIMX*DETDIMY' dlist(NDs) = pixnima(i,j,NIM)-pixe(i,j) pixr(i,j) = pixnima(i,j,NIM) endif endif enddo enddo call barsigg(dlist,NDs,dbar,dsig,NDu) do j = 0001, DETDIMY do i = 0001, DETDIMX pixnima(i,j,NIM) = pixnima(i,j,NIM)-dbar enddo enddo if (DOBLOT) then STRING80 = FILENAME_NIM(NIM) j = 0 do i = 1, 75 if (STRING80(i:i+3).eq.'_flt') j = i if (STRING80(i:i+3).eq.'_flc') j = i enddo if (j.eq.0) . stop 'tried to blot: no _flt/_flc in filename' STRING80(j:j+3) = '_blt' call writfits_r4(STRING80,pixe,DETDIMX,DETDIMY) endif if (DOBLOTX) then STRING80 = FILENAME_NIM(NIM) j = 0 do i = 1, 75 if (STRING80(i:i+3).eq.'_flt') j = i if (STRING80(i:i+3).eq.'_flc') j = i enddo if (j.eq.0) . stop 'tried to blotx: no _flt/_flc in filename' STRING80(j:j+3) = '_dlt' do j = 0001, DETDIMY do i = 0001, DETDIMX pixe(i,j) = pixnima(i,j,NIM)-pixe(i,j) enddo enddo call writfits_r4(STRING80,pixe,DETDIMX,DETDIMY) endif write( *,213) NIM,DBAR,DSIG,NDs,NDu,100.*NDu/NDs, . FILENAME_NIM(NIM)(1:40) write(66,213) NIM,DBAR,DSIG,NDs,NDu,100.*NDu/NDs, . FILENAME_NIM(NIM)(1:40) 213 format(i3.3,1x,2f9.2,2x,i9,1x,i9,1x,f8.4,1x,40a) enddo!NIM call flush(66) endif! not first iteration, do sky norm c----------------------------------- c c initialize the output image to zeros c print*,'INITIALIZE... pixo, pixp...' do i = 0001, PIXDIMX do j = 0001, PIXDIMY pixc_v(i,j) = 0.00 pixi_v(i,j) = 0.00 pixc_n(i,j) = 0 pixi_n(i,j) = 0 enddo enddo print*,' ' print*,'GO THROUGH PIX BY PIX ',PIXDIMY, PIXDIMX print*,' ' do J = 0001, PIXDIMY do I = 0001, PIXDIMX c do J = max( 0001 ,int(YM_MINu+0.5)), c . min(PIXDIMX,int(YM_MAXu+0.5)) c do I = max( 0001 ,int(XM_MINu+0.5)), c . min(PIXDIMX,int(XM_MAXu+0.5)) xref = i/RESCALE + XMo yref = j/RESCALE + YMo NCs = 0 NIs = 0 do NIM = 1, NIMs xc = Wo(NIM) + AG(NIM)*(xref-Xo(NIM)) . + BG(NIM)*(yref-Yo(NIM)) yc = Zo(NIM) + CG(NIM)*(xref-Xo(NIM)) . + DG(NIM)*(yref-Yo(NIM)) call xcyc2xryr_stdgc(xc,yc,xr,yr,FILE_STDGDC) ir = int(xr+0.5) ! pixel location in image # NIM jr = int(yr+0.5) ! (I don't do any interpolation here) if (ir.ge.0001+1.and.ir.le.DETDIMX-1.and. . jr.ge.0001+1.and.jr.le.DETDIMY-1) then xx = ir yy = jr call xryr2xcyc_stdgc(xx,yy,xi,yi,FILE_STDGDC) xmap = Xo(NIM) + GA(NIM)*(xi-Wo(NIM)) . + GB(NIM)*(yi-Zo(NIM)) ymap = Yo(NIM) + GC(NIM)*(xi-Wo(NIM)) . + GD(NIM)*(yi-Zo(NIM)) if (pixnima(ir,jr,NIM).gt.LOFLAG_USE) then NCs = NCs + 1 vc_list(NCs) = pixnima(ir,jr,NIM) if (abs(xmap-xref).le.0.50/RESCALE.and. . abs(ymap-yref).le.0.50/RESCALE) then NIs = NIs + 1 vi_list(NIs) = pixnima(ir,jr,NIM) endif endif endif enddo NIu = 0 call dbubble(vi_list,NIs) call barsig_sns(vi_list,NIs,vi_bar,vi_sig,NIu) NCu = 0 call dbubble(vc_list,NCs) call barsig_sns(vc_list,NCs,vc_bar,vc_sig,NCu) bar = vc_bar sig = vc_sig FIX = ' ' if (NCs.ne.NCu) FIX = '***' if (i.eq.(PIXDIMX)/2.and.(j.eq.j/1*1)) then write( *,111) xref,yref,i,j, . int(i/RESCALE+XOFF_META), . int(j/RESCALE+YOFF_META), . NCu,NCs,bar,sig, . FIX,(int(vc_list(n)),n=1,min(NCs,25)) if (NCs.gt.25) . write( *,112) (int(vc_list(n)),n=26,min(NCs,50)) if (NCs.gt.050) . write( *,112) (int(vc_list(n)),n=51,min(NCs,075)) if (NCs.gt.075) . write( *,112) (int(vc_list(n)),n=51,min(NCs,100)) if (NCs.gt.100) . write( *,112) (int(vc_list(n)),n=51,min(NCs,125)) if (NCs.gt.125) . write( *,112) (int(vc_list(n)),n=51,min(NCs,150)) if (NCs.gt.150) . write( *,112) (int(vc_list(n)),n=51,min(NCs,175)) if (NCs.gt.175) . write( *,112) (int(vc_list(n)),n=51,min(NCs,200)) if (NCs.gt.200) . write( *,112) (int(vc_list(n)),n=51,min(NCs,225)) if (NCs.gt.225) . write( *,112) (int(vc_list(n)),n=51,min(NCs,250)) endif 111 format(f8.2,1x,f8.2,1x,i5.5,1x,i5.5,1x, . 1x,i5.5,1x,i5.5, . i3,1x,i3,1x,f9.3,1x,f8.3,1x,a3,5x,50i6) 112 format(8x,1x,8x,1x,5x,1x,5x,1x, . 1x,5x,1x,5x, . 3x,1x,3x,1x,9x,1x,8x,1x,3x,5x,50i6) pixc_v(i,j) = vc_bar pixc_n(i,j) = NCu pixi_v(i,j) = vi_bar pixi_n(i,j) = NIu if (NIs.lt.1.or.NIu.lt.1) then pixi_v(i,j) = vc_bar endif 137 continue enddo enddo c--------------------------------------------- c c output the final mosaicked image c write(NITSTRING5,'(''NIT'',i2.2)') NIT FILEOUT = LABEL40(1:nLAB) // '_STK_COREL' . // '_' // NITSTRING5 . // '.fits' write(* ,*) 'FILEOUT: ',FILEOUT(1:40) write(66,*) 'FILEOUT: ',FILEOUT(1:40) flush(66) print*,'OUTPUT WCSLTV --- ' print*,' CD1_1 : ',CD1_1 print*,' CD1_1u: ',CD1_1u call writfits_r4_WCSLTV(FILEOUT,pixc_v,PIXDIMX,PIXDIMY, . CRPIX1u,CRPIX2u,CRVAL1u,CRVAL2u, . CD1_1u, CD1_2u, CD2_1u, CD2_2u, . LTV1, LTV2, . LTM1_1,LTM1_2,LTM2_1,LTM2_2) if (OUTPUT(1:6).eq.'SIMPLE') goto 339 if (DOSLIM) goto 339 FILEOUT = LABEL40(1:nLAB) // '_STK_INDEP' . // '_' // NITSTRING5 . // '.fits' call writfits_r4_WCSLTV(FILEOUT,pixi_v,PIXDIMX,PIXDIMY, . CRPIX1u,CRPIX2u,CRVAL1u,CRVAL2u, . CD1_1u, CD1_2u, CD2_1u, CD2_2u, . LTV1, LTV2, . LTM1_1,LTM1_2,LTM2_1,LTM2_2) if (NIMs.gt.125) then FILEOUT = LABEL40(1:nLAB) // '_NUM_COREL' . // '_' // NITSTRING5 . // '.fits' call writfits_i2(FILEOUT,pixc_n,PIXDIMX,PIXDIMY) FILEOUT = LABEL40(1:nLAB) // '_NUM_INDEP' . // '_' // NITSTRING5 . // '.fits' call writfits_i2(FILEOUT,pixi_n,PIXDIMX,PIXDIMY) else allocate(pixb(PIXDIMX,PIXDIMY)) print*,'copy...' do i = 0001, PIXDIMX do j = 0001, PIXDIMY pixb(i,j) = pixc_n(i,j) enddo enddo FILEOUT = LABEL40(1:nLAB) // '_NUM_COREL' . // '_' // NITSTRING5 . // '.fits' call writfits_b1(FILEOUT,pixb,PIXDIMX,PIXDIMY) do i = 0001, PIXDIMX do j = 0001, PIXDIMY pixb(i,j) = pixi_n(i,j) enddo enddo FILEOUT = LABEL40(1:nLAB) // '_NUM_INDEP' . // '_' // NITSTRING5 . // '.fits' call writfits_b1(FILEOUT,pixb,PIXDIMX,PIXDIMY) deallocate(pixb) endif 339 continue enddo!NIT deallocate(pixr) deallocate(pixe) deallocate(pixnima) deallocate(dlist) deallocate(pixc_v) deallocate(pixi_v) deallocate(pixc_n) deallocate(pixi_n) print*,'LOOPu: ',LOOPu print*,'LOOPs: ',LOOPs if (LOOPu.lt.LOOPs) then LOOPu = LOOPu + 1 LOOPx = LOOPu write(66,*) 'NEW LOOP: LOOPu = ',LOOPu,' / ',LOOPs goto 888 endif call flush(66) STOP END c-------------------------------------------- c c bubble sort a real*8 into ascending order c subroutine dbubble(r1,NTOT) implicit none real*8 r1(1) integer NTOT integer n real*8 temp logical change 777 continue change = .false. do n = 1, NTOT-1 if (r1(n).gt.r1(n+1)) then temp = r1(n) r1(n) = r1(n+1) r1(n+1) = temp change = .true. endif enddo if (change) goto 777 end c----------------------------------------- c c real function rclip(rval,rlo,rhi) implicit none real rval real rlo real rhi rclip = rval if (rclip.gt.rhi) rclip = rhi if (rclip.lt.rlo) rclip = rlo if (.not.(rclip.lt.rhi).and. . .not.(rclip.gt.rlo)) rclip = rhi return end c----------------------------------------- c c this routine does a least squares solution (with no c data rejection or weighting) for the 6-param linear c fit for: c c c x2 = A*(x1-x1o) + B*(y1-y1o) + x2o c y2 = C*(x1-x1o) + D*(y1-y1o) + y2o c c it may look like there are 8 params, but two of the c offsets are arbitrary and are just set to the centroid c of the distribution. c subroutine glob_fit6nrDP(x1,y1,x2,y2,NUSE, . A,B,C,D,x1o,y1o,x2o,y2o) implicit none real*8 x1(1), y1(1) real*8 x2(1), y2(1) integer NUSE real*8 A, B, C, D real*8 x1o, y1o, x2o, y2o real*8 sxx, sx, swx, szx real*8 syy, sy, swy, szy real*8 sw, sz, sxy real*8 dlta real*8 dsxx, dsyy, dsxy real*8 dswx, dswy, dszx, dszy integer n if (NUSE.lt.3) goto 999 x1o = 0 y1o = 0 x2o = 0 y2o = 0 do n = 1, NUSE x1o = x1o + x1(n) y1o = y1o + y1(n) x2o = x2o + x2(n) y2o = y2o + y2(n) enddo x1o = x1o/NUSE y1o = y1o/NUSE x2o = x2o/NUSE y2o = y2o/NUSE sxx = 0.0 sx = 0.0 syy = 0.0 sy = 0.0 swx = 0.0 swy = 0.0 szx = 0.0 szy = 0.0 sw = 0.0 sz = 0.0 sxy = 0.0 do n = 1, NUSE sxy = sxy + (x1(n)-x1o)*(y1(n)-y1o) sxx = sxx + (x1(n)-x1o)*(x1(n)-x1o) sx = sx + (x1(n)-x1o) syy = syy + (y1(n)-y1o)*(y1(n)-y1o) sy = sy + (y1(n)-y1o) swx = swx + (x2(n)-x2o)*(x1(n)-x1o) swy = swy + (x2(n)-x2o)*(y1(n)-y1o) sw = sw + (x2(n)-x2o) szx = szx + (y2(n)-y2o)*(x1(n)-x1o) szy = szy + (y2(n)-y2o)*(y1(n)-y1o) sz = sz + (y2(n)-y2o) enddo dsxx = sx*sx - NUSE*sxx dsyy = sy*sy - NUSE*syy dsxy = sx*sy - NUSE*sxy dlta = dsxx*dsyy - dsxy*dsxy if (dlta.eq.0) goto 999 dswx = sw*sx - NUSE*swx dswy = sw*sy - NUSE*swy dszx = sz*sx - NUSE*szx dszy = sz*sy - NUSE*szy A = (dswx*dsyy-dswy*dsxy)/dlta B = (dswy*dsxx-dswx*dsxy)/dlta C = (dszx*dsyy-dszy*dsxy)/dlta D = (dszy*dsxx-dszx*dsxy)/dlta c print*,'x1o: ',x1o,y1o c print*,'x2o: ',x2o,y2o return 999 continue A = 1 B = 0 C = 0 D = 1 x1o = 0 y1o = 0 x2o = 0 y2o = 0 return end c--------------------------------------------------- c c this is the routine that takes in several estimates c of the pixel value and computes *some* kind of c sigma clipped average for them. c subroutine barsigg(xlist,NTOT,bar,sig,NUSE) implicit none integer NTOT real xlist(NTOT) real bar real sig integer NUSE integer n real*8 bsum, ssum integer nsum integer NIT NUSE = NTOT bar = 0.e0 sig = 9e9 do NIT = 01, 50 bsum = 0. ssum = 0. nsum = 0. do n = 1, NTOT if (abs(xlist(n)-bar).le.2.50*sig) then bsum = bsum + xlist(n) ssum = ssum + abs(xlist(n)-bar) nsum = nsum + 1 endif enddo if (nsum.gt.0) bar = bsum/ nsum if (nsum.gt.1) sig = ssum/(nsum-1) enddo NUSE = nsum if (nsum.le.1) sig = 0.999 return end c--------------------------------------------------- c c this is the routine that takes in several estimates c of the pixel value and computes *some* kind of c sigma clipped average for them. c subroutine rbarsigs(xlist,NTOT,bar,sig,NUSE,SIGU) implicit none integer NTOT real*8 xlist(NTOT) real*8 bar real*8 sig integer NUSE real SIGU integer n real*8 bsum, ssum integer nsum integer NIT integer nn integer nmin real*8 xmin, x bar = 0.e0 sig = 9e9 if (NTOT.ge.7) then call dbubble(xlist,NTOT) nn = 1 + NTOT*2/3 nmin = 1 xmin = xlist(nmin+nn)-xlist(nmin) do n = 2, NTOT-nn x = xlist(n+nn)-xlist(n) if (x.lt.xmin) then xmin = x nmin = n endif enddo sig = xmin/2 bsum = 0. do n = nmin, nmin+nn bsum = bsum + xlist(n) enddo bar = bsum / (1+nn) endif do NIT = 01, 12 bsum = 0. ssum = 0. nsum = 0. do n = 1, NTOT if (abs(xlist(n)-bar).le.SIGU*sig) then bsum = bsum + xlist(n) ssum = ssum + abs(xlist(n)-bar) nsum = nsum + 1 endif enddo if (nsum.gt.0) bar = bsum/ nsum if (nsum.gt.1) sig = ssum/(nsum-1) enddo NUSE = nsum if (nsum.le.1) sig = 0.999 return end real function root(n,list,NTOT) implicit none real n integer list(1) integer NTOT integer nl do nl = 1, NTOT-2 if (n.lt.list(nl+1)) goto 3 enddo 3 continue root = nl if (list(nl).ne.list(nl+1)) . root = nl + 1.*(n-list(nl))/(list(nl+1)-list(nl)) return end c----------------------------------------- c c real*8 function dclip(dval,rlo,rhi) implicit none real*8 dval real rlo real rhi dclip = dval if (dclip.gt.rhi) dclip = rhi if (dclip.lt.rlo) dclip = rlo if (.not.(dclip.lt.rhi).and. . .not.(dclip.gt.rlo)) dclip = rhi return end c--------------------------------------------------- c c find the most common value within a region of an c image; this just finds the value below which 10% c of the pixels land. c real function histmode_r4(i1,i2,j1,j2,pixarr) implicit none integer i1,i2,j1,j2 real pixarr(4096,4096) integer i, j, h integer mhi, mlo real hist_summ integer htot integer hist(500) integer hcum(500) real tmin integer hmin, hh integer dmin integer dcum integer cmin integer ntot real ptot do h = 1,500 hist(h) = 0 hcum(h) = 0 enddo htot = 0 do i = i1,i2 do j = j1,j2 if (i.lt.0001) goto 2 if (j.lt.0001) goto 2 if (i.gt.4096) goto 2 if (j.gt.4096) goto 2 if (pixarr(i,j).ge.10000) goto 2 if (pixarr(i,j).le.-0900) goto 2 h = pixarr(i,j)+100 if (h.lt. 1) goto 2 if (h.gt.500) goto 2 hist(h) = hist(h) + 1 htot = htot + 1 2 continue enddo enddo histmode_r4 = 0 hcum(1) = hist(1) do h = 2, 500 hcum(h) = hcum(h-1) + hist(h) if (hcum(h).lt.0.1*htot) histmode_r4 = h-100 enddo hmin = 1 dmin = 499 do h = 1, 350 do hh = h+1,500 dcum = hcum(hh)-hcum(h) if (dcum.gt.htot*0.33) goto 3 enddo 3 continue if (hh-h.lt.dmin.or. . hh-h.eq.dmin.and. . (dcum.gt.cmin)) then dmin = hh-h hmin = h cmin = dcum c print*,'---> h: ',h,dmin,cmin endif enddo ptot = 0. ntot = 0 do h = hmin-1-dmin/3,hmin+dmin+dmin/3+1 ptot = ptot + hist(h)*(h-100) ntot = ntot + hist(h) c write(*,'(i4,1x,i8)') h-100,hist(h) enddo histmode_r4 = ptot/ntot return end c----------------------------------------------------- c c barsig for small number statistics... N<=6 c c subroutine barsig_sns(xlist,NTOTT,bar,sig,NUSE) implicit none integer NTOTT real*8 xlist(99) real*8 bar real*8 sig integer NUSE integer NTOT integer n real bar1, sig1 real bar2, sig2 real bar3, sig3 real*8 slist(99) NTOT = NTOTT if (NTOT.gt.10) then call rbarsigs(xlist,NTOTT,bar,sig,NUSE,3.25) return endif if (NTOT.eq.0) then bar = 0. sig = 0. NUSE = 0 return endif do n = 1, NTOT slist(n) = xlist(n) enddo NTOT = NTOTT 777 continue call dbubble(slist,NTOT) if (NTOT.eq.10) then bar1 = (slist(1)+slist(2)+slist(3)+slist(4) . +slist(5)+slist(6)+slist(7)+slist(8))/8 sig1 = (slist(7)-slist(2))/2.5 bar2 = (slist(2)+slist(3)+slist(4)+slist(5) . +slist(6)+slist(7)+slist(8)+slist(9))/8 sig2 = (slist(8)-slist(3))/2.5 bar = bar1 sig = sig1 if (sig2.lt.sig1) then bar = bar2 sig = sig2 endif if (sig.lt.0.10*abs(bar)) sig = 0.10*abs(bar) if (slist(10).gt.bar+3*sig) then NTOT = 9 goto 777 endif if (slist(01).lt.bar-3*sig) then NTOT = 9 slist(1) = slist(2) slist(2) = slist(3) slist(3) = slist(4) slist(4) = slist(5) slist(5) = slist(6) slist(6) = slist(7) slist(7) = slist(8) slist(8) = slist(9) slist(9) = slist(10) goto 777 endif bar = (slist(1)+slist(2)+slist(3)+slist(4) . +slist(5)+slist(6)+slist(7)+slist(8) . +slist(9)+slist(10))/10 sig = (abs(slist(01)-bar) . +abs(slist(02)-bar) . +abs(slist(03)-bar) . +abs(slist(04)-bar) . +abs(slist(05)-bar) . +abs(slist(06)-bar) . +abs(slist(07)-bar) . +abs(slist(08)-bar) . +abs(slist(09)-bar) . +abs(slist(10)-bar))/9 NUSE = 10 goto 666 endif if (NTOT.eq.9) then bar1 = (slist(1)+slist(2)+slist(3)+slist(4) . +slist(5)+slist(6)+slist(7))/7 sig1 = (slist(7)-slist(2))/3.0 bar2 = (slist(2)+slist(3)+slist(4)+slist(5) . +slist(6)+slist(7)+slist(8))/7 sig2 = (slist(8)-slist(3))/3.0 bar = bar1 sig = sig1 if (sig2.lt.sig1) then bar = bar2 sig = sig2 endif if (sig.lt.0.10*abs(bar)) sig = 0.10*abs(bar) if (slist(9).gt.bar+3*sig) then NTOT = 8 goto 777 endif if (slist(1).lt.bar-3*sig) then NTOT = 8 slist(1) = slist(2) slist(2) = slist(3) slist(3) = slist(4) slist(4) = slist(5) slist(5) = slist(6) slist(6) = slist(7) slist(7) = slist(8) slist(8) = slist(9) goto 777 endif bar = (slist(1)+slist(2)+slist(3)+slist(4) . +slist(5)+slist(6)+slist(7)+slist(8)+slist(9))/9 sig = (abs(slist(1)-bar) . +abs(slist(2)-bar) . +abs(slist(3)-bar) . +abs(slist(4)-bar) . +abs(slist(5)-bar) . +abs(slist(6)-bar) . +abs(slist(7)-bar) . +abs(slist(8)-bar) . +abs(slist(9)-bar))/8 NUSE = 9 goto 666 endif if (NTOT.eq.8) then bar1 = (slist(1)+slist(2)+slist(3)+slist(4)+slist(5))/4 sig1 = (slist(6)-slist(2))/3.0 bar2 = (slist(2)+slist(3)+slist(4)+slist(5)+slist(6))/4 sig2 = (slist(7)-slist(3))/3.0 bar = bar1 sig = sig1 if (sig2.lt.sig1) then bar = bar2 sig = sig2 endif if (sig.lt.0.10*abs(bar)) sig = 0.10*abs(bar) if (slist(8).gt.bar+3*sig) then NTOT = 7 goto 777 endif if (slist(1).lt.bar-3*sig) then NTOT = 7 slist(1) = slist(2) slist(2) = slist(3) slist(3) = slist(4) slist(4) = slist(5) slist(5) = slist(6) slist(6) = slist(7) slist(7) = slist(8) goto 777 endif bar = (slist(1)+slist(2)+slist(3)+slist(4) . +slist(5)+slist(6)+slist(7)+slist(8))/8 sig = (abs(slist(1)-bar) . +abs(slist(2)-bar) . +abs(slist(3)-bar) . +abs(slist(4)-bar) . +abs(slist(5)-bar) . +abs(slist(6)-bar) . +abs(slist(7)-bar) . +abs(slist(8)-bar))/7 NUSE = 8 goto 666 endif if (NTOT.eq.7) then bar1 = (slist(1)+slist(2)+slist(3)+slist(4))/4 sig1 = (slist(5)-slist(1))/3.0 bar2 = (slist(2)+slist(3)+slist(4)+slist(5))/4 sig2 = (slist(6)-slist(2))/3.0 bar = bar1 sig = sig1 if (sig2.lt.sig1) then bar = bar2 sig = sig2 endif if (sig.lt.0.10*abs(bar)) sig = 0.10*abs(bar) if (slist(7).gt.bar+3*sig) then NTOT = 6 goto 777 endif if (slist(1).lt.bar-3*sig) then NTOT = 6 slist(1) = slist(2) slist(2) = slist(3) slist(3) = slist(4) slist(4) = slist(5) slist(5) = slist(6) slist(6) = slist(7) goto 777 endif bar = (slist(1)+slist(2)+slist(3)+ . slist(4)+slist(5)+slist(6)+slist(7))/7 sig = (abs(slist(1)-bar) . +abs(slist(2)-bar) . +abs(slist(3)-bar) . +abs(slist(4)-bar) . +abs(slist(5)-bar) . +abs(slist(6)-bar) . +abs(slist(7)-bar))/6 NUSE = 7 goto 666 endif if (NTOT.eq.6) then bar1 = (slist(1)+slist(2)+slist(3)+slist(4))/4 sig1 = (slist(4)-slist(1))/2.5 bar2 = (slist(2)+slist(3)+slist(4)+slist(5))/4 sig2 = (slist(5)-slist(2))/2.5 bar = bar1 sig = sig1 if (sig2.lt.sig1) then bar = bar2 sig = sig2 endif if (sig.lt.4) sig = 4.0 if (sig.lt.0.10*abs(bar)) sig = 0.10*abs(bar) if (slist(6).gt.bar+3*sig) then NTOT = 5 goto 777 endif if (slist(1).lt.bar-3*sig) then NTOT = 5 slist(1) = slist(2) slist(2) = slist(3) slist(3) = slist(4) slist(4) = slist(5) slist(5) = slist(6) goto 777 endif bar = (slist(1)+slist(2)+slist(3)+ . slist(4)+slist(5)+slist(6))/6 sig = (abs(slist(1)-bar) . +abs(slist(2)-bar) . +abs(slist(3)-bar) . +abs(slist(4)-bar) . +abs(slist(5)-bar) . +abs(slist(6)-bar))/5 NUSE = 6 goto 666 endif if (NTOT.eq.5) then if (slist(3).gt.35000.and. . slist(2).lt.01000.and. . slist(1).lt.01000) then NTOT = 2 goto 777 endif bar1 = (slist(1)+slist(2)+slist(3)+slist(4))/4 sig1 = (slist(4)-slist(1))/2 bar2 = (slist(2)+slist(3)+slist(4)+slist(5))/4 sig2 = (slist(5)-slist(2))/2 bar3 = (slist(1)+slist(2)+slist(3))/3 sig3 = (slist(3)-slist(1))*1.5 bar = bar1 sig = sig1 if (sig2.lt.sig1) then bar = bar2 sig = sig2 endif if (sig3.lt.sig1) then bar = bar3 sig = sig3 endif if (sig.lt.0.10*abs(bar)) sig = 0.10*abs(bar) if (slist(5).gt.bar+3*sig) then NTOT = 4 goto 777 endif if (slist(1).lt.bar-3*sig) then NTOT = 4 slist(1) = slist(2) slist(2) = slist(3) slist(3) = slist(4) slist(4) = slist(5) goto 777 endif bar = (slist(1)+slist(2)+slist(3)+ . slist(4)+slist(5))/5 sig = (abs(slist(1)-bar) . +abs(slist(2)-bar) . +abs(slist(3)-bar) . +abs(slist(4)-bar) . +abs(slist(5)-bar))/4 NUSE = 5 goto 666 endif if (NTOT.eq.4) then if (slist(3).gt.35000.and. . slist(2).lt.01000.and. . slist(1).lt.01000) then NTOT = 2 goto 777 endif bar1 = (slist(1)+slist(2)+slist(3))/3 sig1 = (slist(3)-slist(1)) bar2 = (slist(2)+slist(3)+slist(4))/3 sig2 = (slist(4)-slist(2)) bar3 = (slist(1)+slist(2))/2 sig3 = (slist(2)-slist(1))*3 bar = bar1 sig = sig1 if (sig2.lt.sig1) then bar = bar2 sig = sig2 endif if (sig3.lt.sig1) then bar = bar3 sig = sig3 endif if (sig.lt.0.10*abs(bar)) sig = 0.10*abs(bar) if (slist(4).gt.bar+3*sig) then NTOT = 3 goto 777 endif if (slist(1).lt.bar-3*sig) then NTOT = 3 slist(1) = slist(2) slist(2) = slist(3) slist(3) = slist(4) goto 777 endif bar = (slist(1)+slist(2)+slist(3)+slist(4))/4 sig = (abs(slist(1)-bar) . +abs(slist(2)-bar) . +abs(slist(3)-bar) . +abs(slist(4)-bar))/3 NUSE = 4 goto 666 endif if (NTOT.eq.3) then bar1 = (slist(1)+slist(2))/2 sig1 = (slist(2)-slist(1)) bar2 = (slist(2)+slist(3))/2 sig2 = (slist(3)-slist(2)) bar = bar1 sig = sig1 if (sig2.lt.sig1) then bar = bar2 sig = sig2 endif if (sig.lt.0.10*abs(bar)) sig = 0.10*abs(bar) if (slist(3).gt.bar+3*sig) then NTOT = 2 goto 777 endif if (slist(1).lt.bar-3*sig) then NTOT = 2 slist(1) = slist(2) slist(2) = slist(3) goto 777 endif bar = (slist(1)+slist(2)+slist(3))/3 sig = (abs(slist(1)-bar) . +abs(slist(2)-bar) . +abs(slist(3)-bar))/2 NUSE = 3 goto 666 endif if (NTOT.eq.2) then bar = slist(1) sig = 4 if (sig.lt.0.10*abs(bar)) sig = 0.10*abs(bar) if (slist(2).gt.bar+5*sig) then NUSE = 1 bar = slist(1) sig = 999.9 goto 666 endif if (abs(slist(2)).lt.20.and.slist(1).lt.-50) then NUSE = 1 bar = slist(2) sig = 999.9 goto 666 endif bar = (slist(1)+slist(2))/2 sig = (slist(2)-slist(1))/2 NUSE = 2 goto 666 endif if (NTOT.eq.1) then bar = slist(1) sig = 999.9 NUSE = 1 goto 666 endif print*,' ' print*,'---> STOP...' print*,' ' print*,'---> SHOULD NOT BE HERE.' print*,' ' 666 continue return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/PARLOR/islinux.f" c**** c********************************************* c program q c implicit none c c logical islinux, islinux_var c c islinux_var = islinux() c c islinux_var = islinux() c c stop c end logical function islinux() implicit none logical islinux_save integer i data i/0/ data islinux_save/.true./ common /islinux_/i,islinux_save byte b(2) equivalence(i,b) if (i.eq.1) goto 1 i = 1 islinux_save = .false. if (b(1).eq.1) islinux_save = .true. 1 islinux = islinux_save return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/STRING/strlen.f" c**** c********************************************* integer function strlen(STRING) implicit none character*(*) STRING integer i i = 0 1 continue i = i + 1 if (STRING(i:i).eq.' ') then strlen = i-1 return endif goto 1 end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/query_hdr_r4.f" c**** c********************************************* c--------------------------------------------------- c c This routine checks to see if the header of an image c contains a particular keyword. If it does, it returns c its value-string in STREAMX. c subroutine query_hdr_r4(filename,FIELDX,r4) implicit none character*(*) filename character*8 field real r4 character*20 stream character*8 fieldx character*20 streamx integer i integer ios, k character*2880 buff integer nread c----------------------------------------------- !print*,'query_hdr...',FILENAME !print*,' fieldx: ',fieldx streamx = ' ' close(10) open(10,file=FILENAME,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') streamx = 'NULL' i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buff if (ios.lt.0) goto 900 do k = 0, 35, 1 field = buff(k*80+01:k*80+08) stream = buff(k*80+11:k*80+31) !print*,i,k,field,stream if (field.eq.fieldx) streamx = stream(1:20) if (field.eq.'END ') goto 101 109 continue enddo goto 100 101 continue close(10) !print*,' streamx: ',streamx if (streamx(1:4).eq.'NULL') then !print*,'query_hdr_r4: cannot find: ' !print*,' FILENAME: ',FILENAME !print*,' KEYWORDX: ',FIELDX !print*,' KEYWORD : ',FIELD r4 = 0.001 return endif read(streamx,*) r4 return 900 continue print*,' ' print*,'imginfo.e ERROR EXIT. ' print*,' ' print*,'ONE OF THE IMAGES WAS NOT IN STANDARD' print*,'HST FITS FORMAT.' print*,' ' write(*,'(''PROBLEM FILE: '',a80)') FILENAME print*,' ' stop end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_i4.f" c**** c********************************************* c-------------------------------------------------------- c c This routine reads in images stored in integer*4 format... c c to use: c c input parameters: c c FILE is the filename c NX,NY are the dimensions of the image to be c read in c c c output parameters: c c pix( , ) is an integer*4 image of dimensions NX,NY c c c subroutine readfits_i4(FILE,pix,NX,NY) implicit none integer NX, NY character*(*) FILE integer*4 pix(NX,NY) character*70 INFO(10) common / fitsinfo / INFO integer naxes integer laxis(3) character*8 field character*20 stream integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k integer ii, jj integer n character*2880 buffc byte buffb(2880) equivalence (buffb,buffc) integer*4 ibuff(720) integer ifirst, i1, i2 integer j integer np1, np2, npt integer nextend integer nread real*8 bscale, bzero integer bitpix logical LINUX data LINUX/.true./ logical DIAG data DIAG /.false./ character*70 HDR(25) common/HDR/HDR character*80 FILEU FILEU = 'NULL' do i = 1, 75 if (FILE(i:i+4).eq.'.fits') then FILEU = FILE(1:i+4) goto 1 endif enddo print*,' ' print*,'writfits_i4: no .fits ' print*,' FILE: ',FILE print*,' ' stop 1 continue if (DIAG) then print*,'enter readfits...' print*,'FILE: ',FILE(1:60) endif open(10,file=FILEU,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'...opened' bscale = 1 bzero = 0 naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 do i = 1, 10 INFO(i) = ' ' enddo do i = 1, 23 HDR(i) = ' ' enddo i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buffc if (DIAG) print*,'READREC: ',i do k = 0, 35, 1 if (DIAG) write(*,'(i4,1x,i4,1x,a80)') . i,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+31) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'EXPTIME ') INFO(01) = stream if (field.eq.'FILTNAM1') INFO(02) = stream if (field.eq.'FILENAME') INFO(03) = stream if (field.eq.'DATE-OBS') INFO(04) = stream if (field.eq.'TIME-OBS') INFO(05) = stream if (field.eq.'DEC_TARG') INFO(06) = stream if (field.eq.'RA_TARG ') INFO(07) = stream if (field.eq.'PA_V3 ') INFO(08) = stream if (field.eq.'PROPOSID') INFO(09) = stream if (field.eq.'CCDGAIN ') INFO(10) = stream if (field.eq.'CRPIX1 ') HDR(01) = stream if (field.eq.'CRPIX2 ') HDR(02) = stream if (field.eq.'CRVAL1 ') HDR(03) = stream if (field.eq.'CRVAL2 ') HDR(04) = stream if (field.eq.'CTYPE1 ') HDR(05) = stream if (field.eq.'CTYPE2 ') HDR(06) = stream if (field.eq.'CD1_1 ') HDR(07) = stream if (field.eq.'CD1_2 ') HDR(08) = stream if (field.eq.'CD2_1 ') HDR(09) = stream if (field.eq.'CD2_2 ') HDR(10) = stream if (field.eq.'ORIENTAT') HDR(11) = stream if (field.eq.'PA_APER ') HDR(12) = stream if (field.eq.'PA_V3 ') HDR(13) = stream if (field.eq.'DATE-OBS') HDR(14) = stream if (field.eq.'TIME-OBS') HDR(15) = stream if (field.eq.'EXPTIME ') HDR(16) = stream if (field.eq.'ROOTNAME') HDR(17) = stream if (field.eq.'TARGNAME') HDR(18) = stream if (field.eq.'RA_TARG ') HDR(19) = stream if (field.eq.'DEC_TARG') HDR(20) = stream if (field.eq.'PROPOSID') HDR(21) = stream if (field.eq.'FILTER1 ') HDR(22) = stream if (field.eq.'FILTER2 ') HDR(23) = stream if (field.eq.'VAFACTOR') HDR(24) = stream if (field.eq.'END ') goto 101 enddo goto 100 101 continue if (laxis(1).ne.NX.or.laxis(2).ne.NY) then print*,'FITS image not the expected dimensions: ' print*,' input NX: ',nx print*,' input NY: ',ny print*,' ' print*,' laxis(1): ',laxis(1) print*,' laxis(2): ',laxis(2) print*,' ' stop endif nread = nread + 1 if (DIAG) then print*,'----------------------------------------' print*,' NREAD: ',nread print*,'NEXTEND: ',nextend print*,' NAXIS: ',naxes print*,' LAXIS: ',laxis(1),laxis(2),laxis(3) print*,' BITPIX: ',bitpix print*,' BSCALE: ',bscale print*,' BZERO: ',bzero endif ifirst = i+1 i1 = i i2 = i if (BITPIX.ne.32) then print*,' ' print*,'readfits_i4...: ' print*,' ' print*,' you called a routine to read in a' print*,' long i*4 image, and the image you' print*,' gave it has BITPIX = ',BITPIX print*,' ' print*,' FILE: ',FILE print*,' ' stop endif nbper = 4*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 np2 = min(np2,npt) call buff2pix_i4(buffb,ibuff,0001,0720) do n = np1, np2, 1 jj = n/NX + 1 ii = n-NX*(jj-1) pix(ii,jj) = ibuff(n-np1+1)*bscale+bzero enddo enddo if (DIAG) then print*,' NBPER: ',nbper print*,' NBYT1: ',nbyte1 print*,' NBYT2: ',nbyte2 print*,' IFIRST: ',ifirst print*,' I1: ',i1 print*,' I2: ',i2 print*,' NPT: ',NPT endif return 900 continue print*,'READFITS_I4 ERROR' print*,' FILEU: ',FILEU stop end subroutine buff2pix_i4(buff,pix,n1,nt) implicit none byte buff(2880) integer*4 pix(*) integer n1,nt byte b(4) integer ii equivalence(ii,b) integer i, npu, nbu logical islinux do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (.not.(islinux())) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) b(3) = buff(nbu+3) b(4) = buff(nbu+4) else b(4) = buff(nbu+1) b(3) = buff(nbu+2) b(2) = buff(nbu+3) b(1) = buff(nbu+4) endif if (npu.ge.1.and.npu.le.nt) pix(npu) = ii enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_i2.f" c**** c********************************************* subroutine readfits_i2(FILE,pix,NX,NY) implicit none character*(*) FILE integer NX, NY integer*2 pix(NX,NY) character*70 INFO(10) common / fitsinfo / INFO integer naxes integer laxis(3) character*8 field character*20 stream integer*4 pixu integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k integer ii, jj integer n integer NXU, NYU character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer*2 ibuff(1440) integer ifirst, i1, i2 integer j integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix integer r2i logical DIAG data DIAG /.false./ character*70 HDR(25) common/HDR/HDR character*80 FILEU FILEU = FILE do i = 75,2,-1 if (FILE(i:i+4).eq.'.fits') FILEU = FILE(1:i+4) enddo c write(*,'(''ENTER readfits_i2: '',80a)') FILEU open(10,file=FILEU,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'...opened' bscale = 1 bzero = 0 naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 do i = 1, 10 INFO(i) = ' ' enddo do i = 1, 25 HDR(i) = ' ' enddo HDR(24) = ' 1.000 ' i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buffc if (DIAG) print*,'READREC: ',i do k = 0, 35, 1 if (DIAG) write(*,'(i4,1x,i4,1x,a80)') . i,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+31) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'EXPTIME ') INFO(01) = stream if (field.eq.'FILTNAM1') INFO(02) = stream if (field.eq.'FILENAME') INFO(03) = stream if (field.eq.'DATE-OBS') INFO(04) = stream if (field.eq.'TIME-OBS') INFO(05) = stream if (field.eq.'DEC_TARG') INFO(06) = stream if (field.eq.'RA_TARG ') INFO(07) = stream if (field.eq.'PA_V3 ') INFO(08) = stream if (field.eq.'PROPOSID') INFO(09) = stream if (field.eq.'CCDGAIN ') INFO(10) = stream if (field.eq.'CRPIX1 ') HDR(01) = stream if (field.eq.'CRPIX2 ') HDR(02) = stream if (field.eq.'CRVAL1 ') HDR(03) = stream if (field.eq.'CRVAL2 ') HDR(04) = stream if (field.eq.'CTYPE1 ') HDR(05) = stream if (field.eq.'CTYPE2 ') HDR(06) = stream if (field.eq.'CD1_1 ') HDR(07) = stream if (field.eq.'CD1_2 ') HDR(08) = stream if (field.eq.'CD2_1 ') HDR(09) = stream if (field.eq.'CD2_2 ') HDR(10) = stream if (field.eq.'ORIENTAT') HDR(11) = stream if (field.eq.'PA_APER ') HDR(12) = stream if (field.eq.'PA_V3 ') HDR(13) = stream if (field.eq.'DATE-OBS') HDR(14) = stream if (field.eq.'TIME-OBS') HDR(15) = stream if (field.eq.'EXPTIME ') HDR(16) = stream if (field.eq.'ROOTNAME') HDR(17) = stream if (field.eq.'TARGNAME') HDR(18) = stream if (field.eq.'RA_TARG ') HDR(19) = stream if (field.eq.'DEC_TARG') HDR(20) = stream if (field.eq.'PROPOSID') HDR(21) = stream if (field.eq.'FILTER1 ') HDR(22) = stream if (field.eq.'FILTER2 ') HDR(23) = stream if (field.eq.'VAFACTOR') HDR(24) = stream if (field.eq.'END ') goto 101 enddo goto 100 101 continue nread = nread + 1 if (DIAG) then print*,'----------------------------------------' print*,' NREAD: ',nread print*,'NEXTEND: ',nextend print*,' NAXIS: ',naxes print*,' LAXIS: ',laxis(1),laxis(2),laxis(3) print*,' BITPIX: ',bitpix print*,' BSCALE: ',bscale print*,' BZERO: ',bzero endif ifirst = i+1 i1 = i i2 = i if (BITPIX.ne.16) then print*,' ' print*,'readfits_i2: ' print*,' ' print*,' you called a routine to read in an' print*,' unsigned i2 image, and the image you' print*,' gave it has BITPIX = ',BITPIX print*,' ' print*,' FILEU: ',FILEU print*,' ' do ii = 1, NX do jj = 1, NY pix(ii,jj) = 0 enddo enddo print*,' ' stop endif nbper = 2*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 if (laxis(1).gt.NX.and.laxis(2).gt.NY) then print*,' not enough image space! ' print*,' ' print*,' laxis1: ',laxis(1) print*,' NX: ',NX print*,' ' print*,' laxis2: ',laxis(2) print*,' NY: ',NY print*,' ' stop endif NXU = laxis(1) NYU = laxis(2) if (DIAG) then print*,' NX: ',NX print*,' NY: ',NY print*,' NBPER: ',nbper print*,' NBYT1: ',nbyte1 print*,' NBYT2: ',nbyte2 print*,' IFIRST: ',ifirst print*,' I1: ',i1 print*,' I2: ',i2 print*,' NPT: ',NPT endif do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/2 + 1 np2 = (nbyteE-nbyte1)/2 + 1 np2 = min(np2,npt) call buff2pix_i2(buffb,ibuff,0001,1440) do n = np1, np2, 1 jj = n/NXU + 1 ii = n-NXU*(jj-1) pixu = ibuff(n-np1+1)*bscale+bzero if (pixu.gt.32768) pixu=pixu-65536 pix(ii,jj) = pixu enddo enddo if (DIAG) then print*,' NBPER: ',nbper print*,' NBYT1: ',nbyte1 print*,' NBYT2: ',nbyte2 print*,' IFIRST: ',ifirst print*,' I1: ',i1 print*,' I2: ',i2 print*,' NPT: ',NPT endif return 900 continue print*,'FILE = ',FILE print*,'READFITS_I2 ERROR' stop end c---------------------------------------------- c c c subroutine buff2pix_i2(buff,pix,n1,nt) implicit none byte buff(2880) integer*2 pix(*) integer n1,nt byte b(2) integer ii equivalence(ii,b) integer i, npu, nbu logical islinux do i = 1, 1440 npu = n1+i-1 nbu = (i-1)*2 if (.not.(islinux())) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) else b(2) = buff(nbu+1) b(1) = buff(nbu+2) endif if (npu.ge.1.and.npu.le.nt) pix(npu) = ii enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_b1.f" c**** c********************************************* subroutine readfits_b1(FILE,pix,NX,NY) implicit none character*(*) FILE integer NX, NY byte pix(NX,NY) character*70 INFO(10) common / fitsinfo / INFO integer naxes integer laxis(3) character*8 field character*20 stream integer*4 pixu integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k integer ii, jj integer n integer NXU, NYU character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) byte ibuff(2880) integer ifirst, i1, i2 integer j integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix integer r2i logical DIAG data DIAG /.false./ character*70 HDR(25) common/HDR/HDR character*80 FILEU FILEU = FILE do i = 75,2,-1 if (FILE(i:i+4).eq.'.fits') FILEU = FILE(1:i+4) enddo c write(*,'(''ENTER readfits_b1: '',80a)') FILEU c print*,' ----> NX,NY: ',NX,NY open(10,file=FILEU,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'...opened' bscale = 1 bzero = 0 naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 do i = 1, 10 INFO(i) = ' ' enddo do i = 1, 23 HDR(i) = ' ' enddo i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buffc if (DIAG) print*,'READREC: ',i do k = 0, 35, 1 if (DIAG) write(*,'(i4,1x,i4,1x,a80)') . i,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+31) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'EXPTIME ') INFO(01) = stream if (field.eq.'FILTNAM1') INFO(02) = stream if (field.eq.'FILENAME') INFO(03) = stream if (field.eq.'DATE-OBS') INFO(04) = stream if (field.eq.'TIME-OBS') INFO(05) = stream if (field.eq.'DEC_TARG') INFO(06) = stream if (field.eq.'RA_TARG ') INFO(07) = stream if (field.eq.'PA_V3 ') INFO(08) = stream if (field.eq.'PROPOSID') INFO(09) = stream if (field.eq.'CCDGAIN ') INFO(10) = stream if (field.eq.'CRPIX1 ') HDR(01) = stream if (field.eq.'CRPIX2 ') HDR(02) = stream if (field.eq.'CRVAL1 ') HDR(03) = stream if (field.eq.'CRVAL2 ') HDR(04) = stream if (field.eq.'CTYPE1 ') HDR(05) = stream if (field.eq.'CTYPE2 ') HDR(06) = stream if (field.eq.'CD1_1 ') HDR(07) = stream if (field.eq.'CD1_2 ') HDR(08) = stream if (field.eq.'CD2_1 ') HDR(09) = stream if (field.eq.'CD2_2 ') HDR(10) = stream if (field.eq.'ORIENTAT') HDR(11) = stream if (field.eq.'PA_APER ') HDR(12) = stream if (field.eq.'PA_V3 ') HDR(13) = stream if (field.eq.'DATE-OBS') HDR(14) = stream if (field.eq.'TIME-OBS') HDR(15) = stream if (field.eq.'EXPTIME ') HDR(16) = stream if (field.eq.'ROOTNAME') HDR(17) = stream if (field.eq.'TARGNAME') HDR(18) = stream if (field.eq.'RA_TARG ') HDR(19) = stream if (field.eq.'DEC_TARG') HDR(20) = stream if (field.eq.'PROPOSID') HDR(21) = stream if (field.eq.'FILTER1 ') HDR(22) = stream if (field.eq.'FILTER2 ') HDR(23) = stream if (field.eq.'END ') goto 101 enddo goto 100 101 continue nread = nread + 1 if (DIAG) then print*,'----------------------------------------' print*,' NREAD: ',nread print*,'NEXTEND: ',nextend print*,' NAXIS: ',naxes print*,' LAXIS: ',laxis(1),laxis(2),laxis(3) print*,' BITPIX: ',bitpix print*,' BSCALE: ',bscale print*,' BZERO: ',bzero endif ifirst = i+1 i1 = i i2 = i if (BITPIX.ne.08) then print*,'readfits_b1...: ' print*,' ' print*,' you called a routine to read in a' print*,' byte (b1) image, and the image you' print*,' gave it has BITPIX = ',BITPIX print*,' ' print*,' FILEU: ',FILEU print*,' ' stop endif nbper = laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 c print*,' ----> laxis(1): ',laxis(1) c print*,' ----> laxis(2): ',laxis(2) if (laxis(1).gt.NX.and.laxis(2).gt.NY) then print*,' not enough image space! ' print*,' ' print*,' laxis1: ',laxis(1) print*,' NX: ',NX print*,' ' print*,' laxis2: ',laxis(2) print*,' NY: ',NY print*,' ' stop endif NXU = laxis(1) NYU = laxis(2) if (DIAG) then print*,' NX: ',NX print*,' NY: ',NY print*,' NBPER: ',nbper print*,' NBYT1: ',nbyte1 print*,' NBYT2: ',nbyte2 print*,' IFIRST: ',ifirst print*,' I1: ',i1 print*,' I2: ',i2 print*,' NPT: ',NPT endif do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1) + 1 np2 = (nbyteE-nbyte1) + 1 np2 = min(np2,npt) do ii = 1, 2880 ibuff(ii) = buffb(ii) enddo 1119 format(1x,i8,1x,i10,1x,i10,1x,i10,1x,i4,1x,i4,1x, . 4f10.0) do n = np1, np2, 1 jj = n/NXU + 1 ii = n-NXU*(jj-1) pixu = ibuff(n-np1+1)*bscale+bzero if (ii.ge.1.and.ii.le.NX.and. . jj.ge.1.and.jj.le.NX) pix(ii,jj) = pixu enddo jj = np1/NXU + 1 ii = np1-NXU*(jj-1) enddo if (DIAG) then print*,' NBPER: ',nbper print*,' NBYT1: ',nbyte1 print*,' NBYT2: ',nbyte2 print*,' IFIRST: ',ifirst print*,' I1: ',i1 print*,' I2: ',i2 print*,' NPT: ',NPT endif c print*,'---> pix(4095,4231): ',pix(4095,4231) c print*,'---> pix(0001,0001): ',pix(0001,0001) return 900 continue print*,'FILEU: ',FILEU print*,'READFITS_B1 ERROR' stop end subroutine buff_b1_pix(pix,n1,nt) implicit none byte pix(1) integer n1,nt byte pbuff(2880) common /sneaky/pbuff integer i integer npu do i = 1, 2880, 1 npu = n1+i-1 !if (npu.ge.1.and.npu+1.le.nt) pix(npu+1) = pbuff(i ) !if (npu.ge.1.and.npu .le.nt) pix(npu ) = pbuff(i+1) if (npu.ge.1.and.npu .le.nt) pix(npu ) = pbuff(i) enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_r4e.f" c**** c********************************************* c----------------------------------------------------------------- c c reads an r4 fits image, with extensions (reads in one extension) c subroutine readfits_r4e(FILE,pix,NDIMX,NDIMY,NEXTENU) implicit none character*(*) FILE integer NDIMX,NDIMY real pix(NDIMX,NDIMY) integer NEXTENU character*200 FILEU character*70 INFO(10) common / fitsinfo / INFO integer naxes integer laxis(3) common/laxis3_/laxis integer NXF integer NYF character*8 field character*40 stream integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k c integer j character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer ifirst, i1, i2 integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix character*70 HDR(25) common/HDR/HDR logical DIAG data DIAG /.false./ integer NEND integer iend if (DIAG) then print*,'enter readfits_r4e...... ' print*,'FILEi: ',FILE(1:60) endif FILEU = FILE iend = 0 do i = 196,1,-1 if (DIAG) print*,i,iend,FILE(i:i+4) if (FILE(i:i+4).eq.'.fits') iend = i+4 enddo if (DIAG) then print*,'iend: ',iend endif if (iend.eq.0) then print*,'NO .fits in FILENAME' print*,'FILE: ',FILE stop endif FILEU = FILE(1:iend) if (DIAG) then print*,'purge...' print*,'FILEu: ',FILEU endif open(10,file=FILEU,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'...opened ',FILEU naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 do i = 1, 10 INFO(i) = ' ' enddo BSCALE = 1.0 BZERO = 0.0 NEND = 0 i = 0 nread = 0 100 continue i = i + 1 if (DIAG) print*,'READREC: ',i read(10,rec=i,iostat=ios) buffc do k = 0, 35, 1 if (DIAG) write(*,'(i4,1x,i4,1x,a80)') . i,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+51) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'EXPTIME ') INFO(1) = stream if (field.eq.'FILTER ') INFO(2) = stream if (field.eq.'FILTNAM1') INFO(2) = stream if (field.eq.'FILENAME') INFO(3) = stream if (field.eq.'DATE-OBS') INFO(4) = stream if (field.eq.'TIME-OBS') INFO(5) = stream if (field.eq.'DEC_TARG') INFO(6) = stream if (field.eq.'RA_TARG ') INFO(7) = stream if (field.eq.'PA_V3 ') INFO(8) = stream if (field.eq.'PROPOSID') INFO(9) = stream if (field.eq.'CRPIX1 ') HDR(01) = stream if (field.eq.'CRPIX2 ') HDR(02) = stream if (field.eq.'CRVAL1 ') HDR(03) = stream if (field.eq.'CRVAL2 ') HDR(04) = stream if (field.eq.'CTYPE1 ') HDR(05) = stream if (field.eq.'CTYPE2 ') HDR(06) = stream if (field.eq.'CD1_1 ') HDR(07) = stream if (field.eq.'CD1_2 ') HDR(08) = stream if (field.eq.'CD2_1 ') HDR(09) = stream if (field.eq.'CD2_2 ') HDR(10) = stream if (field.eq.'ORIENTAT') HDR(11) = stream if (field.eq.'PA_APER ') HDR(12) = stream if (field.eq.'PA_V3 ') HDR(13) = stream if (field.eq.'DATE-OBS') HDR(14) = stream if (field.eq.'TIME-OBS') HDR(15) = stream if (field.eq.'EXPTIME ') HDR(16) = stream if (field.eq.'ROOTNAME') HDR(17) = stream if (field.eq.'TARGNAME') HDR(18) = stream if (field.eq.'RA_TARG ') HDR(19) = stream if (field.eq.'DEC_TARG') HDR(20) = stream if (field.eq.'PROPOSID') HDR(21) = stream if (field.eq.'FILTER ') HDR(22) = stream if (field.eq.'FILTER1 ') HDR(22) = stream if (field.eq.'FILTER2 ') HDR(23) = stream if (field.eq.'VAFACTOR') HDR(24) = stream if (field.eq.'END ') then !print*,' ---> NEND: ',NEND,NEXTENU if (NEND.eq.NEXTENU) goto 101 NEND = NEND + 1 endif enddo goto 100 101 continue nread = nread + 1 if (DIAG) then print*,' ' print*,'----------------------------------------' print*,' NREAD: ',nread print*,'NEXTEND: ',nextend print*,' NAXIS: ',naxes print*,' LAXIS: ',laxis(1),laxis(2),laxis(3) print*,' BITPIX: ',bitpix print*,' BSCALE: ',bscale print*,' BZERO: ',bzero print*,' NDIMX: ',NDIMX print*,' NDIMY: ',NDIMY print*,' ' endif ifirst = i+1 i1 = i i2 = i NXF = laxis(1) NYF = laxis(2) nbper = 4*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 if (BITPIX.eq.-64) then print*,'from readfits_r4e... ' print*,' BITPIX: ',BITPIX print*,'call readfits_r8e... ' print*,' ' call readfits_r8e_r4(FILE,pix,NDIMX,NDIMY,NEXTENU) return endif if (BITPIX.ne.-32) then print*,'readfits_r4e...' print*,'BITPIX: ',BITPIX print*,'prob' stop endif do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 c call buff2pix_r4(buffb,pix,np1,npt) call buff2pix_r4_edge(buffb,pix,np1,npt, . NDIMX,NDIMY,laxis(1),laxis(2)) if (DIAG) write(*,1115) i,np1,np2,npt 1115 format(1x,i8,1x,i10,1x,i10,1x,i10) enddo close(10) if (DIAG) print*,'...closed ',FILEU return 900 continue print*,' ' print*,'readfits_r4e ERROR' write(*,'(''NEXTU: '',i4 )') NEXTENU write(*,'(''FILEI: '',a200)') FILE write(*,'('' IEND: '',i4 )') IEND write(*,'(''FILEU: '',a200)') FILEU print*,' ' stop end c------------------------------------------------------ c c subroutine buff2pix_r4_edge(buff,pix,n1,nt, . NXP,NYP,NXF,NYF) implicit none c character buff(2880) byte buff(2880) integer NXP,NYP real pix(NXP,NYP) integer n1,nt integer NXF,NYF real pbuff(720) common /sneaky/pbuff integer i integer npu, nbu integer NX, NY byte b(4) real r equivalence(r,b) logical islinux if (NYF.eq.0) continue ! just to "use" the argument do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (npu.ge.1.and.npu.le.nt) then NX = npu - (npu-1)/NXF*NXF NY = 1 + (npu-1)/NXF if (NX.le.NXP.and.NY.le.NYP) then if (.not.islinux()) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) b(3) = buff(nbu+3) b(4) = buff(nbu+4) endif if (islinux()) then b(4) = buff(nbu+1) b(3) = buff(nbu+2) b(2) = buff(nbu+3) b(1) = buff(nbu+4) endif if (npu.ge.1.and.npu.le.nt) pix(NX,NY) = r endif endif enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_i2e.f" c**** c********************************************* c----------------------------------------------------------- c c read in an i2 image with extensions c subroutine readfits_i2e(FILEI,pix,NDIMX,NDIMY,NEXTENU) implicit none character*(*) FILEI integer NDIMX,NDIMY integer NEXTENU integer*2 pix(NDIMX,NDIMY) character*199 FILEU character*070 INFO(10) c common / fitsinfo / INFO integer naxes integer laxis(3) integer NXF integer NYF character*8 field character*40 stream integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k c integer j character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer ifirst, i1, i2 integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix character*70 HDR(25) c common/HDR/HDR logical DIAG data DIAG /.false./ integer NEND integer ii, jj FILEU = FILEI do i = 195,2,-1 if (FILEI(i:i+4).eq.'.fits') then FILEU = FILEI(1:i+4) do ii = i+5, 80 FILEU(ii:ii) = ' ' enddo endif enddo if (DIAG) then print*,'enter readfits_i2e...' write(*,'(''FILEI: '',80a)') FILEI write(*,'(''FILEU: '',80a)') FILEU endif open(10,file=FILEU,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'...opened' naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 do i = 1, 10 INFO(i) = ' ' enddo BSCALE = 1.0 BZERO = 0.0 NEXTEND = 0 NEND = -1 i = 0 nread = 0 100 continue i = i + 1 if (DIAG) print*,'READREC: ',i read(10,rec=i,iostat=ios) buffc do k = 0, 35, 1 if (DIAG) write(*,'(i8,1x,i4,1x,a80)') . i,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+51) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'EXPTIME ') INFO(1) = stream if (field.eq.'FILTNAM1') INFO(2) = stream if (field.eq.'FILENAME') INFO(3) = stream if (field.eq.'DATE-OBS') INFO(4) = stream if (field.eq.'TIME-OBS') INFO(5) = stream if (field.eq.'DEC_TARG') INFO(6) = stream if (field.eq.'RA_TARG ') INFO(7) = stream if (field.eq.'DEC_DEG ') INFO(6) = stream if (field.eq.'RA_DEG ') INFO(7) = stream if (field.eq.'PA_V3 ') INFO(8) = stream if (field.eq.'PROPOSID') INFO(9) = stream if (field.eq.'CRPIX1 ') HDR(01) = stream if (field.eq.'CRPIX2 ') HDR(02) = stream if (field.eq.'CRVAL1 ') HDR(03) = stream if (field.eq.'CRVAL2 ') HDR(04) = stream if (field.eq.'CTYPE1 ') HDR(05) = stream if (field.eq.'CTYPE2 ') HDR(06) = stream if (field.eq.'CD1_1 ') HDR(07) = stream if (field.eq.'CD1_2 ') HDR(08) = stream if (field.eq.'CD2_1 ') HDR(09) = stream if (field.eq.'CD2_2 ') HDR(10) = stream if (field.eq.'ORIENTAT') HDR(11) = stream if (field.eq.'PA_APER ') HDR(12) = stream if (field.eq.'PA_V3 ') HDR(13) = stream if (field.eq.'DATE-OBS') HDR(14) = stream if (field.eq.'TIME-OBS') HDR(15) = stream if (field.eq.'EXPTIME ') HDR(16) = stream if (field.eq.'ROOTNAME') HDR(17) = stream if (field.eq.'TARGNAME') HDR(18) = stream if (field.eq.'RA_TARG ') HDR(19) = stream if (field.eq.'DEC_TARG') HDR(20) = stream if (field.eq.'RA_DEG ') HDR(19) = stream if (field.eq.'DEC_DEG ') HDR(20) = stream if (field.eq.'PROPOSID') HDR(21) = stream if (field.eq.'FILTER1 ') HDR(22) = stream if (field.eq.'FILTER2 ') HDR(23) = stream if (field.eq.'VAFACTOR') HDR(24) = stream if (field.eq.'CCDGAIN ') HDR(25) = stream if (field.eq.'END ') then if (NEXTENU.gt.NEXTEND.and.NEXTENU.gt.1) then print*,' ' write(*,'(''readfits_i2e: '',80a)') FILEI print*,' NEXTENU.lt.NEXTEND...' print*,' ---> NEXTEND: ',NEXTEND print*,' ---> NEXTENU: ',NEXTENU print*,' ' stop endif NEND = NEND + 1 if (NEND.ge.1) goto 101 endif enddo goto 100 101 continue nread = nread + 1 if (DIAG) then print*,' ' print*,'----------------------------------------' print*,' NREAD: ',nread print*,' NEXTEND: ',nextend print*,' NEXTENU: ',nextenu print*,' NAXIS: ',naxes print*,' LAXIS: ',laxis(1),laxis(2),laxis(3) print*,' BITPIX: ',bitpix print*,' BSCALE: ',bscale print*,' BZERO: ',bzero print*,' NDIMX: ',NDIMX print*,' NDIMY: ',NDIMY print*,' ' endif ifirst = i+1 i1 = i i2 = i NXF = laxis(1) NYF = laxis(2) nbper = 2*laxis(1)*laxis(2) if (BITPIX.eq. 8) nbper = 1*laxis(1)*laxis(2) if (BITPIX.eq. 32) nbper = 4*laxis(1)*laxis(2) if (BITPIX.eq.-32) nbper = 4*laxis(1)*laxis(2) if (BITPIX.eq.-64) nbper = 8*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) npt = min(NDIMX*NDIMY,npt) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 if (DIAG) then print*,' i : ',i print*,' i1: ',i1 print*,' i2: ',i2 print*,' npt: ',npt print*,'NEND: ',NEND,NEXTENU,BITPIX endif c print*,'NEND: ',NEND,NEXTENU,BITPIX if (NEND.ne.NEXTENU) then if (naxes.ne.0) i = i2 goto 100 endif if (DIAG) then print*,' ' print*,'OK! TIME TO READ...' print*,' i1: ',i1 print*,' i2: ',i2 print*,' npt: ',npt print*,' NDIMX: ',NDIMX print*,' NDIMY: ',NDIMY print*,' ' endif if (BITPIX.ne.16) then print*,' ' print*,'Problem in readfits_i2e...' print*,' ' print*,' FILEI: ',FILEI print*,' NDIMX: ',NDIMX print*,' NDIMY: ',NDIMY print*,' NEXTENU: ',NEXTENU print*,' BITPIX: ',BITPIX print*,' prob... BITPIX be 16 for readfits_i2e...' print*,' ' do ii = 1, NDIMX do jj = 1, NDIMY pix(ii,jj) = 0 enddo enddo stop endif do i = i1, i2, 1 if (DIAG) write(*,1115) i read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/2 + 1 np2 = (nbyteE-nbyte1)/2 + 1 if (DIAG) write(*,1115) i,np1,np2,npt call buff2pix_i2e(buffb,pix,np1,npt) if (DIAG) write(*,1115) i,np1,np2,npt,i/laxis(1) 1115 format(1x,i8,1x,i10,1x,i10,1x,i10,1x,i6.6) enddo close(10) return 900 continue print*,'FILEU: ',FILEU print*,'READFITS_I2E ERROR' stop end subroutine buff2pix_i2e(buff,pix,n1,nt) implicit none byte buff(2880) integer*2 pix(*) integer n1,nt byte b(2) integer*2 ii equivalence(ii,b) integer i, npu, nbu logical islinux do i = 1, 1440 npu = n1+i-1 nbu = (i-1)*2 if (.not.islinux()) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) endif if (islinux()) then b(2) = buff(nbu+1) b(1) = buff(nbu+2) endif if (npu.ge.1.and.npu.le.nt) pix(npu) = ii enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_r4.f" c**** c********************************************* c-------------------------------------------------- c c this just reads in an r4 fits image c subroutine readfits_r4(FILE,pix,NDIMX,NDIMY) implicit none character*(*) FILE integer NDIMX,NDIMY real pix(NDIMX,NDIMY) character*199 FILEU character*070 INFO(10) integer naxes integer laxis(3) character*8 field character*70 stream integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k integer j character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) real*4 buffr(0720) integer ii,nn,nx,ny integer nxx, nyy integer ifirst, i1, i2 integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix logical DIAG data DIAG /.false./ character*70 HDR(25) c common/HDR/HDR logical extend_tf FILEU = FILE do i = 1, 195 if (FILE(i:i+4).eq.'.fits') then FILEU = FILE(1:i+4) goto 1 endif enddo print*,' ' print*,'readfits_r4: no .fits' print*,' FILE: ',FILE stop 1 continue do i = 1, 25 HDR(i) = ' ' enddo if (DIAG) then print*,'enter readfits_r4...' print*,'FILE: ',FILE(1:60) endif open(10,file=FILEU,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'...opened' naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 do i = 1, 10 INFO(i) = ' ' enddo extend_tf = .false. i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buffc if (DIAG) print*,'READREC: ',i do k = 0, 35, 1 if (DIAG) write(*,'(i4,1x,i4,1x,a80)') . i,k,buffc(k*80+1:k*80+80) do j = 1, 80 if (ichar(buffc(k*80+j:k*80+j)).eq.0) . buffc(k*80+j:k*80+j) = ' ' enddo field = buffc(k*80+01:k*80+08) stream = buffc(k*80+10:k*80+79) if (DIAG) write(*,'('' FIELD : '',8a)') field if (DIAG) write(*,'('' STREAM: '',20a)') stream if (DIAG) write(*,'('' STREAM: '',70a)') stream if (field.eq.'EXTEND ') read(stream,*) extend_tf if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'EXPTIME ') INFO(1) = stream if (field.eq.'FILTNAM1') INFO(2) = stream if (field.eq.'FILENAME') INFO(3) = stream if (field.eq.'DATE-OBS') INFO(4) = stream if (field.eq.'TIME-OBS') INFO(5) = stream if (field.eq.'DEC_TARG') INFO(6) = stream if (field.eq.'RA_TARG ') INFO(7) = stream if (field.eq.'PA_V3 ') INFO(8) = stream if (field.eq.'PROPOSID') INFO(9) = stream if (field.eq.'CRPIX1 ') HDR(01) = stream if (field.eq.'CRPIX2 ') HDR(02) = stream if (field.eq.'CRVAL1 ') HDR(03) = stream if (field.eq.'CRVAL2 ') HDR(04) = stream if (field.eq.'CTYPE1 ') HDR(05) = stream if (field.eq.'CTYPE2 ') HDR(06) = stream if (field.eq.'CD1_1 ') HDR(07) = stream if (field.eq.'CD1_2 ') HDR(08) = stream if (field.eq.'CD2_1 ') HDR(09) = stream if (field.eq.'CD2_2 ') HDR(10) = stream if (field.eq.'ORIENTAT') HDR(11) = stream if (field.eq.'PA_APER ') HDR(12) = stream if (field.eq.'PA_V3 ') HDR(13) = stream if (field.eq.'DATE-OBS') HDR(14) = stream if (field.eq.'TIME-OBS') HDR(15) = stream if (field.eq.'EXPTIME ') HDR(16) = stream if (field.eq.'ROOTNAME') HDR(17) = stream if (field.eq.'TARGNAME') HDR(18) = stream if (field.eq.'RA_TARG ') HDR(19) = stream if (field.eq.'DEC_TARG') HDR(20) = stream if (field.eq.'PROPOSID') HDR(21) = stream if (field.eq.'FILTER1 ') HDR(22) = stream if (field.eq.'FILTER2 ') HDR(23) = stream if (field.eq.'VAFACTOR') HDR(24) = stream if (field.eq.'END ') goto 101 enddo goto 100 101 continue nread = nread + 1 if (extend_tf.and.NREAD.eq.1.and.NAXES.eq.0) goto 100 ! read the first extension... if (DIAG) then print*,'----------------------------------------' print*,' NREAD: ',nread print*,'NEXTEND: ',nextend print*,' NAXIS: ',naxes print*,' LAXIS: ',laxis(1),laxis(2),laxis(3) print*,' BITPIX: ',bitpix print*,' BSCALE: ',bscale print*,' BZERO: ',bzero endif ifirst = i+1 i1 = i i2 = i nbper = 4*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 if (BITPIX.ne.-32) then print*,' FILEU: ',FILEU(1:40) print*,' FILE : ',FILE(1:40) print*,'BITPIX.ne.-32... unreal!' stop endif do i = 01, NDIMX do j = 01, NDIMY pix(i,j) = 0. enddo enddo do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 call buff2pix_r4(buffb,buffr,0001,0720) do ii = 001, 720 nn = np1 + (ii-1) ny = 1 + (nn-1)/laxis(1) nx = nn-(ny-1)*laxis(1) if (nx.ge.001.and.nx.le.NDIMX.and. . ny.ge.001.and.ny.le.NDIMY) then pix(nx,ny) = buffr(ii) nxx = nx nyy = ny endif enddo if (ny.gt.NDIMY) goto 899 c if (DIAG) write(*,1115) i,np1,np2,npt,nxx,nyy c1115 format(1x,i8,1x,i10,1x,i10,1x,i10,1x,2i6) enddo 899 close(10) c if (DIAG) write(*,1115) i,np1,np2,npt,nxx,nyy return 900 continue print*,' ' print*,'READFITS ERROR: ' print*,' ' write(*,'('' could not read in file: '',80a)') FILEU print*,' ' stop end subroutine buff2pix_r4(buff,pix,n1,nt) implicit none byte buff(2880) real pix(*) integer n1,nt byte b(4) real r equivalence(r,b) integer i, npu, nbu logical islinux do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (.not.islinux()) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) b(3) = buff(nbu+3) b(4) = buff(nbu+4) endif if (islinux()) then b(4) = buff(nbu+1) b(3) = buff(nbu+2) b(2) = buff(nbu+3) b(1) = buff(nbu+4) endif if (npu.ge.1.and.npu.le.nt) pix(npu) = r enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_j2r.f" c**** c********************************************* cc----------------------------------------------------- c c This reads in an image in jay's integer*2 format into c a real*4 pixel array c subroutine readfits_j2r(FILE,pix,NX,NY) implicit none character*(*) FILE integer NX, NY real*4 pix(NX,NY) character*70 INFO(10) common / fitsinfo / INFO integer naxes integer laxis(3) character*8 field character*20 stream real*4 pixu integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k integer ii, jj integer n integer NXU, NYU character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer*2 ibuff(1440) integer ifirst, i1, i2 c integer j integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix c integer r2i logical LINUX data LINUX/.true./ logical DIAG data DIAG /.false./ character*70 HDR(25) common/HDR/HDR character*199 FILEU FILEU = FILE do i = 75,2,-1 if (FILE(i:i+4).eq.'.fits') FILEU = FILE(1:i+4) enddo open(10,file=FILEU,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'...opened' bscale = 1 bzero = 0 naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 do i = 1, 10 INFO(i) = ' ' enddo do i = 1, 25 HDR(i) = ' ' enddo HDR(24) = ' 1.000 ' i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buffc if (DIAG) print*,'READREC: ',i do k = 0, 35, 1 if (DIAG) write(*,'(i4,1x,i4,1x,a80)') . i,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+31) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'EXPTIME ') INFO(01) = stream if (field.eq.'FILTNAM1') INFO(02) = stream if (field.eq.'FILENAME') INFO(03) = stream if (field.eq.'DATE-OBS') INFO(04) = stream if (field.eq.'TIME-OBS') INFO(05) = stream if (field.eq.'DEC_TARG') INFO(06) = stream if (field.eq.'RA_TARG ') INFO(07) = stream if (field.eq.'PA_V3 ') INFO(08) = stream if (field.eq.'PROPOSID') INFO(09) = stream if (field.eq.'CCDGAIN ') INFO(10) = stream if (field.eq.'CRPIX1 ') HDR(01) = stream if (field.eq.'CRPIX2 ') HDR(02) = stream if (field.eq.'CRVAL1 ') HDR(03) = stream if (field.eq.'CRVAL2 ') HDR(04) = stream if (field.eq.'CTYPE1 ') HDR(05) = stream if (field.eq.'CTYPE2 ') HDR(06) = stream if (field.eq.'CD1_1 ') HDR(07) = stream if (field.eq.'CD1_2 ') HDR(08) = stream if (field.eq.'CD2_1 ') HDR(09) = stream if (field.eq.'CD2_2 ') HDR(10) = stream if (field.eq.'ORIENTAT') HDR(11) = stream if (field.eq.'PA_APER ') HDR(12) = stream if (field.eq.'PA_V3 ') HDR(13) = stream if (field.eq.'DATE-OBS') HDR(14) = stream if (field.eq.'TIME-OBS') HDR(15) = stream if (field.eq.'EXPTIME ') HDR(16) = stream if (field.eq.'ROOTNAME') HDR(17) = stream if (field.eq.'TARGNAME') HDR(18) = stream if (field.eq.'RA_TARG ') HDR(19) = stream if (field.eq.'DEC_TARG') HDR(20) = stream if (field.eq.'PROPOSID') HDR(21) = stream if (field.eq.'FILTER ') HDR(22) = stream if (field.eq.'FILTER ') HDR(23) = stream if (field.eq.'FILTER1 ') HDR(22) = stream if (field.eq.'FILTER2 ') HDR(23) = stream if (field.eq.'VAFACTOR') HDR(24) = stream if (field.eq.'END ') goto 101 enddo goto 100 101 continue nread = nread + 1 if (DIAG) then print*,'----------------------------------------' print*,' NREAD: ',nread print*,'NEXTEND: ',nextend print*,' NAXIS: ',naxes print*,' LAXIS: ',laxis(1),laxis(2),laxis(3) print*,' BITPIX: ',bitpix print*,' BSCALE: ',bscale print*,' BZERO: ',bzero endif ifirst = i+1 i1 = i i2 = i if (BITPIX.ne.16) then print*,' ' print*,'readfits_j2r...: ' print*,' ' print*,' you called a routine to read in an' print*,' unsigned i2 image, and the image you' print*,' gave it has BITPIX = ',BITPIX print*,' ' print*,' FILEU: ',FILEU print*,' ' do ii = 1, NX do jj = 1, NY pix(ii,jj) = 0 enddo enddo stop endif nbper = 2*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 if (laxis(1).gt.NX.and.laxis(2).gt.NY) then print*,' not enough image space! ' print*,' ' print*,' laxis1: ',laxis(1) print*,' NX: ',NX print*,' ' print*,' laxis2: ',laxis(2) print*,' NY: ',NY print*,' ' stop endif NXU = laxis(1) NYU = laxis(2) if (DIAG) then print*,' NX: ',NX print*,' NY: ',NY print*,' NBPER: ',nbper print*,' NBYT1: ',nbyte1 print*,' NBYT2: ',nbyte2 print*,' IFIRST: ',ifirst print*,' I1: ',i1 print*,' I2: ',i2 print*,' NPT: ',NPT endif do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/2 + 1 np2 = (nbyteE-nbyte1)/2 + 1 np2 = min(np2,npt) call buff2pix_j2r(buffb,ibuff,0001,1440) do n = np1, np2, 1 jj = n/NXU + 1 ii = n-NXU*(jj-1) pixu = ibuff(n-np1+1)*bscale+bzero if (pixu.gt.55000) pixu = 55000 + (pixu-55000)*5 pix(ii,jj) = pixu enddo enddo if (DIAG) then print*,' NBPER: ',nbper print*,' NBYT1: ',nbyte1 print*,' NBYT2: ',nbyte2 print*,' IFIRST: ',ifirst print*,' I1: ',i1 print*,' I2: ',i2 print*,' NPT: ',NPT endif return 900 continue print*,'READFITS_I2 ERROR' print*,' FILE: ',FILE stop end subroutine buff2pix_j2r(buff,pix,n1,nt) implicit none byte buff(2880) integer*2 pix(*) integer n1,nt byte b(2) integer*2 ii equivalence(ii,b) integer i, npu, nbu logical islinux do i = 1, 1440 npu = n1+i-1 nbu = (i-1)*2 if (.not.islinux()) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) endif if (islinux()) then b(2) = buff(nbu+1) b(1) = buff(nbu+2) endif if (npu.ge.1.and.npu.le.nt) pix(npu) = ii enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_r8e_r4.f" c**** c********************************************* c----------------------------------------------------------------- c c reads an r4 fits image, with extensions (reads in one extension) c subroutine readfits_r8e_r4(FILE,pix,NDIMX,NDIMY,NEXTENU) implicit none character*(*) FILE integer NDIMX,NDIMY real*4 pix(NDIMX,NDIMY) integer NEXTENU character*199 FILEU character*70 INFO(10) common / fitsinfo / INFO integer naxes integer laxis(3) common/laxis3_/laxis integer NXF integer NYF character*8 field character*40 stream integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k integer j character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer ifirst, i1, i2 integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix character*70 HDR(25) common/HDR/HDR logical DIAG data DIAG /.false./ integer NEND integer iend if (DIAG) then print*,'enter readfits_r4e...... ' print*,'FILEi: ',FILE(1:60) endif FILEU = FILE iend = 0 do i = 196,1,-1 if (DIAG) print*,i,iend,FILE(i:i+4) if (FILE(i:i+4).eq.'.fits') iend = i+4 enddo if (DIAG) then print*,'iend: ',iend endif if (iend.eq.0) stop 'NO .fits in FILENAME' FILEU = FILE(1:iend) if (DIAG) then print*,'purge...' print*,'FILEu: ',FILEU endif open(10,file=FILEU,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'...opened ',FILEU naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 do i = 1, 10 INFO(i) = ' ' enddo BSCALE = 1.0 BZERO = 0.0 NEND = 0 i = 0 nread = 0 100 continue i = i + 1 if (DIAG) print*,'READREC: ',i read(10,rec=i,iostat=ios) buffc do k = 0, 35, 1 if (DIAG) write(*,'(i4,1x,i4,1x,a80)') . i,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+51) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'EXPTIME ') INFO(1) = stream if (field.eq.'FILTER ') INFO(2) = stream if (field.eq.'FILTNAM1') INFO(2) = stream if (field.eq.'FILENAME') INFO(3) = stream if (field.eq.'DATE-OBS') INFO(4) = stream if (field.eq.'TIME-OBS') INFO(5) = stream if (field.eq.'DEC_TARG') INFO(6) = stream if (field.eq.'RA_TARG ') INFO(7) = stream if (field.eq.'PA_V3 ') INFO(8) = stream if (field.eq.'PROPOSID') INFO(9) = stream if (field.eq.'CRPIX1 ') HDR(01) = stream if (field.eq.'CRPIX2 ') HDR(02) = stream if (field.eq.'CRVAL1 ') HDR(03) = stream if (field.eq.'CRVAL2 ') HDR(04) = stream if (field.eq.'CTYPE1 ') HDR(05) = stream if (field.eq.'CTYPE2 ') HDR(06) = stream if (field.eq.'CD1_1 ') HDR(07) = stream if (field.eq.'CD1_2 ') HDR(08) = stream if (field.eq.'CD2_1 ') HDR(09) = stream if (field.eq.'CD2_2 ') HDR(10) = stream if (field.eq.'ORIENTAT') HDR(11) = stream if (field.eq.'PA_APER ') HDR(12) = stream if (field.eq.'PA_V3 ') HDR(13) = stream if (field.eq.'DATE-OBS') HDR(14) = stream if (field.eq.'TIME-OBS') HDR(15) = stream if (field.eq.'EXPTIME ') HDR(16) = stream if (field.eq.'ROOTNAME') HDR(17) = stream if (field.eq.'TARGNAME') HDR(18) = stream if (field.eq.'RA_TARG ') HDR(19) = stream if (field.eq.'DEC_TARG') HDR(20) = stream if (field.eq.'PROPOSID') HDR(21) = stream if (field.eq.'FILTER ') HDR(22) = stream if (field.eq.'FILTER1 ') HDR(22) = stream if (field.eq.'FILTER2 ') HDR(23) = stream if (field.eq.'VAFACTOR') HDR(24) = stream if (field.eq.'END ') then !print*,' ---> NEND: ',NEND,NEXTENU if (NEND.eq.NEXTENU) goto 101 NEND = NEND + 1 endif enddo goto 100 101 continue nread = nread + 1 if (DIAG) then print*,' ' print*,'----------------------------------------' print*,' NREAD: ',nread print*,'NEXTEND: ',nextend print*,' NAXIS: ',naxes print*,' LAXIS: ',laxis(1),laxis(2),laxis(3) print*,' BITPIX: ',bitpix print*,' BSCALE: ',bscale print*,' BZERO: ',bzero print*,' NDIMX: ',NDIMX print*,' NDIMY: ',NDIMY print*,' ' endif ifirst = i+1 i1 = i i2 = i NXF = laxis(1) NYF = laxis(2) nbper = 8*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 if (BITPIX.ne.-64) then print*,'readfits_r8e...' print*,'BITPIX: ',BITPIX print*,'prob' stop endif if (DIAG) then print*,' ' print*,'do i --- ',i1,i2 print*,' nbper: ',nbper print*,' npt: ',npt print*,' ' endif do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/8 + 1 np2 = (nbyteE-nbyte1)/8 + 1 call buff2pix_r8_edge(buffb,pix,np1,npt, . NDIMX,NDIMY,laxis(1),laxis(2)) if (DIAG) write(*,1115) i,np1,np2,npt 1115 format(1x,i8,1x,i10,1x,i10,1x,i10) enddo if (DIAG) then print*,' ' do j = 10, 01, -1 write(*,'(10x,i2,1x,10f8.2)') j, (pix(i,j),i=1,10) enddo print*,' ' endif close(10) if (DIAG) print*,'...closed ',FILEU return 900 continue print*,'READFITS ERROR' stop end c------------------------------------------------------ c c subroutine buff2pix_r8_edge(buff,pix,n1,nt, . NXP,NYP,NXF,NYF) implicit none byte buff(2880) integer NXP,NYP real*4 pix(NXP,NYP) integer n1,nt integer NXF,NYF c real pbuff(360) integer i integer npu, nbu integer NX, NY byte b(8) real*8 r8 equivalence(r8,b) logical islinux if (NYF.eq.0) continue do i = 1, 360 npu = n1+i-1 nbu = (i-1)*8 if (npu.ge.1.and.npu.le.nt) then NX = npu - (npu-1)/NXF*NXF NY = 1 + (npu-1)/NXF if (NX.le.NXP.and.NY.le.NYP) then if (.not.islinux()) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) b(3) = buff(nbu+3) b(4) = buff(nbu+4) b(5) = buff(nbu+5) b(6) = buff(nbu+6) b(7) = buff(nbu+7) b(8) = buff(nbu+8) endif if (islinux()) then b(8) = buff(nbu+1) b(7) = buff(nbu+2) b(6) = buff(nbu+3) b(5) = buff(nbu+4) b(4) = buff(nbu+5) b(3) = buff(nbu+6) b(2) = buff(nbu+7) b(1) = buff(nbu+8) endif if (npu.ge.1.and.npu.le.nt) pix(NX,NY) = SNGL(r8) endif endif enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/notblank70.f" c**** c********************************************* c---------------------------------------------- c c logical function notblank70(string70) implicit none character*70 string70 integer i notblank70 = .false. do i = 1, 70 if (string70(i:i).ge.'a'.and. . string70(i:i).le.'z') notblank70 = .true. if (string70(i:i).ge.'A'.and. . string70(i:i).le.'Z') notblank70 = .true. if (string70(i:i).ge.'0'.and. . string70(i:i).le.'9') notblank70 = .true. enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/WFC3IR/read_wfc3ir_flt_full.f" c**** c********************************************* subroutine read_wfc3ir_flt_full_simpl(FILENAME,pixr) implicit none character*200 FILENAME real pixr(1014,1014) real pixo(1014,1014) real*8 CRPIX1, CRPIX2 real*8 CRVAL1, CRVAL2 real*8 CD1_1, CD1_2 real*8 CD2_1, CD2_2 integer LOFLAG, HIFLAG real*8 BDRY_XR(4,4) real*8 BDRY_YR(4,4) character*05 FILT real*4 EXPT real*4 RDAT integer PROP call read_wfc3ir_flt_full(FILENAME,pixr,pixo, . CRPIX1, CRPIX2, . CRVAL1, CRVAL2, . CD1_1, CD1_2, . CD2_1, CD2_2, . LOFLAG, HIFLAG, . BDRY_XR,BDRY_YR, . FILT,EXPT,RDAT,PROP) return end subroutine read_wfc3ir_flt_full(FILENAME,pixr,pixo, . CRPIX1, CRPIX2, . CRVAL1, CRVAL2, . CD1_1, CD1_2, . CD2_1, CD2_2, . LOFLAG, HIFLAG, . BDRY_XR,BDRY_YR, . FILT,EXPT,RDAT,PROP) implicit none character*200 FILENAME real pixr(1014,1014) real pixo(1014,1014) real*8 CRPIX1, CRPIX2 real*8 CRVAL1, CRVAL2 real*8 CD1_1, CD1_2 real*8 CD2_1, CD2_2 integer LOFLAG, HIFLAG real*8 BDRY_XR(4,4) real*8 BDRY_YR(4,4) character*05 FILT real*4 EXPT real*4 RDAT integer PROP c c----------------------------------- c c real pix(1014,1014) c real pmax c integer*2 pox(1014,1014) c integer pux(1014,1014) integer i, j integer ii,jj c real xsum, ysum c real xbar, ybar c real mbar_sky character*70 INFO(10) common / fitsinfo / INFO c real EXPTIME c integer k c real pval c integer ival real pixi(1014,1014) real pixh(1014,1014) integer*2 pixi2(1014,1014) integer pixi2_l real*4, dimension(:,:), allocatable :: pixi_sub integer*2, dimension(:,:), allocatable :: pixi2_sub real rsum real dd c integer Ls c real plist(9) c integer*2 i2 character*20 STREAM character*20 STRING_APER integer i4_query_hdre real*4 r4_query_hdre real*8 r8_query_hdre real*8 rdate_header real*8 PA_APER real*8 PA_V3 real*8 COSPA, SINPA logical MASKIRBLOB data MASKIRBLOB /.true./ common /MASKIRBLOB_/MASKIRBLOB c c-------------------------------------------------- c do i = 0001, 1014 do j = 0001, 1014 pixi(i,j) = -50.0 pixi2(i,j) = 0 enddo enddo call query_hdre_r8(FILENAME,'CRPIX1 ',CRPIX1,-1) call query_hdre_r8(FILENAME,'CRPIX2 ',CRPIX2,-1) call query_hdre_r8(FILENAME,'CRVAL1 ',CRVAL1,-1) call query_hdre_r8(FILENAME,'CRVAL2 ',CRVAL2,-1) c call query_hdre_r8(FILENAME,'CD1_1 ',CD1_1,-1) c call query_hdre_r8(FILENAME,'CD1_2 ',CD1_2,-1) c call query_hdre_r8(FILENAME,'CD2_1 ',CD2_1,-1) c call query_hdre_r8(FILENAME,'CD2_2 ',CD2_2,-1) call query_hdre(FILENAME,'APERTURE',STRING_APER,-1) if (STRING_APER(2:9).eq.'IRSUB512') then ! this works for IRSUB512 and IRSUB512-FIX print*,'WFC3IR SPECIAL APERTURE: ',STRING_APER(2:20) allocate( pixi_sub(512,512)) allocate(pixi2_sub(512,512)) call readfits_r4e(FILENAME, pixi_sub,512,512,1) call readfits_i2e(FILENAME,pixi2_sub,512,512,3) do i = 001, 512 do j = 001, 512 pixi(i+251,j+251) = pixi_sub(i,j) pixi2(i+251,j+251) = pixi2_sub(i,j) enddo enddo CRPIX1 = CRPIX1 + 251 CRPIX2 = CRPIX2 + 251 LOFLAG = LOFLAG*4 HIFLAG = HIFLAG*4 deallocate( pixi_sub) deallocate(pixi2_sub) goto 3 endif if (STRING_APER(2:9).eq.'IRSUB256') then ! this works for IRSUB256 and IRSUB256-FIX print*,'WFC3IR SPECIAL APERTURE: ',STRING_APER(2:20) allocate( pixi_sub(256,256)) allocate(pixi2_sub(256,256)) call readfits_r4e(FILENAME, pixi_sub,256,256,1) call readfits_i2e(FILENAME,pixi2_sub,256,256,3) do i = 001, 256 do j = 001, 256 pixi(i+379,j+379) = pixi_sub(i,j) pixi2(i+379,j+379) = pixi2_sub(i,j) enddo enddo CRPIX1 = CRPIX1 + 379 CRPIX2 = CRPIX2 + 379 LOFLAG = LOFLAG*16 HIFLAG = HIFLAG*16 deallocate( pixi_sub) deallocate(pixi2_sub) goto 3 endif if (STRING_APER(2:9).eq.'IRSUB128') then ! this works for IRSUB128 and IRSUB128-FIX print*,'WFC3IR SPECIAL APERTURE: ',STRING_APER(2:20) allocate( pixi_sub(128,128)) allocate(pixi2_sub(128,128)) call readfits_r4e(FILENAME, pixi_sub,128,128,1) call readfits_i2e(FILENAME,pixi2_sub,128,128,3) do i = 001, 128 do j = 001, 128 pixi(i+443,j+443) = pixi_sub(i,j) pixi2(i+443,j+443) = pixi2_sub(i,j) enddo enddo CRPIX1 = CRPIX1 + 443 CRPIX2 = CRPIX2 + 443 LOFLAG = LOFLAG*64 HIFLAG = HIFLAG*64 deallocate( pixi_sub) deallocate(pixi2_sub) goto 3 endif if (STRING_APER(2:8).eq.'IRSUB64') then ! this works for IRSUB64 and IRSUB64-FIX print*,'WFC3IR SPECIAL APERTURE: ',STRING_APER(2:20) allocate( pixi_sub(64,64)) allocate(pixi2_sub(64,64)) call readfits_r4e(FILENAME, pixi_sub,64,64,1) call readfits_i2e(FILENAME,pixi2_sub,64,64,3) do i = 001, 064 do j = 001, 064 pixi(i+475,j+475) = pixi_sub(i,j) pixi2(i+475,j+475) = pixi2_sub(i,j) enddo enddo CRPIX1 = CRPIX1 + 475 CRPIX2 = CRPIX2 + 475 LOFLAG = LOFLAG*256 HIFLAG = HIFLAG*256 deallocate( pixi_sub) deallocate(pixi2_sub) goto 3 endif call readfits_r4e(FILENAME,pixi ,1014,1014,1) call readfits_i2e(FILENAME,pixi2,1014,1014,3) 3 continue do i = 0001, 1014 do j = 0001, 1014 pixo(i,j) = pixi(i,j) enddo enddo PA_APER = r8_query_hdre(FILENAME,'PA_APER ',-1) PA_V3 = PA_APER + 0.1256971 COSPA = cos(PA_V3*3.14159/180.0) SINPA = sin(PA_V3*3.14159/180.0) CD1_1 = -COSPA*0.120978/60/60 CD1_2 = SINPA*0.120978/60/60 CD2_1 = SINPA*0.120978/60/60 CD2_2 = COSPA*0.120978/60/60 PROP = i4_query_hdre(FILENAME,'PROPOSID',-1) c print*,'PROP: ',PROP EXPT = r4_query_hdre(FILENAME,'EXPTIME ',-1) call query_hdre(FILENAME, 'FILTER ',STREAM,-1) if (STREAM(1:1).eq.'F') FILT = STREAM(1:5) ! allow quotes in the filter name... if (STREAM(2:2).eq.'F') FILT = STREAM(2:6) RDAT = SNGL(rdate_header(FILENAME)) LOFLAG = -50 HIFLAG = 30000 do i = 1, 4 do j = 1, 4 BDRY_XR(i,j) = 0. BDRY_YR(i,j) = 0. enddo enddo BDRY_XR(1,1) = 0001. BDRY_YR(1,1) = 0001. BDRY_XR(2,1) = 1013. BDRY_YR(2,1) = 0001. BDRY_XR(3,1) = 1013. BDRY_YR(3,1) = 1013. BDRY_XR(4,1) = 0001. BDRY_YR(4,1) = 1013. do i = 0001, 1014 do j = 0001, 1014 pixi2_l = pixi2(i,j) if (iand(pixi2_l,00001).ne.0) continue ! Reed-Solomon decoding error if (iand(pixi2_l,00002).ne.0) continue ! data missing/replaced by fill if (iand(pixi2_l,00004).ne.0) pixi(i,j) = -500 ! bad detector pixel if (iand(pixi2_l,00008).ne.0) continue ! deviant zero-read (bias) value if (iand(pixi2_l,00016).ne.0) continue ! hot pixel if (iand(pixi2_l,00032).ne.0) continue ! unstable response if (iand(pixi2_l,00256).ne.0) continue ! full-well saturation if (MASKIRBLOB.and. . iand(pixi2_l,00512).ne.0) pixi(i,j) = -500 ! bad/uncertain value (blob) if (iand(pixi2_l,01024).ne.0) continue ! (reserved) if (iand(pixi2_l,02048).ne.0) continue ! signal in zero-read if (iand(pixi2_l,04096).ne.0) continue ! CR detected by MDriz if (iand(pixi2_l,08192).ne.0) continue ! CR detected during up-the-ramp if (iand(pixi2_l,16384).ne.0) continue ! pixel affected by ghost/crosstalk pixr(i,j) = pixi(i,j) if (pixi2_l.eq.00256) pixr(i,j) = HIFLAG+1 ! full-well saturation ; only if there are no other flags enddo enddo do i = 1, 1014 do j = 1, 1014 pixh(i,j) = pixr(i,j) enddo enddo do i = 1, 1014 do j = 1, 1014 rsum = 0. if (pixr(i,j).ge.HIFLAG) then do ii = max(0001,i-5), min(1014,i+5) do jj = max(0001,j-5), min(1014,j+5) dd = sqrt(1.*(i-ii)**2+(j-jj)**2) rsum = rsum + 1.0/(1+dd)**2*pixh(ii,jj) enddo enddo pixr(i,j) = pixr(i,j) + rsum endif enddo enddo c------------------------------------------------ c c blank out the death star c do i = 0001, 1014 do j = 0001, 1014 rsum = sqrt((i-359.)**2+(j-55.)**2) if (rsum.lt.25) pixr(i,j) = -751 enddo enddo c print*,'EXIT WFC3IR_READ_FULL_WSUB: ' c print*,' CRPIX: ',CRPIX1,CRPIX2 c print*,' CRVAL: ',CRVAL1,CRVAL2 return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/ACSWFC/read_acswfc_flt_full.f" c**** c********************************************* c-------------------------------------------------- c c subroutine read_acswfc_flt_smpl(FILENAME,pix) implicit none character*200 FILENAME real pix(4096,4096) real*8 CRPIX1, CRPIX2 real*8 CRVAL1, CRVAL2 real*8 CD1_1, CD1_2 real*8 CD2_1, CD2_2 integer LOFLAG, HIFLAG real*8 BDRY_XR(4,4) real*8 BDRY_YR(4,4) character*05 FILT real*4 EXPT real*4 RDAT integer PROP real GAIN byte, dimension(:,:), allocatable :: pxq allocate(pxq(4096,4096)) call read_acswfc_flt_full(FILENAME,pix,pxq, . CRPIX1, CRPIX2, . CRVAL1, CRVAL2, . CD1_1, CD1_2, . CD2_1, CD2_2, . LOFLAG, HIFLAG, . BDRY_XR, BDRY_YR, . FILT,EXPT, . RDAT,PROP,GAIN) deallocate(pxq) return end c--------------------------------------------------- c c subroutine read_acswfc_flt_full(FILENAME,pix,pxq, . CRPIX1, CRPIX2, . CRVAL1, CRVAL2, . CD1_1, CD1_2, . CD2_1, CD2_2, . LOFLAG, HIFLAG, . BDRY_XR, BDRY_YR, . FILT,EXPT, . RDAT,PROP,GAIN) implicit none character*200 FILENAME real pix(4096,4096) byte pxq(4096,4096) real*8 CRPIX1, CRPIX2 real*8 CRVAL1, CRVAL2 real*8 CD1_1, CD1_2 real*8 CD2_1, CD2_2 integer LOFLAG, HIFLAG real*8 BDRY_XR(4,4) real*8 BDRY_YR(4,4) character*05 FILT real*4 EXPT real*4 RDAT integer PROP real*4 GAIN c c---------------------------------------------------- c integer NAXIS1 integer NAXIS2 real*8 COSPA, SINPA real*8 PA_APER real*8 PA_V3 real pix2k2k(2048,2048) integer*2 pxd2k2k(2048,2048) character*20 APERTURE character*80 FILTU character*80 FILT1, FILT2, FILT3, FILT4 real*8 r8_query_hdre real*4 r4_query_hdre integer i4_query_hdre real*8 rdate_header integer i, j logical str_contains real*4, dimension(:,:), allocatable :: pxz integer*2, dimension(:,:), allocatable :: pxd ! data quality array if (.false.) then print*,' ' print*,'ENTER: subroutine read_acswfc_flt_full ' print*,'---> FILENAME: ',FILENAME print*,' ' endif NAXIS1 = int(r8_query_hdre(FILENAME,'NAXIS1 ',-1)) NAXIS2 = int(r8_query_hdre(FILENAME,'NAXIS2 ',-1)) if (NAXIS1.lt.4096.and.NAXIS2.lt.2048) . stop 'only FLT ACS full frame (for now)' CRPIX1 = r8_query_hdre(FILENAME,'CRPIX1 ',-1) CRPIX2 = r8_query_hdre(FILENAME,'CRPIX2 ',-1) CRVAL1 = r8_query_hdre(FILENAME,'CRVAL1 ',-1) CRVAL2 = r8_query_hdre(FILENAME,'CRVAL2 ',-1) PA_APER = r8_query_hdre(FILENAME,'PA_APER ',-1) PA_V3 = PA_APER + 0.2181083 COSPA = cos(PA_V3*3.14159/180.0) SINPA = sin(PA_V3*3.14159/180.0) CD1_1 = -COSPA*0.049730/60/60 CD1_2 = SINPA*0.049730/60/60 CD2_1 = SINPA*0.049730/60/60 CD2_2 = COSPA*0.049730/60/60 PROP = i4_query_hdre(FILENAME,'PROPOSID',-1) EXPT = r4_query_hdre(FILENAME,'EXPTIME ',-1) RDAT = SNGL(rdate_header(FILENAME)) call query_hdre(FILENAME,'FILTER ',FILTU,-1) call query_hdre(FILENAME,'FILTER1 ',FILT1,-1) call query_hdre(FILENAME,'FILTER2 ',FILT2,-1) call query_hdre(FILENAME,'FILTNAM1',FILT3,-1) call query_hdre(FILENAME,'FILTNAM2',FILT4,-1) call query_hdre(FILENAME,'APERTURE',APERTURE,-1) FILT = FILTU(1:5) if (FILT1(1:1).eq.'F') FILT = FILT1(1:5) if (FILT2(1:1).eq.'F') FILT = FILT2(1:5) if (FILT3(1:1).eq.'F') FILT = FILT3(1:5) if (FILT4(1:1).eq.'F') FILT = FILT4(1:5) if (FILT1(2:2).eq.'F') FILT = FILT1(2:6) if (FILT2(2:2).eq.'F') FILT = FILT2(2:6) if (FILT3(2:2).eq.'F') FILT = FILT3(2:6) if (FILT4(2:2).eq.'F') FILT = FILT4(2:6) LOFLAG = -50 HIFLAG = 76000 GAIN = 2 GAIN = r4_query_hdre(FILENAME,'CCDGAIN ',-1) if (GAIN.eq.1) HIFLAG = 55000 do i = 1, 4 do j = 1, 4 BDRY_XR(i,j) = 0. BDRY_YR(i,j) = 0. enddo enddo BDRY_XR(1,2) = 0001 BDRY_YR(1,2) = 0001 BDRY_XR(2,2) = 4095 BDRY_YR(2,2) = 0001 BDRY_XR(3,2) = 4095 BDRY_YR(3,2) = 2047 BDRY_XR(4,2) = 0001 BDRY_YR(4,2) = 2047 BDRY_XR(1,1) = 0001 BDRY_YR(1,1) = 2049 BDRY_XR(2,1) = 4095 BDRY_YR(2,1) = 2049 BDRY_XR(3,1) = 4095 BDRY_YR(3,1) = 4095 BDRY_XR(4,1) = 0001 BDRY_YR(4,1) = 4095 if (_SKIPPX_) then do i = 0001, 4096 do j = 0001, 4096 pix(i,j) = -750 enddo enddo goto 444 endif c P000003 L21 E00 APERTURE= 'WFC1B-2K ' / aperture name 00001 jehr02leq_flt.fits if (APERTURE(2:9).eq.'WFC1B-2K') then call readfits_r4e(FILENAME,pix2k2k,2048,2048,1) call readfits_i2e(FILENAME,pxd2k2k,2048,2048,3) allocate(pxd(4096,4096)) do i = 0001, 4096 do j = 0001, 4096 pix(i,j) = -750 pxd(i,j) = -750 enddo enddo do i = 0001, 2048 do j = 0001, 2048 pix(i+2048,j+2048) = pix2k2k(i,j) pxd(i+2048,j+2048) = pxd2k2k(i,j) enddo enddo do i = 0001, 4096 do j = 0001, 4096 if (iand(pxd(i,j),int( 256,2)).gt.0) pxq(i,j) = 1 ! physical saturation if (iand(pxd(i,j),int(2048,2)).gt.0) pxq(i,j) = 1 ! a2d saturation enddo enddo deallocate(pxd) goto 444 endif if (str_contains(FILENAME,200,'_flt.fits',09).or. . str_contains(FILENAME,200,'_flc.fits',09).or. . str_contains(FILENAME,200,'_crj.fits',09).or. . str_contains(FILENAME,200,'_crc.fits',09)) then call readfits_WFC(FILENAME,pix(0001,2049),4) call readfits_WFC(FILENAME,pix(0001,0001),1) allocate(pxd(4096,4096)) call readfits_i2e(FILENAME,pxd(0001,2049),4096,2048,6) call readfits_i2e(FILENAME,pxd(0001,0001),4096,2048,3) do i = 0001, 4096 do j = 0001, 4096 if (iand(pxd(i,j),int( 256,2)).gt.0) pxq(i,j) = 1 ! physical saturation if (iand(pxd(i,j),int(2048,2)).gt.0) pxq(i,j) = 1 ! a2d saturation enddo enddo deallocate(pxd) goto 444 endif if (str_contains(FILENAME,200,'_WJC.fits',09).or. . str_contains(FILENAME,200,'_WJX.fits',09).or. . str_contains(FILENAME,200,'_WXC.fits',09).or. . str_contains(FILENAME,200,'_WJ2.fits',09)) then call readfits_j2r(FILENAME,pix(0001,0001),4096,4096) goto 444 endif if (str_contains(FILENAME,200,'_raw.fits',09)) then call readfits_acsraw2r(FILENAME,pix) goto 444 endif if (str_contains(FILENAME,200,'_raz.fits',09).or. . str_contains(FILENAME,200,'_rzc.fits',09)) then allocate(pxz(8288,2068)) call readfits_r4(FILENAME,pxz,8288,2068) do i = 0001, 2048 do j = 0001, 2048 pix(i+0000,j+0000) = pxz(0*2072+24+i,j) pix(4097-i,j+0000) = pxz(1*2072+24+i,j) pix(i+0000,4097-j) = pxz(2*2072+24+i,j) pix(4097-i,4097-j) = pxz(3*2072+24+i,j) enddo enddo deallocate(pxz) goto 444 endif print*,'PROB : subroutine read_acswfc_flt_full ' print*,' could not read in file: ' print*,' ',FILENAME stop 444 continue do i = 0001, 4096 do j = 2046, 2051 pix(i,j) = -750 enddo enddo c if (GAIN.eq.1) then c do i = 0001, 4096 c do j = 0001, 4096 c if (pix(i,j).gt.55000) pix(i,j) = 71500 c enddo c enddo c endif return end subroutine readfits_WFC(FILE,pix,nimg) implicit none character*(*) FILE real pix(4096,2048) character*70 INFO(10) common / fitsinfo / INFO integer nimg integer naxes integer laxis(3) character*8 field character*20 stream integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer ifirst, i1, i2 integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix logical LINUX data LINUX/.true./ logical first_header integer NH_RECs character*2880 HEADER_STRING(99) common /HEADER_STRING_INFO/NH_RECs,HEADER_STRING character*200 FILEu FILEu = 'NONE' do i = 1, 195 if (FILE(i:i).eq.' ') then print*,'readfits_WJC filename problem' print*,' space before .fits ' print*,' FILE: ',FILE stop endif if (FILE(i:i+4).eq.'.fits') then FILEu = FILE(1:i+4) goto 3 endif enddo if (FILE(i:i).eq.' ') then print*,'readfits_WJC filename problem' print*,' space before .fits ' print*,' FILE: ',FILE stop endif 3 continue open(10,file=FILEu,status='old',iostat=ios, . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') bscale = 1.0 bzero = 0.0 naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 NH_RECs = 0 first_header = .true. i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buffc if (first_header) then NH_RECs = NH_RECs + 1 HEADER_STRING(NH_RECs) = buffc endif do k = 0, 35, 1 field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+31) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'END ') then first_header = .false. goto 101 endif enddo goto 100 101 continue nread = nread + 1 ifirst = i+1 i1 = i i2 = i if (naxes.eq.0) then ! maybe multiple images stored as extensions if (nextend.eq.0) then print*,'THIS IS A NULL IMAGE: ' print*,'NAXES: ',NAXES print*,'NEXND: ',NEXTEND stop endif endif if (nread.ne.nimg+1) then nbper = abs(BITPIX/8)*laxis(1)*laxis(2) if (NAXES.eq.0) nbper = 0 i = int(i + 1.0*nbper/2880 + 0.9999) goto 100 endif if (laxis(1).ne.4096.or. . laxis(2).ne.2048) then print*,' laxis1: ',laxis(1) print*,' laxis2: ',laxis(2) print*,' 4096: ',4096 print*,' 2048: ',2048 stop endif if (naxes.eq.2) then ! nimg is irrelevant; ignore nbper = 4*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 endif if (naxes.eq.3) then nbper = 4*laxis(1)*laxis(2) nbyte1 = 1 + nbper*(nimg-1) nbyte2 = nbper*(nimg ) i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 npt = laxis(1)*laxis(2) endif do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 call buff2pix_r4_wfc(buffb,pix,np1,npt) enddo return 900 continue print*,'readfits_WFC: READFITS ERROR' print*,'FILE : ',FILE print*,'FILEu: ',FILEu print*,' ios: ',ios stop end subroutine buff2pix_r4_wfc(buff,pix,n1,nt) implicit none byte buff(2880) real pix(*) integer n1,nt byte b(4) real r equivalence(r,b) integer i, npu, nbu do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (.not.(_LINUX_)) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) b(3) = buff(nbu+3) b(4) = buff(nbu+4) endif if ((_LINUX_)) then b(4) = buff(nbu+1) b(3) = buff(nbu+2) b(2) = buff(nbu+3) b(1) = buff(nbu+4) endif if (npu.ge.1.and.npu.le.nt) pix(npu) = r enddo return end subroutine sub_wfcacs_readraw2raz(FILEI,pixz) implicit none character*80 FILEI real*4 pixz(8288,2068) c---------------------- c c progression of fix... c real, dimension(:,:,:), allocatable :: pixa0 ! original amp real pixa1(2072,2068,4) ! corrected for ref-pixels real, dimension(:,:,:), allocatable :: pixa1 ! ref pixels corrected for column real, dimension(:,:,:), allocatable :: pixa2 ! whole image corrected for average real, dimension(:,:,:), allocatable :: pixa3 ! whole image corrected for column/average/row integer i,j,k real*8 barj(2068) real*8 sigj(2068) real refbar(4), refsig(4) integer refuse(4) real refcolbar(24,4) real refcolsig(24,4) real*8 ptot integer ntot real*8 bark(4), barb real*8 sigk(4) c real dx real rj integer jj real fj byte rowuse(2068,4) real rowref(2068,4) real rowbar(2068,4) integer rowtot(4) byte usek(2068,4) integer nskip integer nfixd character*80 FILEB character*80 FILEO integer n integer Ls, Lu real*8 xl(9999), xbar, xsig real*8 bias_shift_bar_kn(4,16) real*8 bias_shift_sig_kn(4,16) integer NARG real rn, fn integer nn real bias_shift(4,17) data bias_shift / . 0.0000, 0.0000, 0.0000, 0.0000, . 2.7270, 2.6762, 2.4282, 2.4256, . 5.2498, 5.1106, 4.4137, 4.7800, . 7.3278, 7.0069, 5.6505, 7.0362, . 9.0420, 8.2736, 6.4285, 8.7642, . 10.3455, 9.1745, 7.0294, 9.8053, . 11.4173, 9.7687, 7.5445, 10.5576, . 12.3301, 10.1248, 8.0041, 11.2053, . 13.0142, 10.5457, 8.3000, 11.9011, . 13.7405, 10.9688, 8.3529, 12.5295, . 14.0843, 11.1583, 8.5229, 13.0714, . 14.4022, 11.2714, 8.6627, 13.5581, . 15.0245, 11.3666, 8.8438, 14.0528, . 15.5655, 11.5520, 9.0489, 14.4749, . 15.9700, 11.7052, 9.1862, 14.6787, . 16.1995, 11.7212, 9.2854, 14.9770, . 16.4175, 11.8703, 9.1763, 15.4222/ real*4, dimension(:,:), allocatable :: pix1 real*4, dimension(:,:), allocatable :: pix4 integer GAIN real r4_query_hdre allocate(pixa0(2072,2068,4)) allocate(pixa1(2072,2068,4)) allocate(pixa2(2072,2068,4)) allocate(pixa3(2072,2068,4)) allocate(pix1(4144,2068)) allocate(pix4(4144,2068)) if (FILEI(10:18).ne.'_raw.fits') then print*,' ' print*,'FILENAME must have the string "_raw.fits" ' print*,' characters 10 through 18.' print*,' ' print*,' restrictive, I know... ' print*,' ' stop endif c------------------------------------------------------ c c output image will have _rrs.fits instead of _raw.fits c FILEB = FILEI FILEO = FILEI FILEO(11:13) = 'raz' write(*,*) write(*,'(''INPUT INT*2: '',a18)') FILEI(01:18) write(*,'(''OUTPUT REAL*4: '',a18)') FILEO(01:18) write(*,*) c------------------------------------------------------ c c read-in the pixel data into 3-d arrays: (2072x2068x4) c one per amplifier c print*,'read_acsraw_pixa...' call read_acsraw_pixa(FILEI,pixa0) GAIN = 2 GAIN = int(r4_query_hdre(FILEI,'CCDGAIN ',-1) + 0.5) c------------------------------------------------------ c c STEP1: compute the column-by-column residual for each c column in the reference pixels of each amplifier c remove the trend so that the ref pixels are flat. c print*,'------------------------------------------------------' print*,' ' print*,'STEP1: FIND COLUMN BY COLUMN DEPENDENCE...' print*,' ' do k = 1, 4 call find_refcol(pixa0(1,1,k),refcolbar(1,k),refcolsig(1,k)) call subt_refcol(pixa0(1,1,k),refcolbar(1,k), . pixa1(1,1,k)) enddo c c this output just shows the column-by-column trends for c each amplifier, and also shows how similar the columns c are with respect to one another. c print*,' ' print*,' AMP --- AVERAGE COLUMN RESPONSE (DNs)' print*,' ' write(*,'(9x,1x,3x,24(1x,''i='',i2.2))') (i,i=1,24) do k = 1, 4 write(*,'(9x,i1,3x,24(1x,f4.1))') k,(refcolbar(i,k),i=1,24) enddo print*,' ' print*,' AMP --- RMS BY COLUMN (DNs)' print*,' ' write(*,'(9x,1x,3x,24(1x,''i='',i2.2))') (i,i=1,24) do k = 1, 4 write(*,'(9x,i1,3x,24(1x,f4.1))') k,(refcolsig(i,k),i=1,24) enddo print*,' ' c--------------------------------------------------------- c c STEP2: Figure out which rows have too much flux to use as c reference pixels; at some point if we get the bias c drift calibrated, then we may be able to make some c of the reference pixels usable again; but until then, c it's best to just flag as unusable those that have c too much signal; for this, I use an average of 75 DN, c which amounts to about 0.4 DN of throw in the bias. c print*,'------------------------------------------------------' print*,' ' print*,'STEP2: FIND COMPROMISED ROWS...' print*,' ' print*,' AMP ROW_USE ROW_REJ' do k = 1, 4 rowuse(1,k) = 0 ! never use the first row rowtot(k) = 0 ptot = 0. do i = 0001, 0024 ptot = ptot + pixa1(i,1,k) enddo rowref(1,k) = SNGL(ptot/24) rowbar(1,k) = 0.00 do j = 0002, 2068 ptot = 0. do i = 0001, 0024 ptot = ptot + pixa1(i,j-1,k) ptot = ptot + pixa1(i,j ,k) ! use avg ref corr... enddo rowref(j,k) = SNGL(ptot/48) ptot = 0. do i = 0025, 2072 ptot = ptot + (pixa1(i,j,k)-rowref(j,k)) enddo rowbar(j,k) = SNGL(ptot/2048) rowuse(j,k) = 1 c c conditions under which we should not use this row to c tell us about the row-by-row 1/f-noise correction c if (rowbar(j,k).gt.99) rowuse(j,k) = 0 ! average pixel value of less than 100 e-... if (pixa1(25,j,k).gt.25000) rowuse(j,k) = 0 ! near-saturated pixel that may have bled into... if (pixa1(26,j,k).gt.25000) rowuse(j,k) = 0 if (pixa1(27,j,k).gt.25000) rowuse(j,k) = 0 if (pixa1(28,j,k).gt.25000) rowuse(j,k) = 0 if (pixa1(29,j,k).gt.25000) rowuse(j,k) = 0 if (pixa1(30,j,k).gt.25000) rowuse(j,k) = 0 rowtot(k) = rowtot(k) + rowuse(j,k) enddo write(*,'(10x,i1,7x,i4,5x,i4)') k,rowtot(k),2067-rowtot(k) ! report the number of good rows per amp enddo print*,' ' c-------------------------------------------------------- c c STEP3: Compute the average DC offset for each amplifier c Use the good reference rows to determine the c average ref-pixel correction for each amplifier. c Then remove it. There is double insurance against c bad rows coming in. We start using only the good c rows, but we also find a robust, sigma-clipped c mean of the remaining rows. c print*,'------------------------------------------------------' print*,' ' print*,'STEP3: AVERAGE REFERENCE SUB (DNs)' print*,' ' write(*,119) 119 format(12x,'AMP',3x,' BLEV ',7x,' SIGMA', . 3x,'NREF_USE',3x,'NREF_REJ') 118 format(12x,i3, 3x,f8.2, 7x,f8.2, . 3x,i8,3x,i8) do k = 1, 4 call find_refbar(pixa1(1,1,k),rowuse(1,k), . refbar(k),refsig(k),refuse(k),6.0) call subt_refbar(pixa1(1,1,k),refbar(k), . pixa2(1,1,k)) write(*,118) k,refbar(k),refsig(k), ! output the RMS . refuse(k), . 24*2068-refuse(k) enddo print*,' ' c---------------------------------------------- c c this is not needed for the BLEV_COR stage; c it's a diagnostic to help me see how the bias c drift correlates with signal in the pixel c c call dump_testf(pixa2,NARG) c-------------------------------------------------- c c STEP4: find the line-by-line reference correction; c use only the lines that we believe should be c good from each amplifier c print*,'------------------------------------------------------' print*,' ' print*,'STEP4: DEFINE REF CORRECTION LINE BY LINE...' print*,' (assume all 4 amps are the same) ' nskip = 0 nfixd = 0 do j = 0001, 2068 ! go through line by line... do k = 01, 04 ptot = 0. do i = 01, 24 ptot = ptot + pixa2(i,j,k) enddo bark(k) = ptot/24 enddo do k = 01, 04 ptot = 0. do i = 01, 24 ptot = ptot + (pixa2(i,j,k)-bark(k))**2 enddo sigk(k) = sqrt(ptot/(24-1)) enddo do k = 1, 4 usek(j,k) = 0 if (sigk(k).lt.7.5.and.rowuse(j,k).eq.1) usek(j,k) = 1 enddo c c usek(j,k) now contains 1 for the amplifiers where the row c is usable; things can be unusable either because c (1) they have saturated pixels too close c (2) the flux in that row is high enough to make c the bias-drift correction significant c (3) the rms of the 24 pixels within the ref row are c greater than 7.5 DN (typical is 2) c ptot = 0. ntot = 0 do k = 1, 4 ptot = ptot + usek(j,k)*bark(k) ntot = ntot + usek(j,k) enddo barj(j) = 0. sigj(j) = 0. if (ntot.ge.2) then ! give this row a row-specific barj(j) = ptot/ntot ! correction only if there are ptot = 0. ! at least two amps contributing, do k = 1, 4 ! otherwise, use no row correction ptot = ptot + usek(j,k)*(bark(k)-barj(j))**2 enddo sigj(j) = sqrt(ptot/(ntot-1))/sqrt(1.*ntot) endif c write(77,177) NARG,j,barj(j), sigj(j), ntot, ! this is just diagnostic; it allows c . (bark(k),k=1,4), ! me to plot the correction implied for c . (sigk(k),k=1,4), ! a given row for amp1 against that for c . (usek(j,k),k=1,4), ! amp2; they should be well correlated c . (rowbar(j,k),k=1,4) c . c 177 format(i4,1x,i4.4,1x,f8.4,1x,f8.4,1x,i1, c . 5x,4f8.4, c . 5x,4f8.4, c . 5x,4i2, c . 5x,f8.1) if (ntot.ge.2) nfixd = nfixd + 1 ! keep a tally of how many rows have the 1/f if (ntot.lt.2) nskip = nskip + 1 ! correction performed enddo write(*,*) write(*,'(10x,'' ROWS FIXED: '',i4)') nfixd write(*,'(10x,'' ROWS SKIPD: '',i4)') nskip write(*,*) c c Now that we have the row-based correction, determine which c correction to use for each pixel. Pixels in the data image c are somewhere between the reference pixels of their row and c those of the row above; use linear interpolation to determine c how to weight them. I could use a spline to do this, but c maybe that's overkill... c do i = 0001, 2072 do j = 0001, 2068 rj = j + (i-12.50)/(2072.0+146.0) jj = int(rj) if (jj.lt.0001) jj = 0001 if (jj.gt.2067) jj = 2067 fj = rj-jj barb = barj(jj) + fj*(barj(jj+1)-barj(jj)) do k = 1, 4 pixa3(i,j,k) = SNGL(pixa2(i,j,k) - barb) enddo enddo enddo print*,' ' c-------------------------------------------------- c c STEP5: output the results c print*,'------------------------------------------------------' print*,' ' print*,'STEP5: OUTPUT THE RESULTS... ' print*,' ' c--------------------------------------------------- c c The full correction. Includes c (1) column correction for each amp, c (2) average for ref-pixel correction for each amp, c (3) and the average row-by-row correction over c the four amps c call pixa2pix14(pixa3,pix1,pix4) ! copies the by-amp cube into by-chip images do i = 0001, 2072 do j = 0001, 2068 pixz(i+(1-1)*2072,j) = pixa3(i,j,1)*2.0170000E+00 ! calibrated gain for amplifier C ATODGNC pixz(i+(2-1)*2072,j) = pixa3(i,j,2)*2.0109999E+00 ! calibrated gain for amplifier D ATODGND pixz(i+(3-1)*2072,j) = pixa3(i,j,3)*2.0200000E+00 ! calibrated gain for amplifier A ATODGNA pixz(i+(4-1)*2072,j) = pixa3(i,j,4)*1.8860000E+00 ! calibrated gain for amplifier B ATODGNB enddo enddo if (GAIN.eq.1) then do i = 0001, 8288 do j = 0001, 2068 pixz(i,j) = pixz(i,j)/2 if (pixz(i,j).gt.50000) pixz(i,j) = 65000 enddo enddo endif do k = 1, 4 do i = 0001, 2048 rn = 1 + i/128.0 nn = int(rn) fn = rn-nn xbar = bias_shift(k,nn) . + fn*(bias_shift(k,nn+1) . -bias_shift(k,nn )) do j = 0001, 2068 pixz(24+(k-1)*2072+i,j) = . SNGL(pixz(24+(k-1)*2072+i,j) - xbar) enddo enddo enddo if (.false.) then print*,' ' print*,' ' do n = 01, 16 do k = 1, 4 Ls = 0 do i = max(0001,(n-2)*128+64), . min(2048,(n-1)*128+64) do j = 2063, 2068 Ls = Ls + 1 xl(Ls) = pixz(24+(k-1)*2072+i,j) enddo enddo call barsiga(xl,Ls,xbar,xsig,2.25,Lu) bias_shift_bar_kn(k,n) = xbar bias_shift_sig_kn(k,n) = xsig enddo write(91,'(i3,1x,i2,5x,4f10.3,5x,4f10.3,5x,4f10.3)') . NARG,n, . (bias_shift_bar_kn(k,n),k=1,4), . (bias_shift_sig_kn(k,n),k=1,4), . (bias_shift_bar_kn(k,n) . -bias_shift_bar_kn(k,1),k=1,4) write(* ,'(i3,1x,i2,5x,4f10.3,5x,4f10.3,5x,4f10.3)') . NARG,n, . (bias_shift_bar_kn(k,n),k=1,4), . (bias_shift_sig_kn(k,n),k=1,4), . (bias_shift_bar_kn(k,n) . -bias_shift_bar_kn(k,1),k=1,4) enddo print*,' ' print*,' ' endif c call cowritfits_raw_r4w(FILEI,FILEO,pix1,pix4) ! output the chips, using the fits-header of the input image c call writfits_r4h(FILEO,pixz,8288,2068,STRING_HEAD) c--------------------------------------------------- c c all but the row-by-row correction... c c call pixa2pix14(pixa2,pix1,pix4) c call cowritfits_raw_r4w(FILEI,FILEB,pix1,pix4) deallocate(pixa0) deallocate(pixa1) deallocate(pixa2) deallocate(pixa3) return end c--------------------------------------------- c c convert from x-extended format to amp format c subroutine pixb2pixa(pixb0,pixa0) implicit none real pixb0(8288,2068) real pixa0(2072,2068,4) integer i, j, k do k = 1, 4 do i = 0001, 2072 do j = 0001, 2068 pixa0(i,j,k) = pixb0(i+(k-1)*2072,j) enddo enddo enddo return end c--------------------------------------------- c c convert from amp format to x-extended format c subroutine pixa2pixb(pixa,pixb) implicit none real pixa(2072,2068,4) real pixb(8288,2068) integer i, j, k do k = 1, 4 do i = 0001, 2072 do j = 0001, 2068 pixb(i+(k-1)*2072,j) = pixa(i,j,k) enddo enddo enddo return end c-------------------------------------------------------------- c c this will read-in a standard-format _raw image into a c three-dimensional array, 2072x2068 for each of the 4 amps c subroutine read_acsraw_pixa(FILENAME,pix_ijk) implicit none character*80 FILENAME real pix_ijk(2072,2068,4) integer*2, dimension(:,:), allocatable :: pixi integer i, j print*,'enter read-acsraw_pixa...' allocate(pixi(4144,2068)) call readfits_i2e(FILENAME,pixi,4144,2068,1) do i = 0001, 2072 do j = 0001, 2068 pix_ijk(i,j,1) = pixi(0000+i,0000+j)+32768 pix_ijk(i,j,2) = pixi(4145-i,0000+j)+32768 enddo enddo call readfits_i2e(FILENAME,pixi,4144,2068,4) do i = 0001, 2072 do j = 0001, 2068 pix_ijk(i,j,3) = pixi(0000+i,2069-j)+32768 pix_ijk(i,j,4) = pixi(4145-i,2069-j)+32768 enddo enddo deallocate(pixi) return end c-------------------------------------------------------------- c c this routine will subtract the average reference-pixel value c from each amplifer c subroutine subt_refbar(pix_ij_bef,refbar, . pix_ij_aft) real pix_ij_bef(2072,2068) real refbar real pix_ij_aft(2072,2068) integer i, j do j = 0001, 2068 do i = 0001, 2072 pix_ij_aft(i,j) = pix_ij_bef(i,j) - refbar enddo enddo return end c-------------------------------------------------------------- c c c subroutine avg_overk(psplink,psplinb,psplins,Ns) implicit none integer Ns real psplink(Ns,4) real psplinb(Ns) real psplins(Ns) integer n do n = 1, Ns psplinb(n) = (psplink(n,1)+psplink(n,2) . +psplink(n,3)+psplink(n,4))/4.0 psplins(n) = (abs(psplink(n,1)-psplinb(n)) . +abs(psplink(n,2)-psplinb(n)) . +abs(psplink(n,3)-psplinb(n)) . +abs(psplink(n,4)-psplinb(n)))/3.0 enddo return end c-------------------------------------------------------------- c c subroutine subt_refspline(pix_ij,vsplinb) implicit none real pix_ij(2072,2068) real vsplinb(2068) integer i, j real vcor real f do j = 0001, 2068 do i = 0001, 2072 f = (i-12.5)/(2072.00-12.5) if (f.lt.0) f = 0.0 vcor = vsplinb(2068) if (i.le.2067) then vcor = (1-f)*vsplinb(j ) . + ( f )*vsplinb(j+1) endif pix_ij(i,j) = pix_ij(i,j) - vcor enddo enddo return end subroutine pixa2pix14(pix_ijk,pix1,pix4) implicit none real pix_ijk(2072,2068,4) real pix1(4144,2068) real pix4(4144,2068) integer i, j do i = 0001, 2072 do j = 0001, 2068 pix1(0000+i,0000+j) = pix_ijk(i,j,1) pix1(4145-i,0000+j) = pix_ijk(i,j,2) enddo enddo do i = 0001, 2072 do j = 0001, 2068 pix4(0000+i,2069-j) = pix_ijk(i,j,3) pix4(4145-i,2069-j) = pix_ijk(i,j,4) enddo enddo return end c------------------------------------------------------------- c c subroutine copy_pixa(pixa1,pixa2) implicit none real pixa1(2072,2068,4) real pixa2(2072,2068,4) integer i, j, k do k = 1, 4 do i = 0001, 2072 do j = 0001, 2068 pixa2(i,j,k) = pixa1(i,j,k) enddo enddo enddo return end c----------------------------------------------------- c c will write a real*4 into the header-shell of an c integer*2 raw image (FILEI) c c There are 6 extensions total, but only #1 and #4 c have any data. c subroutine cowritfits_raw_r4w(FILEI,FILEO,pix1,pix4) implicit none character*80 FILEI, FILEO real*4 pix1(4096,2048) real*4 pix4(4096,2048) c integer nimg integer naxes integer laxis(3) character*8 field character*20 stream integer nbyte0 integer nbyteE integer nbperi, nbyte1i, nbyte2i, npti integer nbperj, nbyte1j, nbyte2j, nptj integer ios, k! , kk character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer np1, np2 integer NREAD c integer bitpix c real dtde_l(11) c real chg_leak(4,17) c common /dtde_l_ /dtde_l c common /chg_leak_/chg_leak logical atend real rDAT character*12 DATESTR character*12 TIMESTR common /rDAT_/rDAT,DATESTR,TIMESTR real CTE_FRAC common /CTE_FRAC_/CTE_FRAC integer NMOD common /MMOD_/NMOD character*11 HOW(4) integer NIT2DO common/NIT2DO_/NIT2DO real pix1min, pix1max real pix4min, pix4max integer i, ifirst, i1, i2 integer j, jfirst, j1, j2 logical DIAG common /DIAG_/DIAG data DIAG/.false./ pix1min = 0.0 pix1max = 0.0 pix4min = 0.0 pix4max = 0.0 do i = 0001, 4144 do j = 0001, 2068 if (pix1(i,j).lt.pix1min) pix1min = pix1(i,j) if (pix4(i,j).lt.pix4min) pix4min = pix4(i,j) if (pix1(i,j).gt.pix1max) pix1max = pix1(i,j) if (pix4(i,j).gt.pix4max) pix4max = pix4(i,j) enddo enddo if (DIAG) then print*,'---> pix1min: ',pix1min, pix1max print*,'---> pix4min: ',pix4min, pix4max endif HOW(1) = 'NONE ' HOW(2) = 'LINEAR-3 ' HOW(3) = 'QUADRATIC-5' HOW(4) = 'LINEAR-5 ' if (.true.) then print*,' ENTER COWRITE_RAW: ' print*,' ----> FILEI: ',FILEI(1:30) print*,' ----> FILEO: ',FILEO(1:30) print*,' ' endif if (DIAG) print*,'OPEN10 FILEI: ',FILEI open(10,file=FILEI,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') HOW(1) = 'NONE ' HOW(2) = 'LINEAR-3 ' HOW(3) = 'QUADRATIC-5' HOW(4) = 'LINEAR-5 ' if (DIAG) then print*,'ENTER COWRITE_RAW: ' print*,' ----> FILEI: ',FILEI(1:30) print*,' ----> FILEO: ',FILEO(1:30) endif if (DIAG) print*,'OPEN10 FILEI: ',FILEI open(10,file=FILEI,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') if (DIAG) print*,'OPEN11 FILEO: ',FILEO open(11,file=FILEO,status='unknown', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') i = 0 j = 0 NREAD = -1 099 continue NREAD = NREAD + 1 if (DIAG) print*,' ' naxes = 0 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 100 continue i = i + 1 j = j + 1 if (DIAG) write(*,'(80(''-''))') read(10,rec=i,iostat=ios) buffc atend = .false. do k = 00, 35 if (DIAG) . write(*,'(''NREAD='',i1,3x, . ''IREC='',i9.9,1x, . ''JREC='',i9.9,1x,i2,1x,a80)') . NREAD,i,j,k,buffc(k*80+1:k*80+80) field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+31) if (NREAD.eq.1.or.NREAD.eq.4) then if (field.eq.'BITPIX ') write(buffc(k*80+01:k*80+80),111) 111 format('BITPIX = -32 / bits pe', . 'r data value ') if (field.eq.'BZERO ') write(buffc(k*80+01:k*80+80),112) 112 format('BZERO = 0.0 / physica', . 'l value for an array value of zero ') endif if (NREAD.eq.1) then if (field.eq.'DATAMIN ') . write(buffc(k*80+01:k*80+80),113) pix1min if (field.eq.'DATAMAX ') . write(buffc(k*80+01:k*80+80),114) pix1max endif if (NREAD.eq.4) then if (field.eq.'DATAMIN ') . write(buffc(k*80+01:k*80+80),113) pix4min if (field.eq.'DATAMAX ') . write(buffc(k*80+01:k*80+80),114) pix4max endif 113 format('DATAMIN = ',f8.2,' / physica', . 'l value for an array value of zero ') 114 format('DATAMAX = ',f8.2,' / physica', . 'l value for an array value of zero ') if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (buffc(k*80+01:k*80+3).eq.'END') atend = .true. enddo if (.not.atend) then write(11,rec=j,iostat=ios) buffc goto 100 endif write(11,rec=j,iostat=ios) buffc if (DIAG) then print*,' ' print*,'PROCESS...' print*,' NREAD = ',NREAD print*,' NAXIS = ',NAXES print*,' LAXIS1= ',laxis(1) print*,' LAXIS2= ',laxis(2) print*,' ' endif if (NREAD.eq.6) then close(10) close(11) return endif if (naxes.eq.0) goto 099 ifirst = i+1 ! first record of the image in this extension jfirst = j+1 ! first record of the image in this extension nbperi = 2*laxis(1)*laxis(2) npti = laxis(1)*laxis(2) nbyte1i = 1 nbyte2i = nbperi i1 = i+1 + nbyte1i/2880 i2 = i+1 + nbyte2i/2880 nbperj = 4*laxis(1)*laxis(2) nptj = laxis(1)*laxis(2) nbyte1j = 1 nbyte2j = nbperj j1 = j+1 + nbyte1j/2880 j2 = j+1 + nbyte2j/2880 if (NREAD.eq.2.or.NREAD.eq.3.or. . NREAD.eq.5.or.NREAD.eq.6) then print*,'NREAD = ',NREAD print*,'naxes = ',naxes print*,'we shouldnt be here for anything' print*,'but NREAD=1 and NREAD=4 ' stop endif if (NREAD.eq.1) then if (DIAG) print*,'NREAD = 1... OUTPUT IMAGE' do j = j1, j2, 1 nbyte0 = (j-jfirst)*2880+ 1 nbyteE = (j-jfirst)*2880+2880 np1 = (nbyte0-nbyte1j)/4 + 1 np2 = (nbyteE-nbyte1j)/4 + 1 call pix2buff_r4_(buffb,pix1,np1,nptj) write(11,rec=j,iostat=ios) buffc enddo i = i2 j = j2 goto 099 endif if (NREAD.eq.4) then if (DIAG) print*,'NREAD = 4... OUTPUT IMAGE' do j = j1, j2, 1 nbyte0 = (j-jfirst)*2880+ 1 nbyteE = (j-jfirst)*2880+2880 np1 = (nbyte0-nbyte1j)/4 + 1 np2 = (nbyteE-nbyte1j)/4 + 1 call pix2buff_r4_(buffb,pix4,np1,nptj) write(11,rec=j,iostat=ios) buffc enddo i = i2 j = j2 goto 099 endif print*,'cowrite_raw_rbc should never get here...' stop return 900 continue print*,'cowritefits_raw: READFITS ERROR' stop end c------------------------------------------------------- c c subroutine pix2buff_r4_(buff,pix,n1,nt) implicit none byte buff(2880) real*4 pix(*) integer n1,nt byte b(4) real*4 r equivalence(r,b) integer i, npu, nbu do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (npu.ge.1.and.npu.le.nt) r = pix(npu) if (.not.(_LINUX_)) then buff(nbu+1) = b(1) buff(nbu+2) = b(2) buff(nbu+3) = b(3) buff(nbu+4) = b(4) endif if ((_LINUX_)) then buff(nbu+1) = b(4) buff(nbu+2) = b(3) buff(nbu+3) = b(2) buff(nbu+4) = b(1) endif enddo return end c------------------------------------------------ c c find the average value of the reference pixels; c with sigma clipping at SIG_CLIP c c subroutine find_refbar(pix_ij,rowuse, . refbar,refsig,refuse,SIG_CLIP) implicit none real pix_ij(2072,2068) byte rowuse(2068) real refbar real refsig integer refuse real SIG_CLIP integer i, j real*8 stot real*8 ptot integer ntot integer ntoto real*8 bar, sig byte pixu(24,2068) integer NIT ntot = 0 do i = 0001, 0024 do j = 0001, 2068 pixu(i,j) = rowuse(j) ntot = ntot + pixu(i,j) enddo enddo NIT = 0 1 continue ntoto = ntot NIT = NIT + 1 ptot = 0. ntot = 0 do i = 0001, 0024 do j = 0001, 2068 ptot = ptot + pixu(i,j)*pix_ij(i,j) ntot = ntot + pixu(i,j) enddo enddo bar = ptot/ntot stot = 0. do i = 0001, 0024 do j = 0001, 2068 stot = stot + pixu(i,j)*abs(pix_ij(i,j)-bar) enddo enddo sig = stot/ntot ntot = 0 do i = 0001, 0024 do j = 0001, 2068 if (abs(pix_ij(i,j)-bar).gt.SIG_CLIP*sig) pixu(i,j) = 0 ntot = ntot + pixu(i,j) enddo enddo close(31) if (NIT.le.05) goto 1 if (NIT.le.10.and.ntot.lt.ntoto) goto 1 ! iterate max 10 times; only repeat if we've rejected pixels refbar = SNGL(bar) refsig = SNGL(sig) refuse = ntot stot = 0. ntot = 0 do i = 0001, 0024 do j = 0001, 2068 stot = stot + pixu(i,j)*(pix_ij(i,j)-bar)**2 ntot = ntot + pixu(i,j) enddo enddo refsig = SNGL(sqrt(stot/ntot)) return end c-------------------------------------------------------------- c c this will find the column-by-column residual for each row c refcolbar(i) is the average of each column relative c refcolsig(i) is the sigma along the column c subroutine find_refcol(pix_ij,refcolbar,refcolsig) implicit none real pix_ij(2072,2068) real refcolbar(24) real refcolsig(24) integer i, j real*8 ptot real*8 pnorm(24,2068) real*8 collist(2068) real*8 bar, sig integer Ns, Nu c--------------------------------------------- c c Subtract the average for each row, so that we can c focus on the column-by-column behavior. Since c most of the columns start high and asymtote after c 12 pixels or so, let's define the average by the c right half. c do j = 0001, 2068 ptot = 0. do i = 0013, 0024 ptot = ptot + pix_ij(i,j) enddo bar = ptot/12 do i = 0001, 0024 pnorm(i,j) = pix_ij(i,j) - bar ! pnorm is the residual enddo enddo do i = 01, 24 Ns = 0 do j = 0001, 2068 if (pix_ij(25,j).lt.25000.and. ! I have found that if there are saturated . pix_ij(26,j).lt.25000.and. ! pixels near the reference pixels, . pix_ij(27,j).lt.25000.and. ! they can bleed into the ref pixels . pix_ij(28,j).lt.25000.and. ! and mess up the column by column . pix_ij(29,j).lt.25000.and. ! trends ; so only use columns that . pix_ij(30,j).lt.25000) then ! are free of trends. Ns = Ns + 1 collist(Ns) = pnorm(i,j) endif enddo call barsig_r4(collist,Ns,bar,sig,5.0,Nu) ! this takes the list of good residuals c 199 format(i2,1x,f10.2,1x,f10.3,1x,i4) ! for column#i and determines the refcolbar(i) = SNGL(bar) ! average excess/deficit and its rms refcolsig(i) = SNGL(sig) ! the average will be used to adjust the enddo ! column by column ref-pix trends return end c------------------------------------------------------- c c c subroutine barsig_r4(xlist,NTOT,bar,sig,SIG_REJ,NUSE) implicit none integer NTOT real*8 xlist(NTOT) real*8 bar real*8 sig real SIG_REJ integer NUSE integer n real*8 bsum, ssum integer nsum integer NIT bar = 0.e0 sig = 9e9 do NIT = 1, 5 bsum = 0. ssum = 0. nsum = 0. do n = 1, NTOT if (abs(xlist(n)-bar).le.SIG_REJ*sig) then bsum = bsum + xlist(n) ssum = ssum + (xlist(n)-bar)**2 nsum = nsum + 1 endif enddo if (nsum.gt.0) bar = bsum / nsum if (nsum.gt.1) sig = sqrt(ssum/(nsum-1)) enddo NUSE = nsum if (nsum.le.1) sig = 0.999 return end c------------------------------------------------------- c c c subroutine barsiga(xlist,NTOT,bar,sig,SIG_REJ,NUSE) implicit none integer NTOT real*8 xlist(NTOT) real*8 bar real*8 sig real SIG_REJ integer NUSE integer n real*8 bsum, ssum integer nsum integer NIT bar = 0.e0 sig = 9e9 do NIT = 1, 15 bsum = 0. ssum = 0. nsum = 0. do n = 1, NTOT if (abs(xlist(n)-bar).le.SIG_REJ*sig) then bsum = bsum + xlist(n) ssum = ssum + abs(xlist(n)-bar) nsum = nsum + 1 endif enddo if (nsum.gt.0) bar = bsum / nsum if (nsum.gt.1) sig = ssum / (nsum-1) enddo NUSE = nsum if (nsum.le.1) sig = 0.999 return end c-------------------------------------------------------------- c c this will subtract the column-by-column trends from the c reference pixels. c subroutine subt_refcol(pix_ij_BEF,refcolbar, . pix_ij_AFT) implicit none real pix_ij_BEF(2072,2068) real refcolbar(24) real pix_ij_AFT(2072,2068) integer i, j do i = 0001, 0024 do j = 0001, 2068 pix_ij_AFT(i,j) = pix_ij_BEF(i,j) - refcolbar(i) enddo enddo do i = 0025, 2072 do j = 0001, 2068 pix_ij_AFT(i,j) = pix_ij_BEF(i,j) enddo enddo return end c-------------------------------------------------------------- c c this will output the data needed to optimize the c correction for bias-drift ; Matt, there's no need c to translate this routine c subroutine dump_testf(pix_ijk,NARG) implicit none real pix_ijk(2072,2068,4) integer NARG integer i, j, k, n real*8 a(20) real f(20) real val real*8 ptot, refbar data f / 0.00100, 0.00095, 0.00090, 0.00085, 0.00080, . 0.00075, 0.00070, 0.00065, 0.00060, 0.00055, . 0.00050, 0.00045, 0.00040, 0.00035, 0.00030, . 0.00025, 0.00020, 0.00015, 0.00010, 0.00005/ open(99,file='dump_testf.ACS_bias',status='unknown') do k = 1, 4 do n = 1, 20 a(n) = 0.00 enddo do j = 0001, 2068 ptot = 0 do i = 01, 24 ptot = ptot + pix_ijk(i,j,k) enddo refbar = ptot/24 write(99,199) NARG,k,j,refbar,(a(n),n=1,20) 199 format(i3.3,1x,i1,1x,i4.4,3x,f8.2,3x,20(f8.1,1x)) do i = 0001, 2068+146 val = 0.00 if (i.ge.0001.and.i.le.2068) val = pix_ijk(i,j,k) do n = 1, 20 a(n) = a(n) + (val-a(n))*f(n) enddo enddo enddo!j enddo!k close(99) return end subroutine readfits_acsraw2r(FILENAME,pix) implicit none character*80 FILENAME real pix(4096,4096) real pixz(8288,2068) integer i, j call sub_wfcacs_readraw2raz(FILENAME,pixz) do i = 0001, 2048 do j = 0001, 2048 pix(i+0000,j+0000) = pixz(0*2072+24+i,j) pix(4097-i,j+0000) = pixz(1*2072+24+i,j) pix(i+0000,4097-j) = pixz(2*2072+24+i,j) pix(4097-i,4097-j) = pixz(3*2072+24+i,j) enddo enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/WFC3UV/read_wfc3uv_flt_full.f" c**** c********************************************* c c#include "/user/jayander/FORTRAN/PARLOR/islinux.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/query_hdre.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/query_hdre_i4.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/query_hdre_r4.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/query_hdre_r8.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/rdate_header.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_i2e.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_j2r.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_r4.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_r4e.f" c#include "/user/jayander/FORTRAN/FITSIO/GEN/readfits_r8e_r4.f" c#include "/user/jayander/FORTRAN/ROUTINES/STRING/str_contains.f" c subroutine read_wfc3uv_flt_smpl(FILENAME,pix) character*200 FILENAME real pix(4096,4096) real*8 CRPIX1, CRPIX2 real*8 CRVAL1, CRVAL2 real*8 CD1_1, CD1_2 real*8 CD2_1, CD2_2 integer LOFLAG, HIFLAG real*8 BDRY_XR(4,4) real*8 BDRY_YR(4,4) character*05 FILT real*4 EXPT real*4 RDAT integer PROP byte, dimension(:,:), allocatable :: pixq allocate(pixq(4096,4096)) c print*,'ENTER read_wfc3uv_flt_smpl...' call read_wfc3uv_flt_full(FILENAME,pix,pixq, . CRPIX1, CRPIX2, . CRVAL1, CRVAL2, . CD1_1, CD1_2, . CD2_1, CD2_2, . LOFLAG, HIFLAG, . BDRY_XR, BDRY_YR, . FILT,EXPT, . RDAT,PROP) deallocate(pixq) c print*,'EXIT read_wfc3uv_flt_smpl...' return end subroutine read_wfc3uv_flt_full(FILENAME, pix, pxq, . CRPIX1, CRPIX2, . CRVAL1, CRVAL2, . CD1_1, CD1_2, . CD2_1, CD2_2, . LOFLAG, HIFLAG, . BDRY_XR, BDRY_YR, . FILT,EXPT, . RDAT,PROP) implicit none character*200 FILENAME real pix(4096,4096) byte pxq(4096,4096) real*8 CRPIX1, CRPIX2 real*8 CRVAL1, CRVAL2 real*8 CD1_1, CD1_2 real*8 CD2_1, CD2_2 integer LOFLAG, HIFLAG real*8 BDRY_XR(4,4) real*8 BDRY_YR(4,4) character*05 FILT real*4 EXPT real*4 RDAT integer PROP integer NAXIS1 integer NAXIS2 real*8 COSPA, SINPA real*8 PA_APER real*8 PA_V3 character*20 STREAM real*8 r8_query_hdre real*4 r4_query_hdre integer i4_query_hdre real*8 rdate_header integer i, j logical str_contains real*4, dimension(:,:), allocatable :: pixz c print*,' ' c print*,'ENTER: subroutine read_wfc3uv_flt_full ' c print*,'---> FILENAME: ',FILENAME c print*,' ' do i = 0001, 4096 do j = 0001, 4096 pix(i,j) = -750 pxq(i,j) = 0 enddo enddo NAXIS1 = int(r8_query_hdre(FILENAME,'NAXIS1 ',-1)) NAXIS2 = int(r8_query_hdre(FILENAME,'NAXIS2 ',-1)) CRPIX1 = r8_query_hdre(FILENAME,'CRPIX1 ',-1) CRPIX2 = r8_query_hdre(FILENAME,'CRPIX2 ',-1) CRVAL1 = r8_query_hdre(FILENAME,'CRVAL1 ',-1) CRVAL2 = r8_query_hdre(FILENAME,'CRVAL2 ',-1) PA_APER = r8_query_hdre(FILENAME,'PA_APER ',-1) PA_V3 = PA_APER - 0.0645919 if (PA_V3.gt.360.0) PA_V3 = PA_V3 - 360.0 if (PA_V3.lt.000.0) PA_V3 = PA_V3 + 360.0 COSPA = cos(PA_V3*3.14159/180.0) SINPA = sin(PA_V3*3.14159/180.0) CD1_1 = -COSPA*0.039773/60/60 CD1_2 = SINPA*0.039773/60/60 CD2_1 = SINPA*0.039773/60/60 CD2_2 = COSPA*0.039773/60/60 PROP = i4_query_hdre(FILENAME,'PROPOSID',-1) EXPT = r4_query_hdre(FILENAME,'EXPTIME ',-1) RDAT = SNGL(rdate_header(FILENAME)) call query_hdre(FILENAME,'FILTER ',STREAM,-1) FILT = 'FXXXW' if (STREAM(1:1).eq.'F') FILT = STREAM(1:5) if (STREAM(2:2).eq.'F') FILT = STREAM(2:6) LOFLAG = -50 HIFLAG = 64000 do i = 1, 4 do j = 1, 4 BDRY_XR(i,j) = 0. BDRY_YR(i,j) = 0. enddo enddo BDRY_XR(1,2) = 0001 BDRY_YR(1,2) = 0001 BDRY_XR(2,2) = 4095 BDRY_YR(2,2) = 0001 BDRY_XR(3,2) = 4095 BDRY_YR(3,2) = 2047 BDRY_XR(4,2) = 0001 BDRY_YR(4,2) = 2047 BDRY_XR(1,1) = 0001 BDRY_YR(1,1) = 2049 BDRY_XR(2,1) = 4095 BDRY_YR(2,1) = 2049 BDRY_XR(3,1) = 4095 BDRY_YR(3,1) = 4095 BDRY_XR(4,1) = 0001 BDRY_YR(4,1) = 4095 if (str_contains(FILENAME,200,'_flt.fits',09).or. . str_contains(FILENAME,200,'_flc.fits',09)) then !print*,'call readfits_WFC4: ',FILENAME(1:40) call WFC3UV_FLTREAD(FILENAME,pix,pxq) goto 444 endif if (str_contains(FILENAME,200,'_WJC.fits',09).or. . str_contains(FILENAME,200,'_WJX.fits',09).or. . str_contains(FILENAME,200,'_WXC.fits',09).or. . str_contains(FILENAME,200,'_WJ2.fits',09)) then call readfits_j2r(FILENAME,pix(0001,0001),4096,4096) do i = 0001, 4096 do j = 0001, 4096 pxq(i,j) = 0 if (pix(i,j).gt.HIFLAG) pxq(i,j) = 1 enddo enddo goto 444 endif c c raz type file... c if (NAXIS1.eq.8412.and.NAXIS2.eq.2070) then allocate(pixz(8412,2070)) call readfits_r4(FILENAME,pixz,8412,2070) do i = 0001, 2048 do j = 0001, 2048 pix(0000+i,0000+j) = pixz(0025+i,j) pix(2048+i,0000+j) = pixz(4177-i,j) pix(0000+i,4097-j) = pixz(4231+i,j+3) pix(2048+i,4097-j) = pixz(8383-i,j+3) enddo enddo deallocate(pixz) goto 444 endif print*,'PROB : subroutine read_wfc3uv_flt_full ' print*,' could not read in file: ' print*,' ',FILENAME stop 444 continue do i = 0001, 4096 do j = 2046, 2051 pix(i,j) = -750 enddo enddo c print*,' ' c print*,'EXIT : subroutine read_wfc3uv_flt_full ' c print*,' ' return end c-------------------------------------------------------------- c c check: UVIS-CENTER --- full array --- ic9r16asq c UVIS1 --- udef sub --- ichl08ujq c UVIS2 --- udef sub --- ichl08ulq c UVIS2-M1K1C-SUB --- std sub --- icdw04ljq_flt.fits c UVIS2-C1K1C-SUB --- std sub --- icck01leq c UVIS2-C512C-SUB --- std sub --- icjd04ezq_flt.fits c UVIS2-2K2C-SUB --- std sub --- icp601pyq_flt.fits c UVIS2-M512C-SUB --- std sub --- ic8ea1eeq_flt.fits c c-------------------------------------------------------------- c-------------------------------------------- c c subroutine WFC3UV_FLTREAD(FILE,pix,pxq) implicit none character*200 FILE real pix(4096,4096) byte pxq(4096,4096) character*20 NAMEAP real pix0512(0512,0512) real pix0513(0513,0512) real pix1024(1024,1024) real pix1025(1025,1024) real pix4096(4096,2051) real pix2048(2048,2048) real pix2047(2047,2050) real pix4096g(4096,2050) integer i, j character*20 STREAM integer*2 pix0512i(0512,0512) integer*2 pix0513i(0513,0512) integer*2 pix1024i(1024,1024) integer*2 pix1025i(1025,1024) integer*2 pix4096i(4096,2051) integer*2 pix4096h(4096,2050) integer*2 pix2048i(2048,2048) integer*2 pix2047i(2047,2050) character*20 STREAM_CENTERA1 character*20 STREAM_CENTERA2 character*20 STREAM_SIZAXIS1 character*20 STREAM_SIZAXIS2 character*20 STREAM_NAXIS1 character*20 STREAM_NAXIS2 character*20 STREAM_BITPIX character*20 STREAM_CCDAMP character*20 STREAM_BINAXIS1 character*20 STREAM_BINAXIS2 integer CENTERA1 integer CENTERA2 integer SIZAXIS1 integer SIZAXIS2 integer NAXIS1 integer NAXIS2 integer BITPIX character*4 CCDAMP integer BINAXIS1 integer BINAXIS2 c c---------------------------------------------------------- c logical ISSUBARRAY ISSUBARRAY = .true. call query_hdre(FILE,'APERTURE',NAMEAP,-1) call query_hdre(FILE,'SUBARRAY',STREAM,-1) call query_hdre(FILE,'CENTERA1',STREAM_CENTERA1,-1) call query_hdre(FILE,'CENTERA2',STREAM_CENTERA2,-1) call query_hdre(FILE,'SIZAXIS1',STREAM_SIZAXIS1,-1) call query_hdre(FILE,'SIZAXIS2',STREAM_SIZAXIS2,-1) call query_hdre(FILE,'NAXIS1 ',STREAM_NAXIS1,-1) call query_hdre(FILE,'NAXIS2 ',STREAM_NAXIS2,-1) call query_hdre(FILE,'BITPIX ',STREAM_BITPIX,-1) call query_hdre(FILE,'CCDAMP ',STREAM_CCDAMP,-1) BINAXIS1 = 1 BINAXIS2 = 1 call query_hdre(FILE,'BINAXIS1',STREAM_BINAXIS1,-1) call query_hdre(FILE,'BINAXIS2',STREAM_BINAXIS2,-1) if (STREAM_CENTERA1(1:4).eq.'NULL') STREAM_CENTERA1 = '0' if (STREAM_CENTERA2(1:4).eq.'NULL') STREAM_CENTERA2 = '0' if (STREAM_SIZAXIS1(1:4).eq.'NULL') STREAM_SIZAXIS1 = '0' if (STREAM_SIZAXIS2(1:4).eq.'NULL') STREAM_SIZAXIS2 = '0' if ( STREAM_NAXIS1(1:4).eq.'NULL') STREAM_NAXIS1 = '0' if ( STREAM_NAXIS2(1:4).eq.'NULL') STREAM_NAXIS2 = '0' if (STREAM_BINAXIS1(1:4).eq.'NULL') STREAM_BINAXIS1 = '0' if (STREAM_BINAXIS2(1:4).eq.'NULL') STREAM_BINAXIS2 = '0' read(STREAM_CENTERA1,*) CENTERA1 read(STREAM_CENTERA2,*) CENTERA2 read(STREAM_SIZAXIS1,*) SIZAXIS1 read(STREAM_SIZAXIS2,*) SIZAXIS2 read(STREAM_NAXIS1 ,*) NAXIS1 read(STREAM_NAXIS2 ,*) NAXIS2 read(STREAM_BITPIX ,*) BITPIX read(STREAM_BINAXIS1,*) BINAXIS1 read(STREAM_BINAXIS2,*) BINAXIS2 CCDAMP = STREAM_CCDAMP(2:5) do i = 0001, 4096 do j = 0001, 4096 pix(i,j) = -750 enddo enddo if (BINAXIS1.ne.1.or. . BINAXIS2.ne.1) then print*,' ' print*,'***********************************' print*,'*** ' print*,'*** BINNED IMAGE ',FILE print*,'*** ' print*,'*** DO NOT READ IN...' print*,'*** ' print*,'***********************************' print*,' ' print*,' STREAM_BINAXIS1: ',BINAXIS1,STREAM_BINAXIS1 print*,' STREAM_BINAXIS2: ',BINAXIS2,STREAM_BINAXIS2 print*,' ' return endif if (NAMEAP(01:01).eq.'''') NAMEAP = NAMEAP(02:20) do i = 1, 20 if (NAMEAP(i:i).eq.'''') NAMEAP(i:i) = ' ' enddo read(STREAM,*) ISSUBARRAY c write(*,'(''WFC3UV_FLTREAD NAMEAP: '',20a,'' SUB? '',l1,5x,80a)') c . NAMEAP,ISSUBARRAY,FILE if (NAMEAP(01:06).eq.'UVIS '.or. . NAMEAP(01:06).eq.'UVIS1 '.or. . NAMEAP(01:06).eq.'UVIS2 '.or. . NAMEAP(01:09).eq.'UVIS-FIX '.or. . NAMEAP(01:09).eq.'UVIS1-FIX'.or. . NAMEAP(01:09).eq.'UVIS2-FIX'.or. . NAMEAP(01:09).eq.'G280-REF '.or. . NAMEAP(01:09).eq.'UVIS-QUAD'.or. . NAMEAP(01:11).eq.'UVIS-CENTER'.or. . NAMEAP(01:11).eq.'UVIS-IR-FIX'.or. . NAMEAP(01:12).eq.'UVIS1-IR-FIX'.or. . NAMEAP(01:12).eq.'UVIS2-IR-FIX'.or. . NAMEAP(01:15).eq.'UVIS1-C1K1C-CTE'.or. . NAMEAP(01:15).eq.'UVIS2-C1K1C-CTE'.or. . NAMEAP(01:15).eq.'UVIS2-C512C-CTE'.or. . NAMEAP(01:13).eq.'UVIS-QUAD-FIX') then if (ISSUBARRAY) then print*,' ' print*,'IMAGE: ' print*,' ' print*,FILE print*,' ' print*,'HAS A FULL-FRAME APERTURE ' print*,'BUT IT HAS THE SUBARRAY ' print*,'KEYWORD SET TO TRUE. ' print*,' ' print*,' NAMEAP: ',NAMEAP print*,' ISSUBARRAY: ',ISSUBARRAY print*,' ' print*,'ROUTINE IS NOT DESIGNED TO DEAL WITH ' print*,'USER-DEFINED SUBARRAYS. ' print*,' ' print*,'STOP' stop endif call readfits_WFC3(FILE,pix4096 ,1) call readfits_i2e(FILE,pix4096i,4096,2051,3) do i = 0001, 4096 do j = 0001, 2048 pix(i,j+0000) = pix4096(i,j) pxq(i,j+0000) = 0 if (iand(pix4096i(i,j),int(256,2)).eq.256) . pxq(i,j+0000) = 1 enddo enddo call readfits_WFC3(FILE,pix4096,4) call readfits_i2e(FILE,pix4096i,4096,2051,6) do i = 0001, 4096 do j = 0001, 2048 pix(i,j+2048) = pix4096(i,j) pxq(i,j+2048) = 0 if (iand(pix4096i(i,j),int(256,2)).eq.256) . pxq(i,j+2048) = 1 enddo enddo do i = 0001, 4096 do j = 2048-2, 2049+2 pix(i,j) = -750 enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS1-C512A-SUB') then call readfits_r4e(FILE,pix0513 ,0513,0512,1) call readfits_i2e(FILE,pix0513i,0513,0512,3) do i = 0001, 0513 do j = 0001, 0512-2 pix(i+0000,j+1538+2048) = pix0513(i,j) enddo enddo do i = 0001, 0513 do j = 0002, 0511-2 pxq(i+0000,j+1538+2048) = 0 if (iand(pix0513i(i,j),int(256,2)).eq.256) then pxq(i+0000,j+1538+2048) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS2-C1K1C-SUB') then !print*,'C1K1Ca: ',FILE call readfits_r4e(FILE,pix1025 ,1025,1024,1) call readfits_i2e(FILE,pix1025i,1025,1024,3) do i = 0001, 1025 do j = 0001, 1024 pix(i+0000,j+0001) = pix1025(i,j) pxq(i+0000,j+0001) = 0 if (iand(pix1025i(i,j),int(256,2)).eq.256) then pxq(i+0000,j+0001) = 1 endif enddo enddo !call writfits_r4('pix1025.fits' ,pix1025 ,1025,1024) !call writfits_i2('pix1025i.fits',pix1025i,1025,1024) !print*,'C1K1Cb: ',FILE return endif if (NAMEAP(01:15).eq.'UVIS2-M1K1C-SUB') then call readfits_r4e(FILE,pix1024 ,1024,1024,1) call readfits_i2e(FILE,pix1024i,1024,1024,3) do i = 0001, 1024 do j = 0001, 1024 pix(i+1023,j+1027) = pix1024(i,j) pxq(i+1023,j+1027) = 0 if (iand(pix1024i(i,j),int(256,2)).eq.256) then pxq(i+1023,j+1027) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS2-C512C-SUB') then call readfits_r4e(FILE,pix0513 ,0513,0512,1) call readfits_i2e(FILE,pix0513i,0513,0512,3) do i = 0001, 0513 do j = 0001, 0512 pix(i+0000,j+0001) = pix0513(i,j) pxq(i+0000,j+0001) = 0 if (iand(pix0513i(i,j),int(256,2)).eq.256) then pxq(i+0000,j+0001) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS2-C512D-SUB') then call readfits_r4e(FILE,pix0513 ,0513,0512,1) call readfits_i2e(FILE,pix0513i,0513,0512,3) do i = 0001, 0513 do j = 0001, 0512 pix(i+3583,j+0001) = pix0513(i,j) pxq(i+3583,j+0001) = 0 if (iand(pix0513i(i,j),int(256,2)).eq.256) then pxq(i+3583,j+0001) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS1-C512B-SUB') then call readfits_r4e(FILE,pix0513 ,0513,0512,1) call readfits_i2e(FILE,pix0513i,0513,0512,3) do i = 0001, 0513 do j = 0001, 0512-2 pix(i+3583,j+1538+2048) = pix0513(i,j) pxq(i+3583,j+1538+2048) = 0 if (iand(pix0513i(i,j),int(256,2)).eq.256) then pxq(i+3583,j+1538+2048) = 1 endif enddo enddo return endif if (NAMEAP(01:14).eq.'UVIS2-M512-SUB') then call readfits_r4e(FILE,pix0512 ,0512,0512,1) call readfits_i2e(FILE,pix0512i,0512,0512,3) do i = 0001, 0512 do j = 0001, 0512 pix(i+1791,j+1539) = pix0512(i,j) pxq(i+1791,j+1539) = 0 if (iand(pix0512i(i,j),int(256,2)).eq.256) then pxq(i+1791,j+1539) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS2-M512C-SUB') then call readfits_r4e(FILE,pix0512 ,0512,0512,1) call readfits_i2e(FILE,pix0512i,0512,0512,3) do i = 0001, 0512 do j = 0001, 0512 pix(i+1535,j+1539) = pix0512(i,j) pxq(i+1535,j+1539) = 0 if (iand(pix0512i(i,j),int(256,2)).eq.256) then pxq(i+1535,j+1539) = 1 endif enddo enddo return endif if (NAMEAP(01:14).eq.'UVIS1-M512-SUB') then call readfits_r4e(FILE,pix0512 ,0512,0512,1) call readfits_i2e(FILE,pix0512i,0512,0512,3) do i = 0001, 0512 do j = 0001, 0512 pix(i+1791,j+2048) = pix0512(i,j) pxq(i+1791,j+2048) = 0 if (iand(pix0512i(i,j),int(256,2)).eq.256) then pxq(i+1791,j+2048) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS2-2K2C-SUB ') then call readfits_r4e(FILE,pix2047 ,2047,2050,1) call readfits_i2e(FILE,pix2047i,2047,2050,3) do i = 0001, 2047 do j = 0001, 2050 pix(i+0000,j+0001) = pix2047(i,j) pxq(i+0000,j+0001) = 0 if (iand(pix2047i(i,j),int(256,2)).eq.256) then pxq(i+0000,j+0001) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS2-2K2D-SUB ') then call readfits_r4e(FILE,pix2047 ,2047,2050,1) call readfits_i2e(FILE,pix2047i,2047,2050,3) do i = 0001, 2047 do j = 0001, 2050 pix(i+2049,j+0001) = pix2047(i,j) pxq(i+2049,j+0001) = 0 if (iand(pix2047i(i,j),int(256,2)).eq.256) then pxq(i+2049,j+0001) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS1-2K2B-SUB ') then c print*,'read1...' call readfits_r4e(FILE,pix2047 ,2047,2050,1) c print*,'read3...' call readfits_i2e(FILE,pix2047i,2047,2050,3) do i = 0001, 2047 do j = 0001, 2048 pix(i+2049,j+2048) = pix2047(i,j) pxq(i+2049,j+2048) = 0 if (iand(pix2047i(i,j),int(256,2)).eq.256) then pxq(i+2049,j+2048) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS1-2K2A-SUB ') then call readfits_r4e(FILE,pix2047 ,2047,2050,1) call readfits_i2e(FILE,pix2047i,2047,2050,3) do i = 0001, 2047 do j = 0001, 2048 pix(i+0000,j+2048) = pix2047(i,j) pxq(i+0000,j+2048) = 0 if (iand(pix2047i(i,j),int(256,2)).eq.256) then pxq(i+0000,j+2048) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS2 ') then print*,'UVIS2... user defined subarray...' print*,'UVIS2... really!...' print*,'CENTERA1 = ',CENTERA1 print*,'CENTERA2 = ',CENTERA2 print*,'SIZAXIS1 = ',SIZAXIS1 print*,'SIZAXIS2 = ',SIZAXIS2 do i = 0001, 4096 do j = 0001, 4096 pix(i,j) = 0.00 enddo enddo if (CENTERA1.eq.1557.and. . CENTERA2.eq.1540.and. . SIZAXIS1.eq.1024.and. . SIZAXIS2.eq.1024) then call readfits_r4e(FILE,pix1024 ,1024,1024,1) call readfits_i2e(FILE,pix1024i,1024,1024,3) do i = 0001, 1024 do j = 0001, 1024 pix(i+1020-1,j+1028-1) = pix1024(i,j) pxq(i+1020-1,j+1028-1) = 0 if (iand(pix1024i(i,j),int(256,2)).eq.256) then pxq(i+1020-1,j+1028-1) = 1 endif enddo enddo return endif if (CENTERA2.ne.1027) stop 'CENTERA2.ne.1027' if (SIZAXIS1.ne.2048) stop 'SIZAXIS1.ne.2048' if (SIZAXIS2.ne.2048) stop 'SIZAXIS2.ne.2048' if (CCDAMP.ne.'C ') stop 'CCDAMP.ne."C "' call readfits_r4e(FILE,pix2048 ,2048,2048,1) call readfits_i2e(FILE,pix2048i,2048,2048,3) do i = 0001, 2048 do j = 0001, 2048 pix(i+1024-1,j+0003-1) = pix2048(i,j) pxq(i+1024-1,j+0003-1) = 0 if (iand(pix2048i(i,j),int(256,2)).eq.256) then pxq(i+1024-1,j+0003-1) = 1 endif enddo enddo return endif if (NAMEAP(01:15).eq.'UVIS1 ') then print*,'UVIS1... user defined subarray...' if (CENTERA1.ne.2073) stop 'CENTERA1.ne.2073' if (CENTERA2.ne.1027) stop 'CENTERA2.ne.1027' if (SIZAXIS1.ne.2048) stop 'SIZAXIS1.ne.2048' if (SIZAXIS2.ne.2048) stop 'SIZAXIS2.ne.2048' if (CCDAMP.ne.'A ') stop 'CCDAMP.ne."A "' print*,' FILE: ',FILE print*,'CALL readfits_r4e...' call readfits_r4e(FILE,pix2048 ,2048,2048,1) call readfits_i2e(FILE,pix2048i,2048,2048,3) print*,'RETN readfits_r4e...' print*,'LOOP1...' print*,'LOOP2...' do i = 0001, 2048 do j = 0001, 2048 if (i+1024-0001.ge.0001.and.i+1024-0001.le.4096.and. . j+0003+2048.ge.0001.and.j+0003+2048.le.4096) then pix(i+1024-1,j+0003+2048-1) = pix2048(i,j) pxq(i+1024-1,j+0003+2048-1) = 0 if (iand(pix2048i(i,j),int(256,2)).eq.256) then pxq(i+1024-1,j+0003+2048-1) = 1 endif endif enddo enddo print*,'LOOP3...' print*,'RETN' return endif if (NAMEAP(01:15).eq.'UVIS2-2K4-SUB ') then if (CENTERA1.ne.2074) stop 'CENTERA1.ne.2074' if (CENTERA2.ne.1027) stop 'CENTERA2.ne.1027' if (CCDAMP.ne.'D ') stop 'CCDAMP.ne."D "' print*,'FILE: ',FILE print*,'CALL readfits_r4e...' call readfits_r4e(FILE,pix4096g,4096,2050,1) print*,'CALL readfits_i2e...' call readfits_i2e(FILE,pix4096h,4096,2050,3) !print*,'RETN readfits_r4e...' !print*,'LOOP1...' do i = 0001, 4096 do j = 0001, 2048 pix(i,j) = pix4096g(i,j) pxq(i,j) = 0 if (iand(pix4096h(i,j),int(256,2)).eq.256) pxq(i,j) = 1 enddo enddo c print*,'OUTPUT TEMP...' c call writfits_r4('temp.fits',pix,4096,4096) c if (.true.) stop return endif if (NAMEAP(01:15).eq.'UVIS1-2K4-SUB ') then c if (CENTERA1.ne.2074) stop 'CENTERA1.ne.2074' c if (CENTERA2.ne.1027) stop 'CENTERA2.ne.1027' c if (CCDAMP.ne.'D ') stop 'CCDAMP.ne."D "' !print*,'FILE: ',FILE !print*,'CALL readfits_r4e...' call readfits_r4e(FILE,pix4096g,4096,2050,1) call readfits_i2e(FILE,pix4096h,4096,2050,3) !print*,'RETN readfits_r4e...' !print*,'LOOP1...' do i = 0001, 4096 do j = 0001, 2048 pix(i,j+2048) = pix4096g(i,j) pxq(i,j+2048) = 0 if (iand(pix4096h(i,j),int(256,2)).eq.256) pxq(i,j+2048) = 1 enddo enddo c print*,'OUTPUT TEMP...' c call writfits_r4('temp.fits',pix,4096,4096) return endif c4444 continue do i = 0001, 4096 do j = 0001, 4096 pix(i,j) = -1000 pxq(i,j) = 0 pxq(i,j) = 1 enddo enddo print*,' ' print*,'4444 ' print*,' ' print*,'WFC3UV_FLTREAD not yet designed to operate on' print*,' ' print*,' FILE: ',FILE(1:200) print*,' ' print*,'aperture: ',NAMEAP print*,'subarray: ',ISSUBARRAY print*,'AS A SUBARRAY...' print*,' ' return end c-------------------------------------------- c c subroutine readfits_WFC3(FILE,pix,nimg) implicit none character*200 FILE real pix(4096,2051) character*70 INFO(10) common / fitsinfo / INFO integer nimg integer naxes integer laxis(3) character*8 field character*20 stream integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer ifirst, i1, i2 integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix logical islinux, islinuxu character*70 HDR(25) common/HDR/HDR open(10,file=FILE,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') bscale = 1.0 bzero = 0.0 naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 do i = 1, 10 INFO(i) = ' ' enddo do i = 1, 25 HDR(i) = ' ' enddo i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buffc do k = 0, 35, 1 field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+31) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'EXPTIME ') INFO(01) = stream if (field.eq.'FILTER ') INFO(02) = stream if (field.eq.'FILENAME') INFO(03) = stream if (field.eq.'DATE-OBS') INFO(04) = stream if (field.eq.'TIME-OBS') INFO(05) = stream if (field.eq.'DEC_TARG') INFO(06) = stream if (field.eq.'RA_TARG ') INFO(07) = stream if (field.eq.'PA_V3 ') INFO(08) = stream if (field.eq.'PROPOSID') INFO(09) = stream if (field.eq.'CCDGAIN ') INFO(10) = stream if (field.eq.'CRPIX1 ') HDR(01) = stream if (field.eq.'CRPIX2 ') HDR(02) = stream if (field.eq.'CRVAL1 ') HDR(03) = stream if (field.eq.'CRVAL2 ') HDR(04) = stream if (field.eq.'CTYPE1 ') HDR(05) = stream if (field.eq.'CTYPE2 ') HDR(06) = stream if (field.eq.'CD1_1 ') HDR(07) = stream if (field.eq.'CD1_2 ') HDR(08) = stream if (field.eq.'CD2_1 ') HDR(09) = stream if (field.eq.'CD2_2 ') HDR(10) = stream if (field.eq.'ORIENTAT') HDR(11) = stream if (field.eq.'PA_APER ') HDR(12) = stream if (field.eq.'PA_V3 ') HDR(13) = stream if (field.eq.'DATE-OBS') HDR(14) = stream if (field.eq.'TIME-OBS') HDR(15) = stream if (field.eq.'EXPTIME ') HDR(16) = stream if (field.eq.'ROOTNAME') HDR(17) = stream if (field.eq.'TARGNAME') HDR(18) = stream if (field.eq.'RA_TARG ') HDR(19) = stream if (field.eq.'DEC_TARG') HDR(20) = stream if (field.eq.'PROPOSID') HDR(21) = stream if (field.eq.'FILTER ') HDR(22) = stream if (field.eq.'FILTER ') HDR(23) = stream if (field.eq.'VAFACTOR') HDR(24) = stream if (field.eq.'CCDGAIN ') HDR(25) = stream if (field.eq.'END ') goto 101 enddo goto 100 101 continue nread = nread + 1 ifirst = i+1 i1 = i i2 = i if (naxes.eq.0) then ! maybe multiple images stored as extensions if (nextend.eq.0) then print*,'THIS IS A NULL IMAGE: ' print*,'NAXES: ',NAXES print*,'NEXND: ',NEXTEND stop endif endif if (nread.ne.nimg+1) then nbper = abs(BITPIX/8)*laxis(1)*laxis(2) if (NAXES.eq.0) nbper = 0 i = int(i + 1.0*nbper/2880 + 0.9999) goto 100 endif if (laxis(1).ne.4096.or. . laxis(2).ne.2051) then print*,' laxis1: ',laxis(1) print*,' laxis2: ',laxis(2) print*,' 4096: ',4096 print*,' 2051: ',2051 stop endif if (naxes.eq.2) then ! nimg is irrelevant; ignore nbper = 4*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 endif if (naxes.eq.3) then nbper = 4*laxis(1)*laxis(2) nbyte1 = 1 + nbper*(nimg-1) nbyte2 = nbper*(nimg ) i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 npt = laxis(1)*laxis(2) endif islinuxu = islinux() do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 call buff2pix_r4q(buffb,pix,np1,npt,islinuxu) enddo return 900 continue print*,'readfits_WFC3: READFITS ERROR' stop end subroutine buff2pix_r4q(buff,pix,n1,nt,islinuxu) implicit none byte buff(2880) real pix(*) integer n1,nt logical islinuxu byte b(4) real r equivalence(r,b) integer i, npu, nbu do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (.not.islinuxu) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) b(3) = buff(nbu+3) b(4) = buff(nbu+4) endif if (islinuxu) then b(4) = buff(nbu+1) b(3) = buff(nbu+2) b(2) = buff(nbu+3) b(1) = buff(nbu+4) endif if (npu.ge.1.and.npu.le.nt) pix(npu) = r enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/ACSHRC/read_acshrc_flt_full.f" c**** c********************************************* subroutine read_acshrc_flt_smpl(FILENAME,pix) implicit none character*200 FILENAME real pix(1024,1024) real*8 CRPIX1, CRPIX2 real*8 CRVAL1, CRVAL2 real*8 CD1_1, CD1_2 real*8 CD2_1, CD2_2 integer LOFLAG, HIFLAG real*8 BDRY_XR(4,4) real*8 BDRY_YR(4,4) character*05 FILT real*4 EXPT real*4 RDAT integer PROP call read_acshrc_flt_full(FILENAME,pix, . CRPIX1, CRPIX2, . CRVAL1, CRVAL2, . CD1_1, CD1_2, . CD2_1, CD2_2, . LOFLAG, HIFLAG, . BDRY_XR, BDRY_YR, . FILT,EXPT, . RDAT,PROP) return end subroutine read_acshrc_flt_full(FILENAME,pix, . CRPIX1, CRPIX2, . CRVAL1, CRVAL2, . CD1_1, CD1_2, . CD2_1, CD2_2, . LOFLAG, HIFLAG, . BDRY_XR, BDRY_YR, . FILT,EXPT, . RDAT,PROP) implicit none character*200 FILENAME real pix(1024,1024) real*8 CRPIX1, CRPIX2 real*8 CRVAL1, CRVAL2 real*8 CD1_1, CD1_2 real*8 CD2_1, CD2_2 integer LOFLAG, HIFLAG real*8 BDRY_XR(4,4) real*8 BDRY_YR(4,4) character*05 FILT real*4 EXPT real*4 RDAT integer PROP integer NAXIS1 integer NAXIS2 real*8 COSPA, SINPA real*8 PA_APER real*8 PA_V3 character*200 FILTU character*80 FILT1, FILT2, FILT3, FILT4 real*8 r8_query_hdre real*4 r4_query_hdre integer i4_query_hdre real*8 rdate_header integer i, j print*,' ' print*,'ENTER: subroutine read_wfcacs_flt_full ' print*,'---> FILENAME: ',FILENAME print*,' ' NAXIS1 = INT(r8_query_hdre(FILENAME,'NAXIS1 ',-1)) NAXIS2 = INT(r8_query_hdre(FILENAME,'NAXIS2 ',-1)) if (NAXIS1.ne.1024.and.NAXIS2.ne.1024) . stop 'only FLT ACS/HRC full frame (for now)' CRPIX1 = r8_query_hdre(FILENAME,'CRPIX1 ',-1) CRPIX2 = r8_query_hdre(FILENAME,'CRPIX2 ',-1) CRVAL1 = r8_query_hdre(FILENAME,'CRVAL1 ',-1) CRVAL2 = r8_query_hdre(FILENAME,'CRVAL2 ',-1) PA_APER = r8_query_hdre(FILENAME,'PA_APER ',-1) PA_V3 = PA_APER - 0.001 COSPA = cos(PA_V3*3.14159/180.0) SINPA = sin(PA_V3*3.14159/180.0) CD1_1 = -COSPA*0.02829/60/60 CD1_2 = SINPA*0.02829/60/60 CD2_1 = SINPA*0.02829/60/60 CD2_2 = COSPA*0.02829/60/60 PROP = i4_query_hdre(FILENAME,'PROPOSID',-1) EXPT = r4_query_hdre(FILENAME,'EXPTIME ',-1) RDAT = SNGL(rdate_header(FILENAME)) call query_hdre(FILENAME,'FILTER ',FILTU,-1) call query_hdre(FILENAME,'FILTER1 ',FILT1,-1) call query_hdre(FILENAME,'FILTER2 ',FILT2,-1) call query_hdre(FILENAME,'FILTNAM1',FILT3,-1) call query_hdre(FILENAME,'FILTNAM2',FILT4,-1) FILT = FILTU(1:5) if (FILT1(1:1).eq.'F') FILT = FILT1(1:5) if (FILT2(1:1).eq.'F') FILT = FILT2(1:5) if (FILT3(1:1).eq.'F') FILT = FILT3(1:5) if (FILT4(1:1).eq.'F') FILT = FILT4(1:5) if (FILT1(2:2).eq.'F') FILT = FILT1(2:6) if (FILT2(2:2).eq.'F') FILT = FILT2(2:6) if (FILT3(2:2).eq.'F') FILT = FILT3(2:6) if (FILT4(2:2).eq.'F') FILT = FILT4(2:6) LOFLAG = -50 HIFLAG = 125000 do i = 1, 4 do j = 1, 4 BDRY_XR(i,j) = 0. BDRY_YR(i,j) = 0. enddo enddo BDRY_XR(1,1) = 0002 BDRY_YR(1,1) = 0002 BDRY_XR(2,1) = 1023 BDRY_YR(2,1) = 0002 BDRY_XR(3,1) = 1023 BDRY_YR(3,1) = 1023 BDRY_XR(4,1) = 0002 BDRY_YR(4,1) = 1023 call readfits_HRC(FILENAME,pix,1) call HRCIMGFIX(pix) return end subroutine readfits_HRC(FILE,pix,nimg) implicit none character*(*) FILE real pix(1024,1024) character*70 INFO(10) common / fitsinfo / INFO integer nimg integer naxes integer laxis(3) character*8 field character*20 stream integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios, k character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer ifirst, i1, i2 integer np1, np2, npt integer nextend integer nread real bscale, bzero integer bitpix logical LINUX data LINUX/.true./ logical first_header integer NH_RECs character*2880 HEADER_STRING(99) common /HEADER_STRING_INFO/NH_RECs,HEADER_STRING open(10,file=FILE,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') bscale = 1.0 bzero = 0.0 naxes = -1 laxis(1) = 1 laxis(2) = 1 laxis(3) = 1 nextend = 0 NH_RECs = 0 first_header = .true. i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buffc if (first_header) then NH_RECs = NH_RECs + 1 HEADER_STRING(NH_RECs) = buffc endif do k = 0, 35, 1 field = buffc(k*80+01:k*80+08) stream = buffc(k*80+11:k*80+31) if (field.eq.'NAXIS ') read(stream,*) naxes if (field.eq.'NAXIS1 ') read(stream,*) laxis(1) if (field.eq.'NAXIS2 ') read(stream,*) laxis(2) if (field.eq.'NAXIS3 ') read(stream,*) laxis(3) if (field.eq.'NEXTEND ') read(stream,*) nextend if (field.eq.'BITPIX ') read(stream,*) bitpix if (field.eq.'BSCALE ') read(stream,*) bscale if (field.eq.'BZERO ') read(stream,*) bzero if (field.eq.'END ') then first_header = .false. goto 101 endif enddo goto 100 101 continue nread = nread + 1 ifirst = i+1 i1 = i i2 = i if (naxes.eq.0) then ! maybe multiple images stored as extensions if (nextend.eq.0) then print*,'THIS IS A NULL IMAGE: ' print*,'NAXES: ',NAXES print*,'NEXND: ',NEXTEND stop endif endif if (nread.ne.nimg+1) then nbper = abs(BITPIX/8)*laxis(1)*laxis(2) if (NAXES.eq.0) nbper = 0 i = int(i + 1.0*nbper/2880 + 0.9999) goto 100 endif if (laxis(1).ne.1024.or. . laxis(2).ne.1024) then print*,' laxis1: ',laxis(1) print*,' laxis2: ',laxis(2) print*,' 1024: ',1024 print*,' 1024: ',1024 stop endif if (naxes.eq.2) then ! nimg is irrelevant; ignore nbper = 4*laxis(1)*laxis(2) npt = laxis(1)*laxis(2) nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 endif if (naxes.eq.3) then nbper = 4*laxis(1)*laxis(2) nbyte1 = 1 + nbper*(nimg-1) nbyte2 = nbper*(nimg ) i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 npt = laxis(1)*laxis(2) endif do i = i1, i2, 1 read(10,rec=i,iostat=ios) buffc nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 call buff2pix_r4_hrc(buffb,pix,np1,npt) enddo return 900 continue print*,'readfits_WFC: READFITS ERROR' stop end subroutine buff2pix_r4_hrc(buff,pix,n1,nt) implicit none byte buff(2880) real pix(*) integer n1,nt byte b(4) real r equivalence(r,b) integer i, npu, nbu do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (.not.(_LINUX_)) then b(1) = buff(nbu+1) b(2) = buff(nbu+2) b(3) = buff(nbu+3) b(4) = buff(nbu+4) endif if ((_LINUX_)) then b(4) = buff(nbu+1) b(3) = buff(nbu+2) b(2) = buff(nbu+3) b(1) = buff(nbu+4) endif if (npu.ge.1.and.npu.le.nt) pix(npu) = r enddo return end c----------------------------------------------------- c c black-out the occulting finger, so no stars will be c sought there c subroutine HRCIMGFIX(pix) implicit none real pix(1024,1024) integer i, j, ic do j = 1024, 0777, -1 ic = 349 + (432-349)*(1024-j)/(1024-0777) do i = ic-15, ic+15 pix(i,j) = -100 enddo enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/writfits_r4.f" c**** c********************************************* c----------------------------------------------------- c c this just writes a real*4 fits image c subroutine writfits_r4(FILE,pix,PXDIMX,PXDIMY) implicit none character*(*) FILE integer PXDIMX,PXDIMY real pix(PXDIMX,PXDIMY) integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios character*2880 buffc byte buffb(2880) equivalence (buffb,buffc) integer ifirst, i1, i2 integer np1, np2, npt integer k, j character*200 FILEU character*70 HDR(25) common/HDR/HDR integer nonspace logical notblank70 HDR(05) = "' pixel '" HDR(06) = "' pixel '" FILEU = FILE do i = 1, 195 if (FILE(i:i+4).eq.'.fits') then FILEU = FILE(1:i+4) goto 1 endif enddo print*,' ' print*,'writfits_r4: no .fits' print*,' FILE: ',FILE stop 1 continue i = 1 open(10,file=FILEU,status='unknown', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') do k = 00, 35 write(buffc(k*80+1:k*80+80),'(80x)') enddo write(10,rec=i,iostat=ios) buffc write(buffc( 0*80+1: 1*80),'(''SIMPLE = T'')') write(buffc( 1*80+1: 2*80),'(''BITPIX = -32'')') write(buffc( 2*80+1: 3*80),'(''NAXIS = '',8x,i12)') 2 write(buffc( 3*80+1: 4*80),'(''NAXIS1 = '',8x,i12)') PXDIMX write(buffc( 4*80+1: 5*80),'(''NAXIS2 = '',8x,i12)') PXDIMY write(buffc( 5*80+1: 6*80),'(''DATATYPE= '',9a)') . " 'REAL*4' " write(buffc(07*80+1:08*80),'(''COMMENT '',a05)') ' ' write(buffc(08*80+1:09*80),'(''COMMENT '',a05)') ' ' if (notblank70(HDR(01))) .write(buffc(09*80+1:10*80),'(''CRPIX1 = '',a70)') HDR(01) if (notblank70(HDR(02))) .write(buffc(10*80+1:11*80),'(''CRPIX2 = '',a70)') HDR(02) if (notblank70(HDR(03))) .write(buffc(11*80+1:12*80),'(''CRVAL1 = '',a70)') HDR(03) if (notblank70(HDR(04))) .write(buffc(12*80+1:13*80),'(''CRVAL2 = '',a70)') HDR(04) if (notblank70(HDR(05))) .write(buffc(13*80+1:14*80),'(''CTYPE1 = '',a70)') HDR(05) if (notblank70(HDR(06))) .write(buffc(14*80+1:15*80),'(''CTYPE2 = '',a70)') HDR(06) if (notblank70(HDR(07))) .write(buffc(15*80+1:16*80),'(''CD1_1 = '',a70)') HDR(07) if (notblank70(HDR(08))) .write(buffc(16*80+1:17*80),'(''CD1_2 = '',a70)') HDR(08) if (notblank70(HDR(09))) .write(buffc(17*80+1:18*80),'(''CD2_1 = '',a70)') HDR(09) if (notblank70(HDR(10))) .write(buffc(18*80+1:19*80),'(''CD2_2 = '',a70)') HDR(10) if (notblank70(HDR(11))) .write(buffc(19*80+1:20*80),'(''ORIENTAT= '',a70)') HDR(11) if (notblank70(HDR(12))) .write(buffc(20*80+1:21*80),'(''PA_APER = '',a70)') HDR(12) if (notblank70(HDR(13))) .write(buffc(21*80+1:22*80),'(''PA_V3 = '',a70)') HDR(13) if (notblank70(HDR(14))) .write(buffc(22*80+1:23*80),'(''DATE-OBS= '',a70)') HDR(14) if (notblank70(HDR(15))) .write(buffc(23*80+1:24*80),'(''TIME-OBS= '',a70)') HDR(15) if (notblank70(HDR(16))) .write(buffc(24*80+1:25*80),'(''EXPTIME = '',a70)') HDR(16) if (notblank70(HDR(17))) .write(buffc(25*80+1:26*80),'(''ROOTNAME= '',a70)') HDR(17) if (notblank70(HDR(18))) .write(buffc(26*80+1:27*80),'(''TARGNAME= '',a70)') HDR(18) if (notblank70(HDR(19))) .write(buffc(27*80+1:28*80),'(''RA_TARG = '',a70)') HDR(19) if (notblank70(HDR(20))) .write(buffc(28*80+1:29*80),'(''DEC_TARG= '',a70)') HDR(20) if (notblank70(HDR(21))) .write(buffc(29*80+1:30*80),'(''PROPOSID= '',a70)') HDR(21) if (notblank70(HDR(22))) .write(buffc(30*80+1:31*80),'(''FILTER1 = '',a70)') HDR(22) if (notblank70(HDR(23))) .write(buffc(31*80+1:32*80),'(''FILTER2 = '',a70)') HDR(23) if (notblank70(HDR(24))) .write(buffc(33*80+1:34*80),'(''VAFACTOR= '',a70)') HDR(24) if (notblank70(HDR(25))) .write(buffc(32*80+1:33*80),'(''CCDGAIN = '',a70)') HDR(25) write(buffc(33*80+1:34*80),'(''COMMENT '',a05)') ' ' write(buffc(34*80+1:35*80),'(''COMMENT '',a05)') ' ' write(buffc(35*80+1:36*80),'(''END '')') do k = 00, 34 nonspace = 0 do j = 10, 80 if (buffc(k*80+j:k*80+j).ne.' '.and. . iachar(buffc(k*80+j:k*80+j)).ne.0) nonspace = nonspace+1 enddo if (nonspace.eq.0) then do j = 1, 80 buffc(k*80+j:k*80+j) = ' ' enddo endif enddo write(10,rec=i,iostat=ios) buffc ifirst = i+1 i1 = i i2 = i nbper = 4*PXDIMX*PXDIMY npt = PXDIMX*PXDIMY nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 do i = i1, i2, 1 nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 call pix2buff_r4(buffb,pix,np1,npt) write(10,rec=i,iostat=ios) buffc enddo close(10) return 900 continue print*,'writfits_r4.f ERROR' print*,' FILEU: ',FILEU stop end c------------------------------------------- c c c logical function notblank70_(string70) implicit none character*70 string70 integer i notblank70_ = .false. do i = 1, 70 if (string70(i:i).ge.'a'.and. . string70(i:i).le.'z') notblank70_ = .true. if (string70(i:i).ge.'A'.and. . string70(i:i).le.'Z') notblank70_ = .true. if (string70(i:i).ge.'0'.and. . string70(i:i).le.'9') notblank70_ = .true. enddo return end c------------------------------------------------------- c c subroutine pix2buff_r4(buff,pix,n1,nt) implicit none byte buff(2880) real*4 pix(*) integer n1,nt byte b(4) real*4 r equivalence(r,b) integer i, npu, nbu logical islinux do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (npu.ge.1.and.npu.le.nt) r = pix(npu) if (.not.islinux()) then buff(nbu+1) = b(1) buff(nbu+2) = b(2) buff(nbu+3) = b(3) buff(nbu+4) = b(4) endif if (islinux()) then buff(nbu+1) = b(4) buff(nbu+2) = b(3) buff(nbu+3) = b(2) buff(nbu+4) = b(1) endif enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/writfits_b1.f" c**** c********************************************* subroutine writfits_b1(FILE,pix,PXDIMX,PXDIMY) implicit none character*(*) FILE integer PXDIMX,PXDIMY byte pix(PXDIMX,PXDIMY) integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) integer ifirst, i1, i2 integer np1, np2, npt character*70 HDR(25) common/HDR/HDR character*80 FILEU FILEU = FILE do i = 75,2,-1 if (FILE(i:i+4).eq.'.fits') FILEU = FILE(1:i+4) enddo c write(*,'(''ENTER writfits_b1: '',80a)') FILEU open(10,file=FILEU, . status='unknown', . err =900, . recl =2880, . form ='UNFORMATTED', . access='DIRECT') i = 1 write(buffc( 0*80+1: 1*80),'(''SIMPLE = T '')') write(buffc( 1*80+1: 2*80),'(''BITPIX = 8 '')') write(buffc( 2*80+1: 3*80),'(''NAXIS = '',i12)') 2 write(buffc( 3*80+1: 4*80),'(''NAXIS1 = '',i12)') PXDIMX write(buffc( 4*80+1: 5*80),'(''NAXIS2 = '',i12)') PXDIMY write(buffc( 5*80+1: 6*80),'(''DATATYPE= '',9a)') . ' ''BYTE ''' write(buffc( 6*80+1: 7*80),'(''DATE = '',11a)') . ' ''28/01/00''' write(buffc( 7*80+1: 8*80),'(''BSCALE = '',i12)') 00001 write(buffc( 8*80+1: 9*80),'(''BZERO = '',i12)') 00000 write(buffc(09*80+1:10*80),'(''CRPIX1 = '',a20)') HDR(01) write(buffc(10*80+1:11*80),'(''CRPIX2 = '',a20)') HDR(02) write(buffc(11*80+1:12*80),'(''CRVAL1 = '',a20)') HDR(03) write(buffc(12*80+1:13*80),'(''CRVAL2 = '',a20)') HDR(04) write(buffc(13*80+1:14*80),'(''CTYPE1 = '',a20)') HDR(05) write(buffc(14*80+1:15*80),'(''CTYPE2 = '',a20)') HDR(06) write(buffc(15*80+1:16*80),'(''CD1_1 = '',a20)') HDR(07) write(buffc(16*80+1:17*80),'(''CD1_2 = '',a20)') HDR(08) write(buffc(17*80+1:18*80),'(''CD2_1 = '',a20)') HDR(09) write(buffc(18*80+1:19*80),'(''CD2_2 = '',a20)') HDR(10) write(buffc(19*80+1:20*80),'(''ORIENTAT= '',a20)') HDR(11) write(buffc(20*80+1:21*80),'(''PA_APER = '',a20)') HDR(12) write(buffc(21*80+1:22*80),'(''PA_V3 = '',a20)') HDR(13) write(buffc(22*80+1:23*80),'(''DATE-OBS= '',a20)') HDR(14) write(buffc(23*80+1:24*80),'(''TIME-OBS= '',a20)') HDR(15) write(buffc(24*80+1:25*80),'(''EXPTIME = '',a20)') HDR(16) write(buffc(25*80+1:26*80),'(''ROOTNAME= '',a20)') HDR(17) write(buffc(26*80+1:27*80),'(''TARGNAME= '',a20)') HDR(18) write(buffc(27*80+1:28*80),'(''RA_TARG = '',a20)') HDR(19) write(buffc(28*80+1:29*80),'(''DEC_TARG= '',a20)') HDR(20) write(buffc(29*80+1:30*80),'(''PROPOSID= '',a20)') HDR(21) write(buffc(30*80+1:31*80),'(''FILTER1 = '',a20)') HDR(22) write(buffc(31*80+1:32*80),'(''FILTER2 = '',a20)') HDR(23) write(buffc(32*80+1:33*80),'(''VAFACTOR= '',a20)') HDR(24) write(buffc(33*80+1:34*80),'(''COMMENT '')') write(buffc(34*80+1:35*80),'(''COMMENT '')') write(buffc(35*80+1:36*80),'(''END '')') c print*,buffc write(10,rec=i,iostat=ios) buffc ifirst = i+1 i1 = i i2 = i nbper = PXDIMX*PXDIMY npt = PXDIMX*PXDIMY nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 c print*,'nbyte1: ',nbyte1 c print*,'nbyte2: ',nbyte1 c print*,' i1: ',i1 c print*,' i2: ',i2 do i = i1, i2, 1 nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1) + 1 np2 = (nbyteE-nbyte1)+ 1 !if (i.lt.0010) print*,'i: ',i,i1,i2,np1,np2,nbyte0 !if (i.gt.2900) print*,'i: ',i,i1,i2,np1,np2,nbyte0 call pix2buff_b1(pix,buffb,np1,npt) write(10,rec=i,iostat=ios) buffc enddo close(10) return 900 continue print*,'WRITFITS.f ERROR' stop end subroutine pix2buff_b1(pix,buffb,n1,nt) implicit none byte pix(1) byte buffb(2880) integer n1,nt integer i integer npu byte ipval do i = 1, 2880 npu = (1+(n1-1)*2)+i-1 npu = (1+(n1-1)*1)+i-1 if (npu.ge.1.and.npu.le.nt) then ipval = pix(npu) buffb(i) = ipval endif enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/writfits_i2.f" c**** c********************************************* subroutine writfits_i2(FILE,pix,PXDIMX,PXDIMY) implicit none integer PXDIMX,PXDIMY character*(*) FILE integer*2 pix(PXDIMX,PXDIMY) integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios character*2880 buffc byte buffb(2880) equivalence (buffb,buffc) integer ifirst, i1, i2 integer j, k integer np1, np2, npt character*70 HDR(25) common/HDR/HDR character*80 FILEU integer nonspace logical notblank70 FILEU = FILE do i = 75,2,-1 if (FILE(i:i+4).eq.'.fits') FILEU = FILE(1:i+4) enddo !write(*,'(''ENTER writfits_i2: '',80a)') FILEU open(10,file=FILEU, . status='unknown', . err =900, . recl =2880, . form ='UNFORMATTED', . access='DIRECT') do k = 00, 35 write(buffc(k*80+1:k*80+80),'(80x)') enddo i = 1 write(buffc( 0*80+1: 1*80),'(''SIMPLE = T '')') write(buffc( 1*80+1: 2*80),'(''BITPIX = 16 '')') write(buffc( 2*80+1: 3*80),'(''NAXIS = '',i12)') 2 write(buffc( 3*80+1: 4*80),'(''NAXIS1 = '',i12)') PXDIMX write(buffc( 4*80+1: 5*80),'(''NAXIS2 = '',i12)') PXDIMY write(buffc( 5*80+1: 6*80),'(''DATATYPE= '',9a)') . ' ''INTEGER*4 ''' write(buffc( 6*80+1: 7*80),'(''DATE = '',11a)') . ' ''28/01/00''' write(buffc( 7*80+1: 8*80),'(''BSCALE = '',i12)') 00001 write(buffc( 8*80+1: 9*80),'(''BZERO = '',i12)') 00000 if (notblank70(HDR(01))) .write(buffc(09*80+1:10*80),'(''CRPIX1 = '',a70)') HDR(01) if (notblank70(HDR(02))) .write(buffc(10*80+1:11*80),'(''CRPIX2 = '',a70)') HDR(02) if (notblank70(HDR(03))) .write(buffc(11*80+1:12*80),'(''CRVAL1 = '',a70)') HDR(03) if (notblank70(HDR(04))) .write(buffc(12*80+1:13*80),'(''CRVAL2 = '',a70)') HDR(04) if (notblank70(HDR(05))) .write(buffc(13*80+1:14*80),'(''CTYPE1 = '',a70)') HDR(05) if (notblank70(HDR(06))) .write(buffc(14*80+1:15*80),'(''CTYPE2 = '',a70)') HDR(06) if (notblank70(HDR(07))) .write(buffc(15*80+1:16*80),'(''CD1_1 = '',a70)') HDR(07) if (notblank70(HDR(08))) .write(buffc(16*80+1:17*80),'(''CD1_2 = '',a70)') HDR(08) if (notblank70(HDR(09))) .write(buffc(17*80+1:18*80),'(''CD2_1 = '',a70)') HDR(09) if (notblank70(HDR(10))) .write(buffc(18*80+1:19*80),'(''CD2_2 = '',a70)') HDR(10) if (notblank70(HDR(11))) .write(buffc(19*80+1:20*80),'(''ORIENTAT= '',a70)') HDR(11) if (notblank70(HDR(12))) .write(buffc(20*80+1:21*80),'(''PA_APER = '',a70)') HDR(12) if (notblank70(HDR(13))) .write(buffc(21*80+1:22*80),'(''PA_V3 = '',a70)') HDR(13) if (notblank70(HDR(14))) .write(buffc(22*80+1:23*80),'(''DATE-OBS= '',a70)') HDR(14) if (notblank70(HDR(15))) .write(buffc(23*80+1:24*80),'(''TIME-OBS= '',a70)') HDR(15) if (notblank70(HDR(16))) .write(buffc(24*80+1:25*80),'(''EXPTIME = '',a70)') HDR(16) if (notblank70(HDR(17))) .write(buffc(25*80+1:26*80),'(''ROOTNAME= '',a70)') HDR(17) if (notblank70(HDR(18))) .write(buffc(26*80+1:27*80),'(''TARGNAME= '',a70)') HDR(18) if (notblank70(HDR(19))) .write(buffc(27*80+1:28*80),'(''RA_TARG = '',a70)') HDR(19) if (notblank70(HDR(20))) .write(buffc(28*80+1:29*80),'(''DEC_TARG= '',a70)') HDR(20) if (notblank70(HDR(21))) .write(buffc(29*80+1:30*80),'(''PROPOSID= '',a70)') HDR(21) if (notblank70(HDR(22))) .write(buffc(30*80+1:31*80),'(''FILTER1 = '',a70)') HDR(22) if (notblank70(HDR(23))) .write(buffc(31*80+1:32*80),'(''FILTER2 = '',a70)') HDR(23) if (notblank70(HDR(24))) .write(buffc(33*80+1:34*80),'(''VAFACTOR= '',a70)') HDR(24) if (notblank70(HDR(25))) .write(buffc(32*80+1:33*80),'(''CCDGAIN = '',a70)') HDR(25) write(buffc(33*80+1:34*80),'(''COMMENT '',a05)') ' ' write(buffc(34*80+1:35*80),'(''COMMENT '',a05)') ' ' write(buffc(35*80+1:36*80),'(''END '')') do k = 00, 34 nonspace = 0 do j = 10, 80 if (buffc(k*80+j:k*80+j).ne.' '.and. . iachar(buffc(k*80+j:k*80+j)).ne.0) nonspace = nonspace+1 enddo if (nonspace.eq.0) then do j = 1, 80 buffc(k*80+j:k*80+j) = ' ' enddo endif enddo write(10,rec=i,iostat=ios) buffc ifirst = i+1 i1 = i i2 = i nbper = 2*PXDIMX*PXDIMY npt = PXDIMX*PXDIMY nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 do i = i1, i2, 1 nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 np1 = (nbyte0-nbyte1)/2 + 1 np2 = (nbyteE-nbyte1)/2 + 1 !if (i.lt.0010) print*,'i: ',i,i1,i2,np1,np2,nbyte0 !if (i.gt.2900) print*,'i: ',i,i1,i2,np1,np2,nbyte0 call pix2buff_i2(buffb,pix,np1,npt) write(10,rec=i,iostat=ios) buffc enddo close(10) return 900 continue print*,'WRITFITS.f ERROR' stop end subroutine pix2buff_i2(buff,pix,n1,nt) implicit none byte buff(2880) integer*2 pix(*) integer n1,nt byte b(2) integer*2 ii equivalence(ii,b) integer i, npu, nbu logical islinux do i = 1, 1440 npu = n1+i-1 nbu = (i-1)*2 if (npu.ge.1.and.npu.le.nt) ii = pix(npu) if (.not.(islinux())) then buff(nbu+1) = b(1) buff(nbu+2) = b(2) else buff(nbu+1) = b(2) buff(nbu+2) = b(1) endif enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/writfits_r4_WCSLTV.f" c**** c********************************************* c----------------------------------------------------- c c this just writes a real*4 fits image c subroutine writfits_r4_WCSLTV(FILE,pix,PXDIMX,PXDIMY, . CRPIX1,CRPIX2,CRVAL1,CRVAL2, . CD1_1, CD1_2, CD2_1, CD2_2, . LTV1, LTV2, . LTM1_1,LTM1_2,LTM2_1,LTM2_2) implicit none character*(*) FILE integer PXDIMX,PXDIMY real pix(PXDIMX,PXDIMY) real*8 CRPIX1,CRPIX2,CRVAL1,CRVAL2 real*8 CD1_1, CD1_2, CD2_1, CD2_2 real*8 LTV1, LTV2 real*8 LTM1_1,LTM1_2,LTM2_1,LTM2_2 integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer i,ios character*2880 buffc byte buffb(2880) equivalence (buffb,buffc) integer ifirst, i1, i2 integer np1, np2, npt integer k character*80 FILEU character*70 HDR(25) common/HDR/HDR FILEU = FILE do i = 75,2,-1 if (FILE(i:i+4).eq.'.fits') FILEU = FILE(1:i+4) enddo open(10,file=FILEU,status='unknown', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') do k = 00, 34 write(buffc(k*80+1:k*80+80),'(80x)') enddo write(10,rec=i,iostat=ios) buffc write(buffc(00*80+1:01*80),'(''SIMPLE = T'')') write(buffc(01*80+1:02*80),'(''BITPIX = -32'')') write(buffc(02*80+1:03*80),'(''NAXIS = '',8x,i12)') 2 write(buffc(03*80+1:04*80),'(''NAXIS1 = '',8x,i12)') PXDIMX write(buffc(04*80+1:05*80),'(''NAXIS2 = '',8x,i12)') PXDIMY write(buffc(05*80+1:06*80),'(''DATATYPE= '',9a)') " 'REAL*4' " write(buffc(06*80+1:07*80),'(''COMMENT '',a05)') ' ' write(buffc(07*80+1:08*80),'(''CTYPE1 = '',a10)') "'RA---TAN'" write(buffc(08*80+1:09*80),'(''CTYPE2 = '',a10)') "'DEC--TAN'" write(buffc(09*80+1:10*80),'(''CRPIX1 = '',f20.10)') CRPIX1 write(buffc(10*80+1:11*80),'(''CRPIX2 = '',f20.10)') CRPIX2 write(buffc(11*80+1:12*80),'(''CRVAL1 = '',f20.10)') CRVAL1 write(buffc(12*80+1:13*80),'(''CRVAL2 = '',f20.10)') CRVAL2 write(buffc(13*80+1:14*80),'(''CD1_1 = '',f20.10)') CD1_1 write(buffc(14*80+1:15*80),'(''CD1_2 = '',f20.10)') CD1_2 write(buffc(15*80+1:16*80),'(''CD2_1 = '',f20.10)') CD2_1 write(buffc(16*80+1:17*80),'(''CD2_2 = '',f20.10)') CD2_2 write(buffc(17*80+1:18*80),'(''COMMENT '',a05)') ' ' write(buffc(18*80+1:19*80),'(''LTV1 = '',f20.10)') LTV1 write(buffc(19*80+1:20*80),'(''LTV2 = '',f20.10)') LTV2 write(buffc(20*80+1:21*80),'(''LTM1_1 = '',f20.10)') LTM1_1 write(buffc(21*80+1:22*80),'(''LTM1_2 = '',f20.10)') LTM1_2 write(buffc(22*80+1:23*80),'(''LTM2_1 = '',f20.10)') LTM2_1 write(buffc(23*80+1:24*80),'(''LTM2_2 = '',f20.10)') LTM2_2 write(buffc(24*80+1:25*80),'(''COMMENT '',a05)') ' ' write(buffc(25*80+1:26*80),'(''END '')') write(10,rec=i,iostat=ios) buffc ifirst = i+1 i1 = i i2 = i nbper = 4*PXDIMX*PXDIMY npt = PXDIMX*PXDIMY nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 do i = i1, i2, 1 nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 call pix2buff_r4_WCS(buffb,pix,np1,npt) write(10,rec=i,iostat=ios) buffc enddo close(10) return 900 continue print*,'writfits_r4.f ERROR' print*,' FILEU: ',FILEU stop end c------------------------------------------------------- c c subroutine pix2buff_r4_WCS(buff,pix,n1,nt) implicit none byte buff(2880) real*4 pix(*) integer n1,nt byte b(4) real*4 r equivalence(r,b) integer i, npu, nbu do i = 1, 720 npu = n1+i-1 nbu = (i-1)*4 if (npu.ge.1.and.npu.le.nt) r = pix(npu) if (.not.(_LINUX_)) then buff(nbu+1) = b(1) buff(nbu+2) = b(2) buff(nbu+3) = b(3) buff(nbu+4) = b(4) endif if ((_LINUX_)) then buff(nbu+1) = b(4) buff(nbu+2) = b(3) buff(nbu+3) = b(2) buff(nbu+4) = b(1) endif enddo return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/ROUTINES/STRING/str_contains.f" c**** c********************************************* c----------------------------------------- c c this routine will return whether STRING1 c contains an incidence STRING2 c logical function str_contains(STRING1,L1,STRING2,L2) implicit none character*(*) STRING1 integer L1 character*(*) STRING2 integer L2 integer L1u integer L2u integer L1t L1u = L1 L2u = L2 if (L1u.eq.0) then L1u = 0 11 continue if (STRING1(L1u+1:L1u+1).eq.' ') goto 12 goto 11 12 continue endif if (L2u.eq.0) then L2u = 0 21 continue if (STRING1(L2u+1:L2u+1).eq.' ') goto 22 goto 21 22 continue endif str_contains = .true. do L1t = 1, L1u-L2u+1 if (STRING1(L1t:L1t+L2u-1).eq.STRING2(1:L2u)) return enddo str_contains = .false. return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/GDC/STDGDCs/extract_stdgc.f" c**** c********************************************* c------------------------------------------------------ c c c subroutine extract_stdgc(xr,yr,xc,yc,mc,FILE_STDGC,SENSE) implicit none real*8 xr, yr real*8 xc, yc, mc character*(*) FILE_STDGC integer SENSE save logical FIRST data FIRST/.true./ character*200 FILE_STDGCu character*200 FILE_STDGCc integer NDIM_XGC, NDIM_YGC integer*4 XGC_0, NDIM_XCG integer*4 YGC_0, NDIM_YCG integer i, ios integer k character*08 FIELD character*20 STREAM character*2880 buffc real*8 fx, fy real*8 xcu, ycu integer ipix, jpix integer*4, dimension(:,:), allocatable :: xgc integer*4, dimension(:,:), allocatable :: ygc integer*2, dimension(:,:), allocatable :: mgc integer*4, dimension(:,:), allocatable :: xcg integer*4, dimension(:,:), allocatable :: ycg if (FILE_STDGC(1:4).eq.'NONE'.or. . FILE_STDGC(1:4).eq.'NULL') then if (SENSE.eq.0) then mc = 0. return endif if (SENSE.eq.1) then ! forward... xc = xr yc = yr return endif if (SENSE.eq.-1) then ! forward... xr = xc yr = yc return endif endif if (FIRST) FILE_STDGCc = ' ' FILE_STDGCu = FILE_STDGC do k = 196,2,-1 if (FILE_STDGCu(k:k+4).eq.'.fits') . FILE_STDGCu = FILE_STDGCu(1:k+4) enddo if (FILE_STDGCc.ne.FILE_STDGCu) then FILE_STDGCc = FILE_STDGCu c print*,'EXTRACT_STDGC --- OPEN(10): ',FILE_STDGCc open(10,file=FILE_STDGCc, . status='old', . err =900, . recl =2880, . form ='UNFORMATTED', . access='DIRECT') i = 1 read(10,rec=i,iostat=ios) buffc do k = 0, 35 FIELD = buffc(k*80+01:k*80+08) STREAM = buffc(k*80+11:k*80+30) if (FIELD.eq.'NDIM_XGC') read(STREAM,*) NDIM_XGC if (FIELD.eq.'NDIM_YGC') read(STREAM,*) NDIM_YGC if (FIELD.eq.'NDIM_XCG') read(STREAM,*) NDIM_XCG if (FIELD.eq.'NDIM_YCG') read(STREAM,*) NDIM_YCG if (FIELD.eq.'XGC_0 ') read(STREAM,*) XGC_0 if (FIELD.eq.'YGC_0 ') read(STREAM,*) YGC_0 enddo if (.not.FIRST) deallocate(xgc,ygc,mgc,xcg,ycg) allocate(xgc(NDIM_XGC,NDIM_YGC)) allocate(ygc(NDIM_XGC,NDIM_YGC)) allocate(mgc(NDIM_XGC,NDIM_YGC)) allocate(xcg(NDIM_XCG,NDIM_YCG)) allocate(ycg(NDIM_XCG,NDIM_YCG)) i = 2 call getext_i4(xgc,NDIM_XGC,NDIM_YGC,i) call getext_i4(ygc,NDIM_XGC,NDIM_YGC,i) call getext_i2(mgc,NDIM_XGC,NDIM_YGC,i) call getext_i4(xcg,NDIM_XCG,NDIM_YCG,i) call getext_i4(ycg,NDIM_XCG,NDIM_YCG,i) close(10) FIRST = .false. endif if (SENSE.eq.1) then ! forward... ipix = int(xr) jpix = int(yr) xc = -9999 yc = -9999 if (ipix.lt. 1-1) return if (ipix.gt.NDIM_XGC+1) return if (jpix.lt. 1-1) return if (jpix.gt.NDIM_YGC+1) return if (ipix.lt.1) ipix = 1 if (jpix.lt.1) jpix = 1 if (ipix.gt.NDIM_XGC-1) ipix = NDIM_XGC-1 if (jpix.gt.NDIM_YGC-1) jpix = NDIM_YGC-1 fx = xr-ipix fy = yr-jpix xc = (1-fx)*(1-fy)*xgc(ipix ,jpix )/1d5 . + (1-fx)*( fy )*xgc(ipix ,jpix+1)/1d5 . + ( fx )*(1-fy)*xgc(ipix+1,jpix )/1d5 . + ( fx )*( fy )*xgc(ipix+1,jpix+1)/1d5 yc = (1-fx)*(1-fy)*ygc(ipix ,jpix )/1d5 . + (1-fx)*( fy )*ygc(ipix ,jpix+1)/1d5 . + ( fx )*(1-fy)*ygc(ipix+1,jpix )/1d5 . + ( fx )*( fy )*ygc(ipix+1,jpix+1)/1d5 return endif if (SENSE.eq.0) then ! find the zeropoint... ipix = int(xr) jpix = int(yr) mc = 0.000 if (ipix.lt. 1) return if (ipix.gt.NDIM_XGC-1) return if (jpix.lt. 1) return if (jpix.gt.NDIM_YGC-1) return fx = xr-ipix fy = yr-jpix mc = (1-fx)*(1-fy)*mgc(ipix ,jpix )/1d4 . + (1-fx)*( fy )*mgc(ipix ,jpix+1)/1d4 . + ( fx )*(1-fy)*mgc(ipix+1,jpix )/1d4 . + ( fx )*( fy )*mgc(ipix+1,jpix+1)/1d4 return endif if (SENSE.eq.-1) then ! reverse xcu = 1 + (xc-XGC_0) ycu = 1 + (yc-YGC_0) ipix = int(xcu) jpix = int(ycu) xr = -1 yr = -1 if (ipix.lt. 1) return if (ipix.gt.NDIM_XCG-1) return if (jpix.lt. 1) return if (jpix.gt.NDIM_YCG-1) return if (xcg(ipix ,jpix ).le.-2000000000) return if (xcg(ipix+1,jpix ).le.-2000000000) return if (xcg(ipix ,jpix+1).le.-2000000000) return if (xcg(ipix+1,jpix+1).le.-2000000000) return fx = xcu-ipix fy = ycu-jpix xr = (1-fx)*(1-fy)*xcg(ipix ,jpix )/1d5 . + (1-fx)*( fy )*xcg(ipix ,jpix+1)/1d5 . + ( fx )*(1-fy)*xcg(ipix+1,jpix )/1d5 . + ( fx )*( fy )*xcg(ipix+1,jpix+1)/1d5 yr = (1-fx)*(1-fy)*ycg(ipix ,jpix )/1d5 . + (1-fx)*( fy )*ycg(ipix ,jpix+1)/1d5 . + ( fx )*(1-fy)*ycg(ipix+1,jpix )/1d5 . + ( fx )*( fy )*ycg(ipix+1,jpix+1)/1d5 return endif print*,'ILLEGAL SENSE',SENSE stop 900 continue print*,'file open error' print*,' FILE_STDGCc: ',FILE_STDGCc print*,' FILE_SGDGC : ',FILE_STDGC stop end c-------------------------------------------------------------------- c c subroutine getext_i4(pix,NDIMX,NDIMY,i) implicit none integer NDIMX, NDIMY integer*4 PIX(NDIMX,NDIMY) integer i integer o integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer ifirst, i1, i2, ios integer np1, np2, npt integer nbu, npu character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) byte b(4) integer*4 ii equivalence(ii,b) integer ipix, jpix ifirst = i+1 i1 = i i2 = i nbper = 4*NDIMX*NDIMY npt = NDIMX*NDIMY nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 do i = i1, i2, 1 nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/4 + 1 np2 = (nbyteE-nbyte1)/4 + 1 read(10,rec=i,iostat=ios) buffc do o = 1, 720 npu = np1+o-1 nbu = (o-1)*4 ii = 0 ipix = npu - (npu-1)/NDIMX*NDIMX jpix = 1 + (npu-1)/NDIMX if (ipix.ge.1.and.ipix.le.NDIMX.and. . jpix.ge.1.and.jpix.le.NDIMY) then if (.not.(_LINUX_)) then b(1) = buffb(nbu+1) b(2) = buffb(nbu+2) b(3) = buffb(nbu+3) b(4) = buffb(nbu+4) endif if ((_LINUX_)) then b(4) = buffb(nbu+1) b(3) = buffb(nbu+2) b(2) = buffb(nbu+3) b(1) = buffb(nbu+4) endif pix(ipix,jpix) = ii endif enddo!o enddo!i i = i2 + 1 return end c-------------------------------------------------------------------- c c subroutine getext_i2(pix,NDIMX,NDIMY,i) implicit none integer NDIMX, NDIMY integer*2 PIX(NDIMX,NDIMY) integer i integer o integer nbyte0 integer nbyteE integer nbyte1 integer nbyte2 integer nbper integer ifirst, i1, i2, ios integer np1, np2, npt integer nbu, npu character*2880 buffc byte buffb(2880) equivalence (buffc,buffb) byte b(2) integer*2 ii equivalence(ii,b) integer ipix, jpix ifirst = i+1 i1 = i i2 = i nbper = 2*NDIMX*NDIMY npt = NDIMX*NDIMY nbyte1 = 1 nbyte2 = nbper i1 = i+1 + nbyte1/2880 i2 = i+1 + nbyte2/2880 do i = i1, i2, 1 nbyte0 = (i-ifirst)*2880+ 1 nbyteE = (i-ifirst)*2880+2880 np1 = (nbyte0-nbyte1)/2 + 1 np2 = (nbyteE-nbyte1)/2 + 1 read(10,rec=i,iostat=ios) buffc do o = 1, 1440 npu = np1+o-1 nbu = (o-1)*2 ii = 0 ipix = npu - (npu-1)/NDIMX*NDIMX jpix = 1 + (npu-1)/NDIMX if (ipix.ge.1.and.ipix.le.NDIMX.and. . jpix.ge.1.and.jpix.le.NDIMY) then if (.not.(_LINUX_)) then b(1) = buffb(nbu+1) b(2) = buffb(nbu+2) endif if ((_LINUX_)) then b(2) = buffb(nbu+1) b(1) = buffb(nbu+2) endif pix(ipix,jpix) = ii endif enddo!o enddo!i i = i2 + 1 return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/GDC/STDGDCs/xcyc2xryr_stdgc.f" c**** c********************************************* c------------------------------------------------------ c subroutine xcyc2xryr_stdgc(xc,yc,xr,yr,FILE_STDGC) implicit none real*8 xc, yc real*8 xr, yr character*(*) FILE_STDGC real*8 mc call extract_stdgc(xr,yr,xc,yc,mc,FILE_STDGC,-1) ! -1 = reverse return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/GDC/STDGDCs/xryr2mc_stdgc.f" c**** c********************************************* c------------------------------------------------------ c c mc should be the pixel area correction c c subroutine xryr2mc_stdgc(xr,yr,mc,FILE_STDGC) implicit none real*8 xr, yr real*8 mc character*(*) FILE_STDGC real*8 xc, yc call extract_stdgc(xr,yr,xc,yc,mc,FILE_STDGC,0) ! 0 = pix area correction return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/GDC/STDGDCs/xryr2xcyc_stdgc.f" c**** c********************************************* c------------------------------------------------------ c subroutine xryr2xcyc_stdgc(xr,yr,xc,yc,FILE_STDGC) implicit none real*8 xr, yr real*8 xc, yc character*(*) FILE_STDGC real*8 mc call extract_stdgc(xr,yr,xc,yc,mc,FILE_STDGC,1) ! 1 = forward return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/query_hdre.f" c**** c********************************************* c--------------------------------------------------- c c This routine checks to see if the header of an image c contains a particular keyword. If it does, it returns c its value-string in STREAMX. c subroutine query_hdre(filename,FIELDX,streamx,NEXTu) implicit none character*(*) filename character*8 fieldx character*20 streamx character*8 field character*20 stream integer NEXTu character*200 FILENAMEu integer i integer ios, k character*2880 buff integer NREAD logical EXTEND integer BITPIX integer NAXIS1, NAXIS2, NAXIS3 c----------------------------------------------- streamx = ' ' do i = 1, 195 if (FILENAME(i:i+4).eq.'.fits') goto 3 enddo print*,'query_hdre...',FILENAME stop 'no ".fits" ' 3 continue FILENAMEu = FILENAME(1:i+4) close(10) open(10,file=FILENAMEu,status='old',iostat=ios, . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') streamx = 'NULL' i = 0 NREAD = 0 BITPIX = 8 EXTEND = .false. 100 continue i = i + 1 read(10,rec=i,iostat=ios) buff if (ios.eq.5002) then ! bad option (?); maybe end of file? return endif if (ios.lt. 0) goto 901 NAXIS1 = 0 NAXIS2 = 1 NAXIS3 = 1 do k = 0, 35, 1 field = buff(k*80+01:k*80+08) stream = buff(k*80+11:k*80+31) if (field.eq.fieldx) then streamx = stream(1:20) if (NEXTu.eq.-1) then close(10) return endif endif if (field.eq.'EXTEND ') read(stream,*) EXTEND if (field.eq.'END ') goto 101 if (field.eq.'BITPIX ') read(stream,*) BITPIX if (field.eq.'NAXIS1 ') read(stream,*) NAXIS1 if (field.eq.'NAXIS2 ') read(stream,*) NAXIS2 if (field.eq.'NAXIS3 ') read(stream,*) NAXIS3 continue enddo goto 100 101 continue if (NREAD.ne.NEXTu.or.NEXTu.eq.-1) then NREAD = NREAD + 1 i = i + (abs(BITPIX)/8*NAXIS1*NAXIS2*NAXIS3+2879)/2880 goto 100 endif close(10) return 900 continue print*,' ' print*,'query_hdre ERROR EXIT. ' print*,' ' print*,'FILE OPEN ERROR: ' print*,' ' write(*,'('' FIELDX: '',a8)') FIELDX print*,' ' write(*,'(''PROBLEM FILE : '',a)') FILENAME write(*,'(''PROBLEM FILEu: '',a)') FILENAMEu print*,' ' write(*,'('' IOS: '',i5)') ios print*,' ' print*,' ' print*,' ' stop 901 continue print*,' ' print*,'query_hdre ERROR EXIT. ' print*,'i/o error...' print*,' ' write(*,'('' FIELDX: '',a8)') FIELDX print*,' ' write(*,'(''PROBLEM FILE : '',a)') FILENAME write(*,'(''PROBLEM FILEu: '',a)') FILENAMEu print*,' ' write(*,'('' IOS: '',i5)') ios print*,' ' stop end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/query_hdre_i4.f" c**** c********************************************* c--------------------------------------------------- c integer function i4_query_hdre(filename,FIELDX,NEXTu) implicit none character*(*) FILENAME character*8 FIELDX integer NEXTu integer i4 call query_hdre_i4(FILENAME,FIELDX,i4,NEXTu) i4_query_hdre = i4 return end c--------------------------------------------------- c subroutine query_hdre_i4(filename,FIELDX,i4,NEXTu) implicit none character*(*) filename c character*8 field integer*4 i4 integer NEXTu c character*20 stream character*8 fieldx character*20 streamx c integer i c integer ios, k c character*2880 buff c integer nread c logical EXTEND c integer ii c integer nn c----------------------------------------------- streamx = ' ' call query_hdre(filename,FIELDX,streamx,NEXTu) read(STREAMX,*,err=3) i4 return 3 continue i4 = -1 return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/query_hdre_r4.f" c**** c********************************************* real*4 function r4_query_hdre(filename,FIELDX,NEXTu) implicit none character*(*) FILENAME character*8 FIELDX integer NEXTu real r4 call query_hdre_r4(filename,FIELDX,r4,NEXTu) r4_query_hdre = r4 return end c--------------------------------------------------- c c This routine checks to see if the header of an image c contains a particular keyword. If it does, it returns c its value-string in STREAMX. c subroutine query_hdre_r4(filename,FIELDX,r4,NEXTu) implicit none character*(*) filename character*8 FIELDX real r4 integer NEXTu character*20 streamx c real*4 safe_read_r4 streamx = ' ' call query_hdre(filename,FIELDX,streamx,NEXTu) read(STREAMX,*,err=3) r4 return 3 continue r4 = -1 return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/query_hdre_r8.f" c**** c********************************************* real*8 function r8_query_hdre(FILENAME,FIELDX,NEXTu) implicit none character*80 FILENAME character*8 FIELDX integer NEXTu real*8 r8 call query_hdre_r8(filename,FIELDX,r8,NEXTu) r8_query_hdre = r8 return end c--------------------------------------------------- c c This routine checks to see if the header of an image c contains a particular keyword. If it does, it returns c its value-string in STREAMX. c subroutine query_hdre_r8(filename,FIELDX,r8,NEXTu) implicit none character*(*) filename character*8 FIELDX real*8 r8 integer NEXTu character*20 streamx real*8 safe_read_r8 streamx = ' ' call query_hdre(filename,FIELDX,streamx,NEXTu) r8 = safe_read_r8(STREAMX) return end real*8 function safe_read_r8(STREAMX) implicit none character*20 STREAMX integer i integer n safe_read_r8 = -1 n = 0 do i = 1, 20 if (STREAMX(i:i).ne.' ') then if (.not.STREAMX(i:i).ge.'0'.and. . .not.STREAMX(i:i).le.'9'.and. . .not.STREAMX(i:i).eq.'.'.and. . .not.STREAMX(i:i).eq.'e'.and. . .not.STREAMX(i:i).eq.'-'.and. . .not.STREAMX(i:i).eq.'+'.and. . .not.STREAMX(i:i).eq.' ') goto 1 n = n + 1 endif enddo if (n.ge.1) then read(STREAMX,*,err=5) safe_read_r8 return endif 1 return 5 continue print*,' ' print*,'ERROR IN: ' print*,' ' print*,'safe_read_r8: ' print*,' STREAMX: ',STREAMX print*,' ' print*,' ' safe_read_r8 = 0. return end c********************************************* c**** c**** #include "/user/jayander/FORTRAN/FITSIO/GEN/rdate_header.f" c**** c********************************************* real*8 function rdate_header(FILENAME) implicit none integer i character filename*(*) c integer NCHAR c integer iEXPT c real rEXPT integer iPA real rPA integer iPID c character*6 FILTSTR c character*9 ROOTSTR real rRA real rDEC character*20 DATESTR character*20 TIMESTR integer iMIN, iSEC c character decsgn c real rRA0, rDC0 c real dRA real rSUNA real rTEMP c real vaFAC integer iDAY integer iMON integer iYIR integer iHRS real*8 rDAT character*8 field character*20 stream integer ios, k character*2880 buff integer nread c character*11 OBJNAME integer DOY(12) data DOY / 000, 031, 059, 090, 120, 151, . 181, 212, 243, 273, 304, 334/ c character*8 CHINJVAL rdate_header = 0.0 DATESTR = 'DATELESS' TIMESTR = 'TIMELESS' rRA = 0. rDEC = 0. iPID = 0 iPA = 0 rPA = 0 rSUNA = 0. rTEMP = 0. open(10,file=FILENAME,status='old', . err=900,recl=2880,form='UNFORMATTED', . access='DIRECT') i = 0 nread = 0 100 continue i = i + 1 read(10,rec=i,iostat=ios) buff if (ios.lt.0) goto 900 do k = 0, 35, 1 field = buff(k*80+01:k*80+08) stream = buff(k*80+11:k*80+31) if (field.eq.'TIME-OBS') TIMESTR = stream(01:20) if (field.eq.'DATE-OBS') DATESTR = stream(01:20) if (field.eq.'END ') goto 101 enddo goto 100 101 close(10) if (DATESTR(06:06).eq.'-'.and.DATESTR(09:09).eq.'-') . DATESTR = DATESTR(02:13) if (DATESTR(07:07).eq.'-'.and.DATESTR(10:10).eq.'-') . DATESTR = DATESTR(03:14) if (DATESTR(08:08).eq.'-'.and.DATESTR(11:11).eq.'-') . DATESTR = DATESTR(04:15) if (TIMESTR(04:04).eq.':'.and.TIMESTR(07:07).eq.':') . TIMESTR = TIMESTR(02:09) if (TIMESTR(05:05).eq.':'.and.TIMESTR(05:05).eq.':') . TIMESTR = TIMESTR(03:10) if (DATESTR.eq.'DATELESS') return if (TIMESTR.eq.'TIMELESS') return if (DATESTR.ne.'DATELESS') then read(DATESTR(01:04),*) iYIR read(DATESTR(06:07),*) iMON if (iMON.lt.01.or.iMON.gt.12) then print*,'---> iMON: ',iMON print*,'---> DATE: ',DATESTR stop endif read(DATESTR(09:10),*) iDAY endif if (TIMESTR.ne.'TIMELESS') then read(TIMESTR(1:2),*) iHRS read(TIMESTR(4:5),*) iMIN read(TIMESTR(7:8),*) iSEC endif rDAT = iYIR + (DOY(iMON)+iDAY)/365.0d0 rDAT = rDAT + (iHRS + iMIN/60. + iSEC/60./60.)/8766.d0 rdate_header = rDAT return 900 continue print*,' ' print*,'rdate_header...' print*,' PROBLEM OPENING FILE: ',FILENAME print*,' ' stop end