CTITLESAPEAK -- PRINTER PRINTOUT OF ALL VELOCITY PEAKS 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** C INDSAPEAK 00020000 CA AUTHOR W. J. BROWN 00030000 CA DESIGNER W. J. BROWN 00040000 CA LANGUAGE FORTRAN 00050000 CA SYSTEM IBM AND CRAY 00060000 CA WRITTEN 02-01-77 00070000 C REVISED 10-25-77 GCW. ADDED PEAK SEMBLENCE TO LISTINGAND 00080000 C FLAGGED VELOCITY AT PEAK SEMBL. 00090000 C REVISED 05-11-78 MENDEKE - CHANGED VELOCITY SMOOTHING. 00100000 C REVISED 07-05-78 COOPER - CHANGED TO ALLOW NEGATIVEADJUSTING 00110000 C OF VALUES. 00120000 C REVISED 06-20-79 BY SAS - MODIFIED TO ELIMINATE VELOCITY MASK 00130000 C BOUNDARY PEAKS. 00140000 C REVISED 08-26-81 BY ESN - ADDED TIME VARIANT MASK CAPABILITY. 00150000 C REVISED 03-11-86 BY ESN - FOR CRAY COMPATABILITY. 00160000 C REVISED 11-13-89 BY RDK - FOR CRAY CFT77 COMPATIBILITY. 00161002 CA 00170000 CA 00180000 CA CALL SAPEAK(XARRAY, VASLV,VAELV, TLO, VASUV, VAEUV, THI, 00190000 CA VELINA, VELN, TIME, IPR, VELST) 00200000 CA 00210000 CA INPUT XARRAY = ARRAY CONTAINING ONE TIME SCAN R4 00220000 CA INPUT VASLV = STARTING LOWER VELOCITY I4 00230000 CA INPUT VAELV = ENDING LOWER VELOCITY I4 00240000 CA INPUT TLO = ANALYSIS START TIME (MS) I4 00250000 CA INPUT VASUV = STARTING UPPER VELOCITY I4 00260000 CA INPUT VAEUV = ENDING UPPER VELOCITY I4 00270000 CA INPUT THI = ANALYSIS END TIME (MS) I4 00280000 CA INPUT VELINA = VELOCITY INCREMENT I4 00290000 CA INPUT VELN = NUMBER OF VELOCITY IN ARRAY I4 00300000 CA INPUT TIME = TIME FOR THIS SCAN (MS) I4 00310000 CA INPUT IPR = PRINTER UNIT I4 00320000 CA INPUT VELST = MINIMUM OVERALL VELOCITY I4 00330000 CA 00340000 CA 00350000 CA THIS APPLICATION ROUTINE WILL PRODUCE A PRINTER PLOT OF 00360000 CA ALL VELOCITY PEAKS. 00370000 CAEND 00380000 C 00390000 C LOCAL VARIABLES AND CONSTANTS (INTERNAL TO SUBROUTINE). 00400000 C 00410000 C AA = REAL VARIABLE FOR COMPUTING THREE POINT FIT R4 00420000 C BB = REAL VARIABLE FOR COMPUTING THREE POINT FIT R4 00430000 C CC = REAL VARIABLE FOR COMPUTING THREE POINT FIT R4 00440000 C BLNK = CHARACTER STRING ' ' A4 00450000 C ADJVEL = VELOCITY ADJUSTMENT R4 00460000 C CALVEL = UNSMOOTHED VELOCITY I4 00470000 C NVELM1 = NUMBER OF VELOCITY PER TIME SCAN MINUS 1 I4 00480000 C NVEL = NUMBER OF VELOCITY PER TIME SCAN I4 00490000 C PKVEL = PEAK VELOCITY FOR THIS TIME SCAN I4 00500000 C VLPRT = WORK ARRAY FOR PRINTING VELOCITIES I4 00510000 C EJECT 00520000 SUBROUTINE SAPEAK (XARRAY, VASLV, VAELV, TLO, VASUV, VAEUV, 00530000 * THI, VELINA, VELN, TIME, IPR, VELST) 00540000 IMPLICIT INTEGER (A-Z) 00550000 C 00560000 C EXTERNAL S1ATP 00570001 C 00580000 C REAL ARRAYS IN PARAMETER LIST. 00590000 C 00600000 REAL XARRAY (1) 00610000 C 00620000 C INTEGER ARRAYS LOCAL 00630000 C 00640000 INTEGER VLPRT (20) 00650000 C 00660000 C REAL VARIABLES AND CONSTANTS--LOCAL (INTERNAL 00670000 C TO SUBROUTINE). 00680000 C 00690000 REAL AA 00700000 REAL ADJVEL 00710000 REAL BB 00720000 REAL CC 00730000 REAL FPTHI 00740000 REAL FPTIME 00750000 REAL FPTLO 00760000 REAL PKS 00770000 REAL VATFRC 00780000 C 00790000 C CHARACTER VARIABLES 00800000 C 00810000 CHARACTER*32 FORMAT 00820000 C 00830000 C DATA STATEMENTS 00840000 C 00850000 DATA BLNK /' '/ 00860000 C 00870000 C INITIALIZATION 00880000 C 00890000 IF (1.EQ.2) CALL S1ATP 00891001 C 00892001 CALL ARSET ( VLPRT, 20, BLNK ) 00900000 C 00910000 C 1 6 11 16 21 26 31 36 41 46 00920000 C !----!----!----!----!----!----!----!----!----! 00930000 CALL S1MVCH('(1X,I5,F7.3,3X, I6,T ,''*'')',1,FORMAT,1,31) 00940000 NVEL = VELN 00950000 PKS = -1. 00960000 J = 1 00970000 C 00980000 C CHECK FOR VELOCITY MASK 00990000 C 01000000 MASKF = 1 01010000 C 01020000 C IF (VASLV .EQ. VAELV .AND. VASUV .EQ. VAEUV) MASKF = 0 01030000 C 01040000 C FIND THE MAXIMUM SEMBLENCE FOR THIS TIME SCAN 01050000 C 01060000 NVELM1 = NVEL - 1 01070000 IST = 2 01080000 IEND = NVELM1 01090000 C 01100000 C MODIFY START/END TIME SCAN INDEXES FOR VEL MASK 01110000 C 01120000 IF (MASKF .EQ. 0)GO TO 5 01130000 C 01140000 FPTLO = TLO 01150000 FPTHI = THI 01160000 FPTIME = TIME 01170000 VALDIF = VAELV - VASLV 01180000 VAHDIF = VAEUV - VASUV 01190000 VATFRC = (FPTIME - FPTLO)/(FPTHI - FPTLO) 01200000 VLO = VASLV + (VATFRC * VALDIF + 0.5) 01210000 VHI = VASUV + (VATFRC * VAHDIF + 0.5) 01220000 C 01230000 IST = ((VLO -VELST + VELINA - 1)/ VELINA) + 1 01240000 IEND = ((VHI - VELST)/ VELINA) + 1 01250000 IST = IST + 1 01260000 IEND = IEND - 1 01270000 5 CONTINUE 01280000 C 01290000 DO 20 01300000 * I = IST, IEND 01310000 C 01320000 AA = XARRAY(I-1) 01330000 BB = XARRAY(I) 01340000 CC = XARRAY(I+1) 01350000 IF (I .EQ. 2) AA = BB 01360000 IF (I .EQ. NVELM1) CC = BB 01370000 C 01380000 01390000 IF ( BB .LE. 0.) GO TO 20 01400000 IF ( BB .LE. AA ) GO TO 20 01410000 IF ( BB .LE. CC ) GO TO 20 01420000 CALVEL = VELST + ( I-1 ) * VELINA 01430000 C 01440000 C COMPUTE THE PEAK VELOCITY 01450000 C 01460000 ADJVEL = 0. 01470000 C 01480000 C PEFORM 3 PT. QUADRATIC FIT TO MAX VALUE 01490000 C 01500000 C V(X) = AX**2 + BX + C 01510000 C V(X)' = 2AX + B = 0 FOR X = XP AT PEAK V(XP) 01520000 C SO XP = -B/2A AND V(XP) = -.25 B**2/A + C 01530000 C TAKE V(X) AT X = -1, 0, 1 AND WE GET, 01540000 C B = .5 (V(1) - V(-1)) 01550000 C 2A = V(-1) + V(1) - 2V(0) 01560000 C C = V(0) 01570000 C 01580000 C NOW DO IT 01590000 C 01600000 C 01610000 IF (XARRAY(I) .EQ. 0.) GO TO 10 01620000 IF (XARRAY(I-1) .EQ. 0.) GO TO 10 01630000 IF (XARRAY(I+1) .EQ. 0.) GO TO 10 01640000 C 01650000 AA = .5 * (XARRAY(I-1) + XARRAY(I+1) -2. * XARRAY(I)) 01660000 IF ( ABS(AA) .LT. .001) GO TO 10 01670000 BB = .5 * (XARRAY(I+1) - XARRAY(I-1)) 01680000 CC = XARRAY(I) 01690000 ADJVEL = (-BB / (2.*AA))*VELINA 01700000 IF (ABS(ADJVEL) .LT. 1.0) ADJVEL = 0.0 01710000 10 CONTINUE 01720000 PKVEL = CALVEL + ADJVEL 01730000 IF (XARRAY(I) .LT. PKS) GO TO 15 01740000 PKS = XARRAY(I) 01750000 JSTAR = J 01760000 C 01770000 15 VLPRT(J) = PKVEL 01780000 J = J + 1 01790000 IF ( J .EQ. 20 ) GO TO 30 01800000 20 CONTINUE 01810000 30 PRTOP = J - 1 01820000 IF ( PRTOP .EQ. 0 ) GO TO 40 01830000 JSTAR = 17 + 6*JSTAR 01840000 CALL S1BNCV(JSTAR, FORMAT, 22, 3) 01850000 CALL S1BNCV(PRTOP, FORMAT, 16, 2) 01860000 WRITE ( IPR, FORMAT ) TIME,PKS,(VLPRT(JJ),JJ=1,PRTOP) 01870000 40 CONTINUE 01880000 C 01890000 RETURN 01900000 C 01910000 C 01920000 END 01930000