SUBROUTINE Pedit C C Subroutine to manipulate the data on a point by point basis. C C VERSION 1.0 16 OCTOBER 1988 C 1.2 13 DECEMBER 1988 C IMPLICIT UNDEFINED (A-Z) SAVE REAL *4 PI PARAMETER ( PI = 3.1415926535 ) INTEGER *4 NMAX PARAMETER ( NMAX = 15000 ) INCLUDE 'VPLOT.INC' INTEGER *4 INTEG, ICHAN, SPTR, BPTR, ISTAR, IBASE, NINT, N INTEGER *4 IOK(NMAX), REC(NMAX), IS(NMAX), NPTS, POINTID INTEGER *4 I, J, K, ICHAN, LINES(5), POINTS(5), POINTER(NMAX) INTEGER *4 SYMBOL(5), ICOLOR, XTYPE, YTYPE, MASK(4), IMARK(NMAX) INTEGER *4 THISMASK, UNMASK(4) REAL *4 X(NMAX), Y(NMAX), NPHOT(NMAX,4), V(NMAX,4), PHASE(NMAX,2) REAL *4 XMIN, XMAX, YMIN, YMAX, TIME(NMAX) REAL *4 ZPOINT, SLOPE, XFIT(2), YFIT(2) REAL *4 XLO, XHI, YLO, YHI, RX, RY, DIST, DISTANCE, SCALE CHARACTER *1 CH CHARACTER *40 TITLE(6) LOGICAL NEWSTAR, MARKED, HCOPY INCLUDE 'HARDCOPY.INC' C********************************************************************** DATA SYMBOL / 2, 3, 6, 13, 16 / DATA LINES / 11, 22, 33, 44, 55 / DATA POINTS / 1, 2, 3, 4, 5 / DATA MASK / 1, 2, 4, 8 / DATA UNMASK / 14, 13, 11, 7 / C---------------------------------------------------------------------- WRITE(6,*) ' PEDIT. Edits point data. ' INTEG = 1 ! NUMBER OF INTEGRATIONS ICHAN = 1 ! CHANNEL FOR PLOTTING SPTR = 1 ! POINTER TO STAR IN STAR LIST XTYPE = 1 ! TYPE OF X AXIS TO PLOT YTYPE = 1 ! TYPE OF Y AXIS TO PLOT 40 WRITE (6,*) ' Star number to edit (def=1st observed star): ' READ (5,'(I5)') J IF (J.EQ.0) THEN SPTR = 1 ISTAR = SLIST(1) GO TO 60 ELSE DO 50 I = 1, NSTAR IF ( J .EQ. SLIST(I) ) THEN SPTR = I ISTAR = J GOTO 60 END IF 50 CONTINUE END IF WRITE (6,*) ' Star is not in star list! ' GO TO 40 C Read pointer to baseline in baseline list 60 CONTINUE IF ( NBASE .EQ. 1 ) THEN WRITE(6,*) ' ONLY ONE BASELINE IN DATA SET ' BPTR = 1 ELSE WRITE (6,*) ' Sequential baseline number to edit (def=1): ' READ (5,'(I1)') BPTR IF (BPTR.EQ.0) BPTR=1 IF (BPTR .GT.NBASE) THEN WRITE (6,*) ' Sorry. Only ',NBASE, $ ' baselines in data set.' GO TO 60 END IF END IF IBASE = BLIST(BPTR) MARKED = .FALSE. NEWSTAR = .TRUE. HCOPY = .FALSE. C Set up graphics here 80 CONTINUE IF ( HCOPY ) THEN NPLOTS = NPLOTS + 1 WRITE(PLOTFILE(6:8),'(I3.3)') NPLOTS CALL PGBEGIN(0,PLOTFILE//PLOT_DEV, 1, 1 ) ELSE CALL PGBEGIN(0, '/EGA', 1, 1) END IF 100 CONTINUE C Get data for this star/baseline C IF ( NEWSTAR .AND. MARKED ) THEN CALL DELPOINT( NPTS, REC, IOK ) MARKED = .FALSE. END IF IF ( NEWSTAR ) THEN ISTAR = SLIST(SPTR) IBASE = BLIST(BPTR) POINTID = 1 CALL GETSTAR ( ISTAR, IBASE, NPTS, NMAX, NPHOT,IS, $ TIME, PHASE, V, REC, IOK ) NEWSTAR = .FALSE. END IF NINT = 1 N = 1 ICOLOR = 1 X(1) = 0. Y(1) = 0. POINTER(1) = 1 IMARK(1) = ICOLOR C Average data to the appropriate integration time and C throw out deleted points C DO 150 I = 1, NPTS IF ( (I.GT.1) .AND. (IS(I).NE.IS(I-1) ) ) THEN ICOLOR = MOD(ICOLOR,15) + 1 IMARK(N) = ICOLOR END IF IF ( IAND(IOK(I),MASK(ICHAN)) .NE. 0 ) GO TO 150 IF ( PHASE(I,1).GT.PHIMAX .OR. PHASE(I,1).LT.PHIMIN) $ GO TO 150 IF ( XTYPE .EQ. 1 ) THEN X(N) = X(N) + TIME(I) ELSE IF ( XTYPE .EQ. 2 ) THEN X(N) = X(N) + FLOAT(N) ELSE IF ( XTYPE .EQ. 3 ) THEN X(N) = X(N) + PHASE(I,1) ELSE IF ( XTYPE .EQ. 4 ) THEN X(N) = X(N) + V(I,1) ELSE IF ( XTYPE .EQ. 5 ) THEN X(N) = X(N) + NPHOT(I,ICHAN) END IF IF ( YTYPE .EQ. 1 ) THEN Y(N) = Y(N) + V(I,ICHAN) ELSE IF ( YTYPE .EQ. 2 ) THEN Y(N) = Y(N) + V(I,ICHAN) $ / ( 1. + DVDP(ICHAN)*(PHASE(I,1)-PHIREF) ) ELSE IF ( YTYPE .EQ. 3 ) THEN Y(N) = Y(N) + NPHOT(I,ICHAN) ELSE IF ( YTYPE .EQ. 4 ) THEN IF ( V(I,ICHAN) .LE. 0 ) THEN Y(N) = Y(N) - SQRT ( -V(I,ICHAN) ) ELSE Y(N) = Y(N) + SQRT ( V(I,ICHAN) ) END IF END IF IF ( NINT .EQ. 1 ) THEN POINTER(N) = I IMARK(N) = ICOLOR END IF IF ( NINT .EQ. INTEG ) THEN X(N) = X(N) / FLOAT(INTEG) Y(N) = Y(N) / FLOAT(INTEG) N = N + 1 X(N) = 0. Y(N) = 0. END IF NINT = MOD( NINT, INTEG ) + 1 150 CONTINUE C Throw away partial average at end. N = N - 1 C Fit a line through the data C CALL FITLINE ( N, X, Y, SLOPE, ZPOINT ) C C Decide on range for plot C IF ( N .EQ. 0 ) THEN YMIN = 0. YMAX = 1. XMIN = 0. XMAX = 15. ELSE YMIN = Y(1) YMAX = Y(1) XMIN = X(1) XMAX = X(1) DO I = 1, N YMIN = MIN ( YMIN, Y(I) ) YMAX = MAX ( YMAX, Y(I) ) XMIN = MIN ( XMIN, X(I) ) XMAX = MAX ( XMAX, X(I) ) END DO IF ( YMIN .GE. YMAX ) THEN YMIN = 0. YMAX = MAX ( YMAX, 1. ) END IF END IF C IF ( XTYPE .EQ. 1 ) THEN TITLE(1) = 'TIME (HOURS)' ELSE IF ( XTYPE .EQ. 2 ) THEN TITLE(1) = 'POINTS' ELSE IF ( XTYPE .EQ. 3 ) THEN TITLE(1) = 'PHASE RMS (RADIANS)' ELSE IF ( XTYPE .EQ. 4 ) THEN TITLE(1) = 'VIS SQUARED, CHANNEL 1' ELSE IF ( XTYPE .EQ. 5 ) THEN TITLE(1) = 'NUMBER OF PHOTONS PER INTEGRATION' END IF IF ( YTYPE .EQ. 1 ) THEN TITLE(2) = 'VISIBILITY SQUARED' ELSE IF ( YTYPE .EQ. 2 ) THEN TITLE(2) = 'POINT CALIBRATED VISIBILITY SQUARED' ELSE IF ( YTYPE .EQ. 3 ) THEN TITLE(2) = 'NUMBER OF PHOTONS / 4 ms' ELSE IF ( YTYPE .EQ. 4 ) THEN TITLE(2) = 'VISIBILITY' END IF WRITE(TITLE(3),1205) ISTAR, IBASE WRITE(TITLE(4),1200) ICHAN, FILTERID(ICHAN) WRITE(TITLE(5),1215) DATE, INTEG IF ( SLOPE.GT.0.) THEN WRITE(TITLE(6),1210) ZPOINT, SLOPE ELSE WRITE(TITLE(6),1211) ZPOINT, ABS(SLOPE) END IF 1200 FORMAT( 5X, 'CHANNEL = ', I2, 4X, A7 ) 1205 FORMAT( 5X, ' STAR = ', I5, ' BASELINE = ', I10 ) 1210 FORMAT( 'Y = ', F6.3, ' + ', F6.3, ' X ', 18X ) 1211 FORMAT( 'Y = ', F6.3, ' - ', F6.3, ' X ', 18X ) 1215 FORMAT( A15, ' INTEGRATION =', I3, ' SAMPLES' ) C C Set big BLUE letters so that PGENV will leave C more room around the plot. C ICOLOR = 5 CALL PGSCI ( ICOLOR ) CALL PGSCH ( 1.5 ) CALL PGRNGE ( XMIN, XMAX, XLO, XHI ) CALL PGRNGE ( YMIN, YMAX, YLO, YHI ) CALL PGENV ( XLO, XHI, YLO, YHI, 0, 1 ) CALL PGMTEXT ( 'T', 2.5, 0.5, 0.5, TITLE(3) ) CALL PGSCH ( 1.0 ) CALL PGMTEXT ( 'B', 3.5, 0.5, 0.5, TITLE(1) ) CALL PGMTEXT ( 'L', 3.5, 0.5, 0.5, TITLE(2) ) CALL PGMTEXT ( 'T', 1.5, 0.5, 0.5, TITLE(4) ) CALL PGMTEXT ( 'R', 2.5, 0.5, 0.5, TITLE(5) ) CALL PGMTEXT ( 'B', 5.0, 0.5, 0.5, TITLE(6) ) CALL PGSCI ( IMARK(1) ) CALL PGPOINT( 1, X(1), Y(1), SYMBOL(1) ) DO 170 I = 2, N IF ( IMARK(I) .NE. IMARK(I-1) ) THEN CALL PGSCI ( IMARK(I) ) END IF CALL PGPOINT( 1, X(I), Y(I), SYMBOL(1) ) 170 CONTINUE ICOLOR = ICOLOR + 1 CALL PGSCI ( ICOLOR ) K = MOD( ICOLOR, 5 ) + 1 XFIT(1) = XMIN XFIT(2) = XMAX YFIT(1) = ZPOINT + SLOPE * XFIT(1) YFIT(2) = ZPOINT + SLOPE * XFIT(2) CALL PGLINE ( 2, XFIT, YFIT ) C C Terminate the hardcopy here C IF ( HCOPY ) THEN HCOPY = .FALSE. CALL PGEND GO TO 80 END IF C C Ask for next command C 200 CONTINUE CALL EGA_RESTORE_DEFAULT 210 CONTINUE CALL LOCATE(0,0) CALL WRITE_STRING ( 'Command:' ) RX = X(POINTID) RY = Y(POINTID) CALL PGCURSE( RX, RY, CH ) CALL CAPS ( CH ) 215 CALL LOCATE(9,0) CALL WRITE_STRING ( CH ) IF ( CH .EQ. '?' ) THEN CALL LOCATE (0, 1) CALL WRITE_STRING ( '? Displays this help ' ) CALL LOCATE (0, 2) CALL WRITE_STRING ( 'A Average data before plot ' ) CALL LOCATE (0, 3) CALL WRITE_STRING ( 'B Go to the next baseline ' ) CALL LOCATE (0, 4) CALL WRITE_STRING ( 'C Toggle channel number ' ) CALL LOCATE (0, 5) CALL WRITE_STRING ( 'D Delete point, 4 channels ' ) CALL LOCATE (0, 6) CALL WRITE_STRING ( 'Z Delete this channel only ' ) CALL LOCATE (0, 7) CALL WRITE_STRING ( 'G Remove graffiti from plot' ) CALL LOCATE (0, 7) CALL WRITE_STRING ( 'I Identify nearest ok scan ' ) CALL LOCATE (0, 8) CALL WRITE_STRING ( 'N Go to next star ' ) CALL LOCATE (0, 9) CALL WRITE_STRING ( 'P Go to previous star ' ) CALL LOCATE (0,10) CALL WRITE_STRING ( 'R Move cursor to Right ' ) CALL LOCATE (0,11) CALL WRITE_STRING ( 'L Move cursor to Left ' ) CALL LOCATE (0,12) CALL WRITE_STRING ( 'S Go to a new star ' ) CALL LOCATE (0,13) CALL WRITE_STRING ( 'T Test calibration ' ) CALL LOCATE (0,14) CALL WRITE_STRING ( 'U Undelete ' ) CALL LOCATE (0,15) CALL WRITE_STRING ( 'V Delete by visibility ' ) CALL LOCATE (0,16) CALL WRITE_STRING ( 'X Toggle X axis ' ) CALL LOCATE (0,17) CALL WRITE_STRING ( 'Y Toggle Y axis ' ) CALL LOCATE (0,18) CALL WRITE_STRING ( 'H Hardcopy ' ) CALL LOCATE (0,19) CALL WRITE_STRING ( 'Q Quit ' ) GO TO 210 ELSE IF ( CH .EQ. 'N' ) THEN C go to next scan IF ( MARKED ) THEN CALL DELPOINT( NPTS, REC, IOK ) MARKED = .FALSE. END IF NEWSTAR = .TRUE. SPTR = MOD(SPTR,NSTAR) + 1 CALL LOCATE (0,1) CALL WRITE_STRING ('PATIENCE IS A VIRTUE' ) ELSE IF ( CH .EQ. 'P' ) THEN IF ( MARKED ) THEN CALL DELPOINT( NPTS, REC, IOK ) MARKED = .FALSE. END IF NEWSTAR = .TRUE. SPTR = MOD(SPTR+NSTAR-2,NSTAR) + 1 CALL LOCATE (0,1) CALL WRITE_STRING ('GROW OLD GRACEFULLY' ) ELSE IF ( (CH .EQ. 'B') .AND. (NBASE .GT. 1) ) THEN C C Do nothing if there is only one baseline C IF ( MARKED ) THEN CALL DELPOINT( NPTS, REC, IOK ) MARKED = .FALSE. END IF NEWSTAR = .TRUE. BPTR = MOD(BPTR,NBASE) + 1 ELSE IF ( CH .EQ. 'C' ) THEN ICHAN = MOD(ICHAN,4) + 1 ELSE IF ( CH .EQ. 'G' ) THEN GO TO 100 ELSE IF ( CH .EQ. 'A' ) THEN C change integration time CALL LOCATE (0,1) CALL WRITE_STRING ( ' New integration time = ' ) READ (5,*) INTEG INTEG = MIN(100, MAX(1,INTEG) ) ELSE IF ( CH .EQ. 'T' ) THEN CALL LOCATE (0,1) CALL WRITE_STRING ( ' INPUT REFERENCE PHASE A. C. ' ) CALL LOCATE (30,1) READ (5,*) PHIREF CALL LOCATE (0,2) CALL WRITE_STRING ( ' INPUT MINIMUM PHASE A. C. ' ) CALL LOCATE (30,2) READ (5,*) PHIMIN CALL LOCATE (0,3) CALL WRITE_STRING ( ' INPUT SLOPE THIS CHANNEL ONLY ' ) CALL LOCATE (32,3) READ (5,*) DVDP(ICHAN) YTYPE = 2 GO TO 100 ELSE IF ( CH .EQ. 'S' ) THEN CALL LOCATE (0,1) CALL WRITE_STRING ( ' STAR NUMBER: ' ) READ (5,*) J DO 350 I = 1, NSTAR IF ( J .EQ. SLIST(I) ) THEN NEWSTAR = .TRUE. SPTR = I ISTAR = J GOTO 100 END IF 350 CONTINUE CALL LOCATE ( 0,1) CALL WRITE_STRING ( ' STAR IS NOT IN STAR LIST ' ) GO TO 210 ELSE IF ( CH .EQ. 'X' ) THEN XTYPE = MOD(XTYPE, 5 ) + 1 ELSE IF ( CH .EQ. 'Y' ) THEN YTYPE = MOD(YTYPE, 4 ) + 1 ELSE IF ( CH .EQ. 'I' ) THEN C C Identify scan closest to cursor C SCALE = XMAX - XMIN IF ( SCALE .NE. 0 ) THEN SCALE = ( YMAX - YMIN ) / SCALE SCALE = SCALE * SCALE END IF DISTANCE = 1.E9 POINTID = 1 DO 400 I = 1, N DIST = SCALE * (RX-X(I))*(RX-X(I)) + $ (RY-Y(I))*(RY-Y(I)) IF ( DIST .LT. DISTANCE ) THEN DISTANCE = DIST POINTID = I END IF 400 CONTINUE CALL LOCATE (0,2) WRITE(6,*) ' DATA NUMBER ', POINTID GO TO 200 ELSE IF ( (CH .EQ. 'D').OR.(CH.EQ. 'Z') ) THEN C C Delete the scan closest to the cursor. C Z this channel only, D all 4 channels C THISMASK = 15 IF ( CH .EQ. 'Z' ) THISMASK = MASK(ICHAN) MARKED = .TRUE. SCALE = XMAX - XMIN IF ( SCALE .NE. 0 ) THEN SCALE = ( YMAX - YMIN ) / SCALE SCALE = SCALE * SCALE ELSE SCALE = 1. END IF DISTANCE = 1.E9 POINTID = 0 DO 450 I = 1, N DIST = SCALE * (RX-X(I))*(RX-X(I)) + (RY-Y(I))*(RY-Y(I)) IF ( DIST .LT. DISTANCE ) THEN DISTANCE = DIST POINTID = I END IF 450 CONTINUE IF ( POINTID .NE. 0 ) THEN CALL LOCATE (0,2) WRITE(6,*) ' POINT ', POINTID, ' DELETED ' NINT = 0 I = POINTER(POINTID) 470 CONTINUE IF ( (PHASE(I,1).LT.PHIMAX) .AND. $ (PHASE(I,1).GT.PHIMIN) .AND. $ (IAND(IOK(I),MASK(ICHAN)) .EQ. 0) ) THEN IOK(I) = IOR ( IOK(I),THISMASK ) NINT = NINT + 1 END IF I = I + 1 IF ( (NINT .LT. INTEG).AND.(I.LE.NPTS) ) GO TO 470 CALL PGSCI ( 0 ) CALL PGPOINT( 1, X(POINTID), Y(POINTID), SYMBOL(1) ) C Move the X point to some large value so that it is ignored X(POINTID) = 1.E6 C Move cursor to next closest point using Identify option CH = 'I' CALL EGA_RESTORE_DEFAULT GO TO 215 ELSE POINTID = 1 END IF GO TO 200 C ELSE IF ( CH .EQ. 'V') THEN CALL LOCATE (0,1) CALL WRITE_STRING( ' DELETE ALL 4 CHANNELS ' ) CALL LOCATE (0,2) CALL WRITE_STRING( ' TO MARK POINTS BELOW CURSOR ') CALL LOCATE (0,3) CALL WRITE_STRING( ' TYPE Q TO ABORT THIS SESSION ' ) CALL LOCATE (0,4) CALL WRITE_STRING(' TYPE A TO DELETE POINTS ABOVE CURSOR') CALL LOCATE (0,5) CALL WRITE_STRING(' TYPE B TO CUT OUT POINTS BELOW CURSOR') CALL LOCATE (0,6) CALL WRITE_STRING(' TYPE C TO TOGGLE WHAT TO DELETE') THISMASK = 15 550 CONTINUE CALL PGCURSE (RX, RY, CH ) CALL CAPS ( CH ) DO 570 I = 1, N IF ( Y(I) .LT. RY ) THEN CALL PGSCI ( 1 ) CALL PGPOINT ( 1, X(I), Y(I), SYMBOL(1) ) ELSE CALL PGSCI ( 6 ) CALL PGPOINT ( 1, X(I), Y(I), SYMBOL(1) ) END IF 570 CONTINUE IF ( CH .EQ. 'A' ) THEN MARKED = .TRUE. DO 580 I = 1, NPTS IF ( V(I,ICHAN) .GT. RY ) THEN IOK(I) = IOR(IOK(I),THISMASK) END IF 580 CONTINUE ELSE IF ( CH .EQ. 'B' ) THEN MARKED = .TRUE. DO 590 I = 1, NPTS IF ( V(I,ICHAN) .LT. RY ) THEN IOK(I) = IOR(IOK(I),THISMASK) END IF 590 CONTINUE ELSE IF ( CH .EQ. 'C' ) THEN IF ( THISMASK .EQ. 15 ) THEN THISMASK = MASK(ICHAN) CALL LOCATE (0,1) CALL WRITE_STRING( ' DELETE THIS CHANNEL ONLY' ) ELSE THISMASK = 15 CALL LOCATE (0,1) CALL WRITE_STRING( ' DELETE ALL 4 CHANNELS ' ) END IF GO TO 550 ELSE IF ( CH .NE. 'Q' ) THEN GO TO 550 END IF ELSE IF ( CH .EQ. 'U' ) THEN CALL LOCATE (0,1) CALL WRITE_STRING ( ' A for all 4 channels undeleted ' ) CALL LOCATE (0,2) CALL WRITE_STRING ( ' T for this channel undeleted ' ) CALL LOCATE (0,3) CALL WRITE_STRING ( ' Anything else has no action ' ) CALL PGCURSE (RX, RY, CH ) IF (CH .EQ. 'A' ) THEN DO 595 I = 1, NPTS IOK(I) = 0 595 CONTINUE MARKED = .TRUE. ELSE IF ( CH .EQ. 'T' ) THEN DO 596 I = 1, NPTS IOK(I) = IAND( IOK(I), UNMASK(ICHAN) ) 596 CONTINUE MARKED = .TRUE. END IF GO TO 100 ELSE IF ( CH .EQ. 'R' ) THEN POINTID = MOD(POINTID,N)+1 GO TO 200 ELSE IF ( CH .EQ. 'L' ) THEN POINTID = MOD(N+POINTID-2,N)+1 GO TO 200 ELSE IF ( CH .EQ. 'H' ) THEN HCOPY = .TRUE. CALL PGEND GO TO 80 ELSE IF ( CH .EQ. '$' ) THEN WRITE(6,*) ' DVDP = ', DVDP WRITE(6,*) ' PHIMIN = ', PHIMIN DO 600 I = 1, NPTS WRITE(6,*) I, IOK(I) 600 CONTINUE C ELSE IF ( CH .EQ. 'Q' ) THEN C QUIT after deleting any deleted points IF ( MARKED ) THEN CALL DELPOINT( NPTS, REC, IOK ) MARKED = .FALSE. END IF GO TO 900 ELSE CALL LOCATE (0,2) CALL WRITE_STRING(' Illegal command.' ) GO TO 200 END IF CALL PGASK(.FALSE.) CALL PGADVANCE GO TO 100 900 CONTINUE CALL PGEND RETURN END SUBROUTINE FITLINE ( N, X, Y, SLOPE, ZPOINT ) C C Fit a line through (X(i), Y(i), i=1, N ) C and return the slope, SLOPE and y-intersept, ZPOINT C SAVE INTEGER *4 N, I REAL *4 X(*), Y(*), SLOPE, ZPOINT REAL *4 XXSUM, XYSUM, XSUM, YSUM C IF ( N .LT. 2 ) THEN SLOPE = 0. ZPOINT = 0. GO TO 900 END IF XXSUM = 0. XYSUM = 0. XSUM = 0. YSUM = 0. DO 100 I = 1, N XSUM = XSUM + X(I) XXSUM = XXSUM + X(I)*X(I) XYSUM = XYSUM + X(I)*Y(I) YSUM = YSUM + Y(I) 100 CONTINUE XSUM = XSUM / FLOAT(N) XXSUM = XXSUM / FLOAT(N) XYSUM = XYSUM / FLOAT(N) YSUM = YSUM / FLOAT(N) SLOPE = ( XYSUM-XSUM*YSUM)/(XXSUM-XSUM*XSUM) ZPOINT= YSUM - SLOPE*XSUM 900 CONTINUE RETURN END SUBROUTINE DELPOINT( NPTS, REC, IOK ) C C Delete marked points C IMPLICIT UNDEFINED (A-Z) SAVE INTEGER *4 I, NPTS, IOK(*), REC(*), IERR DO 100 I = 1, NPTS WRITE(2, REC=REC(I),IOSTAT=IERR) IOK(I) IF (IERR .NE. 0 ) THEN WRITE(6,*) ' ERROR ', IERR, ' UPDATING POINT CAL FILE' END IF 100 CONTINUE RETURN END SUBROUTINE Pexprt C C Subroutine to export data on a point by point basis to an ASCII file C C VERSION 1.0 1 Feb 89 C IMPLICIT UNDEFINED (A-Z) SAVE INTEGER *4 NMAX PARAMETER ( NMAX = 15000 ) INCLUDE 'VPLOT.INC' INTEGER *4 ICHAN, SPTR, BPTR, ISTAR, IBASE INTEGER *4 IOK(NMAX), REC(NMAX), IS(NMAX), NPTS INTEGER *4 I, J, IERR INTEGER *4 MASK(4) REAL *4 NPHOT(NMAX,4), V(NMAX,4), PHASE(NMAX,2), TIME(NMAX) CHARACTER *12 ASCFILE C********************************************************************** DATA MASK / 1, 2, 4, 8 / C---------------------------------------------------------------------- WRITE(6,*) ' PEXPRT. Exports point data to ASCII file. ' 40 WRITE (6,*) ' Star number to export (def=1st observed star): ' READ (5,'(I5)') J IF (J.EQ.0) THEN SPTR = 1 ISTAR = SLIST(1) GO TO 60 ELSE DO 50 I = 1, NSTAR IF ( J .EQ. SLIST(I) ) THEN SPTR = I ISTAR = J GOTO 60 END IF 50 CONTINUE END IF WRITE (6,*) ' Star is not in star list! ' GO TO 40 C Read pointer to baseline in baseline list 60 CONTINUE IF ( NBASE .EQ. 1 ) THEN WRITE(6,*) ' ONLY ONE BASELINE IN DATA SET ' BPTR = 1 ELSE WRITE (6,*) ' Sequential baseline number to edit (def=1): ' READ (5,'(I1)') BPTR IF (BPTR.EQ.0) BPTR=1 IF (BPTR .GT.NBASE) THEN WRITE (6,*) ' Sorry. Only ',NBASE, $ ' baselines in data set.' GO TO 60 END IF END IF IBASE = BLIST(BPTR) C C Get output file and open 80 CONTINUE WRITE (6,'(A,I4.4,A)') ' File name for ASCII data (def = ', $ ISTAR, '.DAT): ' READ (5,'(A)',ERR=80) ASCFILE IF (ASCFILE.EQ.'' .OR. ASCFILE(1:1).EQ.' ') THEN WRITE (ASCFILE, '(I4.4,A4,4X)') ISTAR, '.DAT' END IF OPEN (UNIT=7,FILE=ASCFILE,STATUS='UNKNOWN',IOSTAT=IERR ) IF (IERR .NE. 0 ) THEN WRITE(6,*) ' Cannot open file named ',ASCFILE,' Try again.' GO TO 80 END IF C C Get data for this star/baseline ISTAR = SLIST(SPTR) IBASE = BLIST(BPTR) CALL GETSTAR ( ISTAR, IBASE, NPTS, NMAX, NPHOT,IS, $ TIME, PHASE, V, REC, IOK ) C C change deleted points to -1 and write out data with mask WRITE (7,1002) DO 150 I = 1, NPTS IF (PHASE(I,1).GT.PHIMAX .OR. PHASE(I,1).LT.PHIMIN) $ IOK(I) = IOK(I) + 16 WRITE (7,1001) I, TIME(I), IOK(I), PHASE(I,1), (V(I,J), $ NPHOT(I,J), J=1,4) 150 CONTINUE 1001 FORMAT (I4, F10.6, I4, F9.5, 4(F8.4,F8.2)) 1002 FORMAT (' # UT Hours Flg Phase Vis(1) Phot(1) ', $ 'Vis(2) Phot(2) Vis(3) Phot(3) Vis(4) Phot(4)') RETURN END