PROGRAM u2chk C C pgf77 -o u2chk u2chk.f u2sub.f C C 030416 NZ create C 030417 NZ finish, debug, test C 030418 NZ change index file (no 0) C 030420 NZ finish byte flip implementation C add histogram data C 030421 NZ extend to 25 items (idat) C 030422 NZ add accum.#stars in table, list bins ns=0 C 030424 NZ add (R-J) color index histogram C 030427 NZ use subr. open_zfile, use only 23 items C 030501 NZ count_id and cat_id C 030528 NZ replace "rflg" by "epos" C 030529 NZ extend ncat,icat for flag A2 C 030530 NZ comment out nhpmnl test printout C 030601 NZ outut nx array to DA file, line by line C C - interactive C - read unformatted, direct access zone files C - check for byte-flip C - read all data C - check for RA,Dec out-of-range, other warnings C - get statistics: counts, min,max per item & zone, histograms C - option: output index files IMPLICIT NONE INTEGER zmax, jmax, dimi, dimb PARAMETER (zmax= 288 ! maximal zone number . ,jmax= 240 ! bins along RA (0.1 h steps) . ,dimi= 25 ! numb. of items each star . ,dimb= 32 ) ! numb. of histogram bins INTEGER idat(dimi) ! all integer data each star . ,datmi(dimi), datma(dimi) . ,dazmi(zmax,dimi), dazma(zmax,dimi) INTEGER nx (zmax,jmax) ! accumul.numb.stars for index file . ,cnt(zmax,jmax) ! star count = f (zone,RA) INTEGER nsz(zmax) INTEGER hisn(dimi,0:dimb), his0(dimi), hiss(dimi) INTEGER hisc(0:dimb) INTEGER ncat(7), icat(7) ! count individ. catalogs for PM DATA hiss / 54000000, 18000000, 50, 5, 5, 1, 5, 1, 1 . , 1000, 1000, 1000, 1000, 10, 10, 4, 4 ! step size histograms . , 100000000, 500, 500, 500, 10, 10, 2000000, 2000000/ DATA his0 / 0, -18, 10, 0, 0, 0, 0, 0, 0 . , -5, -5, -15, -15, 0, 0, 0, 0 ! offset index histogr. . , 0, 0, 0, 0, 0, 0, 0, 0 / INTEGER i,j,k,jj,hb, jz,jo, zn,z1,z2, un, ni, ra0, n2m . ,j240, j000, ns, nat,naz, dc1,dc2,ra2,nxr,nxd . ,cmi,cma, nzmi,nzma, u2id, id_prob, nsza, n0,ztop INTEGER color, pmrac, pm_max, nhpmnl REAL*8 dcma, rama, cosdec, mas2rad CHARACTER*40 pathz, patho, answer, fnxf,fnxu,fnxd,fnlog,fnz CHARACTER*1 x1, a1, cxr,cxd LOGICAL errflg, outx, bf, only_rd * defaults CC pathz = '/d1/rl/u2/' pathz = '/mnt/cdrom/u2/' patho = './' x1 = 'y' z1 = 1 z2 = 55 un = 11 ! file device unit number for zone files only_rd = .TRUE. ! no write to zone files n2m = 0 ! count stars with valid 2MASS photometry j240 = 0 j000 = 0 ra2 = 360 * 3600 * 1000 ! 24 hour in mas id_prob = 0 ! count cases of ID# problems mas2rad = DATAN (1.0d0) / (4.5d1 * 3.6d6) nhpmnl = 0 * get info from user WRITE (*,'(/a)') 'UCAC2 release check program' WRITE (*,'(a/)') ' hit "enter" for defaults' WRITE (*,'(a)') 'path for input zone files = ' WRITE (*,'(a,$)') pathz READ (*,'(a)') answer IF (answer.NE.' ') pathz = answer WRITE (*,'(a)') 'path for output files = ' WRITE (*,'(a,$)') patho READ (*,'(a)') answer IF (answer.NE.' ') patho = answer WRITE (*,'(a,a,a,$)') . 'shall I output index files ? ',x1,' ' READ (*,'(a)') a1 IF (answer.NE.' ') x1 = a1 * check for byte flip CALL chk_byte_flip (pathz,un,bf) * loop 101 WRITE (*,'(a,i4,a,$)') 'run up to zone = ',z2,' ' READ (*,'(a)') answer IF (answer.NE.' ') READ (answer,*) z2 IF (z2.LE.0.OR.z2.GT.zmax) THEN WRITE (*,'(a,i3,a)') 'invaid: range = 1...',zmax,', z2 > z1' GOTO 101 ENDIF * prepare jz = INDEX(pathz,' ') - 1 ! length of string jo = INDEX(patho,' ') - 1 fnxf = patho(1:jo) // 'u2index.txt' ! formatted, ASCII fnxu = patho(1:jo) // 'u2index.unf' ! unformatted, single record fnxd = patho(1:jo) // 'u2index.da' ! same as DA file fnlog= patho(1:jo) // 'u2chk.log' WRITE (*,'(/a,a)') 'log output will go to ',fnlog IF (x1.EQ.'y'.OR.x1.EQ.'Y') THEN outx = .TRUE. WRITE (*,'(a,a)') 'index text file = ',fnxf CC WRITE (*,'(a,a)') 'index unform. file = ',fnxu WRITE (*,'(a,a)') 'index unform. DA file= ',fnxd ELSE outx = .FALSE. ENDIF * start log output OPEN (9,FILE=fnlog) WRITE (9,'(a )') 'log output of ' WRITE (9,'(a )') '---------------------' WRITE (9,'(a,a)') 'input path = ',pathz(1:jz) WRITE (9,'(a,a)') 'output path = ',patho(1:jo) WRITE (9,'(a,2i4/)') 'range of zones = ',z1,z2 CC WRITE (9,'(/a)') 'histogram: step size, offset =' CC DO j=1,dimi CC WRITE (9,'(i3,i10,i6)') j,hiss(j),his0(j) CC ENDDO * initialize DO zn=1,zmax DO j=1,jmax cnt (zn,j) = 0 ENDDO ENDDO DO j=1,dimi datmi (j) = 999000000 datma (j) =-999000000 ENDDO DO zn=1,zmax nsz (zn) = 0 ENDDO DO hb=0,dimb hisc(hb) = 0 DO j=1,dimi hisn(j,hb) = 0 ENDDO ENDDO DO j=1,7 ncat(j) = 0 ENDDO ns = 0 ! counter total number stars read u2id = 0 * loop all zones DO zn=z1,z2 WRITE (*,'(a,i3)') 'begin with zone = ',zn CALL open_zfile (pathz,un,zn,only_rd) * loop all stars DO i=1,999000 CALL read_u2line (un,i,bf,idat,errflg) IF (errflg) GOTO 91 CC IF (zn.EQ.1.AND.i.LE.3) THEN CC WRITE (*,'(a,i6)') 'test print i = ',i CC WRITE (*,'(6i11)') (idat(j),j= 1, 6) CC WRITE (*,'(6i11)') (idat(j),j= 7,12) CC WRITE (*,'(6i11)') (idat(j),j=13,18) CC WRITE (*,'(6i11)') (idat(j),j=19,24) CC ENDIF ns = ns + 1 nsz(zn) = nsz(zn) + 1 * check sorting by RA (within zone) IF (nsz(zn).GT.1) THEN ! need previous star in same zone IF (idat(1).LT.ra0) THEN WRITE (*,'(a,i3,3i11)') . 'sort by RA error: zone,i,RA = ',zn,i,idat(1),ra0 STOP ENDIF ENDIF ra0 = idat(1) ! save for comparison with next star * check running UCAC2 ID number u2id = u2id + 1 ! should be this running number CC IF (idat(24).NE.u2id) THEN CC id_prob = id_prob + 1 ! count problem cases CC ENDIF * count individual catalogs used for PM CALL count_id (idat(9),ncat) ! item 9 = cflg * numb.of high PM stars not in NLTT cosdec = DCOS (idat(2)*mas2rad) pmrac = IDNINT (idat(12) * cosdec) ! 0.1 mas/yr pm_max = MAX (ABS(pmrac),idat(13)) ! 0.1 mas/yr IF (pm_max.GT.1800) THEN CALL cat_id (idat(9),icat) ! identify catalogs IF (icat(6).EQ.0) THEN nhpmnl = nhpmnl + 1 CC WRITE (9,'(a,i3,i9,i7,2i11,i5,1x,7i1)') CC . 'nhpmnl,u2id,pm_max=' CC . ,nhpmnl,u2id,pm_max, idat(1),idat(2),idat(3) CC . ,(icat(j),j=1,7) ENDIF ENDIF * histogram input DO j=1,dimi ! all items hb = IDNINT (DFLOAT(idat(j)) / DFLOAT(hiss(j))) - his0(j) IF (hb.LT.0) hb = 0 IF (hb.GT.dimb) hb = dimb hisn(j,hb) = hisn(j,hb) + 1 ENDDO IF (idat(18).GT.0) THEN ! is a 2MASS star color = 10 * idat(3) - idat(19) ! R - J color index (mmag) hb = IDNINT (DFLOAT(color) / 500) + 6 ! index 0 = -3 mag IF (hb.LT.0) hb = 0 IF (hb.GT.dimb) hb = dimb hisc(hb) = hisc(hb) + 1 ENDIF * initialize min,max IF (ns.EQ.1) THEN ! overall DO j=1,dimi datmi (j) = idat(j) datma (j) = idat(j) ENDDO ENDIF IF (nsz(zn).EQ.1) THEN ! each zone DO j=1,dimi dazmi (zn,j) = idat(j) dazma (zn,j) = idat(j) ENDDO ENDIF * find min, max values for all items DO j=1,dimi IF (idat(j).LT.datmi(j)) datmi(j) = idat(j) IF (idat(j).GT.datma(j)) datma(j) = idat(j) IF (idat(j).LT.dazmi(zn,j)) dazmi(zn,j) = idat(j) IF (idat(j).GT.dazma(zn,j)) dazma(zn,j) = idat(j) ENDDO * count stars = f (zone, RA bin) for index jj = idat(1) / 5400000 + 1 ! 0.1 hour bins (mas) IF (jj.GT.jmax) THEN j240 = j240 + 1 jj = 240 ENDIF IF (idat(1).LT.0) THEN j000 = j000 + 1 jj = 1 ENDIF cnt (zn,jj) = cnt (zn,jj) + 1 * count valid 2MASS photometry IF (idat(18).GT.0) n2m = n2m + 1 ENDDO ! loop all stars each zone 91 CLOSE (un) WRITE (*,'(a,2i9)') . '... done, stars in zone, total = ',nsz(zn),ns ENDDO ! all zones * output statistics to log file WRITE (9,'(/a,i9)') 'total number stars read = ',ns WRITE (9,'(a,2i9)') 'number of RA <0, >=24h = ',j000,j240 WRITE (9,'( a,i9)') 'number stars ID problem = ',id_prob WRITE (9,'( a,i9)') 'number stars valid 2MASS= ',n2m WRITE (9,'( a,i9)') 'numb.stars no 2MASS phot= ',ns-n2m WRITE (9,'( a,i9)') 'n. high PM, not in NLTT = ',nhpmnl WRITE (9,'(/a,a)') 'catalog ID bit: 1' . ,' 2 4 8 16 32 64' WRITE (9,'(a,a)') 'catalog name : YS' . ,' AC2000 Tycho-2 AGK2 Hip NLTT USNO-A2' WRITE (9,'( a,7i8)') 'numb.of stars :',(ncat(j),j=1,7) WRITE (9,'(/a)') 'overall min,max for each item:' WRITE (9,'(2i11,a)') datmi( 1),datma( 1),' 1 RA2000 (mas)' WRITE (9,'(2i11,a)') datmi( 2),datma( 2),' 2 DC2000 (mas)' WRITE (9,'(2i11,a)') datmi( 3),datma( 3),' 3 UCAC mag (1/100)' WRITE (9,'(2i11,a)') datmi( 4),datma( 4),' 4 sigx (mas)' WRITE (9,'(2i11,a)') datmi( 5),datma( 5),' 5 sigy (mas)' WRITE (9,'(2i11,a)') datmi( 6),datma( 6),' 6 nobs UCAC' WRITE (9,'(2i11,a)') datmi( 7),datma( 7),' 7 epos UCAC (mas)' WRITE (9,'(2i11,a)') datmi( 8),datma( 8),' 8 n.catalogs PM' WRITE (9,'(2i11,a)') datmi( 9),datma( 9),' 9 PM cat. ID' WRITE (9,'(2i11,a)') datmi(10),datma(10),' 10 centr.epoch RA,DC' WRITE (9,'(2i11,a)') datmi(11),datma(11),' 11 1/1000 yr - 1975' WRITE (9,'(2i11,a)') datmi(12),datma(12) . ,' 12 PM RA (no cos) (0.1 mas/yr)' WRITE (9,'(2i11,a)') datmi(13),datma(13) . ,' 13 PM Declination (0.1 mas/yr)' WRITE (9,'(2i11,a)') datmi(14),datma(14) . ,' 14 sig PMx (0.1 mas/yr)' WRITE (9,'(2i11,a)') datmi(15),datma(15) . ,' 15 sig PMy (0.1 mas/yr)' WRITE (9,'(2i11,a)') datmi(16),datma(16),' 16 ratio x (1/20)' WRITE (9,'(2i11,a)') datmi(17),datma(17),' 17 ratio y (1/20)' WRITE (9,'(2i11,a)') datmi(18),datma(18),' 18 2MASS identifier' WRITE (9,'(2i11,a)') datmi(19),datma(19) . ,' 19 2MASS J mag (1/1000)' WRITE (9,'(2i11,a)') datmi(20),datma(20) . ,' 20 2MASS H mag (1/1000)' WRITE (9,'(2i11,a)') datmi(21),datma(21) . ,' 21 2MASS K mag (1/1000)' WRITE (9,'(2i11,a)') datmi(22),datma(22),' 22 2MASS ph_qual' WRITE (9,'(2i11,a)') datmi(23),datma(23),' 23 2MASS cc_flag' CC WRITE (9,'(2i11,a)') datmi(24),datma(24),' 24 UCAC2 ID' CC WRITE (9,'(2i11,a)') datmi(24),datma(25),' 25 run11 ID' * generate index vector, output to formatted table IF (outx) THEN OPEN (13,FILE=fnxf) WRITE (13,'(a)') 'nsbin= number of stars in this bin' WRITE (13,'(a)') 'naz = number of stars accumulated in zone' WRITE (13,'(a)') 'nat = number of stars accumulated total' WRITE (13,'(a)') 'zn = zone number' WRITE (13,'(a)') 'jj = RA index = 1...240 for 0.1 hour bins' WRITE (13,'(a)') 'DCmax= largest declination of bin (deg)' WRITE (13,'(a)') 'RAmax= largest right ascension of bin (h)' WRITE (13,'(/a)') . ' nsbin naz nat zn jj DCmax RAmax' WRITE (13,'(100a1)') ('-',j=1,44) nat = 0 cmi = cnt (1,1) cma = cnt (1,1) DO zn=z1,z2 naz = 0 DO jj=1,jmax IF (cnt(zn,jj).LT.cmi) cmi = cnt(zn,jj) IF (cnt(zn,jj).GT.cma) cma = cnt(zn,jj) nat= nat + cnt (zn,jj) ! accumulated total numb.stars naz= naz + cnt (zn,jj) ! accumulated numb.stars per zone nx (zn,jj) = nat dcma = zn * 0.5d0 - 90.0d0 rama = jj * 0.1d0 WRITE (13,'(i6,i8,i9,2i4,f6.1,f5.1)') . cnt(zn,jj), naz, nat, zn, jj, dcma, rama ENDDO IF (zn.EQ.1) THEN nzmi = naz nzma = naz ELSE IF (naz.LT.nzmi) nzmi = naz IF (naz.GT.nzma) nzma = naz ENDIF ENDDO ! all zones output formatted index file * output index to unformatted file CC OPEN (12,FILE=fnxu,FORM='unformatted') CC WRITE (12) nx CC CLOSE (12) OPEN (12,FILE=fnxd,ACCESS='direct',RECL=960) ! 240 * 4 byte DO zn=1,zmax WRITE (12,REC=zn) (nx(zn,k),k=1,240) ! determines order of elements ENDDO CLOSE (12) ENDIF ! output of index files requested * table of bins with no stars WRITE (9,'(/a)') 'table of bins with no stars:' WRITE (9,'( a)') ' zn RAi max_dec RA min RA max' WRITE (9,'( a)') '--------------------------------' n0 = 0 IF (z2.LT.261) THEN ztop = z2 ELSE ztop = 261 ENDIF DO zn=z1,ztop ! survey gets incomplete above +40 decl. DO jj=1,jmax IF (cnt(zn,jj).LE.0) THEN n0 = n0 + 1 dcma = zn * 0.5d0 - 90.0d0 rama = jj * 0.1d0 WRITE (9,'(i3,i5,3f8.2)') . zn,jj,dcma,rama-0.1,rama ENDIF ENDDO ENDDO WRITE (9,'(a,i6,2i4)') . 'number of bins with no stars, z1,ztop = ',n0,z1,ztop WRITE (*,'(/a,i6,2i4)') . 'number of bins with no stars, z1,ztop = ',n0,z1,ztop * table by zone number WRITE (9,'(/a,a)') . 'zone, number of stars in zone, ' . ,'accumulated, min,max RA,Dec (mas):' WRITE (9,'(a,a)') . ' zn nsz ntot' . ,' min_ra max_ra min_dc max_dc' WRITE (9,'(100a1)') ('-',j=1,64) nxr = 0 ! count stars out of range in RA nxd = 0 ! count stars out of range in Dec nsza= 0 ! accumulated number of stars DO zn=z1,z2 IF (dazmi(zn,1).LT.0.OR.dazma(zn,1).GT.ra2) THEN nxr = nxr + 1 cxr = 'R' ELSE cxr = ' ' ENDIF dc1 = (zn-1) * 1800000 -324000000 ! smallest expected Dec dc2 = zn * 1800000 -324000001 ! largest expected Dec IF (dazmi(zn,2).LT.dc1.OR.dazma(zn,2).GT.dc2) THEN nxd = nxd + 1 cxd = 'D' ELSE cxd = ' ' ENDIF nsza = nsza + nsz(zn) ! gives UCAC2 ID if started at zone 1 WRITE (9,'(i3,i8,i9,4i11,1x,2a1)') zn,nsz(zn), nsza . ,dazmi(zn,1),dazma(zn,1), dazmi(zn,2),dazma(zn,2) . ,cxr,cxd ENDDO WRITE (9,'(/a,i6)') 'number of stars out of range RA = ',nxr WRITE (9,'( a,i6)') 'number of stars out of range Dec = ',nxd * overall statistic WRITE (9,'(a,2i8)') 'min,max numb.stars in a bin =',cmi,cma WRITE (*,'(a,2i8)') 'min,max numb.stars in a bin =',cmi,cma WRITE (9,'(a,2i8)') 'min,max numb.stars in a zone =',nzmi,nzma WRITE (*,'(a,2i8)') 'min,max numb.stars in a zone =',nzmi,nzma * histogram data * re-assign step size: change of units for following output table hiss ( 1) = 1 ! RA unit now hour hiss ( 2) = 5 ! dec unit now degree hiss ( 3) = 5 ! 1/2 mag * 10 hiss (10) = 1 ! epoch now year his0 (10) = 1970 ! -10 + 1980 hiss (11) = 1 ! epoch now year his0 (11) = 1970 ! -10 + 1980 hiss (12) = 1 ! proper motion: now unit = 0.1 mas/yr hiss (13) = 1 hiss (14) = 1 ! error prop.mot.: now unit = mas/yr hiss (15) = 1 hiss (16) = 2 ! ratio: now unit = 0.1, step = 0.2 hiss (17) = 2 hiss (18) = 1 hiss (19) = 5 ! 1/2 mag steps * 10 hiss (20) = 5 hiss (21) = 5 WRITE (9,'(/a,a)') . 'histogram data by item: ns = numb.of stars,' . ,' bin value = center of bin' WRITE (9,'(a)') . 'the first and last bin also contains stars out of range' WRITE (9,'(/a,a)') . ' ns RA ns Dec ns mag' . ,' ns sigx ns sigy ns R-J' DO hb=0,dimb WRITE (9,'(6(i9,i5))') . (hisn(j,hb), (hb+his0(j))*hiss(j), j= 1, 5) . , hisc(hb),(hb-6)*5 ENDDO WRITE (9,'(/a,a)') . ' ns nobs ns epos ns ncat' . ,' ns cflg ns cepr ns cepd' DO hb=0,dimb WRITE (9,'(6(i9,i5))') . (hisn(j,hb), (hb+his0(j))*hiss(j), j= 6,11) ENDDO WRITE (9,'(/a,a)') . ' ns pmr ns pmd ns spmx' . ,' ns spmy ns rx ns ry' DO hb=0,dimb WRITE (9,'(6(i9,i5))') . (hisn(j,hb), (hb+his0(j))*hiss(j), j=12,17) ENDDO WRITE (9,'(/a,a)') . ' ns 2mid ns 2m_J ns 2m_H' . ,' ns 2m_K ns 2mph ns 2mcc' DO hb=0,dimb WRITE (9,'(6(i9,i5))') . (hisn(j,hb), (hb+his0(j))*hiss(j), j=18,23) ENDDO * the end WRITE (*,'(/2a)') 'for more see log file = ',fnlog WRITE (*,'(a/)') 'thanks for using , have a nice day!' END ! main *******************************************************************