!+++++++++++++++++++++++++++++++++++++++++++++++++++++++
!.IDENTIFICATION: pltab.prg
!.PURPOSE: MIDAS proceduce to plot one or two columns of a table
!.USE: execute as @@ pltab par1 [par2 [par3]] [par4] where:
! par1 = input table
! par2 = column 1
! par3 = column 2
! par4 = sc_x,sc_y,off_x,off_y (defaults device filling)
!.AUTHOR: R.H. Warmels ESO - Garching
!.VERSION: 931103 RHW Created for environment document
! ----------------------------------------------------------------------
DEFINE/PARAM P1 ? TABLE "Enter table:"
!
IF P2(1:1) .EQ. "?" THEN
DEFINE/PARAM P3 ? C "Enter input for the ordinate column:"
IF P3(1:3) .EQ. "SEQ" THEN
WRITE/OUT "*** FATAL: Illegal combination of column parameters"
RETURN
ENDIF
ENDIF
!
IF P2(1:3) .EQ. "SEQ" THEN
DEFINE/PARAM P3 ? C "Enter input for the ordinate column:"
IF P3(1:3) .EQ. "SEQ" THEN
WRITE/OUT "*** FATAL: Illegal combination of column parameters"
RETURN
ENDIF
ENDIF
!
WRITE/KEYWORD IN_A {P1}
!
RUN pltab.exe
WRITE/KEYWORD PLCDATA/C/1/60 {P1}
WRITE/KEYWORD PLCDATA/C/61/20 "TABLE "
!
@ purgeplt {P1}
IF MID$PLOT(26:30) .EQ. "SPOOL" THEN !make the plot if spool is on
@ sendplot
ENDIF
To run the application execute the procedure via:
Midas 001> @@ pltab table column_1 column_2
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C all rights reserved
C.IDENTIFICATION: PLTAB
C.LANGUAGE: F77+ESOext
C.AUTHOR: Rein H. Warmels
C.PURPOSE: Plots two columns of a table
C.NOTE: PLOTTBL uses the plotting routines available in the plot
C library which again uses the low level AGL routines.
C.VERSION: 931103 RHW Created for the environment document
C ---------------------------------------------------------------------
PROGRAM PLTTBL ! program PLTTBL *** main body ***
IMPLICIT NONE
C
INTEGER COL(3)
INTEGER I, IST, IAC, IL1, IL2
INTEGER KUN, KNUL
INTEGER ISTAT, PLMODE, ACCESS
INTEGER MADRID(1)
INTEGER NCOL, NSC, NAC, NAR
INTEGER NCOLUM,NCOL1,NCOL2,NROW
INTEGER TID
REAL FRAME(8)
REAL RMIN,RMAX
CHARACTER LABEL1*80,LABEL2*80,LABEL3*80
CHARACTER TEXT*80
CHARACTER*16 LABEL(3),UNIT(3),OLAB
CHARACTER TABLE*60,SEL*80
CHARACTER*17 COLUMN(3)
C
INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST'
COMMON /VMR/MADRID
INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST'
DATA SEL/' '/
DATA ACCESS/0/
C
9000 FORMAT (I4)
9001 FORMAT('*** WARNING: zero dynamics range in x; '//
2 'value = ',G13.6)
9002 FORMAT('*** WARNING: zero dynamics range in y; '//
2 'value = ',G13.6)
C
C *** start executable code
CALL STSPRO('PLOTTAB') !start comm. with MIDAS
C
C *** read parameters
CALL STKRDC('IN_A',1,1,60,IAC,TABLE,KUN,KNUL,ISTAT) ! get table name
C
C *** read columns
CALL STKRDC('P2',1,1,40,NCOL1,COLUMN(1),KUN,KNUL,ISTAT) ! first column
CALL STKRDC('P3',1,1,40,NCOL2,COLUMN(2),KUN,KNUL,ISTAT) ! second column
C
C *** this procedure read the table
CALL TBTOPN(TABLE,F_I_MODE,TID,ISTAT)
CALL TBIGET(TID,NCOL,NROW,NSC,NAC,NAR,ISTAT) ! read table information
C
IF (NROW.LE.0) THEN
CALL STTPUT('*** FATAL: No points in the table ... ',ISTAT)
CALL STSEPI
END IF
CALL TDRSEL(TID,SEL,ISTAT) ! table selection
C
C *** get column adresses
IST = 1
DO 10 I = 1,2
CALL TBCSER(TID,COLUMN(I),COL(I),ISTAT) ! find column no.
CALL TBLGET(TID,COL(I),LABEL(I),ISTAT)
C
CALL TBUGET(TID,COL(I),UNIT(I),ISTAT) ! read units
10 CONTINUE
C
C *** get the labeling of the axes; first the x-axis
OLAB = 'COLUMN '
IF (LABEL(1)(1:2).EQ.' ') THEN
WRITE (OLAB(7:10),9000) COL(1)
ELSE
OLAB = LABEL(1)
END IF
LABEL1 = OLAB
IL1= INDEX(LABEL1,' ')
IL2= INDEX(UNIT(1),' ')-1
LABEL1 = LABEL1(1:IL1)//'('//UNIT(1)(1:IL2)//')'
C
C *** the y axis
OLAB = 'COLUMN '
IF (LABEL(2)(1:2).EQ.' ') THEN
WRITE (OLAB(7:10),9000) COL(2)
ELSE
OLAB = LABEL(2)
END IF
LABEL2 = OLAB
IL1= INDEX(LABEL2,' ')
IL2= INDEX(UNIT(2),' ')-1
LABEL2 = LABEL2(1:IL1)//'('//UNIT(2)(1:IL2)//')'
C
C *** calculate frame
CALL TDUMNX(TID,COL(1),NROW,0,RMIN,RMAX)
IF (RMIN.EQ.RMAX) THEN
WRITE(TEXT,9001) RMIN
CALL STTPUT(TEXT,ISTAT)
ENDIF
FRAME(1) = RMIN
FRAME(2) = RMAX
CALL PTKWRR('XWNDL',4,FRAME(1))
CALL TDUMNX(TID,COL(2),NROW,0,RMIN,RMAX)
IF (RMIN.EQ.RMAX) THEN
WRITE(TEXT,9002) RMIN
CALL STTPUT(TEXT,ISTAT)
ENDIF
FRAME(5) = RMIN
FRAME(6) = RMAX
CALL PTKWRR('YWNDL',4,FRAME(5))
C
C *** get the plot setup
PLMODE = -1
CALL PTOPEN(' ',' ',ACCESS,PLMODE) ! access and plot mode
C
C *** make the frame, tickmarks, etc ...
LABEL3 = 'Table: '//TABLE
CALL PTAXES(FRAME(1),FRAME(5),LABEL1,LABEL2,'TITLE='//LABEL3)
C
C *** do the work
CALL PLTBL(TID,NCOLUM,COL(1),COL(2),NROW)
C
C *** good bye and finish
CALL TBTCLO(TID,ISTAT)
CALL PTCLOS()
CALL STSEPI ! stop communication with MIDAS
END
SUBROUTINE PLTBL(TID,NCOLUM,I1,I2,NROW)
C +++
C.PURPOSE: Plots one or two columns of a table
C.AUTHOR: Rein H. Warmels
C.COMMENTS: none
C.VERSION: 931103 RHW Createsd for environment document
C ---
IMPLICIT NONE
INTEGER TID ! Table identifier
INTEGER NCOLUM ! # of columns to be plotted
INTEGER I1 ! index to first column
INTEGER I2 ! index to second column
INTEGER NROW ! number of row
C
INTEGER NPMAX
PARAMETER (NPMAX=100000)
INTEGER IFIRST, I, ISTAT, IR, IAC
INTEGER STYPE, LTYPE
REAL VX, VY
REAL XPS(NPMAX), YPS(NPMAX)
LOGICAL IPLOT,ISEL,INULL
CHARACTER TEXT*80
C
9001 FORMAT('*** FATAL: Maximum number of table entries is ',I8)
C
IFIRST = 0
IR = 0
C
DO 10 I = 1,NROW
IPLOT = .TRUE.
CALL TBSGET(TID,I,ISEL,ISTAT)
IF (ISEL) THEN
CALL TBRRDR(TID,I,1,I1,VX,INULL,ISTAT)
IF (INULL) THEN
IPLOT = .FALSE.
ENDIF
C
CALL TBRRDR(TID,I,1,I2,VY,INULL,ISTAT)
IF (INULL) THEN
IPLOT = .FALSE.
ENDIF
IF (IPLOT) THEN
IR = IR + 1
IF (IR.GT.NPMAX) THEN
WRITE (TEXT,9001) NPMAX
CALL STTPUT(TEXT,ISTAT)
CALL STSEPI
ENDIF
XPS(IR) = VX
YPS(IR) = VY
ENDIF
ENDIF
10 CONTINUE
C
CALL PTKRDI('STYPE',1,IAC,STYPE)
CALL PTKRDI('LTYPE',1,IAC,LTYPE)
IF (LTYPE.EQ.0 .AND. STYPE.EQ.0) THEN
CALL STTPUT('*** FATAL: LTYPE and STYPE '//
2 'both equal 0: NO PLOT',ISTAT)
CALL PTCLOS()
CALL STSEPI
ELSE
CALL PTDATA(STYPE,LTYPE,0,XPS,YPS,0.0,IR)
ENDIF
C
C *** end of the plotting
RETURN
END