CThe data for 1153 galaxies are in ir.cat.  The columns are as in our
C paper:    G.R.Knapp et al. 1989, ApJ Suppl 70, 329.
CThe IR flux densities are in Jy, the 1 sigma noise in mJy.  These
Care *NOT* corrected for the scale differences.  The program calc.for
C(see source deck below) does this, rounds them off, and 
Cperforms various manipulations to the optical magnitudes 
Cthat you may or may not care about.
C   The redshifts are from 
C RC2 (Sec.Ref.Cat., deVaucouleurs)
C RSA= Rev. Shapley-Ames, Sandage & Tammann 1981, Carnegie
C Davies et al. (see Burstein et al. 87, Ap.J.Suppl. 64,601   ('7 Samurai'))
C ZCAT = CfA redshift survey (J.P.Huchra, priv.comm.)
C                                  Have fun.  Jill R. Knapp

c	Program to correct blue magnitudes and IR fluxes for E/S0 Galaxies
c               in paper of J.R.Knapp et al. 1989, ApJSuppl. 70, 329
	common const,twopi,signt,sign0,ra,alpha
	common dec,delta,epoch,xl2,xb2
	character *1 sign,magtype
	character *8 name
	character*9 name1
	character*7 mortyp
	integer r1,r2,r3,d1,d2,d3
	real*4 kcor
	conv = 3.141592653898/180.
	open (8,file='output.dat',status='mod')
	rewind 8
	open(9,file='color.dat',status='mod')
	rewind 9
	open (3,file='table2',status='old')
	rewind 3
	open(4,file='types.dat',status='old')
	rewind 4
10	read (3,15,end=60) name,mortyp,r1,r2,r3,sign,d1,d2,d3,
     1     bt,magtype,iv,s12,n12,s25,n25,s60,n60,s100,n100
15	format (a8,a5,3i2,1x,a1,3i2,f5.1,a1,i5,f6.2,i3,f6.2,i3,
     1          f7.2,i4,f7.2,i4)
	read (4,16,end=60) name1,color
16	format(1x,a9,29x,f4.2)
c
c     calculate galactic coords l,b from subroutine pregal
c
	ras = r3
	decs  = d3
	call pregal (r1,r2,ras,sign,d1,d2,decs,xl1,xb1)
	ra=ra/15./conv
	dec=dec/conv
	xl = xl1 * conv
	xb = xb1 * conv
c     calculate ab if it is zero; correct zwicky magnitudes
  	c = abs(1./sin(xb + 0.00436 - 0.0297*sin(xl) - 0.0175*cos(3*xl)))
	  if (xb .gt. 0.) then
	    sn = 0.1948*cos(xl)   + 0.0725*sin(xl)
     1         + 0.1168*cos(2*xl) - 0.0921*sin(2*xl)
     1         + 0.1147*cos(3*xl) + 0.0784*sin(3*xl)
     1         + 0.0479*cos(4*xl) + 0.0847*sin(4*xl)
	    ab = 0.19*(1. + sn*cos(xb))*c
	    else
	    ss = 0.2090*cos(xl)   - 0.0133*sin(xl)
     1         + 0.1719*cos(2*xl) - 0.0214*sin(2*xl)
     1         - 0.1071*cos(3*xl) - 0.0014*sin(3*xl)
     1         + 0.0681*cos(4*xl) + 0.0519*sin(4*xl)
	    ab = 0.21*(1. + ss*cos(xb))*c
	    end if
  	if (magtype .eq. 'z') then
	call zwicky(ra,dec,bt,btc)
	bt=btc
	end if
	v=iv
	if(iv.eq.0.) v=3500.
	kcor=1.5e-5*v
	if(magtype.eq.'b') go to 30
	bt=bt-kcor
30	bt0=bt-ab
	  bt0 = int(100.*bt0 + 0.5)/100.
	  if(bt.eq.0.) bt0=0.
c   Now correct colors for extinction and redshift
	if(color.eq.0.) go to 40
	color = color-ab/4.1 - 9.5e-6*v
c  
40	continue
c
c  Correct micron flux densities
	xn12=n12
	xn25=n25
	xn60=n60
	xn100=n100
	s12=s12*0.947
	s25=s25*0.935
	s60=s60*1.028
	s100=s100*0.889
	xn12=xn12*0.947
	xn25=xn25*0.935
	xn60=xn60*1.028
	xn100=xn100*0.889
c
c  Put flux densities in mJy
c
	is12=int(1000.*s12 + 0.5)
	is25=int(1000.*s25 + 0.5)
	is60=int(1000.*s60 + 0.5)
	is100=int(1000.*s100 +0.5)
	n12=int(100.*xn12+0.5)/100.
	n25=int(100.*xn25+0.5)/100.
	n60=int(100.*xn60+0.5)/100.
	n100=int(100.*xn100+0.5)/100.
c
	if(color.eq.0.) go to 44
	absm=bt0-25.
	xlb=(5.48-absm)/2.5
	xlb=10.**xlb
	xl100=9.38e5*s100
	rir=xl100/xlb
	xu100=938*n100
	uir=xu100/xlb
	if(s100.gt.0.) uir=0.
c	write(9,11) color,rir,uir,mortyp,name1,name
c1	format(f9.2,1x,2(1pe10.2),1x,a7,a9,a8)
	write(9,11) name1,name,color
11	format(1x,a9,a8,f9.2)
44	continue
	write(8,50) name,mortyp,bt0,iv,is12,n12,
     1  is25,n25,is60,n60,is100,n100
50	format(a8,1x,a5,1x,f5.1,1x,i5,2(i5,i4),
     1  1x,2(i6,i5))
	goto 10
60	continue
	end
	SUBROUTINE PREGAL (irah,iram,ras,sign,idecd,idecm,decs,xlx,xbx)
c Precesses coordinates to any epoch and calculates l2 and b2
c Modified for epoch=1950,day=0 with mean places; no reads or writes - pec
	common const,twopi,signt,sign0,ra,alpha
	common dec,delta,epoch,xl2,xb2
	character*1 sign,sign2
	const=3.1415926535898/180.
	twopi=360./3.1415926535898
	yr = 1950.
	day = 0.
	epoch = 1950.
	ppoch=yr+day/365.25
	ra=(irah+iram/60.+ras/3600.)*15.*const
	isign=1
	if(sign.eq.'-') isign=-1
	dec=isign*(idecd+idecm/60.+decs/3600.)*const
	call preces(1950.)                          
	call galcon
	call preces(ppoch)
	itest = 0
30	asp=alpha/const/15.
	dsp=delta/const
	ih=asp
	m=(asp-ih)*60.
	s=(asp-ih-m/60.)*3600.
	id=dsp
	idm=(dsp-id)*60.
	ds=(dsp-id-idm/60.)*3600.
	id=iabs(id)
	idm=iabs(idm)
	ds=abs(ds)
	sign2='+'   
	if(dsp.lt.0.) sign2='-'   
	xlx=xl2
	xbx=xb2
  	return
	end
c	-------------------------------------------------------------
	subroutine preces(pepoch)
	common const,twopi,signt,sign0,ra,alpha
	common dec,delta,epoch,xl2,xb2
	t0=(epoch-1900.)/100.
	t=(pepoch-epoch)/100.
	zeta=(2304.25+1.396*t0)*t+0.302*t**2+0.018*t**3
	z=zeta+0.791*t**2
	theta=(2004.682-0.853*t0)*t-0.426*t**2-0.042*t**3
	zeta=const*zeta/3600.
	z=const*z/3600.
	theta=const*theta/3600.
	tth=tan(theta/2.0)
	q=sin(theta)*(tan(dec)+tth*cos(ra+zeta))
	q1=q*sin(ra+zeta)/(1.0-q*cos(ra+zeta))
	dra=atan(q1)
	q2=tth*(cos(ra+zeta)-sin(ra+zeta)*tan(0.5*dra))
	ddec=2.*atan(q2)
	alpha=ra+zeta+z+dra
	delta=dec+ddec
	if(alpha.gt.twopi) alpha=alpha-twopi
	if(alpha.lt.0.0) alpha=alpha+twopi
	return
	end
c	-----------------------------------------------------------------
	subroutine galcon
	common const,twopi,signt,sign0,ra,alpha
	common dec,delta,epoch,xl2,xb2
	alpol=282.25*const
	delpol=62.6*const
	q1=cos(delta)*cos(alpha-alpol)
	q2=cos(delta)*sin(alpha-alpol)*cos(delpol)+sin(delta)*sin(delpol)
	q3=-cos(delta)*sin(alpha-alpol)*sin(delpol)+sin(delta)*cos(delpol)
	xl2=(atan2(q2,q1))/const + 33.
	xb2=(asin(q3))/const
	if(xl2.gt.360.) xl2=xl2-360.
	if(xl2.lt.0.) xl2=xl2+360.
	return
 	end
c--------------------------------------------------------------------------
	subroutine zwicky(ra,dec,bt,btc)
	btc=bt
	if(dec.lt.-3.or.dec.gt.15.) go to 200
	if(ra.lt.7.1.or.ra.gt.18.27) goto 200
	if(bt.lt.10.) then
	btc=bt+0.67
	go to 500
	end if
	if(bt.ge.10.and.bt.le.12.9) then
	btc=bt-0.46
	go to 500
	end if
	if(bt.ge.13.and.bt.le.13.9) then
	btc=bt-0.52
	go to 500
	end if
	if(bt.ge.14.and.bt.le.14.9) then
	btc=bt-0.17
	go to 500
	end if
	if(bt.ge.15.and.bt.le.15.5) then
	btc=bt+0.19
	go to 500
	end if
	if(bt.ge.15.6.and.bt.le.15.7) then
	btc=bt+0.48
	go to 500
	end if
200	if(bt.lt.10.) then
	btc=bt+0.02
	go to 500
	end if
	if(bt.ge.10.and.bt.le.11.9) then
	btc=bt-0.06
	go to 500
	end if
	if(bt.ge.12.and.bt.le.12.9) then
	btc=bt-0.09
	go to 500
	end if
	if(bt.ge.13.and.bt.le.13.9) then
	btc=bt-0.19
	go to 500
	end if
	if(bt.ge.14.and.bt.le.14.9) then
	btc=bt-0.17
	go to 500
	end if
	if(bt.ge.15.and.bt.le.15.5) then
	btc=bt-0.03
	go to 500
	end if
	if(bt.ge.15.6.and.bt.le.15.7) then
	btc=bt-0.04
	go to 500
	end if
500	return
