c ====================================================================== Subroutine EVTHELP Write(*,*)' Following Commands is available. ' Write(*,*)' ' Write(*,*)' LIST : Print List of Histograms in //PAWC. ' Write(*,*)' ' Write(*,*)' INIT : Initialize IniEncFlag without exit.' Write(*,*)' If you change parameters for ENCs, ' Write(*,*)' execute this command.' Write(*,*)' ' Write(*,*)' START : Start Event Loop. ' Write(*,*)' ' Write(*,*)' ' Write(*,*)' QUIT : Exit Event Loop with closing RDF. ' Write(*,*)' ' Write(*,*)' UPDATE: Enable/Disable UPDATE.' Write(*,*)' ' Write(*,*)' EVTLOOP> UPDATE' Write(*,*)' UPDATE> ON : Update Histograms' Write(*,*)' UPDATE> OFF : No-update' Write(*,*)' ' Write(*,*)' SCAT : Change the status for Scatter PLOT of 2D.' Write(*,*)' ' Write(*,*)' EVTLOOP> SCAT' Write(*,*)' SCAT> ON : Enable to plot' Write(*,*)' SCAT> OFF : Disable to plot' Write(*,*)' SCAT> CLEAR : Clear plot window' Write(*,*)' SCAT> SCALE : Define Down Scale' Write(*,*)' SCAT> RND : Plot with random' Write(*,*)' number' Write(*,*)' > ON or OFF ' Write(*,*)' SCAT> COLOR : Enable Color plot.' Write(*,*)' SCAT> NCOLOR : Disable Color plot.' Write(*,*)' SCAT> FACTOR : Define a factor of' Write(*,*)' color level.' Write(*,*)' ' Write(*,*)' To Interrupt Event Loop, hit RETURN-KEY.' Write(*,*)' ' Return End c ====================================================================== Subroutine ANASTORE(FANANAME) Include 'common.f' Character*132 fananame Integer ICYCLE ICYCLE = 0 Call HROPEN(10,'ANAPAW',FANANAME,'N',1024,ISTAT) Call HCDIR('//PAWC',' ') Call HCDIR('//ANAPAW',' ') Call HROUT(0,ICYCLE,'N') Call HREND('ANAPAW') Call HCDIR('//PAWC',' ') Return End c ====================================================================== Subroutine ANAFETCH(FANANAME,IDOFFSET) Include 'common.f' Character*132 fananame Integer IDOFFSET,ICYCLE ICYCLE = 0 Call HIDALL(AIDALL,AMAXHST) If(BOOKFLAG .and. (IDOFFSET.EQ.0)) Then I = 2000 Do While (I.LT.AIDALL(AMAXHST)) I = I + 1000 EndDo IDOFFSET = I EndIf Call HROPEN(10,'ANAPAW',FANANAME,' ',1024,ISTAT) Call HCDIR('//PAWC',' ') Call HCDIR('//ANAPAW',' ') Call HRIN(0,ICYCLE,IDOFFSET) Call HREND('ANAPAW') Call HCDIR('//PAWC',' ') Return End c ====================================================================== Subroutine HST1 Include 'common.f' Integer iniX,iniY Character*4 OPTLGY OPTLGY='LOGY' Call GETHPLOPT(OPTLGY) Call HIDALL(AIDALL,AMAXHST) Call KUGETI(NX) Call KUGETI(NY) K = 0 ADUMID = 101 ANUMH1ID = 0 AHST1ID = 0 iniX = 1 iniY = 1 Do I = 1 , HSTDEFMAX AH1ID(I) = 0 EndDo 4 Call KUPROI(' HST1>',AHST1ID) If(AHST1ID .GT. 0)Then Call HKIND(AHST1ID,AHISTKIND,' ') If(AHISTKIND.EQ.2)Then Write(*,*) AHST1ID ,' : This is 2D-Histogram.' Goto 4 EndIf AH1ID(1) = AHST1ID ANUMH1ID = ANUMH1ID + 1 c Write(*,*)1,AHST1ID ADUMID = AHST1ID Do I = 2, NX*NY Call KUPROI(' HST1>',AHST1ID) If(AHST1ID .EQ. -1)GOTO 2 If(AHST1ID .EQ. 0)THEN ADUMID = ADUMID+1 iniY = int((I+NX-1)/NX) iniX = I - NX*(iniY-1) c write(*,*)I - 1,iniX,iniY k = I - 1 GOTO 5 EndIf Call HKIND(AHST1ID,AHISTKIND,' ') If(AHISTKIND.EQ.2)Then Write(*,*) AHST1ID ,' : This is 2D-Histogram.' Goto 3 EndIf AH1ID(I) = AHST1ID ANUMH1ID = ANUMH1ID + 1 3 Continue EndDo ElseIf(AHST1ID .EQ. 0)Then 5 Do I = iniY, NY Do J = iniX, NX K = K + 1 1 Continue If(HEXIST(ADUMID))Then Call HKIND(ADUMID,AHISTKIND,' ') If(AHISTKIND.EQ.2)Then C Write(*,*) ADUMID ,' : This is 2D-Histogram.' ADUMID = ADUMID + 1 Goto 1 EndIf AH1ID(K) = ADUMID ANUMH1ID = ANUMH1ID + 1 ADUMID = ADUMID + 1 Else ADUMID = ADUMID + 1 If(ADUMID.GT.AIDALL(AMAXHST))GOTO 2 Goto 1 EndIf EndDo iniX = 1 EndDo EndIf 2 Continue Call LIST1D(-1) HST1FLAG = .TRUE. AIFIRST = 1 Call HPLZON(NX,NY,1,' ') If(OPTLGY.EQ.'LINY')Then Do K = 1,ANUMH1ID Call ISELNT(k*10) Call HPLOT(AH1ID(K),' ',' ',0) Call WRTHID(AH1ID(K)) EndDo EndIf Return End c ====================================================================== Subroutine HST2 Include 'common.f' Integer iniX,iniY Call HIDALL(AIDALL,AMAXHST) Call KUGETI(N2X) Call KUGETI(N2Y) K = 0 ADUMID = 101 ANUMH2ID = 0 AHST2ID = 0 iniX = 1 iniY = 1 Do I = 1 , HSTDEFMAX AH2ID(I) = 0 EndDo 4 Call KUPROI(' HST2>',AHST2ID) If(AHST2ID .GT. 0)Then Call HKIND(AHST2ID,AHISTKIND,' ') If(AHISTKIND.EQ.1)Then Write(*,*) AHST2ID ,' : This is 1D-Histogram.' Goto 4 EndIf AH2ID(1) = AHST2ID ANUMH2ID = ANUMH2ID + 1 ADUMID = AHST2ID Do I = 2, N2X*N2Y Call KUPROI(' HST2>',AHST2ID) If(AHST2ID .EQ. -1)GOTO 2 If(AHST2ID .EQ. 0)Then ADUMID = ADUMID + 1 iniY = int((I+N2X-1)/N2X) iniX = I - N2X*(iniY-1) k = I - 1 Goto 5 EndIf Call HKIND(AHST2ID,AHISTKIND,' ') If(AHISTKIND.EQ.1)Then Write(*,*) AHST2ID ,' : This is 1D-Histogram.' Goto 3 EndIf AH2ID(I) = AHST2ID ANUMH2ID = ANUMH2ID + 1 3 Continue EndDo ElseIf(AHST2ID .EQ. 0)Then 5 Do I = iniY, N2Y Do J = iniX, N2X K = K + 1 1 Continue If(HEXIST(ADUMID))Then Call HKIND(ADUMID,AHISTKIND,' ') If(AHISTKIND.EQ.1)Then C Write(*,*) ADUMID ,' : This is 1D-Histogram.' ADUMID = ADUMID + 1 Goto 1 EndIf AH2ID(K) = ADUMID ANUMH2ID = ANUMH2ID + 1 ADUMID = ADUMID + 1 Else ADUMID = ADUMID + 1 If(ADUMID.GT.AIDALL(AMAXHST))GOTO 2 Goto 1 EndIf EndDo iniX = 1 EndDo EndIf 2 Continue If(SCATFL)Then Call IACWK(4) Call IDAWK(1) Call ICLRWK(4,0) Call IACWK(1) Call IDAWK(4) EndIf Call LIST2D(-1) HST2FLAG = .TRUE. Return End c ================================================================= Subroutine LISTPROF(hid) Include 'common.f' Write(*,*)' ' Write(*,*)'Profile-Histograms:' Write(*,*)' ' Do j = 1, i3-1 c Do j = 1, j3 If(HPID(J).EQ.HID .OR. HID.EQ.0)Then Write(*,888)' ( HID : ',HPID(J),' ) ( TITLE : ', & TITLE_PF(J),' ) ( GATE : ',cpid(j),' )' Write(*,889)' ( bin : ',pxbin(j), & ' ) ( xmin : ',pxmin(j), & ' ) ( xmax : ',pxmax(j),' )' Write(*,891)' ( VAL_X : ',seg_idpx(j),vidpx_1(j), & vidpx_2(j),val_idpx(j),' ) ( VAL_Y : ', & seg_idpy(j),vidpy_1(j), & vidpy_2(j),val_idpy(j),' )' Write(*,*)' ' EndIf EndDo 888 Format(3X,A9,I4,A13,A20,A12,I5,A2) 889 Format(A13,I4,A12,F8.2,A12,F8.2,A2) 891 Format(A15,I3,I4,I4,I4,A14,I3,I4,I4,I4,A3) Return End c ================================================================= Subroutine LIST1D(hid) Include 'common.f' Write(*,*)' ' Write(*,*)'1D-Histograms:' Write(*,*)' ' If(HID.EQ.-1)Then Do k = 1, ANUMH1ID Do j = 1, i1-1 c Do j = 1, j1 If( AH1ID(K).EQ.H1ID(J) )Then Write(*,888)' ( HID : ',AH1ID(K),' ) ( TITLE : ', & TITLE_1D(J),' ) ( GATE : ',c1id(j),' )' Write(*,889)' ( bin : ',bin(j),' ) ( xmin : ',minh(j), & ' ) ( xmax : ',maxh(j),' )' Write(*,789)' ( VALUE : ',seg_id(j), & vid1(j),vid2(j),val_id(j), & ' )' Write(*,*)' ' EndIf EndDo EndDo Else Do j = 1, i1-1 c Do j = 1, j1 If(H1ID(j).EQ.HID .OR. HID.EQ.0)Then Write(*,888)' ( HID : ',H1ID(J),' ) ( TITLE : ', & TITLE_1D(J),' ) ( GATE : ',c1id(j),' )' Write(*,889)' ( bin : ',bin(j),' ) ( xmin : ',minh(j), & ' ) ( xmax : ',maxh(j),' )' Write(*,789)' ( VALUE : ',seg_id(j), & vid1(j),vid2(j),val_id(j), & ' )' Write(*,*)' ' EndIf Enddo EndIf 888 Format(3X,A9,I4,A13,A20,A12,I5,A2) 889 Format(A12,I4,A12,F8.2,A12,F8.2,A2) 789 Format(A14,I3,I4,I4,I3,A2) Return End c ================================================================= Subroutine LIST2D(hid) Include 'common.f' Write(*,*)' ' Write(*,*)'2D-Histograms:' Write(*,*)' ' K = 0 If(HID.EQ.-1)Then Do nny = 1, n2y Do nnx = 1, n2x k = k + 1 If(k.le.anumh2id)Then Do j = 1, i2-1 c Do j = 1, j2 If((ah2id(k).eq.h2id(j)) .AND. & (HID.EQ.-1 .OR. AH2ID(K).EQ.HID) )Then Write(*,888)' ( HID : ',AH2ID(K), & ' ) ( TITLE : ', & TITLE_2D(J),' ) ( GATE : ',c2id(j),' )' Write(*,889)' ( xbin : ',xbin(j), & ' ) ( xmin : ',xmin(j), & ' ) ( xmax : ',xmax(j),' )' Write(*,890)' ( ybin : ',ybin(j), & ' ) ( ymin : ',ymin(j), & ' ) ( ymax : ',ymax(j),' )' Write(*,891)' ( VAL_X : ',seg_idx(j),vidx_1(j), & vidx_2(j),val_idx(j),' ) ( VAL_Y : ', & seg_idy(j),vidy_1(j), & vidy_2(j),val_idy(j),' )' Write(*,*)' ' EndIf EndDo EndIf EndDo EndDo Else Do j = 1, i2-1 c Do j = 1, j2 If(H2ID(J).EQ.HID .OR. HID.EQ.0)Then Write(*,888)' ( HID : ',H2ID(J),' ) ( TITLE : ', & TITLE_2D(J),' ) ( GATE : ',c2id(j),' )' Write(*,889)' ( xbin : ',xbin(j), & ' ) ( xmin : ',xmin(j), & ' ) ( xmax : ',xmax(j),' )' Write(*,890)' ( ybin : ',ybin(j), & ' ) ( ymin : ',ymin(j), & ' ) ( ymax : ',ymax(j),' )' Write(*,891)' ( VAL_X : ',seg_idx(j),vidx_1(j), & vidx_2(j),val_idx(j),' ) ( VAL_Y : ', & seg_idy(j),vidy_1(j), & vidy_2(j),val_idy(j),' )' Write(*,*)' ' EndIf EndDo EndIf 888 Format(3X,A9,I4,A13,A20,A12,I5,A2) 889 Format(A13,I4,A12,F8.2,A12,F8.2,A2) 890 Format(A13,I4,A12,F8.2,A12,F8.2,A2) 891 Format(A15,I3,I4,I4,I4,A14,I3,I4,I4,I4,A3) Return End c ================================================================= Subroutine LISTGATE(GKIND,GetID) Include 'common.f' Character*256 GKIND Character*6 GIDMESS(0:4)/'ALL','GATE','AND','OR','XYGATE'/ Integer mg,ma,mo,m2d,iflag,GetID iflag = 0 If(GKIND.EQ.' ')Then GID=0 ElseIf(GKIND.EQ.'G')Then GID=1 ElseIf(GKIND.EQ.'A')Then GID=2 ElseIf(GKIND.EQ.'O')Then GID=3 ElseIf(GKIND.EQ.'X')Then GID=4 Else Write(*,*)' ' Write(*,*)' ANAPAW-E : No such option exists.' Write(*,*)' ' Return EndIf Write(*,*)' ' Write(*,*)'Kind : ',GIDMESS(GID) Write(*,*)' ' mg = 1 ma = 1 mo = 1 m2d = 1 Do k = 1, gseq-1 If(gtkind(k).eq.1)Then If(GKIND.EQ.'G' .OR. GKIND.EQ.' ')Then If( (GetID.EQ.GATEID(mg)) .OR. (GetID.EQ.0) )Then Write(*,788)' ( GID : ',GATEID(mg), & ' ) ( KIND : Gate ) ' Write(*,789)' ( VALUE : ',seg_gateid(mg), & vgateid1(mg),vgateid2(mg),val_gateid(mg), & ') ( Limit : ', & gatemin(mg),gatemax(mg),' )' Write(*,790)' ( TOTAL ENTRIES : ',tegate(mg), & ' ) ( ACCEPTED ENTRIES : ',accgate(mg),' )' Write(*,*)' ' EndIf EndIf mg = mg + 1 ElseIf(gtkind(k).eq.2)Then If(GKIND.EQ.'A' .OR. GKIND.EQ.' ')Then If( (GetID.EQ.GAndID(ma)) .OR. (GetID.EQ.0) )Then Write(*,888)' ( GID : ',GAndID(ma), & ' ) ( KIND : And ) ( ACCEPTED EVENTS : ', & accand(ma),' )' Do i=1,int(gsubandid(ma)/8),1 Write(*,889)' ( ELEMENTS : ', & (gandele(ma,j),j=(i*8-7)+1,(i*8)+1) EndDo Write(*,889)' ( ELEMENTS : ', & (gandele(ma,j),j=(i*8-7)+1,gsubandid(ma)) Write(*,*)' ' EndIf EndIf ma = ma + 1 ElseIf(gtkind(k).eq.3)Then If(GKIND.EQ.'O' .OR. GKIND.EQ.' ')Then If( (GetID.EQ.GorID(mo)) .OR. (GetID.EQ.0) )Then Write(*,988)' ( GID : ',GorID(mo), & ' ) ( KIND : Or ) ( ACCEPTED EVENTS : ', & accor(mo),' )' Do i=1,int(gsuborid(mo)/8),1 Write(*,989)' ( ELEMENTS : ', & (gorele(mo,j),j=(i*8-7)+1,(i*8)+1) EndDo Write(*,989)' ( ELEMENTS : ', & (gorele(mo,j),j=(i*8-7)+1,gsuborid(mo)) Write(*,*)' ' EndIf EndIf mo = mo + 1 ElseIf(gtkind(k).eq.4)Then If(iflag.eq.0)Then Do i = 1,gitd-1 If(GKIND.EQ.'X' .OR. GKIND.EQ.' ')Then If( (GetID.EQ.TDgateID(i)) .OR. (GetID.EQ.0) )Then Write(*,1008)' ( GID : ',tdgateid(i), & ' ) ( KIND : XYGate ) ' Write(*,1009)' ( VAL_X : ',tdsegidx(i), & tdvidx1(i), & tdvidx2(i),tdvalx(i),' ) ( VAL_Y : ', & tdsegidy(i),tdvidy1(i), & tdvidy2(i),tdvaly(i),' )' Write(*,1010)' ( Number of Points : ', & tdnop(i),' )' Write(*,1011)' ( TOTAL ENTRIES : ',tdgate(i), & ' ) ( ACCEPTED ENTRIES : ', & acctdgate(i),' )' Write(*,*)' ' EndIf EndIf EndDo iflag = 1 EndIf EndIf EndDo 788 Format(3X,A10,I4,A20) 789 Format(A15,I3,I4,I4,I4,A14,F8.2,F8.2,A2) 790 Format(A23,I10,A24,I10,A2) 888 Format(3X,A10,I4,A40,I10,A2) 889 Format(A18,8(1I5,',')) 988 Format(3X,A10,I4,A40,I10,A2) 989 Format(A18,8(1I5,',')) 1008 Format(3X,A10,I4,A22) 1009 Format(A15,I3,I4,I4,I4,A14,I3,I4,I4,I4,A3) 1010 Format(A26,I5,A3) 1011 Format(A23,I10,A24,I10,A2) Write(*,*)' ' Return End c ================================================================= Subroutine ERASE Include 'common.f' Integer iflag Call HRESET(0,' ') iflag = 0 mg = 1 ma = 1 mo = 1 Do k = 1, gseq-1 If(gtkind(k).eq.1)Then tegate(mg) = 0 accgate(mg) = 0 mg = mg + 1 ElseIf(gtkind(k).eq.2)Then accand(ma) = 0 ma = ma + 1 ElseIf(gtkind(k).eq.3)Then accor(mo) = 0 mo = mo + 1 ElseIf(gtkind(k).eq.4)Then If(iflag.eq.0) Then Do i = 1,gitd-1 tdgate(i) = 0 acctdgate(i) = 0 EndDo iflag = 1 EndIf EndIf EndDo BLKC = 0 EVTSCA = 0 TrigNum = 0 Return End c ================================================================= Subroutine HISTCUT(HID,COPT) Include 'common.f' Real xvX1,xvY1,array_x(2),array_y(2),array0x(2),array0y(2) Real HXY Integer ISTAT/1/,NT,dum0,dlen,CWKID,KNT Parameter (dum0=0) Real hcutx(20),hcuty(20) Integer nop,hckind,hcj,hcutlun,dumkind Integer FGSEG,FGKIND,FGM Character*70 HComment,HComment2 Character CUTNAME*40,COPT*4 Real rtempx,rtempy Character CHCUTGID*5,CHTMPX*10,CHTMPY*10,GIDTEXT*80 nop = 1 HComment = 'No-Commnet' If(COPT.EQ.'S')Then c If(N2X*N2Y.NE.1)Then c Write(*,*)' ' c Write(*,*)' ANAPAW-E : Valid for Zone = (1,1).' c Write(*,*)' ' c Return c EndIf Write(*,*)' ' Write(*,*)' ANAPAW-M : Scatter Mode.' Call IACWK(4) Call IDAWK(1) CWKID = 4 If(HID.EQ.0)Then Call KUPROI('HID>',HID) CURRHID = HID Else CURRHID = HID EndIf Do k = 1, ANUMH2ID If(HID.EQ.AH2ID(k))Then KNT = k EndIf EndDo ElseIf(COPT.NE.'S')Then CWKID = 1 CURRHID = DispID(DSeqID) If(HID.EQ.0)Then HID = CURRHID Else CURRHID = HID EndIf If(COPT.EQ.'M') COPT=' ' Else Write(*,*)' ' Write(*,*)' ANAPAW-E : Wrong option.' Write(*,*)' ' Return EndIf 100 Call HKIND(CURRHID,DUMKIND,' ') If(DUMKIND.EQ.-1 .OR. DUMKIND.EQ.0)Then Write(*,*)' ' Write(*,*)' ANAPAW-E : Unknown histogram.' Write(*,*)' ' Return ElseIf(DUMKIND.EQ.1)Then Write(*,*)' ' Write(*,*)' ANAPAW-E : ',CURRHID,' is 1D-Histogram.' Write(*,*)' ' Call KUPROI(' ID for 2D Histogram>',CURRHID) Goto 100 EndIf Call ISELNT(1) c Call KUGETF(HCUTNAME,L) If(COPT.NE.'S')Then Call HPLOT(CURRHID,COPT,' ',0) Call WRTHID(CURRHID) EndIf 112 HCUTLUN = 23 Write(*,*)' ' Write(*,'(A24,A132)')' ANAPAW-M : FileName = ',HCUTNAME Call KUINQF(HCUTNAME,HCUTLUN) If(HCUTLUN.NE.-1)Then Write(*,*)' ANAPAW-W : File already exist.' Write(*,*)' ' 113 Call KUINPS(' Append/OverWrite/NewFile/Quit =a>', & ANAKEY,L) If(ANAKEY.EQ.'o' .OR. ANAKEY.EQ.'O')Then Call KUOPEN(HCUTLUN,HCUTNAME,'UNKNOWN',ISTAT) Write(HCUTLUN,'(A)')'# ANAPAW Cut File V1.0' ElseIf(ANAKEY.EQ.'a' .OR. ANAKEY.EQ.'A' .OR. & ANAKEY.EQ.' ')Then Call KUOPEN(HCUTLUN,HCUTNAME,'APPEND',ISTAT) ElseIf(ANAKEY.EQ.'n' .OR. ANAKEY.EQ.'N')Then 114 Call KUINPS('New FileName >',HCUTNAME,L) If(HCUTNAME.EQ.' ')goto 114 Goto 112 ElseIf(ANAKEY.EQ.'q' .OR. ANAKEY.EQ.'Q')Then Write(*,*)' ' Write(*,*)' ANAPAW-M : Exit HCUT Mode.' Write(*,*)' ' goto 998 Else Goto 113 EndIf ElseIf(HCUTLUN.EQ.-1)Then Call TGETLEN(HCUTNAME,dlen) tdfile(itd) = HCUTNAME tdflen(itd) = dlen itd = itd + 1 jtd = jtd + 1 gtkind(gseq) = 4 gseq = gseq + 1 HCUTLUN = 23 Call KUOPEN(HCUTLUN,HCUTNAME,'APPEND',ISTAT) Write(HCUTLUN,'(A)')'# ANAPAW Cut File V1.0' EndIf 222 Continue Call fcler(array_x,2) Call fcler(array_y,2) Call fcler(array0x,2) Call fcler(array0y,2) Call fcler(hcutx,20) Call fcler(hcuty,20) HCUTGID = HCUTGID + 1 Write(*,*)' ' 333 Call KUPROI(' Input ID of 2D-Gate? ',HCUTGID) Call FINDGATE(HCUTGID,FGSEG,FGKIND,FGM) If(FGKIND.EQ.4)Then Write(*,*)' ' Write(*,*)' ANAPAW-W : ID is already used.' Write(*,*)' ' HCUTGID = HCUTGID + 1 Goto 333 EndIf If(HCUTGID.LT.1001 .OR. HCUTGID.GT.3000)Then Write(*,*)' 1001 <= ID of 2D-Gate <= 3000 ' Goto 333 EndIf Call KUINPS(' Any Comment? >',HComment,L) Call KUALFA If(COPT.EQ.'S')Then Call UPAWLOC(nop,hcutx(1),hcuty(1),100*KNT,CWKID,'-*') Else cIf(COPT.EQ.'M')Then Call UPAWLOC(nop,hcutx(1),hcuty(1),-1,CWKID,'-*') EndIf If(nop.lt.3)Then Write(*,*)' ' Write(*,*)' ANAPAW-E : Need atleast 3 points for a 2D plot' Write(*,*)' ' Return EndIf Write(*,*)' ' Write(*,*)' ANAPAW-M : Number of Points = ',nop Write(*,*)' ' rtempy = hcuty(1) rtempx = hcutx(1) Do i = 2, nop If(hcuty(i).gt.rtempy)Then rtempx = hcutx(i) rtempy = hcuty(i) EndIf EndDo Write(CHCUTGID,*)HCUTGID Write(CHTMPX,*)rtempx Write(CHTMPY,*)rtempy If(COPT.EQ.'S')Then GIDTEXT = 'TEXT '//CHTMPX//' '//CHTMPY//' '//CHCUTGID//' 0.02' Call KUEXEC(GIDTEXT) Else GIDTEXT = 'TEXT '//CHTMPX//' '//CHTMPY//' '//CHCUTGID//' 0.3' Call KUEXEC(GIDTEXT) EndIf Call FINDHID(CURRHID,HCKIND,HCJ) If(HComment.EQ.'No-Comment')Then HComment2 = ' ' Else HComment2 = HComment EndIf If(HCJ.NE.0)Then Write(HCUTLUN,*)'# ',HComment2 Write(HCUTLUN,*)HCUTGID Write(HCUTLUN,*)'X: ',seg_idx(HCJ),vidx_1(HCJ), & vidx_2(HCJ),val_idx(HCJ) Write(HCUTLUN,*)'Y: ',seg_idy(HCJ),vidy_1(HCJ), & vidy_2(HCJ),val_idy(HCJ) Write(HCUTLUN,*)'#: ',NOP Do i = 1,NOP Write(HCUTLUN,'(2F10.3)')HCUTX(I),HCUTY(I) EndDo ElseIf(HCJ.EQ.0)Then Write(HCUTLUN,*)'# ',HComment2 Write(HCUTLUN,*)HCUTGID Write(HCUTLUN,*)'X: ',dum0,dum0,dum0,dum0 Write(HCUTLUN,*)'Y: ',dum0,dum0,dum0,dum0 Write(HCUTLUN,*)'#: ',NOP Do i = 1,NOP Write(HCUTLUN,'(2F10.3)')HCUTX(I),HCUTY(I) EndDo EndIf c --- For READCUT --- CUTNAME = 'fort.cut' Call KUOPEN(24,CUTNAME,'UNKNOWN',ISTAT) Write(24,'(A)')'# ANAPAW Cut File V1.0' If(HCJ.NE.0)Then Write(24,*)'# ',HComment Write(24,*)HCUTGID Write(24,*)'X: ',seg_idx(HCJ),vidx_1(HCJ), & vidx_2(HCJ),val_idx(HCJ) Write(24,*)'Y: ',seg_idy(HCJ),vidy_1(HCJ), & vidy_2(HCJ),val_idy(HCJ) Write(24,*)'#: ',NOP Do i = 1,NOP Write(24,'(2F10.3)')HCUTX(I),HCUTY(I) EndDo ElseIf(HCJ.EQ.0)Then Write(24,*)'# ',HComment Write(24,*)HCUTGID Write(24,*)'X: ',dum0,dum0,dum0,dum0 Write(24,*)'Y: ',dum0,dum0,dum0,dum0 Write(24,*)'#: ',NOP Do i = 1,NOP Write(24,'(2F10.3)')HCUTX(I),HCUTY(I) EndDo EndIf If(COPT.EQ.'S')Then Call IDAWK(4) Call IACWK(1) EndIf Call KUCLOS(24,' ',ISTAT) c tdfile(itd) = CUTNAME c Call READCUT(CUTNAME) c itd = itd + 1 gtkind(gseq) = 4 gseq = gseq + 1 ckind(cseq) = 4 cseq = cseq + 1 c Call KUCLOS(HCUTLUN,' ',ISTAT) 998 Return End c ================================================================= Subroutine READCUT(CUTNAME) Include 'common.f' Character CDum1*22,CDum2*2,CDum3*3,CDum*70,cutname*40 Real hcutx(20),hcuty(20) Integer nop,hckind,hcj,hcutlun,xyid c Write(*,*)cutname c Call KUINQF(CUTNAME,HCUTLUN) c If(HCUTLUN.NE.-1)Return HCUTLUN = 23 Call KUOPEN(HCUTLUN,CUTNAME,'OLD',ISTAT) Read(HCUTLUN,'(A22)',err=2,end=3)CDum1 c Write(*,*)CDum1 If(CDum1.NE.'# ANAPAW Cut File V1.0')Then Write(*,*)' ' Write(*,*)' ANAPAW-E : Not CUT-FILE.' Write(*,*)' ' Goto 2 EndIf Do While(.TRUE.) Read(HCUTLUN,'(A)',err=2,end=3)HcutComment(gitd) Read(HCUTLUN,*,err=2,end=3)tdgateid(gitd) Read(HCUTLUN,*,err=2,end=3)CDum3, & tdsegidx(gitd),tdvidx1(gitd), & tdvidx2(gitd),tdvalx(gitd) Read(HCUTLUN,*,err=2,end=3)CDum3, & tdsegidy(gitd),tdvidy1(gitd), & tdvidy2(gitd),tdvaly(gitd) Read(HCUTLUN,*,err=2,end=3)CDum3,tdnop(gitd) Do k = 1,tdnop(gitd) Read(HCUTLUN,'(2F10.3)',err=2,end=3)tdx(k,gitd), & tdy(k,gitd) EndDo Write(XYLine(gitd),*)tdgateid(gitd),',', & tdsegidx(gitd),',',tdvidx1(gitd),',', & tdvidx2(gitd),',',tdvalx(gitd),',', & tdsegidy(gitd),',',tdvidy1(gitd),',', & tdvidy2(gitd),',',tdvaly(gitd),'\n' c Write(*,*)HcutComment(gitd) c Write(*,*)tdgateid(gitd) c Write(*,*)itd,gitd c Write(*,*)'X: ', c & tdsegidx(gitd),tdvidx1(gitd), c & tdvidx2(gitd),tdvalx(gitd) c Write(*,*)'Y: ', c & tdsegidy(gitd),tdvidy1(gitd), c & tdvidy2(gitd),tdvaly(gitd) c Write(*,*)'#: ',tdnop(gitd) c Do k = 1,tdnop(gitd) c Write(*,'(2F10.3)')tdx(k,gitd),tdy(k,gitd) c EndDo HCUTGID = tdgateid(gitd) gitd = gitd + 1 EndDo 2 Continue c write(*,*)'Err' 3 Continue c write(*,*)'End' Call KUCLOS(HCUTLUN,' ',ISTAT) If(BOOKFLAG) Call AVIEW(1) Return End c ================================================================= Subroutine CLEARALL Include 'common.f' Call AINIT If( .NOT.ONLINEFLAG .and. FILEFLAG.EQ.1 )Then Call CLOSE_RAWDAT RDFNAME = ' ' LASTRDFNAME = ' ' EndIf ANAFNAME = ' ' Call ERASE Call HDELET(0) INITFLAG = .TRUE. Call AVIEW(1) Return End c ================================================================= Subroutine EVTLOOP Include 'common.f' Logical IOFLAG Integer MaxCon Real HSTLIM(4) Character*4 OPTLGX,OPTLGY COMSTATUS = 2 OPTLGY = 'LOGY' Call GETHPLOPT(OPTLGY) 101 Continue Do While(.TRUE.) If( (KUQKEY().eq.1 .or. LPFIRST) .and. & (.NOT.BATCHFL) )Then If(SCATFL)CALL IDAWK(4) If(HST1FLAG)Then Call HPLZON(NX,NY,1,' ') Do K = 1,ANUMH1ID If(OPTLGY.EQ.'LINY')Then Call ISELNT(k*10) Call HPLOT(AH1ID(K),' ',' ',0) Call WRTHID(AH1ID(K)) Call GetDispID(AH1ID(K)) EndIf EndDo EndIf AIFIRST = 1 If(SCATFL)CALL IACWK(4) If(.NOT.LPFIRST)Then Write(*,*)' ANAPAW-M : Interrupt Event Loop!' Write(*,*)' ' Write(*,*)' Blocks : ',blkc Write(*,*)' Total trigger : ',trignum Write(*,*)' Valid Events : ',evtsca Write(*,'(A18,F7.2)')' Valid/Total(%): ', & float(evtsca)/float(trignum)*100. Write(*,*)' ' If(EfficiencyFlag)Then Call LISTEFF(0) EndIf EndIf 103 Call CLrdln(CHPRMPT,CKEY,L) If (L.EQ.0) L = 1 If (CKEY .EQ. 'QUIT' .OR. CKEY .EQ. 'quit' .OR. & CKEY(1:1).EQ.'Q' .OR. CKEY(1:1).EQ.'q' .OR. & CKEY(1:2).EQ.'EX' .OR. CKEY(1:2).EQ.'ex' )Then If(SCATFL)CALL IDAWK(4) Goto 105 ElseIf (CKEY .eq. 'START' .OR. CKEY .EQ. 'start' & .OR. CKEY .eq. 's' .OR. CKEY .eq. 'S')Then Write(*,*)' ' Call KUEXEC('shell date') Write(*,*)' ' Write(*,*)' ANAPAW-M : Hit to stop.' Write(*,*)' ' If(LPFIRST)Then UPDATEFL = .TRUE. AIFIRST = 1 EndIf If(BATCHFL)UPDATEFL = .FALSE. If(SCATFL)CALL MKSCATTER OPTLGX = 'LOGX' OPTLGY = 'LOGY' Call GETHPLOPT(OPTLGX) Call GETHPLOPT(OPTLGY) Call HPLOPT(OPTLGX,1) Call HPLOPT(OPTLGY,1) Goto 104 ElseIf (CKEY .eq. 'LIST' .OR. CKEY .EQ. 'list')Then Call KUEXEC('hist/list S') Write(*,*)' ' Goto 103 ElseIf (CKEY .eq. 'INIT' .OR. CKEY .EQ. 'init')Then Do i = 1,50 INITENCFLAG(i) = .TRUE. EndDo Goto 103 ElseIf (CKEY .eq. 'HELP' .OR. CKEY .EQ. 'help')Then Call EVTHELP Goto 103 ElseIf (CKEY .eq. 'UPDATE' .OR. CKEY .EQ. 'update')Then Call KUINPS(' UPDATE>',UPDATESW,L) If(UPDATESW .EQ. 'ON' .OR. UPDATESW .EQ. 'on')Then UPDATEFL = .TRUE. ElseIf(UPDATESW .EQ. 'OFF' .OR. UPDATESW .EQ. 'off')Then UPDATEFL = .FALSE. EndIf Goto 103 ElseIf (CKEY .eq. 'SCAT' .OR. CKEY .EQ. 'scat')Then Call KUINPS(' SCAT>',SCATSW,L) If(SCATSW .EQ. 'ON' .OR. SCATSW .EQ. 'on')Then Call IGWKTY(WKTYP) Call IOPWK(4,4,WKTYP) Call IACWK(4) Call IDAWK(1) SCATFL = .TRUE. Call MKSCATTER Call IACWK(1) Call IDAWK(4) If(HST2FLAG .and. SCATFL)Then Do j = 1,ANUMH2ID ScatNum(j) = 0 EndDo EndIf ElseIf(SCATSW .EQ. 'OFF' .OR. SCATSW .EQ. 'off')Then Call IGWKTY(WKTYP) Call IDAWK(4) Call ICLWK(4,4,WKTYP) SCATFL = .FALSE. ElseIf(SCATSW .EQ. 'CLEAR' .OR. SCATSW .EQ. 'clear')Then Call ICLRWK(4,0) If(HST2FLAG .and. SCATFL)Then Do j = 1,ANUMH2ID ScatNum(j) = 0 EndDo EndIf ElseIf(SCATSW .EQ. 'SCALE' .OR. SCATSW .EQ. 'scale')Then 109 Call KUPROI(' SCAT/DownScale>',ScatDS) If(ScatDS .LE. 0 .or. ScatDS .GE.100000)Goto 109 If(HST2FLAG .and. SCATFL)Then Do j = 1,ANUMH2ID ScatNum(j) = 0 EndDo EndIf ElseIf(SCATSW .EQ. 'RND' .OR. SCATSW .EQ. 'rnd')Then 110 Call KUINPS(' SCAT/Random>',CKEY,L) If(CKEY.EQ.'ON' .or. CKEY.EQ.'on')Then RNDFLAG = .TRUE. If(SCATFL)Call ICLRWK(4,0) ElseIf(CKEY.EQ.'OFF' .or. CKEY.EQ.'off')Then RNDFLAG = .FALSE. Else Goto 110 EndIf ElseIf(SCATSW .EQ. 'COLOR' .OR. & SCATSW .EQ. 'color' .OR. & SCATSW .EQ. 'COL' .OR. & SCATSW .EQ. 'col')Then COLFLAG = .TRUE. ElseIf(SCATSW .EQ. 'NCOLOR' .OR. & SCATSW .EQ. 'ncolor' .OR. & SCATSW .EQ. 'NCOL' .OR. & SCATSW .EQ. 'ncol')Then COLFLAG = .FALSE. ElseIf(SCATSW .EQ. 'FACTOR' .OR. & SCATSW .EQ. 'factor' .OR. & SCATSW .EQ. 'FAC' .OR. & SCATSW .EQ. 'fac') Then 111 Call KUPROR(' SCAT/Factor>',SCEF) If(SCEF .LE. 0 .or. ScatDS .GE.100)Goto 111 EndIf Goto 103 Else If(SCATFL)CALL IDAWK(4) If(CKEY(1:L).NE.' ')Write(*,*)' > ',CKEY(1:L) Call KUEXEC(CKEY) If(SCATFL)CALL IACWK(4) AIFIRST = 1 c If(L.EQ.0)L=1 c If(CKEY(1:L).NE.' ')Write(*,*)' ' Goto 103 EndIf 104 Continue LPFIRST = .FALSE. EndIf c --- Clear ,Get and Calculate Event --- c trignum = trignum + 1 Call Clear_Data Call EventRead If(.NOT.ERFlag)Then EVTWNUM = EVTMAX Goto 200 EndIf c Call CalcData c Call ANAFILL If(EVTERR)Goto 200 EvtSca = EvtSca + 1 LOOP = LOOP + 1 c Call ANAFILL c -- RDMP -- If( ( DMPFIOFLAG ) .and. ( GateFlag(DMPGID) ) )Goto 201 If(STOPFLAG)Goto 202 201 Continue If( ( DMPFIOFLAG ) .and. ( GateFlag(DMPGID) ) )Then Call Add_Event(EvtData,rnum) EndIf 202 Continue c -- NTUPLE -- If( ( NtupleFlag ) .and. ( GateFlag(NtupleGID) ) )Goto 203 If(STOPFLAG)Goto 204 203 Continue If( ( NtupleFlag ) .and. ( GateFlag(NtupleGID) ) )Then If(NTPLsca .EQ. 200000)Then IOFLAG = .True. NTPLsca = 0 Else IOFLAG = .False. NTPLsca = NTPLsca + 1 EndIf Do i = 1, iana AnalyzerFlag(analyzerid(iana)) = .TRUE. EndDo Call Add_Ntuple(IOFLAG) Do i = 1, iana AnalyzerFlag(analyzerid(iana)) = .FALSE. EndDo Call HFNT(10) EndIf 204 Continue c -- USERSUB -- If(STOPFLAG)Goto 200 Call USERSUB(GateFlag) c -- STOP -- 200 Continue c File Status If(FILEEND)Then Write(*,*)' ' Write(*,*)' ANAPAW-M : End Of File.' Write(*,*)' ' Goto 105 EndIf c --------------------------------------- If(.NOT.BATCHFL)Then Call NARITIMER(RefTime,NariFlag) If(NariFlag.eq.1)Then If(SCATFL)CALL IDAWK(4) If(AIFIRST.EQ.1)Then If(HST1FLAG)Then Call HPLZON(NX,NY,1,' ') Do K = 1,ANUMH1ID Call ISELNT(k*10) If(OPTLGY.EQ.'LOGY')Then HSTLIMLOG(K) = 10.*HMAX(AH1ID(K)) Call HMAXIM(AH1ID(K),HSTLIMLOG(K)) EndIf Call HPLOT(AH1ID(K),'K',' ',0) Call WRTHID(AH1ID(K)) Call GetDispID(AH1ID(K)) EndDo EndIf AIFIRST = 0 Else If(HST1FLAG)Then Call HPLZON(NX,NY,1,' ') If(SCATFL)Call IDAWK(4) If(UPDATEFL)Then If(OPTLGY.EQ.'LOGY')Then Do K = 1,ANUMH1ID MaxCon = HMAX(AH1ID(K)) c Write(*,*)'1 ',k,MaxCon,HSTLIMLOG(K) Call ISELNT(k*10) If(MaxCon .GT. 0.8*HSTLIMLOG(K))Then Call HPLZON(NX,NY,1,' ') Do J = 1,ANUMH1ID Call ISELNT(j*10) MaxCon = HMAX(AH1ID(j)) HSTLIMLOG(J) = 10.*MaxCon Call HMAXIM(AH1ID(j),HSTLIMLOG(J)) Call HPLOT(AH1ID(j),'K',' ',0) Call WRTHID(AH1ID(j)) Call GetDispID(AH1ID(j)) c Write(*,*)'2 ',j,MaxCon,HSTLIMLOG(J) EndDo Goto 303 EndIF Call HPLOT(AH1ID(K),'U',' ',0) EndDo ElseIf(OPTLGY.EQ.'LINY')Then Do K = 1,ANUMH1ID Call ISELNT(k*10) MaxCon = HMAX(AH1ID(K)) Call IGQWK(1,'NTWN',HSTLIM) If(MaxCon .GT. 0.9*HSTLIM(4))Then Call HPLZON(NX,NY,1,' ') Do J = 1,ANUMH1ID Call ISELNT(j*10) Call HPLOT(AH1ID(j),'K',' ',0) Call WRTHID(AH1ID(j)) Call GetDispID(AH1ID(j)) EndDo Goto 303 EndIF Call HPLOT(AH1ID(K),'U',' ',0) Call GetDispID(AH1ID(K)) EndDo EndIf 303 Continue EndIf EndIf EndIf If(SCATFL)CALL IACWK(4) EndIf EndIf If(NUM.NE.0)Then If(LOOP.EQ.NUM)Then Write(*,*)' ' Write(*,*)' ANAPAW-M : End Event Loop by user limit.' Write(*,*)' ' Goto 105 EndIf EndIf INITFLAG = .FALSE. EndDo 105 Write(*,*)' ' Write(*,*)' ANAPAW-M : End Event Loop.' Write(*,*)' ' Write(*,*)' Blocks : ',blkc Write(*,*)' Total trigger : ',trignum Write(*,*)' Valid Events : ',evtsca Write(*,'(A18,F7.2)')' Valid/Total(%): ', & float(evtsca)/float(trignum)*100. Write(*,*)' ' If(EfficiencyFlag)Then Call LISTEFF(0) EndIf COMSTATUS = 1 Call KUEXEC('shell date') If(.NOT. INITFLAG)Then If(.NOT.ONLINEFLAG)Then Call CLOSE_RAWDAT LASTRDFNAME = RDFNAME RDFNAME = 'ONLINE' EndIf If(SCATFL)CALL IDAWK(4) If(.NOT.BATCHFL)Then If(HST1FLAG)Then Call HPLZON(NX,NY,1,' ') Do K = 1,ANUMH1ID Call ISELNT(k*10) Call HPLOT(AH1ID(K),' ',' ',0) Call WRTHID(AH1ID(K)) Call GetDispID(AH1ID(K)) EndDo EndIf EndIf EndIf Return End c ===================================================================== SUBROUTINE CLEAR_DATA Include 'common.f' c clear values do i = 1,EVTWNUM EvtData(i) = 0 enddo do i = 1,50 naok(i) = 0 enddo seg_id(0)=0 seg_idx(0)=0 seg_idy(0)=0 seg_idpx(0)=0 seg_idpy(0)=0 seg_gateid(0)=0 Return End c ===================================================================== Subroutine ANAADD include 'common.f' Call KUGETF(ANAADDNAME,L) 112 ANALUN = 22 Write(*,'(A)')'FileName : ',ANAADDNAME Call KUINQF(ANAADDNAME,ANALUN) If(ANALUN.NE.-1)Then Write(*,*)' ' Write(*,*)' ANAPAW-W : File already exist.' Write(*,*)' ' 113 Call KUINPS('OverWrite/Append/NewFile/Quit ', & ANAKEY,L) If(ANAKEY.EQ.'o' .OR. ANAKEY.EQ.'O')Then Call KUOPEN(ANALUN,ANAADDNAME,'UNKNOWN',ISTAT) ElseIf(ANAKEY.EQ.'a' .OR. ANAKEY.EQ.'A')Then Call KUOPEN(ANALUN,ANAADDNAME,'APPEND',ISTAT) ElseIf(ANAKEY.EQ.'n' .OR. ANAKEY.EQ.'N')Then 114 Call KUINPS('New FileName >',ANAADDNAME,L) If(ANAADDNAME.EQ.' ')goto 114 Goto 112 ElseIf(ANAKEY.EQ.'q' .OR. ANAKEY.EQ.'Q')Then Write(*,*)' ' Write(*,*)' ANAPAW-M : Exit ANAADD Mode.' Write(*,*)' ' goto 998 Else Goto 113 EndIf ElseIf(ANALUN.EQ.-1)Then ANALUN = 22 Call KUOPEN(ANALUN,ANAADDNAME,'APPEND',ISTAT) EndIf Write(*,*)' ' Write(*,*)' Type ''AQ'' to quit ANAADD Mode.' Write(*,*)' ' If(ANASTOP)Then Write(*,*)' ' Write(*,*)' ANAPAW-W : STOP exists in ANA-CODE. All of ' Write(*,*)' definitions created in ANAADD Mode' Write(*,*)' have STOP-GATE.' Write(*,*)' ' EndIf 111 Call CLrdln('Analys Com >',ANAKEY,L) If(ANAKEY.EQ.'DEL' .OR. ANAKEY.EQ.'del')Then Backspace(unit=ANALUN) Goto 111 EndIf If(ANAKEY.EQ.'AQ' .OR. ANAKEY.EQ.'aq')Then Call KUCLOS(ANALUN,' ',ISTAT) Call ANAINIT(ANAADDNAME) Goto 998 EndIf If(ANAKEY.NE.' ') Write(ANALUN,'(A)')ANAKEY(1:L) Goto 111 998 Continue Return End c ====================================================================== Subroutine FINDHID(FHID,FKIND,FJ) Include 'common.f' Integer FHID,FKIND,FJ Call HKIND(FHID,FKIND,' ') If(FKIND.EQ.1)Then Do j = 1, i1-1 c Do j = 1, j1 If(H1ID(j).EQ.FHID)Then FJ = J EndIf Enddo ElseIf(FKIND.EQ.2)Then Do j = 1, i2-1 c Do j = 1, j2 If(H2ID(j).EQ.FHID)Then FJ = J EndIf Enddo Else FKIND = 0 FJ = 0 EndIf If(.NOT.BOOKFLAG)FJ = 0 Return End c ====================================================================== Subroutine FINDGATE(FGID,FGSEG,FGKIND,FGM) Include 'common.f' Integer FGID,FGSEG,FGKIND,FGM Integer mg,ma,mo,m2d mg = 1 ma = 1 mo = 1 m2d = 1 FGKIND = -1 c write(*,*)'FGID',FGID Do k = 1, gseq-1 If(gtkind(k).eq.1)Then If(GATEID(mg).EQ.FGID)Then FGSEG = K FGKIND = 1 ! GATE FGM = mg Return EndIf mg = mg + 1 ElseIf(gtkind(k).eq.2)Then If(GAndID(ma).EQ.FGID)Then FGSEG = K FGKIND = 2 ! AND FGM = ma Return EndIf ma = ma + 1 ElseIf(gtkind(k).eq.3)Then If(GorID(mo).EQ.FGID)Then FGSEG = K FGKIND = 3 ! OR FGM = mo Return EndIf mo = mo + 1 ElseIf(gtkind(k).eq.4)Then Do i = 1,gitd-1 If(TDgateID(i).EQ.FGID)Then FGSEG = K FGKIND = 4 ! 2D FGM = i Return EndIf EndDo Else FGKIND = -1 EndIf EndDo Return End c ====================================================================== Subroutine CHANGE_GATE(GID) Include 'common.f' Integer FGSEG,FGKIND,FGM,ALen,subtemp,ierr Character Linein*400,CDum*4,GKIND*256 Linein = 'No Change' 700 Continue If(GID.EQ.0)Then Write(*,*)' ' Write(*,*)' ANAPAW-W : Input Gate ID' Write(*,*)' To exit, GID = -1' Write(*,*)' ' Call KUPROI(' GID>',GID) If(GID .EQ. -1)Goto 704 Goto 700 EndIf Call FINDGATE(GID,FGSEG,FGKIND,FGM) c Write(*,*)GID,FGSEG,FGKIND,FGM If(FGKIND.EQ.1)Then GKIND = 'G' Call LISTGATE(GKIND,GID) Call KUPROI(' Analyzer >',seg_gateid(FGM)) Call KUPROI(' ID 1 >',vgateid1(FGM)) Call KUPROI(' ID 2 >',vgateid2(FGM)) Call KUPROI(' Word >',val_gateid(FGM)) Call KUPROR(' Min >',gatemin(FGM)) Call KUPROR(' Max >',gatemax(FGM)) Write(*,*)' ' Write(GateLine(FGM),*)GID,',',seg_gateid(FGM),',', & vgateid1(FGM),',',vgateid2(FGM),',',val_gateid(FGM),',', & gatemin(FGM),',',gatemax(FGM),'\n' ElseIf(FGKIND.EQ.2)Then GKIND = 'A' Call LISTGATE(GKIND,GID) Call KUPROS(' Elements >',Linein,Alen) Write(*,*)' ' If(Linein.EQ.'No Change')Goto 702 Call lineread(Linein,tempread,subtemp,ierr) If(ierr.eq.1)Goto 701 gsubandid(FGM) = subtemp+1 Do i = 1,gsubandid(FGM) gandele(FGM,i+1) = tempread(i) EndDo 702 Write(AndLine(FGM),*)GID, & (',',gandele(FGM,i),i=2,gsubandid(FGM)),'\n' Write(AndChara(FGM),*)GID, & (',',gandele(FGM,i),i=2,gsubandid(FGM)),'\n' ElseIf(FGKIND.EQ.3)Then GKIND = 'O' Call LISTGATE(GKIND,GID) Call KUPROS(' Elements >',Linein,Alen) Write(*,*)' ' If(Linein.EQ.'No Change')Goto 703 Call lineread(Linein,tempread,subtemp,ierr) If(ierr.eq.1)Goto 701 gsuborid(FGM) = subtemp+1 Do i = 1,gsuborid(FGM) gorele(FGM,i+1) = tempread(i) EndDo 703 Write(OrLine(FGM),*)GID, & (',',gorele(FGM,i),i=2,gsuborid(FGM)),'\n' Write(OrChara(FGM),*)GID, & (',',gorele(FGM,i),i=2,gsuborid(FGM)),'\n' ElseIf(FGKIND.EQ.-1)Then Write(*,*)' ' Write(*,*)' ANAPAW-E : Wrong GateID.' Write(*,*)' ' Return 701 Continue Write(*,*)' ' Write(*,*)' ANAPAW-E : Wrong Statement.' Write(*,*)' ' Return EndIf 704 Call AVIEW(1) Write(*,*)' ' Return End c ====================================================================== Subroutine CHANGE_HIST(HID,CKEY) Include 'common.f' Integer FKIND,FJ,ALen Character CTEMP*80 Integer GMINX,GMAXX,GMINY,GMAXY,GBINX,GBINY Real RMINX,RMAXX,RMINY,RMAXY Real GLX1,GLX2,GLY1,GLY2 Real Dumbinx1,Dumbinx2,Dumbiny1,Dumbiny2 Integer dumgate,Dumbinx,Dumbiny Logical LOLOGX,LOLOGY Character*4 OPTLGX,OPTLGY Dumbinx1 = 0. Dumbiny1 = 0. Dumbinx2 = 0. Dumbiny2 = 0. Dumgate = 0 Dumbinx = 0 Dumbiny = 0 LOLOGX = .FALSE. LOLOGY = .FALSE. 1200 Continue If(CKEY.NE.' ')Then If(HID.EQ.0)Then CURRHID = DispID(DSeqID) HID = CURRHID Else CURRHID = HID EndIf EndIf OPTLGX = 'LOGX' OPTLGY = 'LOGY' Call GETHPLOPT(OPTLGX) Call GETHPLOPT(OPTLGY) If(OPTLGX .EQ. 'LOGX')Then LOLOGX = .TRUE. Else LOLOGX = .FALSE. EndIf If(OPTLGY .EQ. 'LOGY')Then LOLOGY = .TRUE. Else LOLOGY = .FALSE. EndIf Call FINDHID(HID,FKIND,FJ) If(FJ.EQ.0)Then Write(*,*)' ' Write(*,*)' ANAPAW-W : Input Histogram ID' Write(*,*)' To exit, HID = -1' Write(*,*)' ' Call KUPROI(' HID>',HID) If(HID.EQ.-1)Goto 1202 Goto 1200 EndIf If(FKIND.EQ.1)Then If(CKEY.EQ.' ')Then Call LIST1D(HID) Call KUPROI(' GateID >',c1id(FJ)) Call KUPROI(' Analyzer >',seg_id(FJ)) Call KUPROI(' ID 1 >',vid1(FJ)) Call KUPROI(' ID 2 >',vid2(FJ)) Call KUPROI(' Word >',val_id(FJ)) Call KUPROI(' Bin >',bin(FJ)) Call KUPROR(' Min >',minh(FJ)) Call KUPROR(' Max >',maxh(FJ)) Call KUPROS(' Title >',title_1d(FJ),tlen1d(FJ)) Write(*,*)' ' Write(H1DLine(FJ),*)HID,',',c1id(FJ),',', & seg_id(FJ),',',vid1(FJ),',', & vid2(FJ),',',val_id(FJ),',',bin(FJ),',', & minh(FJ),',',maxh(FJ),',','''', & title_1d(FJ)(1:tlen1d(FJ)),'''', & '\n' Dumbinx1 = (maxh(FJ)-minh(FJ))/bin(FJ) Dumgate = c1id(FJ) Dumbinx = bin(FJ) Dumbinx2 = (maxh(FJ)-minh(FJ))/bin(FJ) c If( (Dumbinx1 .NE. Dumbinx2) .OR. c & ( (Dumbinx1 .EQ. Dumbinx2) .and. c & (Dumbinx .LT. bin(FJ) ) ) .OR. c & (Dumgate .NE. c1id(FJ)) )Then Call HDELET(HID) Call HBOOK1(HID,title_1d(FJ),bin(FJ), & minh(FJ),maxh(FJ),0.) Call HPLOT(HID,' ',' ',0) Call WRTHID(HID) c Else c Call HXI(HID,minh(FJ),GMINX) c Call HXI(HID,maxh(FJ),GMAXX) c Call HCOPYR(HID,99999,title_1d(FJ)(1:tlen1d(FJ)), c & GMINX,GMAXX,0,0,' ') c Call HDELET(HID) c Call HCOPY(99999,HID,title_1d(FJ)(1:tlen1d(FJ))) c Call HDELET(99999) c Call HPLOT(HID,' ',' ',0) c Call WRTHID(HID) c EndIf ElseIf(CKEY.EQ.'X')Then Call HPLOT(HID,' ',' ',0) Call WRTHID(HID) Call IRQLC(1,20,ISTAT,NT,GLX1,GLY1) IF (LOLOGX.AND.GLX1.GT.0.) GLX1=10.**(GLX1) IF (LOLOGY.AND.GLY1.GT.0.) GLY1=10.**(GLY1) Call IRQLC(1,20,ISTAT,NT,GLX2,GLY2) IF (LOLOGX.AND.GLX2.GT.0.) GLX2=10.**(GLX2) IF (LOLOGY.AND.GLY2.GT.0.) GLY2=10.**(GLY2) If(GLX1.LT.GLX2)Then RMINX = GLX1 RMAXX = GLX2 Else RMINX = GLX2 RMAXX = GLX1 EndIf Call HXI(HID,RMINX,GMINX) Call HXI(HID,RMAXX,GMAXX) Call HCOPYR(HID,99999,title_1d(FJ)(1:tlen1d(FJ)), & GMINX,GMAXX,0,0,' ') Call HDELET(HID) Call HCOPY(99999,HID,title_1d(FJ)(1:tlen1d(FJ))) Call HGIVE(HID,CTEMP,GBINX,DUMX1,DUMX2, & GBINY,DUMY1,DUMY2,NWT,LOC) minh(FJ) = DUMX1 maxh(FJ) = DUMX2 bin(FJ) = GBINX Call HPLOT(HID,' ',' ',0) Call WRTHID(HID) Call HDELET(99999) Write(H1DLine(FJ),*)HID,',',c1id(FJ),',', & seg_id(FJ),',',vid1(FJ),',', & vid2(FJ),',',val_id(FJ),',',bin(FJ),',', & minh(FJ),',',maxh(FJ),',','''', & title_1d(FJ)(1:tlen1d(FJ)),'''', & '\n' ElseIf(CKEY.EQ.'Y' .OR. CKEY.EQ.'T')Then Write(*,*)' ' Write(*,*)' ANAPAW-E : This Option is valid for 2D.' Write(*,*)' ' Return EndIf ElseIf(FKIND.EQ.2)Then If(CKEY.EQ.' ')Then Call LIST2D(HID) Call KUPROI(' GateID >',c2id(FJ)) WRITE(*,*)' X-Axis :' Call KUPROI(' Analyzer >',seg_idx(FJ)) Call KUPROI(' ID 1 >',vidx_1(FJ)) Call KUPROI(' ID 2 >',vidx_2(FJ)) Call KUPROI(' Word >',val_idx(FJ)) WRITE(*,*)' Y-Axis :' Call KUPROI(' Analyzer >',seg_idy(FJ)) Call KUPROI(' ID 1 >',vidy_1(FJ)) Call KUPROI(' ID 2 >',vidy_2(FJ)) Call KUPROI(' Word >',val_idy(FJ)) WRITE(*,*)' X-Axis :' Call KUPROI(' Bin >',xbin(FJ)) Call KUPROR(' Min >',xmin(FJ)) Call KUPROR(' Max >',xmax(FJ)) WRITE(*,*)' Y-Axis :' Call KUPROI(' Bin >',ybin(FJ)) Call KUPROR(' Min >',ymin(FJ)) Call KUPROR(' Max >',ymax(FJ)) Call KUPROS(' Title >',title_2d(FJ),tlen2d(FJ)) Write(*,*)' ' same_flag_hst2(FJ) = .FALSE. If( seg_idx(FJ).eq.seg_idy(FJ) ) Then If( (vidx_1(FJ).EQ.vidy_1(FJ)) .and. & (vidx_2(FJ).EQ.vidy_2(FJ)) ) Then same_flag_hst2(FJ) = .TRUE. EndIf EndIf Write(H2DLine(FJ),*)HID,',',c2id(FJ),',', & seg_idx(FJ),',',vidx_1(FJ),',', & vidx_2(FJ),',',val_idx(FJ),',',seg_idy(FJ),',', & vidy_1(FJ),',',vidy_2(FJ),',',val_idy(FJ),',', & xbin(FJ),',',xmin(FJ),',',xmax(FJ),',', & ybin(FJ),',',ymin(FJ),',',ymax(FJ),',','''', & title_2d(FJ)(1:tlen2d(FJ)),'''','\n' Dumbinx1 = (xmax(FJ)-xmin(FJ))/xbin(FJ) Dumbiny1 = (ymax(FJ)-ymin(FJ))/ybin(FJ) Dumgate = c2id(FJ) Dumbinx = xbin(FJ) Dumbiny = ybin(FJ) Dumbinx2 = (xmax(FJ)-xmin(FJ))/xbin(FJ) Dumbiny2 = (ymax(FJ)-ymin(FJ))/ybin(FJ) c If( (Dumbinx1 .NE. Dumbinx2) .OR. c & (Dumbiny1 .NE. Dumbiny2) .OR. c & ( (Dumbinx1 .EQ. Dumbinx2) .and. c & (Dumbinx .LT. xbin(FJ)) ) .OR. c & ( (Dumbiny1 .EQ. Dumbiny2) .and. c & (Dumbiny .LT. ybin(FJ)) ) .OR. c & (Dumgate .NE. c2id(FJ)) )Then Call HDELET(HID) Call HBOOK2(HID,title_2d(FJ),xbin(FJ), & xmin(FJ),xmax(FJ),ybin(FJ),ymin(FJ),ymax(FJ),0.) Call HPLOT(HID,' ',' ',0) Call WRTHID(HID) c Else c Call HXYIJ(HID,xmin(FJ),ymin(FJ),GMINX,GMINY) c Call HXYIJ(HID,xmax(FJ),ymax(FJ),GMAXX,GMAXY) c Call HCOPYR(HID,99999,title_2d(FJ)(1:tlen2d(FJ)), c & GMINX,GMAXX,GMINY,GMAXY,' ') c Call HDELET(HID) c Call HCOPY(99999,HID,title_2d(FJ)(1:tlen2d(FJ))) c Call HDELET(99999) c If(HSUM(HID).EQ.0)Then c Call HRESET(HID,' ') c EndIf c Call HPLOT(HID,' ',' ',0) c Call WRTHID(HID) c EndIf Else Call HPLOT(HID,' ',' ',0) Call WRTHID(HID) Call IRQLC(1,20,ISTAT,NT,GLX1,GLY1) IF (LOLOGX.AND.GLX1.GT.0.) GLX1=10.**(GLX1) IF (LOLOGY.AND.GLY1.GT.0.) GLY1=10.**(GLY1) Call IRQLC(1,20,ISTAT,NT,GLX2,GLY2) IF (LOLOGX.AND.GLX2.GT.0.) GLX2=10.**(GLX2) IF (LOLOGY.AND.GLY2.GT.0.) GLY2=10.**(GLY2) If(GLX1.LT.GLX2)Then RMINX = GLX1 RMAXX = GLX2 Else RMINX = GLX2 RMAXX = GLX1 EndIf If(GLY1.LT.GLY2)Then RMINY = GLY1 RMAXY = GLY2 Else RMINY = GLY2 RMAXY = GLY1 EndIf If(CKEY.EQ.'X')Then Call HXYIJ(HID,RMINX,ymin(FJ),GMINX,GMINY) Call HXYIJ(HID,RMAXX,ymax(FJ),GMAXX,GMAXY) c Write(*,*),RMINX,GMINX,RMAXX,GMAXX c Write(*,*),RMINY,GMINY,RMAXY,GMAXY Call HCOPYR(HID,99999,title_2d(FJ)(1:tlen2d(FJ)), & GMINX,GMAXX,GMINY,GMAXY,' ') Call HDELET(HID) Call HCOPY(99999,HID,title_2d(FJ)(1:tlen2d(FJ))) Call HGIVE(HID,CTEMP,GBINX,DUMX1,DUMX2, & GBINY,DUMY1,DUMY2,NWT,LOC) xmin(FJ) = DUMX1 xmax(FJ) = DUMX2 xbin(FJ) = GBINX ElseIf(CKEY.EQ.'Y')Then Call HXYIJ(HID,xmin(FJ),RMINY,GMINX,GMINY) Call HXYIJ(HID,xmax(FJ),RMAXY,GMAXX,GMAXY) c Write(*,*),RMINX,GMINX,RMAXX,GMAXX c Write(*,*),RMINY,GMINY,RMAXY,GMAXY Call HCOPYR(HID,99999,title_2d(FJ)(1:tlen2d(FJ)), & GMINX,GMAXX,GMINY,GMAXY,' ') Call HDELET(HID) Call HCOPY(99999,HID,title_2d(FJ)(1:tlen2d(FJ))) Call HGIVE(HID,CTEMP,GBINX,DUMX1,DUMX2, & GBINY,DUMY1,DUMY2,NWT,LOC) ymin(FJ) = DUMY1 ymax(FJ) = DUMY2 ybin(FJ) = GBINY ElseIf(CKEY.EQ.'T')Then Call HXYIJ(HID,RMINX,RMINY,GMINX,GMINY) Call HXYIJ(HID,RMAXX,RMAXY,GMAXX,GMAXY) c Write(*,*),RMINX,GMINX,RMAXX,GMAXX c Write(*,*),RMINY,GMINY,RMAXY,GMAXY Call HCOPYR(HID,99999,title_2d(FJ)(1:tlen2d(FJ)), & GMINX,GMAXX,GMINY,GMAXY,' ') Call HDELET(HID) Call HCOPY(99999,HID,title_2d(FJ)(1:tlen2d(FJ))) Call HGIVE(HID,CTEMP,GBINX,DUMX1,DUMX2, & GBINY,DUMY1,DUMY2,NWT,LOC) xmin(FJ) = DUMX1 xmax(FJ) = DUMX2 xbin(FJ) = GBINX ymin(FJ) = DUMY1 ymax(FJ) = DUMY2 ybin(FJ) = GBINY EndIf If(HSUM(HID).EQ.0)Then Call HRESET(HID,' ') EndIf Call HPLOT(HID,' ',' ',0) Call WRTHID(HID) Call HDELET(99999) Write(H2DLine(FJ),*)HID,',',c2id(FJ),',', & seg_idx(FJ),',',vidx_1(FJ),',', & vidx_2(FJ),',',val_idx(FJ),',',seg_idy(FJ),',', & vidy_1(FJ),',',vidy_2(FJ),',',val_idy(FJ),',', & xbin(FJ),',',xmin(FJ),',',xmax(FJ),',', & ybin(FJ),',',ymin(FJ),',',ymax(FJ),',','''', & title_2d(FJ)(1:tlen2d(FJ)),'''','\n' EndIf Do i = 1,ANUMH2ID If(HST2FLAG .and. (HID.EQ.AH2ID(i)))Then If(SCATFL)Then Call IACWK(4) Call IDAWK(1) Call ICLRWK(4,0) Call IACWK(1) Call IDAWK(4) EndIf goto 1202 EndIf EndDo Else 1201 Continue Write(*,*)' ' Write(*,*)' ANAPAW-W : Wrong Histogram ID.' Goto 1202 EndIf 1202 Continue Write(*,*)' ' If(chscx.EQ.1)Then Call KUEXEC('OPT LOGX') ElseIf(chscy.EQ.1)Then Call KUEXEC('OPT LOGY') EndIf Call AVIEW(1) Return End c ====================================================================== Subroutine ANAWRITE Include 'common.f' Integer mg,ma,mo,m2d,mstop,mcomment,me,mana Integer Alen Character Lineout*500,Lineend*2 mg = 1 ma = 1 mo = 1 m2d = 1 mstop = 1 multi1 = 1 multi2 = 1 multip = 1 mcomment = 1 me = 1 Lineout = ' ' Lineend = CHAR(0)//CHAR(0) Alen = 0 mana = 1 Call KUGETF(ANAWNAME,L) 212 ANAWLUN = 25 Write(*,*)' ' Write(*,'(A24,A132)')' ANAPAW-M : FileName = ',ANAWNAME Call KUINQF(ANAWNAME,ANAWLUN) If(ANAWLUN.NE.-1)Then Write(*,*)' ' Write(*,*)' ANAPAW-W : File already exist.' Write(*,*)' ' 213 Call KUINPS('OverWrite/NewFile/Append/Quit =o>', & ANAKEY,L) ANAWLUN = 25 If(ANAKEY.EQ.'o' .OR. ANAKEY.EQ.'O' .OR. & ANAKEY.EQ.' ')Then Call KUOPEN(ANAWLUN,ANAWNAME,'UNKNOWN',ISTAT) ElseIf(ANAKEY.EQ.'a' .OR. ANAKEY.EQ.'A')Then Call KUOPEN(ANAWLUN,ANAWNAME,'APPEND',ISTAT) ElseIf(ANAKEY.EQ.'n' .OR. ANAKEY.EQ.'N')Then 214 Call KUINPS('New FileName >',ANAWNAME,L) If(ANAWNAME.EQ.' ')goto 214 Goto 212 ElseIf(ANAKEY.EQ.'q' .OR. ANAKEY.EQ.'Q')Then Write(*,*)' ' Write(*,*)' ANAPAW-M : Exit Write Mode.' Write(*,*)' ' goto 998 Else Goto 213 EndIf ElseIf(ANAWLUN.EQ.-1)Then ANAWLUN = 25 Call KUOPEN(ANAWLUN,ANAWNAME,'NEW',ISTAT) EndIf c Header Write(ANAWLUN,'(A)')'! === ANA-FILE === ' c new cc Analyzer c Write(ANAWLUN,'(A6)')'ANALYS' c Do I = 1, 50 c If(AnalyzerFlag(I))Write(ANAWLUN,'(I1)')I c EndDo c Gates Do k = 1, cseq-1 c write(*,*)k,ckind(k) Lineout = ' ' c If(ckind(k).eq.9 .or. ckind(k).eq.-9)Then c goto 997 If(ckind(k).eq.9)Then Write(Lineout,*)analyzerid(mana),Lineend Do i = 1, 499 If(ICHAR(Lineout(i:i)).eq.0 .and. & ICHAR(Lineout(i+1:i+1)).eq.0) Alen = i-1 EndDo write(ANAWLUN,'(A)')Lineout(2:Alen) mana = mana + 1 ElseIf(ckind(k).eq.0)Then Call TGETLEN(AnaComment(mcomment),Alen) Write(ANAWLUN,'(A)')AnaComment(mcomment)(1:Alen) mcomment = mcomment + 1 ElseIf(ckind(k).eq.1)Then Write(Lineout,*)gateid(mg),',',seg_gateid(mg),',', & vgateid1(mg),',',vgateid2(mg),',',val_gateid(mg),',', & gatemin(mg),',',gatemax(mg),Lineend Do i = 1, 499 If(ICHAR(Lineout(i:i)).eq.0 .and. & ICHAR(Lineout(i+1:i+1)).eq.0) Alen = i-1 EndDo write(ANAWLUN,'(A)')Lineout(2:Alen) mg = mg + 1 ElseIf(ckind(k).eq.2)Then Write(Lineout,*)gandid(ma), & (',',gandele(ma,i),i=2,gsubandid(ma)),Lineend Do i = 1, 499 If(ICHAR(Lineout(i:i)).eq.0 .and. & ICHAR(Lineout(i+1:i+1)).eq.0) Alen = i-1 EndDo write(ANAWLUN,'(A)')Lineout(2:Alen) ma = ma + 1 ElseIf(ckind(k).eq.3)Then Write(Lineout,*)gorid(mo), & (',',gorele(mo,i),i=2,gsuborid(mo)),Lineend Do i = 1, 499 If(ICHAR(Lineout(i:i)).eq.0 .and. & ICHAR(Lineout(i+1:i+1)).eq.0) Alen = i-1 EndDo write(ANAWLUN,'(A)')Lineout(2:Alen) mo = mo + 1 ElseIf(ckind(k).eq.4)Then Write(ANAWLUN,'(A2,A)')'@,',tdfile(m2d)(1:tdflen(m2d)+1) m2d = m2d + 1 ElseIf(ckind(k).eq.5)Then Write(Lineout,*)stopid(mstop),Lineend Do i = 1, 499 If(ICHAR(Lineout(i:i)).eq.0 .and. & ICHAR(Lineout(i+1:i+1)).eq.0) Alen = i-1 EndDo write(ANAWLUN,'(A)')Lineout(2:Alen) mstop = mstop + 1 c Histograms ElseIf(ckind(k).eq.6)Then Write(Lineout,*)c1id(multi1),',',seg_id(multi1),',', & vid1(multi1),',',vid2(multi1),',', & val_id(multi1),',',bin(multi1),',', & minh(multi1),',',maxh(multi1),',', & '''',title_1d(multi1)(1:tlen1d(multi1)),'''',Lineend Do i = 1, 499 If(ICHAR(Lineout(i:i)).eq.0 .and. & ICHAR(Lineout(i+1:i+1)).eq.0) Alen = i-1 EndDo write(ANAWLUN,'(A)')Lineout(2:Alen) multi1 = multi1 + 1 ElseIf(ckind(k).eq.7)Then Write(Lineout,*)c2id(multi2),',',seg_idx(multi2),',', & vidx_1(multi2),',',vidx_2(multi2),',', & val_idx(multi2),',', & seg_idy(multi2),',',vidy_1(multi2),',', & vidy_2(multi2),',',val_idy(multi2),',', & xbin(multi2),',',xmin(multi2),',',xmax(multi2),',', & ybin(multi2),',',ymin(multi2),',',ymax(multi2),',', & '''',title_2d(multi2)(1:tlen2d(multi2)),'''',Lineend Do i = 1, 499 If(ICHAR(Lineout(i:i)).eq.0 .and. & ICHAR(Lineout(i+1:i+1)).eq.0) Alen = i-1 EndDo write(ANAWLUN,'(A)')Lineout(2:Alen) multi2 = multi2 + 1 ElseIf(ckind(k).eq.8)Then Write(Lineout,*)cpid(multip),',',seg_idpx(multip),',', & vidpx_1(multip),',',vidpx_2(multip),',', & val_idpx(multip),',',seg_idpy(multip),',', & vidpy_1(multip),',',vidpy_2(multip),',', & val_idpy(multip),',',pxbin(multip),',', & pxmin(multip),',',pxmax(multip),',', & pymin(multip),',',pymax(multip),',', & '''',title_pf(multip)(1:tlenpf(multip)),'''', & ',',profopt(multip),Lineend Do i = 1, 499 If(ICHAR(Lineout(i:i)).eq.0 .and. & ICHAR(Lineout(i+1:i+1)).eq.0) Alen = i-1 EndDo write(ANAWLUN,'(A)')Lineout(2:Alen) multip = multip + 1 ElseIf(ckind(k).eq.10)Then Write(Lineout,*)Effgateid(me),Lineend Do i = 1, 499 If(ICHAR(Lineout(i:i)).eq.0 .and. & ICHAR(Lineout(i+1:i+1)).eq.0) Alen = i-1 EndDo write(ANAWLUN,'(A)')Lineout(2:Alen) me = me + 1 ElseIf(ckind(k).eq.-1)Then Write(ANAWLUN,'(A4)')'GATE' ElseIf(ckind(k).eq.-2)Then Write(ANAWLUN,'(A3)')'AND' ElseIf(ckind(k).eq.-3)Then Write(ANAWLUN,'(A2)')'OR' ElseIf(ckind(k).eq.-4)Then Write(ANAWLUN,'(A6)')'XYGATE' ElseIf(ckind(k).eq.-5)Then Write(ANAWLUN,'(A4)')'STOP' ElseIf(ckind(k).eq.-6)Then Write(ANAWLUN,'(A4)')'HST1' ElseIf(ckind(k).eq.-7)Then Write(ANAWLUN,'(A4)')'HST2' ElseIf(ckind(k).eq.-8)Then Write(ANAWLUN,'(A4)')'PROF' c new ElseIf(ckind(k).eq.-9)Then Write(ANAWLUN,'(A6)')'ANALYS' c ElseIf(ckind(k).eq.-10)Then Write(ANAWLUN,'(A4)')'LEFF' EndIf 997 Continue EndDo c Exit Write(ANAWLUN,'(A4)')'EXIT' Call KUCLOS(ANAWLUN,' ',ISTAT) 998 Continue Return End c ====================================================================== Subroutine CHKIO(X,Y,GX,GY,GPNIN,CIO) INTEGER GPNIN REAL GX(20),GY(20) REAL PI,GX0,GY0 REAL X,Y,THCHK,COSTH,SINTH REAL X22,X33,X44,Y33,Y44,X00 INTEGER CHKCNT,I,CIO PARAMETER (PI=3.14159265359,GX0=-1000.,GY0=-1000.) CHKCNT = 0 DO I = 1, GPNIN IF(I.EQ.GPNIN)THEN THCHK = ATAN2(GY(1)-GY(I),GX(1)-GX(I)) COSTH = COS(THCHK) SINTH = SIN(THCHK) X22 = SQRT( (GX(1)-GX(I))**2 + (GY(1)-GY(I))**2 ) X33 = (GX0-GX(I))*COSTH + (GY0-GY(I))*SINTH Y33 = -(GX0-GX(I))*SINTH + (GY0-GY(I))*COSTH X44 = (X-GX(I))*COSTH + (Y-GY(I))*SINTH Y44 = -(X-GX(I))*SINTH + (Y-GY(I))*COSTH ELSE THCHK = ATAN2(GY(I+1)-GY(I),GX(I+1)-GX(I)) COSTH = COS(THCHK) SINTH = SIN(THCHK) X22 = SQRT( (GX(I+1)-GX(I))**2 + (GY(I+1)-GY(I))**2 ) X33 = (GX0-GX(I))*COSTH + (GY0-GY(I))*SINTH Y33 = -(GX0-GX(I))*SINTH + (GY0-GY(I))*COSTH X44 = (X-GX(I))*COSTH + (Y-GY(I))*SINTH Y44 = -(X-GX(I))*SINTH + (Y-GY(I))*COSTH ENDIF IF( Y33*Y44 .LT. 0. ) THEN X00 = X33 - Y33/(Y44-Y33)*(X44-X33) IF( (0.LE.X00) .AND. (X00.LT.X22) )THEN CHKCNT = CHKCNT + 1 ENDIF ENDIF ENDDO IF(MOD(CHKCNT,2).EQ.0)THEN CIO = 0. c WRITE(*,*)CHKIO ELSEIF(MOD(CHKCNT,2).EQ.1)THEN CIO = 1. c WRITE(*,*)CHKIO ENDIF RETURN END c ====================================================================== Subroutine GATE2D(GID,GIDX,GIDY,GVALX,GVALY,GIO) Integer GIO,GIDX,GIDY Integer FGSEG,FGKIND,FGM Real GVALX,GVALY Include 'common.f' GIO = 0 ! (0 : Out) (1 : In) (-1 : Error) Call FINDGATE(GID,FGSEG,FGKIND,FGM) If(FGKIND.NE.4)Then GIO = -1 Goto 444 EndIf If( GIDX.GE.tdvidx1(FGM) .AND. GIDX.LE.tdvidx2(FGM) .AND. & GIDY.GE.tdvidy1(FGM) .AND. GIDY.LE.tdvidy2(FGM) )Then Call CHKIO(GVALX,GVALY,tdx(1,FGM),tdy(1,FGM),tdnop(FGM),GIO) Else GIO = -1 EndIf 444 Continue Return End c ====================================================================== Subroutine GATE2DnoID(GID,GVALX,GVALY,GIO) Integer GIO Integer FGSEG,FGKIND,FGM Real GVALX,GVALY Include 'common.f' GIO = 0 ! (0 : Out) (1 : In) (-1 : Error) Call FINDGATE(GID,FGSEG,FGKIND,FGM) If(FGKIND.NE.4)Then GIO = -1 Goto 445 EndIf Call CHKIO(GVALX,GVALY,tdx(1,FGM),tdy(1,FGM),tdnop(FGM),GIO) 445 Continue Return End c ====================================================================== Subroutine TGETLEN(tchar,tlen) Character tchar*132 Integer tlen,i,k k = 0 tlen = 0 Do i = 1,131 tlen = tlen + 1 If(tchar(i:i).eq.' ')Then k = k + 1 If(k.gt.21)Goto 1001 Else k = 0 EndIf Enddo 1001 Continue tlen = tlen - k If(tlen.EQ.0)tlen = 1 Return End c ====================================================================== Subroutine TGETNLEN(tchar,tlen) Character tchar*134 Integer tlen,i,k tlen = 0 Do i = 1,134 If(ICHAR(tchar(i:i)).EQ.10) tlen = i-1 Enddo 1001 Continue If(tlen.EQ.0)tlen = 1 Return End c ====================================================================== Integer Function A2I(inputi) Integer i,j,inputi,outputi Do i = 0,9,1 j = ior(x'0030',i) If(char(j).EQ.char(inputi))Then A2I = i Goto 1001 EndIf EndDo 1001 Continue Return End c ====================================================================== Subroutine AVIEW(INUM) Include 'common.f' Integer INUM ! (0:Close) (1:Open) Integer ISTAT,Iview,Vilen,pid Character*80 viewprm,viewpid Character*20 chpid If(INUM.EQ.0 .and. WinFlag.EQ.1)Then Call GETENV('VIEWANA_PID',viewpid) Call KUINQF(viewpid,ISTAT) If(ISTAT.EQ.-1)Goto 2 Call KUOPEN(40,viewpid,'UNKNOWN',ISTAT) Read(40,*)pid write(chpid,*)pid Call KUEXEC('shell kill -9 '//chpid) Call KUEXEC('shell rm -f $VIEWANA_PID') 2 Continue Call GETENV('VIEWANA_PARAM',viewprm) Call KUINQF(viewprm,ISTAT) If(ISTAT.EQ.-1)Goto 3 Call KUEXEC('shell rm -f $VIEWANA_PARAM') 3 Continue WinFlag = 0 Call KUCLOS(40,' ',ISTAT) ElseIf(INUM.EQ.1)Then Call GETENV('VIEWANA_PARAM',viewprm) Call KUOPEN(50,viewprm,'UNKNOWN',ISTAT) c GATE Iview = 1 Write(50,'(A)')'@gate' Do While (ICHAR(GateLine(Iview)(1:1)).NE.0) Call TGETNLEN(GateLine(Iview),Vilen) Write(50,'(A)')GateLine(Iview)(1:Vilen) Iview = Iview + 1 EndDo c AND Iview = 1 Write(50,'(A)')'@and' Do While (ICHAR(AndLine(Iview)(1:1)).NE.0) Call TGETNLEN(AndLine(Iview),Vilen) Write(50,'(A)')AndLine(Iview)(1:Vilen) Iview = Iview + 1 EndDo c OR Iview = 1 Write(50,'(A)')'@or' Do While (ICHAR(OrLine(Iview)(1:1)).NE.0) Call TGETNLEN(OrLine(Iview),Vilen) Write(50,'(A)')OrLine(Iview)(1:Vilen) Iview = Iview + 1 EndDo c XYGATE Iview = 1 Write(50,'(A)')'@xy' Do While (ICHAR(XYLine(Iview)(1:1)).NE.0) Call TGETNLEN(XYLine(Iview),Vilen) Write(50,'(A)')XYLine(Iview)(1:Vilen) Iview = Iview + 1 EndDo c Hist1 Iview = 1 Write(50,'(A)')'@1D' Do While (ICHAR(H1DLine(Iview)(1:1)).NE.0) Call TGETNLEN(H1DLine(Iview),Vilen) Write(50,'(A)')H1DLine(Iview)(1:Vilen) Iview = Iview + 1 EndDo c Hist2 Iview = 1 Write(50,'(A)')'@2D' Do While (ICHAR(H2DLine(Iview)(1:1)).NE.0) Call TGETNLEN(H2DLine(Iview),Vilen) Write(50,'(A)')H2DLine(Iview)(1:Vilen) Iview = Iview + 1 EndDo Call KUCLOS(50,' ',ISTAT) EndIf Return End c ====================================================================== Subroutine WRTHID(HISTOGRAMID) Integer HISTOGRAMID Character idtitle*80,titletemp*25,idtemp*5 Write(idtemp,'(I5)')HISTOGRAMID titletemp = '''Histogram ID = '//idtemp//'''' idtitle = 'ATITLE '//titletemp//' ! ! 300' Call KUEXEC(idtitle) Return End c ====================================================================== Subroutine GETVIEWSTAT Include 'common.f' Character*80 viewpid Integer istat Call GETENV('VIEWANA_PID',viewpid) Call KUINQF(viewpid,istat) If(ISTAT.EQ.-1)Then WinFlag = 0 Else WinFlag = 1 EndIf Return End c ====================================================================== SUBROUTINE UPAWLOC(NP,XP,YP,NTPRI,IWKID,CHOPT) COMMON /QUEST/IQUEST(100) DIMENSION RQUEST(100) EQUIVALENCE(IQUEST(1),RQUEST(1)) REAL X(2),Y(2) CHARACTER*20 CHLOC(3) DIMENSION IOPT(6) EQUIVALENCE (IOPT(1),IOPTST),(IOPT(2),IOPTPL),(IOPT(3),IOPTMI) EQUIVALENCE (IOPT(4),IOPTP) ,(IOPT(5),IOPTL) ,(IOPT(6),IOPTS) LOGICAL LOLOGX,LOLOGY INTEGER NP REAL XP(20) REAL YP(20) INTEGER NTPRI CHARACTER*(*) CHOPT INTEGER MAXP,IFIRST Parameter (MAXP=20) * *----------------------------------------------------------------------- * IFIRST = 0 CALL UOPTC(CHOPT,'*+-PLS',IOPT) CALL IGQ('MTYP',RMKOLD) IF (IOPTST.GT.0) CALL IGSET('MTYP',3.) NP=0 CALL HPLGIV(XL,YL,XH,YH) NTHIST=IQUEST(12) * 10 LCDNR = 21 IF (NP.EQ.0) THEN IF (IOPTPL.GT.0) LCDNR = 11 ELSE IF (IOPTMI.GT.0) LCDNR = 41 IF (IOPTPL.GT.0) LCDNR = 11 ENDIF IF(IOPTS.NE.0)LCDNR=-LCDNR * IF(NTPRI.GE.0)THEN IF(NTPRI.NE.1)CALL ISELNT(1) CALL ISELNT(NTPRI) ELSE CALL ISELNT(1) DO 20 I=10,NTHIST,10 CALL ISELNT(I) 20 CONTINUE ENDIF * 30 CALL IRQLC(IWKID,LCDNR,ISTAT,NT,XX,YY) IF (ISTAT.EQ.0) GO TO 40 * XLOC = XX YLOC = YY LOLOGX = .FALSE. LOLOGY = .FALSE. CALL HPLCHA(NT,XX,YY,IDH,XLOC,YLOC,ICX,ICY) IF (IQUEST(1).NE.0) LOLOGX=.TRUE. IF (IQUEST(2).NE.0) LOLOGY=.TRUE. IF (IOPTS.NE.0.AND.ISTAT.NE.1)THEN WRITE(CHLOC(1),'('' NP ='',I8)') NP+1 WRITE(CHLOC(2),'('' X ='',G12.4)') XLOC WRITE(CHLOC(3),'('' Y ='',G12.4)') YLOC CALL IGMESS(3,CHLOC,'VLOCATE','P') GOTO 30 ENDIF * IF (NP.EQ.0) THEN CALL ISELNT(NT) IFIRST = 1 ENDIF IF (IFIRST .EQ. 1) THEN NP=NP+1 IF (NP.GT.MAXP) THEN NP=NP-1 CALL KUALFA Write(*,10000)MAXP 10000 FORMAT(' Maximum number of points=',I3,' reached') GO TO 40 ENDIF XP(NP) = XLOC YP(NP) = YLOC X(2) = XLOC IF (LOLOGX.AND.X(2).GT.0.) X(2)=LOG10(X(2)) Y(2) = YLOC IF (LOLOGY.AND.Y(2).GT.0.) Y(2)=LOG10(Y(2)) IF (IOPTP.GT.0.OR.IOPTST.GT.0) CALL IPM(1,X(2),Y(2)) IF ((NP.GT.1).AND.(IOPTL.GT.0.OR.IOPTMI.GT.0)) CALL IPL(2,X,Y) X(1) = XLOC IF (LOLOGX.AND.X(1).GT.0.) X(1)=LOG10(X(1)) Y(1) = YLOC IF (LOLOGY.AND.Y(1).GT.0.) Y(1)=LOG10(Y(1)) ENDIF GO TO 10 * 40 CONTINUE XP(NP) = XLOC YP(NP) = YLOC X(1) = XP(1) IF (LOLOGX.AND.X(1).GT.0.) X(1)=LOG10(X(1)) Y(1) = YP(1) IF (LOLOGY.AND.Y(1).GT.0.) Y(1)=LOG10(Y(1)) X(2) = XLOC IF (LOLOGX.AND.X(2).GT.0.) X(2)=LOG10(X(2)) Y(2) = YLOC IF (LOLOGY.AND.Y(2).GT.0.) Y(2)=LOG10(Y(2)) IF ((NP.GT.1).AND.(IOPTL.GT.0.OR.IOPTMI.GT.0)) CALL IPL(2,X,Y) CALL IGSET('MTYP',RMKOLD) IF (IOPTS.NE.0) CALL IGMESS(1,' ',' ','C') * Return END