SUBROUTINE RDATA (NEWSTAR, MOREDATA, NEWLOCK) C C Version 3.2 Better error handling if incremented time is not C equal to block header time. 29 Oct 1991 C Version 3.1 Includes proper treatment of Scan records. 9 Jun 1988 C Version 2.5 Includes 1988 format changes, tape format 3. C Version 2.4 Compact 386 version April 1988 C Version 2.3 for the new data tape format (circa July 1987) C the date is now the UT date. Much nicer than before. C C This subroutine reads data from a Mt Wilson optical interferometer C data tape and sets LASER = the laser positions in microns C MTIME = the UT time in seconds C N, X, Y, A = fringe data. C C It updates the header information in the include file REDBLK. C It discards ENDERR bad records at the end of each lock. C C output flags: C NEWSTAR set true if a scan record is encountered. C No data is returned and the old values of the C header block are kept until the next call to RDATA. C MOREDATA set false if an end of file is read, or if ISTAR is C changed to -1. C NEWLOCK set true if this data is the first data of a new C lock. C C All records that are not data records are copied to file 'other.dat' C Except for the laser data, which take up too much room. C C Internal data storage: C BUFFER and B contain the data in raw form (right off the tape) C These arrays contain data as well as dark counts, weather info, etc. C C L, T0, and TAKE contain the laser position, time, and fringe info C in a buffer of length ENDERR, used to dispose of bad data at the end C of a lock. C C Written 15 Apr 1987 David Mozurkewich C Modified 9 Jul 1987 C 11 Aug 1987 added NEWLOCK C 4 Apr 1988 moved common blocks to o:\work\util C Swap bytes in input records. C Changed names of the logical bit operations. C Swap words in double precission laser values IMPLICIT NONE SAVE INCLUDE 'fritz.inc' C Conversions from stroke units to microns C SCONV conv is wierd, because only part C of the stroke is used REAL *8 CONV REAL *4 SCONV PARAMETER ( CONV = 0.6329914D0 / 64.D0 ) PARAMETER (SCONV = 0.6329914D0 / 1234.00 ) INTEGER *4 MASK, TSAMP, BADCOUNT, istarold INTEGER *4 NREADS, ITER, I, J, BNTR, PNTR INTEGER *2 CLKFLG, TAKES(2), MSB, LSB, I2100 INTEGER *4 T0(MAXERR), NOW, TMP, TAKE12, IERR REAL *8 L(MAXERR), LASTL LOGICAL NEWSTAR, MOREDATA, FIRST, NEWLOCK, CHECKED EXTERNAL MSB, LSB EQUIVALENCE (TAKES(1), TAKE12) DATA BNTR / 101 / DATA I2100 / 100 / DATA CLKFLG / -1 / DATA FIRST / .TRUE. / DATA MASK / 255 / data istarold /-9999/ C....................................................................... C C variables C L laser position in microns C T0 time in msec from 0 hours UT C IF ( FIRST ) THEN C C Set some internal variables C BADCOUNT = 0 ! Number of misnumbered locks NLOCK = 0 ! Number of locks of data on this star NDATA = 0 ! Number of data records on this star DO I = 1, 4 BDATA(I) = 0 ! Number of bad data points DARK(I) = 0. ! dark count. END DO C Read the header block, if necessary. IF ( ENDERR .GT. MAXERR ) THEN WRITE(TERME,*) $ ' RDATA: ENDERR is too big. reduced to ', MAXERR ENDERR = MAXERR END IF IREC = 0 C C Read the header block. The first record on tape is numbered 0 C But FORTRAN thinks it's 1 C READ ( TERMD, REC=IREC+1+OFFSET, IOSTAT=IERR ) BUFFER IF ( IERR .NE. 0 ) GO TO 400 CALL BUFSWAP ( BUFFER, 1024 ) C Header format C 1 block number should be zero C 23 bytes per block header C 24 bytes per block C 25 format type 2 or 3 FTYPE = BUFFER(25) IF ( (BUFFER(23).NE.20) .OR. (BUFFER(24).NE.2048) ) THEN WRITE(TERMP,1100) BUFFER( 1), BUFFER(23), $ BUFFER(24), BUFFER(25) GO TO 550 1100 FORMAT( ' *** The header block is corrupt ' $ / ' block numb. = ', I8, $ / ' header size = ', I8, ' bytes ' $ / ' block size = ', I8, ' bytes ' $ / ' format type = ', I8 ) END IF IF ( (FTYPE .LT. 3 ) .OR. ( FTYPE .GT. 5 ) ) THEN WRITE(TERMP,1110) FTYPE 1110 FORMAT ( ' *** Invalid format type ', I8 ) GO TO 550 END IF NOW = 28800+ 3600*BUFFER(3) + 60*BUFFER(4) + BUFFER(5) NOW = 1000 * NOW + 4*((1000+BUFFER(6))/4) - 2 IMON = BUFFER( 7) IDAY = BUFFER(8) IYEAR = MOD(BUFFER( 9), I2100) + 1900 IF ( NOW .GT. 86400000 ) THEN NOW = NOW - 86400000 CALL NEXTDAY ( IDAY, IMON, IYEAR ) END IF STROKE= SCONV * FLOAT( BUFFER(10) ) ISTAR = BUFFER(11) IBASE = BUFFER(12) TSAMP = BUFFER(13) C Read the first data block and check the header. IREC = 1 READ ( TERMD, REC=IREC+1+OFFSET, IOSTAT=IERR ) BUFFER IF ( IERR .NE. 0 ) GO TO 450 CALL BUFSWAP ( BUFFER, 1024) IF ( BUFFER(1) .NE. IREC ) THEN WRITE(TERMP,'(2(A,I5))') ' First block, number ', IREC, $ ' is numbered ', BUFFER(1) END IF NOW = 28800 + 3600*BUFFER(3) + 60*BUFFER(4) + BUFFER(5) NOW = 1000 * NOW + 4*((1000+BUFFER(6))/4) - 2 IF ( NOW .GT. 86400000 ) NOW = NOW - 86400000 STROKE= SCONV * FLOAT( BUFFER(7) ) ISTAR = BUFFER( 8) IBASE = LSB( BUFFER( 9) ) JITTR = 0 C C The jitter in the first block is usually garbage, so throw it out. C C JITTR = MSB( BUFFER( 9) ) C IF ( JITTR .LT. 0 ) THEN C WRITE(TERMP,*) ' ***ERROR*** JITTER < 0 RECORD ', IREC C END IF TSAMP = BUFFER(10) BNTR = 0 CHECKED = .TRUE. NEWSTAR = .TRUE. PNTR = 1 C On the first call, fill up the buffers. NREADS = ENDERR + 1 C When a new star is encountered, NEWSTAR is set to .TRUE. Neither C star information nor data are returned to the main program. C RDATA must be called again (this time with NEWSTAR=.TRUE.) C to get the first data on the new star. C ELSE IF ( NEWSTAR ) THEN C C Check record type. SCAN and TIME records are allowed. C NLOCK = 0 NDATA = 0 DSCAN = 0 DO I = 1, 4 DARK(I) = 0. END DO IF ( B(1,BNTR) .EQ. -3 ) THEN CALL AUXINFO( BNTR, NOW, L(PNTR) ) ELSE IF ( B(1,BNTR) .EQ. -1 ) THEN NLOCK = NLOCK + 1 ISTAR = B(10,BNTR) IBASE = B(11,BNTR) ISCAN = B(13,BNTR) CALL AUXINFO( BNTR, NOW, L(PNTR) ) ELSE WRITE(TERMP,*) ' First record of a new star is neither', $ ' a scan record nor a time record.' WRITE(TERMP,*) ' Block = ', IREC, ' record = ', BNTR WRITE(TERMP,*) ' BOZO city ! ' MOREDATA = .FALSE. GO TO 600 END IF C C Put the scan information C into the header block. C Re-fill the buffer. NREADS = ENDERR + 1 ELSE NREADS = 1 NEWLOCK = .FALSE. END IF C----------------------------------------------------------------------- 100 CONTINUE C Read the appropriate number (NREADS) of data records. ITER = NREADS DO 200 I = 1, ITER C Return to here until a data/time record has been read. 110 CONTINUE C Do we need more data from the tape ? IF ( BNTR .EQ. NRECS ) THEN BNTR = 1 IREC = IREC + 1 READ (TERMD, REC=IREC+1+OFFSET, IOSTAT=IERR) BUFFER IF ( IERR .NE. 0 ) GO TO 500 CALL BUFSWAP ( BUFFER, 1024) IF ( BUFFER(1) .NE. IREC ) THEN IF ( BUFFER(1) .EQ. 0 ) GO TO 410 IF ( BADCOUNT .EQ. 0 ) THEN WRITE(TERMP,'(2(A,I5))') ' Block number ', $ IREC, ' is numbered ', BUFFER(1) END IF BADCOUNT = BADCOUNT + 1 END IF IF ( .NOT. FIRST ) CHECKED = .FALSE. C CHECKED is false until the information in the block C header has been checked. It is not checked here, C since it need not be correct if a scan record C or a time record preceeds the next data record. ELSE BNTR = BNTR + 1 END IF C C Scan record IF ( (B(1,BNTR) .EQ. -3) .AND. NEWSTAR ) THEN CHECKED = .TRUE. CALL AUXINFO ( BNTR, NOW, L(PNTR) ) NREADS = ENDERR + 1 GO TO 100 ELSE IF ( B(1,BNTR) .EQ. -3) THEN NEWSTAR = .TRUE. CHECKED = .TRUE. GO TO 600 C Time record ELSE IF ( B( 1,BNTR) .EQ. -1 ) THEN IF ( (.NOT. FIRST ).AND.(B(10,BNTR) .EQ. -1 ) ) THEN GO TO 560 END IF IF ( (.NOT.FIRST).AND.(B(10,BNTR) .NE. ISTAR)) THEN CHECKED = .TRUE. IF ( .NOT. NEWSTAR ) THEN NEWSTAR = .TRUE. GO TO 600 END IF ISTAR = B(10,BNTR) IBASE = B(11,BNTR) IF ( B(12,BNTR) .EQ. 7000 ) THEN CIFLAG = 4 ELSE IF ( B(12,BNTR) .EQ. 3500 ) THEN CIFLAG = 8 ELSE CIFLAG = B(12,BNTR) WRITE(TERMP,*) ' ILLEGAL VALUE OF COHERENT ', $ ' INTEGRATION FLAG = ', CIFLAG END IF ISCAN = B(13,BNTR) ELSE IF ((.NOT.FIRST).AND.(B(11,BNTR).NE.IBASE)) THEN C C This should never occur, but the fringe tracker computer is C broken, so we kind of ignore the error. C CHECKED = .TRUE. IF ( .NOT. NEWSTAR ) THEN NEWSTAR = .TRUE. GO TO 600 END IF ISTAR = B(10,BNTR) IBASE = B(11,BNTR) ISCAN = B(13,BNTR) END IF IF ( .NOT. CHECKED ) THEN IF ((BUFFER(8) .NE. ISTAR) .OR. $ (LSB(BUFFER(9)) .NE. IBASE) ) THEN WRITE(TERMP,*) ' ***ERROR*** Block header ', $ ' has wrong star or baseline ' WRITE(TERMP,*) ' BLOCK NUMBER =', IREC WRITE(TERMP,*) ' current baseline = ', IBASE, $ ' header value = ', LSB(BUFFER(9)) WRITE(TERMP,*) ' Values from header has ', $ ' been ignored. ' END IF JITTR = MSB(BUFFER(9)) IF ( JITTR .LT. 0 ) JITTR = JITTR + 256 CHECKED = .TRUE. END IF C C Yet more tape-format-error correction C IF ( ISCAN .EQ. 0 ) ISCAN = B(13,BNTR) IF ( ISCAN .NE. B(13,BNTR) ) THEN WRITE(TERMP,1115) ISCAN, B(13,BNTR), IREC, BNTR 1115 FORMAT ( ' ***WARNING*** ', $ ' Scan number changed in mid scan!! ' / $ ' Was ', I5, ' is ', I5, / $ ' Block = ', I5, ' Record = ', I5 ) END IF CALL AUXINFO ( BNTR, NOW, L(PNTR) ) NREADS = ENDERR + 1 NEWLOCK = .TRUE. GO TO 100 C Other non-data records ELSE IF ( B(1,BNTR) .LT. -1 ) THEN CALL AUXINFO ( BNTR, NOW, L(PNTR) ) GO TO 110 END IF C C This is a data record. If the block header has not been checked C yet, it should be done now. C IF ( .NOT. CHECKED ) THEN IF ((.NOT.FIRST).AND.(BUFFER(8) .NE. ISTAR)) THEN WRITE(TERMP,1130) ISTAR, BUFFER(8), IREC MOREDATA = .FALSE. GO TO 600 ELSE IF ((.NOT.FIRST) .AND. $ (LSB(BUFFER(9)).NE.IBASE) ) THEN WRITE(TERMP,1140) IBASE, BUFFER(9), IREC MOREDATA = .FALSE. GO TO 600 END IF 1130 FORMAT ( ' Block header => NEW STAR ', $ ' Should have followed a scan record' / $ ' ISTAR = ', I5, ' BUFFER(8) = ', I5, $ ' BLOCK NUMBER =', I5, ' ***FATAL ERROR***') 1140 FORMAT ( ' Block header => NEW BASELINE ', $ ' Should have followed a scan record' / $ ' IBASE = ', I5, ' BUFFER(9) = ', I5, $ ' BLOCK NUMBER =', I5, ' ***FATAL ERROR***') TMP = 28800+3600*BUFFER(3)+60*BUFFER(4)+BUFFER(5) IF ( TMP .GT. 86400 ) TMP = TMP - 86400 TMP = 1000 * TMP + 4*((1000+BUFFER(6))/4) - 2 IF ( ((TMP-NOW).EQ.1000).AND.(MOD(TMP,10).EQ.6) ) THEN WRITE(TERMP,*) ' ***Header on block # ', IREC, $ ' header time =', TMP, ' it should be =', NOW WRITE(TERMP,*) ' Incremented value will be used' ELSE IF ( TMP-NOW .NE. 0 ) THEN WRITE(TERMP,*) ' ***Header on block # ', IREC, $ ' header time =', TMP, ' it should be =', NOW WRITE(TERMP,*) ' Time from block header used' NOW = TMP END IF JITTR = MSB(BUFFER(9)) IF ( JITTR .LT. 0 ) JITTR = JITTR + 256 CHECKED = .TRUE. END IF C C Delay line jitter is stored in the the block headers. Keep the C information, butit doesn't get used now. C*********************************************************************** C THIS is the way it is * C * C The white-light (fringe) data is an average over four ms. * C The averaging interval ends at the 4 ms tick corresponding * C to the time of the current data record. The laser positions, * C however, are instantaneous. One would suppose, the white light * C data should be added to the mean of the present and previous * C laser positions and 2 ms should be subtracted from the time. * C In practice, this is not quite correct, since the laser * C positions get measured about 50 microseconds after the ms tick. * C To account for this, we give slightly unequal weights to the * C two laser positions in the mean. * C*********************************************************************** NDATA = NDATA + 1 T0(PNTR) = NOW NOW = NOW + 4 C C Switch the order of the words in double precision. TAKES(2) = B(12,BNTR) TAKES(1) = B(13,BNTR) L(PNTR) = 0.5125*CONV*DBLE(TAKE12) + LASTL LASTL = 0.4875*CONV*DBLE(TAKE12) C Save NXYA for red and blue channels C NXY for amp channels DO 160 J = 1, 11 TAKE(J,PNTR) = B(J,BNTR) 160 CONTINUE PNTR = MOD( PNTR, ENDERR ) + 1 200 CONTINUE NEWSTAR = .FALSE. C C Return time, laser position and the N, X, Y's C Convert time from msec to seconds. C MTIME = 1.D-3 * DBLE( T0(PNTR) ) LASER = L (PNTR) N(1) = TAKE( 1,PNTR) X(1) = TAKE( 2,PNTR) Y(1) = TAKE( 3,PNTR) A(1) = TAKE( 4,PNTR) N(2) = TAKE( 5,PNTR) X(2) = TAKE( 6,PNTR) Y(2) = TAKE( 7,PNTR) A(2) = TAKE( 8,PNTR) C C The amplitude data is paked two one bit numbers per I*2 word. C N is an unsigned integer. N(3) = IAND ( TAKE( 9, PNTR), MASK ) X(3) = IAND ( TAKE(10, PNTR), MASK ) Y(3) = IAND ( TAKE(11, PNTR), MASK ) IF ( X(3) .GT. 127 ) X(3) = X(3) - 256 IF ( Y(3) .GT. 127 ) Y(3) = Y(3) - 256 N(4) = IAND (ISHFT ( TAKE( 9,PNTR), -8 ), MASK) X(4) = IAND (ISHFT ( TAKE(10,PNTR), -8 ), MASK) Y(4) = IAND (ISHFT ( TAKE(11,PNTR), -8 ), MASK) IF ( X(4) .GT. 127 ) X(4) = X(4) - 256 IF ( Y(4) .GT. 127 ) Y(4) = Y(4) - 256 c write(6,*)n(1),x(1),y(1),n(2),x(2),y(2),n(3),x(3),y(3), c 1 n(4),x(4),y(4) C C Sometimes, the number of photons in channels 3 and 4 can be C larger than one byte. When this happens, we can correct for it by C add 256 to small values of N. Due to our low system visibility, C X, and Y are small enough to fit in one byte, unless N gets, really C BIG. If this happens this scheme will not work. C NLIMIT(3:4) contains the minimum number of photons allowed in C each channel. C LIMITS contains the stars numbers that correspond to the values in C NLIMIT. C DO 5001 J=1,20 IF (ISTAR.NE.LIMITS(J)) GOTO 5001 if(istar.ne.istarold.and.limits(j+1).eq.9999)then write(6,'(a,i4,a,f5.2)')' Enter nlimit3, nlimit4! (Star ', $ istar,'), Time = ',mtime/3600.D0 read(5,*)nlimit(j,3),nlimit(j,4) endif IF ( N(3) .LT. NLIMIT(J,3) .and. n(2).gt.0 ) N(3) = N(3) + 256 IF ( N(4) .LT. NLIMIT(J,4) .and. n(2).gt.0 ) N(4) = N(4) + 256 5001 CONTINUE istarold=istar C C Check for bad data C C DO 380 I = 1, 1 C IF (( X(I).EQ.0).AND.(Y(I).EQ.0) ) THEN C WRITE(TERMP,*) ' **X=Y=0 ON CHANNEL 1 ** IREC = ', IREC C END IF C 380 CONTINUE DO 390 I = 1, 4 IF (( ABS(X(I)) + ABS(Y(I)) .GT. N(I) ).OR. $ ( N(I) .LT. 0 ) ) THEN BDATA(I) = BDATA(I) + 1 IF ( BDATA(I) .EQ. 1 ) $ WRITE(TERMP,1120) X(I), Y(I), N(I), I, IREC, BNTR END IF 1120 FORMAT ( ' *** bad data *** x,y,n = ',3I7, ' chan', I2, $ ' block', I7, ' rec', I4 ) 390 CONTINUE C Debug output C WRITE(TERMP,'(9I5)') TAKE( 9,PNTR), N(3), N(4), C $ TAKE(10,PNTR), X(3), X(4), TAKE(11,PNTR), Y(3), Y(4) GO TO 600 400 CONTINUE WRITE(TERMP,*) $ ' ***Read error ', IERR, ' reading Header block on tape ' WRITE(TERMP,*) ' UNIT ', TERMD, ' RDATA bombs gracefully' WRITE(TERMP,'(2(A,I5))') ' Block number ', IREC, $ ' is numbered ', BUFFER(1) MOREDATA = .FALSE. GO TO 600 410 CONTINUE WRITE(TERMP,'(A,I5,A)') ' RDATA: Block number ', IREC, $ ' is new header block ' WRITE(TERMP,'((A,I5))') ' OFFSET adjusted and FRITZ continues ' NEWSTAR = .TRUE. OFFSET = IREC FIRST = .TRUE. GO TO 900 450 CONTINUE WRITE(TERMP,*) $ ' ***Error ', IERR, ' reading first data block on tape ' WRITE(TERMP,*) ' ***RDATA bombs' MOREDATA = .FALSE. GO TO 600 500 CONTINUE IF ( IERR .NE. -1 ) THEN WRITE(TERMP,*) ' ***Read error ', IERR, ' on tape *** ' WRITE(TERMP,*) ' RDATA bombs block no =', $ IREC, ' record number ', BNTR END IF MOREDATA = .FALSE. GO TO 600 550 CONTINUE WRITE(TERMP,*) ' RDATA ends. block no =', $ IREC, ' record number ', BNTR MOREDATA = .FALSE. GO TO 600 560 CONTINUE WRITE(TERMM,*) ' *** STAR = -1 => END OF FILE ' WRITE(TERMM,*) ' BLOCK NUMBER ', IREC, $ ' RECORD NUMBER = ', BNTR MOREDATA = .FALSE. NEWSTAR = .TRUE. 600 CONTINUE IF ( MOREDATA ) THEN FIRST = .FALSE. ELSE C C Empty the white light buffer C C ISCAN = -1 C CALL AUXINFO ( BNTR, NOW, L(PNTR) ) C C Prepare to read a new file C FIRST = .TRUE. END IF 900 CONTINUE RETURN END SUBROUTINE AUXINFO ( BNTR, NOW, LAS ) C C This subroutine is called each time auxiliary data is encountered. C C It generates dark count blocks for visi-data and a log of all data. C Because there is so much laser data, it is ignored. All other data C is written to the log file, along with the current time. C C The output file will eventually become the log file C C NOLOG has been deactivated. 7 Jun 1988 C NOLOG was re-activated 7 July 1990 C IMPLICIT NONE SAVE REAL *4 SCONV PARAMETER (SCONV = 0.6329914D0 / 1234.00 ) INCLUDE 'fritz.inc' INTEGER *4 I, BNTR, NOW INTEGER *2 ICODE, NTAU, I2STAR, I2BASE, MORE(8), I2100 REAL *8 LAS CHARACTER *8 WHAT(8) INTEGER *4 HIGH, LOW, DOUBLE DOUBLE( HIGH, LOW ) = ISHFT( HIGH, 16 ) + IAND( LOW, 65535 ) DATA WHAT / ' time ', ' c time ', ' header ', ' comment', $ ' dark ', ' weather', ' laser ', ' ' / C C NTAU = integration time for dark counts C DATA ICODE, NTAU, MORE / 1, 5000, 8*0 / DATA I2100 /100/ C C ISCAN = -1 if this is the end of the file. The white C light buffers have to be flushed before the program terminates. C C IF ( ISCAN .EQ. -1 ) THEN C WRITE(6,*) ' AUXINFO: END OF FILE DETECTED ' C B(1,BNTR) = -8 C END IF IF ( B(1,BNTR) .EQ. -1 ) THEN NLOCK = NLOCK + 1 NOW = 28800+3600*B(2,BNTR)+60*B(3,BNTR)+B(4,BNTR) NOW = 1000 * NOW + 4*((1000+B(5,BNTR))/4) - 2 IMON = B( 6,BNTR) IDAY = B( 7,BNTR) IYEAR = MOD(B( 8,BNTR), I2100) + 1900 IF ( NOW .GT. 86400000 ) THEN NOW = NOW - 86400000 CALL NEXTDAY ( IDAY, IMON, IYEAR ) END IF STROKE= SCONV * FLOAT( B( 9,BNTR) ) ISTAR = B(10,BNTR) IBASE = B(11,BNTR) IF ( B(12,BNTR) .EQ. 7000 ) THEN TSAMPLE = 4 ELSE IF ( B(12,BNTR) .EQ. 3500 ) THEN TSAMPLE = 8 ELSE WRITE(6,*) ' BAD TSAMPLE VALUE = ', B(12,BNTR) END IF ISCAN = B(13,BNTR) ELSE IF ( B(1,BNTR) .EQ. -3 ) THEN ISCAN = B(2,BNTR) FTYPE = B(3,BNTR) ISTAR = B(4,BNTR) IBASE = B(5,BNTR) APCODE= B(6,BNTR) SETDA = B(7,BNTR) WLFLAG= B(8,BNTR) DO 50 I = 1, 4 DARK(I) = 0 FILTER(I) = B(8+I,BNTR) 50 CONTINUE ELSE IF ( B(1,BNTR) .EQ. -5 ) THEN DARK(1) = DOUBLE ( B(2,BNTR), B(4,BNTR) ) DARK(2) = DOUBLE ( B(6,BNTR), B(7,BNTR) ) DARK(3) = DOUBLE ( B(5,BNTR), B(3,BNTR) ) DARK(4) = DOUBLE ( B(8,BNTR), B(9,BNTR) ) DSCAN = B(12,BNTR) I2STAR = ISTAR I2BASE = IBASE DJTR = B(13,BNTR) END IF IF ( .NOT. NOLOG ) THEN I = - B(1,BNTR) IF ( ( I .LE. 0 ) .OR. ( I .GT. 8 ) ) THEN WRITE(TERML, *) ' BAD RECORD TYPE ', B(1,BNTR) ELSE WRITE(TERML, '(A,13I7)') WHAT(I), (B(I,BNTR),I=1,NWORDS) END IF END IF RETURN END SUBROUTINE BUFSWAP( BUFFER, N ) C C swap the high and low order bytes of a I*2 array C 4 April 1988 David Mozurkewich C C ***NOTE*** The NDP fortran manual is wrong, a shift to the C right shifts in the carry bit, not zeros. C IMPLICIT NONE INTEGER *2 BUFFER(*), MASK INTEGER *4 N, I DATA MASK / 255 / DO 100 I = 1, N BUFFER(I) = ISHFT(BUFFER(I),8) + $ IAND( ISHFT(BUFFER(I),-8), MASK ) 100 CONTINUE RETURN END INTEGER *2 FUNCTION LSB( I ) C C Returns the least significant byte of a two byte integer C IMPLICIT NONE INTEGER *2 I, MASK DATA MASK / 255 / LSB = IAND ( I, MASK ) RETURN END INTEGER *2 FUNCTION MSB( I ) C C Returns the most significant byte of a two byte integer C INTEGER *2 I MSB = ISHFT( I, -8 ) RETURN END