! BUTOUT SUBROUTINE ORBIT C.ORBIT SBP 2008.03.17 !tpl call butout(int(4,120), nnnnn) ! writes butns.nnnnn returning nnnnn ! Input: ! RAW(4,120) -- Integer: Array of raw button values. ! ! Output ! NNNNN -- Integer: Number of butns.nnnnn file created ! now puts butns.nnnnnnn into [cesr.orbit.but.mm] ! where mm=mod(nnnnnnnn/1000,100) !ie 00 to 99 only ! july 2011 change destination to $CESR_ONLINE/machine_data/meas/orbit/xx/ subroutine butout(raw,ver) use str_find_mod implicit none integer*4 :: PROPS(3) integer*4, parameter :: lpmax=2,pd1max=7,pd2max=6,fd1max=2,numdets=120 integer*4 :: jnum,leng, slens(20) character(80) :: strings(20), blank ! integer*4 raw(4,numdets),ver,l,n,i,k integer*4 vnumbr, jj,iw,num_width integer*4 pdmax(lpmax),intlng(lpmax),pdat(lpmax,10) integer*4 savre,seprt(7),cesrb,wxfrb,exfrb integer*4 polar(2),rffmd,timeref,ln integer*4 auxdat(100),naux,bpm_typ(120) character(12) :: auxnam(22) = [ & 'CSR HORZ CUR', 'CSR VERT CUR', 'CSR QUAD CUR', 'CSR QADD CUR', & 'CSR SQEWQUAD', 'CHS BPM EPCS', 'XSA QUAD CUR', 'XSA HORZ CUR', & 'XSA CANT CUR', 'XSA CANT TRM', 'XSA VERT CUR', 'XSA PVERTING', & 'XSA PSKEWING', 'XSA DIPQ CUR', 'XSA PMAG CUR', 'CSR SEXT CUR', & 'CSR OCTU CUR', 'CSR SQEWSEXT', 'LIBERA X DAT', 'LIBERA Y DAT', & 'LIBERA DATA ', 'CSR COMMENTS'] integer*4 micamp(50),setdat(10),attdb(0:3),ampdb(0:3) integer*4 get_next_f,wxbnd,exbnd,polbmp integer*4 pd,fd,ibeab,icur,jd,js,jyear,jday,jfill,subdir logical anyneg, err character(8) verst character(120) filenm ! ! real fdat(1,5),gev integer posuamp(9),eleuamp(9),nsuamp(9) ! character(120) next_butnum, lognam_dat character stamp*20,day*9,hms*8,daytime*18,latnam*40 character pdatlab(lpmax,10)*4,fdatlab(1,5)*4 character savtyp*3,savset*10 integer lun, ix ! data pdmax / pd1max,pd2max / data intlng / 2 , 9 / data (pdatlab(1,pd),pd=1,pd1max) /'ATT=','AMP=','BUN=','GAT=', & ' =','HSP=','INJ='/ data (pdatlab(2,pd),pd=1,pd2max) /'RFM=','DIP=','TIM=','FIL=', & 'VER=','SAV='/ data (fdatlab(1,fd),fd=1,fd1max) /'SN1=','SN2='/ data attdb /20,26,40,46/ data ampdb / 0,12,24,36/ ! ! __________________________begin main_____________________________ ! call fullfilename( & '$CESR_MACH_MEAS/orbit/next_butnum.num', next_butnum) ver=get_next_f(next_butnum) !get and incr number for selected type pdat(2,5)=ver call form_file_name_with_number('ORBIT',ver,filenm, err) !version to filename lun=lunget() !Get first free disk unit number at or above 30 open(unit=lun, status='new',file=filenm) ! ------------------------get-setup-data--------------------------- call csr_tstamp(stamp) !as '01-Jan-2000 01:30:00' hms=stamp(13:20) !convert to oldstyle day=stamp(1:7)//stamp(10:11) daytime=day//' '//hms call nmrget(fdat(1,1),fdat(1,2)) ! sen1 sen2 in gauss. fdat(1,1)=max(-999.,min(fdat(1,1),9999.)) fdat(1,2)=max(-999.,min(fdat(1,2),9999.)) call getlat(latnam) call vxgetn( 'CSRBPM FLAGS' ,1,120,bpm_typ) !get proc type call vxgetn( 'CSR POS MAMP' ,1,9,posuamp) !get currents (just a small part call vxgetn( 'CSR ELE MAMP' ,1,9,eleuamp) !get currents call vxgetn( 'CSR 4NS MAMP' ,1,9,nsuamp) !get currents call vxgetn( 'CSRBPM COMD ' ,1,10,setdat) !get beam commands call vxgetn( 'CSR POLARITY' ,1,2,polar) ibeab=min(9,max(1,setdat(9))) !replaces beabun, above if(polar(1) < 0) ibeab=-ibeab !e- pdat(1,1)=attdb(setdat(5)) ! db of attenuators,20db always in pdat(1,2)=ampdb(setdat(6)) ! db of amplifiers used pdat(1,3)=ibeab ! bunch number and polarity pdat(1,4)=setdat(7) ! processor gate 0>>off 1>>on call vxgetn( 'CSR POLARITY' ,1,2,polar) call vxgetn( 'CRF FREQ CON' ,1,1,rffmd) call vxgetn( 'CSR BEND CUR' ,1,1,cesrb) call vxgetn( 'CSRBPM TIM ' ,9,9,timeref) call vxgetn( 'WXF BEND CUR' ,1,1,wxfrb) call vxgetn( 'EXF BEND CUR' ,1,1,exfrb) pdat(1,7)=polar(2) pdat(2,1)=mod(rffmd,1000) !avoid ***** pdat(2,2)=cesrb gev=5.258*pdat(2,2)/17859. ! scale factor from scorbd.flx pdat(2,3)=timeref/16 ! bnch1>~5000 2>~10000 3>~15000 wxbnd=wxfrb exbnd=exfrb polbmp=polar(2) if(polbmp == 0.and.wxbnd == 0.and.exbnd == 0) then savtyp='lum' ! lum set elseif(polbmp == 1.and.wxbnd > 1000) then savtyp='pos' ! pos set elseif(polbmp == 2.and.exbnd > 1000) then savtyp='el-' ! el set else savtyp='xxx' ! odd set endif call fullfilename('$CESR_ONLINE/machine_data/logging/rec/lognam.dat',lognam_dat) open(unit=17,file=lognam_dat, status='old',action='read') read(17,'(/,3i)') jyear,jday,jfill pdat(2,4)=100*jday+jfill !!! pdat(2,4) > int*2 close(unit=17) call vxgetn( 'CSR SAVRECRD' ,1,1,savre) !read lattice name pdat(2,6)=savre ! cesr save set# write(savset,'(a3,'';'',i6.6)') savtyp,pdat(2,6) ! -----------------------end-get-setup-data------------------------ write(lun,1910) trim(filenm), daytime,savset, trim(latnam) write(lun,1920) 'E T1 ', (float(eleuamp(i))*.001, i=1,9) write(lun,1920) 'P T1 ', (float(posuamp(i))*.001, i=1,9) write(lun,1920) '4 NS ', (float(nsuamp(i))*.001, i=1,9) do l=1,lpmax write(lun,1930) intlng(l),pdmax(l), & (pdatlab(l,pd),pdat(l,pd),pd=1,pdmax(l)) enddo write(lun,1940) fd1max,(fdatlab(1,fd),fdat(1,fd),fd=1,fd1max) 1910 format('c',4x,a,2x,'Date:'a18,2x,a10,2x,'Lat:',a) 1920 format('c',4x,a5,9f8.3) 1930 format('c',2i1,2x,9(a4,i,2x)) 1940 format('cf',i1,2x,9(a4,f8.3,2x)) do n=1,120 iw=3 do i=1,4 iw=max(num_width(raw(i,n),10)+1,iw) enddo write(lun,506) n,(raw(i,n),i=1,4),bpm_typ(n) enddo 506 format(i6,4i,i6) ! ADD STEERING DATA AT END write(LUN,510) size(auxnam) 510 format('C END BUTNS',I5,' KICKS FOLLOW ') do i=1,size(auxnam) n=vnumbr(auxnam(i)) call vmgprop(auxnam(i),props) !get property masks if(props(1) == '2000000'x) then !no cmd or val, but string if(n > 20) print *,' Warning: too many strings to save' n=min(20,n) !limit # read strings = '' ! Temp fix for vstget bug. call vstget(auxnam(i),1,n,strings,slens) !get strings from mpm if (auxnam(i) == 'CSR COMMENTS') then blank = ' ' do jj = 1, n call vstput(auxnam(i), jj, jj, blank) enddo endif if(slens(1) > 80) print *,'Warning: saved string too long' leng=min(80,slens(1)) !assume all strings same length if(leng > 80) print *,' Warning: saved string too long' write(lun,209) auxnam(i),n,leng, (strings(k)(1:leng), k=1,n) 209 format(1x,a12,i6,',',i6,','/(1x,a)) else call vxgetn(auxnam(i),1,n,auxdat) write(lun,203) auxnam(i),n,(auxdat(k),k=1,n) endif 203 format(1x,a12,i6,', -1, 7,'/,('c',11x,10i7)) enddo close(unit=lun) return end subroutine butout