C
C Program PICTURES to draw lines and points C C Program PICTURES is designed to draw texts and 2-D projections of C 3-D lines and points. The drawing is controled with control data. C The form of the file containing control data and the form of the C files containing the data to be drawn is described below. C C The program is coded in the ANSI X3.9-1978 Fortran77 standard language C employing the ANSI X3.124-1985 GKS (Graphical Kernel System) level 2b C subroutines. C C Version: 5.40 C Date: 2000, February 10 C C Coded by Jana Konopaskova, 1993, September 25 C Revised by Ludek Klimes C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: klimes@seis.karlov.mff.cuni.cz C C....................................................................... C C Program PICTURES has originally been designed to be linked with the C CALCOMP-GKS interface 'calcomp.for' and with GKS graphics library for C a particular computer system. However, the program is recently used C with the CALCOMP-PostScript interface 'calcops.for' supplemented with C simple interface 'gksps.for' from GKS to PostScript. Note that C 'gksps.for' contains just GKS routines called by program PICTURES and C mostly exploits subroutines of 'calcops.for'. Moreover, the current C version of 'gksps.for' does not support most of GKS text attributes C used by program PICTURES and should be finished and debugged in the C future. C C calcomp.for C calcops.for C gksps.for C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C PICDAT='string'... Name of the input file to control plotting. C Description of file PICDAT C No default, obligatory parameter. C Data specifying the form of the output file: C PICTURE='string'... String containing the name of the output C PostScript file with the plotted picture. C Default: PICTURE='picture.ps' C C C Data to control plotting 2-D projections of 3-D lines and points, C including corresponding descriptive texts: C The control file is a sequence of four sets of formated records. C Each set can be repeated to change the projection or plotting C attributes for the subsequent lines or points. C The form of the sets is as follows: C (1) Projection matrix: C The set of two records (1.1) and (1.2) determining the projection C matrix: C (1.1) 'PROJECTION' C The above string identifies this section. C (1.2) PM(1) PM(2) PM(3) PM(4) PM(5) PM(6) PM(7) PM(8) / C here PM(1) to PM(8) are real numbers determining C projection matrix, which transforms coordinates X1,X2,X3 C to 2-D plot coordinates Y1,Y2: C Y1 = PM(1) + PM(3)*X1 + PM(5)*X2 + PM(7)*X3 C Y2 = PM(2) + PM(4)*X1 + PM(6)*X2 + PM(8)*X3 C Note: In future versions these line may be replaced by, e.g., C (1.1) 'PROJECTION' C (1.2) C10,C11,C12,C13 C (1.3) C20,C21,C22,C23 C Transformation matrix from model coordinates X1,X2,X3 to C 2-D plot coordinates C1,C2: C C1 = C10 + C11*X1 + C12*X2 + C13*X3 C C2 = C20 + C21*X1 + C22*X2 + C23*X3 C (2) Graphic attributes: C The set of records determining the attributes for drawing (see C also the GKS documentation). Only the first and the last records C are compulsory. C Each string represents the name of the attribute parameter. C The parameters not listed in the control data file take the C default values. C We use notation R1,R2,...for real constants and I1,I2,...for C integer constants: (attention: the slashes at the end of records C are important) C 'ATTRIBUTES' C The above string identifies this section. C 'INIT' / All attributes are inicialized to their defaults C (subroutine DFLTAT). C 'ILC' I1 / Determines whether the lines are to be drawn C (0-no, 1-yes). C Default: 1 C 'IPC' I1 / Determines whether the points are to be drawn C (0-no, 1-yes). C Default: 1 C 'ITC' I1 / Determines whether the texts are to be drawn: C 0: No texts are drawn. C 1: Texts describing points and texts describing C lines with specified reference points are C drawn. C 2: All texts except those describing empty lines C without specified reference points are drawn. C 3: All texts are drawn. C Default: 1 C 'LCOLI' I1 / Color index determining the color of lines . C Default: 1 C 'PCOLI' I1 / Color index determining the color of points. C Default: 1 C 'TCOLI' I1 / Color index determining the color of texts. C Default: 1 C 'LTYPE' I1 / Determines linetype: C 1: solid, C 2: dashed, C 3: dotted, C 4: dashed-dotted line. C Default: 1 C 'LWIDTH' R1 / Relative linewidth scale factor. C In PostScript (interface 'gksps.for'), thickness C of lines in points (1/72 in). C Default: 1.0 C 'MTYPE' I1 / Determines marker type: C 1: '.', C 2: '+', C 3: '*', C 4: 'o', C 5: 'x'. C Default: 3 C 'MSZSF' R1 / Marker size scale factor. C In PostScript (interface 'gksps.for'), marker C size in dekapoints (1dpt=1in/72=3.537777mm). C Default: 1.0 C 'CHH' R1 / Character height. C In PostScript (interface 'gksps.for'), character C height in dekapoints (1dpt=1in/72=3.537777mm). C Default: 1.0 C 'CHXP' R1 / Character expansion factor. C Default: 1.0 C 'CHSP' R1 / Character spacing. C Default: 0.0 C 'CHUP' R1 R2 / Character up vector. C Default: 0.0 1.0 C 'TXAL' I1 I2 / Text alignment. C Default: 0 0 C 'FP' I1 I2 / Font and text precision: C Text precision: C 0: string, C 1: char, C 2: stroke. C Default font: 1 C Default text precision: 0 C 'TXP' I1 / Determines text path. C Default: 0 C / List of attributes must be terminated by a C slash. C (3) Instruction to plot lines: C According to the attributes currently set, whole lines, points of C lines or texts at the reference pints of lines may be drawn. C Records (3.1) and (3.2) determine the lines to be drawn: C (3.1) 'LINES' C The above string identifies this section. C (3.2) 'NFILE' C 'NFILE'... Name of the input data file containing 3-D C lines to be plotted according to the attributes currently C set. C If 'NFILE'=' ' or is replaced by a slash, the data C describing the lines are included immediately after line C (3.2). C The data representing lines should have form C LINES (or briefly LIN). C Default: 'NFILE'=' '. C (4) Instruction to plot points: C According to the attributes currently set, points or texts C describing the points may be drawn. C Records (4.1) and (4.2) determine the points to be drawn: C (4.1) 'POINTS' C The above string identifies this section. C (4.2) 'NFILE' C 'NFILE'... Name of the input data file containing 3-D C points to be plotted according to the attributes currently C set. C If 'NFILE'=' ' or is replaced by a slash, the data C describing the points are included immediately after line C (4.2). C The data representing lines should have form C POINTS (or briefly PTS). C Default: 'NFILE'=' '. C C....................................................................... C C This file contains following routines: C Program PICTURES C Subroutine PAINT C Subroutine SCAN C Subroutine ATTRIB C Subroutine DFLTAT C Except above routines, program PICTURES requires CALCOMP plotting C routines and GKS (Graphical Kernel System) subroutines. C GKS must be installed before the program PICTURES can be C executed. C C======================================================================= C C Program PICTURES to draw texts and 2-D projection of 3-D points and C lines. C C----------------------------------------------------------------------- EXTERNAL ERROR,RSEP1,RSEP3T,PLOTN,PLOTS,PLOT,PAINT,SCAN C----------------------------------------------------------------------- REAL LX(1000), LY(1000), PX(100), PY(100) DIMENSION ICOL(100), WDTH(100) CHARACTER INDATA*80,FSEP*80,FILPS*80 C----------------------------------------------------------------------- LDIM=1000 NDIM=100 MDIM=100 C C Reading main input data: WRITE(*,'(A)') '+PICTURES: Enter input filename: ' FSEP=' ' READ (*,*) FSEP IF(FSEP.EQ.' ') THEN C PICTURES-01 CALL ERROR('PICTURES-01: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF WRITE(*,'(A)') '+PICTURES: Working... ' C C Reading input and output filenames: CALL RSEP1(LU1,FSEP) CALL RSEP3T('PICDAT',INDATA,' ') IF(INDATA.EQ.' ') THEN C PICTURES-02 CALL ERROR('PICTURES-02: No input file specified') C Input file with the description of the picture must be specified C by parameter PICDAT. C There is no default filename. END IF CALL RSEP3T('PICTURE',FILPS,'picture.ps') C CALL SCAN (INDATA,ICOL,WDTH,MDIM,NUM,IERR) IF(IERR.NE.0) THEN IF(IERR.EQ.-1) THEN WRITE (*,240) INDATA GO TO 100 END IF IF (IERR.EQ.-2) WRITE (*,250) INDATA IF (IERR.EQ.-4) WRITE (*,260) IF (IERR.EQ.-5) WRITE (*,270) GO TO 100 END IF CALL PLOTN(FILPS,0) CALL PLOTS(0,0,0) DO 40 I=1,NUM CALL PAINT(INDATA,ICOL(I),WDTH(I),PX,PY,NDIM,LX,LY,LDIM,IERR) IF (IERR.NE.0) THEN IF (IERR.EQ.-1 .OR. IERR.EQ.-2) WRITE(*,275) IF (IERR.EQ.-3) WRITE(*,280) IF (IERR.EQ.-4) WRITE(*,260) IF (IERR.GT.0) WRITE (*,285) GO TO 100 END IF 40 CONTINUE CALL PLOT (0.,0.,999) WRITE(*,'(A)') '+PICTURES: Done. ' 100 STOP C 230 FORMAT(/' A reading error occurred, try again.') 240 FORMAT(/' *****************************************', + /' * The file ',A12, ' cannot be found.*' + /' *****************************************') 250 FORMAT(/' ******************************************************** +' /' * An error occurred when reading the file ', A12,'.* +' /' * Maybe the syntax of that file is wrong. * +' /' ********************************************************') 260 FORMAT(/' *****************************************************' + /' * An error occurred during reading the objects that *' + /' * should be drawn. Maybe the syntax of the file *' + /' * containing that objects is wrong. *' + /' *****************************************************') 270 FORMAT(/' *****************************************************' + /' * The dimension of some arrays in the program *' + /' * PICTURES is not sufficient. It is necessarry *' + /' * to increase the dimension of the arrays ICOL and *' + /' * WDTH to a certain value and to assign the same *' + /' * value to the variable MDIM (see the source code *' + /' * pictures.for) *' + /' *****************************************************') 275 FORMAT(/' A problem occurred while accessing the file containing' + /' control data. Maybe your disk is not all right.') 280 FORMAT(/' ***********************************************' + /' * The file containing the objects that should *' + /' * be drawn cannot be found. *' + /' ***********************************************') 285 FORMAT(/' ******************************************************** +' /' * Some objects or their partitions could not be drawn * +' /' * because of insufficient dimension of some arrays in * +' /' * the program PICTURES. It is necessarry to increase * +' /' * the dimension of the arrays LX,LY (resp. PX,PY) to * +' /' * a certain value and to assign the same value to the * +' /' * variable LDIM (resp. NDIM) (see the source code * +' /' * pictures.for * +' /' ********************************************************') C END C C======================================================================= C C C SUBROUTINE PAINT (INDATA,ICOLOR,WIDTH,PX,PY,NDIM,LX,LY,LDIM,IERR) C C Subroutine PAINT is designed to draw texts and 2-D projections of 3-D C points and lines. C C Input: C INDATA..The name of the file containing control data. C (character*12) C ICOLOR..Color index. Only objects with color index equal to C ICOLOR will be drawn. (integer) C WIDTH...Linewidth. Only lines with linewidth equal to WIDTH will C be drawn. (real) C NDIM... Dimension of auxiliary arrays PX, PY (integer) C LDIM... Dimension of auxiliary arrays LX, LY (integer) C C Output: C IERR... Error parameter (integer) C IERR=0: No errors occurred C IERR=-1: It was not possible to open the file indata C IERR=-2: An error occurred while reading the file C containing control data. C IERR=-3: It was not possible to open the file containing C data that should be drawn. C IERR=-4: An error occurred while reading the file C containing data that should be drawn. C IERR.GT.0: Insufficient either the dimension ndim or the C dimension LDIM. Some objects or their parts C cannot be drawn. C Auxiliary arrays: C PX,PY...Arrays used for the storage of the projection of points. C These arrays are used only when points are stored in the C file containing lines. (real) C LX,LY...Arrays used for the storage of the projection of points C determining a line or for the storage of the projection C of points. (real) C C Parameters in common block /DEFLT/: C These parameters are inicialized at the beginning of subroutine C paint through subroutine dfltat. All parameters in common block C except LUIN, LUDATA and EPS can be changed by the help of the file C containing control data. C PM... Array containing the projection matrix. (real) C LUIN... Logical unit specifier used for the access to control C data. (integer) C LUDAT...Logical unit specifier used for the access to the data to C be drawn. (integer) C ITC,IPC,ILC... Determine whether it is required to draw texts, C points and lines, respectively (0 - drawing is not C required, positive - drawing is required). (integer) C TCOLI,PCOLI,LCOLI...Color indices determining the color of texts, C points and lines, respectively (for details see the C documentation to the graphics system GKS). (integer) C LWIDTH..Relative linewidth (real) C EPS... A little real number. Lines will be drawn when C ABS(LWIDTH-WIDTH) is less than EPS. C C Subroutines required: DFLTAT, ATTRIB, GKS subroutines C C GKS requirements: C GKS must be installed and workstation(s) prepared C (see the documentation to GKS) so that immediate calling of GKS C output functions is possible. C C----------------------------------------------------------------------- C LOGICAL PR,AT,PO,LI CHARACTER INDATA*12,NFILE*12,CNTR*2,W,ST*80 INTEGER TCOLI,LCOLI,PCOLI REAL LWIDTH,PM(8),LX(*),LY(*),PX(*),PY(*) COMMON/DEFLT/ PM,LUIN,LUDAT,ITC,IPC,ILC,TCOLI,PCOLI,LCOLI,LWIDTH, + EPS C C----------------------------------------------------------------------- C IERR=0 RMAX=3.402823E+38 RC=3.40282E+38 CALL DFLTAT(-1) C ------------------------------------------------------------------ OPEN (LUIN,ERR=190,FILE=INDATA,STATUS='OLD') 1 CNTR='@@' READ (LUIN,*,END=200,ERR=180) CNTR IF (CNTR.EQ.'@@') GO TO 200 PR=CNTR.EQ.'PR' .OR. CNTR.EQ.'pr' AT=CNTR.EQ.'AT' .OR. CNTR.EQ.'at' PO=CNTR.EQ.'PO' .OR. CNTR.EQ.'po' LI=CNTR.EQ.'LI' .OR. CNTR.EQ.'li' IF(.NOT.PR .AND. .NOT.AT .AND. .NOT.PO .AND. .NOT.LI) GO TO 180 C ------------------------------------------------------------------ IF(PR) READ (LUIN,*,ERR=180)PM C ------------------------------------------------------------------ IF(AT) THEN CALL ATTRIB(1,IERR) IF (IERR.EQ.-1) GO TO 180 END IF C ------------------------------------------------------------------ IF (PO.OR.LI) THEN IT=0 IP=0 IL=0 IF(ITC.GE.1 .AND. TCOLI.EQ.ICOLOR) IT=ITC IF(IPC.GE.1 .AND. PCOLI.EQ.ICOLOR) IP=1 DIF=ABS(LWIDTH-WIDTH) IF(ILC.EQ.1 .AND. LCOLI.EQ.ICOLOR .AND. DIF.LT.EPS) IL=1 NFILE='EMPTY ' READ (LUIN,*,ERR=180) NFILE LU=LUIN IF (NFILE.NE.'EMPTY ')THEN IF(IT.EQ.0 .AND. IP.EQ.0 .AND. IL.EQ.0) GO TO 1 OPEN (LUDAT,ERR=170,FILE=NFILE,STATUS='OLD') LU=LUDAT END IF 10 W='@' READ(LU,*,ERR=195) W IF(W.NE.'@') GO TO 10 END IF C ------------------------------------------------------------------ IF (PO) THEN IND=0 20 CONTINUE X1=0. X2=0. X3=0. ST='$' READ(LU,*,END=50,ERR=195) ST,X1,X2,X3 IF (ST.EQ.'$') THEN GO TO 50 END IF IF (IND.EQ.LDIM) THEN IERR=IERR+1 25 CONTINUE ST='$' READ (LU,*,END=50,ERR=195) ST,X1,X2,X3 IF (ST.EQ.'$') THEN GO TO 50 END IF GO TO 25 END IF IND=IND+1 LX(IND)=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 LY(IND)=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 IF (IT.GE.1) THEN N=80 DO 30 I=80,2,-1 IF(ST(I:I).NE.' ') GO TO 40 N=N-1 30 CONTINUE 40 CALL GTX (LX(IND),LY(IND),ST(1:N)) END IF GO TO 20 50 IF (IP.EQ.1) CALL GPM(IND,LX,LY) IF (LU.NE.LUIN) REWIND(LU) END IF C ------------------------------------------------------------------ IF (LI) THEN INDP=0 70 INDL=2 Y1=RMAX Y2=0. Y3=0. ST='$' READ(LU,*,END=1,ERR=195) ST,Y1,Y2,Y3 IF (ST.EQ.'$')THEN IF (IP.EQ.1 .AND. INDP.GT.0) CALL GPM (INDP,PX,PY) IF (LU.NE.LUIN) REWIND(LU) GO TO 1 END IF C X1=RMAX X2=0. X3=0. READ (LU,*,END=70,ERR=195) X1,X2,X3 IF (IT.GE.1) THEN N=80 DO 75 I=80,2,-1 IF (ST(I:I).NE.' ') GO TO 78 N=N-1 75 CONTINUE 78 CONTINUE IF (Y1.LE.RC) THEN P1=PM(1)+PM(3)*Y1+PM(5)*Y2+PM(7)*Y3 P2=PM(2)+PM(4)*Y1+PM(6)*Y2+PM(8)*Y3 CALL GTX (P1,P2,ST(1:N)) ELSE IF (X1.LE.RC.AND.IT.GE.2) THEN P1=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 P2=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 CALL GTX (P1,P2,ST(1:N)) ELSE IF (IT.GE.3) THEN P1=PM(1) P2=PM(2) CALL GTX (P1,P2,ST(1:N)) END IF END IF IF (X1.GT.RC) GO TO 70 C Y1=RMAX Y2=0. Y3=0. READ (LU,*,END=70,ERR=195) Y1,Y2,Y3 IF (Y1.GT.RC) THEN IF (INDP.LT.NDIM) THEN INDP=INDP+1 PX(INDP)=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 PY(INDP)=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 ELSE IERR=IERR+1 END IF GO TO 70 END IF LX(1)=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 LY(1)=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 LX(2)=PM(1)+PM(3)*Y1+PM(5)*Y2+PM(7)*Y3 LY(2)=PM(2)+PM(4)*Y1+PM(6)*Y2+PM(8)*Y3 80 CONTINUE X1=RMAX X2=0. X3=0. READ(LU,*,END=70,ERR=195) X1,X2,X3 IF (X1.GT.RC) THEN IF(IL.EQ.1) CALL GPL(INDL,LX,LY) GO TO 70 END IF IF (INDL.EQ.LDIM) THEN IERR=IERR+1 90 X1=RMAX READ(LU,*,END=70,ERR=195) X1,X2,X3 IF (X1.LE.RC) GO TO 90 IF (IL.EQ.1) CALL GPL(INDL,LX,LY) GO TO 70 END IF INDL=INDL+1 LX(INDL)=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 LY(INDL)=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 GO TO 80 END IF C ------------------------------------------------------------------ GO TO 1 170 IERR=-3 GO TO 200 180 IERR=-2 GO TO 200 190 IERR=-1 RETURN 195 IERR=-4 200 REWIND(LUIN) RETURN C END C C======================================================================= C C C SUBROUTINE SCAN (INDATA,ICOL,WDTH,NDIM,NUM,IERR) C C Subroutine SCAN is designed to look over the file containing control C data for drawing 2-D projection of 3-D points and lines and to C determine which colors and linewidths are required for drawing the C data. C C Input: C INDATA..The name of the file containing control data C (character*12) C NDIM... Dimension of output arrays ICOL and WDTH (integer) C C Output: C ICOL... Array containing color indexes representing colors C required for drawing the data (integer) C WDTH... Array containing linewidths. A linewidth in any array C element WDTH(I) corresponds to color index ICOL(I). It is C possible to have WDTH(I) less than zero. In such case the C linewidth corresponding to color index ICOL(I) is C arbitrary. (real) C NUM... The number of color indexes (resp. linewidths) stored in C array ICOL (resp. WDTH) (integer) C IERR... Error indicator (integer) C IERR=0: No errors occurred C IERR=-1: It was not possible to open the file indata C IERR=-2: An error occurred while reading the file C containing control data. C IERR=-4: An error occurred while reading the file C containing data that should be drawn. C IERR=-5: The dimension NDIM of the arrays ICOL and WDTH is C not sufficiet. C C Parameters in common block /DEFLT/: C These parameters are inicialized at the beginning of subroutine C scan through subroutine DFLTAT. All parameters in common block C except LUIN, LUDATA and EPS can be changed by the help of the file C containing control data. C PM... Array containing the projection matrix. C LUIN... Logical unit specifier used for the access to control C data. (integer) C LUDAT.. Logical unit specifier used for the access to the data to C be drawn. (integer) C ITC,IPC,ILC... Determine whether it is required to draw texts, C points and lines, respectively (0 - drawing is not C required, positive - drawing is required). (integer) C TCOLI,PCOLI,LCOLI...Color indexes determining the color of texts, C points and lines respectively (for details see the C documentation to the graphics system GKS). (integer) C LWIDTH..Linewidth (real) C EPS... A little real number. Lines will be drawn when C ABS(LWIDTH-WIDTH) is less than EPS. C C Subroutines required: DFLTAT, ATTRIB C C----------------------------------------------------------------------- C INTEGER TCOLI,LCOLI,PCOLI,ICOL(*) REAL LWIDTH,PM(8),WDTH(*) CHARACTER INDATA*12,NFILE*12,CNTR*2,W LOGICAL PR,AT,PO,LI COMMON/DEFLT/ PM,LUIN,LUDAT,ITC,IPC,ILC,TCOLI,PCOLI,LCOLI,LWIDTH, + EPS C C----------------------------------------------------------------------- C IERR=0 RMAX=3.402823E+38 RC=3.40282E+38 CALL DFLTAT(-2) NUM=0 C ------------------------------------------------------------------ OPEN (LUIN,ERR=170,FILE=INDATA,STATUS='OLD') 10 CNTR='@@' READ (LUIN,*,END=200,ERR=180) CNTR IF (CNTR.EQ.'@@') GO TO 200 PR=CNTR.EQ.'PR' .OR. CNTR.EQ.'pr' AT=CNTR.EQ.'AT' .OR. CNTR.EQ.'at' PO=CNTR.EQ.'PO' .OR. CNTR.EQ.'po' LI=CNTR.EQ.'LI' .OR. CNTR.EQ.'li' IF (.NOT.PR .AND. .NOT.AT .AND. .NOT.PO .AND. .NOT.LI) GO TO 180 C ------------------------------------------------------------------ IF (PR) READ (LUIN,*,ERR=180) PM C ------------------------------------------------------------------ IF(AT) THEN CALL ATTRIB(0,IERR) IF (IERR.EQ.-1) GO TO 180 END IF C ------------------------------------------------------------------ IF (PO.OR.LI) THEN NFILE='EMPTY ' READ (LUIN,*,ERR=180) NFILE IF (NFILE.EQ.'EMPTY ') THEN 30 W='@' READ (LUIN,*,ERR=185) W IF (W.NE.'@') GO TO 30 END IF IF (ITC.EQ.0) GO TO 60 IF (NUM.EQ.0) GO TO 50 DO 40 I=1,NUM IF (ICOL(I).EQ.TCOLI) GO TO 60 40 CONTINUE 50 NUM=NUM+1 IF (NUM.GT.NDIM) GO TO 190 ICOL(NUM)=TCOLI WDTH(NUM)=-1.0 60 CONTINUE IF (IPC.EQ.0) GO TO 90 IF (NUM.EQ.0) GO TO 80 DO 70 I=1,NUM IF (ICOL(I).EQ.PCOLI) GO TO 90 70 CONTINUE 80 NUM=NUM+1 IF (NUM.GT.NDIM) GO TO 190 ICOL(NUM)=PCOLI WDTH(NUM)=-1.0 90 CONTINUE END IF C ------------------------------------------------------------------ IF (PO .AND. NFILE.EQ.'EMPTY ') THEN 100 X1=RMAX READ (LUIN,*,END=100,ERR=185) W,X1,X2,X3 IF (X1.LE.RC) GO TO 100 END IF C ------------------------------------------------------------------ IF (LI) THEN IF (ILC.EQ.0) GO TO 130 IF (NUM.EQ.0) GO TO 120 DO 110 I=1,NUM IF (ICOL(I).EQ.LCOLI) THEN IF (ABS(WDTH(I)-LWIDTH).LT.EPS)GO TO 130 IF (WDTH(I).GE.0.0) GO TO 110 WDTH(I)=LWIDTH GO TO 130 END IF 110 CONTINUE 120 NUM=NUM+1 IF (NUM.GT.NDIM) GO TO 190 ICOL(NUM)=LCOLI WDTH(NUM)=LWIDTH 130 CONTINUE IF (NFILE.EQ.'EMPTY ') THEN 140 X1=RMAX X2=0. X3=0. READ (LUIN,*,END=10,ERR=185) W,X1,X2,X3 IF (X1.GT.RC) GO TO 10 150 X1=RMAX READ (LUIN,*,END=140,ERR=185) X1,X2,X3 IF (X1.GT.RC) GO TO 140 GO TO 150 END IF END IF C ------------------------------------------------------------------ GO TO 10 170 IERR=-1 RETURN 180 IERR=-2 GO TO 200 185 IERR=-4 GO TO 200 190 IERR=-5 200 REWIND (LUIN) RETURN C END C C======================================================================= C C C SUBROUTINE ATTRIB (ICONTR,IERR) C C Subroutine ATTRIB is designed to read some attributes from the C file containing control data for drawing 2-D projections of 3-D C points and lines and to set up GKS according to the attributes. C C Input: C ICONTR..Control parameter (integer) C ICONTR=0: Attributes are red but GKS is not set up C according to them. C ICONTR=1: Attributes are read and GKS is set up. C C Output: C IERR... Error parameter (integer) C IERR=0: No errors occurred. C IERR=-1: Error occurred while reading the file containing C control data. C C Subroutines required: C subroutine DFLTAT C subroutines of GKS C C----------------------------------------------------------------------- C INTEGER TCOLI,PCOLI REAL LWIDTH,PM(8) CHARACTER AT*6 COMMON/DEFLT/ PM,LUIN,LUDAT,ITC,IPC,ILC,TCOLI,PCOLI,LCOLI,LWIDTH, + EPS C C----------------------------------------------------------------------- C 10 AT='@@@@@@' PAR2=0.0 READ (LUIN,*,ERR=30)AT,PAR1,PAR2 IF(AT.EQ.'@@@@@@') GO TO 50 IPAR1=NINT(PAR1) IPAR2=NINT(PAR2) IF (ICONTR.EQ.0) GO TO 20 IF (AT.EQ.'CHH ' .OR. AT.EQ.'chh ') CALL GSCHH(PAR1) IF (AT.EQ.'CHXP ' .OR. AT.EQ.'chxp ') CALL GSCHXP(PAR1) IF (AT.EQ.'CHSP ' .OR. AT.EQ.'chsp ') CALL GSCHSP(PAR1) IF (AT.EQ.'CHUP ' .OR. AT.EQ.'chup ') CALL GSCHUP(PAR1,PAR2) IF (AT.EQ.'TXAL ' .OR. AT.EQ.'txal ') CALL GSTXAL(IPAR1,IPAR2) IF (AT.EQ.'FP ' .OR. AT.EQ.'fp ') CALL GSTXFP(IPAR1,IPAR2) IF (AT.EQ.'TXP ' .OR. AT.EQ.'txp ') CALL GSTXP(IPAR1) IF (AT.EQ.'LTYPE ' .OR. AT.EQ.'ltype ') CALL GSLN(IPAR1) IF (AT.EQ.'MTYPE ' .OR. AT.EQ.'mtype ') CALL GSMK(IPAR1) IF (AT.EQ.'MSZSF ' .OR. AT.EQ.'mszsf ') CALL GSMKSC(PAR1) 20 IF (AT.EQ.'ITC ' .OR. AT.EQ.'itc ') ITC=IPAR1 IF (AT.EQ.'IPC ' .OR. AT.EQ.'ipc ') IPC=IPAR1 IF (AT.EQ.'ILC ' .OR. AT.EQ.'ilc ') ILC=IPAR1 IF (AT.EQ.'INIT ' .OR. AT.EQ.'init ') CALL DFLTAT(ICONTR) IF (AT.EQ.'TCOLI ' .OR. AT.EQ.'tcoli ') THEN IF (ICONTR.NE.0) CALL GSTXCI(IPAR1) TCOLI=IPAR1 END IF IF (AT.EQ.'LWIDTH' .OR. AT.EQ.'lwidth') THEN IF (ICONTR.NE.0) CALL GSLWSC(PAR1) LWIDTH=PAR1 END IF IF (AT.EQ.'LCOLI ' .OR. AT.EQ.'lcoli ') THEN IF (ICONTR.NE.0) CALL GSPLCI(IPAR1) LCOLI=IPAR1 END IF IF (AT.EQ.'PCOLI ' .OR. AT.EQ.'pcoli ') THEN IF (ICONTR.NE.0) CALL GSPMCI(IPAR1) PCOLI=IPAR1 END IF GO TO 10 C ------------------------------------------------------------------ 30 IERR=-1 50 RETURN C END C C======================================================================= C C C SUBROUTINE DFLTAT(ICONTR) C C Subroutine DFLTAT is designed to initialize some parameters. C This subroutine serves to subroutines PAINT and SCAN. C C Input: C ICONTR...Control parameter (integer) C ICONTR=0: Only the parameters TCOLI,LWIDTH LCOLI,PCOLI, C ITC,IPC,ILC are initialized C ICONTR=-2: As ICONTR=0 but in addition LUIN,LUDAT,EPS C and projection matrix PM are initialized C ICONTR=-1: As ICONTR=-2 but in addition GKS is set up C according to initial attributes C ICONTR=1: As ICONTR=0 but in addition GKS is set up C according to initial attributes C C Subroutines required: Subroutines of system GKS C C----------------------------------------------------------------------- C INTEGER TXALH,TXALV,TCOLI,FONT,PREC,TXP,PCOLI REAL LWIDTH,MSZSF,PM(8) COMMON/DEFLT/ PM,LUIN,LUDAT,ITC,IPC,ILC,TCOLI,PCOLI,LCOLI,LWIDTH, + EPS C C----------------------------------------------------------------------- C IF (ICONTR.NE.-1 .AND. ICONTR.NE.-2) GO TO 5 PM(1)=0.0 PM(2)=0.0 PM(3)=1.0 PM(4)=0.0 PM(5)=0.0 PM(6)=1.0 PM(7)=0.0 PM(8)=0.0 LUIN=1 LUDAT=2 EPS=0.001 5 TCOLI=1 LWIDTH=1.0 LCOLI=1 PCOLI=1 ITC=1 IPC=1 ILC=1 IF (ICONTR.EQ.0 .OR. ICONTR.EQ.-2) GO TO 10 CHH=1.0 CHXP=1.0 CHSP=0.0 CHUX=0.0 CHUY=1.0 TXALH=0 TXALV=0 FONT=1 PREC=0 TXP=0 LTYPE=1 MTYPE=3 MSZSF=1.0 CALL GSCHH(CHH) CALL GSCHXP(CHXP) CALL GSCHSP(CHSP) CALL GSCHUP(CHUX,CHUY) CALL GSTXAL(TXALH,TXALV) CALL GSTXCI(TCOLI) CALL GSTXFP(FONT,PREC) CALL GSTXP(TXP) CALL GSLN(LTYPE) CALL GSLWSC(LWIDTH) CALL GSPLCI(LCOLI) CALL GSMK(MTYPE) CALL GSMKSC(MSZSF) CALL GSPMCI(PCOLI) 10 RETURN C END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for INCLUDE 'calcops.for' C calcops.for INCLUDE 'gksps.for' C gksps.for C C======================================================================= C