CTITLESAUMIG -- APPLY REVERSE MIGRATION 00010001 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR N.L.C 00020000 CA DESIGNER RALPH MCMILLAN 00030000 CA LANGUAGE FORTRAN 00040000 CA SYSTEM IBM AND CRAY 00050000 CA WRITTEN 11-01-84 00060000 C REVISED 11-01-84 LBL. COMMENTED OUT A VPSS CALL. 00070000 C DUAL PATH FOR IBM AND CRAY-- IBM 00080000 C USES MINVT/MSOLV AS TRID SOLVER 00090000 C CRAY USES DECOMP/SOLVE. 00100000 C REVISED 07-10-86 ESN. FOR IBM VECTORIZATION. 00110000 C REVISED 07-28-87 ESN. TO CALL THE IBM ESSL TRI-D 00120000 C ROUTINES. 00130000 C REVISED 02-17-88 FAC COPIED FROM SASMIG FOR DEVELOPMENT 00140000 C OF UMIG BY NLC. 00150000 C REVISED 06-30-88 ESN. FOR PRODUCTION RELEASE. 00160000 C REVISED 09-19-89 ESN. REMOVE ALL REFERENCES TO AP CODE. 00170001 C REVISED 05-04-90 LWC. CHANGED INDEX AND CALLS TO DIAGONAL 00171001 C SOLVER. 00172001 CA 00180000 CA 00190000 CA CALL SAUMIG (X, NOSAMP, NB, NSAVE, NBUF, LBUF, NI, SEGN, START, 00200000 CA ALPHA, FATEN1, FATEN2, A, SIGMA, AOFF, ADIAG, GT, 00210000 CA V, FT, TEST, F, TEMPU, RV) 00220001 CA I / O X = BUFFER CONTAINING A BLOCK OF MUTLIPLEXED R4 00230000 CA SAMPLES 00240000 CA INPUT NOSAMP = NUMBER OF SAMPLES IN A TRACE I4 00250000 CA INPUT NB = NUMBER OF TRACES (INCLUDING ZERO BORDER) I4 00260000 CA INPUT NSAVE = NUMBER OF TRACES USED TO BLOCK INPUT I4 00270000 CA INPUT NBUF = NUMBER OF BUFFERS NEEDED TO TO READ A I4 00280000 CA BLOCK FROM THE WORK FILE 00290000 CA INPUT LBUF = LENGTH OF A WORK FILE BUFFER I4 00300000 CA INPUT NI = NUMBER OF TIME SAMPLES REPRESENTED IN A I4 00310000 CA BLOCK OF DATA WRITTEN TO WORK FILE 00320000 CA INPUT SEGN = CURRENT SEGMENT IN TIME BEING PROCESSED I4 00330000 CA INPUT START = SAMPLE COUNT TO START MIGRATION I4 00340000 CA INPUT ALPHA = R4 00350000 CA INPUT FATEN1 = FREQUENCY ATTENUATION FACTOR 1 R4 00360000 CA INPUT FATEN2 = FREQUENCY ATTENUATION FACTOR 2 R4 00370000 CA I / O A = R4 00380000 CA I / O SIGMA = BLOCK TRANSITION STATE R4 00390000 CA I / O AOFF = TEMPORARY ARRAY TO HOLD OFF DIAGONAL R4 00400000 CA ELEMENTS OF TRIDIAGONAL MATRIX 00410000 CA I / O ADIAG = TEMPORARY ARRAY TO HOLD DIAGONAL R4 00420000 CA ELEMENTS OF TRIDIAGONAL MATRIX 00430000 CA I / O GT = TEMPORARY ARRAY R4 00440000 CA I / O V = TEMPORARY ARRAY (CAN BE SAME ARRAY AS R4 00450000 CA ADIAG) 00460000 CA I / O FT = TEMPORARY ARRAY (CAN BE SAME ARRAY AS A) R4 00470000 CA I / O TEST = TEMPORARY ARRAY R4 00480000 CA I / O F = TEMPORARY ARRAY R4 00490000 CA I / O TEMPU = TEMPORARY ARRAY R4 00500000 CA 00510000 CA 00520000 CA THIS ROUTINE APPLIES REVERSE MIGRATION TO A SEGMENT OF A SECTION. 00530001 CA 00540000 C EJECT 00550000 C 00560000 C LOCAL VARIABLES AND CONSTANTS (INTERNAL TO SUBROUTINE). 00570000 C 00580000 C B = TEMPORARY VALUE USED FOR AVERAGING R4 00590000 C CLIPV = SCALED VALUED FOR CLIPPING (= CLIP * IMAX) I4 00600000 C CNT = NUMBER OF CHARACTERS IN SCALED VALUES I4 00610000 C IMAX = MAXIMUM SCALED VALUE (EITHER 9 OR 99) I4 00620000 C INC = INCREMENT TO KEEP NUMBER OF POINTS .LE. 120 I4 00630000 C POINT = ONE WORD OF '.' CHARACTERS I4 00640000 C SCALE = SCALING FACTOR R4 00650000 C TEMP = TEMPORARY SCALED VALUE I4 00660000 C 00670000 C EJECT 00680000 SUBROUTINE SAUMIG (X, NOSAMP, NB, NSAVE, NBUF, LBUF, NI, SEGN, 00690000 * START, ALPHA, FATEN1, FATEN2, A, SIGMA, 00700000 * AOFF, ADIAG, GT, V, FT, TEST, F, TEMPU, RV) 00710001 C 00720000 IMPLICIT INTEGER (A-Z) 00730000 C 00740000 C 00750000 C REAL ARRAYS IN PARAMETER LIST. 00760000 REAL A (1) 00770000 REAL ADIAG (1) 00780000 REAL AOFF (1) 00790000 REAL F (1) 00800000 REAL FT (1) 00810000 REAL GT (1) 00820000 REAL SIGMA (1) 00830000 REAL TEMPU (1) 00840000 REAL TEST (1) 00850000 REAL V (1) 00860000 REAL X (1) 00870000 C 00880000 C 00890000 C REAL VARIABLES IN PARAMETER LIST. 00900000 REAL ALPHA 00910000 REAL FATEN1 00920000 REAL FATEN2 00930000 REAL RV,RVB,CA 00940000 C 00950000 C-------- DUAL PATH 00960000 C 00970000 COMMON /SYSTEM/ SYSTEM 00980000 C 00990000 IF (S1CPCH(SYSTEM,1,'CRAY',1,4) .EQ. 0) GO TO 2000 01000000 C 01010000 C------- IBM ROUTE 01020000 C 01030000 ADUM = 1 01040000 BDUM = ADUM + 2*NB 01050000 CDUM = BDUM + 2*NB 01060000 DDUM = CDUM + 2*NB 01070000 C 01080000 NBM1 = NB - 1 01090000 RVB = ( 1.0 - RV )/ ( 1.0 + RV ) 01100000 C 01110000 C******************************************* 01120000 C******* IF(IVV.EQ.2) GO TO 11 01130000 C************************************** 01140000 DO 10 01150000 * I = 1, NB 01160000 CA = A(I)/(1.0+RVB) 01170000 GT(I) = (1.0+RV) * CA 01180000 AOFF(I) = ALPHA - CA 01190000 ADIAG(I) = 1. - 2. * AOFF(I) 01200000 A(I) = ALPHA + CA 01210000 C 01220000 10 CONTINUE 01230000 C 01240000 CESSL CALL MINVT (AOFF, ADIAG, AOFF, NB, TEST, F) 01250000 DO 1150 L = 1, NB 01260000 1150 TEST(ADUM-1+L) = AOFF(L) 01270000 DO 1151 L = 1, NB 01280000 1151 TEST(BDUM-1+L) = ADIAG(L) 01290000 DO 1152 L = 1, NB 01300000 1152 TEST(CDUM-1+L) = AOFF(L) 01310000 TEST(BDUM) = -TEST(CDUM) 01320000 TEST(ADUM-1+NB) = -TEST(BDUM-1+NB) 01330000 CX CALL MEINVT (TEST(ADUM), TEST(BDUM), TEST(CDUM), NB, 01340000 CX * TEST(BDUM), TEST(CDUM)) 01350000 CALL SGTNPF (NB, TEST(ADUM), TEST(BDUM), TEST(CDUM), 0) 01360000 C 01370000 C******************************* 01380000 11 CONTINUE 01390000 C********************************** 01400000 DO 60 01410000 * I = START, NI 01420000 C*NLC II = NI - I + START 01430003 II = I 01440003 IF ((SEGN-1) * NI + II .GT. NOSAMP) GO TO 60 01450000 IC = (II - 1) * NSAVE + 1 01460000 IC1 = 1 01470000 C 01480000 DO 20 01490000 * J = 1, NBUF 01500000 DO 15 L = 1, NSAVE 01510000 15 TEMPU(IC1+L-1) = X(IC+L-1) 01520000 IC = IC + LBUF 01530000 IC1 = IC1 + NSAVE 01540000 C 01550000 20 CONTINUE 01560000 C 01570000 DO 30 01580001 * J = 2, NBM1 01590000 CESSL V(J) = TEMPU(J) + 01600000 TEST(DDUM-1+J) = TEMPU(J) + 01610000 * A(J) * (TEMPU(J+1)+TEMPU(J-1) - 2.*TEMPU(J)) + 01620000 * GT(J) * (SIGMA(J+1)+SIGMA(J-1) - 2.*SIGMA(J)) 01630000 C 01640000 30 CONTINUE 01650000 TEST(DDUM-1+1) = 0.0 01660000 TEST(DDUM-1+NB) = 0.0 01670000 C 01680000 CESSL CALL MSOLV (AOFF, TEST, F, NB, FT, V) 01690000 CX CALL MESOLV (TEST(ADUM), TEST(BDUM), TEST(CDUM), 01700000 CX * NB, TEST(DDUM), TEST(DDUM)) 01710000 CALL SGTNPS (NB, TEST(ADUM), TEST(BDUM), TEST(CDUM), 01720000 * TEST(DDUM)) 01730000 C 01740000 DO 50 01750000 * J = 1, NB 01760000 CESSL SIGMA(J)=SIGMA(J)*RV + FT(J) * FATEN1 + TEMPU(J) * FATEN2 01770000 SIGMA(J)=SIGMA(J)*RV+TEST(DDUM-1+J)*FATEN1+TEMPU(J)*FATEN201780000 C 01790000 50 CONTINUE 01800000 C 01810000 IC = (II - 1) * NSAVE + 1 01820001 IC1 = 1 01830000 C 01840000 DO 40 01850000 * J = 1, NBUF 01860000 DO 37 L = 1, NSAVE 01870000 CESSL X(IC+L-1) = FT(IC1+L-1) 01880000 X(IC+L-1) = TEST(DDUM-1+IC1+L-1) 01890000 37 CONTINUE 01900000 IC = IC + LBUF 01910000 IC1 = IC1 + NSAVE 01920000 C 01930000 40 CONTINUE 01940000 C 01950000 60 CONTINUE 01960000 C 01970000 RETURN 01980000 C 01990000 C------ CRAY ROUTE 02000000 C 02010000 2000 CONTINUE 02020000 C 02030000 ADUM = 1 02040000 BDUM = ADUM + 2 * NB 02050000 CDUM = BDUM + 2 * NB 02060000 DDUM = CDUM + 2 * NB 02070000 C 02080000 NBM1 = NB - 1 02090000 RVB = ( 1.0 - RV )/ ( 1.0 + RV ) 02100000 C 02110000 C***************************************** 02120000 C******* IF(IVV.EQ.2) GO TO 101 02130000 C************************************* 02140000 DO 100 02150000 * I = 1, NB 02160000 CA = A(I)/(1.0+RVB) 02170000 GT(I) = (1.0+RV) * CA 02180000 AOFF(I) = ALPHA - CA 02190000 ADIAG(I) = 1. - 2. * AOFF(I) 02200000 A(I) = ALPHA + CA 02210000 C 02220000 100 CONTINUE 02230000 C*************************************** 02240000 101 CONTINUE 02250000 C*********************************** 02260000 C 02270000 CDIR$ IVDEP 02280000 DO 150 L = 1, NB 02290000 TEST(BDUM-1+L) = ADIAG(L) 02300000 TEST(CDUM +L) = AOFF(L) 02311002 150 CONTINUE 02312002 DO 170 L = 2, NB 02320000 TEST(ADUM +L-1) = AOFF(L) 02331002 170 CONTINUE 02332002 TEST(BDUM) = -TEST(CDUM + 1) 02340002 TEST(ADUM +NB-1) = -TEST(BDUM-1+NB) 02350002 CALL DECOM1 (TEST(BDUM), TEST(ADUM), TEST(CDUM), NB) 02360002 C 02370000 DO 600 02380000 * I = START, NI 02390000 C*NCL II = NI - I + START 02400003 II = I 02410003 IF ((SEGN-1) * NI + II .GT. NOSAMP) GO TO 600 02420000 IC = (II - 1) * NSAVE + 1 02430000 IC1 = 1 02440000 C 02450000 DO 200 02460000 * J = 1, NBUF 02470000 DO 180 L = 1, NSAVE 02480000 180 TEMPU(IC1+L-1) = X(IC+L-1) 02490000 IC = IC + LBUF 02500000 IC1 = IC1 + NSAVE 02510000 C 02520000 200 CONTINUE 02530000 C 02540000 DO 300 02550001 * J = 2, NBM1 02560000 TEST(DDUM-1+J) = TEMPU(J) + 02570000 * A(J) * (TEMPU(J+1)+TEMPU(J-1) - 2.*TEMPU(J)) + 02580000 * GT(J) * (SIGMA(J+1)+SIGMA(J-1) - 2.*SIGMA(J)) 02590000 C 02600000 300 CONTINUE 02610000 TEST(DDUM-1+1) = 0.0 02620000 TEST(DDUM-1+NB) = 0.0 02630000 C 02640000 CALL SOLV1 (TEST(BDUM), TEST(ADUM), TEST(CDUM), TEST(DDUM), NB) 02650002 C 02660000 DO 500 02670000 * J = 1, NB 02680000 SIGMA(J)=SIGMA(J)*RV + TEST(DDUM-1+J) * FATEN1 + TEMPU(J) * FATEN202690000 C 02700000 500 CONTINUE 02710000 C 02720000 IC = (II - 1) * NSAVE + 1 02730001 IC1 = 1 02740000 C 02750000 DO 400 02760000 * J = 1, NBUF 02770000 DO 370 L = 1, NSAVE 02780000 X(IC+L-1) = TEST(DDUM-1+IC1+L-1) 02790000 370 CONTINUE 02800000 IC = IC + LBUF 02810000 IC1 = IC1 + NSAVE 02820000 C 02830000 400 CONTINUE 02840000 C 02850000 600 CONTINUE 02860000 C 02870000 RETURN 02880000 C 02890000 END 02900000