c I(MJS) added the patch for correcting for the template velocity here.
c HL added error from er in quadrature to zero3 in case ians=55 -- Jan 17, 1996
c HL May 28, 1997:
c      changed display for template 6 to be OIII velocity, etc. instead 
c      also hardwired ntemp = 6, er = 1.
c
	program mmultimakc
c	create .coo results file 
	character*20  maskname, cooname
	character*20  inname,ocooname,o3zname
	dimension z(10), zer(10),r(10),v(10)
c
        integer map, mtemp
        parameter (map = 500, mtemp = 6)
        integer n1arr(map), narr(map,mtemp)
        integer ittarr(map,mtemp), itt(mtemp)
        real xarr(map), yarr(map), rmagarr(map)
        real dyarr(map), grcolorarr(map)
        real zarr(map,mtemp), zerarr(map,mtemp)
        real rarr(map,mtemp)
        real zo3arr(map), zero3arr(map)
        real ro3arr(map)
        character*78 carr(map), centry
        logical done, start
c
	 print 10
10	 format(' Name of mask file (dflt = mask): ',$)
	 read(*,'(a20)') maskname
	 if(maskname.eq."") maskname="mask"
         write(*,'(''mask file = '', a20)') maskname
	 open(1,file=maskname,status='old')
	 print 20
20	 format(' Name of results file (dflt = fort.2): ',$)
	 read(*,'(a20)') inname
	 if(inname.eq."") inname="fort.2"
         write(*,'(''results file = '', a20)') inname
	 open(2,file=inname,status='old')
	 print 28
28	 format(' OIII z file (dflt = fort.3): ',$)
	 read(*,'(a20)') o3zname 
cc	if(o3zname.ne."") then
         if (o3zname .eq. "") o3zname = "fort.3"
         write(*,'(''OIII z file = '', a20)') o3zname
	 open(9,file=o3zname,status='old')
cc	endif
	 print 26
26	 format(' Name of output file : ',$)
	 read(*,'(a20)') cooname
	 if(cooname.eq."") cooname="coo.1"
         write(*,'(''output coo file = '', a20)')
     $           cooname
	 open(4,file=cooname,status='new')
         open(44, file='mmultimake_c.out.tmp', 
     $            status='unknown')
c
         do i = 1, map
            carr(i) = '     '
         end do
	 print 27
27	 format(' Old .coo file (optional): ',$)
	 read(*,'(a20)') ocooname
	if(ocooname.ne."") then
         if (ocooname .eq. cooname) then
            write(*,*) 'error: old and new coo names same'
            stop
         end if
	 open(3,file=ocooname,status='old')
         write(*,*)
         write(*,*) 'reading old coo file ', ocooname
         read(3,'(a78)',iostat=ios) centry
         do while (ios .eq. 0)
            read(centry(1:5),'(i5)') i
            carr(i) = centry            
            write(*,'(a78)') centry
            read(3,'(a78)',iostat=ios) centry
         end do
         close(3)
         write(*,*)
	endif
c
	 print 31
31	 format('Number of templates: ',$)
cc	 read(*,'(i2)') ntemp 
         ntemp = 6
	 write(*,*) ntemp
	 print 30
30	 format(' Error in wavelength solution (in A): ',$)
cc	 read(*,'(f4.2)')  er
         er = 1.
	 write(*,*) er
	 er=(er/5000.)
c
	 open(8,file='vcorr',status='old')
	 do 1200 jj=1,ntemp
	 read(8,*) v(jj)
         if (o3zname .ne. "" .and. jj .eq. 6) v(6) = v(5)
	 write(*,*) jj, v(jj)
1200	continue
	close(8)
c	
	 print 40
40	 format(' Starting aperture:  ',$)
	 read(*,'(i3)') istart 
	 write(*,*) istart
c
        nap = 0
        read(1,*,iostat=ios) 
     $       n1,x,y,e1,e2,qq,rmag,iap,dy,grcolor
        do while (ios .eq. 0)
           nap = nap + 1
           if (nap .gt. map) then
              write(*,*) 'error: too many apertures'
              write(*,*) 'nap > map: ', nap, map
              stop
           end if
           n1arr(nap) = n1
           xarr(nap) = x
           yarr(nap) = y
           rmagarr(nap) = rmag
           dyarr(nap) = dy
           grcolorarr(nap) = grcolor

           do itemp = 1, ntemp
              read(2,*) n,xabs,q1,z(itemp),
     $                  zer(itemp),q3,r(itemp),q4,ittt
              narr(nap,itemp) = n
              zarr(nap,itemp) = z(itemp)
              zerarr(nap,itemp) = zer(itemp)
              rarr(nap,itemp) = r(itemp)
              ittarr(nap,itemp) = ittt
           end do

           if(o3zname.ne."") then
             read(9,*) o31,o32,o33,zo3,zero3,o34,r03,o34,io3temp
             zo3arr(nap) = zo3
             zero3arr(nap) = zero3
             ro3arr(nap) = r03
             narr(nap,6) = n
             zarr(nap,6) = zo3
             zerarr(nap,6) = zero3
             rarr(nap,6) = r03
             ittarr(nap,6) = 55
           endif
           
           read(1,*,iostat=ios) 
     $       n1,x,y,e1,e2,qq,rmag,iap,dy,grcolor
        end do
        write(*,*) 'read in ', nap, ' apertures'
        close(1)
        close(2)
        if (o3zname .ne. "") close(9)
c
        i = istart
        done = .false.

        do while (.not. done)
cc	do 1000 i=1,500
	write(*,*)
	write(*,*) '--------------------------------------'
	write(*,*)
cc	read(1,*,end=99) n1,x,y,e1,e2,qq,rmag,iap,dy,grcolor
        n1 = n1arr(i)
        x = xarr(i)
        y = yarr(i)
        rmag = rmagarr(i)
        dy = dyarr(i)
        grcolor = grcolorarr(i)
	write(*,*) n1, x, y, '   rmag= ',rmag,'  Color= ',grcolor

	write(*,*)
c	if(ocooname.ne."") then
c	read(3,*) ion,ox,oy,oz,oe,or,ocl,om 
c	write(*,88) ion, oz, oe, or, ocl 
88	format(3x,'old: ',6x,i3,f10.5,'+-',f6.4,2x,f5.2,f4.0)
c	write(*,*)
c	endif

	if(o3zname.ne."") then
cc	  read(9,*) o31,o32,o33,zo3,zero3,o34,r03,o34,io3temp
          zo3 = zo3arr(i) 
          zero3 = zero3arr(i) 
          r03 = ro3arr(i) 
	  zo3=(1+zo3)*(1+(v(io3temp)/299898.00))-1
	endif

	do 1100 itemp=1,ntemp
cc	read(2,*,end=99) n,xabs,q1,z(itemp),zer(itemp),q3,r(itemp),q4,itt
        n = narr(i,itemp)
        z(itemp) = zarr(i,itemp)
        zer(itemp) = zerarr(i,itemp)
        r(itemp) = rarr(i,itemp)
        itt(itemp) = ittarr(i,itemp)

	z(itemp)=(1+z(itemp))*(1+(v(itemp)/299898.00))-1
	if(r(itemp).eq.0) z(itemp)=0
cc1100	write(*,66)  itt,itemp, n, z(itemp), r(itemp) 
1100	continue
c
1102    open(21, file='mmultimake_c.tmp', status='unknown')
        do itemp = 1, ntemp
           write(*,66) itt(itemp), itemp, n, z(itemp), r(itemp)          
           write(21,*) itt(itemp), itemp, n, z(itemp), r(itemp)
        end do
        close(21)
66	format(1x,i3,' = ',i3,3x,i4,2x,f7.4,3x,f5.2)
cc	if(n1.lt.istart) goto 1000
100	write(*,*)
	write(*,*) 'Choose template number or:' 
	write(*,*) '0=nothing, -1=chip defect, 99=enter by hand' 
	write(*,*) '77=star, 88=check by eye later' 
	write(*,*) '55=change OII to OIII redshift ' 
	write(*,*) '66= keep old value ' 
	write(*,*) '100=force pick peak, 999=done '
	write(*,*) '22=new aperture'
	print 35
35	format(' Input: ',$)
	sw=0.
	read(*,'(i3)',err=100) ians
	write(*,*) ians
c
	if(ians.eq.0) then
	zz=0.
	zerzer=0.
	rr=0.
	class=0.
	sw=1.
	endif
c 
	if(ians.eq.-1) then
	zz=0.
	zerzer=0.
	rr=0.
	class=-1.
	sw=1.
	endif
c 
	if(ians.eq.88) then
	zz=0.
	zerzer=0.
	rr=0.
	class=88.
	sw=1.
	endif
c 
	if(ians.eq.77) then
	zz=0.
	zerzer=0.
	rr=0.
	class=77.
	sw=1.
	endif
c 
	if(ians.eq.55) then
	if(o3zname.eq."") then
	call rbell(1)
	write(*,*) '>>> Error: no OIII z file <<<'
	goto 100
	endif
	if(zo3.eq.0.) then
	call rbell(1)
	write(*,*) '>>> No OIII z listed <<< '
	goto 100
	endif
	zz=zo3
	zerzer=zero3
	zerzer=sqrt(zero3**2+er**2)
	rr=r03
	class=5.
	sw=1.
	endif
c 
c 
	if(ians.eq.66) then
	if(ocooname.eq."") then
	call rbell(1)
	write(*,*) '>>> Error: no old .coo file <<<'
	goto 100
	endif
	zz=oz  
	zerzer=oe
	rr=or
	class=ocl
	sw=1.
	endif
c
	if(ians.le.ntemp.and.ians.gt.0) then
	if(ians.eq.6) then
	call rbell(3)
	write(*,*) '>>>Never choose template 6!<<<'
	goto 100
	endif
	zz=z(ians)
	zerzer=zer(ians)
	zerzer=sqrt(zer(ians)**2+er**2)
	rr=r(ians)
	class=ians
	sw=1.
	end if
c 
	if(ians.eq.99) then
	 print 41
41	 format(' Redshift: ',$)
	 read(*,*) zz 
	 print 42
42	 format(' Redshift error: ',$)
	 read(*,*) zerzer 
	 print 43
43	 format(' R: ',$)
	 read(*,*) rr  
	 print 44
44	 format('Class: ',$)
	 read(*,*) class
	 sw=1.
	 endif
c
        if (ians .eq. 100) then
           itempwant = 0
           do while (itempwant .lt. 1 .or.
     $               itempwant .gt. 5) 
              write(*,*) 'which template: '
              read(*,*) itempwant
              if (itempwant .lt. 1 .or.
     $            itempwant .gt. 5) then
                 write(*,*) 'out of bounds; try again'
              end if
           end do

           write(*,*) 'desired redshift zwant: '
           read(*,*) zwant
           zwantvcorr = (1.+zwant)
     $                / (1.+(v(itempwant)/299898.)) - 1.
           write(*,*) 'corrected for template ', itempwant, 
     $                ' velocity'
           write(*,*) 'zwantvcorr = ', zwantvcorr

           call corel(n, itempwant, zwantvcorr, 
     $                zout, zerout, rout,
     $                zo3out, zero3out, ro3out)
           write(*,*) 'done corel'
           itt(itempwant) = itempwant
           z(itempwant) = zout
           zer(itempwant) = zerout           
           r(itempwant) = rout
           z(itempwant) = (1.+z(itempwant))
     $                  * (1.+(v(itempwant)/299898.00))-1.

           if(o3zname .ne. "" .and. itempwant .eq. 5) then
             zo3 = zo3out
             zero3 = zero3out           
             r03 = ro3out
             zo3=(1+zo3)*(1+(v(io3temp)/299898.00))-1
           end if

           write(*,*)
           write(*,*) '--------------------------------------'
           write(*,*)
           write(*,*) n1, x, y, '   rmag= ',rmag,'  Color= ',grcolor
           write(*,*)
           goto 1102         
        end if
c         (ians .eq. 100)
c
cc	if (sw.ne.1) goto 100  
	if (sw .ne. 1 .and. ians .ne. 999 .and.
     $      ians .ne. 22) goto 100  
c
        if (ians .eq. 999) then
           done = .true.         
        else if (ians .eq. 22) then
           iapwant = 0
           do while (iapwant .lt. 1 .or.
     $               iapwant .gt. nap) 
              write(*,*) 
              write(*,*) 'enter new aperture: '
              read(*,*) iapwant
              if (iapwant .lt. 1 .or.
     $            iapwant .gt. nap) then
                 write(*,*) 'out of bounds; try again'
              end if
           end do
           i = iapwant
        else
c         write(4,77) n1, x, y, zz, zerzer, rr, class, rmag, dy,grcolor
         write(44,77) n1, x, y, zz, zerzer, rr, class, rmag, dy,grcolor
         write(*,77) n1, x, y, zz, zerzer, rr, class, rmag, dy,grcolor
         write(carr(i),77)
     $       n1, x, y, zz, zerzer, rr, class, rmag, dy,grcolor
77      format(1x,i4,2x,f8.2,f10.2,f8.5,f8.5,f8.2,f6.0,2x,f5.2,2x,2f7.3)
           i = i + 1
           if (i .gt. nap) then
              done = .true.
           end if
        end if
c
cc1000	continue
        end do
c         (while .not. done)
c
cc99	close(1)
99	continue
c	close(2)
	close(3)
c	close(4)
c	close(9)
        write(*,*)
        close(44)
c        open(4,file=cooname,status='new')
        write(*,*) 'writing results to ', cooname
        start = .false.
        do i = 1, nap
           if (carr(i)(1:5) .eq. '     ') then
              if (.not. start) then
                 imiss = i
                 start = .true.
                 write(*,'(''missing aperture(s) '', i4, $)') 
     $               imiss
              else if (start .and. i .eq. nap) then
                 write(*,'('' through '', i4)') i
              end if 
           else
              write(4,'(a78)') carr(i)
              if (start) then
                 write(*,'('' through '', i4)') i-1
                 start = .false.
              end if
           end if
        end do
        close(4)
        write(*,*)    
 	stop
	end 
	SUBROUTINE RBELL(IBELL)
        BYTE BELL/7/
        IF (IBELL.LE.0) RETURN
        IF (IBELL.EQ.1) THEN
          WRITE(6,10) BELL
        ELSE
          WRITE(6,11) BELL,BELL
        END IF
10      format(1X,A1)
11      format(1X,A1,A1)
        RETURN
        END
C