SUBROUTINE PEAK(ISW, IARRAY, IBSZ, ITHRSH, INIT, IPOS, IHIGHT, IST *AT, IZPS) C C C This routine will find a peak, provided that: C a. The height of the peak exceeds a threshold that C is given as a parameter. A threshold C is the number of samples that consistantly produce C a positive gradient after a THREE sample linear fit. C C C C WARNING: C C Do not attempt to overlay this routine. C C C PARAMETERS: C C ISW Input turn on diags C IARRAY Input array of 256 real values of "Y". C IBSZ Buffer size (multiple of 3 and .LE. 255) C ITHRSH Input Number of +ve slopes before peak threshold. C INIT Input Initialize all variables flag. C IPOS Returned position of peak height. C IHIGHT Returned Height of peak(integer). C ISTAT 0 = No peak start or end in block. C 1 = Complete peak found (ipos,ihight returned) C 2 = Peak rise encountered(latest ipos,ihight returned) C 64+ = More than one peak in buffer. Call me C again to receive next peak. C 512+= Zero height peak, ipos and ihight refer C to next peak found. "IZPS" is the number of C zero height peaks estimated. C 4096+= Peak height > full scale C IZPS Number of zero height peaks (see ISTAT=512+). C C LOGICAL INIT, TOP, PSTART, ISW INTEGER THRESH, CI, FI, IARRAY(256), CIREJ, FIREJ DATA SLOPE/0./, IPS/0/ DATA PSTART/.FALSE./, TOP/.FALSE./ C C Reset parameters C IPOS = 0 IZPS = 0 IHIGHT = 0 C IC = ISTAT.AND.64 IF (.NOT.(IC.NE.64)) GOTO 2000 IPT = 0 IREJ = ITHRSH/3 C IF (.NOT.(INIT)) GOTO 2020 CI = 0. FI = 0. IPN = 0 GAP = 0. GAPL = 0 IHL = 0 IH = 0 PSTART = .FALSE. IPSL = 0 TOP = .FALSE. 2020 CONTINUE 2000 CONTINUE CRetain status of 2 ISTAT = ISTAT.AND.2 C C C start of main processing loop C C 2040 IF (.NOT.(IPT.LT.(IBSZ-2))) GOTO 2050 IPT = IPT + 1 GAP = GAP + 1. SLAST = SLOPE IF (.NOT.(PSTART)) GOTO 2060 IF (.NOT.(IARRAY(IPT).EQ."7777)) GOTO 2080 ISTAT = ISTAT + 4096 2080 CONTINUE IF (.NOT.(IARRAY(IPT).GT.IH)) GOTO 2100 IH = IARRAY(IPT) IP = IPT 2100 CONTINUE C C Calculate the SLOPE of 3 points C 2060 CONTINUE SLOPE = 0. A1 = 0. A2 = 0. A3 = 0. A4 = 0. DO 2120 I = 1, 3 AX = I A1 = A1 + AX*IARRAY(IPT + I - 1) A2 = A2 + AX A3 = A3 + IARRAY(IPT + I - 1) A4 = A4 + AX*AX 2120 CONTINUE SLOPE = (3*A1 - A2*A3)/(3*A4 - A2*A2) IF (.NOT.(ISW)) GOTO 2140 WRITE(5, 2160) (IARRAY(I), I = IPT, IPT + 2), SLOPE 2160 FORMAT(3I6,' SLOPE= ',F9.0) C 2140 CONTINUE IF (.NOT.(SLOPE.GT.0.)) GOTO 2170 IF (.NOT.(SLAST.GT.0)) GOTO 2190 IF (.NOT.(.NOT.TOP)) GOTO 2210 CI = CI + 1 CIREJ = 1 + CI/IREJ IF (.NOT.(CIREJ.GT.3)) GOTO 2230 CIREJ = 3 2230 CONTINUE IF (.NOT.(ISW)) GOTO 2250 WRITE(5, 2270) CI, CIREJ 2270 FORMAT(' CI=',I3,' CIREJ=',I3) 2250 CONTINUE IF (.NOT.(CI.GE.ITHRSH)) GOTO 2280 ISTAT = ISTAT.OR.2 2280 CONTINUE 2210 CONTINUE IF (.NOT.(CI.EQ.1)) GOTO 2300 PSTART = .TRUE. 2300 CONTINUE GOTO 2200 2190 CONTINUE IF (.NOT.(CI.GE.ITHRSH)) GOTO 2320 IF (.NOT.(FI.GE.ITHRSH)) GOTO 2340 ISTAT = 1 PSTART = .FALSE. IPN = IPN + 1 CI = 0 FI = 0 CIREJ = 0 FIREJ = 0 TOP = .FALSE. GOTO 2050 2340 CONTINUE FIREJ = FIREJ - 1 IF (.NOT.(FIREJ.LE.0)) GOTO 2360 FI = 0 GOTO 2370 2360 CONTINUE SLOPE = 0. - 1. 2370 CONTINUE 2350 CONTINUE GOTO 2200 2320 CONTINUE CI = 0 IH = 0 IHL = 0 2200 CONTINUE GOTO 2180 2170 CONTINUE IF (.NOT.(SLAST.LE.0)) GOTO 2380 IF (.NOT.(CI.GE.ITHRSH)) GOTO 2400 FI = FI + 1 FIREJ = 1 + FI/IREJ IF (.NOT.(FIREJ.GT.3)) GOTO 2420 FIREJ = 3 2420 CONTINUE IF (.NOT.(ISW)) GOTO 2440 WRITE(5, 2460) FI, FIREJ 2460 FORMAT(' FI=',I4,' FIREJ=',I4) 2440 CONTINUE 2400 CONTINUE GOTO 2390 2380 CONTINUE IF (.NOT.(CI.LT.ITHRSH)) GOTO 2470 CIREJ = CIREJ - 1 IF (.NOT.(CIREJ.LE.0)) GOTO 2490 CI = 0 IH = 0 IHL = 0 PSTART = .FALSE. GOTO 2500 2490 CONTINUE SLOPE = 1. 2500 CONTINUE GOTO 2390 2470 CONTINUE TOP = .TRUE. 2390 CONTINUE 2180 CONTINUE C C C End of main processing loop C C GOTO 2040 2050 CONTINUE IC = ISTAT.AND.3 IF (.NOT.(IC.GT.0)) GOTO 2510 IF (.NOT.(IH.GT.IHL)) GOTO 2530 GAPL = GAP IPOS = IP IHIGHT = IH IHL = IH 2530 CONTINUE 2510 CONTINUE IF (.NOT.(IC.EQ.1)) GOTO 2550 IH = 0 IHL = 0 GAP = GAP - GAPL IF (.NOT.(IPN.EQ.2)) GOTO 2570 GAP1 = GAPL GOTO 2580 2570 CONTINUE IF (.NOT.(IPN.GT.2)) GOTO 2590 IF (.NOT.(GAPL.GT.(1.5*GAP1))) GOTO 2610 ISTAT = ISTAT.OR.512 IZPS = GAPL/GAP1 IF (.NOT.((GAPL/GAP1-IZPS).LT..5)) GOTO 2630 IZPS = IZPS - 1 2630 CONTINUE 2610 CONTINUE 2590 CONTINUE 2580 CONTINUE C 2550 CONTINUE IF (.NOT.(IPT.LT.(IBSZ-2))) GOTO 2650 ISTAT = ISTAT.OR.64 GOTO 2660 2650 CONTINUE GAP = GAP + 2 C C 2660 CONTINUE RETURN END