.000755 000151 000151 00000000000 06573236407 010352 5ustar00xpmm000001 1115757 ./corner.f000644 000151 000151 00000003156 06505525271 012056 0ustar00xpmm000001 1117016 SUBROUTINE corner(r,d,s) c c...Take Nominal And Compute Corners And Other Search Parameters c INCLUDE * 'square.inc' DOUBLE PRECISION * r, d, s, rd, r1, r2, d1, d2, cd, zmin, zmax INTEGER * i, j, z1, z2 c 9001 FORMAT (' Illegal Input: R=', f10.6, ' D=', f10.6) 9002 FORMAT (' Illegal Size=', f10.6) c c...Sanity Checks c 100 IF ((r.lt.0.0D00).or.(r.ge.24.0D00)) THEN WRITE (*,9001) r,d CALL EXIT(0) ENDIF IF ((d.le.-90.0D00).or.(d.ge.90.0D00)) THEN WRITE (*,9001) r,d CALL EXIT(0) ENDIF IF (s.le.0.0D00) THEN WRITE (*,9002) s CALL EXIT(0) ENDIF c c...Compute The Corners And Number Of RA Chunks c rd = r*15.0D00 rcent = rd dcent = d cd = COSD(d) r1 = rd - s/cd r2 = rd + s/cd IF (r1.lt.0.0D00) THEN nra = 2 rfrst(1) = 0.0D00 rlast(1) = r2 rfrst(2) = 360.0D00+r1 rlast(2) = 360.0D00 ELSEIF (r2.ge.360.0D00) THEN nra = 2 rfrst(1) = 0.0D00 rlast(1) = r2-360.0D00 rfrst(2) = r1 rlast(2) = 360.0D00 ELSE nra = 1 rfrst(1) = r1 rlast(1) = r2 ENDIF c c...Compute Dec Corners And Zones c d1 = d - s d2 = d + s z1 = (d1+90.0D00)/7.5D00 z2 = (d2+90.0D00)/7.5D00 ndec = z2+1-z1 j = 0 DO i=z1,z2 zmin = i*7.5D00 - 90.0D00 zmax = zmin+7.5D00 j = j+1 dzone(j) = i*75 dfrst(j) = MAX(d1,zmin) dlast(j) = MIN(d2,zmax) ENDDO RETURN END ./density.f000644 000151 000151 00000001514 06505525271 012245 0ustar00xpmm000001 1116057 PROGRAM density c c...Make An Image From The Density Of UA Sources c c WARNING - Uses SLALIB c INCLUDE * 'square.inc' PARAMETER * naxis1 = 1024, * naxis2 = naxis1 DOUBLE PRECISION * r, d, s INTEGER * i, j, image(NAXIS1,NAXIS2) c 9001 FORMAT (' Found', i10, ' Entries') c 100 oldzone = -1 CALL gimme(r,d,s) CALL precess(r,d) CALL xycorner(r,d,s) DO j=1,NAXIS2 DO i=1,NAXIS2 image(i,j) = 0 ENDDO ENDDO nsav = 0 DO j=1,ndec DO i=1,nra CALL sumit(rfrst(i),rlast(i),dzone(j),dfrst(j),dlast(j), * r,d,s,NAXIS1,NAXIS2,image) ENDDO ENDDO WRITE (*,9001) nsav CALL fitsit(NAXIS1,NAXIS2,image,0) CALL EXIT(0) END ./eathist.f000644 000151 000151 00000006732 06505525271 012226 0ustar00xpmm000001 1070500 SUBROUTINE eathist(r1,r2,dz,d1,d2) c c...Ingest ACC And Loop Over DAT c INCLUDE * 'square.inc' INTEGER * dz, i, i1, i2, fr, nr, C_ROOPEN, fd, nlb, err, * C_POSITION, n, nmost, nlast, ir1, ir2, id1, id2, * C_CLOSER, C_READER, m, j, k, f, mb, mr DOUBLE PRECISION * r1, r2, d1, d2 CHARACTER*64 * lb BYTE * bb(65) c 9001 FORMAT ('/uq6/xpmm/a1.0/zone', i4.4, '.acc') 9002 FORMAT (5x, 2i12) 9003 FORMAT (' Cannot Open ', a) 9004 FORMAT (' Fatal Error Accessing ', a) 9005 FORMAT (' Too Many Stars - Quitting Early') 9006 FORMAT (' Z=', i4, ' RA(', i9, ':', i9, ') SPD(', i9, ':', * i9, ')') c c...Eat The ACC File c 100 IF (dz.ne.oldzone) THEN WRITE (lb,9001) dz nlb = 27 OPEN ( * access='sequential', * carriagecontrol='list', * dispose='keep', * err=200, * form='formatted', * name=lb(1:nlb), * readonly, * shared, * status='old', * unit=1 * ) DO i=1,NACC READ (1,9002) frec(i),nrec(i) ENDDO CLOSE (1) oldzone = dz ENDIF c c...Compute Offset And Length c i1 = r1/3.75D00 i1 = MAX(1,MIN(NACC,i1+1)) i2 = r2/3.75D00 i2 = MAX(1,MIN(NACC,i2+1)) fr = frec(i1)-1 nr = 0 DO i=i1,i2 nr = nr+nrec(i) ENDDO c c...Open And Position File c lb(nlb-2:nlb) = 'cat' DO i=1,nlb bb(i) = ICHAR(lb(i:i)) ENDDO bb(nlb+1) = 0 fd = C_ROOPEN(bb) IF (fd.lt.3) THEN WRITE (*,9003) lb(1:nlb) CALL EXIT(0) ENDIF IF (fr.gt.0) THEN err = C_POSITION(fd,12*fr) IF (err.le.0) THEN WRITE (*,9004) lb(1:nlb) CALL EXIT(0) ENDIF ENDIF c c...Set Up Search Parameters c n = ((nr-1)/NCHUNK) + 1 IF (n.gt.1) THEN nmost = NCHUNK nlast = nr - (n-1)*NCHUNK ELSE nmost = 0 nlast = nr ENDIF ir1 = CONVERT*r1 ir2 = CONVERT*r2 id1 = CONVERT*(d1+90.0D00) id2 = CONVERT*(d2+90.0D00) WRITE (*,9006) oldzone,ir1,ir2,id1,id2 c c...Do The Search c DO i=1,n IF (i.eq.n) THEN m = nlast ELSE m = nmost ENDIF err = C_READER(fd,buf,12*m) IF (err.ne.0) THEN WRITE (*,9004) lb(1:nlb) CALL EXIT(0) ENDIF DO j=1,m IF (buf(1,j).ge.ir1) THEN IF (buf(1,j).le.ir2) THEN IF ((buf(2,j).ge.id1).and.(buf(2,j).le.id2)) THEN k = MOD(ABS(buf(3,j)),1000000000) f = k/1000000 k = k - f*1000000 mb = k/1000 mr = k - mb*1000 IF (f.gt.0) THEN mb = mb/10 IF ((mb.ge.1).and.(mb.le.NHIST)) THEN bhist(mb) = bhist(mb)+1 ENDIF mr = mr/10 IF ((mr.ge.1).and.(mr.le.NHIST)) THEN rhist(mr) = rhist(mr)+1 ENDIF ENDIF ENDIF ELSE GO TO 110 ENDIF ENDIF ENDDO fr = fr+m ENDDO c c...All Done c 110 err = C_CLOSER(fd) RETURN c c...You Better Not Get Here c 200 WRITE (*,9003) lb(1:nlb) CALL EXIT(0) END ./eatit.f000644 000151 000151 00000005750 06505526566 011711 0ustar00xpmm000001 1113545 SUBROUTINE eatit(r1,r2,dz,d1,d2) c c...Ingest ACC And Loop Over DAT c INCLUDE * 'square.inc' INTEGER * dz, i, i1, i2, fr, nr, C_ROOPEN, fd, nlb, err, * C_POSITION, n, nmost, nlast, ir1, ir2, id1, id2, * C_CLOSER, C_READER, m, j DOUBLE PRECISION * r1, r2, d1, d2 CHARACTER*64 * lb BYTE * bb(65) c 9002 FORMAT (5x, 2i12) 9003 FORMAT (' Cannot Open ', a) 9004 FORMAT (' Fatal Error Accessing ', a) 9005 FORMAT (' Too Many Stars - Quitting Early') 9006 FORMAT (' Z=', i4, ' RA(', i9, ':', i9, ') SPD(', i9, ':', * i9, ')') c c...Eat The ACC File c 100 i = (dz/75) + 1 lb = fn(i) nlb = nfn(i) IF (dz.ne.oldzone) THEN lb(nlb-2:nlb) = 'acc' OPEN ( * access='sequential', * carriagecontrol='list', * dispose='keep', * err=200, * form='formatted', * name=lb(1:nlb), * readonly, * shared, * status='old', * unit=1 * ) DO i=1,NACC READ (1,9002) frec(i),nrec(i) ENDDO CLOSE (1) oldzone = dz ENDIF c c...Compute Offset And Length c i1 = r1/3.75D00 i1 = MAX(1,MIN(NACC,i1+1)) i2 = r2/3.75D00 i2 = MAX(1,MIN(NACC,i2+1)) fr = frec(i1)-1 nr = 0 DO i=i1,i2 nr = nr+nrec(i) ENDDO c c...Open And Position File c lb(nlb-2:nlb) = 'cat' DO i=1,nlb bb(i) = ICHAR(lb(i:i)) ENDDO bb(nlb+1) = 0 fd = C_ROOPEN(bb) IF (fd.lt.3) THEN WRITE (*,9003) lb(1:nlb) CALL EXIT(0) ENDIF IF (fr.gt.0) THEN err = C_POSITION(fd,12*fr) IF (err.le.0) THEN WRITE (*,9004) lb(1:nlb) CALL EXIT(0) ENDIF ENDIF c c...Set Up Search Parameters c n = ((nr-1)/NCHUNK) + 1 IF (n.gt.1) THEN nmost = NCHUNK nlast = nr - (n-1)*NCHUNK ELSE nmost = 0 nlast = nr ENDIF ir1 = CONVERT*r1 ir2 = CONVERT*r2 id1 = CONVERT*(d1+90.0D00) id2 = CONVERT*(d2+90.0D00) WRITE (*,9006) oldzone,ir1,ir2,id1,id2 c c...Do The Search c DO i=1,n IF (i.eq.n) THEN m = nlast ELSE m = nmost ENDIF err = C_READER(fd,buf,12*m) IF (err.ne.0) THEN WRITE (*,9004) lb(1:nlb) CALL EXIT(0) ENDIF DO j=1,m IF (buf(1,j).ge.ir1) THEN IF (buf(1,j).le.ir2) THEN IF ((buf(2,j).ge.id1).and.(buf(2,j).le.id2)) THEN nsav = nsav+1 CALL saveit(j) ENDIF ELSE GO TO 110 ENDIF ENDIF ENDDO fr = fr+m ENDDO c c...All Done c 110 err = C_CLOSER(fd) RETURN c c...You Better Not Get Here c 200 WRITE (*,9003) lb(1:nlb) CALL EXIT(0) END ./fitsit.f000644 000151 000151 00000004617 06505525271 012071 0ustar00xpmm000001 1070520 SUBROUTINE fitsit(nx,ny,im,dolog) c c...Simple FITS Writer c INCLUDE * 'square.inc' PARAMETER * nhead = 6 INTEGER * nx, ny, im(nx,ny), nlb, fd, err, C_OPENER, i, j, * C_WRITER, C_RAWWRITER, nzero, dolog REAL * z CHARACTER*80 * lb BYTE * bb(80) c 9001 FORMAT ('SIMPLE = T') 9002 FORMAT ('BITPIX = 32') 9003 FORMAT ('NAXIS = 2') 9004 FORMAT ('NAXIS1 = ', 16x, i4) 9005 FORMAT ('NAXIS2 = ', 16x, i4) 9006 FORMAT ('END ') 9010 FORMAT (' Enter Output FITS File Name: ' $) 9011 FORMAT (q, a) 9012 FORMAT (' Cannot Open ', a) 9013 FORMAT (' Fatal Error Writing FITS File=', i10) c c...Get File Name And Open It Under C c 100 WRITE (*,9010) READ (*,9011,err=100,end=200) nlb,lb IF (nlb.le.0) GO TO 100 DO i=1,nlb bb(i) = ICHAR(lb(i:i)) ENDDO bb(nlb+1) = 0 fd = C_OPENER(bb) IF (fd.le.2) THEN WRITE (*,9012) lb(1:nlb) GO TO 100 ENDIF c c...Scribble The Header c DO i=1,NHEAD IF (i.eq.1) THEN WRITE (lb,9001) ELSEIF (i.eq.2) THEN WRITE (lb,9002) ELSEIF (i.eq.3) THEN WRITE (lb,9003) ELSEIF (i.eq.4) THEN WRITE (lb,9004) nx ELSEIF (i.eq.5) THEN WRITE (lb,9005) ny ELSE WRITE (lb,9006) ENDIF DO j=1,80 bb(j) = ICHAR(lb(j:j)) ENDDO err = C_RAWWRITER(fd,bb,80) IF (err.ne.0) GO TO 210 ENDDO DO i=1,80 bb(i) = 0 ENDDO DO i=NHEAD+1,36 err = C_RAWWRITER(fd,bb,80) IF (err.ne.0) GO TO 210 ENDDO c c...Transform and Scribble The Data c nzero = 0 IF (dolog.ne.0) THEN DO j=1,ny DO i=1,nx IF (im(i,j).le.0) THEN im(i,j) = -1 nzero = nzero+1 ELSE z = im(i,j) im(i,j) = 1000.0*LOG10(z) ENDIF ENDDO ENDDO ENDIF err = C_WRITER(fd,im,4*nx*ny) IF (err.ne.0) GO TO 210 CALL c_closer(fd) write (*,9991) nzero 9991 format (' NZero=', i10) RETURN c c...Various Errors c 200 RETURN 210 WRITE (*,9013) err CALL c_closer(fd) RETURN END ./gimme.f000644 000151 000151 00000002407 06505525271 011663 0ustar00xpmm000001 1110276 SUBROUTINE gimme(v1,v2,v3) c c...Get RA,DEC,Width From Command Line Or User c IMPLICIT * NONE DOUBLE PRECISION * v1, v2, v3 INTEGER * nlb, n, IARGC, i CHARACTER*64 * lb c 9001 FORMAT (' Enter Alpha: '$) 9002 FORMAT (' Enter Delta: '$) 9003 FORMAT (' Enter Width: '$) 9004 FORMAT (q, a) c 100 n = IARGC() IF (n.ne.3) THEN 110 WRITE (*,9001) READ (*,9004,err=110,end=200) nlb,lb IF (nlb.le.0) GO TO 110 CALL hms(lb(1:nlb),v1) 120 WRITE (*,9002) READ (*,9004,err=120,end=200) nlb,lb IF (nlb.le.0) GO TO 120 CALL hms(lb(1:nlb),v2) 130 WRITE (*,9003) READ (*,9004,err=130,end=200) nlb,lb IF (nlb.le.0) GO TO 130 CALL hms(lb(1:nlb),v3) ELSE DO i=1,3 CALL getarg(i,lb) nlb = 0 DO nlb=LEN(lb),2,-1 IF (lb(nlb:nlb).gt.' ') GO TO 140 ENDDO 140 IF (i.eq.1) THEN CALL hms(lb(1:nlb),v1) ELSEIF (i.eq.2) THEN CALL hms(lb(1:nlb),v2) ELSE CALL hms(lb(1:nlb),v3) ENDIF ENDDO ENDIF v3 = 0.5D00*v3 RETURN c c...Error c 200 CALL EXIT(0) END ./hist.f000644 000151 000151 00000001616 06505525272 011531 0ustar00xpmm000001 1110316 PROGRAM histogram c c...Extract A Square From USNO-A c INCLUDE * 'square.inc' DOUBLE PRECISION * r, d, s INTEGER * i, j, nb, nr c 9001 FORMAT (' NB=', i10, ' NR=', i10) 9002 FORMAT (' Bin=', i2, ' NB=', i10, ' NR=', i10) c 100 oldzone = -1 scale = 67.14D00 DO i=1,NHIST bhist(i) = 0 rhist(i) = 0 ENDDO CALL gimme(r,d,s) CALL corner(r,d,s) DO j=1,ndec DO i=1,nra CALL eathist(rfrst(i),rlast(i),dzone(j),dfrst(j),dlast(j)) ENDDO ENDDO CLOSE (2) nb = 0 nr = 0 DO i=1,NHIST nb = nb+bhist(i) nr = nr+rhist(i) ENDDO WRITE (*,9001) nb,nr DO i=1,NHIST IF ((bhist(i).gt.0).or.(rhist(i).gt.0)) THEN WRITE (*,9002) i,bhist(i),rhist(i) ENDIF ENDDO CALL EXIT(0) END ./hms.f000644 000151 000151 00000002625 06505525272 011342 0ustar00xpmm000001 1111100 SUBROUTINE hms(str,val) c c...Crack String And Create Value c IMPLICIT * NONE CHARACTER*(*) * str DOUBLE PRECISION * val, piece(3), dp, sgn, z INTEGER * nstr, i, j, dpfind CHARACTER*1 * c c c...Initialization c 100 val = 0.0D00 DO i=1,3 piece(i) = 0.0D00 ENDDO j = 1 dpfind = 0 sgn = 1.0D00 nstr = LEN(str) IF (nstr.le.0) RETURN c c...Loop Over The String c DO i=1,nstr c = str(i:i) c c...Parse c IF ((c.eq.'-').or.(c.eq.'e').or.(c.eq.'E') * .or.(c.eq.'s').or.(c.eq.'S')) THEN sgn = -1.0D00 ELSEIF ((c.eq.'+').or.(c.eq.'w').or.(c.eq.'W') * .or.(c.eq.'n').or.(c.eq.'N')) THEN sgn = 1.0D00 ELSEIF ((c.eq.':').or.(c.eq.',').or.(c.eq.' ')) THEN j = j+1 dpfind = 0 IF (j.gt.3) GO TO 110 ELSEIF (c.eq.'.') THEN dpfind = 1 dp = 1.0D00 ELSEIF ((c.ge.'0').and.(c.le.'9')) THEN z = ICHAR(c)-ICHAR('0') IF (dpfind.eq.0) THEN piece(j) = 10.0D00*piece(j) + z ELSE dp = 0.1D00*dp piece(j) = piece(j) + dp*z ENDIF ENDIF ENDDO c c...Return c 110 val = piece(1) + piece(2)/60.0D00 + piece(3)/3600.0D00 val = val*sgn RETURN END ./lb.f000644 000151 000151 00000001336 06505525272 011157 0ustar00xpmm000001 1110317 PROGRAM lb c c...Just Convert RA/Dec To l/b c IMPLICIT * NONE INTEGER * nra, ndec, nll, nbb DOUBLE PRECISION * r, d, l, b, radian CHARACTER*32 * ra, dec, ll, bb c 9001 FORMAT (' RA:', $) 9002 FORMAT (' Dec: ' $) 9003 FORMAT (q, a) 9004 FORMAT (' l=', f6.2, ' b=', f6.2, ' degrees') c 100 WRITE (*,9001) READ (*,9003) nra,ra CALL hms(ra(1:nra),r) WRITE (*,9002) READ (*,9003) ndec,dec CALL hms(dec(1:ndec),d) radian = 45.0D00/ATAN(1.0D00) r = (r*15.0D00)/radian d = d/radian CALL sla_EQGAL(r,d,l,b) l = l*radian b = b*radian WRITE (*,9004) l,b CALL EXIT END ./precess.f000644 000151 000151 00000000651 06505525272 012221 0ustar00xpmm000001 1111240 SUBROUTINE precess(r,d) c c...Use SLALIB c IMPLICIT * NONE DOUBLE PRECISION * r2000, d2000, bepoch, r1950, d1950, r, d, radian c 100 radian = 45.0D00/ATAN(1.0D00) r1950 = r*15.0D00/radian d1950 = d/radian bepoch = 1950.0D00 CALL sla_FK45Z(r1950,d1950,bepoch,r2000,d2000) r = r2000*radian/15.0D00 d = d2000*radian RETURN END ./saveit.f000644 000151 000151 00000002227 06505525272 012056 0ustar00xpmm000001 1111650 SUBROUTINE saveit(j) c c...Save Results c INCLUDE * 'square.inc' PARAMETER * billion = 1000*1000*1000, * million = 1000*1000, * thousand = 1000 INTEGER * j, nlb, k, fld, mb, mr CHARACTER*64 * lb c 9001 FORMAT (' Enter Output File: ' $) 9002 FORMAT (q, a) 9003 FORMAT (i5, 3i15) 9004 FORMAT (' NSAV=', i10) c 100 IF (nsav.eq.1) THEN WRITE (*,9001) READ (*,9002,err=100,end=200) nlb,lb IF (nlb.le.0) GO TO 100 OPEN ( * access='sequential', * carriagecontrol='list', * dispose='keep', * err=100, * form='formatted', * name=lb(1:nlb), * status='unknown', * unit=2 * ) ENDIF k = MOD(ABS(buf(3,j)),BILLION) fld = k/MILLION k = k - fld*MILLION mb = k/THOUSAND mr = k - mb*THOUSAND WRITE (2,9003) oldzone,buf(1,j),buf(2,j),buf(3,j) IF (MOD(nsav,1000).eq.0) THEN WRITE (*,9004) nsav ENDIF RETURN c c...User Exit c 200 CALL EXIT(0) END ./square.f000644 000151 000151 00000001050 06505526171 012047 0ustar00xpmm000001 1111241 PROGRAM square c c...Extract A Square From USNO-A c INCLUDE * 'square.inc' DOUBLE PRECISION * r, d, s INTEGER * i, j c 9001 FORMAT (' Found', i10, ' Entries') c 100 CALL whereis oldzone = -1 scale = 67.14D00 CALL gimme(r,d,s) CALL corner(r,d,s) nsav = 0 DO j=1,ndec DO i=1,nra CALL eatit(rfrst(i),rlast(i),dzone(j),dfrst(j),dlast(j)) ENDDO ENDDO CLOSE (2) WRITE (*,9001) nsav CALL EXIT(0) END ./square50.f000644 000151 000151 00000001055 06505525273 012233 0ustar00xpmm000001 1113526 PROGRAM square c c...Extract A Square From USNO-A c INCLUDE * 'square.inc' DOUBLE PRECISION * r, d, s INTEGER * i, j c 9001 FORMAT (' Found', i10, ' Entries') c 100 oldzone = -1 scale = 67.14D00 CALL gimme(r,d,s) CALL precess(r,d) CALL corner(r,d,s) nsav = 0 DO j=1,ndec DO i=1,nra CALL eatit(rfrst(i),rlast(i),dzone(j),dfrst(j),dlast(j)) ENDDO ENDDO CLOSE (2) WRITE (*,9001) nsav CALL EXIT(0) END ./sumit.f000644 000151 000151 00000007430 06505525273 011727 0ustar00xpmm000001 1070530 SUBROUTINE sumit(r1,r2,dz,d1,d2,r0,d0,sc,nx,ny,im) c c...Ingest ACC And Loop Over DAT c INCLUDE * 'square.inc' INTEGER * dz, i, i1, i2, fr, nr, C_ROOPEN, fd, nlb, err, * C_POSITION, n, nmost, nlast, ir1, ir2, id1, id2, * C_CLOSER, C_READER, m, j, nx, ny, im(nx,ny), ix, iy DOUBLE PRECISION * r1, r2, d1, d2, sc, radian, r0, d0, radr0, radd0, * r, d, xi, eta CHARACTER*64 * lb BYTE * bb(65) c 9001 FORMAT ('/uq6/xpmm/a1.0/zone', i4.4, '.acc') 9002 FORMAT (5x, 2i12) 9003 FORMAT (' Cannot Open ', a) 9004 FORMAT (' Fatal Error Accessing ', a) 9005 FORMAT (' Too Many Stars - Quitting Early') 9006 FORMAT (' Z=', i4, ' RA(', i9, ':', i9, ') SPD(', i9, ':', * i9, ')') 9007 FORMAT (' Fatal SLALIB Error', i12) c c...Eat The ACC File c 100 IF (dz.ne.oldzone) THEN WRITE (lb,9001) dz nlb = 27 OPEN ( * access='sequential', * carriagecontrol='list', * dispose='keep', * err=200, * form='formatted', * name=lb(1:nlb), * readonly, * shared, * status='old', * unit=1 * ) DO i=1,NACC READ (1,9002) frec(i),nrec(i) ENDDO CLOSE (1) oldzone = dz ENDIF c c...Compute Offset And Length c i1 = r1/3.75D00 i1 = MAX(1,MIN(NACC,i1+1)) i2 = r2/3.75D00 i2 = MAX(1,MIN(NACC,i2+1)) fr = frec(i1)-1 nr = 0 DO i=i1,i2 nr = nr+nrec(i) ENDDO c c...Open And Position File c lb(nlb-2:nlb) = 'cat' DO i=1,nlb bb(i) = ICHAR(lb(i:i)) ENDDO bb(nlb+1) = 0 fd = C_ROOPEN(bb) IF (fd.lt.3) THEN WRITE (*,9003) lb(1:nlb) CALL EXIT(0) ENDIF IF (fr.gt.0) THEN err = C_POSITION(fd,12*fr) IF (err.le.0) THEN WRITE (*,9004) lb(1:nlb) CALL EXIT(0) ENDIF ENDIF c c...Set Up Search Parameters c n = ((nr-1)/NCHUNK) + 1 IF (n.gt.1) THEN nmost = NCHUNK nlast = nr - (n-1)*NCHUNK ELSE nmost = 0 nlast = nr ENDIF ir1 = CONVERT*r1 ir2 = CONVERT*r2 id1 = CONVERT*(d1+90.0D00) id2 = CONVERT*(d2+90.0D00) WRITE (*,9006) oldzone,ir1,ir2,id1,id2 c c...Set Up The Summation Parameters c radian = 45.0D00/ATAN(1.0D00) scale = (nx/2)/(sc/radian) radr0 = 15.0D00*r0/radian radd0 = d0/radian c c...Do The Search c DO i=1,n IF (i.eq.n) THEN m = nlast ELSE m = nmost ENDIF err = C_READER(fd,buf,12*m) IF (err.ne.0) THEN WRITE (*,9004) lb(1:nlb) CALL EXIT(0) ENDIF DO j=1,m IF (buf(1,j).ge.ir1) THEN IF (buf(1,j).le.ir2) THEN IF ((buf(2,j).ge.id1).and.(buf(2,j).le.id2)) THEN r = buf(1,j)/(CONVERT*radian) d = ((buf(2,j)/CONVERT)-90.0D00)/radian CALL sla_DS2TP(r,d,radr0,radd0,xi,eta,err) IF (err.ne.0) GO TO 210 ix = (nx/2) + xi*scale iy = (ny/2) + eta*scale IF ((ix.ge.1).and.(ix.le.nx) * .and.(iy.ge.1).and.(iy.le.ny)) THEN ix = (nx+1)-ix im(ix,iy) = im(ix,iy)+1 nsav = nsav+1 ENDIF ENDIF ELSE GO TO 110 ENDIF ENDIF ENDDO fr = fr+m ENDDO c c...All Done c 110 err = C_CLOSER(fd) RETURN c c...You Better Not Get Here c 200 WRITE (*,9003) lb(1:nlb) CALL EXIT(0) 210 WRITE (*,9007) err CALL EXIT(0) END ./xycorner.f000644 000151 000151 00000005027 06505525274 012441 0ustar00xpmm000001 1070540 SUBROUTINE xycorner(r,d,s) c c...Get Corners On The Basis Of (Xi,Eta) And Compute Search Parameters c c WARNING - Uses SLALIB c INCLUDE * 'square.inc' DOUBLE PRECISION * r, d, s, rd, r1, r2, d1, d2, cd, zmin, zmax, * radian, radr, radd, rads, r3, r4, d3, d4, pi, * rmin, rmax, dmin, dmax, q INTEGER * i, j, z1, z2 c 9001 FORMAT (' Illegal Input: R=', f10.6, ' D=', f10.6) 9002 FORMAT (' Illegal Size=', f10.6) c c...Sanity Checks c 100 IF ((r.lt.0.0D00).or.(r.ge.24.0D00)) THEN WRITE (*,9001) r,d CALL EXIT(0) ENDIF IF ((d.le.-90.0D00).or.(d.ge.90.0D00)) THEN WRITE (*,9001) r,d CALL EXIT(0) ENDIF IF (s.le.0.0D00) THEN WRITE (*,9002) s CALL EXIT(0) ENDIF c c...Use SLALIB To Get Corners c pi = 4.0D00*ATAN(1.0D00) radian = 180.0D00/pi radr = (r*15.0D00)/radian radd = d/radian rads = s/radian CALL sla_DTP2S(-rads,-rads,radr,radd,r1,d1) CALL sla_DTP2S( rads,-rads,radr,radd,r2,d2) CALL sla_DTP2S(-rads, rads,radr,radd,r3,d3) CALL sla_DTP2S( rads, rads,radr,radd,r4,d4) CALL sla_DTP2S(0.0D00,-rads,radr,radd,q,dmin) CALL sla_DTP2S(0.0D00, rads,radr,radd,q,dmax) c c...Compute RA Chunks c rmin = MIN(r1,r2,r3,r4) rmax = MAX(r1,r2,r3,r4) IF ((rmax-rmin).le.pi) THEN nra = 1 rfrst(1) = rmin*radian rlast(1) = rmax*radian ELSE rmin = 2.0D00*pi rmax = 0.0D00 IF (r1.le.pi) THEN rmax = MAX(rmax,r1) ELSE rmin = MIN(rmin,r1) ENDIF IF (r2.le.pi) THEN rmax = MAX(rmax,r2) ELSE rmin = MIN(rmin,r2) ENDIF IF (r3.le.pi) THEN rmax = MAX(rmax,r3) ELSE rmin = MIN(rmin,r3) ENDIF IF (r4.le.pi) THEN rmax = MAX(rmax,r4) ELSE rmin = MIN(rmin,r4) ENDIF nra = 2 rfrst(1) = 0.0D00 rlast(1) = rmax*radian rfrst(2) = rmin*radian rlast(2) = 360.0D00 ENDIF c c...Compute Dec Corners And Zones c dmin = MIN(d1,d2,dmin)*radian dmax = MAX(d3,d4,dmax)*radian z1 = (dmin+90.0D00)/7.5D00 z2 = (dmax+90.0D00)/7.5D00 ndec = z2+1-z1 j = 0 DO i=z1,z2 zmin = i*7.5D00 - 90.0D00 zmax = zmin+7.5D00 j = j+1 dzone(j) = i*75 dfrst(j) = zmin dlast(j) = zmax ENDDO RETURN END ./cio.c000644 000151 000151 00000005025 06505525276 011341 0ustar00xpmm000001 1117270 #include #include #include #include /* ************************************************************************** * * C_OPENER -- Open A NEW File */ c_opener_(bb) char bb[]; { return(creat(bb,0644)); } /* *************************************************************************** * * C_CLOSER -- Close A File */ c_closer_(fd) int *fd; { return(close(*fd)); } /* *************************************************************************** * * C_WRITER -- Use HTONL() To Select ENDIAN */ c_writer_(fd,buf,n) int *fd, *n; char buf[]; { u_long x; int i, nn; char b; nn = (*n); x = 102030405; if (htonl(x) != x) { for (i=0; i #include #include #include /* ************************************************************************** * * C_OPENER -- Open A NEW File */ c_opener_(bb) char bb[]; { return(creat(bb,0644)); } /* *************************************************************************** * * C_CLOSER -- Close A File */ c_closer_(fd) int *fd; { return(close(*fd)); } /* *************************************************************************** * * C_WRITER -- Use HTONL() To Select ENDIAN */ c_writer_(fd,buf,n) int *fd, *n; char buf[]; { u_long x; int i, nn; char b; nn = (*n); x = 102030405; if (htonl(x) != x) { for (i=0; i