* Wed Mar 3 11:12:01 EST 1993 /plas5/h1/pam/src/test sxred.f * Mon Oct 19 14:22:05 EDT 1992 /plas5/h1/pam/src/test sxred.f * Thu Apr 5 11:39:40 EDT 1990 /plasma/h1/pam/src/test sxred.f * Thu Jul 20 11:13:24 EDT 1989 /plasma/h1/pam/src/test sxred.f * Thu Jan 12 14:41:19 EST 1989 /usr4/pam/src/test sxred.f * Fri Nov 4 15:29:17 EST 1988 /usr4/pam/src/test sxred.f c ********************** IMPORTANT!! ***** (April 4, 1990) ***** c SXRED has been modified so that it now can read SEDRs that have c been written to tape or disk by a SUN computer (instead of IBM). c This means that a flag had to be set in each SEDR record to indicate c that it was written by SUN; the LAST WORD IN EVERY RECORD is now set c to "-1" **IF** that record was written by a SUN. Do not, therefore, be c alarmed if a listing of an SEDR shows "-NaN(7fffff)" in that position. SUBROUTINE SXRED0 CHARACTER*4 traj CALL sxredx(0, 0, 0, traj, 0, 0, 0, 0, 0, 0) RETURN END C SUBROUTINE SXRED1(IDSRN) CHARACTER*4 traj CALL sxredx(IDSRN, 0, 0, traj, 0, 0, 0, 0, 0, 1) RETURN END C SUBROUTINE SXRED2(IDSRN, IEOD) CHARACTER*4 traj CALL sxredx(IDSRN, IEOD, 0, traj, 0, 0, 0, 0, 0, 2) RETURN END C SUBROUTINE SXRED3(IDSRN, IEOD, ITIME) INTEGER*4 itime(6) CHARACTER*4 traj CALL sxredx(IDSRN, IEOD, ITIME, traj, 0, 0, 0, 0, 0, 3) RETURN END C SUBROUTINE SXRED4(IDSRN, IEOD, ITIME, TRAJ) INTEGER*4 itime(6) CHARACTER*4 traj CALL sxredx(IDSRN, IEOD, ITIME, TRAJ, 0, 0, 0, 0, 0, 4) RETURN END C SUBROUTINE SXRED5(IDSRN, IEOD, ITIME, TRAJ, ISR) INTEGER*4 itime(6) CHARACTER*4 traj CALL sxredx(IDSRN, IEOD, ITIME, TRAJ, ISR, 0, 0, 0, 0, 5) RETURN END C SUBROUTINE SXRED6(IDSRN, IEOD, ITIME, TRAJ, ISR, ROLL) INTEGER*4 itime(6) CHARACTER*4 traj CALL sxredx(IDSRN, IEOD, ITIME, TRAJ, ISR, ROLL, 0, 0, 0, 6) RETURN END C SUBROUTINE SHDREC(IDSRN, IEOD) CHARACTER*4 traj CALL sxredx(IDSRN, IEOD, 0, traj, 0, 0, 0, 0, 0, 2) RETURN END C SUBROUTINE SNXNAV(IDSRN, IEOD, HDST1) CHARACTER*4 traj LOGICAL*4 HDST1 CALL sxredx(IDSRN, IEOD, 0, traj, 0, 0, HDST1, 0, 0, 7) RETURN END C SUBROUTINE SNXPNT(IDSRN, IEOD, HDST2, NVST) CHARACTER*4 traj LOGICAL*4 HDST2, NVST CALL sxredx(IDSRN, IEOD, 0, traj, 0, 0, 0, HDST2, NVST, 8) RETURN END C SUBROUTINE SXREDX(IDSRN, IEOD, ITIME, TRAJ, ISR, ROLL, hdst1, * hdst2, nvst, narg) C C READS SEDR TAPES. C C RALPH L. MCNUTT, JR. 16 JUNE, 1979 ANNO DOMINI C IMPLICIT REAL*8 (Z) COMMON/HEADER/PROJID,FILEID,ISCID,TAPEID(2),IGENDT,IGENTM, 1 FIPID(2),IFGEND,IFGENT,DPTJ1(2),IFRMT1(2),DPTJ2(2),IFRMT2(2), 2 DPTJ3(2),IFRMT3(2),DPTJ4(2),IFRMT4(2),HSPARE(18) DIMENSION HEDBLK(45) EQUIVALENCE (HEDBLK(1),PROJID) COMMON/TAPERR/iRB(4) DIMENSION NAVIG1(600),NAVIG2(600),POINT1(126),POINT2(126) DIMENSION INAV1(6),INAV2(6),IPNT1(8),IPNT2(8) DIMENSION ANAV1(594),ANAV2(594),APNT1(118),APNT2(118) EQUIVALENCE (NAVIG1(1),INAV1(1)),(NAVIG2(1),INAV2(1)) EQUIVALENCE (NAVIG1(7),ANAV1(1)),(NAVIG2(7),ANAV2(1)) EQUIVALENCE (POINT1(1),IPNT1(1)),(POINT2(1),IPNT2(1)) EQUIVALENCE (POINT1(9),APNT1(1)),(POINT2(9),APNT2(1)) COMMON/NVBUF/NAVIG0(600)/PTBUF/POINT0(126) COMMON/NAVBUF/NAV(252) COMMON/VCTBUF/IV1(126) CHARACTER*4 UNITa C *** REAL*8 UNITa/'FTXXF001'/ C *** INTEGER*2 UNUM(2) c******** double precision numbers for determining shift from Canopus to Vega real*8 zvega, znow INTEGER*4 irb(4), ncount, ifinal, iheader, inow(6) LOGICAL*4 res(12), lsun EQUIVALENCE (irb(1), ncount), (irb(2), res(1)), * (iheader, hedblk(45)) REAL*4 STAR(3) INTEGER*4 NARG INTEGER*4 ICOUNT,IBUFF(378),NBUFF(252),IFLAG(9) equivalence (ibuff(1), inow(1)) EQUIVALENCE (IFLAG(1),IFLAG0),(IFLAG(2),IFLAG1),(IFLAG(3),IFLAG2) EQUIVALENCE (IFLAG(4),IFLAG3),(IFLAG(5),IFLAG4),(IFLAG(6),IFLAG5) EQUIVALENCE (IFLAG(7),IFLAG6),(IFLAG(8),IFLAG7),(IFLAG(9),IFLAG8) DIMENSION CONTRL(14) EQUIVALENCE (CONTRL(1),IERCT),(CONTRL(2),ICALL),(CONTRL(3),IEND), 1(CONTRL(4),JCOUNT),(CONTRL(5),LEOT),(CONTRL(6),IFLAG(1)) INTEGER*4 IREAD,KDSRN CHARACTER*4 PID,FID,AJST,AJSX,ATRAJ,traj,fipid,dptj1,dptj2 CHARACTER*4 IFRMT1,IFRMT2,IFRMT3,IFRMT4,dptj3,dptj4 CHARACTER*4 PROJID,FILEID,TAPEID(2),IFORM(7) CHARACTER*1 SS, EXP(2), SCID(8) LOGICAL*4 HDSTAT,NVSTAT LOGICAL*4 HDST1,HDST2,NVST LOGICAL LINTST,LAST,LEOT LOGICAL LFIRST,LDSRN LOGICAL EOF,EOT,ERR,CHECKS(3),HWARE,NORING DIMENSION ITIME(6) equivalence (icsw, irb(4)) EQUIVALENCE (EOF,RES(1)),(EOT,RES(2)),(ERR,RES(3)),(CHECKS(1), 1 RES(4)),(HWARE,RES(7)),(NORING,RES(8)) equivalence (tapeid(1), scid(1)) c********** # of milliseconds since 1977 for 1992, 295, 12, 0, 0, 0: data zvega/498571200000.00/ DATA ZTIME/0D0/,ZPNTTM/0D0/,ZNAVTM/0D0/, ifinal/-1/, lsun/.false./ DATA ZNOLD/0D0/,ZPOLD/0D0/, ss/'S'/, exp/'P','L'/ DATA IERCT/0/,ICALL/0/,IEND/0/,JCOUNT/0/ DATA NAVIG1/600*0/,NAVIG2/600*0/,POINT1/126*0./,POINT2/126*0./ DATA icount/7000/, iflag/9*0/, iread/1/, kdsrn/9999/ DATA pid/'VGR '/, fid/'SEDR'/, ajst/'JST '/, ajsx/'JSX '/ DATA iform/'LAUN','CRUI','JUPI','SATU','XCRU','URAN','NEPT'/ DATA hdstat/.FALSE./, nvstat/.FALSE./, leot/.FALSE./ DATA lfirst/.TRUE./, ldsrn/.FALSE./, unita/'ft33'/ C ****************************************************************** C C BEGIN EXECUTION C C ****************************************************************** IF (NARG .eq. 2) GO TO 100 IF (NARG .eq. 7) GO TO 110 IF (NARG .eq. 8) GO TO 120 C IF (IDSRN .EQ. KDSRN) GO TO 60 C C * ADSRN=IDSRN C * CALL NUMSTR(ADSRN,-1,UNUM,2) C * CALL MVC(UNUM,UNITa,2,0,2) IF (LFIRST) GO TO 25 C C CALL MVC TO STORE PERTINENT QUANTITIES. C THESE ARE: NAVIG1, NAVIG2, POINT1, POINT2, HEDBLK, C CONTRL, ZNOLD, AND ZPOLD. C USE IBUFF FOR TEMPORARY STORAGE DURING MOVEMENT. C FULL STORAGE REQUIRES 1073 4-BYTE WORDS. C IF (LDSRN) GO TO 60 LDSRN=.TRUE. 25 DO 30 I=1,9 30 IFLAG(I)=0 ZNOLD=0D0 ZPOLD=0D0 LEOT=.FALSE. IERCT=0 ICALL=0 IEND=0 JCOUNT=0 DO 40 I=1,126 POINT1(I)=0. 40 POINT2(I)=0. DO 50 I=1,600 NAVIG1(I)=0 50 NAVIG2(I)=0 LFIRST=.FALSE. 60 CONTINUE IF (NARG .EQ. 1) GO TO 70 CALL xTYME(ITIME,ZTIME) IF (ZTIME .LT. 0.) GO TO 290 IFLAG0=0 IFLAG1=0 IFLAG2=0 GO TO 130 C ****************************************************************** C C REWIND TAPE C C ****************************************************************** 70 CALL TSKIPn(UNITa,.TRUE.,0,0) CALL TWAITn(UNITa, irb) IEND=0 ICALL=0 IERCT=0 write (0, 9000) 9000 FORMAT (/,'TAPE REWOUND') LEOT=.FALSE. JCOUNT=0 ZNOLD=0D0 ZPOLD=0D0 ZNAVTM=0D0 ZPNTTM=0D0 DO 80 I=1,600 NAVIG1(I)=0 80 NAVIG2(I)=0 DO 85 I=1,126 POINT1(I)=0.0 85 POINT2(I)=0.0 DO 90 I=1,9 90 IFLAG(I)=0 GO TO 260 C ****************************************************************** C C ADDITIONAL ENTRY POINTS C C ****************************************************************** C IFLAG0 IS SET IF SHDREC IS CALLED. C IFLAG1 IS SET IF SNXNAV IS CALLED. C IFLAG2 IS SET IF SNXPNT IS CALLED. C *** ENTRY SHDREC(/IDSRN/,/IEOD/) ***** 100 IFLAG0=1 IFLAG1=0 IFLAG2=0 IFLAG5=0 GO TO 130 C *** ENTRY SNXNAV(/IDSRN/,/IEOD/,/HDST1/) ***** 110 HDSTAT=.FALSE. IFLAG1=1 IFLAG2=0 IFLAG5=0 IF (IFLAG0 .EQ. 0) GO TO 130 IFLAG0=0 GO TO 230 C *** ENTRY SNXPNT(/IDSRN/,/IEOD/,/HDST2/,/NVST/) ***** 120 HDSTAT=.FALSE. NVSTAT=.FALSE. IFLAG2=1 IF (IFLAG0 .EQ. 0 .AND. IFLAG1 .EQ. 0) GO TO 130 IFLAG0=0 IFLAG1=0 GO TO 230 C ****************************************************************** C C DECIDE WHETHER TO ADVANCE TAPE C C ****************************************************************** 130 IF (LEOT) GO TO 270 140 IF (IEND .LE. 0) GO TO 150 write (0, 9010) IDSRN 9010 FORMAT (1X,'READ ROUTINE FOR TRAJECTORY TAPE CALLED AFTER +END OF FILE ON UNIT',I4) GO TO 230 150 IF (IEND .EQ. 0) GO TO 160 write (0, 9020) IDSRN 9020 FORMAT (1X,'READ ROUTINE FOR TRAJECTORY TAPE CALLED AFTER +READ ERROR ON UNIT',I4) GO TO 230 160 IF (IFLAG0 .EQ. 1) GO TO 200 IF (IFLAG1 .EQ. 1 .OR. IFLAG2 .EQ. 1) GO TO 200 C IFLAG3 HANDLES THE CASE IN WHICH THE REQUESTED TIMES ARE MORE CLOSELY C SPACED THAN THOSE OF THE SEDR DATA. C READ NEXT PHYSICAL RECORD C IFLAG4 HANDLES THE CASE OF THE REQUESTED TIME FALLING BETWEEN THOSE C OF THE POINTING AND NAVIGATION DATA BLOCKS WHEN THERE IS ONLY ONE C PER LOGICAL RECORD. 170 IF (IFLAG4 .EQ. 1 .AND. ZTIME .LT. ZNOLD) GO TO 500 IF (IFLAG4 .EQ. 2 .AND. ZTIME .LT. ZPOLD) GO TO 500 IF (IFLAG4 .EQ. 0) GO TO 190 IF (IFLAG4 .EQ. 2) GO TO 180 CALL MVC(NAVIG1(1),NAVIG2(1),2400) if (numfor .lt. 1) then write (0,*) "Bad or missing header. NUMFOR = ",numfor, * " Go get a new record." go to 200 endif CALL NVSTOR(NAV,NAVIG1,NUMFOR) GO TO 185 180 CALL MVC(POINT1(1),POINT2(1),504) CALL MVC(IBUFF(IPNT),POINT1(1),504) 185 IFLAG4=0 190 IF (IFLAG7 .EQ. 1 .AND. ZTIME .LE. ZPOLD) GO TO 500 IF (IFLAG7 .EQ. 1 .AND. ZTIME .GT. ZPOLD) GO TO 200 IF (ZTIME .LE. ZNOLD .AND. ZTIME .LE. ZPOLD) GO TO 500 IF (ZTIME .GT. ZNOLD .AND. ZTIME .GT. ZPOLD) GO TO 200 IFLAG4=1 IF (ZTIME .GT. ZNOLD) IFLAG4=2 C IFLAG5=1 IF MULTIPLE POINTING BLOCKS ARE BEING SEARCHED. 200 IF (IFLAG5 .EQ. 1) GO TO 480 CALL TREADn(UNITa,IBUFF,ICOUNT) ICALL=ICALL+1 CALL TWAITn(UNITa, irb) IF (EOF) GO TO 300 IF (ERR) GO TO 310 210 IFLAG3=0 IF (NCOUNT .EQ. 180) GO TO 320 IF (IFLAG6 .EQ. 1) GO TO 220 IF (IFLAG0 .EQ. 1) GO TO 200 220 IF (NCOUNT .EQ. 1008) GO TO 380 IF (NCOUNT .EQ. 1512) GO TO 360 C INCORRECT NUMBER OF BYTES READ write (0, 9030) ncount 9030 FORMAT (/,'NUMBER OF BYTES READ DOES NOT CORRESPOND TO ANY SEDR' 1 ' FORMAT: NCOUNT = 'i6) STOP C ****************************************************************** C C SET FLAGS AND/OR INTERPOLATE - RETURN TO CALLING ROUTINE C C ****************************************************************** 230 IF (IFLAG8 .EQ. 1) GO TO 520 IEOD=IEND IF (IFLAG1 .EQ. 1) HDST1=HDSTAT IF (IFLAG2 .EQ. 0) GO TO 240 HDST2=HDSTAT NVST=NVSTAT 240 ZPOLD=ZPNTTM IF (IFLAG5 .EQ. 0) ZNOLD=ZNAVTM IF (NARG .EQ. 4) TRAJ=ATRAJ CALL MVC(POINT1(1),IV1(1),504) IF (IFLAG0 .EQ. 1) GO TO 250 IF (IFLAG1 .EQ. 1) GO TO 250 IF (IFLAG2 .EQ. 1) GO TO 250 CALL INTERP(ITIME,INAV1,INAV2,ANAV1,ANAV2, +IPNT1,IPNT2,APNT1,APNT2) GO TO 260 250 CALL MVC(NAVIG1(1),NAVIG0(1),2400) CALL MVC(POINT1(1),POINT0(1),504) 260 KDSRN=IDSRN RETURN C ****************************************************************** C C CHECK FOR ADDITIONAL INPUT TAPES. C C ****************************************************************** 270 CALL TNEXT(UNITa,LAST) LEOT=.FALSE. IEND=0 IF (LAST) GO TO 280 ICALL=0 GO TO 140 280 IEND=1 GO TO 140 290 write (0, 9140) 9140 FORMAT (/,'TIME REQUESTED PRECEDES 1977. EXECUTION TERMINATED.') STOP C ****************************************************************** C C EOF ENCOUNTERED C C ****************************************************************** 300 write (0, 9040) IDSRN, ICALL 9040 FORMAT (1X,'TRAJECTORY TAPE END OF FILE ENCOUNTERED ON UNIT', +I4,' CALLS = ',I6) LEOT=.TRUE. IEND=1 IERCT=0 GO TO 270 C ****************************************************************** C C READ ERROR C C ****************************************************************** 310 write (0, 9050) IDSRN 9050 FORMAT (1X,'TAPE READ ERROR ON UNIT ',I4) write (0, 9150) 9150 FORMAT (1X,' BYTES',2X,'RES ARRAY: SEE LNS WRITEUP ON TWAIT', +12X,'CALLS TO TREAD') write (0, 9060) NCOUNT, RES, ICALL 9060 FORMAT (1X,I6,12(2X,L4),I6) IERCT=IERCT+1 IF (IERCT .LE. 10) GO TO 200 write (0, 9070) IERCT 9070 FORMAT (/,'TERMINATION FOR TRAJECTORY TAPE READ ERROR COUNT ',I2) C IEND=-1 C GO TO 230 GO TO 270 C ***************************************************************** C C FILE AND VERIFY HEADER RECORD C C ****************************************************************** 320 HDSTAT=.TRUE. CALL MVC(IBUFF(IREAD),PROJID,180) c ******** was the header record written by IBM or by SUN? IF (iheader .ne. ifinal) THEN c ************ convert EBCDIC characters to ASCII ******************* CALL ebc2asc(projid,projid,8) CALL ebc2asc(tapeid,tapeid,8) CALL ebc2asc(fipid,fipid,8) CALL ebc2asc(dptj1,dptj1,64) ELSE lsun = .TRUE. ENDIF IF (PROJID .EQ. PID) GO TO 330 write (0, 9080) PROJID 9080 FORMAT (/,'TAPE PROJECT ID IS ',A4) STOP 330 IF (FILEID .EQ. FID) GO TO 340 write (0, 9090) FILEID 9090 FORMAT (/,'TAPE FILE ID IS ',A4) STOP C S/C IDENTIFICATION 340 NUMSC=L1X(SCID(4)) C 'A' OR '1' IS VOYAGER 1 (JST TRAJECTORY) C 'B' OR '0' IS VOYAGER 2 (JSX TRAJECTORY) IF (NUMSC .EQ. 65 .OR. NUMSC .EQ. 49) ATRAJ=AJST IF (NUMSC .EQ. 66 .OR. NUMSC .EQ. 48) ATRAJ=AJSX IF (2*(NUMSC-ISCID)/2 .NE. (NUMSC-ISCID)) write (0, 9100) 9100 FORMAT (/,'S/C IDENTIFICATION NOT INTERNALLY CONSISTENT') C NAVIGATION DATA BLOCK FORMAT IDENTIFICATION : C ASSUME IDENTIFICATION FOR FIRST DPTRAJ TAPE IS VALID C FOR ENTIRE SEDR FILE. DO 350 I=1,7 350 IF (IFRMT1(1) .EQ. IFORM(I)) NUMFOR=I C NUMFOR=1 IMPLIES LAUNCH FORMAT C NUMFOR=2 IMPLIES CRUISE FORMAT C NUMFOR=3 IMPLIES JUPITER FORMAT C NUMFOR=4 IMPLIES SATURN FORMAT C NUMFOR=5 IMPLIES EXTENDED CRUISE FORMAT C NUMFOR=6 IMPLIES URANUS FORMAT C NUMFOR=7 IMPLIES NEPTUNE FORMAT C if (numfor .lt. 1) then write (0,*) "Bad or missing header. NUMFOR = ",numfor, * " Go get a new record." go to 200 endif C CHECK EXPERIMENT IDENTIFICATION IF (SCID(1) .NE. ss) write (0, 9110) 9110 FORMAT (/'NOT A FIXED INSTRUMENT SEDR') IF (SCID(2) .NE. EXP(1) .OR. SCID(3) .NE. EXP(2)) write (0, 9120) 9120 FORMAT (/,'NOT A PLASMA SUBSYSTEM SEDR') C ****************************************************************** C C HEADER VERIFICATION AND NAVIGATION DATA BLOCK TYPING COMPLETED. C C ***************************************************************** CALL MVC(NAV(1),IBUFF(1),180) INAV=1 C IFLAG6 IS SET IF SHDREC IS CALLED SO THAT THE NEXT RECORD IS ALSO IF (IFLAG0 .EQ. 1) IFLAG6=1 GO TO 130 C CHECK CONSISTENCY OF JUPITER OR URANUS or Neptune FORMAT 360 IF (NUMFOR .EQ. 3 .OR. NUMFOR .EQ. 6 .or. numfor .eq. 7) GO TO 370 write (0, 9130) 9130 FORMAT (/,'INDICATION OF JUPITER/URANUS/NEPTUNE FORMAT ', 1'INCONSISTENT WITH PHYSICAL RECORD LENGTH') STOP C ****************************************************************** C C SEARCH NAVIGATION BLOCK DATA C C ****************************************************************** 370 INAV=2 C SET UP TIME FOR COMPARISON AND CHECK FOR NAVIG OR POINT TYPE DATA 380 NAVBYT=INAV*504 IFLAG6=0 IF (LINTST(IBUFF(7),IBUFF(8))) GO TO 470 NVSTAT=.TRUE. C FIRST BLOCK IS NAVIGATION DATA BLOCK; STORE FOR FUTURE REFERENCE CALL MVC(IBUFF(1),NAV(1),NAVBYT) c c ******** was the nav block written by IBM or by SUN? IF (nav(navbyt/4) .ne. ifinal) THEN c ************ convert IBM floating point numbers to IEEE floating pt. nerr = icvtf (nav(7), ((navbyt/4) - 6), nav(7)) if (nerr .gt. 0) write (0,*) * "number of conversion errors in 'nav' navig. block=",nerr ELSE if (.not. lsun) * write (0, *) "ERROR! Records written by both IBM and SUN!" ENDIF c JCOUNT=JCOUNT+1 IFLAG5=0 IPNT=INAV*126+1 c c ******* was the pointing block written by IBM or by SUN? IF (ibuff(ipnt + 125) .ne. ifinal) THEN c ************ convert IBM floating point numbers to IEEE floating pt. nerr = icvtf(ibuff(ipnt+8), 92, ibuff(ipnt+8)) if (nerr .gt. 0) write (0,*) * "A) number of conversion errors in 1st pt. of pointing blk=", * nerr nerr = icvtf(ibuff(ipnt+101), 2, ibuff(ipnt+101)) if (nerr .gt. 0) write (0,*) * "B) number of conversion errors in 2nd pt. of pointing blk=", * nerr ELSE if (.not. lsun) * write (0, *) "ERROR! Records written by both IBM and SUN!" ENDIF c C CHECK FOR POINTING VECTOR DATA J=IPNT+11 SCX2=vecabs(IBUFF(J)) IF (SCX2 .GT. 0.0001) GO TO 410 C NOMINAL POINTING DATA TO BE FILLED IN. C CANOPUS REFERENCE ASSUMED. 390 ISTAR=1 c******** is it time to shift from Canopus to Vega? call xtyme(inow, znow) if (znow .ge. zvega) istar=9 IF (NARG .EQ. 5) ISTAR=ISR CALL REFER(ISTAR,STAR) IF (NARG .EQ. 6) CALL ONAxR(STAR,STAR,NAV(7),ROLL) DO 400 I=1,126 400 IV1(I)=0 CALL NOMDIR(STAR) CALL MVC(IV1(1),IBUFF(IPNT),504) C CHECK CONCLUDED 410 IFLAG7=IBUFF(100+IPNT) IF (IFLAG1 .EQ. 1 .AND. IFLAG8 .EQ. 1) GO TO 420 IF (IFLAG1 .EQ. 1 .OR. IFLAG2 .EQ. 1) GO TO 440 IF (IFLAG0 .EQ. 1) GO TO 440 ZPOLD=ZPNTTM CALL xTYME(IBUFF(IPNT),ZPNTTM) C COMPUTE TIME OF NAVIGATION DATA BLOCK IF (IFLAG5 .EQ. 1) GO TO 430 420 ZNOLD=ZNAVTM CALL xTYME(IBUFF(1),ZNAVTM) 430 IF (ICALL .EQ. 2) GO TO 440 C ****************************************************************** C C UPDATE STORAGE ARRAYS C C ****************************************************************** C TRANSFER JPL SUPPLIED POINTING VECTOR DATA TO OUTPUT BUFFER IF (IFLAG4 .EQ. 2 .OR. IFLAG8 .EQ. 1) GO TO 450 440 CALL MVC(POINT1(1),POINT2(1),504) CALL MVC(IBUFF(IPNT),POINT1(1),504) IF (IFLAG4 .EQ. 1 .OR. IFLAG5 .EQ. 1) GO TO 460 C DEAL WITH INITIALIZATION WHEN USING MULTIPLE POINTING BLOCK TAPES. IF (IFLAG1 .EQ. 1 .OR. IFLAG2 .EQ. 1) GO TO 450 IF (IFLAG0 .EQ. 1) GO TO 450 IF (ZNOLD .EQ. ZNAVTM) GO TO 460 C TRANSFER JPL SUPPLIED NAVIGATION DATA TO SINGLE FORMAT BUFFER 450 CALL MVC(NAVIG1(1),NAVIG2(1),2400) if (numfor .lt. 1) then write (0,*) "Bad or missing header. NUMFOR = ",numfor if (ncount .eq. 1008) then numfor = 2 write (0,*) "Because NCOUNT = ",ncount, * " assume Cruise format." else if (ncount .eq. 1512) then numfor = 6 write (0,*) "Because NCOUNT = ",ncount, * " assume Uranus format." else go to 200 endif endif CALL NVSTOR(NAV,NAVIG1,NUMFOR) 460 IF (IFLAG1 .EQ. 1 .OR. IFLAG2 .EQ. 1) GO TO 230 IF (IFLAG0 .EQ. 1) GO TO 230 C ****************************************************************** C C STORAGE ARRAYS UPDATED C C ****************************************************************** IF (IFLAG4 .NE. 0) GO TO 230 IF (ZNOLD .EQ. 0.0) ZNOLD=ZNAVTM IF (ZPOLD .EQ. 0.0) ZPOLD=ZPNTTM IF (IFLAG7 .EQ. 1 .AND. ZTIME .GT. ZPNTTM) GO TO 510 IF (IFLAG7 .EQ. 1 .AND. ZTIME .LE. ZPNTTM) GO TO 230 IF (ZTIME .GT. ZNAVTM .AND. ZTIME .GT. ZPNTTM) GO TO 200 IF (ZTIME .LE. ZNAVTM .AND. ZTIME .LE. ZPNTTM) GO TO 230 IFLAG4=2 IF (ZTIME .LE. ZNAVTM) IFLAG4=1 GO TO 200 C ****************************************************************** C C SEARCH MULTIPLE POINTING BLOCK DATA C C ****************************************************************** 470 IF (IFLAG1 .EQ. 1) GO TO 200 IPNT=1+INAV*126 CALL MVC(IBUFF(127),NBUFF(1),NAVBYT) IFLAG5=1 CALL MVC(IBUFF(1),IBUFF(IPNT),504) c c ******* was the pointing block written by IBM or by SUN? IF (ibuff(ipnt + 125) .ne. ifinal) THEN c ************ convert IBM floating point numbers to IEEE floating pt. nerr = icvtf(ibuff(ipnt+8), 92, ibuff(ipnt+8)) if (nerr .gt. 0) write (0,*) * "C) number of conversion errors in 1st pt. of pointing blk=", * nerr nerr = icvtf(ibuff(ipnt+101), 2, ibuff(ipnt+101)) if (nerr .gt. 0) write (0,*) * "D) number of conversion errors in 2nd pt. of pointing blk=", * nerr ELSE if (.not. lsun) * write (0, *) "ERROR! Records written by both IBM and SUN!" ENDIF c CALL MVC(NAV(1),IBUFF(1),NAVBYT) ICYCLE=0 C NOW READY TO SEARCH ON FIRST POINTING DATA IN MULTIPLE POINTING BLOCKS GO TO 410 C SEARCH ON SUBSEQUENT POINTING DATA IN MULTIPLE POINTING BLOCKS. 480 IF (ICYCLE .EQ. INAV) GO TO 490 IF (IFLAG7 .EQ. 0) GO TO 490 IMOVE=ICYCLE*126+1 CALL MVC(NBUFF(IMOVE),IBUFF(IPNT),504) c ******* was the pointing block written by IBM or by SUN? IF (ibuff(ipnt + 125) .ne. ifinal) THEN nerr = icvtf(ibuff(ipnt+8), 92, ibuff(ipnt+8)) if (nerr .gt. 0) write (0,*) * "E) number of conversion errors in 1st pt. of pointing blk=", * nerr nerr = icvtf(ibuff(ipnt+101), 2, ibuff(ipnt+101)) if (nerr .gt. 0) write (0,*) * "F) number of conversion errors in 2nd pt. of pointing blk=", * nerr ELSE if (.not. lsun) * write (0, *) "ERROR! Records written by both IBM and SUN!" ENDIF ICYCLE=ICYCLE+1 GO TO 410 C IFLAG7 IS SET IF THE CURRENT POINTING BLOCK IS NOT THE LAST IN THIS C LOGICAL RECORD. 490 IFLAG5=0 GO TO 200 500 CONTINUE IFLAG3=1 GO TO 230 510 IF (JCOUNT .GT. 1) GO TO 200 IFLAG8=1 GO TO 110 520 IFLAG8=0 IFLAG1=0 CALL TSKIPn(UNITa,.FALSE.,0,-ICALL+2) C TAPE IS REPOSITIONED AND NAVIGATION BLOCKS ARE FILLED TO BEGIN C PROCESSING AT BEGINNING OF MULTIPLE POINTING BLOCK TAPE. CALL TWAITn(UNITa, irb) IF (EOF) GO TO 300 IF (ERR) GO TO 310 GO TO 200 END SUBROUTINE REFSTR(ITB,ISTAR) DIMENSION ITB(6),IREF(3,15),ISTR(14),TREF(15) LOGICAL FIRST DATA FIRST/.TRUE./, NUMSTR/12/ DATA IREF/000,00,00, 189,06,30, 3 189,16,15, 191,19,00, 5 192,01,22, 192,12,42, 7 196,01,00, 196,11,00, 9 198,22,00, 199,08,00, 1 202,16,00, 203,02,00, 3 365,00,00, 365,00,00, 5 365,00,00/ DATA ISTR/1,9,1,10,11,6,12,1,13,1,14,1,1,1/ C C ROUTINE TO SELECT NOMINAL REFERENCE STAR ( OR SIMULATION THEREOF) C FOR VOYAGER 2 ENCOUNTER, FOR USE WITH PREDICT TRAJECTORY WITH NO POI C SEE VOYAGER MEMO # 62 FOR TIME BOUNDARIES CONTAINED IN IREF C SEE SUBROUTINE REFER FOR KEY TO REFERENCE STAR KEYS USED IN ISTR C J. BELCHER 6/20/79 C C INITIALIZE TREF VECTOR FROM IREF TIMES IN DAY,HOUR,MIN OF 1979 C IF(.NOT.FIRST) GO TO 25 NUM=NUMSTR+1 DO 20 I=1,NUM 20 TREF(I)=(IREF(1,I)-1)*24.+IREF(2,I)*1.+(IREF(3,I)*1.)/60. FIRST=.FALSE. C C COMPUTE TIME FROM ITB C 25 T=(ITB(1)-1979)*24.*365.+(ITB(2)-1)*24.+ITB(3)*1.+(ITB(4)*1.)/60. * +(ITB(5)*1.)/3600. C C FIND APPROPRIATE REFERENCE STAR C DO 30 I=1,NUMSTR IF(T.GT.TREF(I).AND.T.LE.TREF(I+1)) GO TO 40 30 CONTINUE C WRITE(0,50) ITB 50 FORMAT(1H1,'FAILURE IN REFERENCE STAR SEARCH ROUTINE, REFSTR, AT T *IME ',6I5) ISTAR=1 RETURN C 40 ISTAR=ISTR(I) RETURN END SUBROUTINE NVSTOR(NVIN,NVOUT,NUMFOR) C C C VERIFIED FOR SATURN - F.B. + J.D.S. DEC 1980 C C * INTEGER*4 NVIN(1),NVOUT(1) INTEGER*4 NVBUFF(252),NVFORM(600) C **** SEDR ADDRESSES *********************************************** INTEGER*4 IS1(7,11), IS2(3,11), IS3(3,9), IS4(3), IS5(20), * IS6(9), IS7(2,11), is7a(3,11), IS8(4), IS9(9), * is10(9), IS2B(7), IS3A(7), IS3B(7), IS4A, ISL, ISC, * IT1(11), IT2(11), IT3(9), IT4(3), IT5(20), IT6(9), * IT7(11), it7a(11), IT8(4), IT9(9), it10(9), IT2B, * IT3A, IT3B, IT4A, ITL, ITC, NB1(11), NB2(11), NB3(9), * NB4(3), NB5(20), NB6(9), NB7(11), nb7a(11), NB8(4), * NB9(9), nb10(9), NB2B, NB3A, NB3B, NB4A, NBL, NBC DATA IS1 /1,1,1,1,1,1,1, 31,31,49,31,31,49,49, * 49,49,172,80,49,149,149, 51,51,173,82,51,150,150, * 50,50,174,81,50,151,151, 68,68,197,97,68,174,174, * 56,56,181,87,56,158,158, 58,58,183,89,58,160,160, * 65,65,187,93,65,164,164, 57,57,182,88,57,159,159, * 90,90,215,109,90,192,192/ DATA IS2 /19,19,19, 52,52,176, 54,54,175, 72,72,201, * 76,76,203, 82,82,207, 59,59,184, 61,61,186, 66,66,188, * 60,60,185, 94,94,219/ DATA IS3 /25,25,19, 53,53,83, 55,55,85, 74,74,101, * 62,62,90, 64,64,92, 67,67,94, 63,63,91, 96,96,113/ DATA IS4 /80,102,106/ DATA IS5 /25,61,177,209,189,239,221,91,121,157,160,163, * 166,169,139,159,162,165,168,171/ DATA IS6 /25,43,84,86,107,95,115,55,67/ DATA IS7 /19,19, 37,55, 52,153, 54,152, 72,178, * 76,180, 59,161, 61,163, 66,165, 60,162, 94,196/ data is7a /25,0,19, 43,0,55, 53,0,153, 55,0,152, 74,0,178, * 84,0,180, 62,0,161, 64,0,163, 67,0,165, 63,0,162, 96,0,196/ DATA IS8 /80,88,102,104/ DATA IS9 /25,61,154,184,166,198,91,121,139/ data is10/25,61,154,184,166,198,91,121,139/ DATA IS2B /37,37,55,0,106,0,0/ DATA IS3A /0,84,0,103,0,0,0/ DATA IS3B /43,43,0,37,112,0,0/ DATA IS4A/98/,ISL/84/,ISC/88/ C **** CSEDR ADDRESSES (i.e., the generalized format for all SEDRs) DATA IT1 /1,61,121,122,130,138,188,189,194,195,210/ DATA IT2 /19,123,131,142,146,152,190,191,196,197,214/ DATA IT3 /49,128,132,144,192,193,206,207,216/ DATA IT4 /150,174,220/ DATA IT5 /25,79,133,154,198,218,221,239,281,299,301,303, * 305,307,309,328,330,332,334,336/ DATA IT6 /55,109,129,137,168,208,219,269,337/ DATA IT7 /350,392,436,438,445,449,475,476,479,480,493/ data it7a /380,398,437,439,447,463,477,478,489,490,495/ DATA IT8 /453,467,471,473/ DATA IT9 /356,404,440,455,481,497,499,541,568/ data it10/386,582,444,469,491,498,529,559,578/ DATA IT2B/67/,IT3A/162/,IT3B/73/,IT4A/170/ DATA ITL/160/,ITC/166/ C **** NUMBER OF BYTES MOVED ************************************* DATA NB1 /72,24,4,4,4,16,4,4,4,4,16/ DATA NB2 /24,4,4,8,16,8,4,4,4,4,8/ DATA NB3 /24,4,4,8,4,4,4,4,8/ DATA NB4 /8,16,4/ DATA NB5 /96,120,16,24,32,4,72,120,72,8,8,8,8,8,76,8,8, * 8,8,4/ DATA NB6 /24,48,4,4,8,8,4,48,52/ DATA NB7 /24,24,4,4,8,16,4,4,4,4,8/ data nb7a/24,24,4,4,8,16,4,4,4,4,8/ DATA NB8 /8,8,8,8/ DATA NB9 /96,120,16,32,32,4,120,72,40/ data nb10/24, 72, 4, 8, 8, 4, 48, 36, 16/ DATA NB2B/24/,NB3A/16/,NB3B/24/,NB4A/16/ DATA NBL/8/,NBC/8/ N=NUMFOR DO 80 I=1,600 80 NVFORM(I)=0 CALL MVC(NVIN(1),NVBUFF(1),1008) C TRANSFER DATA COMMON TO LAUNCH, CRUISE, JUPITER, SATURN, C EXTENDED CRUISE, URANUS and Neptune FORMATS DO 81 I=1,11 IS1NI=IS1(N,I) IT1I=IT1(I) 81 CALL MVC(NVBUFF(IS1NI),NVFORM(IT1I),NB1(I)) C TRANSFER DATA COMMON TO LAUNCH, CRUISE, JUPITER AND C EXTENDED CRUISE FORMATS IF(N.EQ.4 .OR. N.EQ.6 .or. n.eq.7) GO TO 100 IS2BN=IS2B(N) CALL MVC(NVBUFF(IS2BN),NVFORM(IT2B),NB2B) C TRANSFER DATA COMMON TO LAUNCH, CRUISE AND JUPITER FORMATS 100 IF(N.NE.1 .AND. N.NE.2 .AND. N.NE.3) GO TO 110 DO 105 I=1,11 IS2NI=IS2(N,I) IT2I=IT2(I) 105 CALL MVC(NVBUFF(IS2NI),NVFORM(IT2I),NB2(I)) C TRANSFER DATA COMMON TO LAUNCH, CRUISE, SATURN AND C EXTENDED CRUISE FORMATS. 110 IF (N.EQ.3 .OR. N.EQ.6 .or. n.eq.7) GO TO 120 IS3BN=IS3B(N) CALL MVC(NVBUFF(IS3BN),NVFORM(IT3B),NB3B) C TRANSFER DATA COMMON TO LAUNCH, CRUISE AND SATURN FORMATS. 120 IF(N.NE.1 .AND. N.NE.2 .AND. N.NE.4) GO TO 130 NN=N IF(NN.EQ.4) NN=3 DO 125 I=1,9 IS3NI=IS3(NN,I) IT3I=IT3(I) 125 CALL MVC(NVBUFF(IS3NI),NVFORM(IT3I),NB3(I)) C TRANSFER DATA COMMON TO CRUISE AND SATURN FORMATS. 130 IF(N.NE.2 .AND. N.NE.4) GO TO 140 IS3AN=IS3A(N) CALL MVC(NVBUFF(IS3AN),NVFORM(IT3A),NB3A) C TRANSFER DATA COMMON TO LAUNCH, CRUISE AND EXTENDED CRUISE FORMATS 140 IF(N.NE.1 .AND. N.NE.2 .AND. N.NE.5) GO TO 150 CALL MVC(NVBUFF(IS4A),NVFORM(IT4A),NB4A) C TRANSFER DATA COMMON TO LAUNCH AND CRUISE FORMATS. 150 IF(N.NE.1 .AND. N.NE.2)GO TO 160 DO 155 I=1,3 IS4I=IS4(I) IT4I=IT4(I) 155 CALL MVC(NVBUFF(IS4I),NVFORM(IT4I),NB4(I)) C TRANSFER DATA COMMON TO EXTENDED CRUISE AND URANUS FORMATS. 160 IF(N.NE.5 .AND. N.NE.6) GO TO 166 DO 165 I=1,11 ijklm = i IS7I=IS7(N-4,I) IT7I=IT7(I) CALL MVC(NVBUFF(IS7I),NVFORM(IT7I),NB7(I)) 165 continue c transfer data common to extended cruise and Neptune formats. 166 if (n .lt. 5 .or. n .eq. 6) go to 170 do 168, i=1,11 is7ai = is7a( n-4, i) it7ai = it7a(i) call mvc(nvbuff(is7ai),nvform(it7ai),nb7a(i)) 168 continue C TRANSFER LAUNCH DATA 170 IF(N.NE.1) GO TO 180 CALL MVC(NVBUFF(ISL),NVFORM(ITL),NBL) C TRANSFER CRUISE DATA 180 IF(N.NE.2) GO TO 190 CALL MVC(NVBUFF(ISC),NVFORM(ITC),NBC) C TRANSFER JUPITER DATA 190 IF(N.NE.3) GO TO 200 DO 195 I=1,20 IS5I=IS5(I) IT5I=IT5(I) 195 CALL MVC(NVBUFF(IS5I),NVFORM(IT5I),NB5(I)) C TRANSFER SATURN DATA 200 IF(N.NE.4) GO TO 210 DO 205 I=1,9 IS6I=IS6(I) IT6I=IT6(I) 205 CALL MVC(NVBUFF(IS6I),NVFORM(IT6I),NB6(I)) C TRANSFER EXTENDED CRUISE DATA 210 IF(N.NE.5) GO TO 220 DO 215 I=1,4 IS8I=IS8(I) IT8I=IT8(I) 215 CALL MVC(NVBUFF(IS8I),NVFORM(IT8I),NB8(I)) C TRANSFER URANUS DATA 220 IF(N.NE.6) GO TO 230 DO 225 I=1,9 IS9I=IS9(I) IT9I=IT9(I) 225 CALL MVC(NVBUFF(IS9I),NVFORM(IT9I),NB9(I)) c transfer Neptune data 230 if (n .ne. 7) go to 240 do 235, i=1,9 is10i = is10(i) it10i = it10(i) call mvc(nvbuff(is10i),nvform(it10i),nb10(i)) 235 continue 240 CONTINUE C DATA TRANSFER COMPLETED CALL MVC(NVFORM(1),NVOUT(1),2400) RETURN END SUBROUTINE INTERP(ITIME,INAV1,INAV2,ANAV1,ANAV2, +IPNT1,IPNT2,APNT1,APNT2) IMPLICIT REAL*8(z) COMMON/NVBUF/INAV(6),ANAV(594) COMMON/PTBUF/IPNT(8),APNT(118) DIMENSION INAV1(6),INAV2(6),ANAV1(594),ANAV2(594) DIMENSION IPNT1(8),IPNT2(8),APNT1(118),APNT2(118) DIMENSION ITIME(6),zTIME(6),zCON(6) DIMENSION zTN1(6),zTN2(6),zTP1(6),zTP2(6) DIMENSION ILNS(8),ILNE(8) DIMENSION ILPS(18), ILPE(18) DATA zCON/365D0,24D0,60D0,60D0,1D3,1D0/ DATA ILNS/132,182,229,293,321,340,439,562/, * ILNE /171,211,232,302,330,343,490,575/ DATA ILPS /1,13,18,23,28,33,38,43,48,53,58,63,68,73,78,83,88,94/, * ILPE /3,14,19,24,29,34,39,44,49,54,59,64,69,74,79,84,89,96/ C COMPUTE ALL TIME VARIABLES AS REAL*8 NUMBERS. zTIME(1)=ITIME(1)-1977 zTN1(1)=INAV1(1)-1977 zTN2(1)=INAV2(1)-1977 zTP1(1)=IPNT1(1)-1977 zTP2(1)=IPNT2(1)-1977 DO 10 I=2,6 zTIME(I)=ITIME(I) zTN1(I)=INAV1(I) zTN2(I)=INAV2(I) zTP1(I)=IPNT1(I) 10 zTP2(I)=IPNT2(I) zTYM=0D0 zN1=0D0 zN2=0D0 zP1=0D0 zP2=0D0 DO 20 I=1,6 zTYM=zCON(I)*(zTYM+zTIME(I)) zN1=zCON(I)*(zN1+zTN1(I)) zN2=zCON(I)*(zN2+zTN2(I)) zP1=zCON(I)*(zP1+zTP1(I)) 20 zP2=zCON(I)*(zP2+zTP2(I)) TFRACN=(zTYM-zN1)/(zN2-zN1) TFRACP=(zTYM-zP1)/(zP2-zP1) C DO NOT INTERPOLATE POINTING BLOCK CONTINUATION FLAG C OR TELEMETRY USE CODE ICON=APNT1(93) ITUC = APNT1 (96) C RETAIN FLAG VALUE FOR MOST RECENTLY READ RECORD. APNT1(93)=0. APNT2(93)=0. APNT1 (96) = 0. APNT2 (96) = 0. C INTERPOLATE ALL REAL VALUES DO 30 I=1,594 30 ANAV(I)=(ANAV2(I)-ANAV1(I))*TFRACN+ANAV1(I) DO 40 I=1,118 40 APNT(I)=(APNT2(I)-APNT1(I))*TFRACP+APNT1(I) C CHECK ALL ANGLES AND REINTERPOLATE WHERE NECESSARY C INTERPOLATE NAVIGATION ANGLES DO 200 J=1,6 IS=ILNS(J) IE=ILNE(J) DO 100 I=IS,IE AN1=ANAV1(I) AN2=ANAV2(I) ABSANG=AN1-AN2 IF (ABSANG .LT. 0) ABSANG = -ABSANG IF (ABSANG .LE. 180) GO TO 100 IF (AN1 .LE. AN2) GO TO 60 AN2 = AN2+360. GO TO 70 60 AN1 = AN1+360. 70 ANAV(I) = AMOD((AN2-AN1)*TFRACN+AN1,360.) 100 CONTINUE 200 CONTINUE C INTERPOLATE POINTING VECTOR ANGLES DO 400 J = 1,18 IS=ILPS(J) IE=ILPE(J) DO 300 I=IS,IE AP1 = APNT1(I) AP2 = APNT2(I) ABSANG = AP1-AP2 IF (ABSANG .LT. 0) ABSANG = -ABSANG IF (ABSANG .LT. 180) GO TO 300 IF (AP1 .LE. AP2) GO TO 280 AP2 = AP2+360. GO TO 290 280 AP1 = AP1+360. 290 APNT(I) = AMOD((AP2-AP1)*TFRACP+AP1,360.) 300 CONTINUE 400 CONTINUE C INTERPOLATE FDSC COUNT VALUES IN POINTING BLOCK IFDSC1 = 60*IPNT1(7)+IPNT1(8) IFDSC2 = 60*IPNT2(7)+IPNT2(8) IFDSC = (IFDSC2-IFDSC1)*TFRACP+IFDSC1 IPNT(8) = MOD(IFDSC,60) IPNT(7) =IFDSC/60 C REINSERT CONTINUATION FLAG AND TELEMETRY USE CODE APNT(93)=ICON APNT (96) = ITUC DO 500 I=1,6 INAV(I)=ITIME(I) 500 IPNT(I)=ITIME(I) RETURN END C SUBROUTINE REFER (N,STAR) C *** SUBROUTINE REFER (N,STAR,STRNM) C As of 1/87, nothing in the 'sxred' module calls 'refer' C with 3 arguments. So, for the time being, the 3 argument C option is commented out. C C N SPECIFIES THE REFERENCE STAR C C 1 CANOPUS C 2 RIGILKENTAURUS C 3 HADAR C 4 ACRUX C 5 SPICA C 6 ARCTURUS C 7 MIMOSA C 8 MIAPLACIDUS C 9 VEGA C 10 FOMALHAUT C C 'STAR' CONTAINS THE CARTESIAN COORDINATES OF THE UNIT VECTOR C POINTING TO THE REFERENCE STAR IN THE ECL50 SYSTEM C DIMENSION STAR(3) C DIMENSION STRNM(4) REAL*4 R(2,10) C CHARACTER*4 RCHAR(4, 10), STRNM C DATA RCHAR /' ',' ',' CAN','OPUS', C 2 ' RIG','IL K','ENTA','URUS', C 3 ' ',' ',' H','ADAR', C 4 ' ',' ',' A','CRUX', C 5 ' ',' ',' S','PICA', C 6 ' ',' ','ARCT','URUS', C 7 ' ',' ',' MI','MOSA', C 8 ' ',' MIA','PLAC','IDUS', C 9 ' ',' ',' ','VEGA', C A ' ',' F','OMAL','HAUT'/ DATA R /-52.6674, 95.7107, 2 -60.6243,218.9856, 3 -60.1330,210.0684, 4 -62.8222,185.9498, 5 -10.9012,200.6384, 6 19.4253,213.3351, 7 -59.4158,191.1954, 8 -69.5101,138.1616, 9 38.74 ,278.81 , A -29.89 ,343.73 / C *** CALL NUMP(NARG) EP0=23.445789 RD=3.141593/180. X=COS(RD*R(1,N))*COS(RD*R(2,N)) Y=COS(RD*R(1,N))*SIN(RD*R(2,N)) Z=SIN(RD*R(1,N)) STAR(1)=X STAR(2)=Y*COS(RD*EP0)+Z*SIN(RD*EP0) STAR(3)=-Y*SIN(RD*EP0)+Z*COS(RD*EP0) C *** IF (NARG .EQ. 2) RETURN C DO 1 I=1,4 C 1 STRNM(I)=RCHAR(I,N) RETURN END SUBROUTINE NOMDIR(STAR) C C GIVEN THE UNIT VECTOR POINTING TO THE REFERENCE STAR (ECL50 C COMPONENTS), 'NOMDIR' WILL RETURN THE ECL50 COMPONENTS OF THE C CARTESIAN UNIT VECTORS OF THE S/C AXES. THE NOMINAL POINTING C DIRECTION IS ASSUMED: S/C -Z AXIS POINTING TOWARD EARTH, CANOPUS C SENSOR LOCKED ONTO REFERENCE STAR. THE COMPONENTS ARE CONTAINED C IN WORDS 12 THROUGH 20 OF THE SEDR POINTING VECTOR DATA BLOCKS. C WORDS 66 THROUGH 75 ARE ALSO FILLED WITH THE APPROPRIATE QUANTITIES C DIMENSION STAR(3),SCX(3),SCY(3),SCZ(3),SCXC(3),SCYC(3) DIMENSION ST(3) COMMON/NAVBUF/INTM(6),TRAJ(120),TRAJ2(126) COMMON/VCTBUF/IPTM(8),VCTBLK(92),ICON,RESTP(25) RD=0.017453292 SCZ(1)=TRAJ(1) SCZ(2)=TRAJ(2) SCZ(3)=TRAJ(3) CALL VECnor(SCZ) CALL VECcrs(SCYC,SCZ,STAR) CALL VECnor (SCYC) CALL ONAxR(SCY,SCYC,SCZ,55.0) CALL VECcrs (SCX,SCY,SCZ) DO 100 I=1,3 VCTBLK( 3+I)=SCX(I) VCTBLK( 6+I)=SCY(I) 100 VCTBLK( 9+I)=SCZ(I) C C PUT NAVBLK TIME INTO VCTBLK C DO 200 I=1,6 200 IPTM(I)=INTM(I) IPTM(8)=IPTM(8)+65536 C C FIND THE CARTESIAN UNIT VECTOR OF THE PLS SYMMETRY AXIS IN ECL50 C COORDINATES. C DO 300 I=1,3 SCZ(I)=-SCZ(I) 300 VCTBLK(I+59)=SCZ(I) C C FIND THE CARTESIAN UNIT VECTOR OF THE PLS LATERAL DETECTOR BORESIG C IN ECL50 COORDINATES. C C THETA=360.-43. THETA=317. CALL ONAxR(SCXC,SCX,SCZ,THETA) VCTBLK(65)=SCXC(1) VCTBLK(66)=SCXC(2) VCTBLK(67)=SCXC(3) C C FIND THE CELESTIAL CLOCK AND CONE ANGLES OF THE PLS SYMMETRY AXIS C AND OF THE PLS LATERAL DETECTOR BORESIGHT. C SCYC(1)=-TRAJ(7) SCYC(2)=-TRAJ(8) SCYC(3)=-TRAJ(9) CALL VECnor(SCYC) VCTBLK(59)=ACOS(vecscl(SCYC,SCZ))/RD VCTBLK(64)=ACOS(vecscl(SCYC,SCXC))/RD CALL REFER(1,ST) CALL VECcrs(SCY,SCYC,ST) CALL VECcrs(SCX,SCY,SCYC) VCTBLK(58)= ATAN2(vecscl(SCY,SCZ),vecscl(SCX,SCZ))/RD VCTBLK(63)= ATAN2(vecscl(SCY,SCXC),vecscl(SCX,SCXC))/RD IF (VCTBLK(58) .LT. 0.) VCTBLK(58)=VCTBLK(58)+360. IF (VCTBLK(63) .LT. 0.) VCTBLK(63)=VCTBLK(63)+360. RETURN END