C----------------------------------------------------------------------- C This subroutine scans Phi from 0 to 360 and extracts possible peaks C----------------------------------------------------------------------- SUBROUTINE PSCAN (NMAX,NTOT,SPRESET) INCLUDE 'COMDIF' DIMENSION PHIP(40),PCOUNT(40) EQUIVALENCE (BCOUNT(1),PHIP(1)) NMAX = 0 KI = ' ' N5= 5*NSIZE C----------------------------------------------------------------------- C Start Phi, high speed, + sense C----------------------------------------------------------------------- ACOUNT(N5) = 0 CALL ANGET (RTHETA,ROMEGA,RCHI,RPHI) CALL RPSCAN (NPTS,ICOL,SPRESET) IF (ICOL .NE. 0) THEN WRITE (COUT,10000) CALL GWRITE (ITP,' ') IF (KI .EQ. 'RP') KI = ' ' RETURN ENDIF C----------------------------------------------------------------------- C Look for peaks in the profile: if a given count is more than 4 sigmas C above the average of the 3 counts before and the 3 counts after it, C it is a probably a peak. This may be a little weak -- try 8 sigmas C for now. C----------------------------------------------------------------------- I = NPTS DO 110 J = 1,I INDZ = MOD((J + I - 4),I) + 1 SUM = 0 DO 100 KA = 1,7 IF (KA .NE. 4) SUM = SUM + ACOUNT(INDZ) INDZ = INDZ + 1 IF (INDZ .GT. I) INDZ = 1 100 CONTINUE AVECT = SUM/6.0 THRESH = AVECT + 4.0*SQRT(AVECT/6.0 + ACOUNT(J)) IF (ACOUNT(J) .GT. THRESH) THEN NMAX = NMAX + 1 PHIP(NMAX) = ACOUNT(J+N5) PCOUNT(NMAX) = ACOUNT(J) ENDIF 110 CONTINUE C----------------------------------------------------------------------- C Eliminate duplicate peaks C----------------------------------------------------------------------- IPFLAG = 0 IF (NMAX .GT. 1) THEN DO 120 I = 1,NMAX-1 IF (ABS(PHIP(I) - PHIP(I+1)) .LT. 2.5) THEN IPFLAG = 1 IF (PCOUNT(I) .LT. PCOUNT(I+1)) THEN PCOUNT(I) = - PCOUNT(I) ELSE PCOUNT(I+1) = - PCOUNT(I+1) ENDIF ENDIF 120 CONTINUE IF (IPFLAG .NE. 0) THEN J = 0 DO 130 I = 1,NMAX IF (PCOUNT(I) .GT. 0) THEN J = J + 1 PCOUNT(J) = PCOUNT(I) PHIP(J) = PHIP(I) ENDIF 130 CONTINUE NMAX = J ENDIF ENDIF IF (NMAX .GT. 0) THEN NPEAK = NTOT DO 140 I = 1,NMAX NPEAK = NPEAK + 1 WRITE (COUT,11000) NPEAK,RTHETA,ROMEGA,RCHI,PHIP(I),PCOUNT(I) CALL GWRITE (ITP,' ') WRITE (LPT,11000) NPEAK,RTHETA,ROMEGA,RCHI,PHIP(I),PCOUNT(I) 140 CONTINUE ENDIF IF (KI .EQ. 'RP') KI = ' ' RETURN 10000 FORMAT (1X,' Scan error in PSCAN') 11000 FORMAT (10X,I4,4F10.2,F10.0) END