CTITLEMDAQON -- TRANSPOSE OF MNOQAD 00000010 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR D.D. THOMPSON R&D 00000020 CA DESIGNER D.D. THOMPSON R&D 00000030 CA LANGUAGE VS FORTRAN 00000040 CA SYSTEM IBM OR CRAY 00000041 CA WRITTEN 8/16/77 00000050 C REVISED 5/18/79 REP INCORPORATE SUBROUTINE MSCINM 00000060 C REVISED 4/03/80 DJP CODE OPTIMIZATION 00000070 C REVISED 4/29/86 JMP DUAL IBM/CRAY VERSION. 00000071 C REVISED 11/10/89 RDK REMOVE EXTERNAL FOR S1ATP. 00000071 CA 00000080 CA 00000090 CA CALL MDAQON (Q, QQ, IND, LD, LS, NT, D, W, X, Z, NUM, U, BUFV) 00000100 CA 00000110 CA INPUT: IND = BIASED STACKING TABLES I400000120 CA MIN DIMENSION (3,NT) 00000130 CA IND(1,I)= BIASED DEPTH POINT INDEX FOR TRACE I 00000140 CA IND(2,I)= BIASED RECEIVER INDEX FOR TRACE I 00000150 CA IND(3,I)= BIASED SHOT INDEX FOR TRACE I 00000160 CA BIASES ARE DETERMINED SO THAT: 00000170 CA THE LOWEST DEPTH POINT INDEX TO APPEAR IS > OR = 1 00000180 CA LOWEST RECEIVER INDEX TO APPEAR IS > OR = LD+1 00000190 CA LOWEST SHOT INDEX TO APPEAR IS > OR = LR+1. 00000200 CA IT IS ASSUMED THAT THE DEPTH POINT,RECEIVER AND SHOT00000210 CA INDICES ARE EACH PROPORTIONAL TO GROUND POSITION 00000220 CA FROM SOME REFERENCE POINT. EACH OF THE 3 PARAMETER 00000230 CA TYPES,HOWEVER, MAY HAVE A DIFFERENT PROPORTIONALITY 00000240 CA FACTOR AND REFERENCE POINT. 00000250 CA INPUT: D = ARRAY OF OFFSET DISTANCES SQUARED. R400000260 CA (IT IS RECOMMENDED THAT THE DISTANCES BE 00000270 CA NORMALIZED TO MAX. OF 1 BEFORE SQUARING.) 00000280 CA INPUT: W = TRACE WEIGHT ARRAY R400000290 CA THE ERROR IN THE STATIC PREDICTED BY THE MODEL 00000300 CA FOR TRACE I IS WEIGHTED BY W(I) IN THE LEAST 00000310 CA SQUARES OPTIMIZATION. (LENGTH NT) 00000320 CA INPUT: NUM = NUMBER OF CDP ON EACH SIDE OF CENTRAL CDP TO R400000330 CA INCLUDE IN AVERAGE FOR QUADRATIC COEFFICIENT 00000340 CA (NOTE NUM = 0 IS OK) 00000350 CA OUTPUT:X = SCRATCH ARRAY OF LENGTH LS + LD R800000360 CA (ELEMENTS LD+1 -> LS NOT USED) 00000370 CA INPUT: Q = INPUT ARRAY OF MEASURED STATICS FOR EACH TRACE R800000380 CA STATICS NEED ONLY BE RELATIVE WITHIN EACH GATHER 00000390 CA Y IS PRESERVED UPON RETURN. 00000400 CA OUTPUT:QQ = ADJUSTED LAG ARRAY R800000410 CA WORK : Z = WORK ARRAY OF MIN LENGTH LS+LD R800000420 CA (ELEMENTS LD+1 -> LS NOT USED) 00000430 CA INPUT: NT = NUMBER OF TRACES I400000440 CA INPUT: LD = LAST LOCATION FOR CDP COMPONENTS I400000450 CA INPUT: LS > OR = THE LAST BIASED SHOT INDEX TO APPEAR. I400000460 CA IN/OUT: U = ARRAY BEING BUILT. I400000470 CA INPUT: BUFV = USBUFR VARIABLES I400000480 CA 00000490 CA THIS ROUTINE IS THE TRANSPOSE OF THE ROUTINE MNOQAD WHICH 00000500 CA REMOVES CONSTANT AND QUADRATIC LEAST SQUARE COMPONENTS FROM 00000510 CA INPUT LAG VALUES AND LOADS THEM INTO THE OUTPUT LAG ARRAY. 00000520 CA 00000530 SUBROUTINE MDAQON (Q,QQ,IND,LD,LS,NT,D,W,X,Z,NUM,U,BUFV) 00000540 C 00000550 DOUBLE PRECISION U(1) 00000560 DOUBLE PRECISION Z(1) 00000570 DOUBLE PRECISION Q(1) 00000580 DOUBLE PRECISION QQ(1) 00000590 DOUBLE PRECISION X(1) 00000600 DOUBLE PRECISION SNN 00000610 DOUBLE PRECISION SDD 00000620 DOUBLE PRECISION SN 00000630 DOUBLE PRECISION SD 00000640 INTEGER BUFV(7) 00000650 INTEGER DA 00000660 INTEGER S1CPCH 00000661 INTEGER IND(1) 00000670 REAL D(1) 00000680 REAL W(1) 00000690 C 00000700 C 00000710 C 00000720 C EXTERNAL S1ATP 00000730 C 00000731 COMMON /SYSTEM/SYSTEM, SYBYPW, SYLOCF, JAPNMS 00000732 C IF (1.EQ.2) CALL S1ATP C 00000733 NDP = 2 00000734 IF (S1CPCH(SYSTEM, 1, 'CRAY', 1, 4) .EQ. 0) NDP = 1 00000735 C 00000743 CALL ARSET (Z, NDP*LD, 0.) 00000744 CALL ARSET (X, NDP*LD, 0.) 00000750 CALL ARSET (Z(LS+1), NDP*LD, 0.) 00000760 CALL ARSET (X(LS+1), NDP*LD, 0.) 00000770 KEY = 0 00000780 L = 1 00000790 ILAST = 0 00000800 I = 1 00000810 DA = 1 00000820 CALL USBUFR (0, IND, BUFV, DA, I) 00000830 K = IND(1) 00000840 C 00000850 100 SW = 0. 00000860 SYD = 0. 00000870 SY = 0. 00000880 SX = 0. 00000890 SX2 = 0. 00000900 5 CONTINUE 00000910 KK = IND(I) 00000920 IF (KK .NE. K) GO TO 20 00000930 C WEIGHTS SHOULD BE SQUARED BEFORE COMING TO THIS SUBROUTINE. 00000940 C W2 = W(I) * W(I) 00000950 W2 = W(I) 00000960 D1 = D(I) 00000970 D2 = D1 * W2 00000980 SW = SW + W2 00000990 ID2 = (I+NDP-1)/NDP 00001000 SYD = Q(ID2) * D1 + SYD 00001010 SY = Q(ID2) + SY 00001020 SX = D2 + SX 00001030 SX2 = D1 * D2 + SX2 00001040 I = I + BUFV(4) 00001050 IF ( ((I-1)/BUFV(7)*BUFV(7)+1) .EQ. I) 00001060 + CALL USBUFR (5, IND, BUFV, DA, I) 00001070 ILAST = ILAST + 1 00001080 IF (ILAST .LT. NT) GO TO 5 00001090 C 00001100 KEY = 1 00001110 20 IF (SW .EQ. 0.) GO TO 25 00001120 K1 = K + LS 00001130 STOR = SX / SW 00001140 Z(K) = SYD - SY * STOR 00001150 Z(K1) = SX2 - SX * STOR 00001160 X(K) = SY / SW 00001170 X(K1) = STOR 00001180 25 K = KK 00001190 L = I 00001200 IF (KEY .EQ. 0) GO TO 100 00001210 MUM = NUM 00001220 IF (NUM*4+3 .GT. LD) MUM = (LD-3) / 4 00001230 MUMP = MUM+ 1 00001240 MUMT = MUM * 2 00001250 MUMTP = MUMT + 1 00001260 SD = 0. 00001270 IF (MUMT .LE. 0) GO TO 110 00001280 DO 120 00001290 *I = 1, MUMT 00001300 120 SD = SD + Z(LS + I) 00001310 SN = SD 00001320 110 DO 130 00001330 *I = MUMTP, LD 00001340 I1 = I + LS 00001350 SD = SD + Z(I1) 00001360 K = I - MUM 00001370 IF (DABS(SD) .GT. 1.E-30) GO TO 129 00001380 Z(K) = 0. 00001390 GO TO 130 00001400 129 Z(K) = Z(K) / SD 00001410 130 SD = SD - Z(I1-MUMT) 00001420 IF (MUM .LE. 0) GO TO 701 00001430 SN = SN + Z(LS+MUMTP) 00001440 IF (DABS(SN) .LT. 1.E-30) GO TO 600 00001450 DO 140 00001460 *I = 1, MUM 00001470 140 Z(I) = Z(I) / SN 00001480 GO TO 601 00001490 600 CALL ARSET (Z, NDP*MUM, 0.) 00001500 601 SD = SD + Z(LS+LD-MUMT) 00001510 IF (DABS(SD) .LT. 1.E-30) GO TO 700 00001520 K = LD - MUM + 1 00001530 DO 150 00001540 *I = K, LD 00001550 Z(I) = Z(I) / SD 00001560 150 CONTINUE 00001570 GO TO 701 00001580 700 CALL ARSET (Z(K), NDP*MUM, 0.) 00001590 C 00001600 701 SN = 0. 00001610 SD = 0. 00001620 IF (MUM .LE. 0) GO TO 300 00001630 DO 220 00001640 * I = 1, MUM 00001650 SN = SN + Z(I) 00001660 SD = SD + Z(LD-I+1) 00001670 220 CONTINUE 00001680 DO 225 00001690 * I = 1, MUM 00001700 I1 = I + LS 00001710 I2 = LD - I + 1 00001720 I3 = LS + I2 00001730 SN = SN + Z(I+MUM) 00001740 SD = SD + Z(I2-MUM) 00001750 X(I) = X(I) - X(I1) * SN 00001760 X(I2) = X(I2) - X(I3) * SD 00001770 X(I1) = SN 00001780 X(I3) = SD 00001790 225 CONTINUE 00001800 300 SNN = SN 00001810 SDD = SD 00001820 DO 226 00001830 * I = MUMP, MUMTP 00001840 I1 = I + MUM 00001850 I2 = LD - I + 1 00001860 I3 = I2 - MUM 00001870 I4 = I + LS 00001880 I5 = I2 + LS 00001890 SN = SN + Z(I1) 00001900 SNN = SNN + Z(I1) 00001910 SD = SD + Z(I3) 00001920 SDD = SDD + Z(I3) 00001930 X(I) = X(I) - X(I4) * SNN 00001940 X(I2) = X(I2) - X(I5) * SDD 00001950 X(I4) = SNN 00001960 X(I5) = SDD 00001970 SN = SN - Z(I-MUM) 00001980 226 SD = SD - Z(I2+MUM) 00001990 K1 = MUMTP + 1 00002000 K2 = LD - MUMTP 00002010 DO 230 00002020 * I = K1, K2 00002030 I1 = I + LS 00002040 SN = SN + Z(I+MUM) 00002050 X(I) = X(I) - X(I1) * SN 00002060 X(I1) = SN 00002070 SN = SN - Z(I-MUM) 00002080 230 CONTINUE 00002090 DA = 1 00002100 I = 1 00002110 CALL USBUFR (0, IND, BUFV, DA, I) 00002120 DO 160 00002130 *J= 1, NT 00002140 K = IND(I) 00002150 ID2 = (I+NDP-1)/NDP 00002160 W2 = W(I) 00002170 QQ(ID2) = Q(ID2) - (X(K) + X(LS+K) * D(I)) * W2 00002180 KR = IND(I+1) 00002190 KS = IND(I+2) 00002200 U(KR) = U(KR) + QQ(ID2) 00002210 U(KS) = U(KS) + QQ(ID2) 00002220 I = I + BUFV(4) 00002230 IF ( ((I-1)/BUFV(7)*BUFV(7)+1) .EQ. I) 00002240 + CALL USBUFR (4, IND, BUFV, DA, I) 00002250 160 CONTINUE 00002260 CALL USBUFR (-2, IND, BUFV, DA, I) 00002270 RETURN 00002280 END 00002290