SUBROUTINE AHEAD(XP,YP,ZP,XS,YS,ZS,PEX,PEY,PEZ,SEX,SEY,SEZ, 00000010 1 DELP,DELS,PREF,SREF,MODE) 00000020 INTEGER XP(1),YP(1),ZP(1),XS(1),YS(1),ZS(1),PEX(1),PEY(1), 00000030 1 PEZ(1),SEX(1),SEY(1),SEZ(1),DELP(3),DELS(3),PREF(3), 00000040 2 SREF(3) 00000050 INTEGER CR5/'CR5A'/ 00000060 C =U2DRH.AHEAD 00000070 C SAVE X 00000080 DO 10 I=1,3 00000090 DELP(I) = 0 00000100 10 DELS(I) = 0 00000110 C 00000120 PREF(1) = PEX(1) 00000130 SREF(1) = SEX(1) 00000140 C SAVE Y 00000150 PREF(2) = PEY(1) 00000160 SREF(2) = SEY(1) 00000170 C SAVE Z 00000180 PREF(3) = PEZ(1) 00000190 SREF(3) = SEZ(1) 00000200 C 00000210 IF(MODE.NE.CR5) GO TO 1 00000220 IF(XP(1).GT.0) RETURN 00000230 DO 20 I=1,3 00000240 PREF(I)=0 00000250 20 SREF(I)=0 00000260 RETURN 00000270 1 CONTINUE 00000280 DELP(2) = YP(10) 00000290 DELS(2) = YS(5) 00000300 DELP(3) = ZP(20) 00000310 DELS(3) = ZS(10) 00000320 RETURN 00000330 END 00000340 SUBROUTINE ALIGN(X,Y,Z,/N/,MBLOCK,FLIP,LOCK,I3) 00000010 LOGICAL*1 FLIP,LOCK,MAG(32) 00000020 INTEGER*2 N 00000030 INTEGER FLT1,I2OLD/-1/,ITMAX/24/,ITOLD/-1/ 00000040 REAL*4 LSENSR,LSEN1,LSEN2 00000050 REAL*8 TIME,NAME/' '/ 00000060 REAL*8 ATIM(24,2)/0.D0,23*1.D60, 00000070 X 52.D0,104.D0,157.D0, 21*1.D60/ 00000080 REAL*8 DDN(24,2)/'V1BAM11',23*'BADBAM', 00000090 X 'V2BAM78','V2BAM7A','V2BAM81', 21*'BADBAM'/ 00000100 CCC 00000110 CCC 00000120 CCC V2BAM81 MATRICES WERE GENERATED SEPT. 11, 1981 BASED 00000130 CCC ON SATURN DATA. 00000140 CCC 00000150 CCC 00000160 C***********************************************************************00000170 C**** BOOM ALIGNMENT MATRICES ARE CHOSEN BY S/C AND DATE. WHEN THE 00000180 C**** DATE IS LATER THAN SHOWN BELOW, THE LATEST MATRIX IS USED. 00000190 C**** FOR V1: V1BAM11 00000200 C**** FOR V2 (EPICDAY APPEARS BELOW DAY): 00000210 C**** _______ _______ _______ _______ _______ 00000220 C**** |20AUG77|<--|V2BAM78|-->|11OCT77|<--|V2BAM7A|-->|02DEC77|<-- 00000230 C**** |0. | | | | 52. | | | |104. | 00000240 C**** ------- ------- ------- ------- ------- 00000250 C**** _______ _______ _______ _______ 00000260 C**** <--|V2BAM7C|-->|24JAN78|<--|V2BAM81|-->|01JAN80|<-- 00000270 C**** | | |157. | | | |864. | 00000280 C**** ------- ------- ------- ------- 00000290 C**** _______ _______ _______ _______ 00000300 C**** <--| |-->| |<--| |-->| | 00000310 C**** | | | | | | | | 00000320 C**** ------- ------- ------- ------- 00000330 C***********************************************************************00000340 DIMENSION X(1),Y(1),Z(1) 00000350 DIMENSION HSENSR(9,2,2),LSENSR(9,2,2,2),BOOM(9,2,2) 00000360 DIMENSION LSEN1(9,2,2),LSEN2(9,2,2),MBLOCK(3) 00000370 COMMON /CCA/ WORK(500) 00000380 EQUIVALENCE (LSENSR(1,1,1,1),LSEN1(1,1,1)) 00000390 1 ,(LSENSR(1,1,1,2),LSEN2(1,1,1)),(WORK(9),MAG(1)) 00000400 DATA FLT1/'FLT1'/,LFM/'LFM '/ 00000410 C =W82JB.ALIGN 00000420 C ROUTINE TO DO SENSOR AND BOOM ALIGNMENT 00000430 C I2 = 1 = FLT1 00000440 C 2 = FLT2 00000450 C I3 = 1 = OB OUTBOARD MAG 00000460 C 2 = IB INBOARD MAG 00000470 C I4 = 1 = 0 DEGREE FLIP STATE 00000480 C 2 = 180 DEGREE FLIP STATE 00000490 C 00000500 DATA HSENSR/ 00000510 C HFM FLT1 OB 00000520 1 1.0 , 0.0 , -6.40700E-3, 00000530 2 7.94500E-3, 1.0 , -3.45100E-4, 00000540 3 -4.09980E-3, 0.0 , 1.0 , 00000550 C HFM FLT2 OB 00000560 4 1.0 , 2.03500E-3, -1.45200E-3, 00000570 5 -5.91100E-4, 1.0 , 2.96300E-4, 00000580 6 -8.68000E-4, -5.80640E-4, 1.0 , 00000590 C HFM FLT1 IB 00000600 7 1.0 , 3.22060E-3, 2.32710E-3, 00000610 8 -1.52100E-3, 1.0 , -3.83750E-3, 00000620 9 1.20930E-2, 1.80900E-3, 1.0 , 00000630 C HFM FLT2 IB 00000640 A 1.0 , 2.33050E-3, 1.75340E-3, 00000650 B 1.11040E-2, 1.0 , 1.77190E-3, 00000660 C 2.64810E-3, -1.17660E-3, 1.0 / 00000670 C 00000680 DATA LSEN1/ 00000690 C LFM FLT1 OB 0 00000700 1 1.0 , 1.1532E-3, 3.7620E-3, 00000710 2 -6.73200E-3, 1.0 , -3.39100E-3, 00000720 3 9.91500E-6, -1.47280E-3, 1.0 , 00000730 C LFM FLT2 OB 0 00000740 4 1.0 , -2.89750E-4, 2.89960E-4, 00000750 5 1.23150E-3, 1.0 , 4.00670E-3, 00000760 6 -2.89770E-4, 4.72980E-3, 1.0 , 00000770 C LFM FLT1 IB 0 00000780 7 1.0 , 2.17700E-3, -9.33140E-4, 00000790 8 -1.75440E-3, 1.0 , 1.63700E-6, 00000800 9 -4.99620E-3, 2.82990E-4, 1.0 , 00000810 C LFM FLT2 IB 0 00000820 A 1.0 , -1.24220E-3, -6.17870E-4, 00000830 B -1.16520E-3, 1.0 , -2.61410E-3, 00000840 C 1.18410E-3, -1.47100E-6, 1.0 / 00000850 C 00000860 DATA LSEN2/ 00000870 C LFM FLT1 OB 180 00000880 D 1.0 , 2.60720E-3, 1.53590E-6, 00000890 E 8.80950E-4, 1.0 , 5.89120E-4, 00000900 F -4.59640E-3, -5.52180E-3, 1.0 , 00000910 C LFM FLT2 OB 180 00000920 F 1.0 , -0.28144E-3, 0.26185E-2, 00000930 H -0.59295E-3, 1.0 , 0.56150E-2, 00000940 I -0.31036E-3, 0.36982E-2, 1.0 , 00000950 C LFM FLT1 IB 180 00000960 J 0.99999 , -0.60808E-3, -0.46723E-2, 00000970 K 0.25990E-3, 1.0 , -0.10001E-1, 00000980 L 0.34228E-2, 0.49747E-2, 0.99995 , 00000990 C LFM FLT2 IB 180 00001000 M 1.0 , -0.86780E-3, -0.20358E-2, 00001010 N -0.17806E-2, 1.0 , 0.23719E-2, 00001020 O -0.18601E-2, -0.18617E-2, 1.0 / 00001030 C 00001040 NPTS = N 00001050 I2 = 2 00001060 IF(MBLOCK(3) .EQ. FLT1) I2 = 1 00001070 C**** LOAD DATA MEMBER. 00001080 CALL FMOVE (TIME,8,MBLOCK(9)) 00001090 DO 31 I = 1,ITMAX 00001100 IF (ATIM(I,I2).EQ.1.D60) GO TO 32 00001110 IT = I 00001120 IF (TIME.LE.ATIM(I,I2)) GO TO 32 00001130 31 CONTINUE 00001140 32 IF (I2.EQ.I2OLD.AND.IT.EQ.ITOLD) GO TO 33 00001150 I2OLD = I2 00001160 ITOLD = IT 00001170 IF (DDN(IT,I2).EQ.NAME) GO TO 33 00001180 CALL LOADER(DDN(IT,I2),NAME,IADDR,&50,&50) 00001190 IADDR = IADDR + 8 00001200 CALL IMOVE (BOOM(1,1,I2),72,IADDR) 00001210 WRITE (6,160) DDN(IT,I2),IADDR,((BOOM(I,J,I2),I=1,9),J=1,2) 00001220 33 CONTINUE 00001230 C**** 00001240 IF(MBLOCK(1) .EQ. LFM) GO TO 10 00001250 CALL ROTATE(X,Y,Z,NPTS,HSENSR(1,I2,I3)) 00001260 RETURN 00001270 C 00001280 10 I4 = 1 00001290 IF(FLIP) I4 = 2 00001300 IF(LOCK) RETURN 00001310 CALL ROTATE(X,Y,Z,NPTS,LSENSR(1,I2,I3,I4)) 00001320 IF(.NOT. MAG(23)) CALL ROTATE(X,Y,Z,NPTS,BOOM(1,3-I3,I2)) 00001330 RETURN 00001340 50 WRITE (6,150) DDN(IT,I2) 00001350 STOP 00001360 150 FORMAT (' LOADER UNABLE TO FIND DATA MEMBER ',A8) 00001370 160 FORMAT (' DATA MEMBER ',A8,'LOADED AT ADDRESS ',Z8,/, 00001380 X (15X,1P3E13.5)) 00001390 END 00001400 SUBROUTINE AMB(XP,/NP/,XS,/NS/,XSC,MODE,IRANGE) 00001000 LOGICAL*1 MAG(32),USESCF/.TRUE./,FIRST/.TRUE./ 00002000 INTEGER*2 NP,NS 00003000 INTEGER REPEAT,MASK/Z000F/,SHFTR,RANGE,GS3/'GS-3'/,RGE4/0/,RLT4/0/00004000 DIMENSION XP(1),XS(1),XSC(1) 00005000 COMMON /CCA/ WORK(500) 00006000 EQUIVALENCE (WORK(9),MAG(1)) 00007000 DATA FILL/999./,ALPHA/.1876/ 00008000 C =U2EDR.AMB 00009000 C SUBROUTINE TO COMPUTE AMBIENT MAGNETIC FIELD BY 00010000 C SUBTRACTING SPACECRAFT FIELD FROM PRIME MAG 00011000 C 00012000 C IF MAG(16) = .TRUE. THEN ANY MISSING PRIME SAMPLES MAY BE 00013000 C FILLED IN BY COMPUTING AMBIENT FROM S AND SC 00014000 C 00015000 C AMB = S-SC/ALPHA 00016000 C 00017000 C ALPHA = .1876 00018000 C 00019000 REPEAT = NP/NS 00020000 J = 1 00021000 L = 1 00022000 IF (MODE .NE. GS3) GO TO 15 00023000 C IN GS-3, IF THE RANGE IS 4 OR GREATER, DO NOT USE SCF TO CALCULATE 00024000 C AMBIENT FIELD. THIS IS DETERMINED BY 4 CONSECUTIVE STATUS WORDS 00025000 C WITH RANGES ALL GREATER THAN OR EQUAL TO 4. 00026000 RANGE = SHFTR(IRANGE,4) 00027000 RANGE = LAND(RANGE,MASK) 00028000 IF (FIRST .AND. (RANGE .GE. 4)) USESCF = .FALSE. 00029000 IF (FIRST .AND. (RANGE .GE. 4)) WRITE (6,100) 00030000 FIRST = .FALSE. 00031000 IF (RANGE .GE. 4) GO TO 5 00032000 RLT4 = RLT4 + 1 00033000 RGE4 = 0 00034000 GO TO 10 00035000 5 CONTINUE 00036000 RGE4 = RGE4 + 1 00037000 RLT4 = 0 00038000 10 CONTINUE 00039000 IF (USESCF .AND. (RGE4 .GE. 4)) WRITE (6,100) 00040000 IF ((.NOT. USESCF) .AND. (RLT4 .GE. 4)) WRITE (6,110) 00041000 IF (RGE4 .GE. 4) USESCF = .FALSE. 00042000 IF (RLT4 .GE. 4) USESCF = .TRUE. 00043000 15 CONTINUE 00044000 DO 60 I=1,NP 00045000 C IF MAGNETOMETER SWITCH 27 IS ON, SET THE AMBIENT FIELD EQUAL TO 00046000 C THE SPACECREFT FIELD 00047000 IF (.NOT. MAG(27)) GO TO 20 00048000 XP(I) = XSC(L) 00049000 GO TO 50 00050000 20 CONTINUE 00051000 IF (.NOT. USESCF) GO TO 60 00052000 IF (XSC(L) .NE. FILL) GO TO 25 00053000 XP(I) = FILL 00054000 GO TO 50 00055000 25 CONTINUE 00056000 IF(XP(I) .EQ. FILL) GO TO 30 00057000 XP(I) = XP(I) - XSC(L) 00058000 GO TO 50 00059000 30 IF(MAG(16) .AND. (XS(L) .NE. FILL)) XP(I) = XS(L) - XSC(L)/ALPHA 00060000 50 J = J + 1 00061000 IF(J .LE. REPEAT) GO TO 60 00062000 J = 1 00063000 L = L + 1 00064000 60 CONTINUE 00065000 RETURN 00066000 100 FORMAT (' RANGE ABOVE 4 - SCF NOT USED IN AMB CALCULATIONS') 00067000 110 FORMAT (' RANGE BELOW 4 - SCF USED IN AMB CALCULATIONS') 00068000 END 00069000 SUBROUTINE AMBTAP(MBLOCK,/NP/) 00001000 INTEGER*2 MBLOCK(64),DETREC(64) 00002000 C DETCOM IS USED TO OBTAIN THE FOLLOWING DATA FROM SUBROUTINE MAGTAP: 00003000 C NREC = DETAIL TAPE RECORD COUNT 00004000 C FIRST = LOGICAL VARIABLE INDICATING FIRST WRITE TO DETAIL TAPE 00005000 COMMON /DETCOM/ NREC,FIRST 00006000 INTEGER*2 NREC 00007000 LOGICAL*1 FIRST 00008000 CALL FMOVE (DETREC,128,MBLOCK) 00009000 IF(FIRST) CALL TAPLAB(DETREC,FIRST,NREC) 00010000 LEN = (NP*3 + 32)*4 00011000 NREC = NREC + 1 00012000 MBLOCK(63) = NREC 00013000 MBLOCK(64) = NP * 3 00014000 CALL FWRITE(MBLOCK,20,LEN) 00015000 RETURN 00016000 END 00017000 SUBROUTINE ANGLES (TH,PH,X,Y,Z,F,N) 00000100 C************************************************** C* FORTRAN 77 CONVERSION PROJECT JULY 1991 C* FUNCTION STATEMENTS THETA AND PHI MOVED TO BELOW NON-EXEC CODE C* JUMP BACK INTO LOOP REPLACED BY IF THEN ELSE CONSTRUCT C************************************************** C ********** =U2DRH.ANGLES ********** 00000150 DIMENSION TH(1),PH(1),X(1),Y(1),Z(1),F(1) 00000400 THETA(A,B) = ARSIN(A/B)*57.2957795D0 00000200 PHI(A,B) = 180. - ATAN2(A,-B)*57.2957795D0 00000300 C 00000500 DO 50 I = 1,N 00000600 IF (F(I) .NE. 0.) THEN 00000700 TH(I) = THETA(Z(I),F(I)) 00000800 PH(I) = PHI(Y(I),X(I)) 00000900 ELSE 00001000 TH(I) = 0. 00001400 PH(I) = 0. 00001500 ENDIF 50 CONTINUE C 00001100 RETURN 00001200 END 00001700 SUBROUTINE AVECR2(X,Y,Z,/N/,FDSC,MBLOCK,XSC,YSC,ZSC,NSC) 00000100 LOGICAL*1 SYS(32),MAGIC(32) 00000110 LOGICAL FIRST/.TRUE./,BUFF 00000120 INTEGER*2 FDSC(3),N,NSC 00000130 INTEGER*2 MODE(2) 00000140 INTEGER MBLOCK(1),PSC,OLDPSC,OK,STS(5) 00000150 REAL*8 FLAG(5),BLANK/' '/ 00000160 DIMENSION X(1),Y(1),Z(1) 00000170 1 ,X19(25) ,Y19(25) ,Z19(25) ,F119(25) ,F219(25) 00000180 2 ,M19(25) ,TH19(25) ,PH19(25) ,RMS19(3,25) 00000190 DIMENSION XCR4(33),YCR4(33),ZCR4(33) 00000200 DIMENSION XSC(1),YSC(1),ZSC(1) 00000210 COMMON /OUTPUT/ HEADER(32),DATA(341) 00000220 COMMON /CCA/ WORK(500) 00000230 EQUIVALENCE (WORK(205),BUFF) ,(WORK(1),SYS(1)) 00000240 7 ,(DATA(67),F119(1)) ,(DATA(92),F219(1)) ,(DATA(117),TH19(1)) 00000250 8 ,(DATA(142),PH19(1)),(DATA(167),X19(1)) ,(DATA(192),Y19(1)) 00000260 9 ,(DATA(217),Z19(1)) ,(DATA(242),RMS19(1,1)),(DATA(317),M19(1)) 00000270 EQUIVALENCE (WORK(9),MAGIC(1)) 00000280 DATA OLDPSC/-1/,OK/1/,K/0/ 00000290 DATA FILL/999./ 00000300 C =U2EDR.AVECR2 00000310 C COMPUTE MAGNETIC FIELD AVERAGES FOR CR-1 AND CR-2 FMT 00000320 C THIS CODE SHOULD WORK FOR ANY TELEMETRY MODE WITH 00000330 C A 9.6 SECOND STATUS PERIOD 00000340 C 25 1.92 SEC AVE 00000350 C 5 9.6 SEC AVE 00000360 C 1 48.0 SEC AVE 00000370 C 00000380 C 1.92 SEC AVE CONSISTS OF (P,S) (PRIMARY,SECONDARY) SAMPLES 00000390 C CR-1 = (32,32) N = (160,160) 00000400 C CR-2 = (16,8) N = (80,40) 00000410 C CR-3 = (8,2) N = (40,10) 00000420 C 00000430 C ONE STATUS BLOCK CONTAINS 9.6 SECONDS OF DATA 00000440 C 00000450 C PSC = SPACE CRAFT CLOCK IN INCREMENTS OF 48 SEC. 00000460 PSC = FDSC(1)*60 + FDSC(2) 00000470 C PSC NOT EQUAL TO OLDPSC IMPLIES ONE OF TWO CONDITIONS: 00000480 C (1) FIRST TIME INTO THIS ROUTINE 00000490 C (2) 48 SECONDS OF DATA HAVE BEEN ACCUMULATED 00000500 IF(PSC .NE. OLDPSC) GO TO 40 00000510 C K INCREMENTS BY 1 FOR EVERY 1.92 SECONDS OF THE SPACECRAFT CLOCK 00000520 5 K = FDSC(3)/32 + 1 00000530 C J INCREMENTS BY 1 FOR EVERY 9.6 SECONDS OF THE SPACECRAFT CLOCK 00000540 J = FDSC(3)/160 + 1 00000550 STS(J) = MBLOCK(15) 00000560 CALL FMOVE(FLAG(J),8,MBLOCK(19)) 00000570 C IR2 = THE NUMBER OF WORDS IN THE STATUS BLOCK NEEDED TO 00000580 C CALCULATE A SINGLE 1.92 SECOND AVERAGE 00000590 IR2 = N/5 00000600 IF(OK .LT. K) CALL SCRAP(X19(OK),Y19(OK),Z19(OK),F119(OK), 00000610 1 F219(OK),RMS19(1,OK),K-OK) 00000620 CALL FMOVE (MODE(1),4,MBLOCK(17)) 00000630 C BRANCH AROUND CODE WHICH PROCESSES CR4 DATA 00000640 IF (MODE(2) .NE. 4) GO TO 190 00000650 C BRANCH AROUND CODE WHICH PROCESSES CR4 SECONDARY DATA 00000660 IF (N .NE. 4) GO TO 150 00000670 C LOOP TO PLACE SECONDARY DATA POINTS INTO CR4 COORDINATE ARRAYS 00000680 DO 100 I=1,4 00000690 ICR4 = (I - 1) * 8 + 1 00000700 XCR4(ICR4) = X(I) 00000710 YCR4(ICR4) = Y(I) 00000720 ZCR4(ICR4) = Z(I) 00000730 100 CONTINUE 00000740 IF ((X(3) .NE. FILL) .AND. (X(4) .NE. FILL)) GO TO 105 00000750 XCR4(33) = FILL 00000760 YCR4(33) = FILL 00000770 ZCR4(33) = FILL 00000780 GO TO 107 00000790 C EXTRAPOLATE SECONDARY DATA POINTS TO ESTIMATE NEXT POINT 00000800 105 XCR4(33) = 2. * X(4) - X(3) 00000810 YCR4(33) = 2. * Y(4) - Y(3) 00000820 ZCR4(33) = 2. * Z(4) - Z(3) 00000830 107 IP = 2 00000840 C LOOP TO INTERPOLATE SECONDARY DATA POINTS TO OBTAIN 00000850 C .3 SECOND DATA POINTS. 00000860 DO 140 I=1,4 00000870 IS = (I - 1) * 8 + 1 00000880 IF ((XCR4(IS) .NE. FILL) .AND. (XCR4(IS+8) .NE. FILL)) GO TO 120 00000890 DO 110 I1=1,7 00000900 XCR4(IP) = FILL 00000910 YCR4(IP) = FILL 00000920 ZCR4(IP) = FILL 00000930 IP = IP + 1 00000940 110 CONTINUE 00000950 IP = IP + 1 00000960 GO TO 140 00000970 120 INCX = (XCR4(IS+8) - XCR4(IS)) / 8. 00000980 INCY = (YCR4(IS+8) - YCR4(IS)) / 8. 00000990 INCZ = (ZCR4(IS+8) - ZCR4(IS)) / 8. 00001000 DO 130 I1=1,7 00001010 RI = I 00001020 XCR4(IP) = XCR4(IS) + RI * INCX 00001030 YCR4(IP) = YCR4(IS) + RI * INCY 00001040 ZCR4(IP) = ZCR4(IS) + RI * INCZ 00001050 IP = IP + 1 00001060 130 CONTINUE 00001070 IP = IP + 1 00001080 140 CONTINUE 00001090 GO TO 170 00001100 C PLACE PRIMARY DATA POINTS INTO CR4 COORDINATE ARRAYS 00001110 150 DO 160 I=1,32 00001120 XCR4(I) = X(I) 00001130 YCR4(I) = Y(I) 00001140 ZCR4(I) = Z(I) 00001150 160 CONTINUE 00001160 170 ISTART = 1 00001170 C CALCULATE 1.92 SECOND AVERAGES FRON CR4 DATA 00001180 DO 180 L=1,5 00001190 INCR = 6 + MOD(L+1,2) 00001200 CALL STAT (XCR4(ISTART),YCR4(ISTART),ZCR4(ISTART),INCR, 00001210 1 M19(K),F119(K),F219(K),X19(K),Y19(K),Z19(K),RMS19(1,K))00001220 K = K + 1 00001230 ISTART = ISTART + INCR 00001240 180 CONTINUE 00001250 GO TO 15 00001260 C CALCULATE 1.92 SECOND AVERAGES FOR MODES OTHER THAN CR4 00001270 190 DO 10 L=1,N,IR2 00001280 CALL STAT(X(L),Y(L),Z(L),IR2,M19(K),F119(K),F219(K),X19(K),Y19(K) 00001290 1 ,Z19(K),RMS19(1,K)) 00001300 K = K + 1 00001310 10 CONTINUE 00001320 15 OK = K 00001330 C CALCULATE SPACECRAFT FIELD AVERAGES 00001340 IF ((.NOT. MAGIC(21)) .AND. (.NOT. MAGIC(22))) 00001350 1 CALL AVESCF (XSC,YSC,ZSC,NSC) 00001360 C IF PROCESSING PLS DATA, GENERATE SPECIAL AVERAGES FOR USE BY PLS 00001370 IF(SYS( 1)) CALL SPCAVE(MBLOCK,X,Y,Z,N) 00001380 RETURN 00001390 C 00001400 C 48 SEC AVERAGE 00001410 40 CONTINUE 00001420 OLDPSC = PSC 00001430 BUFF = .TRUE. 00001440 IF(FIRST) GO TO 50 00001450 IF(OK .LT. 25) CALL SCRAP(X19(OK),Y19(OK),Z19(OK),F119(OK), 00001460 1 F219(OK),RMS19(1,OK),26-OK) 00001470 C 00001480 C COMPUTE 48 SECOND SPACECRAFT FIELD AVERAGES 00001490 IF ((.NOT. MAGIC(21)) .AND. (.NOT. MAGIC(22))) 00001500 1 CALL ENDSCF 00001510 CALL BIGAVE(STS,FLAG,5) 00001520 50 FIRST = .FALSE. 00001530 CALL FMOVE(HEADER,128,MBLOCK) 00001540 DO 60 I=1,5 00001550 STS(I) = 0 00001560 FLAG(I) = BLANK 00001570 60 CONTINUE 00001580 OK = 1 00001590 GO TO 5 00001600 C 00001610 ENTRY ENDCR2 00001620 IF(OK .EQ. 1) RETURN 00001630 IF(OK .LT. 25) CALL SCRAP(X19(OK),Y19(OK),Z19(OK),F119(OK), 00001640 1 F219(OK),RMS19(1,OK),26-OK) 00001650 C COMPUTE 48 SECOND SPACECRAFT FIELD AVERAGES 00001660 IF ((.NOT. MAGIC(21)) .AND. (.NOT. MAGIC(22))) 00001670 1 CALL ENDSCF 00001680 CALL BIGAVE(STS,FLAG,5) 00001690 FIRST = .TRUE. 00001700 BUFF = .FALSE. 00001710 RETURN 00001720 END 00001730 SUBROUTINE AVECR5(X,Y,Z,/N/,FDSC,MBLOCK,XSC,YSC,ZSC,NSC) 00010000 LOGICAL*1 SYS(32),MAGIC(32) 00020000 LOGICAL BUFF 00030000 INTEGER*2 FDSC(3),N,ITB(6),NFDSC(3),NSC 00040000 INTEGER MBLOCK(1) 00050000 REAL*8 TIME 00060000 DIMENSION X(1),Y(1),Z(1) 00070000 1 ,X19(25) ,Y19(25) ,Z19(25) ,F119(25) ,F219(25) 00080000 2 ,M19(25) ,TH19(25) ,PH19(25) ,RMS19(3,25) 00090000 DIMENSION XSC(1),YSC(1),ZSC(1) 00100000 COMMON /OUTPUT/ HEADER(32),DATA(341) 00110000 COMMON /CCA/ WORK(500) 00120000 EQUIVALENCE (WORK(205),BUFF) ,(WORK(1),SYS(1)) 00130000 7 ,(DATA(67),F119(1)) ,(DATA(92),F219(1)) ,(DATA(117),TH19(1)) 00140000 8 ,(DATA(142),PH19(1)),(DATA(167),X19(1)) ,(DATA(192),Y19(1)) 00150000 9 ,(DATA(217),Z19(1)) ,(DATA(242),RMS19(1,1)),(DATA(317),M19(1)) 00160000 A ,(HEADER(7),TIME) ,(HEADER(4),ITB(1)) ,(HEADER(13),NFDSC(1))00170000 EQUIVALENCE (WORK(9),MAGIC(1)) 00180000 C***********************************************************************00190000 C COMPUTE MAGNETIC FIELD AVERAGES FOR CR-5 FMT 00200000 C 25 1.92 SEC AVE / 5 9.6 SEC AVE / 1 48. SEC AVE 00210000 C STATUS BLOCK CONTAINS ONE 48 SECOND AVERAGE 00220000 C 00230000 C ############### WARNING ################## 00240000 C THE ORIGINAL SOURCE FROM 4MAR80 IS MISSING 00250000 C THIS IS A RECONSTRUCTION BY T.VOLLMER 27JUL90 FROM THE 00260001 C 4MAR80 LISTING 00270001 C***********************************************************************00280000 CALL FMOVE(HEADER,128,MBLOCK) 00290000 C**** COMPUTE NEW TIMES 00300000 IYR = ITB(1) 00310000 CALL SETIME(IYR,TIME,ITB) 00320000 CALL EPIC(ITB,TIME,HEADER(9)) 00330000 C**** COMPUTE S/C FIELD AVERAGES. 00340000 IF (MAGIC(21).OR.MAGIC(22)) GO TO 50 00350000 CALL AVESCF (XSC,YSC,ZSC,50) 00360000 CALL ENDSCF 00370000 50 CONTINUE 00380000 IR = N/25 00390000 IF (IR .EQ.0) GO TO 100 00391002 K = 1 00400000 DO 10 L = 1,N,IR 00410000 CALL STAT (X(L),Y(L),Z(L),IR,M19(K),F119(K),F219(K),X19(K), 00420000 X Y19(K),Z19(K),RMS19(1,K)) 00430000 10 K = K + 1 00440000 GO TO 200 00441002 100 CONTINUE 00442002 C******************************* 00442103 C FOR SECONDARY MAG WHEN NS < 25 00442203 C******************************* 00442303 IR = 25/N 00443002 I1 = 1 00443102 I2 = IR 00443202 DO 120 I = 1,N 00443302 DO 110 L = I1, I2 00444003 CALL STAT (X(I),Y(I),Z(I),1,M19(L),F119(L),F219(L),X19(L),00445002 X Y19(L),Z19(L),RMS19(1,L)) 00446002 110 CONTINUE 00447002 I1 = I2 + 1 00447102 I2 = I2 + IR 00447202 IF (I .EQ. (N-1)) I2 = 25 00447303 120 CONTINUE 00447402 200 CONTINUE 00449202 CALL BIGAVE(HEADER(15),HEADER(19),1) 00450000 NFDSC(2) = NFDSC(2) + 1 00460000 IF (SYS(1)) CALL SPCAVE (MBLOCK,X,Y,Z,N) 00470000 BUFF = .FALSE. 00480000 RETURN 00490000 END 00500000 SUBROUTINE AVECR6(X,Y,Z,/N/,FDSC,MBLOCK,XSC,YSC,ZSC,NSC) 00000100 LOGICAL*1 SYS(32),MAGIC(32) 00000110 LOGICAL BUFF 00000120 INTEGER*2 FDSC(3),N,ITB(6),NFDSC(3),NSC,INCR 00000130 INTEGER MBLOCK(1) 00000140 REAL*8 DDAY,TIME,S48/5.5555555556D-4/ 00000150 DIMENSION X(1),Y(1),Z(1) 00000160 1 ,X19(25) ,Y19(25) ,Z19(25) ,F119(25) ,F219(25) 00000170 2 ,M19(25) ,TH19(25) ,PH19(25) ,RMS19(3,25) 00000180 DIMENSION XSC(1),YSC(1),ZSC(1) 00000190 COMMON /OUTPUT/ HEADER(32),DATA(341) 00000200 COMMON /CCA/ WORK(500) 00000210 EQUIVALENCE (WORK(205),BUFF) ,(WORK(1),SYS(1)) 00000220 7 ,(DATA(67),F119(1)) ,(DATA(92),F219(1)) ,(DATA(117),TH19(1)) 00000230 8 ,(DATA(142),PH19(1)),(DATA(167),X19(1)) ,(DATA(192),Y19(1)) 00000240 9 ,(DATA(217),Z19(1)) ,(DATA(242),RMS19(1,1)),(DATA(317),M19(1)) 00000250 A ,(HEADER(7),TIME) ,(HEADER(4),ITB(1)) ,(HEADER(13),NFDSC(1))00000260 EQUIVALENCE (WORK(9),MAGIC(1)) 00000270 DATA FILL/999./ 00000280 C 00000290 C =U2EDR.AVECR6 00000300 C COMPUTE MAGNETIC FIELD AVERAGES FOR CR-6 FMT 00000310 C 25 1.92 SEC AVE 00000320 C 5 9.6 SEC AVE 00000330 C 1 48.0 SEC AVE 00000340 C 00000350 C STATUS BLOCK CONTAINS 6 48 SECOND AVERAGES 00000360 C DETAIL DATA IS ALREADY A 1.92 SEC AVE COMPUTED ONBOARD 00000370 C SPACECRAFT 00000380 C 00000390 CALL FMOVE(HEADER,128,MBLOCK) 00000400 DDAY = TIME 00000410 IYR = ITB(1) 00000420 C 00000430 ISTART = 1 00000440 ICOUNT = 1 00000450 L = 0 00000460 IR = N/6 00000470 DO 80 K=1,N,IR 00000480 C CALCULATE 48 SECOND SCF AVERAGES 00000490 IF (MAGIC(21) .OR. MAGIC(22)) GO TO 10 00000500 INCR = 12 + MOD(ICOUNT,2) 00000510 CALL AVESCF (XSC(ISTART),YSC(ISTART),ZSC(ISTART),INCR) 00000520 ISTART = ISTART + INCR 00000530 ICOUNT = ICOUNT + 1 00000540 10 CALL FMOVE(X19,100,X(K)) 00000550 CALL FMOVE(Y19,100,Y(K)) 00000560 CALL FMOVE(Z19,100,Z(K)) 00000570 DO 40 I=1,25 00000580 IF(X19(I) .EQ. FILL) GO TO 30 00000590 F219(I) = SQRT(X19(I)*X19(I) + Y19(I)*Y19(I) + Z19(I)*Z19(I)) 00000600 F119(I) = F219(I) 00000610 RMS19(1,I) = 0. 00000620 RMS19(2,I) = 0. 00000630 RMS19(3,I) = 0. 00000640 M19(I) = 1 00000650 GO TO 40 00000660 30 CONTINUE 00000670 F119(I) = FILL 00000680 F219(I) = FILL 00000690 RMS19(1,I) = FILL 00000700 RMS19(2,I) = FILL 00000710 RMS19(3,I) = FILL 00000720 M19(I) = 0 00000730 40 CONTINUE 00000740 C 00000750 TIME = DDAY + L*S48 00000760 CALL SETIME(IYR,TIME,ITB) 00000770 CALL EPIC(ITB,TIME,HEADER(9)) 00000780 C PLACE 48 SECOND SCF AVERAGES INTO DATA AREA TO BE WRITTEN TO THE 00000790 C SUMMARY TAPE 00000800 IF ((.NOT. MAGIC(21)) .AND. (.NOT. MAGIC(22))) CALL ENDSCF 00000810 IF(SYS( 1)) CALL SPCCR6(HEADER,F119,F219,X19,Y19,Z19,M19,RMS19,IR)00000820 CALL BIGAVE(HEADER(15),HEADER(19),1) 00000830 NFDSC(2) = NFDSC(2) + 1 00000840 L = L + 1 00000850 80 CONTINUE 00000860 BUFF = .FALSE. 00000870 RETURN 00000880 END 00000890 SUBROUTINE AVEGS3(X,Y,Z,/N/,FDSC,MBLOCK,XSC,YSC,ZSC,NSC) 00000100 LOGICAL*1 SYS(32),MAGIC(32) 00000110 LOGICAL FIRST/.TRUE./,BUFF 00000120 INTEGER*2 FDSC(3),N,NSC 00000130 INTEGER MBLOCK(1),PSC,OLDPSC,OK,STS(5),FLAG(5,2) 00000140 REAL*4 BLANK/' '/ 00000150 DIMENSION X(1),Y(1),Z(1),XB(32),YB(32),ZB(32) 00000160 1 ,X19(25) ,Y19(25) ,Z19(25) ,F119(25) ,F219(25) 00000170 2 ,M19(25) ,TH19(25) ,PH19(25) ,RMS19(3,25) 00000180 DIMENSION XSC(1),YSC(1),ZSC(1) 00000190 COMMON /OUTPUT/ HEADER(32),DATA(341) 00000200 COMMON /CCA/ WORK(500) 00000210 EQUIVALENCE (WORK(205),BUFF) ,(WORK(1),SYS(1)) 00000220 7 ,(DATA(67),F119(1)) ,(DATA(92),F219(1)) ,(DATA(117),TH19(1)) 00000230 8 ,(DATA(142),PH19(1)),(DATA(167),X19(1)) ,(DATA(192),Y19(1)) 00000240 9 ,(DATA(217),Z19(1)) ,(DATA(242),RMS19(1,1)),(DATA(317),M19(1)) 00000250 EQUIVALENCE (WORK(9),MAGIC(1)) 00000260 DATA OLDPSC/-1/,OK/1/,K/0/ 00000270 C =U2EDR.AVEGS3 00000280 C COMPUTE MAGNETIC FIELD AVERAGES FOR GS-3 FMT 00000290 C 25 1.92 SEC AVE 00000300 C 5 9.6 SEC AVE 00000310 C 1 48.0 SEC AVE 00000320 C 00000330 C 1.92 SEC AVE CONSISTS OF 32 DETAILED SAMPLES PER 00000340 C STATUS BLOCK (OR 16 IF PROCESSING SEC MAG ONLY) 00000350 C 00000360 C TWO 4.8 SEC BLOCKS MUST BE COMBINED TO MAKE ONE 9.6 SEC AVE 00000370 C 'A' TYPE BLOCK IS FIRST 4.8 SEC IN 9.6 SEC AVE 00000380 C 'B' TYPE BLOCK IS SECOND 4.8 SECONDS IN 9.6 SEC AVE 00000390 C EACH BLOCK CONTAINS 2.5 1.92 SEC AVERAGES 00000400 C 00000410 PSC = FDSC(1)*60 + FDSC(2) 00000420 IF(PSC .NE. OLDPSC) GO TO 40 00000430 5 CONTINUE 00000440 C CALCULATE SPACECRAFT FIELD AVERAGES 00000450 IF ((.NOT. MAGIC(21)) .AND. (.NOT. MAGIC(22))) 00000460 1 CALL AVESCF (XSC,YSC,ZSC,NSC) 00000470 K = FDSC(3)/32 00000480 ISW = MOD(K,5)/2 00000490 J = FDSC(3)/160+ 1 00000500 STS(J) = IOR(STS(J),MBLOCK(15)) 00000510 FLAG(J,1) = IOR(FLAG(J,1),MBLOCK(19)) 00000520 FLAG(J,2) = IOR(FLAG(J,2),MBLOCK(20)) 00000530 IR2 = N/5 00000540 IR = 2*IR2 00000550 K = K + 1 00000560 IF(OK .GE. K) GO TO 10 00000570 CALL SCRAP(X19(OK),Y19(OK),Z19(OK),F119(OK), 00000580 1 F219(OK),RMS19(1,OK),K-OK) 00000590 IF(M .EQ. 1) CALL STAT(XB,YB,ZB,IR2,M19(OK),F119(OK),F219(OK) 00000600 1 ,X19(OK),Y19(OK),Z19(OK),RMS19(1,OK)) 00000610 10 IF(ISW .EQ. 1) GO TO 20 00000620 C C 00000630 C 'A' TYPE BLOCK WITH HALF OF DATA FOR AVERAGE AT END OF BLOCK 00000640 C AND TWO 1.92 SEC AVE AT FRONT END OF BLOCK 00000650 C 00000660 CALL STAT(X(1),Y(1),Z(1),IR,M19(K),F119(K),F219(K),X19(K),Y19(K) 00000670 1 ,Z19(K),RMS19(1,K)) 00000680 L = IR + 1 00000690 K = K + 1 00000700 CALL STAT(X(L),Y(L),Z(L),IR,M19(K),F119(K),F219(K),X19(K),Y19(K) 00000710 1 ,Z19(K),RMS19(1,K)) 00000720 L = L + IR 00000730 K = K + 1 00000740 CALL FMOVE(XB(1),4*IR2,X(L)) 00000750 CALL FMOVE(YB(1),4*IR2,Y(L)) 00000760 CALL FMOVE(ZB(1),4*IR2,Z(L)) 00000770 M = 1 00000780 OK = K 00000790 C 00000800 IF(SYS( 1)) CALL SPCAVE(MBLOCK,X,Y,Z,N) 00000810 RETURN 00000820 C 00000830 C CODE TO TAKE CARE OF MISSING BLOCK TYPE 00000840 C 00000850 20 IF(K .EQ. OK) GO TO 30 00000860 IF(M .EQ. 1) CALL STAT(XB,YB,ZB,IR2,M19(OK),F119(OK),F219(OK) 00000870 1 ,X19(OK),Y19(OK),Z19(OK),RMS19(1,OK)) 00000880 CALL STAT(X(1),Y(1),Z(1),IR2,M19(K),F119(K),F219(K),X19(K),Y19(K) 00000890 1 ,Z19(K),RMS19(1,K)) 00000900 GO TO 35 00000910 C 00000920 C 'B' TYPE STATUS BLOCK WITH HALF OF DATA FOR AVERAGE AT FRONT 00000930 C AND TWO 1.92 SEC AVE AT END OF BLOCK 00000940 C 00000950 30 CONTINUE 00000960 CALL FMOVE(XB(IR2+1),4*IR2,X(1)) 00000970 CALL FMOVE(YB(IR2+1),4*IR2,Y(1)) 00000980 CALL FMOVE(ZB(IR2+1),4*IR2,Z(1)) 00000990 CALL STAT(XB,YB,ZB,IR,M19(K),F119(K),F219(K),X19(K),Y19(K) 00001000 1 ,Z19(K),RMS19(1,K)) 00001010 35 L = IR2 + 1 00001020 K = K + 1 00001030 CALL STAT(X(L),Y(L),Z(L),IR,M19(K),F119(K),F219(K),X19(K),Y19(K) 00001040 1 ,Z19(K),RMS19(1,K)) 00001050 L = L + IR 00001060 K = K + 1 00001070 CALL STAT(X(L),Y(L),Z(L),IR,M19(K),F119(K),F219(K),X19(K),Y19(K) 00001080 1 ,Z19(K),RMS19(1,K)) 00001090 OK = K + 1 00001100 M = 0 00001110 C 00001120 IF(SYS( 1)) CALL SPCAVE(MBLOCK,X,Y,Z,N) 00001130 RETURN 00001140 C 48 SEC AVERAGE 00001150 40 CONTINUE 00001160 OLDPSC = PSC 00001170 BUFF = .TRUE. 00001180 M = 0 00001190 IF(FIRST) GO TO 50 00001200 IF(OK .LT. 25) CALL SCRAP(X19(OK),Y19(OK),Z19(OK),F119(OK), 00001210 1 F219(OK),RMS19(1,OK),26-OK) 00001220 IF(K .EQ. OK) CALL STAT(XB,YB,ZB,IR2,M19(OK),F119(OK),F219(OK) 00001230 1 ,X19(OK),Y19(OK),Z19(OK),RMS19(1,OK)) 00001240 C CALCULATE 48 SECOND SPACECRAFT AVERAGES AND PLACE IN DATA AREA 00001250 C WHERE THEY WILL BE WRITTEN TO THE SUMMARY TAPE 00001260 IF ((.NOT. MAGIC(21)) .AND. (.NOT. MAGIC(22))) 00001270 1 CALL ENDSCF 00001280 CALL BIGAVE(STS,FLAG,5) 00001290 50 FIRST = .FALSE. 00001300 CALL FMOVE(HEADER,128,MBLOCK) 00001310 DO 60 I=1,5 00001320 STS(I) = 0 00001330 FLAG(I,1) = BLANK 00001340 FLAG(I,2) = BLANK 00001350 60 CONTINUE 00001360 OK = 1 00001370 GO TO 5 00001380 C 00001390 ENTRY ENDGS3 00001400 IF(OK .EQ. 1) RETURN 00001410 IF(OK .LT. 25) CALL SCRAP(X19(OK),Y19(OK),Z19(OK),F119(OK), 00001420 1 F219(OK),RMS19(1,OK),26-OK) 00001430 IF(K .EQ. OK) CALL STAT(XB,YB,ZB,IR2,M19(OK),F119(OK),F219(OK) 00001440 1 ,X19(OK),Y19(OK),Z19(OK),RMS19(1,OK)) 00001450 C CALCULATE 48 SECOND SPACECRAFT AVERAGES AND PLACE IN DATA AREA 00001460 C WHERE THEY WILL BE WRITTEN TO THE SUMMARY TAPE. 00001470 IF ((.NOT. MAGIC(21)) .AND. (.NOT. MAGIC(22))) 00001480 1 CALL ENDSCF 00001490 CALL BIGAVE(STS,FLAG,5) 00001500 FIRST = .TRUE. 00001510 BUFF = .FALSE. 00001520 RETURN 00001530 END 00001540 SUBROUTINE AVESCF (XSCF,YSCF,ZSCF,NSCF) 00000100 C ********** =U2EDR.AVESCF ********** 00000105 DIMENSION XSCF(1),YSCF(1),ZSCF(1) 00000110 LOGICAL*1 FIRST/.TRUE./ 00000120 INTEGER*2 NSCF 00000130 REAL*4 FILL/999./ 00000140 REAL*8 XSUM,YSUM,ZSUM,X2SUM,Y2SUM,Z2SUM,RN,DSCX,DSCY,DSCZ,TEMP 00000150 COMMON /OUTPUT/ HEADER(32),DATA(536) 00000160 EQUIVALENCE (DATA(489),RMSXSC),(DATA(490),RMSYSC), 00000170 1 (DATA(491),RMSZSC),(DATA(492),NSC), 00000180 2 (DATA(493),SCX),(DATA(494),SCY), 00000190 3 (DATA(495),SCZ),(DATA(496),SCF) 00000200 C THIS SUBROUTINE CALCULATES 48 SECOND AVERAGES OF SPACECRAFT 00000210 C FIELD AND RMS VALUES. 00000220 IF (.NOT. FIRST) GO TO 10 00000230 C INITIALIZE VALUES TO BEGIN CALCULATING NEW 48 SECOND AVERAGES. 00000240 RN = 0. 00000250 XSUM = 0. 00000260 YSUM = 0. 00000270 ZSUM = 0. 00000280 X2SUM = 0. 00000290 Y2SUM = 0. 00000300 Z2SUM = 0. 00000310 FIRST = .FALSE. 00000320 10 CONTINUE 00000330 DO 20 I=1,NSCF 00000340 C IF COORDINATES ARE EQUAL TO FILL, DO NOT USE IN AVERAGES 00000350 IF (XSCF(I) .EQ. FILL) GO TO 20 00000360 C ACCUMULATE SUMS OF SPACECRAFT FIELD COORDINATES 00000370 XSUM = XSUM + DBLE(XSCF(I)) 00000380 YSUM = YSUM + DBLE(YSCF(I)) 00000390 ZSUM = ZSUM + DBLE(ZSCF(I)) 00000400 C ACCUMULATE SUMS OF THE SQUARES OF THE SPACECRAFT FIELD COORDINATES. 00000410 X2SUM = X2SUM + (DBLE(XSCF(I))**2) 00000420 Y2SUM = Y2SUM + (DBLE(YSCF(I))**2) 00000430 Z2SUM = Z2SUM + (DBLE(ZSCF(I))**2) 00000440 C RN = THE COUNT OF THE NUMBER OF COORDINATES USED TO CALCULATE 00000450 C THE 48 SECOND AVERAGES. 00000460 RN = RN + 1. 00000470 20 CONTINUE 00000480 RETURN 00000490 ENTRY ENDSCF 00000500 C A CALL TO ENDSCF CAUSES THE 48 SECOND AVERAGES OF SPACECRAFT FIELD 00000510 C AND RMS TO BE CALCULATED AND PLACED IN THE DATA BLOCK WHERE THEY 00000520 C WILL BE WRITTEN TO THE SUMMARY TAPE. 00000530 FIRST = .TRUE. 00000540 IF (RN .EQ. 0.) GO TO 30 00000550 C CALCULATE 48 SECOND AVERAGE OF SPACECRAFT FIELD COORDINATES. 00000560 DSCX = XSUM / RN 00000570 DSCY = YSUM / RN 00000580 DSCZ = ZSUM / RN 00000590 SCX = DSCX 00000600 SCY = DSCY 00000610 SCZ = DSCZ 00000620 C CALCULATE SPACECRAFT FIELD AVERAGED OVER 48 SECONDS. 00000630 SCF = DSQRT(DSCX**2 + DSCY**2 + DSCZ**2) 00000640 NSC = RN 00000650 C CALCULATE RMS FOR 48 SECOND PERIOD. 00000660 TEMP = (X2SUM / RN) - (DSCX ** 2) 00000665 IF (TEMP .LT. 0.) TEMP = 0. 00000666 RMSXSC = DSQRT(TEMP) 00000670 TEMP = (Y2SUM / RN) - (DSCY ** 2) 00000675 IF (TEMP .LT. 0.) TEMP = 0. 00000676 RMSYSC = DSQRT(TEMP) 00000680 TEMP = (Z2SUM / RN) - (DSCZ ** 2) 00000685 IF (TEMP .LT. 0.) TEMP = 0. 00000686 RMSZSC = DSQRT(TEMP) 00000690 RETURN 00000700 C IF NO VALID SPACECRAFT FIELD COORDINATES WERE OBTAINED, 00000710 C SET ALL VALUES TO FILL. 00000720 30 SCX = FILL 00000730 SCY = FILL 00000740 SCZ = FILL 00000750 SCF = FILL 00000760 RMSXSC = FILL 00000770 RMSYSC = FILL 00000780 RMSZSC = FILL 00000790 NSC = 0 00000800 RETURN 00000810 END 00000820 SUBROUTINE BIGAVE(STS,FLAG,N) 00010000 LOGICAL*1 SYS(32),MAG(32),LCS3 00030000 LOGICAL ROT 00040000 INTEGER*4 STS(5),NWORD*2(2) 00050000 INTEGER*2 ITB(6) 00051000 REAL*4 MATRIX(9),SPV(6),ANG(2),TTB(3,3),TTB5(3,3),THG(3,3) 00060000 REAL*4 AX19(25),AY19(25),AZ19(25),AF219(25),AF196(5),AF296(5), 00070000 X AX96(5),AY96(5),AZ96(5),ARMS96(3,5),AF148,AF248,AX48,AY48, 00080000 X AZ48,ARMS48 00090000 INTEGER*4 AM96(5),AM48 00100000 REAL*8 TP,TN,FLAG(5),TIME,HDR9 00110000 DIMENSION HDR(32),DATA(341),POSN(13),ATTD(27) 00120000 1 ,X19(25) ,Y19(25) ,Z19(25) ,F119(25) ,F219(25) 00130000 2 ,M19(25) ,TH19(25) ,PH19(25) ,RMS19(3,25) 00140000 3 ,X96(5) ,Y96(5) ,Z96(5) ,F196(5) ,M96(5) 00150000 4 ,F296(5) ,TH96(5) ,PH96(5) ,RMS96(3,5),RMS48(3) 00160000 5 ,SCFLD(155),XSC(50) ,YSC(50) ,ZSC(50) 00170000 COMMON /CCA/ WORK(500) 00180000 COMMON /OUTPUT/ SUMOUT(568) 00190000 EQUIVALENCE (ITB(1),SUMOUT(4)) 00191000 EQUIVALENCE (SUMOUT(1),HDR(1)) ,(SUMOUT(33),DATA(1)) 00200000 1 ,(DATA(1),F148) ,(DATA(2),F248) ,(DATA(3),TH48) 00210000 2 ,(DATA(4),PH48) ,(DATA(5),X48) ,(DATA(6),Y48) 00220000 3 ,(DATA(7),Z48) ,(DATA(8),RMS48(1)) ,(DATA(11),M48) 00230000 4 ,(DATA(12),F196(1)) ,(DATA(17),F296(1)) ,(DATA(22),TH96(1)) 00240000 5 ,(DATA(27),PH96(1)) ,(DATA(32),X96(1)) ,(DATA(37),Y96(1)) 00250000 6 ,(DATA(42),Z96(1)) ,(DATA(47),RMS96(1,1)) ,(DATA(62),M96(1)) 00260000 7 ,(DATA(67),F119(1)) ,(DATA(92),F219(1)) ,(DATA(117),TH19(1)) 00270000 8 ,(DATA(142),PH19(1)),(DATA(167),X19(1)) ,(DATA(192),Y19(1)) 00280000 9 ,(DATA(217),Z19(1)) ,(DATA(242),RMS19(1,1)),(DATA(317),M19(1)) 00290000 A ,(WORK(1),SYS(1)) ,(WORK(9),MAG(1)) ,(WORK(66),MATRIX(1)) 00300000 B ,(WORK(65),ROT) 00310000 EQUIVALENCE (SUMOUT(529),POSN(1)),(SUMOUT(542),ATTD(1)), 00320000 X (POSN(1),TN), (POSN(3),TP), (POSN(5),SPV(1)), 00330000 X (POSN(11),RANGE), (POSN(12),ANG(1)), (ATTD(1),TTB(1,1)), 00340000 X (ATTD(10),TTB5(1,1)), (ATTD(19),THG(1,1)), (SUMOUT(374),SCFLD(1))00350000 X,(SCFLD(155),SCF48), (SCFLD(154),SCZ48), (SCFLD(153),SCY48), 00360000 X (SCFLD(152),SCX48), (SCFLD(151),NSC), (SCFLD(1),XSC(1)), 00370000 X (SCFLD(51),YSC(1)), (SCFLD(101),ZSC(1)), (NWORD(1),HDR(32)) 00380000 EQUIVALENCE (HDR(9),HDR9) 00390000 DATA LEN/2272/ 00400000 C 00410000 C SUMOUT IS THE SUMMARY TAPE MAG RECORD 00411000 C 00420000 C LEN(SUMOUT) = HDR + DATA + SCF + POSITION + ATTITUDE + SPARE 00430000 C 568 = 32 + 341 + 155 + 13 + 27 00440000 C 00450000 C COMPUTE MAGNETIC FIELD AVERAGES 00460000 C 5 9.6 SEC AVE 00470000 C 1 48.0 SEC AVE 00480000 C 00490000 NWORD(2) = 536 00500000 SUMOUT(12) = 48.0 00510000 LCS3 = SYS(3).AND.(SYS(10).OR.SYS(9)) 00520000 IF (MAG(28)) GO TO 20 00530000 IF (SYS(3)) 00540000 X CALL SEDR(HDR(4),HDR(9),HDR(12),TTB,TTB5,ANG,RANGE,SPV,THG,TP,TN)00550000 IF (.NOT. LCS3) GO TO 11 00560000 CALL FMOVE (AX19,100,X19) 00570000 CALL FMOVE (AY19,100,Y19) 00580000 CALL FMOVE (AZ19,100,Z19) 00590000 CALL FMOVE (AF219,100,F219) 00600000 CALL ROTATE (AX19,AY19,AZ19,25,TTB5) 00610000 11 CONTINUE 00620000 IF (ROT .AND. .NOT. MAG(9)) CALL ROTATE (X19,Y19,Z19,25,MATRIX) 00630001 IF (LCS3) GO TO 12 00640000 CALL ANGLES (TH19,PH19,X19,Y19,Z19,F219,25) 00650000 GO TO 13 00660000 12 CALL ANGLES (TH19,PH19,AX19,AY19,AZ19,AF219,25) 00670000 13 CONTINUE 00680000 GO TO 75 00690000 20 CONTINUE 00700000 DO 71 I=1,25 00710000 TIME = HDR9 + 1.92D0*(I-1)/86400.D0 00720000 IF (SYS(3)) 00730000 X CALL SEDR(HDR(4),TIME,1.92E0,TTB,TTB5,ANG,RANGE,SPV,THG,TP,TN) 00740000 IF (.NOT.LCS3) GO TO 41 00750000 AX19(I) = X19(I) 00760000 AY19(I) = Y19(I) 00770000 AZ19(I) = Z19(I) 00780000 AF219(I) = F219(I) 00790000 CALL ROTATE (AX19(I),AY19(I),AZ19(I),1,TTB5) 00800000 41 CONTINUE 00810000 IF (ROT .AND. .NOT. MAG(9)) 00820001 1 CALL ROTATE(X19(I),Y19(I),Z19(I),1,MATRIX) 00821001 IF (LCS3) GO TO 42 00830000 CALL ANGLES(TH19(I),PH19(I),X19(I),Y19(I),Z19(I),F219(I),1) 00840000 GO TO 43 00850000 42 CALL ANGLES(TH19(I),PH19(I),AX19(I),AY19(I),AZ19(I),AF219(I),1) 00860000 43 CONTINUE 00870000 71 CONTINUE 00880000 75 CONTINUE 00890000 IF(MAG( 1)) CALL PRT192(HDR(7),STS,FLAG,N) 00900000 C COMPUTE 9.6 SEC AVE 00910000 J = 0 00920000 DO 50 I=1,25,5 00930000 J = J + 1 00940000 CALL STAT(X19(I),Y19(I),Z19(I),5,M96(J),F196(J),F296(J),X96(J) 00950000 1 ,Y96(J),Z96(J),RMS96(1,J)) 00960000 IF (LCS3) 00970000 X CALL STAT (AX19(I),AY19(I),AZ19(I),5,AM96(J),AF196(J),AF296(J), 00980000 X AX96(J),AY96(J),AZ96(J),ARMS96(1,J)) 00990000 50 CONTINUE 01000000 IF (LCS3) GO TO 44 01010000 CALL ANGLES(TH96,PH96,X96,Y96,Z96,F296,5) 01020000 GO TO 45 01030000 44 CALL ANGLES(TH96,PH96,AX96,AY96,AZ96,AF296,5) 01040000 45 CONTINUE 01050000 C 01060000 C COMPUTE 48.0 SEC AVE 01070000 C 01080000 CALL STAT(X96,Y96,Z96,5,M48,F148,F248,X48,Y48,Z48,RMS48) 01090000 IF (LCS3) GO TO 46 01100000 CALL ANGLES(TH48,PH48,X48,Y48,Z48,F248,1) 01110000 GO TO 47 01120000 46 CALL STAT(AX96,AY96,AZ96,5,AM48,AF148,AF248,AX48,AY48,AZ48, 01130000 X ARMS48) 01140000 CALL ANGLES(TH48,PH48,AX48,AY48,AZ48,AF248,1) 01150000 47 CONTINUE 01160000 C 01170000 IF (MAG(26)) WRITE (26,100) ITB, X48, Y48, Z48 01171000 100 FORMAT (6I5, 3F8.4) 01172000 IF(SYS(21)) CALL MFILM (SUMOUT(4),SUMOUT,DATA,RANGE,SPV) 01180000 IF(MAG( 2)) CALL PRT48(HDR(7),STS,FLAG,N) 01190000 IF(SYS(20)) CALL SUMTAP(SUMOUT,LEN,HDR(4),HDR(13),HDR(17)) 01200000 IF(MAG( 3)) CALL HAVE(DATA(5),HDR(4),POSN(5),SCF48,WORK(60), 01210000 1 F219,HDR(3)) 01220000 RETURN 01230000 END 01240000 SUBROUTINE BLOCK(BUFFER,IBUFFR,TIM,F1,F2,TH,PH,X,Y,Z,RMS,N,Q,L,M) 00000100 C ********** =W82JB.BLOCK ********** 00000105 INTEGER*2 IBUFFR(5,120),GOOD/' '/ 00000110 INTEGER Q(1) 00000115 REAL*8 TIM(1) 00000120 DIMENSION BUFFER(9,120), F1(1),F2(1),TH(1),PH(1),X(1),Y(1),Z(1) 00000130 1 ,RMS(3,1),N(1) 00000140 C 00000150 C SUBROUTINE TO SAVE DATA IN BUFFER UNTIL ENOUGH HAS 00000160 C ACCUMULATED TO DUMP ON PRINTER (ONE PAGE) 00000170 C 00000180 DO 40 I=1,M 00000190 ID = TIM(I) 00000200 D = TIM(I) - ID 00000210 MIN = AMOD(D*1440.,60.) 00000220 SEC = AMOD(D*86400.,60.) 00000230 L = L + 1 00000235 IBUFFR(1,L) = MIN 00000240 IBUFFR(2,L) = TH(I) + SIGN(.5,TH(I)) 00000250 IBUFFR(3,L) = PH(I) +.5 00000260 IBUFFR(4,L) = GOOD 00000264 C IF(Q(I) .NE. 0) CALL CLASFY(Q(I),IBUFFR(4,L)) 00000268 IBUFFR(5,L) = N(I) 00000270 BUFFER(1,L) = SEC 00000280 BUFFER(2,L) = F1(I) 00000290 BUFFER(3,L) = F2(I) 00000300 BUFFER(4,L) = X(I) 00000310 BUFFER(5,L) = Y(I) 00000320 BUFFER(6,L) = Z(I) 00000330 BUFFER(7,L) = RMS(1,I) 00000340 BUFFER(8,L) = RMS(2,I) 00000350 BUFFER(9,L) = RMS(3,I) 00000360 40 CONTINUE 00000370 RETURN 00000380 END 00000390 SUBROUTINE BSPAN(PTIME,PEND,TPEAK,MTIME,MEND, 00000100 1 MBLOCK,ANS,F1,F2,X,Y,Z,RMS,N,/NP/,*) 00000200 LOGICAL FOUND/.FALSE./ 00000300 INTEGER*2 GMT(6) 00000400 REAL*4 MBLOCK(1) 00000500 REAL*8 PTIME,PEND,TPEAK,MTIME,MEND,DEL,TIME 00000600 1 ,SX/0.D0/,SY/0.D0/,SZ/0.D0/,S2X/0.D0/,S2Y/0.D0/ 00000700 2 ,S2Z/0.D0/,S2/0.D0/,XA,YA,ZA,SAR 00000800 DIMENSION ANS(1),F1(1),F2(1),X(1),Y(1),Z(1),RMS(3,1),N(1) 00000900 DATA NT/0/ 00001000 C 00001100 C =U2EDR.BSPAN 00001200 C 00001300 IF(PTIME .GE. MEND) RETURN 1 00001400 IF(PEND .LE. MTIME) GO TO 50 00001500 IF((MTIME .LE. TPEAK) .AND. (TPEAK .LT. MEND)) 00001600 1 CALL PICKUP(MBLOCK,MTIME,TPEAK,NP,F1,F2,X,Y,Z,RMS,N,ANS,FOUND) 00001700 C 00001800 C SUM DATA OVER SAMPLE TIME OF PLS BLOCK 00001900 C 00002000 M = 0 00002100 DEL = MBLOCK(31)/86400.0D0 00002200 DO 10 I=1,NP 00002300 TIME = MTIME + (I-1)*DEL 00002400 IF(TIME .LT. PTIME) GO TO 10 00002500 IF(TIME .GT. PEND) GO TO 50 00002600 M = M + 1 00002700 IF(F1(I) .EQ. 999.) GO TO 10 00002800 SX = SX + X(I) 00002900 SY = SY + Y(I) 00003000 SZ = SZ + Z(I) 00003100 S2X = S2X + X(I)*X(I) 00003200 S2Y = S2Y + Y(I)*Y(I) 00003300 S2Z = S2Z + Z(I)*Z(I) 00003400 S2 = ((RMS(1,I) + RMS(2,I) + RMS(3,I))/3.)**2 00003500 NT = NT + 1 00003600 10 CONTINUE 00003700 IF(M .EQ. 0) RETURN 1 00003800 IF(MEND .LT. PEND) RETURN 1 00003900 GO TO 50 00004000 C 00004100 ENTRY ENDFLD(TPEAK,ANS,*) 00004200 CALL SETIME(0,TPEAK,GMT) 00004300 WRITE(6,170) GMT 00004400 170 FORMAT(' GETFLD - MAG QUEUE EMPTY AT TIME',2I4,3(':',I2),'.' 00004500 1 ,I3,' USE LAST AVAILABLE MAG DATA') 00004600 50 CONTINUE 00004700 IF(.NOT. FOUND) CALL GETOLD(TPEAK,ANS) 00004800 FOUND = .FALSE. 00004900 C 00005000 C COMPUTE AVERAGE 00005100 C DO NOT SAVE UNTIL OK FROM MIT 00005200 C S, XA, YA, ZA ARE OUTPUT 00005300 C 00005400 IF(NT .EQ. 0) GO TO 75 00005500 XA = SX/NT 00005600 YA = SY/NT 00005700 ZA = SZ/NT 00005800 SAR = S2/NT + ((S2X/NT - XA*XA) + 00005900 1 (S2Y/NT - YA*YA) + 00006000 2 (S2Z/NT - ZA*ZA))/3. 00006100 IF (SAR.LT.0.D0) GO TO 30 00006200 S = DSQRT(SAR) 00006300 GO TO 75 00006400 30 S = 0.E0 00006500 WRITE (6,2001) SAR 00006600 75 CONTINUE 00006700 SX = 0.D0 00006800 SY = 0.D0 00006900 SZ = 0.D0 00007000 S2X = 0.D0 00007100 S2Y = 0.D0 00007200 S2Z = 0.D0 00007300 S2 = 0.D0 00007400 NT = 0 00007500 RETURN 00007600 2001 FORMAT ('0WARNING: NEGATIVE SQRT IN BSPAN ',1PD11.3/'0') 00007700 END 00007800 SUBROUTINE CCHECK(SCN,ADDR) 00000100 EXTERNAL WRITE2 00000110 INTEGER SCN,OLDSCN/-1/,SCID(3)/'FLT1','FLT2','PTM '/,ADDR 00000120 REAL*8 DDN(3,3),NAME(3),DATE,DIND 00000130 DIMENSION TYPE(3),ADDR(3) 00000140 COMMON /CCA/ WORK(500) 00000150 EQUIVALENCE (WORK(83),DDN(1,1)) 00000160 DATA NAME/3*'NONAME '/,TYPE/'ZERO','SENS','CAL '/ 00000170 C 00000180 C CHECK TO SEE IF CURRENT MAG CONSTANTS ARE VALID, IF NOT, 00000190 C READ IN A NEW SET. 00000200 C 00000210 C I = 1 = ZERO LEVELS ID = 1 = FLT1 00000220 C 2 = SENSITIVITIES 2 = FLT2 00000230 C 3 = CALIBRATION 3 = PTM 00000240 C 00000250 IF(SCN .EQ. OLDSCN) GO TO 10 00000260 OLDSCN = SCN 00000270 DO 5 ID=1,3 00000280 5 IF(SCN .EQ. SCID(ID)) GO TO 10 00000290 WRITE(6,888) 888 FORMAT(' SNAP REPLACED, SCID NOT EQUAL TO FLT1 OR FLT2') C CALL SNAP(OLDSCN,NAME) 00000300 RETURN 00000310 C 00000320 10 CONTINUE 00000330 DO 30 I=1,3 00000340 IF(DDN(ID,I) .EQ. NAME(I)) GO TO 30 00000350 CALL LOADER(DDN(ID,I),NAME(I),ADDR(I),&90,&90) 00000360 WRITE(6,160) TYPE(I),DDN(ID,I),SCID(ID),ADDR(I) 00000370 DATE = DIND(ADDR(I)) 00000380 ADDR(I) = ADDR(I) + 8 00000390 WRITE(2,180) TYPE(I),SCN,DDN(ID,I),DATE 00000400 CALL LINK(ADDR(I),WRITE2) 00000410 30 CONTINUE 00000420 RETURN 00000430 C 00000440 90 CONTINUE 00000450 WRITE(6,150) TYPE(I),DDN(ID,I),SCID(ID) 00000460 WRITE(2,150) TYPE(I),DDN(ID,I),SCID(ID) 00000470 C ABEND NOT SUPPORTED UNDER MVS/XA T. MCCLANAHAN 11/4/91 C C CALL ABEND(93) 00000480 RETURN 00000490 150 FORMAT(' LOADER UNABLE TO FIND ',A4,' DATA MEMBER, DDN=', 00000500 1 A8,' FOR SPACECRAFT ',A4) 00000510 160 FORMAT(1X,A4,' DATA LOADED FOR DDN ',A8,' SPACECRAFT ',A4, 00000520 1 ' WITH ADDRESS OF ',Z8) 00000530 180 FORMAT(///,1X,A4,' DATA CONSTANTS FOR ',A4,' LOADED WITH NAME ', 00000540 1 A8,' AND GENERATION DATE OF ',A7) 00000550 END 00000560 SUBROUTINE DATCON(IYR,IDY,MON,IDM) 00000100 C**** U2DRH.DATCON 00000150 DIMENSION MONTH(12),JUL(12) 00000200 DATA JUL/31,59,90,120,151,181,212,243,273,304,334,365/ 00000300 DATA MONTH/' JAN',' FEB',' MAR',' APR',' MAY','JUNE','JULY' 00000400 1 ,' AUG','SEPT',' OCT',' NOV',' DEC'/ 00000500 C 00000600 C 00000700 LEAP=(4-MOD(IYR,4))/4 00000800 DO 10 I=1,12 00000900 L=LEAP*((I+10)/12) 00001000 IF(IDY .LE. JUL(I)+L) GO TO 20 00001100 10 CONTINUE 00001200 20 MON=MONTH(I) 00001300 IF(I .EQ. 1) GO TO 30 00001400 IF (I.EQ.2) GO TO 40 00001450 IDM=MOD(IDY,JUL(I-1)+L) 00001500 RETURN 00001600 30 IDM = IDY 00001700 RETURN 00001800 40 IDM = IDY - 31 00001840 RETURN 00001880 END 00001900 SUBROUTINE DEBUG 00001000 C ********** =U2DRH.DEBUG ********** 00001500 INTEGER*2 ITB(6) 00002000 DIMENSION BLOCK(21) 00003000 C 00004000 ENTRY PSTACK(ID,ICNT) 00005000 WRITE(6,150) ID,ICNT 00006000 RETURN 00007000 C 00008000 ENTRY PCHAIN(BLOCK,ITB) 00009000 WRITE(6,160) BLOCK(1),BLOCK(19),BLOCK(20),BLOCK(21),ITB 00010000 RETURN 00011000 150 FORMAT(' DUMP OF DATA TABLE CHAIN FOR ',A3,' WITH ',I4, 00012000 1 ' FREE BLOCKS IN THE STACK') 00013000 160 FORMAT(' BLOCK ADDRESS ',Z8,3(1X,A4),' STARTS AT ',I2,I4 00014000 1 ,3(':',I2),'.',I3) 00015000 END 00016000 SUBROUTINE DECOM(MAP) 00000100 C 00000200 C =U22LB.DECOM BY G. BURGESS 00000300 C 00000400 LOGICAL*1 SYS(32) 00000500 INTEGER*2 MAP(358),ITB(6) 00000600 REAL*8 TIME 00000700 COMMON /CCA/ WORK(500) 00000800 EQUIVALENCE(WORK(1),SYS(1)) 00000900 EQUIVALENCE(WORK(300),IDEC),(WORK(301),OUTDEC(1)) 00001000 EQUIVALENCE(WORK(404),NDEC),(WORK(405),OUTDC1(1)) 00001100 INTEGER EDR1 00001200 COMMON /EDR/ EDR1 00001300 INTEGER*2 OUTDEC(21),OUTDC1(27) 00001400 INTEGER*2 TABLE(223)/ 100,101,102,103,104,105,106,107,108,109,110,00001500 * 111,112,113,114,115,300,301,302,303,304,305,306,307,308,309,310,00001600 * 311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,00001700 * 327,328,329,117,118,119,500,501,502,503,504,505,506,507,508,509,00001800 * 510,511,512,513,514,121,122,123,124,200,201,202,203,204,205,206,00001900 * 207,208,209,126,127,128,129,400,401,402,403,404,405,406,407,408,00002000 * 409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,00002100 * 425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,00002200 * 441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,00002300 * 457,458,459,131,132,133,134,135,136,137,138,139,140,141,142,143,00002400 * 144,145,330,331,332,333,334,335,336,337,338,339,340,341,342,343,00002500 * 344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,00002600 * 147,148,149,600,601,602,603,604,605,606,607,608,609,610,611,612,00002700 * 613,614,151,152,153,154,210,211,212,213,214,215,216,217,218,219,00002800 * 156,157,158,159/ 00002900 INTEGER*2 INDEC(21)/620,621,622,623,624,625,626,627, 00003000 * 660,661,662,663,664,665,666,667,668,669,670,671,672/ 00003100 INTEGER*2 INDEC1(27)/172,174,175,176,177,178,179,181,182,183,184, 00003200 * 185,186,189,190,191,197,200,201,202,203,204,205,620,621,622,623/00003300 IF(.NOT.SYS(31))GO TO 110 00003400 WRITE(6,100) 00003500 WRITE(6,160) TABLE 00003600 110 CONTINUE 00003700 IDEC=21 00003800 C 00003900 DO 50 I=1,IDEC 00004000 DO 10 N=1,223 00004100 M=N+134 00004200 IF(MAP(M).EQ.INDEC(I))GO TO 20 00004300 10 CONTINUE 00004400 OUTDEC(I)=0 00004500 GO TO 50 00004600 20 CONTINUE 00004700 OUTDEC(I)=TABLE(N) 00004800 50 CONTINUE 00004900 NDEC=27 00005000 DO 60 I=1,NDEC 00005100 DO 70 N=1,223 00005200 M=N+134 00005300 IF(MAP(M).EQ.INDEC1(I))GO TO 75 00005400 70 CONTINUE 00005500 OUTDC1(I)=0 00005600 GO TO 60 00005700 75 OUTDC1(I)=TABLE(N) 00005800 60 CONTINUE 00005900 CALL TSET(EDR1+8,IYR,TIME,DUM,DUM) 00006000 CALL SETIME(IYR,TIME,ITB) 00006100 WRITE(6,150) ITB 00006200 IF(SYS(31)) WRITE(6,160) (MAP(I),I=135,357) 00006300 RETURN 00006400 100 FORMAT(' ','MJS77 ENGINEERING TELEMETRY FORMAT STRUCTURE') 00006500 150 FORMAT(' RECIEVED NEW ENGINEERING DECOMUTATION MAP AT TIME ' 00006600 1 ,I2,I4,3(':',I2),'.',I3) 00006700 160 FORMAT(20(1X,I4)) 00006800 END 00006900 SUBROUTINE DMFIX(XP,YP,ZP,/NP/,XS,YS,ZS,/NS/,XPREF,YPREF,ZPREF, 00000100 1 XSREF,YSREF,ZSREF,GMT,IMODE) 00000110 INTEGER*2 GMT(6),NP,NS,N 00000120 INTEGER XP(1),YP(1),ZP(1),XS(1),YS(1),ZS(1) 00000130 1 ,XPREF(1),YPREF(1),ZPREF(1),XSREF(1),YSREF(1),ZSREF(1) 00000140 2 ,XPDX(6),YPDX(5),ZPDX(5),XSDX(6),YSDX(5),ZSDX(5) 00000150 3 ,XPLAST/2048/,XSLAST/2048/,YPDIFF/0/,YSDIFF/0/,ZPDIFF/0/ 00000160 4 ,ZSDIFF/0/,DELP(3),DELS(3),PREF(3),SREF(3),KELP(3),KELS(3) 00000170 COMMON /HEADER/ LFM(6) 00000180 C 00000190 C CORRECT FOR DRIFT IN DELTA MODULATION STRING =W82JS.DMFIX00000200 C 00000210 C 0 1 2 3 00000220 C 0 0 0 0 00000230 C DDDDDDDDDDDDDDDDDDDDDDDDDDDDDD STRING OF DM OUTPUT SAMPLES 00000240 C X Y Z X 00000250 C R R R R FULL WORD REFERENCE LOCATIONS 00000260 C 00000270 C CR-6 PRIME MAG HAS 30 DM SAMPLES PER SEQUENCE 00000280 C CR-6 SECONDARY MAG HAS 15 DM SAMPLES PER SEQUENCE 00000290 C 00000300 CALL LOOK(LFM,DELP,DELS,PREF,SREF,IMODE) 00000310 CALL DXSAVE(XP(29),XPDX(2),NP,30) 00000320 CALL DXSAVE(XS(14),XSDX(2),NS,15) 00000330 C 00000340 CALL DXSAVE(YP(9),YPDX,NP,30) 00000350 CALL DXSAVE(YS(4),YSDX,NS,15) 00000360 C 00000370 CALL DXSAVE(ZP(19),ZPDX,NP,30) 00000380 CALL DXSAVE(ZS(9),ZSDX,NS,15) 00000390 C 00000400 C REMOVE DC LEVEL TO LINE UP WITH LEFT FULL WORD 00000410 C 00000420 CALL XSHIFT(XP,XPREF,XPLAST,NP,PREF(1)) 00000430 CALL XSHIFT(XS,XSREF,XSLAST,NS,SREF(1)) 00000440 KELP(1) = XP(NP-1) - XPDX(6) 00000450 KELS(1) = XS(NS-1) - XSDX(6) 00000460 IF(XPDX(6) .EQ. 99999) KELP(1) = 99999 00000464 IF(XSDX(6) .EQ. 99999) KELS(1) = 99999 00000468 C 00000470 CALL YZSHIF(YP,YPREF,YPDIFF,NP,20) 00000480 CALL YZSHIF(YS,YSREF,YSDIFF,NS,10) 00000490 KELP(2) = DELP(2) + YPDIFF 00000500 KELS(2) = DELS(2) + YSDIFF 00000510 IF(DELP(2) .LE. 0) KELP(2) = 99999 00000514 IF(DELS(2) .LE. 0) KELS(2) = 99999 00000518 C 00000520 CALL YZSHIF(ZP,ZPREF,ZPDIFF,NP,10) 00000530 CALL YZSHIF(ZS,ZSREF,ZSDIFF,NS,5) 00000540 KELP(3) = DELP(3) + ZPDIFF 00000550 KELS(3) = DELS(3) + ZSDIFF 00000560 IF(DELP(3) .LE. 0) KELP(3) = 99999 00000564 IF(DELS(3) .LE. 0) KELS(3) = 99999 00000568 C 00000570 C ROTATE DM STRING ABOUT LEFT FULL WORD TO MATCH 00000580 C LEVEL OF FULL WORD ON RIGHT 00000590 C 00000600 CALL PIVOT(XP,XPREF,XPDX,30,30,PREF(1),KELP(1),NP,5) 00000610 CALL PIVOT(XS,XSREF,XSDX,15,15,SREF(1),KELS(1),NS,5) 00000620 IF(PREF(1) .NE. 0) XP(NP) = PREF(1) 00000630 IF(SREF(1) .NE. 0) XS(NS) = SREF(1) 00000640 C 00000650 CALL PIVOT(YP,YPREF,YPDX,30,10,PREF(2),KELP(2),NP,5) 00000660 CALL PIVOT(YS,YSREF,YSDX,15,5,SREF(2),KELS(2),NS,5) 00000670 C 00000680 CALL PIVOT(ZP,ZPREF,ZPDX,30,20,PREF(3),KELP(3),NP,5) 00000690 CALL PIVOT(ZS,ZSREF,ZSDX,15,10,SREF(3),KELS(3),NS,5) 00000700 C 00000710 RETURN 00000720 END 00000730 SUBROUTINE DMFIX5(XP,YP,ZP,/NP/,XS,YS,ZS,/NS/,XPREF,YPREF,ZPREF, 00000010 1 XSREF,YSREF,ZSREF,GMT,IMODE) 00000020 INTEGER*2 GMT(6),NP,NS 00000030 INTEGER XP(1),YP(1),ZP(1),XS(1),YS(1),ZS(1) 00000040 1 ,XPREF(1),YPREF(1),ZPREF(1),XSREF(1),YSREF(1),ZSREF(1) 00000050 2 ,XPDX(11),YPDX(11),ZPDX(11) 00000060 X ,XSDX(6),YSDX(6),ZSDX(6) 00000070 3 ,XPLAST/2048/,XSLAST/2048/ 00000080 4 ,DELP(3),DELS(3),PREF(3),SREF(3),KELP(3),KELS(3) 00000090 INTEGER YPLAST/2048/,YSLAST/2048/,ZPLAST/2048/,ZSLAST/2048/ 00000100 COMMON /HEADER/ LFM(6) 00000110 C 00000120 C CORRECT FOR DRIFT IN DELTA MODULATION STRING 00000130 C 00000140 CALL LOOK(LFM,DELP,DELS,PREF,SREF,IMODE) 00000150 C 00000160 C CR-5 PRIME MAG HAS 20 DM SAMPLES PER SEQUENCE 00000170 C CR-5 SECONDARY MAG HAS 10 DM SAMPLES PER SEQUENCE 00000180 C 00000190 CALL DXSAVE(XP(19),XPDX(2),NP,20) 00000200 CALL DXSAVE(XS(09),XSDX(2),NS,10) 00000210 C 00000220 CALL DXSAVE(YP(19),YPDX(2),NP,20) 00000230 CALL DXSAVE(YS(09),YSDX(2),NS,10) 00000240 C 00000250 CALL DXSAVE(ZP(19),ZPDX(2),NP,20) 00000260 CALL DXSAVE(ZS(09),ZSDX(2),NS,10) 00000270 C 00000280 C REMOVE DC LEVEL TO LINE UP WITH LEFT FULL WORD 00000290 C 00000300 CALL DMSHF5(XP,XPREF,XPLAST,NP,PREF(1),10) 00000310 CALL DMSHF5(XS,XSREF,XSLAST,NS,SREF(1),5) 00000320 KELP(1) = XP(NP-1) - XPDX(11) 00000330 KELS(1) = XS(NS-1) - XSDX(6) 00000340 IF(XPDX(11).EQ. 99999) KELP(1) = 99999 00000350 IF(XSDX(6) .EQ. 99999) KELS(1) = 99999 00000360 C 00000370 CALL DMSHF5(YP,YPREF,YPLAST,NP,PREF(2),10) 00000380 CALL DMSHF5(YS,YSREF,YSLAST,NS,SREF(2),5) 00000390 KELP(2) = YP(NP-1) - YPDX(11) 00000400 KELS(2) = YS(NS-1) - YSDX(6) 00000410 IF(YPDX(11).EQ. 99999) KELP(2) = 99999 00000420 IF(YSDX(6) .EQ. 99999) KELS(2) = 99999 00000430 C 00000440 CALL DMSHF5(ZP,ZPREF,ZPLAST,NP,PREF(3),10) 00000450 CALL DMSHF5(ZS,ZSREF,ZSLAST,NS,SREF(3),5) 00000460 KELP(3) = ZP(NP-1) - ZPDX(11) 00000470 KELS(3) = ZS(NS-1) - ZSDX(6) 00000480 IF(ZPDX(11).EQ. 99999) KELP(3) = 99999 00000490 IF(ZSDX(6) .EQ. 99999) KELS(3) = 99999 00000500 C 00000510 C ROTATE DM STRING ABOUT LEFT FULL WORD TO MATCH 00000520 C LEVEL OF FULL WORD ON RIGHT 00000530 C 00000540 CALL PIVOT(XP,XPREF,XPDX,20,20,PREF(1),KELP(1),NP,10) 00000550 CALL PIVOT(XS,XSREF,XSDX,10,10,SREF(1),KELS(1),NS,5) 00000560 CALL PIVOT(YP,YPREF,YPDX,20,20,PREF(2),KELP(2),NP,10) 00000570 CALL PIVOT(ZP,ZPREF,ZPDX,20,20,PREF(3),KELP(3),NP,10) 00000580 CALL PIVOT(ZS,ZSREF,ZSDX,10,10,SREF(3),KELS(3),NS,5) 00000590 CALL PIVOT(YS,YSREF,YSDX,10,10,SREF(2),KELS(2),NS,5) 00000600 C 00000610 IF(XP(NP-1).LE.0)RETURN 00000620 C 00000630 IF(PREF(1) .NE. 0) XP(NP) = PREF(1) 00000640 IF(SREF(1) .NE. 0) XS(NS) = SREF(1) 00000650 C 00000660 IF(PREF(2) .NE. 0) YP(NP) = PREF(2) 00000670 IF(SREF(2) .NE. 0) YS(NS) = SREF(2) 00000680 C 00000690 IF(PREF(3) .NE. 0) ZP(NP) = PREF(3) 00000700 IF(SREF(3) .NE. 0) ZS(NS) = SREF(3) 00000710 C 00000720 RETURN 00000730 END 00000740 C 00001000 C THIS CODE WAS REWRITTEN FROM HARDCOPY DUE TO LOSS 3/28/91 00002000 C T. MCCLANAHAN ST SYSTEMS, GSFC CODE694 00003000 C 00004000 C 00005000 SUBROUTINE DMSHF5(X,XREF,XLAST,N,NEXT,LOOP) 00010000 INTEGER*2 N 00020000 INTEGER XLAST,X(1),XDIFF,XREF(1),YZDIFF,YZ(1),YZREF(1),NEXT 00030000 C 00040000 C GIVEN DELTA MODULATOR OUTPUT STRING OF DATA, TIE IT 00050000 C DOWN TO THE LEVEL OF REFERENCE WORDS. 00060000 C 00070000 NL = N/LOOP 00080000 NL1 = NL - 1 00090000 XDIFF = XREF(1) - XLAST 00100000 IF (X(1) .LE. 0) XREF(1) = 0 00110000 IF (XLAST .LE. 0) XDIFF = XREF(1) - X(1) 00120000 IF (XREF(1) .EQ. 0) CALL NOFULL(XDIFF,X,NL1,&5) 00130000 CALL DRIFT(X(1),XDIFF,NL1) 00140000 5 K = NL 00150001 DO 10 I = 2, LOOP 00160000 XDIFF = XREF(I) - X(K) 00170000 IF (X(K) .LE. 0) XDIFF = XREF(I) - X(K+1) 00180000 IF (X(K+1) .LE. 0) XREF(I) = 0 00190000 IF (XREF(I) .EQ. 0) CALL NOFULL(XDIFF,X(K),NL,&10) 00200000 CALL DRIFT(X(K),XDIFF,NL) 00210000 10 K = K + NL 00220000 00221000 IF (XDIFF .NE. -999999) GO TO 20 00230000 X(N) = -1 00240000 RETURN 00250000 20 XLAST = X(N) 00260000 X(N) = NEXT 00270000 IF (NEXT .EQ. 0) X(N) = XLAST + XDIFF 00280000 RETURN 00290000 END 00300000 SUBROUTINE DMSHIF 00000100 INTEGER*2 N 00000110 INTEGER XLAST,X(1),XDIFF,XREF(1),YZDIFF,YZ(1),YZREF(1),NEXT 00000120 C 00000130 C =W82JS.DMSHIF00000140 C GIVEN DELTA MODULATOR OUTPUT STRING OF DATA, TIE IT 00000150 C DOWN TO THE LEVEL OF REFERENCE WORDS 00000160 C 00000170 ENTRY XSHIFT(X,XREF,XLAST,N,NEXT) 00000180 NL = N/5 00000190 NL1 = NL - 1 00000200 XDIFF = XREF(1) - XLAST 00000210 IF(XLAST .LE. 0) XDIFF = XREF(1) - X(1) 00000215 IF(XREF(1) .EQ. 0) CALL NOFULL(XDIFF,X,NL1,&5) 00000220 CALL DRIFT(X(1),XDIFF,NL1) 00000230 5 K = NL 00000240 DO 10 I=2,5 00000250 XDIFF = XREF(I) - X(K) 00000260 IF(X(K) .LE. 0) XDIFF = XREF(I) - X(K+1) 00000265 IF(XREF(I) .EQ. 0) CALL NOFULL(XDIFF,X(K),NL,&10) 00000270 CALL DRIFT(X(K),XDIFF,NL) 00000280 10 K = K + NL 00000290 XLAST = X(N) 00000300 X(N) = NEXT 00000310 IF(NEXT .EQ. 0) X(N) = XLAST + XDIFF 00000320 RETURN 00000330 C 00000340 ENTRY YZSHIF(YZ,YZREF,YZDIFF,N,L) 00000350 NL = N/5 00000360 NLP = NL - L 00000370 NL1 = NLP - 1 00000380 IF(YZDIFF .EQ. -999999) CALL NOFULL(YZDIFF,YZ(1),NL1,&15) 00000390 CALL DRIFT(YZ(1),YZDIFF,NL1) 00000400 15 K = NLP 00000410 DO 20 I=1,4 00000420 YZDIFF = YZREF(I) - YZ(K) 00000430 IF(YZ(K) .LE. 0) YZDIFF = YZREF(I) - YZ(K+1) 00000435 IF(YZREF(I) .EQ. 0) CALL NOFULL(YZDIFF,YZ(K),NL,&20) 00000440 CALL DRIFT(YZ(K),YZDIFF,NL) 00000450 20 K = K + NL 00000460 YZDIFF = YZREF(5) - YZ(K) 00000470 IF(YZ(K) .LE. 0) YZDIFF = YZREF(5) -YZ(K+1) 00000475 IF(YZREF(5) .EQ. 0) CALL NOFULL(YZDIFF,YZ(K),L+1,&30) 00000480 CALL DRIFT(YZ(K),YZDIFF,L+1) 00000490 30 RETURN 00000500 END 00000510 SUBROUTINE DPICR1(A,B,C,D,MODE,DPI) 00000100 LOGICAL*1 DPI(20) 00000110 INTEGER*2 A(1),B(1),C(1),D(1) 00000120 C =W82AL.DPICR1 00000130 GO TO(10,20),MODE 00000140 C FLAG MISSING E1 DATA 00000150 10 CONTINUE 00000160 IF(.NOT. DPI(20)) RETURN 00000170 DO 14 I=1,16 00000180 14 D(I) = -1 00000190 RETURN 00000200 C FLAG MISSING M MODE DATA 00000210 20 CONTINUE 00000220 IF(.NOT. DPI(1)) GO TO 30 00000230 DO 25 I=1,4 00000240 A(I) = -1 00000250 B(I) = -1 00000260 25 C(I) = -1 00000270 A(5) = -1 00000280 30 CONTINUE 00000290 IST = 14 00000300 DO 100 J=2,19 00000310 IF(.NOT. DPI(J)) GO TO 100 00000320 IEND = IST + 15 00000330 IF(J .EQ. 19) IEND = IEND - 1 00000340 M = (IST-1)/3 + 1 00000350 K = MOD(IST,3) + 1 00000360 GO TO (50,60,40),K 00000370 40 B(M) = -1 00000380 50 C(M) = -1 00000390 M = M + 1 00000400 60 M1 = M 00000410 M = IEND/3 00000420 K = MOD(IEND,3) + 1 00000430 GO TO (90,80,70),K 00000440 70 B(M+1) = -1 00000450 80 A(M+1) = -1 00000460 90 DO 95 I=M1,M 00000470 A(I) = -1 00000480 B(I) = -1 00000490 C(I) = -1 00000500 95 CONTINUE 00000510 100 IST = IST + 16 00000520 RETURN 00000540 END 00000550 SUBROUTINE DPICR2(A,B,C,D,MODE,DPI) 00000100 C 00000200 C =W82AL.DPICR2 BY G. BURGESS 00000300 C 00000400 LOGICAL*1 DPI(40) 00000500 INTEGER*2 A(1),B(1),C(1),D(1) 00000600 C 00000700 GO TO (10,20,30,40,50),MODE 00000800 C - FLAG MISSING E1 MODE DATA 00000900 10 CONTINUE 00001000 IF(.NOT.DPI(25)) GO TO 15 00001100 DO 14 J=1,14 00001200 14 D(J)=-1 00001300 15 CONTINUE 00001400 IF(.NOT.DPI(26)) RETURN 00001500 D(15)=-1 00001600 D(16)=-1 00001700 RETURN 00001800 C - FLAG MISSING L MODE DATA 00001900 20 CONTINUE 00002000 IF(.NOT.DPI(26)) GO TO 22 00002100 DO 21 J=1,3 00002200 A(J)=-1 00002300 B(J)=-1 00002400 C(J)=-1 00002500 21 D(J)=-1 00002600 22 CONTINUE 00002700 IF(.NOT.DPI(27)) GO TO 24 00002800 DO 23 J=4,7 00002900 A(J)=-1 00003000 B(J)=-1 00003100 C(J)=-1 00003200 IF(J.EQ.7)GO TO 24 00003300 23 D(J)=-1 00003400 24 CONTINUE 00003500 IF(.NOT.DPI(28)) GO TO 26 00003600 DO 25 J=7,11 00003700 IF(J.EQ.7)GO TO 25 00003800 A(J)=-1 00003900 B(J)=-1 00004000 IF(J.EQ.11)GO TO 26 00004100 C(J)=-1 00004200 25 D(J)=-1 00004300 26 CONTINUE 00004400 IF(.NOT.DPI(29))GO TO 28 00004500 DO 27 J=11,15 00004600 IF(J.EQ.11)GO TO 127 00004700 A(J)=-1 00004800 IF(J.EQ.15)GO TO 28 00004900 B(J)=-1 00005000 127 C(J)=-1 00005100 27 D(J)=-1 00005200 28 CONTINUE 00005300 IF(.NOT.DPI(30))RETURN 00005400 DO 128 J=15,16 00005500 IF(J.EQ.15)GO TO 129 00005600 A(J)=-1 00005700 129 B(J)=-1 00005800 C(J)=-1 00005900 128 D(J)=-1 00006000 RETURN 00006100 C - FLAG MISSING E2 MODE DATA 00006200 30 CONTINUE 00006300 IF(.NOT.DPI(30)) GO TO 32 00006400 DO 31 J=1,7 00006500 31 D(J)=-1 00006600 32 IF(.NOT.DPI(31)) RETURN 00006700 DO 33 J=8,16 00006800 33 D(J)=-1 00006900 RETURN 00007000 C - FLAG MISSING M MODE DATA 00007100 40 CONTINUE 00007200 IF(.NOT.DPI(31)) GO TO 42 00007300 A(1)=-1 00007400 B(1)=-1 00007500 C(1)=-1 00007600 42 CONTINUE 00007700 MF=32 00007800 L1=2 00007900 55 CONTINUE 00008000 DO 48 I=MF,37 00008100 IF(.NOT.DPI(I)) GO TO 46 00008200 L2=L1+4 00008300 DO 44 J=L1,L2 00008400 A(J)=-1 00008500 B(J)=-1 00008600 44 C(J)=-1 00008700 46 L1=L1+5 00008800 48 CONTINUE 00008900 RETURN 00009000 C**** WHEN MODE=5, A POINTS TO A(32), SAME FOR B AND C. 00009100 50 CONTINUE 00009200 MF=25 00009300 L1=1 00009400 GO TO 55 00009600 END 00009700 SUBROUTINE DPICR3(A,B,C,D,MODE,DPI) 00000100 C 00000110 C =W82AL.DPICR3 00000120 C 00000130 LOGICAL*1 DPI(40) 00000140 INTEGER*2 A(1),B(1),C(1),D(1) 00000150 C 00000160 GO TO (10,20,30,40,50),MODE 00000170 10 CONTINUE 00000180 IE1=1 00000190 IE2=2 00000200 IE3=8 00000210 35 CONTINUE 00000220 IF(.NOT.DPI(IE1))GO TO 12 00000230 DO 11 I=1,IE3 00000240 11 D(I)=-1 00000250 12 IF(.NOT.DPI(IE2))RETURN 00000260 IE3=IE3+1 00000270 DO 13 I=IE3,16 00000280 13 D(I)=-1 00000290 RETURN 00000300 C 00000310 20 CONTINUE 00000320 IF(DPI(2))A(1)=-1 00000330 L1=1 00000340 L2=3 00000350 L3=6 00000360 DO 200 N=3,7,2 00000370 IF(.NOT.DPI(N))GO TO 210 00000380 DO 220 I=L1,L2 00000390 IF(I.EQ.L1)GO TO 205 00000400 A(I)=-1 00000410 205 B(I)=-1 00000420 C(I)=-1 00000430 IF(I.EQ.L2)GO TO 210 00000440 220 D(I)=-1 00000450 210 IF(.NOT.DPI(N+1))GO TO 290 00000460 DO 230 I=L2,L3 00000470 IF(I.EQ.L2)GO TO 230 00000480 A(I)=-1 00000490 IF(I.EQ.L3)GO TO 290 00000500 B(I)=-1 00000510 C(I)=-1 00000520 230 D(I)=-1 00000530 290 CONTINUE 00000540 L1=L3 00000550 L2=L1+2 00000560 L3=L2+3 00000570 200 CONTINUE 00000580 IF(.NOT.DPI(9))RETURN 00000590 B(16)=-1 00000600 C(16)=-1 00000610 D(16)=-1 00000620 RETURN 00000630 C 00000640 30 CONTINUE 00000650 IE1=9 00000660 IE2=10 00000670 IE3=6 00000680 GO TO 35 00000690 C 00000700 40 CONTINUE 00000710 MM=1 00000720 M1=3 00000730 M2=6 00000740 M3=9 00000750 IDPI=10 00000760 DO 400 N=1,10 00000770 IDPI=IDPI+1 00000780 IF(.NOT.DPI(IDPI))GO TO 410 00000790 DO 402 I=MM,M1 00000800 A(I)=-1 00000810 IF(I.EQ.M1)GO TO 410 00000820 B(I)=-1 00000830 402 C(I)=-1 00000840 410 IDPI=IDPI+1 00000850 IF(.NOT.DPI(IDPI))GO TO 420 00000860 DO 414 I=M1,M2 00000870 IF(I.EQ.M1)GO TO 412 00000880 A(I)=-1 00000890 412 B(I)=-1 00000900 IF(I.EQ.M2)GO TO 420 00000910 414 C(I)=-1 00000920 420 IDPI=IDPI+1 00000930 IF(.NOT.DPI(IDPI))GO TO 450 00000940 DO 424 I=M2,M3 00000950 IF(I.EQ.M2)GO TO 424 00000960 A(I)=-1 00000970 B(I)=-1 00000980 424 C(I)=-1 00000990 450 CONTINUE 00001000 MM=M3+1 00001010 M1=M1+10 00001020 M2=M2+10 00001030 M3=M3+10 00001040 400 CONTINUE 00001050 50 CONTINUE 00001060 RETURN 00001070 END 00001080 SUBROUTINE DPICR4(A,B,C,D,MODE,DPI) 00000100 C 00000110 C =W82AL.DPICR4 00000120 C 00000130 LOGICAL*1 DPI(20) 00000140 INTEGER*2 A(1),B(1),C(1),D(1) 00000150 C 00000160 GO TO (10,20,30,40,50),MODE 00000170 10 CONTINUE 00000180 IF(.NOT.DPI(1))RETURN 00000190 DO 13 I=1,16 00000200 13 D(I)=-1 00000210 RETURN 00000220 C 00000230 20 CONTINUE 00000240 IF(DPI(1))A(1)=-1 00000250 L1=1 00000260 L2=6 00000270 DO 200 N=2,4 00000280 IF(.NOT.DPI(N))GO TO 210 00000290 DO 220 I=L1,L2 00000300 IF(I.EQ.L1)GO TO 205 00000310 A(I)=-1 00000320 IF(I.EQ.L2)GO TO 210 00000330 205 B(I)=-1 00000340 C(I)=-1 00000350 220 D(I)=-1 00000360 210 L1=L2 00000370 L2=L1+5 00000380 200 CONTINUE 00000390 IF(.NOT.DPI(5))RETURN 00000400 B(16)=-1 00000410 C(16)=-1 00000420 D(16)=-1 00000430 RETURN 00000440 C 00000450 30 CONTINUE 00000460 IF(.NOT.DPI(5))RETURN 00000470 DO 35 I=1,16 00000480 35 D(I)=-1 00000490 RETURN 00000500 C 00000510 40 CONTINUE 00000520 MM=1 00000530 M1=6 00000540 M2=13 00000550 M3=19 00000560 IDPI=5 00000570 DO 400 N=1,5 00000580 IDPI=IDPI+1 00000590 IF(.NOT.DPI(IDPI))GO TO 410 00000600 DO 402 I=MM,M1 00000610 A(I)=-1 00000620 B(I)=-1 00000630 IF(I.EQ.M1)GO TO 410 00000640 402 C(I)=-1 00000650 410 IDPI=IDPI+1 00000660 IF(.NOT.DPI(IDPI))GO TO 420 00000670 DO 414 I=M1,M2 00000680 IF(I.EQ.M1)GO TO 414 00000690 A(I)=-1 00000700 IF(I.EQ.M2)GO TO 420 00000710 B(I)=-1 00000720 414 C(I)=-1 00000730 420 IDPI=IDPI+1 00000740 IF(.NOT.DPI(IDPI))GO TO 450 00000750 DO 425 I=M2,M3 00000760 IF(I.EQ.M2)GO TO 424 00000770 A(I)=-1 00000780 424 B(I)=-1 00000790 425 C(I)=-1 00000800 450 CONTINUE 00000810 MM=M3+1 00000820 M1=MM+6 00000830 M2=M1+7 00000840 M3=M2+6 00000850 400 CONTINUE 00000860 50 CONTINUE 00000870 RETURN 00000880 END 00000890 SUBROUTINE DPICR5(A,B,C,D,MODE,DPI) 00000010 LOGICAL*1 DPI(20) 00000020 INTEGER*2 A(1),B(1),C(1),D(1) 00000030 C 00000040 GO TO (10,20,30,40,50),MODE 00000050 10 CONTINUE 00000060 IF(.NOT.DPI(1))RETURN 00000070 DO 13 I=1,16 00000080 13 D(I)=-1 00000090 RETURN 00000100 C 00000110 20 CONTINUE 00000120 IF(DPI(1))A(1)=-1 00000130 L1=1 00000140 L2=6 00000150 DO 200 N=2,4 00000160 IF(.NOT.DPI(N))GO TO 210 00000170 DO 220 I=L1,L2 00000180 IF(I.EQ.L1)GO TO 205 00000190 A(I)=-1 00000200 IF(I.EQ.L2)GO TO 210 00000210 205 B(I)=-1 00000220 C(I)=-1 00000230 220 D(I)=-1 00000240 210 L1=L2 00000250 L2=L1+5 00000260 200 CONTINUE 00000270 IF(.NOT.DPI(5))RETURN 00000280 I=16 00000290 B(I)=-1 00000300 C(I)=-1 00000310 D(I)=-1 00000320 RETURN 00000330 C 00000340 30 CONTINUE 00000350 IF(.NOT.DPI(5))RETURN 00000360 DO 35 I=1,16 00000370 35 D(I)=-1 00000380 RETURN 00000390 C 00000400 40 CONTINUE 00000410 MM=1 00000420 M1=6 00000430 M2=13 00000440 M3=19 00000450 IDPI=5 00000460 DO 400 N=1,5 00000470 IDPI=IDPI+1 00000480 IF(.NOT.DPI(IDPI))GO TO 410 00000490 DO 402 I=MM,M1 00000500 A(I)=-1 00000510 B(I)=-1 00000520 IF(I.EQ.M1)GO TO 410 00000530 402 C(I)=-1 00000540 410 IDPI=IDPI+1 00000550 IF(.NOT.DPI(IDPI))GO TO 420 00000560 DO 414 I=M1,M2 00000570 IF(I.EQ.M1)GO TO 414 00000580 A(I)=-1 00000590 IF(I.EQ.M2)GO TO 420 00000600 B(I)=-1 00000610 414 C(I)=-1 00000620 420 IDPI=IDPI+1 00000630 IF(.NOT.DPI(IDPI))GO TO 450 00000640 DO 425 I=M2,M3 00000650 IF(I.EQ.M2)GO TO 424 00000660 A(I)=-1 00000670 424 B(I)=-1 00000680 425 C(I)=-1 00000690 450 CONTINUE 00000700 MM=M3+1 00000710 M1=MM+6 00000720 M2=M1+7 00000730 M3=M2+6 00000740 400 CONTINUE 00000750 50 CONTINUE 00000760 RETURN 00000770 END 00000780 SUBROUTINE DPICR6(A,B,C,D,MODE,DPI) 00000100 LOGICAL*1 DPI(10) 00000110 INTEGER*2 A(1),B(1),C(1),D(1) 00000120 C =W82AL.DPICR6 00000130 GO TO(10,20,30,40,50),MODE 00000160 C FLAG MISSING E1 DATA 00000170 10 CONTINUE 00000180 IF(.NOT. DPI(1)) RETURN 00000200 DO 14 J=1,16 00000230 14 D(J) = -1 00000240 RETURN 00000310 C FLAG MISSING L MODE DATA 00000320 20 CONTINUE 00000330 IF(.NOT. DPI(1)) GO TO 24 00000340 DO 22 I=1,5 00000342 A(I) = -1 00000344 B(I) = -1 00000346 C(I) = -1 00000348 D(I) = -1 00000350 22 CONTINUE 00000352 A(6) = -1 00000362 24 IF(.NOT. DPI(2)) GO TO 29 00000370 B(6) = -1 00000373 C(6) = -1 00000376 D(6) = -1 00000379 DO 28 I=7,15 00000380 A(I) = -1 00000520 B(I) = -1 00000530 C(I) = -1 00000540 D(I) = -1 00000550 28 CONTINUE 00000580 29 IF(.NOT. DPI(3)) RETURN 00000590 A(16) = -1 00000594 B(16) = -1 00000598 C(16) = -1 00000600 D(16) = -1 00000610 RETURN 00000620 C FLAG MISSING E2 MODE DATA 00000630 30 CONTINUE 00000640 IF(.NOT. DPI(3)) RETURN 00000660 DO 32 I=1,16 00000670 32 D(I) = -1 00000680 RETURN 00000717 C FLAG MISSING M MODE DATA 00000720 40 CONTINUE 00000730 IF(.NOT. DPI(3)) GO TO 48 00000732 DO 45 I=1,5 00000734 A(I) = -1 00000736 B(I) = -1 00000738 45 C(I) = -1 00000740 48 CONTINUE 00000742 IST = 4 00000744 IEND = 10 00000746 I1 = 6 00000748 GO TO 55 00000750 50 CONTINUE 00000760 IST = 1 00000770 IEND = 5 00000775 I1 = 1 00000780 55 DO 58 L=IST,IEND 00000810 IF(.NOT. DPI(L)) GO TO 57 00000840 I2 = I1 + 12 00000860 DO 56 I=I1,I2 00000870 A(I) = -1 00000880 B(I) = -1 00000890 C(I) = -1 00000900 56 CONTINUE 00000950 57 I1 = I1 + 13 00000980 58 CONTINUE 00001020 RETURN 00001030 END 00001040 SUBROUTINE DPIC5V(A,B,C,D,MODE,DPI) C C DPIC5V.FOR C CREATED BY G. BURGESS 1/9/90 C LOGICAL*1 DPI(20) INTEGER*2 A(1),B(1),C(1),D(1) C GO TO (10,20,30,40),MODE 10 CONTINUE IF(.NOT.DPI(1))RETURN DO 13 I=1,16 13 D(I)=-1 RETURN C 20 CONTINUE IF(DPI(1))A(1)=-1 L1=1 L2=6 DO 200 N=2,4 IF(.NOT.DPI(N))GO TO 210 DO 220 I=L1,L2 IF(I.EQ.L1)GO TO 205 A(I)=-1 IF(I.EQ.L2)GO TO 210 205 B(I)=-1 C(I)=-1 220 D(I)=-1 210 L1=L2 L2=L1+5 200 CONTINUE IF(.NOT.DPI(5))RETURN I = 16 B(I)=-1 C(I)=-1 D(I)=-1 RETURN C 30 CONTINUE IF(.NOT.DPI(5))RETURN DO 35 I=1,16 35 D(I)=-1 RETURN C 40 CONTINUE IF(.NOT.DPI(6)) GO TO 410 DO 42 I=1,4 A(I) = -1 B(I) = -1 C(I) = -1 42 D(I) = -1 I = 5 A(I) = -1 410 CONTINUE DO 450 IDPI = 7,20 M1 = (IDPI-6) * 5 M2 = M1 + 4 M3 = M2 + 1 IF(.NOT.DPI(IDPI)) GO TO 450 DO 420 M = M1,M2 A(M) = -1 B(M) = -1 C(M) = -1 420 D(M) = -1 IF(IDPI.NE.20) A(M3) = -1 450 CONTINUE RETURN END SUBROUTINE DPIGS3(A,B,C,D,MODE,DPI) 00000100 LOGICAL*1 DPI(2,80) 00000110 INTEGER*2 A(1),B(1),C(1),D(1) 00000120 C =W82AL.DPIGS3 00000130 GO TO(10,20,30,40,50),MODE 00000160 C FLAG MISSING E1 DATA 00000170 10 CONTINUE 00000180 DO 15 I=3,5,2 00000190 IF(.NOT. DPI(1,I)) GO TO 15 00000200 L1 = (I/2 -1)*6 + 1 00000210 L2 = L1 + 5 00000220 DO 14 J=L1,L2 00000230 14 D(J) = -1 00000240 15 CONTINUE 00000250 IF(.NOT. DPI(1,7)) RETURN 00000260 D(13) = -1 00000270 D(14) = -1 00000280 D(15) = -1 00000290 D(16) = -1 00000300 RETURN 00000310 C FLAG MISSING L MODE DATA 00000320 20 CONTINUE 00000330 IF(.NOT. DPI(1,7)) GO TO 24 00000340 A(1) = -1 00000350 B(1) = -1 00000360 24 L = 0 00000370 DO 28 I=9,33,2 00000380 IF(MOD(I,10) .EQ. 1) GO TO 28 00000390 L = L + 1 00000400 IF(.NOT. DPI(1,I)) GO TO 28 00000410 N = L + L/2 00000420 J = MOD(L,2) 00000430 IF(J .EQ. 0) GO TO 26 00000440 C(N) = -1 00000450 D(N) = -1 00000460 A(N+1) = -1 00000470 B(N+1) = -1 00000480 C(N+1) = -1 00000490 D(N+1) = -1 00000500 GO TO 28 00000510 26 A(N) = -1 00000520 B(N) = -1 00000530 C(N) = -1 00000540 D(N) = -1 00000550 A(N+1) = -1 00000560 B(N+1) = -1 00000570 28 CONTINUE 00000580 IF(.NOT. DPI(1,35)) RETURN 00000590 C(16) = -1 00000600 D(16) = -1 00000610 RETURN 00000620 C FLAG MISSING E2 MODE DATA 00000630 30 CONTINUE 00000640 IF(.NOT. DPI(1,35)) GO TO 34 00000660 D(1) = -1 00000670 D(2) = -1 00000680 D(3) = -1 00000690 D(4) = -1 00000700 34 L1 = 5 00000710 DO 38 I=37,39,2 00000711 IF(.NOT. DPI(1,I)) GO TO 38 00000712 L2 = L1 + 5 00000713 DO 36 J=L1,L2 00000714 36 D(J) = -1 00000715 38 L1 = 11 00000716 RETURN 00000717 C FLAG MISSING M MODE DATA 00000720 40 CONTINUE 00000730 IST = 43 00000740 GO TO 55 00000750 50 CONTINUE 00000760 IST = 3 00000770 55 L = 0 00000780 DO 58 I=IST,79,2 00000810 IF(MOD(I,10) .EQ. 1) GO TO 58 00000820 L = L + 1 00000830 IF(.NOT. DPI(1,I)) GO TO 58 00000840 N = L + L/2 00000850 J = MOD(L,2) 00000860 IF(J .EQ. 0) GO TO 56 00000870 A(N) = -1 00000880 B(N) = -1 00000890 C(N) = -1 00000900 D(N) = -1 00000910 A(N+1) = -1 00000920 B(N+1) = -1 00000930 GO TO 58 00000940 56 CONTINUE 00000950 C(N-1) = -1 00000960 D(N-1) = -1 00000970 A(N) = -1 00000980 B(N) = -1 00000990 C(N) = -1 00001000 D(N) = -1 00001010 58 CONTINUE 00001020 RETURN 00001030 END 00001040 SUBROUTINE DPIGS5(A,B,C,D,MODE,DPI) 00000010 C 00000020 C CREATED 01/18/85 BY GARY M. BURGESS 00000030 C MODIFIED 08/07/85 BY GARY M. BURGESS 00000040 C 00000050 LOGICAL*1 DPI(2,80) 00000060 INTEGER*2 A(1),B(1),C(1),D(1),FMODE(2) 00000070 C 00000080 COMMON /CCA/ WORK(500) EQUIVALENCE (WORK(35), TIME2), (WORK(38), IYR2) REAL*8 TIME2 GO TO (10,20,30,40,50,60,70,80,90),MODE 00000090 10 CONTINUE 00000100 IF(DPI(1,13)) A(1) = -1 00000110 N = -1 00000120 L = 1 00000130 DO 12 I=15,39,2 00000140 IF(MOD(I,10).EQ.1) GO TO 12 00000150 N = N+1 00000160 IF(MOD(L,2).EQ.1) N = N+1 00000170 IF(.NOT.DPI(1,I)) GO TO 12 00000180 IF(MOD(L,2).EQ.0) GO TO 14 00000190 B(N) = -1 00000200 C(N) = -1 00000210 D(N) = -1 00000220 IF( N.GE.16) GO TO 12 00000230 A(N+1) = -1 00000240 B(N+1) = -1 00000250 C(N+1) = -1 00000260 GO TO 12 00000270 14 D(N) = -1 00000280 A(N+1) = -1 00000290 B(N+1) = -1 00000300 C(N+1) = -1 00000310 D(N+1) = -1 00000320 A(N+2) = -1 00000330 12 L = L + 1 00000340 RETURN 00000350 20 CONTINUE 00000360 N2 = 0 00000370 DO 22 I = 39,47,2 00000380 IF(MOD(I,10).EQ.1) GO TO 22 00000390 N1 = N2+1 00000400 N2 = N1 + 5 00000410 IF( I.EQ.39) N2 = 2 00000420 IF(.NOT.DPI(1,I)) GO TO 22 00000430 IF(N2.GT.16) N2 = 16 00000440 DO 24 N=N1,N2 00000450 24 D(N) = -1 00000460 22 CONTINUE 00000470 RETURN 00000480 30 CONTINUE 00000490 N = 0 00000500 L = 1 00000510 IF(.NOT.DPI(1,47)) GO TO 31 00000520 A(1) = -1 00000530 B(1) = -1 00000540 C(1) = -1 00000550 31 DO 32 I=49,75,2 00000560 IF(MOD(I,10).EQ.1) GO TO 32 00000570 N = N + 1 00000580 IF(MOD(L,2).EQ.0) N = N + 1 00000590 IF(.NOT.DPI(1,I)) GO TO 32 00000600 IF(MOD(L,2).EQ.0) GO TO 34 00000610 D(N) = -1 00000620 IF(N.GE.16) GO TO 36 00000630 A(N+1) = -1 00000640 B(N+1) = -1 00000650 C(N+1) = -1 00000660 D(N+1) = -1 00000670 GO TO 32 00000680 34 B(N) = -1 00000690 C(N) = -1 00000700 D(N) = -1 00000710 A(N+1) = -1 00000720 B(N+1) = -1 00000730 C(N+1) = -1 00000740 32 L = L + 1 00000750 36 CONTINUE 00000760 RETURN 00000770 40 CONTINUE 00000780 N2 = 0 00000790 DO 42 I=75,79,2 00000800 N1 = N2 + 1 00000810 N2 = N1 + 5 00000820 IF(I.EQ.75) N2 = 4 00000830 IF(.NOT.DPI(1,I)) GO TO 42 00000840 DO 44 N=N1,N2 00000850 44 D(N) = -1 00000860 42 CONTINUE 00000870 RETURN 00000880 50 CONTINUE 00000890 L = 0 00000900 N = 0 00000910 DO 52 I=3,79,2 00000920 IF(MOD(I,10).EQ.1) GO TO 52 00000930 L = L + 1 00000940 N = N + 1 00000950 IF(MOD(L,2).EQ.0)N = N + 1 00000960 IF(I.EQ.3) N = 0 00000970 IF(.NOT.DPI(1,I)) GO TO 52 00000980 IF(MOD(L,2).EQ.0)GO TO 54 00000990 IF(I.EQ.3)GO TO 55 00001000 D(N) = -1 00001010 55 A(N+1) = -1 00001020 B(N+1) = -1 00001030 C(N+1) = -1 00001040 D(N+1) = -1 00001050 A(N+2) = -1 00001060 GO TO 52 00001070 54 B(N) = -1 00001080 C(N) = -1 00001090 D(N) = -1 00001100 A(N+1) = -1 00001110 B(N+1) = -1 00001120 C(N+1) = -1 00001130 52 CONTINUE 00001140 C 00001150 M=48 00001160 D(M) = -2 00001170 DO 500 M=49,128 00001180 A(M) = -2 00001190 B(M) = -2 00001200 C(M) = -2 00001210 500 D(M) = -2 00001220 RETURN 00001230 60 CONTINUE 00001240 N = 47 00001250 L = 0 00001260 DO 62 I=3,79,2 00001270 IF(MOD(I,10).EQ.1) GO TO 62 00001280 L = L + 1 00001290 N = N + 1 00001300 IF(MOD(L,2).EQ.0) N = N + 1 00001310 IF(.NOT.DPI(1,I))GO TO 62 00001320 IF(MOD(L,2).EQ.0) GO TO 64 00001330 D(N) = -1 00001340 A(N+1) = -1 00001350 B(N+1) = -1 00001360 C(N+1) = -1 00001370 D(N+1) = -1 00001380 A(N+2) = -1 00001390 GO TO 62 00001400 64 B(N) = -1 00001410 C(N) = -1 00001420 D(N) = -1 00001430 A(N+1) = -1 00001440 B(N+1) = -1 00001450 C(N+1) = -1 00001460 62 CONTINUE 00001470 C 00001480 M=96 00001490 D(M) = -2 00001500 DO 600 M=97,128 00001510 A(M) = -2 00001520 B(M) = -2 00001530 C(M) = -2 00001540 600 D(M) = -2 00001550 RETURN 00001560 70 CONTINUE 00001570 N = 95 00001580 L = 0 00001590 DO 72 I=3,55,2 00001600 IF(MOD(I,10).EQ.1) GO TO 72 00001610 L = L + 1 00001620 N = N + 1 00001630 IF(MOD(L,2).EQ.0) N = N + 1 00001640 IF(.NOT.DPI(1,I)) GO TO 72 00001650 IF(MOD(L,2).EQ.0) GO TO 74 00001660 D(N) = -1 00001670 A(N+1) = -1 00001680 B(N+1) = -1 00001690 C(N+1) = -1 00001700 D(N+1) = -1 00001710 A(N+2) = -1 00001720 GO TO 72 00001730 74 B(N) = -1 00001740 C(N) = -1 00001750 D(N) = -1 00001760 IF(N.GE.128) GO TO 79 00001770 A(N+1) = -1 00001780 B(N+1) = -1 00001790 C(N+1) = -1 00001800 72 CONTINUE 00001810 C 00001820 79 CONTINUE 00001830 RETURN 00001840 80 CONTINUE 00001850 N = 0 00001860 L = 0 00001870 DO 82 I = 55,79,2 00001880 IF(MOD(I,10).EQ.1) GO TO 82 00001890 L = L + 1 00001900 N = N + 1 00001910 IF(MOD(L,2).EQ.1) N = N + 1 00001920 IF(I.EQ.55) N = 0 00001930 IF(.NOT.DPI(1,I)) GO TO 82 00001940 IF(MOD(L,2).EQ.0)GO TO 84 00001950 IF(I.EQ.55) GO TO 81 00001960 A(N) = -1 00001970 B(N) = -1 00001980 C(N) = -1 00001990 D(N) = -1 00002000 81 A(N+1) = -1 00002010 B(N+1) = -1 00002020 GO TO 82 00002030 84 C(N) = -1 00002040 D(N) = -1 00002050 A(N+1) = -1 00002060 B(N+1) = -1 00002070 C(N+1) = -1 00002080 D(N+1) = -1 00002090 82 CONTINUE 00002100 RETURN 00002110 90 CONTINUE 00002120 IF(.NOT.DPI(1,3)) RETURN 00002130 C(1) = -1 00002140 D(1) = -1 00002150 RETURN 00002160 C 00002170 ENTRY FILGS5(A,B,C,D,MODE,FMODE) 00002180 IF(MODE.LT.6.OR.MODE.GT.7) RETURN 00002190 IF(FMODE(1).NE.0) GO TO 1100 00002200 DO 1000 M=1,48 00002210 A(M) = -2 00002220 B(M) = -2 00002230 C(M) = -2 00002240 IF(M.GE.48) GO TO 1000 00002250 D(M) = -2 00002260 1000 CONTINUE 00002270 1100 IF(MODE.EQ.6) RETURN 00002280 IF(FMODE(2).NE.0) RETURN 00002290 M=48 00002300 D(M) = -2 00002310 DO 1200 M=49,96 00002320 A(M) = -2 00002330 B(M) = -2 00002340 C(M) = -2 00002350 IF(M.EQ.96) GO TO 1200 00002360 D(M) = -2 00002370 1200 CONTINUE 00002380 RETURN 00002390 C 00002400 ENTRY LSGS5(A,B,C,D) 00002410 C 00002420 C PROBLEMS WITH L-SHORT DATA 00002430 C SEE VOYAGER MEMORANDUM NO. 114 JUNE 23,1985 00002440 C MODIFIED 8/7/85 BY GARY BURGESS 00002450 C 00002460 IF (IYR2 .GT. 86) RETURN IF (IYR2 .LT. 86) GO TO 2000 IF (TIME2 .GE. 57.0D00)RETURN 2000 CONTINUE DO 100 I=1,15 00002470 A(I) = A(I+1) 00002480 B(I) = B(I+1) 00002490 C(I) = C(I+1) 00002500 100 D(I) = D(I+1) 00002510 I = 16 00002520 A(I) = -1 00002530 B(I) = -1 00002540 C(I) = -1 00002550 D(I) = -1 00002560 RETURN 00002570 END 00002580 SUBROUTINE DRIFT(X,XDIFF,N) 00000100 INTEGER X(1),XDIFF 00000110 C =W82JS.DRIFT 00000120 DO 5 I=1,N 00000130 IF(X(I) .LE. 0) GO TO 5 00000135 X(I) = X(I) + XDIFF 00000140 5 CONTINUE 00000145 RETURN 00000150 END 00000160 SUBROUTINE DXSAVE(X,DX,N,ND) 00000100 C ********** =W82JS.DXSAVE ********** 00000105 INTEGER*2 N 00000110 INTEGER DX(1),X(1) 00000120 C 00000130 K = 0 00000140 DO 20 I=1,N,ND 00000150 K = K + 1 00000160 DX(K) = X(I) - X(I+1) 00000170 IF((X(I) .LE. 0) .OR. (X(I+1) .LE. 0)) DX(K) = 99999 00000175 20 CONTINUE 00000180 C 00000190 RETURN 00000200 END 00000210