CTITLES2TWZR -- FAN FILTER APPLICATION 00000100 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR H. HOOGSTRAAT 00000200 CA DESIGNER H. HOOGSTRAAT 00000300 CA LANGUAGE FORTRAN 00000400 CA SYSTEM IBM AND CRAY 00000500 CA WRITTEN 00000600 C REVISED 06-10-76 BY R. MCMILLAN TO CONVERT S1TWZR. 00000700 C PARAMETER LIST WAS CHANGED AND 00000800 C INITIALIZATION WAS DELETED TO 00000900 C ALLOW SERIAL REUSABLE. 00001000 C REVISED 07-22-76 BY R. MCMILLAN TO CHANGE ROLLOFF 00001100 C ON REJECT FILTER. 00001200 C REVISED 08-27-76 BY R. MCMILLAN TO CHANGE ROLLOFF 00001300 C TO A SLOPE LIKE DIP. 00001400 C REVISED 11-18-81 BY S. NELAN FOR THE CRAY. 00001500 C REVISED 12-05-84 BY LBL. MADE SURE THIS CODE RAN 00001600 C ON IBM AND CRAY. 00001700 CA 00001800 CA 00001900 CA CALL S2TWZR (X, INDEX, LLSLP, LHSLP, RLSLP, RHSLP, LFOURX, 00002000 CA LFOURY, LLROLL, LHROLL, RLROLL, RHROLL, 00002100 CA PASSF, LPASS, HPASS, BACK) 00002200 CA 00002300 CA I/O X = COMPLEX TRANFORM C4 00002400 CA INPUT INDEX = HORIZONTAL FREQUENCY INDEX I4 00002500 CA INPUT LLSLP = LEFT LOW DIP SLOPE R4 00002600 CA INPUT LHSLP = LEFT HIGH DIP SLOPE R4 00002700 CA INPUT RLSLP = RIGHT LOW DIP SLOPE R4 00002800 CA INPUT RHSLP = RIGHT HIGH DIP SLOPE R4 00002900 CA INPUT LFOURX = LENGTH OF VERTICAL TRANSFORM I4 00003000 CA INPUT LFOURY = LENGTH OF HORIZONTAL TRANSFORM I4 00003100 CA INPUT LLROLL = LEFT LOW ROLL-OFF AS A SLOPE R4 00003200 CA INPUT LHROLL = LEFT HIGH ROLL-OFF AS A SLOPE R4 00003300 CA INPUT RLROLL = RIGHT LOW ROLL-OFF AS A SLOPE R4 00003400 CA INPUT RHROLL = RIGHT HIGH ROLL-OFF AS A SLOPE R4 00003500 CA INPUT PASSF = 1 BANDPASS FILTERING I4 00003600 CA = 2 BAND REJECT FILTERING 00003700 CA INPUT LPASS = ABSOLUTE LOW PASS FREQUENCY INDEX I4 00003800 CA INPUT HPASS = ABSOLUTE HIGH PASS FREQUENCY INDEX I4 00003900 CA INPUT BACKG = BACKGROUND PERCENTAGE R4 00004000 CA 00004100 CA 00004200 CA S2TWZR APPLIES FAN FILTERING TO THE TRANSFORMS IN X AND Y. 00004300 C 00004400 C 00004500 C ====================================================== 00004600 C * PROGRAM DEVELOPED BY 00004700 C * H * HOOGSTRAAT PROGRAMMING SERVICES LTD. 00004800 C * P S * BOX 20, SITE 7, SS #1 00004900 C * * * * * * * CALGARY, ALTA. CANADA PH 288-8088 00005000 C ====================================================== 00005100 C 00005200 C 00005300 C LOCAL VARIABLES AND CONSTANTS (INTERNAL TO SUBROUTINE). 00005400 C 00005500 C FACT = FACTOR USED IN ROLL-OFF R4 00005600 C FOURX = VERITCAL TRANSFORM LENGTH CONVERTED TO REAL R4 00005700 C FOURY = HORIZONTAL TRANSFORM LENGTH CONVERTED TO REAL R4 00005800 C HC = HIGH CUT INDEX I4 00005900 C HCHOLD = TEMPORARY HC I4 00006000 C HC1 = STARTING OR ENDING INDEX FOR APPLYING HIGH FILTER I4 00006100 C HP = HIGH PASS INDEX (INCLUDES THE ROLL-OFF) I4 00006200 C LC = LOW CUT INDEX I4 00006300 C LCHOLD = TEMPORARY LC I4 00006400 C LC1 = STARTING OR ENDING INDEX FOR APPLYING LOW FILTER I4 00006500 C LC2 = USED IN REJECT FILTER WHEN ROLL-OFF IS APPLIED I4 00006600 C LF2 = LF21 + 1 I4 00006700 C LF21 = ONE HALF HORIZONTAL TRANSFORM LENGTH I4 00006800 C LP = LOW PASS INDEX I4 00006900 C LP1 = USED IN REJECT ROLL-OFF I4 00007000 C NN = USED AS INDEX TO ARRAY X I4 00007100 C RATIO = USED TO CALCULATE INDICIES FOR FILTER R4 00007200 C RR = USED TO CALCULATE BACKGROUND FACTOR FOR ROLL-OFF R4 00007300 C XNDEX = HORIZONTAL FREQUENCY INDEX CONVERTED TO REAL R4 00007400 C 00007500 C 00007600 SUBROUTINE S2TWZR (X, INDEX, LLSLP, LHSLP, RLSLP, RHSLP, LFOURX, 00007700 * LFOURY, LLROLL, LHROLL, RLROLL, RHROLL, 00007800 * PASSF, LPASS, HPASS, BACK) 00007900 C 00008000 IMPLICIT INTEGER (A-Z) 00008100 C 00008200 C 00008300 C REAL VARIABLES IN PARAMETER LIST. 00008400 REAL BACK 00008500 REAL LHROLL 00008600 REAL LHSLP 00008700 REAL LLROLL 00008800 REAL LLSLP 00008900 REAL RHROLL 00009000 REAL RHSLP 00009100 REAL RLROLL 00009200 REAL RLSLP 00009300 REAL X (1) 00009400 C 00009500 C 00009600 C REAL VARIABLES AND CONSTANTS--LOCAL (INTERNAL TO SUBROUTINE). 00009700 REAL FACT 00009800 REAL FOURX 00009900 REAL FOURY 00010000 REAL RATIO 00010100 REAL RR 00010200 REAL XNDEX 00010300 C 00010400 C 00010500 IF (INDEX .GE. HPASS .OR. INDEX .LT. LPASS) GO TO 300 00010600 C 00010700 FOURY = LFOURY 00010800 FOURX = LFOURX 00010900 XNDEX = INDEX 00011000 RATIO = XNDEX * FOURY / FOURX 00011100 IF (RATIO.LE.0.) RATIO = 1. / 1000. 00011200 C 00011300 LF21 = LFOURY / 2 00011400 LF2 = LF21 + 1 00011500 C 00011600 NN = LF2 + LF2 - 1 00011700 X(NN ) = X(NN ) * BACK 00011800 X(NN+1) = X(NN+1) * BACK 00011900 IF (PASSF .NE. 1) GO TO 160 00012000 C 00012100 LP = LLSLP * RATIO + 1.5 00012200 LC = LLROLL * RATIO + 1.5 00012300 IF (LP .GT. LF21) LP = LF21 00012400 RR = LP - LC + 1 00012500 LCHOLD = LC 00012600 IF (LCHOLD .LT. 1) LCHOLD = 1 00012700 IF (LCHOLD .GE. LP) GO TO 20 00012800 C 00012900 DO 10 00013000 * I = LCHOLD, LP 00013100 FACT = (I - LC + 1 ) / RR 00013200 IF (FACT .LT. BACK) FACT = BACK 00013300 NN = I + I - 1 00013400 X(NN ) = X(NN ) * FACT 00013500 C 00013600 10 X(NN+1) = X(NN+1) * FACT 00013700 C 00013800 20 IF (LC.GT.LF2) LC = LF2 00013900 LC1 = LC - 1 00014000 IF (LC1.LT.1) GO TO 40 00014100 C 00014200 CRAY DO 30 00014300 CRAY * I = 1, LC1 00014400 CRAY NN = I + I - 1 00014500 CRAY X(NN ) = X(NN ) * BACK 00014600 C 00014700 CRA30 X(NN+1) = X(NN+1) * BACK 00014800 C 00014900 IEND = LC1 * 2 00015000 DO 30 00015100 * I = 1, IEND 00015200 30 X(I) = X(I) * BACK 00015300 C 00015400 40 HP = LHSLP * RATIO + 1.5 00015500 HC = LHROLL * RATIO + 1.5 00015600 IF (HP.GT.LF2) HP = LF2 00015700 RR = HC - HP + 1 00015800 HCHOLD = HC 00015900 IF (HCHOLD.GT.LF21) HCHOLD = LF21 00016000 IF (HP.GE.HCHOLD) GO TO 60 00016100 C 00016200 DO 50 00016300 * I = HP, HCHOLD 00016400 FACT = (HC - I + 1) / RR 00016500 IF (FACT .LT. BACK) FACT = BACK 00016600 NN = I + I - 1 00016700 X(NN ) = X(NN ) * FACT 00016800 C 00016900 50 X(NN+1) = X(NN+1) * FACT 00017000 C 00017100 60 IF (HC .LT. 0) HC = 0 00017200 HC1 = HC + 1 00017300 IF (HC1 .GT. LF21) GO TO 80 00017400 C 00017500 CRAY DO 70 00017600 CRAY * I = HC1, LF21 00017700 CRAY NN = I + I - 1 00017800 CRAY X(NN ) = X(NN ) * BACK 00017900 C 00018000 CRA70 X(NN+1) = X(NN+1) * BACK 00018100 C 00018200 IST = 2 * HC1 - 1 00018300 IEND = 2 * LF21 00018400 DO 70 00018500 * I = IST, IEND 00018600 70 X(I) = X(I) * BACK 00018700 C 00018800 80 LP = RLSLP * RATIO + 1.5 00018900 LC = RLROLL * RATIO + 1.5 00019000 IF (LP .GT. LF21) LP = LF21 00019100 RR = LP - LC + 1 00019200 LCHOLD = LC 00019300 IF (LCHOLD .LT. 1) LCHOLD = 1 00019400 IF (LCHOLD .GE. LP) GO TO 100 00019500 C 00019600 DO 90 00019700 * I = LCHOLD, LP 00019800 K = LFOURY + 2 - I 00019900 IF (K .GT. LFOURY) GO TO 90 00020000 FACT = (I - LC + 1) / RR 00020100 IF (FACT .LT. BACK) FACT = BACK 00020200 NN = K + K - 1 00020300 X(NN ) = X(NN ) * FACT 00020400 X(NN+1) = X(NN+1) * FACT 00020500 C 00020600 90 CONTINUE 00020700 C 00020800 100 IF (LC .GT. LF2) LC = LF2 00020900 K = LFOURY + 3 - LC 00021000 IF (K .GT. LFOURY) GO TO 120 00021100 C 00021200 CRAY DO 110 00021300 CRAY * I = K, LFOURY 00021400 CRAY NN = I + I - 1 00021500 CRAY X(NN ) = X(NN ) * BACK 00021600 C 00021700 CR110 X(NN+1) = X(NN+1) * BACK 00021800 C 00021900 IST = 2 * K - 1 00022000 IEND = 2 * LFOURY 00022100 DO 110 00022200 * I = IST, IEND 00022300 110 X(I) = X(I) * BACK 00022400 C 00022500 120 HP = RHSLP * RATIO + 1.5 00022600 HC = RHROLL * RATIO + 1.5 00022700 IF (HP .GT. LF2) HP = LF2 00022800 RR = HC - HP + 1 00022900 HCHOLD = HC 00023000 IF (HCHOLD .GT. LF21) HCHOLD = LF21 00023100 IF (HP .GE. HCHOLD) GO TO 140 00023200 C 00023300 DO 130 00023400 * I = HP, HCHOLD 00023500 K = LFOURY + 2 - I 00023600 IF (K .GT. LFOURY) GO TO 130 00023700 FACT = (HC - I + 1) / RR 00023800 IF (FACT .LT. BACK) FACT = BACK 00023900 NN = K + K - 1 00024000 X(NN ) = X(NN ) * FACT 00024100 X(NN+1) = X(NN+1) * FACT 00024200 C 00024300 130 CONTINUE 00024400 C 00024500 140 IF (HC .LT. 1) HC = 1 00024600 HC1 = LFOURY - HC + 1 00024700 IF (LF2 .GT. HC1) GO TO 300 00024800 C 00024900 CRAY DO 150 00025000 CRAY * I = LF2, HC1 00025100 CRAY NN = I + I - 1 00025200 CRAY X(NN ) = X(NN ) * BACK 00025300 C 00025400 CR150 X(NN+1) = X(NN+1) * BACK 00025500 C 00025600 IST = 2 * LF2 - 1 00025700 IEND = 2 * HC1 00025800 DO 150 00025900 * I = IST, IEND 00026000 150 X(I) = X(I) * BACK 00026100 C 00026200 GO TO 300 00026300 C 00026400 160 LP = LLSLP * RATIO + .5 00026500 LC = LLROLL * RATIO + .5 00026600 HP = LHSLP * RATIO + .5 00026700 HC = LHROLL * RATIO + .5 00026800 IF (LC .LT. HC) GO TO 170 00026900 LC = (LC + HC) / 2 - 1 00027000 HC = LC + 1 00027100 C 00027200 170 HCHOLD = HC 00027300 LCHOLD = LC 00027400 RR = LC - LP + 1 00027500 IF (LP .LT. 0) LP = 0 00027600 IF (LP .GT. LF2) LP = LF2 00027700 IF (LC .LT. 0) LC = 0 00027800 IF (LC .GT. LF2) LC = LF2 00027900 LP1 = LP 00028000 IF (LP1 .LT. 1) LP1 = 1 00028100 IF (LP1 .GT. LC ) GO TO 190 00028200 C 00028300 DO 180 00028400 * I = LP1, LC 00028500 FACT = (LCHOLD - I) / RR 00028600 IF (FACT .LT. BACK) FACT = BACK 00028700 NN = I + I - 1 00028800 X(NN ) = X(NN ) * FACT 00028900 C 00029000 180 X(NN+1) = X(NN+1) * FACT 00029100 C 00029200 190 RR = HP - HC + 1 00029300 IF (HC .LT. 0) HC = 0 00029400 IF (HC .GT. LF2) HC = LF2 00029500 IF (HP .LT. 0) HP = 0 00029600 IF (HP .GT. LF2) HP = LF2 00029700 HC1 = HC 00029800 IF (HC1 .LT. 1) HC1 = 1 00029900 IF (HC1 .GT. HP) GO TO 210 00030000 C 00030100 DO 200 00030200 * I = HC1, HP 00030300 FACT = (I - HCHOLD) / RR 00030400 IF (FACT .LT. BACK) FACT = BACK 00030500 NN = I + I - 1 00030600 X(NN ) = X(NN ) * FACT 00030700 C 00030800 200 X(NN+1) = X(NN+1) * FACT 00030900 C 00031000 210 LC1 = LC + 1 00031100 LC2 = HC - 1 00031200 IF (LC1 .GT. LC2) GO TO 230 00031300 C 00031400 CRAY DO 220 00031500 CRAY * I = LC1, LC2 00031600 CRAY NN = I + I - 1 00031700 CRAY X(NN ) = X(NN ) * BACK 00031800 C 00031900 CR220 X(NN+1) = X(NN+1) * BACK 00032000 C 00032100 IST = 2 * LC1 - 1 00032200 IEND = 2 * LC2 00032300 DO 220 00032400 * I = IST, IEND 00032500 220 X(I) = X(I) * BACK 00032600 C 00032700 230 LP = RLSLP * RATIO + .5 00032800 LC = RLROLL * RATIO + .5 00032900 HP = RHSLP * RATIO + .5 00033000 HC = RHROLL * RATIO + .5 00033100 IF (LC .LT. HC) GO TO 240 00033200 LC = (LC + HC) / 2 - 1 00033300 HC = LC + 1 00033400 C 00033500 240 LCHOLD = LC 00033600 HCHOLD = HC 00033700 RR = LC - LP + 1 00033800 IF (LP .LT. 0) LP = 0 00033900 IF (LP .GT. LF2) LP = LF2 00034000 IF (LC .LT. 0) LC = 0 00034100 IF (LC .GT. LF2) LC = LF2 00034200 LP1 = LP 00034300 IF (LP1 .LT. 1) LP1 = 1 00034400 IF (LP1 .GT. LC) GO TO 260 00034500 C 00034600 DO 250 00034700 * I = LP1, LC 00034800 K = LFOURY + 2 - I 00034900 IF (K .GT. LFOURY) GO TO 250 00035000 FACT = (LCHOLD - I) / RR 00035100 IF (FACT .LT. BACK) FACT = BACK 00035200 NN = K + K - 1 00035300 X(NN ) = X(NN ) * FACT 00035400 X(NN+1) = X(NN+1) * FACT 00035500 C 00035600 250 CONTINUE 00035700 C 00035800 260 RR = HP - HC + 1 00035900 IF (HC .LT. 0) HC = 0 00036000 IF (HC .GT. LF2) HC = LF2 00036100 IF (HP .LT. 0) HP = 0 00036200 IF (HP .GT. LF2) HP = LF2 00036300 HC1 = HC 00036400 IF (HC1 .LT. 1) HC1 = 1 00036500 IF (HC1 .GT. HP) GO TO 280 00036600 C 00036700 DO 270 00036800 * I = HC1, HP 00036900 K = LFOURY + 2 - I 00037000 IF (K .GT. LFOURY) GO TO 270 00037100 FACT = (I - HCHOLD) / RR 00037200 IF (FACT .LT. BACK) FACT = BACK 00037300 NN = K + K - 1 00037400 X(NN ) = X(NN ) * FACT 00037500 X(NN+1) = X(NN+1) * FACT 00037600 C 00037700 270 CONTINUE 00037800 C 00037900 280 LC1 = LC + 1 00038000 LC2 = HC - 1 00038100 IF (LC1 .GT. LC2) GO TO 300 00038200 C 00038300 DO 290 00038400 * I = LC1, LC2 00038500 K = LFOURY + 2 - I 00038600 IF (K .GT. LFOURY) GO TO 290 00038700 NN = K + K - 1 00038800 X(NN ) = X(NN ) * BACK 00038900 C 00039000 290 X(NN+1) = X(NN+1) * BACK 00039100 C 00039200 300 RETURN 00039300 C 00039400 END 00039500