← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to prim/display/src/tloadtbl.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
prim/display/src/tloadtbl.for
 
1
C===========================================================================
 
2
C Copyright (C) 1995-2010 European Southern Observatory (ESO)
 
3
C
 
4
C This program is free software; you can redistribute it and/or
 
5
C modify it under the terms of the GNU General Public License as
 
6
C published by the Free Software Foundation; either version 2 of
 
7
C the License, or (at your option) any later version.
 
8
C
 
9
C This program is distributed in the hope that it will be useful,
 
10
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
12
C GNU General Public License for more details.
 
13
C
 
14
C You should have received a copy of the GNU General Public
 
15
C License along with this program; if not, write to the Free
 
16
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
 
17
C MA 02139, USA.
 
18
C
 
19
C Correspondence concerning ESO-MIDAS should be addressed as follows:
 
20
C       Internet e-mail: midas@eso.org
 
21
C       Postal address: European Southern Observatory
 
22
C                       Data Management Division
 
23
C                       Karl-Schwarzschild-Strasse 2
 
24
C                       D 85748 Garching bei Muenchen
 
25
C                       GERMANY
 
26
C===========================================================================
 
27
C
 
28
      PROGRAM TLOADTBL
 
29
C
 
30
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
31
C
 
32
C.LANGUAGE: F77+ESOext
 
33
C
 
34
C.AUTHOR: J.D.Ponz, K. Banse
 
35
C
 
36
C.IDENTIFICATION:
 
37
C  program TLOADTBL
 
38
C
 
39
C.KEYWORDS:
 
40
C  display, table subsystem
 
41
C
 
42
C.PURPOSE:
 
43
C  Display table positions in the overlay plane of the display window
 
44
C  rows with coordinates falling outside the displayed image are skipped
 
45
C  the no. of skipped rows is stored in OUTPUTI(11)
 
46
C 
 
47
C  INPUTI(20) serves as print flag:  99 = show skipped rows
 
48
C                                         and show coord conversion per row
 
49
C 
 
50
C  Execute the command
 
51
C
 
52
C  LOAD/TABLE table column1 column2 [column3] [symbol [size [level]]]
 
53
C
 
54
C.ALGORITHM:
 
55
C  plot table entries as : square    (0,2)
 
56
C                          circles     (1)
 
57
C                          triangle up (3), triangle down (4)
 
58
C                          cross       (5), open cross    (6)
 
59
C                          diamond     (7)
 
60
C                          X shaped cross (8)
 
61
C  for squares, triangles, circles and diamonds exist a filled option (add 100)
 
62
C  thus filled diamonds have value (107)
 
63
C
 
64
C.INPUT/OUTPUT:
 
65
C  the following keywords are used:
 
66
C
 
67
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  20:55 - 16 DEC 1987
 
68
C               881118  KB
 
69
C               891213  MP
 
70
C 101022        last modif
 
71
C 
 
72
C-------------------------------------------------------------------
 
73
C
 
74
C
 
75
      IMPLICIT NONE
 
76
C 
 
77
      INTEGER MADRID(1)
 
78
      INTEGER IC,I,J,ILEN
 
79
      INTEGER SELROW             ! index for selected rows 
 
80
      INTEGER NROW,NSC,IAV,NVAL
 
81
      INTEGER ISYMBOL,NODRAW,FILL
 
82
      INTEGER NCOL,NACOL,NAROW
 
83
      INTEGER INTEN,OVCON,MAXDL
 
84
      INTEGER ICOL(6),INPAR(3)
 
85
      INTEGER STAT,IMNO,PRFLAG
 
86
      INTEGER CONN                ! connection flag, P8
 
87
      INTEGER TINULL, TID, KUN, KNUL
 
88
      INTEGER NBYTE,TYPE,MY
 
89
      INTEGER IX(512),IY(512),NPOS(2),LASTP(2)
 
90
      INTEGER COLSYM,COLSIZ,COLCOL
 
91
      INTEGER SSX,SSY,LSX,LSY,SKIPD
 
92
C
 
93
      REAL RBUF(6),XY1(2),XY2(2)
 
94
      REAL VALUE(3)
 
95
      REAL TRNULL,RINFO(8),RDUM
 
96
C
 
97
      DOUBLE PRECISION TDNULL
 
98
C
 
99
      CHARACTER*80  FRAME,LINE,CTEST
 
100
      CHARACTER*80  TABLE
 
101
      CHARACTER*16  UNIT1,UNIT2
 
102
      CHARACTER     IFLAG*3,DLINE*40,LASTLINE*40,FORM*16
 
103
      CHARACTER*30  COLUMN(6)
 
104
      CHARACTER*2   PARM(6)
 
105
C
 
106
      LOGICAL ISEL,IPLOT,NULL(3)
 
107
C
 
108
      INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST'
 
109
      INCLUDE 'MID_INCLUDE:IDIDEV.INC/NOLIST'
 
110
      INCLUDE 'MID_INCLUDE:IDIMEM.INC/NOLIST'
 
111
C
 
112
      COMMON /VMR/MADRID
 
113
C
 
114
      INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST'
 
115
C
 
116
       DATA LINE/' '/,  DLINE /' '/
 
117
       DATA LASTLINE/' '/, FRAME /' '/, TABLE /' '/
 
118
       DATA PARM /'P2','P3','P4','P5','P6','P7'/
 
119
       DATA LASTP /0,0/, MAXDL /40/
 
120
C
 
121
C  initialize MIDAS + attach ImageDisplay
 
122
      CALL STSPRO('TLOADTBL')
 
123
      CALL DTOPEN(1,STAT)
 
124
C
 
125
C   get info for relevant memory board + scroll overlay channel
 
126
C   accordingly then clear scroll values, so we also start 
 
127
C   plotting at the lower left corner
 
128
C
 
129
      CALL STKRDI('DAZHOLD',13,1,IAV,OVCON,KUN,KNUL,STAT)
 
130
      CALL DTGICH(QDSPNO,QIMCH,FRAME,RINFO,STAT)
 
131
      IF (FRAME(1:1).EQ.' ')
 
132
     +   CALL STETER(14,'We need an image in the display...!')
 
133
      CALL STFOPN(FRAME,D_R4_FORMAT,0,F_IMA_TYPE,IMNO,STAT)
 
134
      IF (OVCON.EQ.QIMCH)
 
135
     +   CALL DAZZSC(QDSPNO,QOVCH,ZOOMX,SCROLX,SCROLY,STAT)
 
136
C 
 
137
C  INPUTI(20) serves as printflag for debugging
 
138
      CALL STKRDI('INPUTI',20,1,IAV,PRFLAG,KUN,KNUL,STAT)
 
139
      CALL STKRDI('IDIMEMI',2,4,IAV,IX,KUN,KNUL,STAT)
 
140
      SSX = IX(1)                             !1st screen x-pixel
 
141
      SSY = IX(2)                             !1st screen y-pixel
 
142
      LSX = SSX + IX(3) -1                    !last screen x-pixel
 
143
      LSY = SSY + IX(4) -1                    !last screen y-pixel
 
144
C
 
145
C ... get parameters
 
146
C
 
147
      CALL TBMNUL(TINULL,TRNULL,TDNULL)
 
148
      CALL STKRDC('IN_A',1,1,80,IAV,TABLE,KUN,KNUL,STAT)
 
149
      DO 10, I=1,6
 
150
         CALL STKRDC(PARM(I),1,1,30,IAV,COLUMN(I),KUN,KNUL,STAT)
 
151
10    CONTINUE
 
152
      NODRAW = 0
 
153
      IF (COLUMN(3)(1:1) .EQ. '+') THEN
 
154
          IC = 2                             !no IDENT column
 
155
      ELSE 
 
156
          IC = 3
 
157
          CALL UPCAS(COLUMN(3),LINE)         !check for NOdraw option
 
158
          I = INDEX(LINE,',NO')
 
159
          IF (I.GT.1) THEN
 
160
             NODRAW = 1
 
161
             COLUMN(3)(I:) = ' '             !clean column label
 
162
          ENDIF
 
163
      ENDIF 
 
164
      FILL = 0
 
165
      IF ((COLUMN(4)(1:1).EQ.'#').OR.(COLUMN(4)(1:1).EQ.':')) THEN
 
166
         COLSYM = 1                          !variable symbol from column
 
167
      ELSE
 
168
         COLSYM = 0                          !constant symbol
 
169
         CALL GENCNV(COLUMN(4),1,1,INPAR(1),RDUM,RDUM,IAV)
 
170
         IF (IAV.NE.1) INPAR(1) = 0
 
171
         IF (INPAR(1).GE.100) THEN
 
172
            FILL = 1
 
173
            INPAR(1) = INPAR(1) - 100
 
174
         ENDIF
 
175
         ISYMBOL = INPAR(1) + 1
 
176
      ENDIF
 
177
      IF ((COLUMN(5)(1:1).EQ.'#').OR.(COLUMN(5)(1:1).EQ.':')) THEN
 
178
         COLSIZ = 1                          !variable size from column
 
179
      ELSE
 
180
         COLSIZ = 0                          !constant size 
 
181
         CALL GENCNV(COLUMN(5),1,1,INPAR(2),RDUM,RDUM,IAV)
 
182
         IF (IAV.NE.1) INPAR(2) = 3
 
183
      ENDIF
 
184
      IF ((COLUMN(6)(1:1).EQ.'#').OR.(COLUMN(6)(1:1).EQ.':')) THEN
 
185
         COLCOL = 1                          !variable color from column
 
186
      ELSE
 
187
         COLCOL = 0                          !constant color
 
188
         CALL TSCOLR(COLUMN(6),INTEN)        !color string -> color no.
 
189
      ENDIF
 
190
C      
 
191
      CALL STKRDI('INPUTI',1,1,IAV,CONN,KUN,KNUL,STAT)
 
192
                               ! this will put P8 into CONN
 
193
C
 
194
C ... read table
 
195
C
 
196
      CALL TBTOPN(TABLE,F_I_MODE,TID,STAT)
 
197
      CALL TBIGET(TID,NCOL,NROW,NSC,NACOL,NAROW,STAT)
 
198
      DO 20, I=1,IC                               !search for x, y, ident cols
 
199
         CALL TBCSER(TID,COLUMN(I),ICOL(I),STAT)
 
200
         IF (ICOL(I).EQ.-1) CALL STETER(11,'Column not present')
 
201
20    CONTINUE
 
202
      IF (IC .EQ. 3) THEN                       ! if there is an ident col ...
 
203
         CALL TBFGET(TID,ICOL(3),FORM,ILEN,TYPE,STAT) ! get type, format
 
204
         IF (PRFLAG.EQ.99) WRITE(*,40090) TYPE,FORM
 
205
      ENDIF
 
206
      CALL TBUGET(TID,ICOL(1),UNIT1,STAT)
 
207
      CALL TBUGET(TID,ICOL(2),UNIT2,STAT)
 
208
      CALL UPCAS(UNIT1,UNIT1)
 
209
      I = INDEX(UNIT1,'PIX')                 !that catches also "Frame Pixels"
 
210
      CALL UPCAS(UNIT2,UNIT2)
 
211
      J = INDEX(UNIT2,'PIX')
 
212
      IF ((I.GT.0).AND.(J.GT.0)) THEN
 
213
          IFLAG  = '_RS'
 
214
      ELSE
 
215
          IFLAG  = 'WRS'
 
216
      ENDIF
 
217
      IF (COLSYM.EQ.1) THEN
 
218
         CALL TBCSER(TID,COLUMN(4),ICOL(4),STAT)
 
219
         IF (ICOL(4).EQ.-1) CALL STETER(11,'Symbol column not present')
 
220
      ENDIF
 
221
      IF (COLSIZ.EQ.1) THEN
 
222
         CALL TBCSER(TID,COLUMN(5),ICOL(5),STAT)
 
223
         IF (ICOL(5).EQ.-1) CALL STETER(11,'Size column not present')
 
224
      ENDIF
 
225
      IF (COLCOL.EQ.1) THEN
 
226
         CALL TBCSER(TID,COLUMN(6),ICOL(6),STAT)
 
227
         IF (ICOL(6).EQ.-1) CALL STETER(11,'Color column not present')
 
228
      ENDIF
 
229
C
 
230
C  set up PIXXCV
 
231
      CALL PIXXCV('INIT',IMNO,RBUF,STAT)
 
232
      IF (STAT.NE.0)
 
233
     +   CALL STETER(12,'PIXXCV initialization failed...')
 
234
C
 
235
C ... display values
 
236
C
 
237
      NVAL = 0
 
238
      SELROW = 0
 
239
      SKIPD = 0                         !no. of skipped rows
 
240
C 
 
241
      DO 100, I=1,NROW                   !step through all rows
 
242
         CALL TBSGET(TID,I,ISEL,STAT)   !read row selection flag
 
243
         CALL TBRRDR(TID,I,2,ICOL,VALUE,NULL,STAT)
 
244
         IPLOT  = ISEL .AND. ( .NOT. NULL(1)) .AND. ( .NOT. NULL(2))
 
245
         IF (IPLOT) THEN
 
246
            SELROW = SELROW + 1   
 
247
            IF (COLSYM.EQ.1) THEN
 
248
               FILL = 0
 
249
               CALL TBRRDI(TID,I,1,ICOL(4),INPAR(1),NULL,STAT)
 
250
               IF (INPAR(1).GT.100) THEN
 
251
                  FILL = 1
 
252
                  INPAR(1) = INPAR(1) - 100
 
253
               ENDIF
 
254
               ISYMBOL = INPAR(1) + 1
 
255
            ENDIF
 
256
            IF (COLSIZ.EQ.1) 
 
257
     +         CALL TBRRDI(TID,I,1,ICOL(5),INPAR(2),NULL,STAT)
 
258
            IF (COLCOL.EQ.1) 
 
259
     +         CALL TBRRDI(TID,I,1,ICOL(6),INTEN,NULL,STAT)
 
260
C
 
261
            RBUF(1) = VALUE(1)
 
262
            RBUF(2) = VALUE(2)
 
263
            CALL PIXXCV(IFLAG,0,RBUF,STAT)
 
264
            IF (STAT.NE.0) THEN
 
265
               IF (PRFLAG.EQ.99) WRITE(*,10077) I
 
266
               SKIPD = SKIPD + 1
 
267
               GOTO 100               !coord conversion failed - skip this row
 
268
            ENDIF
 
269
            IF (PRFLAG.EQ.99) WRITE(*,10078) (RBUF(J),J=1,6)
 
270
C 
 
271
C  test, if we'd draw outside the display...
 
272
            KUN = 0
 
273
            J = NINT(RBUF(5))                          !screen x-pixel
 
274
            IF ((J.LT.SSX).OR.(J.GT.LSX)) KUN = KUN + 1
 
275
            J = NINT(RBUF(6))                          !screen y-pixel
 
276
            IF ((J.LT.SSY).OR.(J.GT.LSY)) KUN = KUN + 10
 
277
            IF (KUN.GT.0) THEN
 
278
               IF (PRFLAG.EQ.99) THEN
 
279
                  IF (KUN.EQ.1) THEN
 
280
                     WRITE(*,10090) I
 
281
                  ELSE IF (KUN.EQ.10) THEN
 
282
                     WRITE(*,10091) I
 
283
                  ELSE 
 
284
                     WRITE(*,10092) I
 
285
                  ENDIF
 
286
               ENDIF
 
287
               SKIPD = SKIPD + 1
 
288
               GOTO 100                 !screen pixels outside - skip this row
 
289
            ENDIF
 
290
C 
 
291
            LINE(1:) = ' '
 
292
            IF (CONN.EQ.1) THEN        !yes, connect the symbols 
 
293
               NVAL   = NVAL + 1
 
294
               IF (NVAL.GT.512) THEN                      !flush line buffer
 
295
                  CALL IIGPLY(QDSPNO,QOVCH,IX,IY,512,INTEN,1,STAT)
 
296
                  IX(1) = IX(512)
 
297
                  IY(1) = IY(512)
 
298
                  NVAL = 2
 
299
               ENDIF
 
300
               IX(NVAL) = NINT(RBUF(5))
 
301
               IY(NVAL) = NINT(RBUF(6))
 
302
            ENDIF
 
303
C 
 
304
            IF (ISYMBOL.GT.0) THEN
 
305
               XY1(1) = RBUF(5) - INPAR(2)
 
306
               XY1(2) = RBUF(6) - INPAR(2)
 
307
               XY2(1) = RBUF(5) + INPAR(2)
 
308
               XY2(2) = RBUF(6) + INPAR(2)
 
309
               CALL DRAWME(ISYMBOL,FILL,XY1,XY2,INTEN)
 
310
            ENDIF
 
311
C 
 
312
            IF (IC.EQ.3) THEN           ! yes, there is a third column as ident 
 
313
               IF (TYPE .EQ. D_C_FORMAT) THEN         !type is character
 
314
                  CALL TBERDC(TID,I,ICOL(3),CTEST,NULL(3),STAT)
 
315
                  CALL FT_EOS(CTEST,80,LINE,STAT)
 
316
                  NBYTE = INDEX(LINE,' ') - 1
 
317
                  IF (NBYTE.GT.39) NBYTE = 39         !DLINE is 40 chars.
 
318
                  DLINE(1:) = LINE(1:NBYTE)          
 
319
               ELSE                          !type of 3rd column is not char..
 
320
                  CALL TBERDR(TID,I,ICOL(3),VALUE(3),NULL(3),STAT)
 
321
                  IF ((TYPE .EQ. D_I1_FORMAT) .OR.
 
322
     +                (TYPE .EQ. D_I2_FORMAT) .OR.
 
323
     +                (TYPE .EQ. D_I4_FORMAT)) THEN     !integer type 
 
324
                     MY = NINT(VALUE(3))
 
325
                     IAV = 1
 
326
                  ELSE                                  !float type
 
327
                     IAV = 2
 
328
                  ENDIF
 
329
C
 
330
                  CALL W1FORM(FORM,IAV,MY,VALUE(3),TDNULL,DLINE)
 
331
                  IAV = 1
 
332
                  MY = MAXDL - 1                        !avoid overrun of DLINE
 
333
35                IF (DLINE(1:1) .EQ. ' ') THEN         !remove leading blanks
 
334
                     IAV = IAV + 1
 
335
                     IF (IAV.LT.MY) THEN
 
336
                        DLINE(1:) = DLINE(2:)
 
337
                        GOTO 35
 
338
                     ELSE
 
339
                        DLINE(1:1) = 'x'
 
340
                        NBYTE = 1
 
341
                        GOTO 40
 
342
                     ENDIF
 
343
                  ENDIF
 
344
C 
 
345
                  NBYTE = INDEX(DLINE,' ') - 1
 
346
               ENDIF
 
347
C 
 
348
40             DLINE(NBYTE+1:) = '^'                    !mark the end
 
349
               NPOS(1) = NINT(RBUF(5)) + 5
 
350
               NPOS(2) = NINT(RBUF(6))
 
351
 
 
352
               IF (CONN.NE.0) THEN    ! connection flag P8 is +1 or -1
 
353
                  IF (NODRAW.EQ.0)
 
354
     +               CALL IIGTXT(QDSPNO,QOVCH,DLINE(1:NBYTE),
 
355
     +                           NPOS(1),NPOS(2),0,0,INTEN,0,STAT)
 
356
C 
 
357
               ELSE                   ! CONN (P8) is zero (default)
 
358
                  IF (SELROW.EQ.1) THEN     ! in first row of table
 
359
                     LASTP(1) = NPOS(1)
 
360
                     LASTP(2) = NPOS(2)
 
361
                     LASTLINE(1:) = DLINE(1:)    !LASTLINE set to DLINE
 
362
                  ENDIF
 
363
C         
 
364
                  IF (LASTLINE.EQ.DLINE) THEN   !true, at least for first row
 
365
                     NVAL = NVAL + 1
 
366
                     IF (NVAL.GT.512) THEN      !flush line buffer
 
367
                        CALL IIGPLY(QDSPNO,QOVCH,IX,IY,512,INTEN,1,STAT) 
 
368
                        IX(1) = IX(512)
 
369
                        IY(1) = IY(512)
 
370
                        NVAL = 2
 
371
                     ENDIF
 
372
                  ELSE                          !LASTLINE not equal DLINE
 
373
                     IF (NVAL.GT.1) 
 
374
     +                  CALL IIGPLY(QDSPNO,QOVCH,IX,IY,NVAL,
 
375
     +                              INTEN,1,STAT)
 
376
                     NVAL = 1
 
377
                     NBYTE = INDEX(LASTLINE,'^') - 1
 
378
                     IF ((NBYTE.GT.0).AND.(NODRAW.EQ.0))
 
379
     +                  CALL IIGTXT(QDSPNO,QOVCH,LASTLINE(1:NBYTE),
 
380
     +                              LASTP(1),LASTP(2),0,0,INTEN,0,STAT)
 
381
                     LASTLINE(1:) = DLINE(1:)
 
382
                     LASTP(1) = NPOS(1)
 
383
                     LASTP(2) = NPOS(2)
 
384
                  ENDIF
 
385
C         
 
386
                  IX(NVAL) = NINT(RBUF(5))
 
387
                  IY(NVAL) = NINT(RBUF(6))
 
388
               ENDIF
 
389
C 
 
390
            ENDIF
 
391
         ENDIF
 
392
100   CONTINUE
 
393
C 
 
394
      IF (IC.EQ.3) THEN
 
395
         IF ((CONN.NE.-1) .AND. (NODRAW.EQ.0)) THEN
 
396
            NBYTE = INDEX(LASTLINE,'^') - 1
 
397
            CALL IIGTXT(QDSPNO,QOVCH,LASTLINE(1:NBYTE),
 
398
     +                  LASTP(1),LASTP(2),0,0,INTEN,0,STAT)
 
399
         ENDIF
 
400
      ENDIF
 
401
C 
 
402
      IF (NVAL.GT.1) THEN
 
403
         CALL IIGPLY(QDSPNO,QOVCH,IX,IY,NVAL,INTEN,1,STAT)
 
404
      ENDIF
 
405
C 
 
406
C  write no. of skipped rows into OUTPUTI(11)
 
407
      CALL STKWRI('OUTPUTI',SKIPD,11,1,KUN,STAT)
 
408
C
 
409
C ... end
 
410
C
 
411
      CALL TBTCLO(TID,STAT)
 
412
      CALL DTCLOS(QDSPNO)
 
413
C refresh the overlay:      
 
414
      CALL REFOVR(STAT) 
 
415
      CALL STSEPI
 
416
C
 
417
C  Formats
 
418
10077 FORMAT('row no.',I5,' contains bad coord(s) - we skip ...')
 
419
10078 FORMAT('RBUF(1-6)',6F10.4)
 
420
10090 FORMAT('screen x-pixel outside - skip row no. ',I5)
 
421
10091 FORMAT('screen y-pixel outside - skip row no. ',I5)
 
422
10092 FORMAT('screen x- and y-pixel outside - skip row no. ',I5)
 
423
40090 FORMAT('refcolumn: type = ',I3,', format = ',A)
 
424
      END
 
425
 
 
426
      SUBROUTINE DRAWME(FLAG,FILL,XY1,XY2,INTENS)
 
427
C
 
428
C
 
429
      IMPLICIT NONE
 
430
C 
 
431
      INTEGER INTENS,N,NOP,IK,SW,N1,N2,M(2),IX,IY
 
432
      INTEGER XFIG(513),YFIG(513)
 
433
      INTEGER FLAG,FILL,RADIUS,RADX,RADY,NCX,NCY
 
434
      INTEGER CENTER(2)
 
435
C
 
436
      REAL XY1(2),XY2(2)
 
437
      REAL CONST,ANGLE,FACTO,AA
 
438
C
 
439
      INCLUDE 'MID_INCLUDE:IDIDEV.INC/NOLIST'
 
440
      INCLUDE 'MID_INCLUDE:IDIMEM.INC/NOLIST'
 
441
C
 
442
C  branch according to flag
 
443
      GO TO (100,200,100,500,600,700,800,900,1000),FLAG
 
444
C
 
445
C  construct coordinates for a rectangle
 
446
100   IF (FILL.NE.1) THEN
 
447
         XFIG(1) = XY1(1)
 
448
         YFIG(1) = XY1(2)
 
449
         XFIG(2) = XFIG(1)                      !move up
 
450
         YFIG(2) = XY2(2)
 
451
         XFIG(3) = XY2(1)                       !move right
 
452
         YFIG(3) = YFIG(2)
 
453
         XFIG(4) = XFIG(3)                       !move down
 
454
         YFIG(4) = YFIG(1)
 
455
         XFIG(5) = XFIG(1)
 
456
         YFIG(5) = YFIG(1)
 
457
         NOP = 5
 
458
      ELSE
 
459
         N1 = XY1(2)
 
460
         N2 = XY2(2)
 
461
         M(1) = XY1(1)
 
462
         M(2) = XY2(1)
 
463
         IK = 1
 
464
         SW = 1
 
465
         DO 150, N=N1,N2
 
466
            XFIG(IK) = M(SW)
 
467
            YFIG(IK) = N
 
468
            SW = 3 - SW                         !oscillate between 1 and 2
 
469
            IK = IK + 1
 
470
            XFIG(IK) = M(SW)
 
471
            YFIG(IK) = N
 
472
            IK = IK + 1
 
473
150      CONTINUE
 
474
         NOP = IK - 1
 
475
      ENDIF
 
476
      GO TO 10000
 
477
C
 
478
C  construct coordinates of a circle
 
479
200   CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
 
480
      CENTER(2) = NINT((XY1(2)+XY2(2))*0.5)
 
481
      RADX   = ABS(XY1(1)-CENTER(1))
 
482
      RADY   = ABS(XY1(2)-CENTER(2))
 
483
      RADIUS = NINT((RADX+RADY)*0.5)            !get no. of points to draw
 
484
      NOP    = MIN(512,6*RADIUS)
 
485
      CONST  = 6.27/NOP
 
486
      FACTO = 0.017453                          !Pi / 180.
 
487
C
 
488
C  construct points on circle
 
489
      IF (FILL.NE.1) THEN
 
490
         DO 300, N=1,NOP+1
 
491
            ANGLE = (N-1)*CONST
 
492
            XFIG(N) = CENTER(1) + NINT(RADIUS*COS(ANGLE))
 
493
            YFIG(N) = CENTER(2) + NINT(RADIUS*SIN(ANGLE))
 
494
300      CONTINUE
 
495
         NOP = NOP + 1
 
496
      ELSE
 
497
         M(1) = CENTER(2) - RADIUS                !low y
 
498
         M(2) = CENTER(2) + RADIUS                !high y
 
499
         NCX = CENTER(1)
 
500
         NCY = CENTER(2)
 
501
         XFIG(1) = NCX
 
502
         YFIG(1) = M(1)
 
503
         IK = 2
 
504
         SW = -900                             !start at -90 degs */
 
505
         AA = 0.1 * FACTO
 
506
         DO 350, N=M(1),M(2)
 
507
C 
 
508
330         SW = SW + 1
 
509
            IF (SW.GT.900) GOTO 355            !avoid infinite loop
 
510
            ANGLE = SW * AA
 
511
            IY = NINT(RADIUS*SIN(ANGLE))
 
512
            N1 = NCY + IY                      !test y-value of circle
 
513
            IF (N1.LT.N) GOTO 330
 
514
C 
 
515
            IX = NINT(RADIUS*COS(ANGLE))
 
516
            XFIG(IK) = NCX + IX
 
517
            YFIG(IK) = NCY + IY
 
518
            IK = IK + 1
 
519
            XFIG(IK) = NCX - IX
 
520
            YFIG(IK) = YFIG(IK-1)
 
521
            IK = IK + 1
 
522
            XFIG(IK) = NCX + IX
 
523
            YFIG(IK) = YFIG(IK-1)
 
524
            IK = IK + 1
 
525
350      CONTINUE
 
526
355      XFIG(IK) = NCX
 
527
         YFIG(IK) = M(2)
 
528
         NOP = IK 
 
529
      ENDIF
 
530
      GOTO 10000
 
531
C
 
532
C  construct coordinates of a triangle
 
533
500   IF (FILL.NE.1) THEN
 
534
         XFIG(1) = XY1(1)
 
535
         YFIG(1) = XY1(2)
 
536
         CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
 
537
         XFIG(2) = CENTER(1)
 
538
         YFIG(2) = XY2(2)
 
539
         XFIG(3) = XY2(1)
 
540
         YFIG(3) = XY1(2)
 
541
         XFIG(4) = XY1(1)
 
542
         YFIG(4) = XY1(2)
 
543
         NOP = 4
 
544
      ENDIF
 
545
      GO TO 10000
 
546
C
 
547
C  construct coordinates of a triangle
 
548
600   XFIG(1) = XY1(1)
 
549
      YFIG(1) = XY2(2)
 
550
      CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
 
551
      XFIG(2) = CENTER(1)
 
552
      YFIG(2) = XY1(2)
 
553
      XFIG(3) = XY2(1)
 
554
      YFIG(3) = XY2(2)
 
555
      XFIG(4) = XY1(1)
 
556
      YFIG(4) = XY2(2)
 
557
      NOP = 4
 
558
      GOTO 10000
 
559
C
 
560
C  construct coordinates of a cross
 
561
700   CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
 
562
      CENTER(2) = NINT((XY1(2)+XY2(2))*0.5)
 
563
      XFIG(1) = XY1(1)
 
564
      YFIG(1) = CENTER(2)
 
565
      XFIG(2) = XY2(1)
 
566
      YFIG(2) = YFIG(1)
 
567
      XFIG(3) = CENTER(1)
 
568
      YFIG(3) = YFIG(2)
 
569
      XFIG(4) = XFIG(3)
 
570
      YFIG(4) = XY2(2)
 
571
      XFIG(5) = XFIG(4)
 
572
      YFIG(5) = XY1(2)
 
573
      NOP = 5
 
574
      GOTO 10000
 
575
C
 
576
C  construct coordinates of an open cross
 
577
800   CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
 
578
      CENTER(2) = NINT((XY1(2)+XY2(2))*0.5)
 
579
      IK = (XY2(1) - CENTER(1))/2
 
580
      IF (IK.LT.1) IK = 1
 
581
C 
 
582
      XFIG(1) = XY1(1)
 
583
      YFIG(1) = CENTER(2)
 
584
      XFIG(2) = CENTER(1) - IK
 
585
      YFIG(2) = YFIG(1)
 
586
      NOP = 2
 
587
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
 
588
      XFIG(1) = CENTER(1) + IK
 
589
      XFIG(2) = XY2(1)
 
590
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
 
591
      XFIG(1) = CENTER(1)
 
592
      YFIG(1) = XY1(2)
 
593
      XFIG(2) = XFIG(1)
 
594
      YFIG(2) = CENTER(2) - IK
 
595
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
 
596
      YFIG(1) = CENTER(2) + IK
 
597
      YFIG(2) = XY2(2)
 
598
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
 
599
      RETURN
 
600
C
 
601
C  construct coordinates of a diamond
 
602
900   CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
 
603
      CENTER(2) = NINT((XY1(2)+XY2(2))*0.5)
 
604
      XFIG(1) = CENTER(1)
 
605
      YFIG(1) = XY1(2)
 
606
      XFIG(2) = XY2(1)
 
607
      YFIG(2) = CENTER(2)
 
608
      XFIG(3) = XFIG(1)
 
609
      YFIG(3) = XY2(2)
 
610
      XFIG(4) = XY1(1)
 
611
      YFIG(4) = YFIG(2)
 
612
      XFIG(5) = XFIG(1)
 
613
      YFIG(5) = YFIG(1)
 
614
      NOP = 5
 
615
      GOTO 10000
 
616
C
 
617
C  construct coordinates of an X shaped cross
 
618
1000  XFIG(1) = XY1(1)
 
619
      YFIG(1) = XY1(2)
 
620
      XFIG(2) = XY2(1)
 
621
      YFIG(2) = XY2(2)
 
622
      NOP = 2
 
623
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
 
624
      YFIG(1) = XY2(2)
 
625
      XFIG(2) = XY2(1)
 
626
      YFIG(2) = XY1(2)
 
627
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
 
628
      RETURN
 
629
C
 
630
C  now draw the shape
 
631
10000 CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
 
632
C
 
633
      RETURN
 
634
      END