CTITLEAPAGCX -- AP CONTROL FOR AUTOMATIC GAIN CONTROL SCALING 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR STU NELAN 00020000 CA DESIGNER R. D. KNIGHT 00030000 CA LANGUAGE FORTRAN 00040000 CA SYSTEM IBM AND CRAY 00050000 CA WRITTEN 12-16-81 00060000 C REVISED 08-05-82 NELAN - FOR RMS CASE ZEROED OUT APTEM3 00070000 C ARRAY TO PREVENT POSSIBLE CVM PROBLEMS. 00080000 C REVISED 12-10-84 KNIGHT - CREATED FOR CFT FROM 3838 VPSS. 00090000 C REVISED 04-26-85 MURPHY - ADDED INSTANTANEOUS AMPLITUDE AGC 00100000 C AND PARTIAL AGC CAPABILITIES. 00110000 C REVISED 04-26-85 ALSO DELETED REFERENCES, CALLS, &VARIABLES 00120000 C ASSOCIATED WITH THMAXM, THMAXI, THMINM, 00130000 C THMINI, THMAV, & THPSF AND CODE TO 00140000 C CALCULATE SAME FOR TRACE HEADER VALUES 00150000 C DEEMED TO NO LONGER BE NEEDED IN SPARC. 00160000 C PART OF THE SDWRIT SPEED-UP. DELETIONS 00170000 C NOTED BY 'CSU*'(COMMENT SPEED-UP DELETIONS).00180000 C REVISED 05-07-86 NELAN - FOR IBM USE. 00190000 C REVISED 11-06-89 KNIGHT- FOR CRAY CFT77 COMPATIBILITY. 00191003 CA 00200000 CA 00210000 CA CALL APAGCX ( BULK, ZBULK, IBULK, INTR, OTR ) 00220000 CA WORK BULK = REAL WORK ARRAY R8 00230000 CA WORK ZBULK = REAL WORK ARRAY (SAME AS BULK) R8 00240000 CA WORK IBULK = INTEGER WORK ARRAY (SAME AS BULK) I4 00250000 CA INPUT INTR = INPUT TRACE R8 00260000 CA OUTPUT OTR = OUTPUT TRACE R8 00270000 CA 00280000 CA THIS SUBROUTINE PERFORMS THE INITIALIZATION NECESSARY FOR 00290000 CA PERFORMING AGCS IN THE XMP CPU,INCLUDING MEMORY ALLOCATION 00300000 CA AND THE 3838 SIMULATION. 00310000 CA 00320000 C EJECT 00330000 C 00340000 C LOCAL OR INTERNAL ARRAYS. 00350000 C 00360000 C XCOM ( 1) = COMMON ARRAY R8 00370000 C INTR ( 1) = INPUT TRACE AREA R8 00380000 C OTR ( 1) = OUTPUT TRACE AREA R8 00390000 C 00400000 C LOCAL OR INTERNAL VARIABLES AND CONSTANTS. 00410000 C 00420000 C NXARRV = ADDRESS OF X OPERAND I8 00430000 C NICTX = LENGTH OF X OPERAND I8 00440000 C NIDLX = SPACING OF X OPERAND I8 00450000 C NYARRV = ADDRESS OF Y OPERAND I8 00460000 C NICTY = LENGTH OF Y OPERAND I8 00470000 C NIDLY = SPACING OF Y OPERAND I8 00480000 C NUARRV = ADDRESS OF U OPERAND I8 00490000 C NICTU = LENGTH OF U OPERAND I8 00500000 C NIDLU = SPACING OF U OPERAND I8 00510000 C 00520000 C EJECT 00530000 C 00540000 SUBROUTINE APAGCX ( BULK, ZBULK, IBULK, INTR, OTR ) 00550000 C 00560000 IMPLICIT INTEGER (A-Z) 00570000 C 00580000 C COMMON /P/ STATEMENTS GENERATED BY UTCGI4 11/30/83 00590000 CIBM COMMON /P/ STARTP , M00000( 29) 00600000 CIBM REAL *8 STARTP 00610000 COMMON /P/ STARTP ( 2) , M00000( 29) 00620000 COMMON /P/ ACLNAM ( 5) , M00124( 68) 00630000 COMMON /P/ KPNA 00640000 COMMON /P/ KPRNO , M00420( 11) 00650000 COMMON /P/ KPFCF 00660000 COMMON /P/ KPIRSM 00670000 COMMON /P/ KPNRSM 00680000 COMMON /P/ KPIUSM 00690000 COMMON /P/ KPNUSM , M00484 00700000 COMMON /P/ KPRTF , M00492( 6) 00710000 COMMON /P/ KPLOTF 00720000 COMMON /P/ KPMITF 00730000 COMMON /P/ KPPRNT , M00528( 2) 00740000 COMMON /P/ KPBUGF , M00540( 226) 00750000 COMMON /P/ ENDP 00760000 C 00770000 COMMON COM (100) 00780001 C 00790000 C=================================================================== 00800000 C 00810000 C INTEGER ARRAYS--LOCAL 00820000 C 00830000 CIBM INTEGER DLOCAL (75) 00840000 INTEGER IBULK ( 2) 00850000 INTEGER R (15) 00860000 C 00870000 C INTEGER VARIABLES 00880000 C 00890000 INTEGER AABS 00900000 INTEGER ARMS 00910000 CIBM INTEGER ISTATE 00920000 INTEGER LCIT 00930000 CIBM INTEGER LLOCAL 00940000 INTEGER R1 00950000 INTEGER R2 00960000 INTEGER R3 00970000 INTEGER R4 00980000 INTEGER R5 00990000 INTEGER R6 01000000 INTEGER R7 01010000 INTEGER R8 01020000 INTEGER R9 01030000 INTEGER R10 01040000 INTEGER R11 01050000 INTEGER R12 01060000 INTEGER R13 01070000 INTEGER R14 01080000 INTEGER R15 01090000 C 01100000 C REAL VARIABLES 01110000 C 01120000 REAL A0 01130000 REAL CVMGT 01140000 REAL PRCAGC 01150000 REAL UVPSS 01160000 REAL UVPSS1 01170000 REAL UVPSS2 01180000 REAL UVPSS3 01190000 REAL UVPSS4 01200000 REAL XFFTSC 01210000 REAL XINT 01220000 REAL XISCAL 01230000 REAL XLIMIT 01240000 REAL XMAXVL 01250000 REAL XR1 01260000 REAL XR2 01270000 REAL XR3 01280000 REAL XR4 01290000 REAL XR5 01300000 REAL XR6 01310000 REAL XR7 01320000 REAL XR8 01330000 REAL XR9 01340000 REAL XR10 01350000 REAL XR11 01360000 REAL XR12 01370000 REAL XR13 01380000 REAL XR14 01390000 REAL XR15 01400000 REAL XSUM 01410000 REAL XVPSS 01420000 REAL YVPSS 01430000 DOUBLE PRECISION YVPSS8 01440000 C 01450000 C REAL ARRAYS 01460000 C 01470000 REAL BULK (1) 01480000 REAL INTR (1) 01490000 REAL OTR (1) 01500000 REAL XCOM (1) 01510000 REAL ZBULK (1) 01520000 C 01530000 C 01540000 EQUIVALENCE ( R( 1), R1 , XR1 ) 01550000 EQUIVALENCE ( R( 2), R2 , XR2 ) 01560000 EQUIVALENCE ( R( 3), R3 , XR3 ) 01570000 EQUIVALENCE ( R( 4), R4 , XR4 ) 01580000 EQUIVALENCE ( R( 5), R5 , XR5 ) 01590000 EQUIVALENCE ( R( 6), R6 , XR6 ) 01600000 EQUIVALENCE ( R( 7), R7 , XR7 ) 01610000 EQUIVALENCE ( R( 8), R8 , XR8 ) 01620000 EQUIVALENCE ( R( 9), R9 , XR9 ) 01630000 EQUIVALENCE ( R(10), R10, XR10) 01640000 EQUIVALENCE ( R(11), R11, XR11) 01650000 EQUIVALENCE ( R(12), R12, XR12) 01660000 EQUIVALENCE ( R(13), R13, XR13) 01670000 EQUIVALENCE ( R(14), R14, XR14) 01680000 EQUIVALENCE ( R(15), R15, XR15) 01690000 C 01700000 EQUIVALENCE (COM (1), XCOM (1)) 01710000 C 01720000 C INTEGER ARRAYS -- INITIALIZATION 01730000 C 01740000 DATA AABS /'AABS'/ 01750000 DATA ARMS /'ARMS'/ 01760000 DATA KGM / 0/ 01770000 CIBM DATA ISTATE / 88 / 01780000 DATA LCIT / 1000 / 01790000 CIBM DATA LLOCAL /75/ 01800000 C 01810000 C REAL VARIABLES 01820000 C 01830000 CIBM DATA XLIMIT /Z10100000/ 01840000 CIBM DATA XMAXVL /Z7FFFFFFF/ 01850000 DATA XLIMIT /.9956824E-59/ 01860000 DATA XMAXVL /.7237005E+76/ 01870000 C 01880000 C TRANSFER DATA FROM DLOCAL 01890000 C 01900000 TYPSC = COM(KPIRSM+18) 01910000 PMODSV = COM(KPIRSM+26) 01920000 MLTSPC = COM(KPIRSM+57) 01930000 APINDX = COM(KPIRSM+54) 01940000 APCESW = COM(KPIRSM+58) 01950000 APCMDW = COM(KPIRSM+59) 01960000 APCMUL = COM(KPIRSM+60) 01970000 APCMDF = COM(KPIRSM+61) 01980000 NOSAMP = COM(KPIRSM+65) 01990000 APMOVE = COM(KPIRSM+66) 02000000 ISTAMP = COM(KPIRSM+67) 02010000 PRCAGC = XCOM(KPIRSM+68) 02020000 FFTLEN = COM(KPIRSM+69) 02030000 MAG = COM(KPIRSM+70) 02040000 CIBM XFFTSC = XCOM(KPIRSM+71) 02050000 MXWIND = NOSAMP/ 3 02060000 C 02070000 C SET UP 3838 BULK STORAGE ADDRESSES 02080000 C 02090000 APFLV = 1 02100000 APLLV = APFLV + 1 02110000 APNLV = APLLV + 1 02120000 APRTM0 = APNLV + 1 02130000 APLIVC = APRTM0 + 1 02140000 APRTM1 = APLIVC + 1 02150000 APFLWD = APRTM1 + 1 02160000 APNW = APFLWD + 1 02170000 APFLVN = APNW + 1 02180000 APWLD2 = APFLVN + 1 02190000 APFLVM = APWLD2 + 1 02200000 APRTM2 = APFLVM + 1 02210000 APWL = APRTM2 + 1 02220000 APRTM3 = APWL + 1 02230000 APRTM4 = APRTM3 + 1 02240000 APONE = APRTM4 + 1 02250000 APRMSO = APONE + 1 02260000 APSPR0 = APRMSO + 1 02270000 APLIMU = APSPR0 + 1 02280000 APLMU1 = APLIMU + 4 02290000 APLMU2 = APLMU1 + 4 02300000 CSU* APAMAX = APLMU2 + 4 02310000 CSU* APAMIN = APAMAX + 2 02320000 CSU* APABSM = APAMIN + 2 02330000 C ADDED AP FFT SCALER TO BULK STORE AND PARTIAL/AGC SCALERS 02340000 APFTSC = APLMU2 + 4 02350000 APPRC1 = APFTSC + 1 02360000 APPRC2 = APPRC1 + 1 02370000 C 02380000 APINTR = APPRC2 + 1 02390000 APRECU = APINTR + NOSAMP 02400000 IF (MLTSPC .NE. 1) GO TO 5010 02410000 APESWI = APINTR 02420000 APMDWI = APESWI + MXWIND * 2 02430000 APMULT = APMDWI + MXWIND 02440000 APMDDF = APMULT + MXWIND 02450000 APINTR = APMDDF + MXWIND 02460000 APADFR = APINTR + NOSAMP 02470000 APMDFR = APADFR + MXWIND 02480000 APCDFR = APMDFR + MXWIND 02490000 APMUL1 = APCDFR + MXWIND 02500000 APMUL2 = APMUL1 + NOSAMP 02510000 APRECU = APMUL2 + NOSAMP 02520000 5010 CONTINUE 02530000 APLVCT = APRECU + NOSAMP + 1 02540000 APLVDD = APLVCT + NOSAMP 02550000 APTEM3 = APLVDD + NOSAMP 02560000 IF (TYPSC .NE. ARMS) APTEM3 = APLVDD 02570000 APRSUM = APTEM3 + NOSAMP 02580000 APADIF = APRSUM + NOSAMP 02590000 APCDIF = APADIF + NOSAMP 02600000 APWAVG = APCDIF + NOSAMP 02610000 APWVAL = APWAVG + NOSAMP 02620000 APOTR = APINTR 02630000 C ********* SET UP WORK BUFFERS FOR INSTANAEOUS AMPLITUDE AND/OR 02640000 C THE PARTIAL/AGC OPTION. BULK(APT2) WILL BE USED AS A 02650000 C SECONDARY WORK FILE TO SAVE A CLEAN COPY OF INPUT TRACE. 02660000 APT1 = APWVAL + NOSAMP 02670000 APT2 = APT1 + FFTLEN + 2 02680000 APSIZE = APT2 + FFTLEN + 2 02690000 C ********* 02700000 APSIZE = APSIZE + LCIT + 1 02710000 C 02720000 IC = KPIUSM + 1 02730000 IF ( IC+APSIZE.GT.KPIUSM+KPNUSM ) GO TO 9000 02740000 C 02750000 C POSSIBLE VECTORIZATION-INHIBITING EQUIVALENCES: 02760000 C 02770000 C APRTEM = APINTR APRTM2 = APWVAL APTEM3 = APLVDD 02780000 C APTEM3 APWAVG 02790000 C APWAVG 02800000 C APWVAL 02810000 C 02820000 IF (KPBUGF.EQ.3) WRITE(KPPRNT,5100) 02830000 *TYPSC , 02840000 *PMODSV , 02850000 *MLTSPC , 02860000 *APINDX , 02870000 *APCESW , 02880000 *APCMDW , 02890000 *APCMUL , 02900000 *APCMDF , 02910000 *NOSAMP , 02920000 *APMOVE , 02930000 *MXWIND 02940000 5100 FORMAT (' TYPSC, ETC. ',1X,A4,1X,A4,9I8 ) 02950000 C 02960000 5500 CONTINUE 02970000 C 02980000 C ======================================================================02990000 C CALL VPSS (APUNIT,'BLD ', 7, COM(CCW), LCCW, COM(CIT), LCIT) 03000000 C******* THE ABOVE VPSS STATEMENT WAS NOT PROCESSED 03010000 C ======================================================================03020000 C 03030000 C STEP 1 MOVE DATA TO ARRAY PROCESSOR 03040000 C 03050000 C CALL VPSS (APUNIT,'VPUT', COM(APINDX), APMOVE, 1, 0) 03060000 NXARRV = 1 + 0 03070000 CALL ARMVE (COM(APINDX), BULK(NXARRV), APMOVE) 03080000 C CALL VPSS (APUNIT,'VPUT', INTR, NOSAMP, APINTR, 0) 03090000 NXARRV = APINTR + 0 03100000 CALL ARMVE (INTR , BULK(NXARRV), NOSAMP) 03110000 APINPT = APINTR 03120000 C ======================================================================03130000 C 03140000 C STEP 1-A IF INSTANTANEOUS AMPLITUDE FLAG IS ON, 03150000 C COMPUTE THE INSTANTANEOUS AMPLITUDE TRACE 03160000 C TO BE USED FOR DETERMINING THE SCALERS. 03170000 C 03180000 IF (S1CPCH(ISTAMP,1,'OFF ',1,4) .EQ. 0) GO TO 5520 03190000 FFTLN2 = FFTLEN + 2 03200000 C 03210000 C ***** ZERO OUT BUFFERS ***** 03220000 CALL ARSET (BULK(APT1),FFTLN2,0) 03230000 CALL ARSET (BULK(APT2),FFTLN2,0) 03240000 C 03250000 C ***** MOVE TRACE ARRAY TO WORK ARRAY 1 & FFT IT TO FREQ DOMAIN **** 03260000 CALL ARMVE (INTR, BULK(APT1), NOSAMP) 03270000 CALL S2DFT2 (MAG,BULK(APT1), *9010) 03280000 C 03290000 C ***** INTERCHANGE REAL & IMAGINARY PARTS & REVERSE SIGN OF REAL**** 03300000 DO 5510 I=1,FFTLEN,2 03310000 BULK(APT2 + I - 1) = -(ZBULK(APT1+I)) 03320000 BULK(APT2 + I) = ZBULK(APT1 + I - 1) 03330000 5510 CONTINUE 03340000 C 03350000 C ***** SET ZERO FREQ. & NYQUIST FREQ. COMPONENTS TO 0.0 ***** 03360000 BULK(APT2) = 0.0 03370000 BULK(APT2+1) = 0.0 03380000 BULK(APT2+FFTLEN) = 0.0 03390000 BULK(APT2+FFTLEN+1) = 0.0 03400000 C 03410000 C ***** INVERSE FFT TO OBTAIN THE HILBERT TRANSFORM ***** 03420000 CALL S2DFI2 (MAG,BULK(APT2), *9020) 03430000 C 03440000 C **** REAPPLY MUTE BY SETTING VALUES TO 0 IF THEY WERE 0 IN THE * 03450000 C **** ORIGINAL TRACE. THEN COMPUTE THE INSTANTANEOUS AMPLITUDE TRACE.* 03460000 C 03470000 DO 5515 I=1,NOSAMP 03480000 IF (INTR(I) .EQ. 0.0) ZBULK(APT2+I-1) = 0.0 03490000 BULK(APT1+I-1) = SQRT (INTR(I)**2 + ZBULK(APT2+I-1)**2) 03500000 5515 CONTINUE 03510000 C 03520000 C *** MOVE INSTANTANEOUS AMPLITUDE INTO AGCS STREAM & CONTINUE NORMALLY*03530000 APINPT = APT1 03540000 C ======================================================================03550000 5520 CONTINUE 03560000 C 03570000 C *** IF PARTIAL/AGC OPTION IS ON THEN SAVE A COPY OF THE INPUT TRACE 03580000 C *** IN WORK ARRAY 2 FOR LATTER USE IN PARTIAL/AGC CALCULATIONS. 03590000 C "NOT NEEDED ON CRAY VERSION" 03600000 CRAY IF (PRCAGC .EQ. 1.0) GO TO 5525 03610000 CRAY CALL VPSS (APUNIT, VMV, ISTATE, 03620000 CRAY Y 0, APT2, NOSAMP, 1, 03630000 CRAY X 0, APINTR, 1) 03640000 C 03650000 CRAY5 CONTINUE 03660000 C ======================================================================03670000 C 03680000 C STEP 2 INITIALIZE REGISTERS AND BULK STORAGE 03690000 C 03700000 C REGISTER USAGE 03710000 C R1 - FLV (INDEX OF FIRST LIVE VALUE) 03720000 C R2 - LLV (INDEX OF LAST LIVE VALUE) 03730000 C R3 - NLV (NUMBER OF LIVE VALUES) 03740000 C R4 - TEMP0 (ALSO AS NUMBER OF WINDOWS -- MIN OF 03750000 C 5 -- FOR SLIDING WINDOW CVM) 03760000 C R5 - FLV+FIRSWL-1 03770000 C R6 - TEMP1 03780000 C R7 - POSITION OF FIRST WINDOW 03790000 C FOR SLIDING WINDOWS = FLV+WL/2 03800000 C R8 - NW (NUMBER OF WINDOWS) 03810000 C R9 - LIVCK (MIN NUMBER OF LIVE AMPS) 03820000 C R10 - AMOUNT TO COPY ON FRONT END 03830000 C FOR SLIDING WINDOWS = WL/2+FLV 03840000 C R11 - POSITION OF LAST WINDOW 03850000 C FOR SLIDING WINDOWS = WL/2+NW+FLV-1 03860000 C R12 - TEMP2 (ALSO AS LENGTH OF TRACE FOR SLIDING 03870000 C WINDOW CVM WITH R4) 03880000 C R13 - FIRSWL (FIRST WINDOW LENGTH) 03890000 C R14 - TEMP3 03900000 C R15 - AMOUNT TO COPY ON BACK END 03910000 C FOR SLIDING WINDOWS = WL/2 03920000 C 03930000 C ======================================================================03940000 C CALL VPSS (APUNIT, 'XWR ', COM(APINDX), 15, R1) 03950000 CALL ARMVE (COM(APINDX), R(1) , 15) 03960002 C 03970000 IF (KPBUGF.EQ.3) WRITE(KPPRNT,5120) R 03980000 5120 FORMAT ( ' R:', 15I6 ) 03990000 C 04000000 C ======================================================================04010000 C 04020000 C STEP 3 DETERMINE WHERE THE LIVE AMPLITUDES ARE 04030000 C 04040000 C CALL VPSS (APUNIT, 'LIM ', ISTATE, 04050000 C Y 96, APLVDD, 0, 1, R1, R3, 04060000 C X 36, APINTR, 1, R1, 04070000 C U 0, APLIMU) 04080000 C 04090000 NYARRV = APLVDD + R1 04100000 NICTY = 0 + R3 04110000 NIDLY = 1 04120000 NXARRV = APINPT + R1 04130000 NIDLX = 1 04140000 NUARRV = APLIMU 04150000 JUVPSS = 1 04160000 JYVPSS = 1 04170000 JXVPSS = 1 04180000 UVPSS1 = BULK(JUVPSS - 1 + NUARRV) 04190000 UVPSS2 = BULK(JUVPSS - 0 + NUARRV) 04200000 UVPSS3 = BULK(JUVPSS + 1 + NUARRV) 04210000 UVPSS4 = BULK(JUVPSS + 2 + NUARRV) 04220000 C 04230000 CDIR$ IVDEP 04240000 DO 7510 IVPSS = 1, NICTY 04250000 CESN XVPSS = BULK(JXVPSS - 1 + NXARRV) 04260000 CESN BULK(JYVPSS - 1 + NYARRV) = 04270000 CESN & CVMGT(UVPSS2, 0.0 , 04280000 CESN & ABS( XVPSS ).GT. UVPSS1 ) 04290000 C BULK(JYVPSS - 1 + NYARRV) = 04300000 C & CVMGT(UVPSS4, XVPSS , 04310000 C & ABS( XVPSS ).LE. UVPSS3 ) 04320000 CESN JYVPSS = JYVPSS + NIDLY 04330000 CESN JXVPSS = JXVPSS + NIDLX 04340000 BULK(IVPSS - 1 + NYARRV) = ZBULK(IVPSS - 1 + NXARRV) 04350000 IF (ABS(ZBULK(IVPSS-1+NXARRV)) .GT. UVPSS1) 04360000 * BULK(IVPSS-1+NYARRV) = UVPSS2 04370000 7510 CONTINUE 04380000 C 04390000 C IF (KPBUGF.EQ.3) CALL DUMP(7510,BULK(NYARRV),NICTY,KPPRNT) 04400000 C 04410000 C ======================================================================04420000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 04430000 C Y 0, APRECU, NOSAMP, 1, 04440000 C X 0, APONE) 04450000 NYARRV = APRECU 04460000 NICTY = NOSAMP 04470000 NIDLY = 1 04480000 NXARRV = APONE 04490000 JYVPSS = 1 04500000 XVPSS = BULK(NXARRV) 04510000 C 04520000 DO 7520 IVPSS = 1, NICTY 04530000 BULK(IVPSS - 1 + NYARRV) = XVPSS 04540000 7520 CONTINUE 04550000 C 04560000 C IF (KPBUGF.EQ.3) CALL DUMP(7520,BULK(NYARRV),NICTY,KPPRNT) 04570000 C ======================================================================04580000 C 04590000 C CALL VPSS (APUNIT, 'ZMV ', ISTATE, 04600000 C Y 64, APLVCT-1, 2, 1, R1) 04610000 C 04620000 NYARRV = APLVCT-1 04630000 NICTY = 2 + R1 04640000 NIDLY = 1 04650000 JYVPSS = 1 04660000 C 04670000 DO 7530 IVPSS = 1, NICTY 04680000 BULK(IVPSS - 1 + NYARRV) = 0.0 04690000 7530 CONTINUE 04700000 C 04710000 C IF (KPBUGF.EQ.3) CALL DUMP(7530,BULK(NYARRV),NICTY,KPPRNT) 04720000 C 04730000 C ======================================================================04740000 C CALL VPSS (APUNIT, 'REC ', ISTATE, 04750000 C Y 96, APLVCT, 0, 1, R1, R3, 04760000 C X 32, APLVDD, 1, R1, 04770000 C U 32, APRECU, 1, R1) 04780000 NYARRV = APLVCT + R1 04790000 NICTY = 0 + R3 04800000 NIDLY = 1 04810000 NXARRV = APLVDD + R1 04820000 NIDLX = 1 04830000 NUARRV = APRECU + R1 04840000 NIDLU = 1 04850000 JUVPSS = 1 04860000 JYVPSS = 1 04870000 JXVPSS = 1 04880000 C 04890000 BULK(JYVPSS - 1 + NYARRV) = 04900000 &BULK(JYVPSS - 1 + NYARRV) + 04910000 &BULK(JUVPSS - 1 + NUARRV) * 04920000 &BULK(JXVPSS - 1 + NXARRV) 04930000 JYVPSS = JYVPSS + NIDLY 04940000 JXVPSS = JXVPSS + NIDLX 04950000 JUVPSS = JUVPSS + NIDLU 04960000 C 04970000 CDIR$ NOVECTOR 04980000 DO 7540 IVPSS = 2, NICTY 04990000 BULK(IVPSS - 1 + NYARRV) = 05000000 & BULK(IVPSS - 1 + NUARRV) * BULK(IVPSS-2 + NYARRV) + 05010000 & BULK( 0 + NUARRV) * BULK(IVPSS-1 + NXARRV) 05020000 7540 CONTINUE 05030000 C 05040000 CDIR$ VECTOR 05050000 C IF (KPBUGF.EQ.3) CALL DUMP(7540,BULK(NYARRV),NICTY,KPPRNT) 05060000 C 05070000 C ======================================================================05080000 C STEP 4 IF RMS, APPLY LINEAR SCALE FACTOR 05090000 C 05100000 IF (TYPSC .NE. ARMS) GO TO 7650 05110000 C 05120000 C ======================================================================05130000 C CALL VPSS (APUNIT, 'XMVS', APLVCT, 1, R2, R6) 05140000 NYARRV = APLVCT + R2 05150000 CRAY NICTY = 1 05160000 CRAY CALL SCOPY (NICTY, BULK(NYARRV), 1, R6 , 1) 05170000 XR6 = BULK(NYARRV) 05180000 C ======================================================================05190000 C 05200000 C CALL VPSS (APUNIT, 'XCF ', R6, R9, 'NOSC', 'LE ') 05210000 IF(XR6 .LE. XR9 ) GO TO 7640 05220000 C 05230000 C ======================================================================05240000 C CALL VPSS (APUNIT, 'SVE ', ISTATE, 05250000 C Y 0, APRSUM, 05260000 C X 100, APINTR, 0, 1, R1, R3) 05270000 NYARRV = APRSUM 05280000 NXARRV = APINPT + R1 05290000 NICTX = 0 + R3 05300000 NIDLX = 1 05310000 JYVPSS = 1 05320000 JXVPSS = 1 05330000 XVPSS = 0.0 05340000 C 05350000 DO 7600 IVPSS = 1, NICTX 05360000 XVPSS = XVPSS + 05370000 & ABS(BULK(IVPSS - 1 + NXARRV)) 05380000 7600 CONTINUE 05390000 BULK(NYARRV) = XVPSS 05400000 C 05410000 C IF (KPBUGF.EQ.3) CALL DUMP(7600,BULK(NYARRV),1 ,KPPRNT) 05420000 C 05430000 C ======================================================================05440000 C CALL VPSS (APUNIT, 'SMY ', ISTATE, 05450000 C Y 0, APRTM1, 1, 1, 05460000 C X 32, APLVCT, 1, R2, 05470000 C U 0, APRMSO) 05480000 NYARRV = APRTM1 05490000 CRAY NICTY = 1 05500000 CRAY NIDLY = 1 05510000 NXARRV = APLVCT + R2 05520000 CRAY NIDLX = 1 05530000 NUARRV = APRMSO 05540000 JYVPSS = 1 05550000 JXVPSS = 1 05560000 JUVPSS = 1 05570000 UVPSS = BULK(JUVPSS - 1 + NUARRV) 05580000 C 05590000 CRAY DO 7610 IVPSS = 1, NICTY 05600000 BULK(JYVPSS - 1 + NYARRV) = UVPSS * 05610000 & BULK(JXVPSS - 1 + NXARRV) 05620000 CRAY JYVPSS = JYVPSS + NIDLY 05630000 CRAY JXVPSS = JXVPSS + NIDLX 05640000 7610 CONTINUE 05650000 C 05660000 C IF (KPBUGF.EQ.3) CALL DUMP(7610,BULK(NYARRV),NICTY,KPPRNT) 05670000 C 05680000 C ======================================================================05690000 C CALL VPSS (APUNIT, 'DIV ', ISTATE, 05700000 C Y 0, APRSUM, 1, 1, 05710000 C X 0, APRSUM, 1, 05720000 C U 0, APRTM1, 1) 05730000 NYARRV = APRSUM 05740000 CRAY NICTY = 1 05750000 CRAY NIDLY = 1 05760000 NXARRV = APRSUM 05770000 CRAY NIDLX = 1 05780000 NUARRV = APRTM1 05790000 CRAY NIDLU = 1 05800000 JYVPSS = 1 05810000 JXVPSS = 1 05820000 JUVPSS = 1 05830000 C 05840000 CRAY DO 7620 IVPSS = 1, NICTY 05850000 BULK(JYVPSS - 1 + NYARRV) = 05860000 & BULK(JUVPSS - 1 + NUARRV) 05870000 & /BULK(JXVPSS - 1 + NXARRV) 05880000 CRAY JYVPSS = JYVPSS + NIDLY 05890000 CRAY JXVPSS = JXVPSS + NIDLX 05900000 CRAY JUVPSS = JUVPSS + NIDLU 05910000 7620 CONTINUE 05920000 C 05930000 C IF (KPBUGF.EQ.3) CALL DUMP(7620,BULK(NYARRV),NICTY,KPPRNT) 05940000 C 05950000 C ======================================================================05960000 C CALL VPSS (APUNIT, 'SMY ', ISTATE, 05970000 C Y 96, APINTR, 0, 1, R1, R3, 05980000 C X 32, APINTR, 1, R1, 05990000 C U 0, APRSUM) 06000000 NYARRV = APINPT + R1 06010000 NICTY = 0 + R3 06020000 NIDLY = 1 06030000 NXARRV = APINPT + R1 06040000 NIDLX = 1 06050000 NUARRV = APRSUM 06060000 JYVPSS = 1 06070000 JXVPSS = 1 06080000 JUVPSS = 1 06090000 UVPSS = BULK(JUVPSS - 1 + NUARRV) 06100000 CDIR$ IVDEP 06110000 DO 7630 IVPSS = 1, NICTY 06120000 BULK(IVPSS - 1 + NYARRV) = UVPSS * 06130000 & ZBULK(IVPSS - 1 + NXARRV) 06140000 7630 CONTINUE 06150000 C ======================================================================06160000 C STEP 4-A 06170000 C CHECK FOR INSTANTANEOUS AMPLITUDE OPTION. IF 'ON', THEN WE 06180000 C HAVE COMPUTED A LINEAR SCALER FROM THE INSTANTANEOUS AMPLITUDE 06190000 C TRACE AND APPLIED IT TO THE INSTANTANEOUS AMP TRACE. TO BE 06200000 C CONSISTENT, WE MUST ALSO APPLY THAT LINEAR SCALER TO THE ORIGINAL06210000 C INPUT TRACE. NOTE: APINTR IS ALWAYS INDEX TO ORGINAL I/P TRACE. 06220000 C APINPT IS INDEX TO EITHER ORGINAL OR 06230000 C INSTANTANEOUS AMP TRACE. 06240000 C 06250000 IF (S1CPCH(ISTAMP,1,'ON ',1,4) .NE. 0) GO TO 7632 06260000 NYARRV = APINTR + R1 06270000 NICTY = 0 + R3 06280000 NIDLY = 1 06290000 NXARRV = APINTR + R1 06300000 NIDLX = 1 06310000 NUARRV = APRSUM 06320000 JYVPSS = 1 06330000 JXVPSS = 1 06340000 JUVPSS = 1 06350000 UVPSS = BULK(JUVPSS - 1 + NUARRV) 06360000 CDIR$ IVDEP 06370000 DO 7631 IVPSS = 1, NICTY 06380000 BULK(IVPSS - 1 + NYARRV) = UVPSS * 06390000 & ZBULK(IVPSS - 1 + NXARRV) 06400000 7631 CONTINUE 06410000 7632 CONTINUE 06420000 C ======================================================================06430000 C 06440000 C IF (KPBUGF.EQ.3) CALL DUMP(7630,BULK(NYARRV),NICTY,KPPRNT) 06450000 C 06460000 C ======================================================================06470000 C CALL VPSS (APUNIT, 'XID ', 'NOSC') 06480000 7640 CONTINUE 06490000 C ======================================================================06500000 C 06510000 7650 CONTINUE 06520000 C 06530000 C ======================================================================06540000 C STEP 5 SET UP INPUT 06550000 C IF 'ABS', THEN ABSOLUTE VALUE OF INPUT 06560000 C IF 'RMS', THEN INPUT SQUARED 06570000 C 06580000 IF (TYPSC .NE. AABS) GO TO 7660 06590000 APRTEM = APINPT 06600000 7660 CONTINUE 06610000 C 06620000 IF (TYPSC .NE. ARMS) GO TO 7690 06630000 C ======================================================================06640000 C CALL VPSS (APUNIT, 'ZMV ', ISTATE, 06650000 C Y 0, APTEM3, NOSAMP, 1) 06660000 NYARRV = APTEM3 06670000 NICTY = NOSAMP 06680000 NIDLY = 1 06690000 JYVPSS = 1 06700000 C 06710000 DO 7670 IVPSS = 1, NICTY 06720000 BULK(IVPSS - 1 + NYARRV) = 0.0 06730000 7670 CONTINUE 06740000 C 06750000 C IF (KPBUGF.EQ.3) CALL DUMP(7670,BULK(NYARRV),NICTY,KPPRNT) 06760000 C 06770000 C ======================================================================06780000 C CALL VPSS (APUNIT, 'SSA ', ISTATE, 06790000 C Y 96, APTEM3, 0, 1, R1, R3, 06800000 C X 36, APINTR, 1, R1) 06810000 NYARRV = APTEM3 + R1 06820000 NICTY = 0 + R3 06830000 NIDLY = 1 06840000 NXARRV = APINPT + R1 06850000 NIDLX = 1 06860000 JYVPSS = 1 06870000 JXVPSS = 1 06880000 CDIR$ IVDEP 06890000 DO 7680 IVPSS = 1, NICTY 06900000 CRAY XVPSS = ABS(BULK(JXVPSS - 1 + NXARRV)) 06910000 CRAY YVPSS = XVPSS * XVPSS 06920000 CRAY BULK(JYVPSS - 1 + NYARRV) = 06930000 CRAY & CVMGP(YVPSS, -YVPSS, XVPSS) 06940000 BULK(IVPSS - 1 + NYARRV) = 06950000 & ZBULK(IVPSS - 1 + NXARRV) * ZBULK(IVPSS - 1 + NXARRV) 06960000 7680 CONTINUE 06970000 C 06980000 C IF (KPBUGF.EQ.3) CALL DUMP(7680,BULK(NYARRV),NICTY,KPPRNT) 06990000 C ======================================================================07000000 APRTEM = APTEM3 07010000 7690 CONTINUE 07020000 C 07030000 C STEP 6 IF WINDOW MULTIPLIER OR SPECIFIC WINDOWS 07040000 C SUPPLIED -- SUM AMPLITUDES AND LIVE COUNT 07050000 C WITHIN EACH WINDOW 07060000 C 07070000 IF (MLTSPC .NE. 1) GO TO 7730 07080000 C ======================================================================07090000 C CALL VPSS (APUNIT, 'XMVI', R12, 0) 07100000 R12 = 0 07110000 C 07120000 C ======================================================================07130000 C CALL VPSS (APUNIT, 'XMV ', R9, R7) 07140000 R9 = R7 07150000 C 07160000 C ======================================================================07170000 C CALL VPSS (APUNIT, 'XMV ', R4, R8) 07180000 R4 = R8 07190000 C 07200000 C ======================================================================07210000 C CALL VPSS (APUNIT, 'XAD ', R4, R8) 07220000 R4 = R4 + R8 07230000 C ======================================================================07240000 C 07250000 C CALL VPSS (APUNIT, 'XID ', 'LOP1') 07260000 7700 CONTINUE 07270000 C 07280000 C ======================================================================07290000 C CALL VPSS (APUNIT, 'XMVS', APESWI, 2, R12, R5) 07300000 NYARRV = APESWI + R12 07310000 NICTY = 2 07320000 CALL ARMVE (BULK(NYARRV), R(5) , NICTY) 07330002 C 07340000 C ======================================================================07350000 C CALL VPSS (APUNIT, 'XMV ', R14, R5) 07360000 R14 = R5 07370000 C 07380000 C ======================================================================07390000 C CALL VPSS (APUNIT, 'XSB ', R14, R6) 07400000 R14 = R14 - R6 07410000 C 07420000 C ======================================================================07430000 C CALL VPSS (APUNIT, 'SVE ', ISTATE, 07440000 C Y 32, APADIF, R9, 07450000 C X 100, APRTEM, 1, 1, R6, R14) 07460000 NYARRV = APADIF + R9 07470000 NXARRV = APRTEM + R6 07480000 NICTX = 1 + R14 07490000 NIDLX = 1 07500000 JYVPSS = 1 07510000 JXVPSS = 1 07520000 XVPSS = 0.0 07530000 C 07540000 DO 7710 IVPSS = 1, NICTX 07550000 XVPSS = XVPSS + 07560000 & ABS(BULK(IVPSS - 1 + NXARRV)) 07570000 7710 CONTINUE 07580000 BULK(NYARRV) = XVPSS 07590000 C 07600000 C IF (KPBUGF.EQ.3) CALL DUMP(7710,BULK(NYARRV),1 ,KPPRNT) 07610000 C 07620000 C ======================================================================07630000 C CALL VPSS (APUNIT, 'VES ', ISTATE, 07640000 C Y 32, APCDIF, 1, 1, R9, 07650000 C X 32, APLVCT, 1, R5, 07660000 C U 40, APLVCT-1, 1, R6) 07670000 NYARRV = APCDIF + R9 07680000 NICTY = 1 07690000 NIDLY = 1 07700000 NXARRV = APLVCT + R5 07710000 NIDLX = 1 07720000 NUARRV = APLVCT-1 + R6 07730000 NIDLU = 1 07740000 JYVPSS = 1 07750000 JXVPSS = 1 07760000 JUVPSS = 1 07770000 CDIR$ IVDEP 07780000 C DO 7720 IVPSS = 1, NICTY 07790000 BULK(JYVPSS-1+NYARRV) = 07800000 & ZBULK(JXVPSS - 1 + NXARRV) 07810000 & + (-ZBULK(JUVPSS - 1 + NUARRV) ) 07820000 C JYVPSS = JYVPSS + NIDLY 07830000 C JXVPSS = JXVPSS + NIDLX 07840000 C JUVPSS = JUVPSS + NIDLU 07850000 C7720 CONTINUE 07860000 C 07870000 C IF (KPBUGF.EQ.3) CALL DUMP(7720,BULK(NYARRV),NICTY,KPPRNT) 07880000 C 07890000 C ======================================================================07900000 C CALL VPSS (APUNIT, 'XADI', R12, 2) 07910000 R12 = R12 + 2 07920000 C 07930000 C ======================================================================07940000 C CALL VPSS (APUNIT, 'XADI', R9, 1) 07950000 R9 = R9 + 1 07960000 C 07970000 C ======================================================================07980000 C CALL VPSS (APUNIT, 'XC ', R12, R4, 'LOP1', 'LT ') 07990000 IF(R12 .LT. R4 ) GO TO 7700 08000000 C ======================================================================08010000 GO TO 7830 08020000 7730 CONTINUE 08030000 C 08040000 C STEP 7 IF SLIDING WINDOWS SUPPLIED -- SUM 08050000 C AMLITUDES AND LIVE COUNT WITHIN EACH 08060000 C WINDOW 08070000 C 08080000 CC CALL VPSS (APUNIT, 'SVE ', ISTATE, 08090000 CC Y 32, APRSUM, R7, 08100000 CC X 100, APRTEM, 0, 1, R1, R13) 08110000 CC TEST FOR ONE WINDOW 08120000 CC CALL VPSS (APUNIT, 'XCI ', R8, 1, 'WIN1', 'LE ') 08130000 CC 08140000 CC CALL VPSS (APUNIT, 'VES ', ISTATE, 08150000 CC Y 96, APRSUM+1,-1,1,R7, R8, 08160000 CC X 36, APRTEM+1, 1, R5, 08170000 CC U 48, APRTEM , 1, R1) 08180000 CC 08190000 CC CALL VPSS (APUNIT, 'XID ', 'WIN1') 08200000 CC 08210000 CC CALL VPSS (APUNIT, 'ZMV ', ISTATE, 08220000 CC Y 32, APADIF, 1, 1, R7) 08230000 CC 08240000 CC CALL VPSS (APUNIT, 'REC ', ISTATE, 08250000 CC Y 96, APADIF, 0, 1, R7, R8, 08260000 CC X 32, APRSUM, 1, R7, 08270000 CC U 32, APRECU, 1, R7) 08280000 C ======================================================================08290000 C 08300000 C CALL VPSS (APUNIT, 'CVM ', ISTATE, 08310000 C Y 96, APADIF, 0, 1, R7, R4, 08320000 C X 100, APRTEM, 0, 1, R1, R12, 08330000 C U 64, APRECU, 0, 1, R13) 08340000 NYARRV = APADIF + R7 08350000 NICTY = 0 + R4 08360000 NIDLY = 1 08370000 NXARRV = APRTEM + R1 08380000 NICTX = 0 + R12 08390000 NIDLX = 1 08400000 NUARRV = APRECU 08410000 NICTU = 0 + R13 08420000 NIDLU = 1 08430000 CRAY CALL CONVOL (BULK(NUARRV), NICTU, BULK(NXARRV), NICTX, 08440000 CRAY BULK(NYARRV), NIDLU, NIDLX, NIDLY, 08450000 C NICTX MUST EQUAL NICTY + NICTU - 1 08460000 C 08470000 CESN DO 7750 IYPSS = 1, NICTY 08480000 CESN YVPSS = 0.0 08490000 CESN DO 7740 IUPSS = 1, NICTU 08500000 CESN YVPSS = 08510000 CESN & YVPSS + 08520000 CESN & BULK( IUPSS - 1 + NUARRV)* ABS(BULK( IUPSS + IYPSS - 2 + NXARRV))08530000 C7740 CONTINUE 08540000 CESN BULK(IYPSS-1+NYARRV) = YVPSS 08550000 C7750 CONTINUE 08560000 YVPSS8 = 0.0 08570000 DO 8740 IUPSS = 1, NICTU 08580000 YVPSS8 = YVPSS8 + ABS(BULK(IUPSS-1+NXARRV)) 08590000 8740 CONTINUE 08600000 BULK(NYARRV) = YVPSS8 08610000 IF (NICTY .LT. 2) GO TO 8760 08620000 DO 8750 IYPSS = 2, NICTY 08630000 YVPSS8 = YVPSS8 - ABS(BULK(IYPSS-2+NXARRV)) + 08640000 * ABS(BULK(IYPSS-2+NXARRV+NICTU)) 08650000 BULK(IYPSS-1+NYARRV) = YVPSS8 08660000 8750 CONTINUE 08670000 8760 CONTINUE 08680000 C 08690000 C IF (KPBUGF.EQ.3) CALL DUMP(7750,BULK(NYARRV),NICTY,KPPRNT) 08700000 C 08710000 C ======================================================================08720000 C CALL VPSS (APUNIT, 'XCI ', R14, 341, 'CVM1', 'LE ') 08730000 IF(R14 .LE. 341 ) GO TO 7810 08740000 C 08750000 C ======================================================================08760000 C CALL VPSS (APUNIT, 'XID ', 'CVMN') 08770000 7760 CONTINUE 08780000 C 08790000 C ======================================================================08800000 C CALL VPSS (APUNIT, 'XADI', R14, -341) 08810000 R14 = R14 + (-341) 08820000 C 08830000 C ======================================================================08840000 C CALL VPSS (APUNIT, 'XADI', R1, 341) 08850000 R1 = R1 + 341 08860000 C 08870000 C ======================================================================08880000 C CALL VPSS (APUNIT, 'XC ', R13, R14, 'CVMI', 'LE ') 08890000 IF(R13 .LE. R14 ) GO TO 7770 08900000 C 08910000 C ======================================================================08920000 C CALL VPSS (APUNIT, 'XMV ', R13, R14) 08930000 R13 = R14 08940000 C 08950000 C ======================================================================08960000 C CALL VPSS (APUNIT, 'XMV ', R12, R13) 08970000 R12 = R13 08980000 C 08990000 C ======================================================================09000000 C CALL VPSS (APUNIT, 'XAD ', R12, R4) 09010000 R12 = R12 + R4 09020000 C 09030000 C ======================================================================09040000 C CALL VPSS (APUNIT, 'XADI', R12, -1) 09050000 R12 = R12 + (-1) 09060000 C 09070000 C ======================================================================09080000 C CALL VPSS (APUNIT, 'XID ', 'CVMI') 09090000 7770 CONTINUE 09100000 C 09110000 C ======================================================================09120000 C CALL VPSS (APUNIT, 'CVM ', ISTATE, 09130000 C Y 96, APWAVG, 0, 1, R7, R4, 09140000 C X 100, APRTEM, 0, 1, R1, R12, 09150000 C U 64, APRECU, 0, 1, R13) 09160000 NYARRV = APWAVG + R7 09170000 NICTY = 0 + R4 09180000 NIDLY = 1 09190000 NXARRV = APRTEM + R1 09200000 NICTX = 0 + R12 09210000 NIDLX = 1 09220000 NUARRV = APRECU 09230000 NICTU = 0 + R13 09240000 NIDLU = 1 09250000 CRAY CALL CONVOL (BULK(NUARRV), NICTU, BULK(NXARRV), NICTX, 09260000 CRAY BULK(NYARRV), NIDLU, NIDLX, NIDLY, 09270000 C 09280000 C NICTX MUST EQUAL NICTY + NICTU - 1 09290000 CDIR$ IVDEP 09300000 C 09310000 CESN DO 7790 IYPSS = 1, NICTY 09320000 CESN YVPSS = 0.0 09330000 CESN DO 7780 IUPSS = 1, NICTU 09340000 CESN YVPSS = 09350000 CESN & YVPSS + 09360000 CESN & BULK( IUPSS - 1 + NUARRV)*ABS(BULK( IUPSS + IYPSS - 2 + NXARRV)) 09370000 C7780 CONTINUE 09380000 CESN BULK(IYPSS-1+NYARRV) = YVPSS 09390000 C7790 CONTINUE 09400000 YVPSS8 = 0.0 09410000 DO 8780 IUPSS = 1, NICTU 09420000 YVPSS8 = YVPSS8 + ABS(BULK(IUPSS-1+NXARRV)) 09430000 8780 CONTINUE 09440000 BULK(NYARRV) = YVPSS8 09450000 IF (NICTY .LT. 2) GO TO 8795 09460000 DO 8790 IYPSS = 2, NICTY 09470000 YVPSS8 = YVPSS8 - ABS(BULK(IYPSS-2+NXARRV)) + 09480000 * ABS(BULK(IYPSS-2+NXARRV+NICTU)) 09490000 BULK(IYPSS-1+NYARRV) = YVPSS8 09500000 8790 CONTINUE 09510000 8795 CONTINUE 09520000 C 09530000 C IF (KPBUGF.EQ.3) CALL DUMP(7790,BULK(NYARRV),NICTY,KPPRNT) 09540000 C 09550000 C ======================================================================09560000 C CALL VPSS (APUNIT, 'VES ', ISTATE, 09570000 C Y 96, APADIF, 0, 1, R7, R4, 09580000 C X 32, APADIF, 1, R7, 09590000 C U 32, APWAVG, 1, R7) 09600000 NYARRV = APADIF + R7 09610000 NICTY = 0 + R4 09620000 NIDLY = 1 09630000 NXARRV = APADIF + R7 09640000 NIDLX = 1 09650000 NUARRV = APWAVG + R7 09660000 NIDLU = 1 09670000 JYVPSS = 1 09680000 JXVPSS = 1 09690000 JUVPSS = 1 09700000 C 09710000 CDIR$ IVDEP 09720000 DO 7800 IVPSS = 1, NICTY 09730000 BULK(IVPSS-1+NYARRV) = 09740000 & ZBULK(IVPSS - 1 + NXARRV) 09750000 & +ZBULK(IVPSS - 1 + NUARRV) 09760000 7800 CONTINUE 09770000 C 09780000 C IF (KPBUGF.EQ.3) CALL DUMP(7800,BULK(NYARRV),NICTY,KPPRNT) 09790000 C 09800000 C ======================================================================09810000 C CALL VPSS (APUNIT, 'XCI ', R14, 341, 'CVMN', 'GT ') 09820000 IF(R14 .GT. 341 ) GO TO 7760 09830000 C 09840000 C ======================================================================09850000 C CALL VPSS (APUNIT, 'XMV ', R1, R2) 09860000 R1 = R2 09870000 C 09880000 C ======================================================================09890000 C CALL VPSS (APUNIT, 'XSB ', R1, R3) 09900000 R1 = R1 - R3 09910000 C 09920000 C ======================================================================09930000 C CALL VPSS (APUNIT, 'XADI', R1, 1) 09940000 R1 = R1 + 1 09950000 C 09960000 C ======================================================================09970000 C CALL VPSS (APUNIT, 'XID ', 'CVM1') 09980000 7810 CONTINUE 09990000 C 10000000 C ======================================================================10010000 C CALL VPSS (APUNIT, 'VES ', ISTATE, 10020000 C Y 96, APCDIF, 0, 1, R7, R8, 10030000 C X 32, APLVCT, 1, R5, 10040000 C U 40, APLVCT-1, 1, R1) 10050000 NYARRV = APCDIF + R7 10060000 NICTY = 0 + R8 10070000 NIDLY = 1 10080000 NXARRV = APLVCT + R5 10090000 NIDLX = 1 10100000 NUARRV = APLVCT-1 + R1 10110000 NIDLU = 1 10120000 JYVPSS = 1 10130000 JXVPSS = 1 10140000 JUVPSS = 1 10150000 C 10160000 CDIR$ IVDEP 10170000 DO 7820 IVPSS = 1, NICTY 10180000 BULK(IVPSS-1+NYARRV) = 10190000 & ZBULK(IVPSS - 1 + NXARRV) 10200000 & - ZBULK(IVPSS - 1 + NUARRV) 10210000 7820 CONTINUE 10220000 C 10230000 C IF (KPBUGF.EQ.3) CALL DUMP(7820,BULK(NYARRV),NICTY,KPPRNT) 10240000 C 10250000 C ======================================================================10260000 C STEP 8 AVERAGE VALUES WITHIN EACH WINDOW 10270000 C 10280000 7830 CONTINUE 10290000 C ======================================================================10300000 C CALL VPSS (APUNIT, 'LIM ', ISTATE, 10310000 C Y 96, APCDIF, 0, 1, R7, R8, 10320000 C X 32, APCDIF, 1, R7, 10330000 C U 0, APLMU1) 10340000 NYARRV = APCDIF + R7 10350000 NICTY = 0 + R8 10360000 NIDLY = 1 10370000 NXARRV = APCDIF + R7 10380000 NIDLX = 1 10390000 NUARRV = APLMU1 10400000 JUVPSS = 1 10410000 JYVPSS = 1 10420000 JXVPSS = 1 10430000 UVPSS1 = BULK(JUVPSS - 1 + NUARRV) 10440000 UVPSS2 = BULK(JUVPSS - 0 + NUARRV) 10450000 UVPSS3 = BULK(JUVPSS + 1 + NUARRV) 10460000 UVPSS4 = BULK(JUVPSS + 2 + NUARRV) 10470000 C 10480000 CDIR$ IVDEP 10490000 DO 7840 IVPSS = 1, NICTY 10500000 CESN XVPSS = BULK(JXVPSS - 1 + NXARRV) 10510000 CESN BULK(JYVPSS - 1 + NYARRV) = 10520000 CESN & CVMGT(UVPSS4, XVPSS , 10530000 CESN & XVPSS .LE. UVPSS3 ) 10540000 C BULK(JYVPSS - 1 + NYARRV) = 10550000 C & CVMGT(UVPSS4, XVPSS , 10560000 C & XVPSS .LE. UVPSS3 ) 10570000 CESN JYVPSS = JYVPSS + NIDLY 10580000 CESN JXVPSS = JXVPSS + NIDLX 10590000 BULK(IVPSS - 1 + NYARRV) = ZBULK(IVPSS-1+NXARRV) 10600000 IF (ZBULK(IVPSS-1+NXARRV) .LE. UVPSS3) 10610000 * BULK(IVPSS - 1 + NYARRV) = UVPSS4 10620000 7840 CONTINUE 10630000 C 10640000 C IF (KPBUGF.EQ.3) CALL DUMP(7840,BULK(NYARRV),NICTY,KPPRNT) 10650000 C 10660000 C ======================================================================10670000 C CALL VPSS (APUNIT, 'DIV ', ISTATE, 10680000 C Y 96, APWAVG, 0, 1, R7, R8, 10690000 C X 32, APCDIF, 1, R7, 10700000 C U 32, APADIF, 1, R7) 10710000 NYARRV = APWAVG + R7 10720000 NICTY = 0 + R8 10730000 NIDLY = 1 10740000 NXARRV = APCDIF + R7 10750000 NIDLX = 1 10760000 NUARRV = APADIF + R7 10770000 NIDLU = 1 10780000 JYVPSS = 1 10790000 JXVPSS = 1 10800000 JUVPSS = 1 10810000 C 10820000 CDIR$ IVDEP 10830000 DO 7850 IVPSS = 1, NICTY 10840000 BULK(IVPSS - 1 + NYARRV) = 10850000 & ZBULK(IVPSS - 1 + NUARRV) 10860000 & /ZBULK(IVPSS - 1 + NXARRV) 10870000 7850 CONTINUE 10880000 C 10890000 C IF (KPBUGF.EQ.3) CALL DUMP(7850,BULK(NYARRV),NICTY,KPPRNT) 10900000 C 10910000 C ======================================================================10920000 C STEP 9 SET UP SCALE FACTORS 10930000 C IF 'ABS', AVERAGE VALUES FROM ABOVE 10940000 C IF 'RMS', SQRT OF THE AVERAGE VALUES 10950000 C 10960000 IF (TYPSC .NE. AABS) GO TO 7860 10970000 APRTEM = APWAVG 10980000 APRTM2 = APWVAL 10990000 7860 CONTINUE 11000000 C 11010000 IF (TYPSC .NE. ARMS) GO TO 7880 11020000 C ======================================================================11030000 C CALL VPSS (APUNIT, 'SQRT', ISTATE, 11040000 C Y 96, APWVAL, 0, 1, R7, R8, 11050000 C X 32, APWAVG, 1, R7) 11060000 NYARRV = APWVAL + R7 11070000 NICTY = 0 + R8 11080000 NIDLY = 1 11090000 NXARRV = APWAVG + R7 11100000 NIDLX = 1 11110000 JYVPSS = 1 11120000 JXVPSS = 1 11130000 C 11140000 CDIR$ IVDEP 11150000 DO 7870 IVPSS = 1, NICTY 11160000 BULK(IVPSS - 1 + NYARRV) = 11170000 & SQRT(ABS(ZBULK(IVPSS - 1 + NXARRV))) 11180000 7870 CONTINUE 11190000 C 11200000 C IF (KPBUGF.EQ.3) CALL DUMP(7870,BULK(NYARRV),NICTY,KPPRNT) 11210000 C ======================================================================11220000 APRTEM = APWVAL 11230000 APRTM2 = APWAVG 11240000 7880 CONTINUE 11250000 C 11260000 C STEP 10 IF WINDOW MULTIPLIER OR SPECIFIC WINDOWS 11270000 C SUPPLIED -- INTERPOLATE MULTIPLIERS AND 11280000 C SCALARS BETWEEN WINDOW CENTER TIMES 11290000 C 11300000 IF (MLTSPC .NE. 1) GO TO 8060 11310000 C TEST FOR ONE WINDOW 11320000 C ======================================================================11330000 C CALL VPSS (APUNIT, 'XCI ', R8, 1, 'WINN', 'GT ') 11340000 IF(R8 .GT. 1 ) GO TO 7900 11350000 C 11360000 C ======================================================================11370000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 11380000 C Y 32, APMUL2, 1, 1, R7, 11390000 C X 0, APMULT) 11400000 NYARRV = APMUL2 + R7 11410000 CRAY NICTY = 1 11420000 CRAY NIDLY = 1 11430000 NXARRV = APMULT 11440000 JYVPSS = 1 11450000 XVPSS = BULK(NXARRV) 11460000 C 11470000 CRAY DO 7890 IVPSS = 1, NICTY 11480000 BULK(JYVPSS - 1 + NYARRV) = XVPSS 11490000 CRAY JYVPSS = JYVPSS + NIDLY 11500000 7890 CONTINUE 11510000 C 11520000 C ======================================================================11530000 C CALL VPSS (APUNIT,'XGO ', 'ENIT') 11540000 GO TO 8050 11550000 C 11560000 C ======================================================================11570000 C CALL VPSS (APUNIT, 'XID ', 'WINN') 11580000 7900 CONTINUE 11590000 C 11600000 C ======================================================================11610000 C CALL VPSS (APUNIT, 'VES ', ISTATE, 11620000 C Y 96, APADFR, -1, 1, R7, R8, 11630000 C X 32, APRTEM+1, 1, R7, 11640000 C U 40, APRTEM, 1, R7) 11650000 NYARRV = APADFR + R7 11660000 NICTY = -1 + R8 11670000 NIDLY = 1 11680000 NXARRV = APRTEM+1 + R7 11690000 NIDLX = 1 11700000 NUARRV = APRTEM + R7 11710000 NIDLU = 1 11720000 JYVPSS = 1 11730000 JXVPSS = 1 11740000 JUVPSS = 1 11750000 CDIR$ IVDEP 11760000 DO 7910 IVPSS = 1, NICTY 11770000 BULK(IVPSS-1+NYARRV) = 11780000 & ZBULK(IVPSS - 1 + NXARRV) - 11790000 & ZBULK(IVPSS - 1 + NUARRV) 11800000 7910 CONTINUE 11810000 C 11820000 C ======================================================================11830000 C CALL VPSS (APUNIT, 'VES ', ISTATE, 11840000 C Y 96, APMDFR, -1, 1, R7, R8, 11850000 C X 0, APMULT+1, 1, 11860000 C U 8, APMULT, 1) 11870000 NYARRV = APMDFR + R7 11880000 NICTY = -1 + R8 11890000 NIDLY = 1 11900000 NXARRV = APMULT+1 11910000 NIDLX = 1 11920000 NUARRV = APMULT 11930000 NIDLU = 1 11940000 JYVPSS = 1 11950000 JXVPSS = 1 11960000 JUVPSS = 1 11970000 CDIR$ IVDEP 11980000 DO 7920 IVPSS = 1, NICTY 11990000 BULK(IVPSS-1+NYARRV) = 12000000 & ZBULK(IVPSS - 1 + NXARRV) - 12010000 & ZBULK(IVPSS - 1 + NUARRV) 12020000 7920 CONTINUE 12030000 C 12040000 C ======================================================================12050000 C CALL VPSS (APUNIT,'VES ', ISTATE, 12060000 C Y 96, APCDFR, -1, 1, R7, R8, 12070000 C X 0, APMDWI+1, 1, 12080000 C U 8, APMDWI, 1) 12090000 NYARRV = APCDFR + R7 12100000 NICTY = -1 + R8 12110000 NIDLY = 1 12120000 NXARRV = APMDWI+1 12130000 NIDLX = 1 12140000 NUARRV = APMDWI 12150000 NIDLU = 1 12160000 JYVPSS = 1 12170000 JXVPSS = 1 12180000 JUVPSS = 1 12190000 CDIR$ IVDEP 12200000 DO 7930 IVPSS = 1, NICTY 12210000 BULK(IVPSS-1+NYARRV) = 12220000 & ZBULK(IVPSS - 1 + NXARRV) - 12230000 & ZBULK(IVPSS - 1 + NUARRV) 12240000 7930 CONTINUE 12250000 C 12260000 C ======================================================================12270000 C CALL VPSS (APUNIT, 'DIV ', ISTATE, 12280000 C Y 96, APADFR, -1, 1, R7, R8, 12290000 C X 32, APCDFR, 1, R7, 12300000 C U 32, APADFR, 1, R7) 12310000 NYARRV = APADFR + R7 12320000 NICTY = -1 + R8 12330000 NIDLY = 1 12340000 NXARRV = APCDFR + R7 12350000 NIDLX = 1 12360000 NUARRV = APADFR + R7 12370000 NIDLU = 1 12380000 JYVPSS = 1 12390000 JXVPSS = 1 12400000 JUVPSS = 1 12410000 CDIR$ IVDEP 12420000 DO 7940 IVPSS = 1, NICTY 12430000 BULK(IVPSS - 1 + NYARRV) = 12440000 & ZBULK(IVPSS - 1 + NUARRV) 12450000 & /ZBULK(IVPSS - 1 + NXARRV) 12460000 7940 CONTINUE 12470000 C 12480000 C ======================================================================12490000 C CALL VPSS (APUNIT, 'DIV ', ISTATE, 12500000 C Y 96, APMDFR, -1, 1, R7, R8, 12510000 C X 32, APCDFR, 1, R7, 12520000 C U 32, APMDFR, 1, R7) 12530000 NYARRV = APMDFR + R7 12540000 NICTY = -1 + R8 12550000 NIDLY = 1 12560000 NXARRV = APCDFR + R7 12570000 NIDLX = 1 12580000 NUARRV = APMDFR + R7 12590000 NIDLU = 1 12600000 JYVPSS = 1 12610000 JXVPSS = 1 12620000 JUVPSS = 1 12630000 CDIR$ IVDEP 12640000 DO 7950 IVPSS = 1, NICTY 12650000 BULK(IVPSS - 1 + NYARRV) = 12660000 & ZBULK(IVPSS - 1 + NUARRV) 12670000 & /ZBULK(IVPSS - 1 + NXARRV) 12680000 7950 CONTINUE 12690000 C 12700000 C ======================================================================12710000 C CALL VPSS (APUNIT, 'XMV ', R14, R7) 12720000 R14 = R7 12730000 C 12740000 C ======================================================================12750000 C CALL VPSS (APUNIT, 'XMV ', R4, R7) 12760000 R4 = R7 12770000 C 12780000 C ======================================================================12790000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 12800000 C Y 32, APRTM2, 1, 1, R7, 12810000 C X 32, APRTEM, R7) 12820000 NYARRV = APRTM2 + R7 12830000 CRAY NICTY = 1 12840000 CRAY NIDLY = 1 12850000 NXARRV = APRTEM + R7 12860000 JYVPSS = 1 12870000 XVPSS = BULK(NXARRV) 12880000 CRAY$ IVDEP 12890000 CRAY DO 7960 IVPSS = 1, NICTY 12900000 BULK(JYVPSS - 1 + NYARRV) = XVPSS 12910000 CRAY JYVPSS = JYVPSS + NIDLY 12920000 7960 CONTINUE 12930000 C 12940000 C ======================================================================12950000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 12960000 C Y 32, APMUL1, 1, 1, R7, 12970000 C X 0, APMULT) 12980000 NYARRV = APMUL1 + R7 12990000 CRAY NICTY = 1 13000000 CRAY NIDLY = 1 13010000 NXARRV = APMULT 13020000 JYVPSS = 1 13030000 XVPSS = BULK(NXARRV) 13040000 CRAY$ IVDEP 13050000 CRAY DO 7970 IVPSS = 1, NICTY 13060000 BULK(JYVPSS - 1 + NYARRV) = XVPSS 13070000 CRAY JYVPSS = JYVPSS + NIDLY 13080000 7970 CONTINUE 13090000 C 13100000 C ======================================================================13110000 C CALL VPSS (APUNIT, 'XADI', R14, 1) 13120000 R14 = R14 + 1 13130000 C 13140000 C ======================================================================13150000 C CALL VPSS (APUNIT, 'XMVI', R12, 0) 13160000 R12 = 0 13170000 C 13180000 C ======================================================================13190000 C CALL VPSS (APUNIT, 'XADI', R8, -1) 13200000 R8 = R8 + (-1) 13210000 C 13220000 C ======================================================================13230000 C CALL VPSS (APUNIT, 'XID ', 'LOP2') 13240000 7980 CONTINUE 13250000 C 13260000 C ======================================================================13270000 C CALL VPSS (APUNIT, 'XMVS', APMDDF, 1, R12, R6) 13280000 NYARRV = APMDDF + R12 13290000 CRAY NICTY = 1 13300000 CRAY CALL SCOPY (NICTY, BULK(NYARRV), 1, R6 , 1) 13310000 R6 = IBULK(NYARRV) 13320000 C 13330000 C ======================================================================13340000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 13350000 C Y 96, APRTM2, 0, 1, R14, R6, 13360000 C X 32, APADFR, R4) 13370000 NYARRV = APRTM2 + R14 13380000 NICTY = 0 + R6 13390000 NIDLY = 1 13400000 NXARRV = APADFR + R4 13410000 JYVPSS = 1 13420000 XVPSS = BULK(NXARRV) 13430000 C 13440000 DO 7990 IVPSS = 1, NICTY 13450000 BULK(IVPSS - 1 + NYARRV) = XVPSS 13460000 7990 CONTINUE 13470000 C 13480000 C ======================================================================13490000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 13500000 C Y 96, APMUL1, 0, 1, R14, R6, 13510000 C X 32, APMDFR, R4) 13520000 NYARRV = APMUL1 + R14 13530000 NICTY = 0 + R6 13540000 NIDLY = 1 13550000 NXARRV = APMDFR + R4 13560000 JYVPSS = 1 13570000 XVPSS = BULK(NXARRV) 13580000 C 13590000 DO 8000 IVPSS = 1, NICTY 13600000 BULK(IVPSS - 1 + NYARRV) = XVPSS 13610000 8000 CONTINUE 13620000 C 13630000 C ======================================================================13640000 C CALL VPSS (APUNIT, 'XAD ', R14, R6) 13650000 R14 = R14 + R6 13660000 C 13670000 C ======================================================================13680000 C CALL VPSS (APUNIT, 'XADI', R12, 1) 13690000 R12 = R12 + 1 13700000 C 13710000 C ======================================================================13720000 C CALL VPSS (APUNIT, 'XADI', R4, 1) 13730000 R4 = R4 + 1 13740000 C 13750000 C ======================================================================13760000 C CALL VPSS (APUNIT, 'XC ', R12, R8, 'LOP2', 'LT ') 13770000 IF(R12 .LT. R8 ) GO TO 7980 13780000 C 13790000 C ======================================================================13800000 C CALL VPSS (APUNIT, 'XADI', R8, 1) 13810000 R8 = R8 + 1 13820000 C 13830000 C ======================================================================13840000 C CALL VPSS (APUNIT, 'XSB ', R14, R7) 13850000 R14 = R14 - R7 13860000 C 13870000 C ======================================================================13880000 C CALL VPSS (APUNIT, 'ZMV ', ISTATE, 13890000 C Y 32, APRTEM, 1, 1, R7) 13900000 NYARRV = APRTEM + R7 13910000 CRAY NICTY = 1 13920000 CRAY NIDLY = 1 13930000 JYVPSS = 1 13940000 CRAY$ IVDEP 13950000 CRAY DO 8010 IVPSS = 1, NICTY 13960000 BULK(JYVPSS - 1 + NYARRV) = 0.0 13970000 CRAY JYVPSS = JYVPSS + NIDLY 13980000 8010 CONTINUE 13990000 C 14000000 C ======================================================================14010000 C CALL VPSS (APUNIT, 'REC ', ISTATE, 14020000 C Y 96, APRTEM, 0, 1, R7, R14, 14030000 C X 32, APRTM2, 1, R7, 14040000 C U 32, APRECU, 1, R7) 14050000 C 14060000 NYARRV = APRTEM + R7 14070000 NICTY = 0 + R14 14080000 NIDLY = 1 14090000 NXARRV = APRTM2 + R7 14100000 NIDLX = 1 14110000 NUARRV = APRECU + R7 14120000 NIDLU = 1 14130000 JUVPSS = 1 14140000 JYVPSS = 1 14150000 JXVPSS = 1 14160000 C 14170000 BULK(JYVPSS - 1 + NYARRV) = 14180000 &BULK(JYVPSS - 1 + NYARRV) + 14190000 &BULK(JUVPSS - 1 + NUARRV) * 14200000 &BULK(JXVPSS - 1 + NXARRV) 14210000 JYVPSS = JYVPSS + NIDLY 14220000 JXVPSS = JXVPSS + NIDLX 14230000 JUVPSS = JUVPSS + NIDLU 14240000 C 14250000 CDIR$ NOVECTOR 14260000 DO 8020 IVPSS = 2, NICTY 14270000 BULK(IVPSS - 1 + NYARRV) = 14280000 & BULK(IVPSS - 1 + NUARRV) * BULK(IVPSS-2 + NYARRV) + 14290000 & BULK( 0 + NUARRV) * BULK(IVPSS-1 + NXARRV) 14300000 8020 CONTINUE 14310000 CDIR$ VECTOR 14320000 C 14330000 C ======================================================================14340000 C CALL VPSS (APUNIT, 'ZMV ', ISTATE, 14350000 C Y 32, APMUL2, 1, 1, R7) 14360000 NYARRV = APMUL2 + R7 14370000 CRAY NICTY = 1 14380000 CRAY NIDLY = 1 14390000 JYVPSS = 1 14400000 CRAY$ IVDEP 14410000 CRAY DO 8030 IVPSS = 1, NICTY 14420000 BULK(JYVPSS - 1 + NYARRV) = 0.0 14430000 CRAY JYVPSS = JYVPSS + NIDLY 14440000 8030 CONTINUE 14450000 C 14460000 C ======================================================================14470000 C CALL VPSS (APUNIT, 'REC ', ISTATE, 14480000 C Y 96, APMUL2, 0, 1, R7, R14, 14490000 C X 32, APMUL1, 1, R7, 14500000 C U 32, APRECU, 1, R7) 14510000 C 14520000 NYARRV = APMUL2 + R7 14530000 NICTY = 0 + R14 14540000 NIDLY = 1 14550000 NXARRV = APMUL1 + R7 14560000 NIDLX = 1 14570000 NUARRV = APRECU + R7 14580000 NIDLU = 1 14590000 JUVPSS = 1 14600000 JYVPSS = 1 14610000 JXVPSS = 1 14620000 C 14630000 BULK(JYVPSS - 1 + NYARRV) = 14640000 &BULK(JYVPSS - 1 + NYARRV) + 14650000 &BULK(JUVPSS - 1 + NUARRV) * 14660000 &BULK(JXVPSS - 1 + NXARRV) 14670000 JYVPSS = JYVPSS + NIDLY 14680000 JXVPSS = JXVPSS + NIDLX 14690000 JUVPSS = JUVPSS + NIDLU 14700000 C 14710000 CDIR$ NOVECTOR 14720000 DO 8040 IVPSS = 2, NICTY 14730000 BULK(IVPSS - 1 + NYARRV) = 14740000 & BULK(IVPSS - 1 + NUARRV) * BULK(IVPSS-2 + NYARRV) + 14750000 & BULK( 0 + NUARRV) * BULK(IVPSS-1 + NXARRV) 14760000 8040 CONTINUE 14770000 CDIR$ VECTOR 14780000 C 14790000 C ======================================================================14800000 C CALL VPSS (APUNIT, 'XID ', 'ENIT') 14810000 8050 CONTINUE 14820000 C ======================================================================14830000 C 14840000 C STEP 11 COPY FIRST AND LAST SCALARS TO EDGES 14850000 C 14860000 8060 CONTINUE 14870000 C 14880000 C ======================================================================14890000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 14900000 C Y 64, APRTEM, 0, 1, R10, 14910000 C X 32, APRTEM, R7) 14920000 NYARRV = APRTEM 14930000 NICTY = 0 + R10 14940000 NIDLY = 1 14950000 NXARRV = APRTEM + R7 14960000 JYVPSS = 1 14970000 XVPSS = BULK(NXARRV) 14980000 C 14990000 DO 8070 IVPSS = 1, NICTY 15000000 BULK(IVPSS - 1 + NYARRV) = XVPSS 15010000 8070 CONTINUE 15020000 C 15030000 C IF (KPBUGF.EQ.3) CALL DUMP(8070,BULK(NYARRV),NICTY,KPPRNT) 15040000 C 15050000 C ======================================================================15060000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 15070000 C Y 96, APRTEM+1, 0, 1, R11, R15, 15080000 C X 32, APRTEM, R11) 15090000 NYARRV = APRTEM+1 + R11 15100000 NICTY = 0 + R15 15110000 NIDLY = 1 15120000 NXARRV = APRTEM + R11 15130000 JYVPSS = 1 15140000 XVPSS = BULK(NXARRV) 15150000 C 15160000 DO 8080 IVPSS = 1, NICTY 15170000 BULK(IVPSS - 1 + NYARRV) = XVPSS 15180000 8080 CONTINUE 15190000 C 15200000 C IF (KPBUGF.EQ.3) CALL DUMP(8080,BULK(NYARRV),NICTY,KPPRNT) 15210000 C ======================================================================15220000 IF (MLTSPC .NE. 1) GO TO 8110 15230000 C ======================================================================15240000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 15250000 C Y 64, APMUL2, 0, 1, R10, 15260000 C X 32, APMUL2, R7) 15270000 NYARRV = APMUL2 15280000 NICTY = 0 + R10 15290000 NIDLY = 1 15300000 NXARRV = APMUL2 + R7 15310000 JYVPSS = 1 15320000 XVPSS = BULK(NXARRV) 15330000 C 15340000 DO 8090 IVPSS = 1, NICTY 15350000 BULK(IVPSS - 1 + NYARRV) = XVPSS 15360000 8090 CONTINUE 15370000 C 15380000 C ======================================================================15390000 C CALL VPSS (APUNIT, 'SMV ', ISTATE, 15400000 C Y 96, APMUL2+1, 0, 1, R11, R15, 15410000 C X 32, APMUL2, R11) 15420000 NYARRV = APMUL2+1 + R11 15430000 NICTY = 0 + R15 15440000 NIDLY = 1 15450000 NXARRV = APMUL2 + R11 15460000 JYVPSS = 1 15470000 XVPSS = BULK(NXARRV) 15480000 C 15490000 DO 8100 IVPSS = 1, NICTY 15500000 BULK(IVPSS - 1 + NYARRV) = XVPSS 15510000 8100 CONTINUE 15520000 C 15530000 C ======================================================================15540000 8110 CONTINUE 15550000 C 15560000 C STEP 12 SCALE TRACE WITH SCALARS 15570000 C 15580000 C ======================================================================15590000 C CALL VPSS (APUNIT, 'LIM ', ISTATE, 15600000 C Y 96, APRTEM, 0, 1, R1, R3, 15610000 C X 32, APRTEM, 1, R1, 15620000 C U 0, APLMU1) 15630000 NYARRV = APRTEM + R1 15640000 NICTY = 0 + R3 15650000 NIDLY = 1 15660000 NXARRV = APRTEM + R1 15670000 NIDLX = 1 15680000 NUARRV = APLMU1 15690000 JUVPSS = 1 15700000 JYVPSS = 1 15710000 JXVPSS = 1 15720000 UVPSS1 = BULK(JUVPSS - 1 + NUARRV) 15730000 UVPSS2 = BULK(JUVPSS - 0 + NUARRV) 15740000 UVPSS3 = BULK(JUVPSS + 1 + NUARRV) 15750000 UVPSS4 = BULK(JUVPSS + 2 + NUARRV) 15760000 C 15770000 CDIR$ IVDEP 15780000 DO 8120 IVPSS = 1, NICTY 15790000 CESN XVPSS = BULK(JXVPSS - 1 + NXARRV) 15800000 CESN BULK(JYVPSS - 1 + NYARRV) = 15810000 CESN & CVMGT(UVPSS4, XVPSS , 15820000 CESN & XVPSS .LE. UVPSS3 ) 15830000 C BULK(JYVPSS - 1 + NYARRV) = 15840000 C & CVMGT(UVPSS4, XVPSS , 15850000 C & XVPSS .LE. UVPSS3 ) 15860000 CESN JYVPSS = JYVPSS + NIDLY 15870000 CESN JXVPSS = JXVPSS + NIDLX 15880000 BULK(IVPSS - 1 + NYARRV) = ZBULK(IVPSS-1+NYARRV) 15890000 IF (ZBULK(IVPSS-1+NYARRV) .LE. UVPSS3) 15900000 * BULK(IVPSS - 1 + NYARRV) = UVPSS4 15910000 8120 CONTINUE 15920000 C 15930000 C IF (KPBUGF.EQ.3) CALL DUMP(8120,BULK(NYARRV),NICTY,KPPRNT) 15940000 C 15950000 C ======================================================================15960000 C 15970000 C CALL VPSS (APUNIT, 'DIV ', ISTATE, 15980000 C Y 96, APOTR , 0, 1, R1, R3, 15990000 C X 32, APRTEM, 1, R1, 16000000 C U 32, APINTR, 1, R1) 16010000 NYARRV = APOTR + R1 16020000 NICTY = 0 + R3 16030000 NIDLY = 1 16040000 NXARRV = APRTEM + R1 16050000 NIDLX = 1 16060000 NUARRV = APINTR + R1 16070000 NIDLU = 1 16080000 JYVPSS = 1 16090000 JXVPSS = 1 16100000 JUVPSS = 1 16110000 CDIR$ IVDEP 16120000 DO 8130 IVPSS = 1, NICTY 16130000 BULK(IVPSS - 1 + NYARRV) = 16140000 & ZBULK(IVPSS - 1 + NUARRV) 16150000 & /ZBULK(IVPSS - 1 + NXARRV) 16160000 8130 CONTINUE 16170000 C 16180000 C IF (KPBUGF.EQ.3) CALL DUMP(8130,BULK(NYARRV),NICTY,KPPRNT) 16190000 C 16200000 C ======================================================================16210000 C STEP 13 SCALE TRACE WITH RMSOUT VALUE 16220000 C 16230000 IF (MLTSPC .EQ. 1) GO TO 8150 16240000 C 16250000 C ======================================================================16260000 C CALL VPSS (APUNIT, 'SMY ', ISTATE, 16270000 C Y 96, APOTR , 0, 1, R1, R3, 16280000 C X 32, APOTR , 1, R1, 16290000 C U 0, APRMSO) 16300000 NYARRV = APOTR + R1 16310000 NICTY = 0 + R3 16320000 NIDLY = 1 16330000 NXARRV = APOTR + R1 16340000 NIDLX = 1 16350000 NUARRV = APRMSO 16360000 JYVPSS = 1 16370000 JXVPSS = 1 16380000 JUVPSS = 1 16390000 UVPSS = BULK(JUVPSS - 1 + NUARRV) 16400000 CDIR$ IVDEP 16410000 DO 8140 IVPSS = 1, NICTY 16420000 BULK(IVPSS - 1 + NYARRV) = UVPSS * 16430000 & ZBULK(IVPSS - 1 + NXARRV) 16440000 8140 CONTINUE 16450000 C 16460000 C IF (KPBUGF.EQ.3) CALL DUMP(8140,BULK(NYARRV),NICTY,KPPRNT) 16470000 C ======================================================================16480000 8150 CONTINUE 16490000 C 16500000 IF (MLTSPC .NE. 1) GO TO 8170 16510000 C ======================================================================16520000 C CALL VPSS (APUNIT, 'VEM ', ISTATE, 16530000 C Y 96, APOTR , 0, 1, R1, R3, 16540000 C X 32, APOTR , 1, R1, 16550000 C U 32, APMUL2, 1, R1) 16560000 NYARRV = APOTR + R1 16570000 NICTY = 0 + R3 16580000 NIDLY = 1 16590000 NXARRV = APOTR + R1 16600000 NIDLX = 1 16610000 NUARRV = APMUL2 + R1 16620000 NIDLU = 1 16630000 JYVPSS = 1 16640000 JXVPSS = 1 16650000 JUVPSS = 1 16660000 CDIR$ IVDEP 16670000 DO 8160 IVPSS = 1, NICTY 16680000 BULK(IVPSS-1+NYARRV) = 16690000 & ZBULK(IVPSS - 1 + NXARRV) 16700000 & * ZBULK(IVPSS - 1 + NUARRV) 16710000 8160 CONTINUE 16720000 C ======================================================================16730000 8170 CONTINUE 16740000 C=======================================================================16750000 C 16760000 C STEP 14 PARTIAL/AGC CALCULATIONS AND SCALING, IF REQUESTED 16770000 C 16780000 IF (PRCAGC .EQ. 1.0) GO TO 8260 16790000 C 16800000 C FORMULA IS O/P SAMPLE = M(O/P SAMP) + (I/P SAMP)(1-M)(R/A0) 16810000 C WHERE M = PARTIAL/AGC PERCENTAGE DESIRED 16820000 C R = REFERENCE LEVEL (ONLY ONE FOR ENTIRE TRACE LENGTH)16830000 C WILL NOT WORK WITH MULTIPLE TVS REFERENCE LEVELS. 16840000 C A0 = AVERAGE INPUT TRACE AMPLITUDE 16850000 C NOTE: ORIGINAL INPUT TRACE HAS PREVIOUSLY BEEN SAVED IN 16860000 C WORK ARRAY BULK(APT2). NOT DONE IN CRAY VERSION - NOT NEEDED! 16870000 C 16880000 XSUM = 0.0 16890000 LVCT = 0 16900000 XISCAL = 0.0 16910000 C 16920000 IF (TYPSC .NE. AABS) GO TO 8220 16930000 C 16940000 C *** IF 'ABS' , THEN SUM ELEMENTS OF INPUT TRACE; EG. XSUM ** 16950000 C *** COMPUTE # OF LIVE SAMPLES; EG. LVCT ** 16960000 C *** SUM OF INPUT DIV BY # OF LIVE SAMPS=A0(AVG INPUT TRACE AMPLITUDE)16970000 C 16980000 DO 8210 I=1, NOSAMP 16990000 XSUM = XSUM + ABS(INTR(I)) 17000000 IF (INTR(I) .NE. 0.0) LVCT = LVCT + 1 17010000 8210 CONTINUE 17020000 A0 = XSUM/LVCT 17030000 C 17040000 8220 CONTINUE 17050000 C 17060000 IF (TYPSC .NE. ARMS) GO TO 8240 17070000 C 17080000 C *** IF 'RMS' THEN SUM THE SQUARES OF THE INPUT TRACE; EG. XSUM ** 17090000 C *** SUM ELEMENTS OF ORIGINAL INPUT TRACE ARRAY; EG. XSUM ** 17100000 C *** COMPUTE # OF LIVE SAMPLES; EG. LVCT ** 17110000 C *** SQ. ROOT OF(SUM OF SQS./LIVE SAMPS)=A0(AVG INPUT TRACE AMPLITUDE)17120000 C 17130000 DO 8230 I=1, NOSAMP 17140000 XSUM = XSUM + (INTR(I)**2) 17150000 IF (INTR(I) .NE. 0.0) LVCT = LVCT + 1 17160000 8230 CONTINUE 17170000 A0 = SQRT( XSUM / LVCT) 17180000 C 17190000 8240 CONTINUE 17200000 C 17210000 C *** DIVIDE REFERENCE MEAN BY AVG. AMPLITUDE ; R/A0 Y=U/X 17220000 C *** CALCULATE CONSTANT FACTOR ON INPUT SIDE OF FORMULA. (1-M)(R/A0) 17230000 C 17240000 XISCAL = (1.0-PRCAGC) * (BULK(APRMSO)/A0) 17250000 C 17260000 C *** MULTIPLY O/P TRACE BY PARTIAL/AGC PERCENTAGE. ** 17270000 C *** SCALE I/P TRACE BY CONSTANT OF NO TIME VARYING GAIN. 17280000 C *** FINALLY; SUM THE TIME VARYING COMPONENT AND THE TIME INVARIANT 17290000 C *** COMPONENT TO GET THE RESULTANT PARTIALLY AGC TRACE. 17300000 C *** EG. (M)(O/PSAMP) + (I/P SAMP)(1-M)(R/A0) 17310000 C 17320000 DO 8250 I=1, NOSAMP 17330000 BULK(APOTR+I-1) = (BULK(APOTR+I-1) * PRCAGC) + (INTR(I) * XISCAL) 17340000 C 17350000 8250 CONTINUE 17360000 C=======================================================================17370000 C 17380000 8260 CONTINUE 17390000 C=======================================================================17400000 C 17410000 CSU*====================================================================17420000 CSU* THIS CODE DELETED BECAUSE IT WAS DETERMINED THAT THE TRACE HEADER 17430000 CSU* VALUES OF MAX, MIN, THEIR INDEXES, SUM OF TRACE, MEAN, AND PSF 17440000 CSU* WERE NO LONGER NEEDED AND HAD AN ADVERSE EFFECT ON WRIT EVERY 17450000 CSU* TIME THEY WERE CALCULATED IN WRITE. THEREFORE, DELETE IT ALL. 17460000 CSU* COMMENTED OUT 4-23-85..... AFTER A PERIOD OF TIME DELETE LINES. 17470000 CSU* 17480000 CSU* STEP 14 DETERMINE VARIOUS VALUES FOR TRACE HEADER 17490000 CSU* 17500000 CSU*====================================================================17510000 CSU* CALL VPSS (APUNIT, 'MAX ', ISTATE, 17520000 CSU* Y 0, APAMAX, 17530000 CSU* X 4, APOTR , NOSAMP, 1) 17540000 CSU* NYARRV = APAMAX 17550000 CSU* NXARRV = APOTR 17560000 CSU* NICTX = NOSAMP 17570000 CSU* NIDLX = 1 17580000 CSU* IMAX = ISAMAX(NICTX, BULK(NXARRV), NIDLX) 17590000 CSU* BULK(NYARRV) = ABS(BULK(NXARRV - 1 + IMAX)) 17600000 CSU* IBULK(NYARRV + 1) = IMAX - 1 17610000 CSU* 17620000 CSU* IF (KPBUGF.EQ.3) CALL DUMP(8170,BULK(NYARRV),1 ,KPPRNT) 17630000 CSU* 17640000 CSU*====================================================================17650000 CSU* CALL VPSS (APUNIT, 'LIM ', ISTATE, 17660000 CSU* Y 0, APTEM3, NOSAMP, 1, 17670000 CSU* X 4, APOTR , 1, 17680000 CSU* U 0, APLMU2) 17690000 CSU* NYARRV = APTEM3 17700000 CSU* NICTY = NOSAMP 17710000 CSU* NIDLY = 1 17720000 CSU* NXARRV = APOTR 17730000 CSU* NIDLX = 1 17740000 CSU* NUARRV = APLMU2 17750000 CSU* JUVPSS = 1 17760000 CSU* JYVPSS = 1 17770000 CSU* JXVPSS = 1 17780000 CSU* UVPSS1 = BULK(JUVPSS - 1 + NUARRV) 17790000 CSU* UVPSS2 = BULK(JUVPSS - 0 + NUARRV) 17800000 CSU* UVPSS3 = BULK(JUVPSS + 1 + NUARRV) 17810000 CSU* UVPSS4 = BULK(JUVPSS + 2 + NUARRV) 17820000 CSU* CDIR$ IVDEP 17830000 CSU* DO 8180 IVPSS = 1, NICTY 17840000 CSU* XVPSS = BULK(JXVPSS - 1 + NXARRV) 17850000 CSU* BULK(JYVPSS - 1 + NYARRV) = 17860000 CSU* & CVMGT(UVPSS4, ABS( XVPSS ), 17870000 CSU* & ABS( XVPSS ).LE. UVPSS3 ) 17880000 CSU* BULK(JYVPSS - 1 + NYARRV) = 17890000 CSU* & CVMGT(UVPSS4, XVPSS , 17900000 CSU* & ABS( XVPSS ).LE. UVPSS3 ) 17910000 CSU* JYVPSS = JYVPSS + NIDLY 17920000 CSU* JXVPSS = JXVPSS + NIDLX 17930000 CSU* 8180 CONTINUE 17940000 CSU* 17950000 CSU* IF (KPBUGF.EQ.3) CALL DUMP(8180,BULK(NYARRV),NICTY,KPPRNT) 17960000 CSU* 17970000 CSU*====================================================================17980000 CSU* CALL VPSS (APUNIT, 'MAX ', ISTATE, 17990000 CSU* Y 0, APAMIN, 18000000 CSU* X 16, APTEM3, NOSAMP, 1) 18010000 CSU* NYARRV = APAMIN 18020000 CSU* NXARRV = APTEM3 18030000 CSU* NICTX = NOSAMP 18040000 CSU* NIDLX = 1 18050000 CSU* IMAX = ISAMIN(NICTX, BULK(NXARRV), NIDLX) 18060000 CSU* BULK(NYARRV) = (BULK(NXARRV - 1 + IMAX)) 18070000 CSU* IBULK(NYARRV + 1) = IMAX - 1 18080000 CSU* 18090000 CSU* IF (KPBUGF.EQ.3) CALL DUMP(8185,BULK(NYARRV),1 ,KPPRNT) 18100000 CSU* 18110000 CSU*====================================================================18120000 CSU* CALL VPSS (APUNIT, 'SVE ', ISTATE, 18130000 CSU* Y 0, APABSM, 18140000 CSU* X 4, APOTR , NOSAMP, 1) 18150000 CSU* NYARRV = APABSM 18160000 CSU* NXARRV = APOTR 18170000 CSU* NICTX = NOSAMP 18180000 CSU* NIDLX = 1 18190000 CSU* JYVPSS = 1 18200000 CSU* JXVPSS = 1 18210000 CSU* XVPSS = 0.0 18220000 CSU* 18230000 CSU* DO 8190 IVPSS = 1, NICTX 18240000 CSU* XVPSS = XVPSS + 18250000 CSU* & 18260000 CSU* & ABS(BULK(JXVPSS - 1 + NXARRV)) 18270000 CSU* JXVPSS = JXVPSS + NIDLX 18280000 CSU* 8190 CONTINUE 18290000 CSU* BULK(NYARRV) = XVPSS 18300000 CSU* 18310000 CSU* IF (KPBUGF.EQ.3) CALL DUMP(8190,BULK(NYARRV),1 ,KPPRNT) 18320000 CSU* 18330000 CSU*====================================================================18340000 CSU* CALL VPSS (APUNIT, 'SMV ', ISTATE, 18350000 CSU* Y 0, APABSM+1, 1, 1, 18360000 CSU* X 32, APLVCT, R2) 18370000 CSU* NYARRV = APABSM+1 18380000 CSU* CRAY NICTY = 1 18390000 CSU* CRAY NIDLY = 1 18400000 CSU* NXARRV = APLVCT + R2 18410000 CSU* JYVPSS = 1 18420000 CSU* XVPSS = BULK(NXARRV) 18430000 CSU* CRAY$ IVDEP 18440000 CSU* CRAY DO 8200 IVPSS = 1, NICTY 18450000 CSU* BULK(JYVPSS - 1 + NYARRV) = XVPSS 18460000 CSU* CRAY JYVPSS = JYVPSS + NIDLY 18470000 CSU* 8200 CONTINUE 18480000 CSU* 18490000 CSU* IF (KPBUGF.EQ.3) CALL DUMP(8200,BULK(NYARRV),1 ,KPPRNT) 18500000 CSU* 18510000 C=======================================================================18520000 C STEP 15 TRANSFER THE DATA BACK TO THE 370 18530000 C 18540000 C CALL VPSS (APUNIT, 'VGET', OTR, NOSAMP, APOTR, 0) 18550000 NXARRV = APOTR + 0 18560000 CALL ARMVE (BULK(NXARRV), OTR , NOSAMP) 18570000 C 18580000 C IF (KPBUGF.EQ.3) CALL DUMP(9999,BULK(NXARRV),NOSAMP,KPPRNT) 18590000 C 18600000 C ======================================================================18610000 CSU* CALL VPSS (APUNIT,'VGET', COM(APINDX+30), 6, APAMAX, 0) 18620000 CSU* NXARRV = APAMAX + 0 18630000 CSU* CALL SCOPY (6 , BULK(NXARRV), 1, COM(APINDX+30), 1) 18640000 C 18650000 C 18660000 C ======================================================================18670000 C TRANSLATE THE VPSS COMMANDS 18680000 C 18690000 CIBM CALL VPSS (APUNIT, 'XLTE', APAGCX) 18700000 C 18710000 C 18720000 C SAVE LOCAL VARIABLES BEFORE EXIT 18730000 C 18740000 CIBM DO 415 I = 1, LLOCAL 18750000 CIBM5 COM(KPIRSM+I-1) = DLOCAL(I) 18760000 GO TO 9480 18770000 C 18780000 C 18790000 C 18800000 ENTRY APAGCS ( NS, INTR, OTR ) 18810000 C 18820000 C GET NECESSARY VALUES FROM DLOCAL 18830000 C 18840000 PMODSV = COM(KPIRSM+ 26) 18850000 PRCAGC = XCOM(KPIRSM+ 68) 18860000 CIBM XFFTSC = XCOM(KPIRSM+ 71) 18870000 C 18880000 C DETERMINE IF WINDOW MULTIPLIER OR SPECIFIC 18890000 C WINDOWS ARE INPUT 18900000 C 18910000 MLTSPC = 0 18920000 C 18930000 C TEST FOR WHICH VARIATION OF AGC 18940000 C 'A' IS SLIDING WINDOW. 18950000 C 'B' IS USING A WINDOW MULTIPLIER. 18960000 C 'C' IS INPUTING A SPECIFIC WINDOW. 18970000 C 18980000 IF (S1CPCH (PMODSV, 4, 'B', 1, 1) .EQ. 0) MLTSPC = 1 18990000 IF (S1CPCH (PMODSV, 4, 'C', 1, 1) .EQ. 0) MLTSPC = 1 19000000 C 19010000 C ALLOCATE SPACE FOR 3838 WORK 19020000 C 19030000 IC = KPIUSM 19040000 APINDX = IC 19050000 IC = IC + 33 19060000 IF (MLTSPC .NE. 1) GO TO 8500 19070000 MXWIND = NS /3 19080000 APCESW = IC 19090000 APCMDW = APCESW + MXWIND * 2 19100000 APCMUL = APCMDW + MXWIND 19110000 APCMDF = APCMUL + MXWIND 19120000 IC = APCMDF + MXWIND 19130000 C 19140000 8500 CONTINUE 19150000 APMOVE = IC - APINDX 19160000 C 19170000 CIBM CIT = IC 19180000 CIBM IC = IC + LCIT 19190000 CIBM J = LOC(COM(IC)) 19200000 CIBM I = J - (J/8) * 8 19210000 CIBM IF (I .NE. 0) IC = IC + 1 19220000 CIBM CCW = IC 19230000 CIBM LCCW = 200 19240000 CIBM IC = IC + LCCW 19250000 C 19260000 C RESERVE BLANK COMMON AREA 19270000 C 19280000 NOWDS = IC - KPIUSM 19290000 CALL UPRESM (NOWDS) 19300000 IF (NOWDS.EQ.0) GO TO 9000 19310000 C 19320000 COM ( KPIRSM+ 54) = APINDX 19330000 COM ( KPIRSM+ 57) = MLTSPC 19340000 COM ( KPIRSM+ 58) = APCESW 19350000 COM ( KPIRSM+ 59) = APCMDW 19360000 COM ( KPIRSM+ 60) = APCMUL 19370000 COM ( KPIRSM+ 61) = APCMDF 19380000 COM ( KPIRSM+ 66) = APMOVE 19390000 C 19400000 C INITIALIZE 3838 PARAMETERS 19410000 C 19420000 DO 8600 I = 1, 15 19430000 8600 COM(APINDX+I-1) = 0 19440000 C 19450000 XCOM(APINDX+8) = NS /10 19460000 XCOM(APINDX+15) = 1.0 19470000 XCOM(APINDX+17) = 0.0 19480000 XCOM(APINDX+18) = XLIMIT 19490000 XCOM(APINDX+19) = 1.0 19500000 XCOM(APINDX+20) = XLIMIT 19510000 XCOM(APINDX+21) = 0.0 19520000 XCOM(APINDX+22) = XMAXVL 19530000 XCOM(APINDX+23) = XMAXVL 19540000 XCOM(APINDX+24) = XLIMIT 19550000 XCOM(APINDX+25) = 1.0 19560000 XCOM(APINDX+26) = XMAXVL 19570000 XCOM(APINDX+27) = XMAXVL 19580000 XCOM(APINDX+28) = XLIMIT 19590000 XCOM(APINDX+29) = XMAXVL 19600000 CIBM XCOM(APINDX+30) = XFFTSC 19610000 XCOM(APINDX+31) = PRCAGC 19620000 XCOM(APINDX+32) = 1.0 - PRCAGC 19630000 C 19640000 RETURN 19650000 C 19660000 C ERROR DIAGNOSTICS AND EXIT 19670000 C 19680000 9000 WRITE (KPPRNT, 9900) 19690000 GO TO 9470 19700000 C 19710000 9010 WRITE (KPPRNT, 9910) 19720000 GO TO 9470 19730000 C 19740000 9020 WRITE (KPPRNT, 9920) 19750000 GO TO 9470 19760000 C 19770000 9470 KPRTF = -1 19780000 C 19790000 9480 CONTINUE 19800000 RETURN 19810000 C 19820000 9900 FORMAT (/5X,'*** NOT ENOUGH MEMORY AVAILABLE IN APAGCX***') 19830000 C 19840000 9910 FORMAT (/5X,'*** FFT TRANSFORM ERROR IN APAGCX***') 19850000 C 19860000 9920 FORMAT (/5X,'*** INVERSE FFT TRANSFORM ERROR IN APAGCX***') 19870000 C 19880000 C ==================================================================== 19890000 C END 19900000 C 19910000 C ==================================================================== 19920000 C FOLLOWING ROUTINES ARE USEFUL FOR CHECKING AP 19930000 C SIMULATION ON 3081 CPU 19940000 C ==================================================================== 19950000 C ==================================================================== 19960000 C 19970000 C SUBROUTINE SCOPY ( N, FROM, INCF, TO, INCT ) 19980000 C DIMENSION FROM(1) 19990000 C DIMENSION TO (1) 20000000 C 20010000 C IF = 1 20020000 C IT = 1 20030000 C 20040000 C DO 100 J=1,N 20050000 C TO(IT) = FROM(IF) 20060000 C IF = IF + INCF 20070000 C 100 IT = IT + INCT 20080000 C 20090000 C RETURN 20100000 C END 20110000 C 20120000 C ==================================================================== 20130000 C ==================================================================== 20140000 C ==================================================================== 20150000 C 20160000 C FUNCTION ISAMAX ( N, SX, INCX ) 20170000 C DIMENSION SX (1) 20180000 C 20190000 C TEST = ABS(SX(1)) 20200000 C I = 1 20210000 C K = 1 20220000 C 20230000 C DO 100 J=1,N 20240000 C IF ( ABS(SX(I)).GT.TEST ) K=J 20250000 C IF ( ABS(SX(I)).GT.TEST ) TEST=ABS(SX(I)) 20260000 C I = I + INCX 20270000 C 100 CONTINUE 20280000 C 20290000 C ISAMAX = K 20300000 C RETURN 20310000 C END 20320000 C 20330000 C ==================================================================== 20340000 C ==================================================================== 20350000 C ==================================================================== 20360000 C 20370000 C 20380000 C FUNCTION ISAMIN ( N, SX, INCX ) 20390000 C DIMENSION SX (1) 20400000 C 20410000 C TEST = ABS(SX(1)) 20420000 C I = 1 20430000 C K = 1 20440000 C 20450000 C DO 100 J=1,N 20460000 C IF ( ABS(SX(I)).LT.TEST ) K=J 20470000 C IF ( ABS(SX(I)).LT.TEST ) TEST=ABS(SX(I)) 20480000 C I = I + INCX 20490000 C 100 CONTINUE 20500000 C 20510000 C ISAMIN = K 20520000 C RETURN 20530000 C END 20540000 C 20550000 C ==================================================================== 20560000 C ==================================================================== 20570000 C ==================================================================== 20580000 C 20590000 C 20600000 C FUNCTION CVMGT ( X, Y, TEST ) 20610000 C REAL CVMGT 20620000 C REAL X 20630000 C REAL Y 20640000 C LOGICAL TEST 20650000 C 20660000 C IF (TEST) CVMGT=X 20670000 C IF (.NOT.TEST) CVMGT=Y 20680000 C RETURN 20690000 C END 20700000 C 20710000 C ==================================================================== 20720000 C ==================================================================== 20730000 C ==================================================================== 20740000 C 20750000 C 20760000 C SUBROUTINE DUMP ( N, X, L, IPR ) 20770000 C REAL X(2) 20780000 C 20790000 C M = L 20800000 C IF (M.GT.100 ) M = 100 20810000 C WRITE(IPR , 90) N 20820000 C 90 FORMAT(2X,I6,'------------------------------------------') 20830000 C WRITE(IPR ,100) (X(I),I=1,M) 20840000 C100 FORMAT(2X,10E13.5) 20850000 C 20860000 C RETURN 20870000 END 20880000