C  @(#)idfunc.for	19.1 (ESO-DMD) 02/25/03 14:00:27 
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
      PROGRAM IDFUNC
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: K.Banse
C
C.IDENTIFICATION
C  program IDFUNC              		version 1.00	890628
C 981019
C
C.KEYWORDS
C  Image Display, split screen, overlay, alpha numeric generator
C  LUT tables, system status, cursor, distance
C
C
C.PURPOSE
C  a) en/disable the split screen mode, modify the VOC control register
C  b) write alphanumeric string to alphanumeric memory or 
C     overlay channel of ImageDisplay
C  c) create LUT tables for Image Display, using hue, saturation and intensity
C     store them optionally in a table file 
C  d) depending upon P1 display the general layout of the ImageDisplay
C     or the different internal registers
C  e) read the position of the two cursors on the display
C     and calculate the distance of relevant pixels in world coordinate space
C     Store xworlds, yworlds + distance in descriptor or table or not at all.
C
C
C.ALGORITHM
C  a) use the IDIs to do the "hardware" job
C  b) create my alphabet
C  d) get relevant keywords and display info in user friendly format
C     use IIDIAG to read the registers
C  e) use both cursors and read screen pixels, when the ENTER button is pressed
C     get real pixels and world coordinates and compute Euclidean distance
C
C.INPUT/OUTPUT
C  the following keys are used:
C
C  ACTION/C/1/2         action flag
C                  	= SS, set split screen info (a)
C                  	= CE, set the CE bit (a)
C                  	= CP, copy overlay graph + text to image channel
C                  	= IC, iconify display
C                  	= IK, iconify graphics window
C                  	= AE, enable the alpha numerics (a)
C                  	= GE, set the GE bit (a)
C                  	= AN, manage alphanumerics (b)
C                  	= HU, handle HIS model LUT (c)
C                  	= DI, compute distance between two points (e)
C                  	= ST, use GETSTR to get an input string from Midas
C			      command window while in a different 
C			      display window
C 
C  DAZHOLD/I/1/10       cursor no., cursor form,  (for all)
C                  	split screen mode + x,y- split addresses
C 
C  a) 
C  DAZIN/I/1/1          if ACTION = C, A or G, enable flag, 0 or 1
C
C  b)
C  P1/C/1/100		max. 100 characters to be displayed in one go
C			if only blanks => clear alpha memory
C  P3/C/1/1		mode = A      - use alphanumeric memory
C			     = O,Norm - use overlay channel
C  P5/C/1/1		text size  (0, 1, 2)
C 
C  c)
C  P1/C/1/60		name of table file 
C  DAZIN/I/1/2		section of LUT table 
C  INPUTR/R/1/9		start, end + number of levels 
C			for Intensity, Saturation and Hue
C
C  d)
C  MID$SESS/C/1/5            display type
C  P1/C/1/1                  G(eneral) or I(nternal)
C  P2/C/1/1                  flag for output to file
C 
C  e)
C  P1/C/1/15			optional descriptor name where world coordinates
C				+ distance should be stored
C				or table name, if data should go to a table
C				= ?, if data only to be displayed on terminal
C  P2/C/1/2			= A or ?, for appending values to descriptor 
C				          or not
C				= ID for using identifiers in tables
C				= NO[,start_no]  for automatic numbering 
C                                                in tables
C				start_no an optional starting number
C  P3/C/1/2			mark flag,
C				(1:1) = Y - put crosses on screen, else no
C				(2:2) = Y - draw also the connecting line in
C				            the overlay channel, else no
C
C  OUTPUTR/R/10/5		receives world coords + distance
C  OUTPUTI/I/1/1		receives total no. of coordinates obtained
C  CURSOR/I/1/4			(1) holds max. no. of coords reading on input
C				(1,,,4) will be filled with cursor pos. within
C				routine GETCURS ...
C 
C. VERSIONS
C  1.00            build up from te different individual programs
C see SCCS
C 
C 020502	last modif
C 
C--------------------------------------------------
C
      IMPLICIT NONE
C
      INTEGER      FLAG,IAV,N,M,SPLMOD,STAT
      INTEGER      SPLCX(4,5),SPLCY(4,5)
      INTEGER      DAZHLD(10),KK,SXO,SYO
      INTEGER      MEMIDS(4),XOFFS(4),YOFFS(4)
      INTEGER      SPLFLG,XSPLIT,YSPLIT
      INTEGER      ILIN,IPOS,IOFF,NBYTE,COOS(4)
      INTEGER      KIN(2),XY1(3),XY2(2),MEMO1,MEMO2
      INTEGER      KSECT,UNI(1),NULO,LUTSZ
      INTEGER      COOCNT,COOMAX,COOFF,FELEM
      INTEGER      IDFLAG,NCOLS,NCOLS1,NOREC
      INTEGER      NOFLAG,NOOFF,JM(40),SUBLO(3)
      INTEGER      TABFLG,ST1,ST2
      INTEGER      XYDUM(2),TCOLNM(7)
      INTEGER      XFIG(5),YFIG(5),XCROSS(5),YCROSS(5)
      INTEGER      TID,IMNO,LABCOL,TXTSIZ,INFLAG,FILESW
      INTEGER      MADRID(1)
C
      REAL         REA(5,10),RDX,RDY
      REAL         PCUR1(6),PCUR2(6),VAL
      REAL         RLUT(768),HSI(768),RQ(768)
      REAL         H,HEND,S,SEND,FI,FIEND,IVALU,HVALU,SVALU
      REAL         RBUF(10),RINCI,RINCH,RINCS,RD
C 
      DOUBLE PRECISION DD
C 
      CHARACTER    COMPAR(11)*2
      CHARACTER    ACTION*3,LINE*100,CBUF*220,COLO*3
      CHARACTER    DISPMO*1,KEYFLG*1
      CHARACTER    FRAME*80
      CHARACTER    HEADR1*80
      CHARACTER    INFO*24,DESCR*15
      CHARACTER    APPFLG*1,IDF*8,OLDIDF*8,LABL*8,DRAW*2
      CHARACTER    TABLE*80,TABUNI*16,TABLAB(7)*16
      CHARACTER    ERROR1*30,PROMPT*40,CACT*8
C
      INCLUDE  'MID_INCLUDE:ST_DEF.INC'
C
      INCLUDE  'MID_INCLUDE:IDIDEV.INC'
      INCLUDE  'MID_INCLUDE:IDIMEM.INC'
C 
      COMMON  /VMR/ MADRID
C
      EQUIVALENCE      (TABLE,DESCR)
C 
      INCLUDE  'MID_INCLUDE:ST_DAT.INC'
C
      DATA      COOS      /-1,-1,-1,-1/
      DATA      XOFFS     /4*0/,   YOFFS  /4*0/  
      DATA      ERROR1    /'No image loaded... '/
      DATA      INFO      /'switch cursor(s) on... '/
      DATA      IDF       /'ID '/,     OLDIDF   /' '/
      DATA      TCOLNM    /1,2,3,4,5,6,7/
      DATA      TABLAB    /'XSTART ','YSTART ',
     +                     'XEND ','YEND ','DISTANCE',
     +                     'NO ','IDENT '/
      DATA      REA       /50*0./
      DATA      DRAW      /'??'/
      DATA      XCROSS    /0,0,0,-4,5/,   YCROSS    /-4,4,0,0,0/
      DATA      PROMPT    /' enter identifier '/
      DATA      CACT      /'YYYY?C0 '/,   LABL      /' '/
      DATA      COMPAR 
     +      /'SS','CE','AE','GE','AN','HU','ST','DI','CP','IC','IK'/
C
C  get into MIDAS
      CALL STSPRO('IDFUNC')
      FILESW = 0
      NOREC = 0
C
C  get action flags
      CALL STKRDC('ACTION',1,1,3,IAV,ACTION,UNI,NULO,STAT)
      CALL UPCAS(ACTION,ACTION)
C 
      DO 120 N=1,11
         IF (ACTION(1:2).EQ.COMPAR(N)) THEN
            FLAG = N
            GOTO 200
         ENDIF
120   CONTINUE
      GOTO 90000
C
C  branch to desired action
200   IF (FLAG .NE. 11) CALL DTOPEN(1,STAT)
      CALL STKRDI('DAZHOLD',1,10,IAV,DAZHLD,UNI,NULO,STAT)
      GOTO (1000,2000,2000,2000,6000,7000,8800,9000,
     +      3000,3300,3300),FLAG  
C 

C 
C******************************
C 
C  here we handle the VOC related stuff
C 
C******************************
C 
C  get split screen mode + split addresses, if mode < 0
1000  SPLMOD = DAZHLD(3)
      MEMIDS(3) = QLSTCH + 1
      MEMIDS(4) = MEMIDS(3)
      SXO = 0
      SYO = QDSZY - 1
C
      IF (SPLMOD.EQ.1) THEN
         DO 1100 N=1,4
            MEMIDS(N) = N - 1
1100     CONTINUE
         SPLFLG = 0
         XSPLIT = (QDSZX - 1) / 2
         YSPLIT = (QDSZY - 1) / 2
C 
      ELSE IF (SPLMOD.EQ.2) THEN
         MEMIDS(1) = 1
         MEMIDS(2) = 0
         SPLFLG = 1
         XSPLIT = (QDSZX - 1) / 2
         YSPLIT = 0
C 
      ELSE IF (SPLMOD.EQ.3) THEN
         MEMIDS(1) = 2
         MEMIDS(2) = 3
         SPLFLG = 1
         XSPLIT = (QDSZX - 1) / 2
         YSPLIT = 2*QDSZY - 1
C 
      ELSE IF (SPLMOD.EQ.4) THEN
         MEMIDS(1) = 0
         MEMIDS(2) = 3
         SPLFLG = 2
         XSPLIT = 0
         YSPLIT = (QDSZY - 1) / 2
C 
      ELSE IF (SPLMOD.EQ.5) THEN
         MEMIDS(1) = 1
         MEMIDS(2) = 2
         SPLFLG = 2
         XSPLIT = 2*QDSZX - 1
         YSPLIT = (QDSZY - 1) / 2
      ENDIF
C
C  compute center values for split screen mode
      CALL SPLCNT(SPLCX,SPLCY)
C
C  clear alpha-numerics
      CALL IIMCMY(QDSPNO,QALPNO,1,0,STAT)
C
C *** clear split screen ***
C
      IF (SPLMOD.EQ.0) THEN           !set up VOC to show only one image
C
         SPLFLG = -1
         MEMIDS(1) = 0
         XSPLIT = 0
         YSPLIT = QDSZY - 1
C 
         DO 1300 M=1,QLSTCH+1            !loop through memory channels
            N = M - 1
            IF (N.NE.QOVCH) THEN
               CALL DTGICH(QDSPNO,N,LINE,RBUF,STAT)
               SCROLX = SXO
               SCROLY = SYO
               CALL DTPICH(QDSPNO,N,LINE,RBUF,STAT)
            ENDIF
1300     CONTINUE
C
         CALL IIDSSS(QDSPNO,MEMIDS,XOFFS,YOFFS,SPLFLG,
     +               XSPLIT,YSPLIT,STAT)    !do the hardware part...
         QIMCH = 0            	  
         CALL WALPHB(QIMCH,0)                !display alpha stuff for channel 0
C
C *** set split screen ***
C
      ELSE            			!set up VOC to show 4 channels
         CALL STETER(13,'Currently no support for split screen...')
      ENDIF
          GOTO 90000
C *****
C
C  enable/disable Cursor/ Graphics/ Alpha-memory
2000  CALL STKRDI('DAZIN',1,1,IAV,M,UNI,NULO,STAT)
C
C  en/disable cursor(s)
      IF (FLAG.EQ.1) THEN
         IF (DAZHLD(1).EQ.2) THEN
            CALL IICSCV(QDSPNO,1,M,STAT)            !we use two cursors
            CALL IICSCV(QDSPNO,2,M,STAT)
         ELSE IF (DAZHLD(1).EQ.1) THEN
            CALL IICSCV(QDSPNO,2,M,STAT)
         ELSE
            CALL IICSCV(QDSPNO,1,M,STAT)
         ENDIF
C
C  en/disable the alpha numerics board
      ELSE IF (FLAG.EQ.2) THEN
         CALL DAZVIS(QDSPNO,QALPNO,2,M)
C
C  en/disable graphics/overlay
      ELSE
         CALL DAZVIS(QDSPNO,QOVCH,2,M) 
      ENDIF
      GOTO 90000
C 
C *****
C
C  copy overlay -> image channel
C 
3000  CALL STKRDI('DAZIN',1,2,IAV,KIN,UNI,NULO,STAT)     !chanl_no, append_flag
      CALL IIGCPY(QDSPNO,KIN(1),KIN(2),STAT)
      GOTO 90000
C 
C  iconify/de-iconify display window
C 
3300  CALL STKRDI('DAZIN',1,1,IAV,M,UNI,NULO,STAT)      !1 or 0 (iconify_flag)
      IF (ACTION(2:2).EQ.'K') THEN
         CALL DTOPEN(2,STAT)                            !open graphics w.
         CALL IIDICO(GDSPNO,M,STAT)
         CALL DTCLOS(GDSPNO)                            !and close it
C refresh the overlay:      
CC         CALL REFOVR(STAT) 			!why did I do that??
         CALL STSEPI
      ELSE
         CALL IIDICO(QDSPNO,M,STAT)
         GOTO 90000
      ENDIF

C 
C******************************
C 
C  here we handle the alphanumerics stuff
C 
C******************************
C 
C  get characters + all other info
6000  IF (ACTION(3:3).EQ.'F') THEN                     !we have input from file
         CALL STKRDC('P1',1,1,80,IAV,FRAME,UNI,NULO,STAT)     !get file name
         N = INDEX(FRAME,' ') - 1
         IF (N.LT.1) N = 80
         OPEN(UNIT=33,FILE=FRAME(1:N),STATUS='OLD',ERR=6906)
         FILESW = 1                       !indicate, that we have file input
      ELSE
         GOTO 6060
      ENDIF
C
C  reading loop for file input
6030  DISPMO = 'O'                            !that's a capital `o'
      COLO(1:3) = 'WHI'
      TXTSIZ = 0
      KEYFLG = 'N'
C 
      CBUF(1:) = ' '
      READ(33,10100,END=6909) CBUF
      N = 1                                   !start for extraction
      LINE(1:) = ' ' 
      CALL EXTRSS(CBUF,' ',N,LINE,IAV)
      IF (IAV.LE.0) GOTO 6030                 !skip empty records
      FRAME(1:) = ' '
      CALL EXTRSS(CBUF,' ',N,FRAME,IAV)
      IF (IAV.LE.0) THEN
         FRAME = 'CURSOR '
         GOTO 6090
      ENDIF
      IF (FRAME(1:1).EQ.'?') FRAME = 'CURSOR '
      CALL EXTRSS(CBUF,' ',N,HEADR1,IAV)
      IF (IAV.LE.0) GOTO 6090                !end of record reached
      DISPMO = HEADR1(1:1)
      IF (DISPMO.EQ.'?') DISPMO = 'O '
      CALL EXTRSS(CBUF,' ',N,HEADR1,IAV)
      IF (IAV.LE.0) GOTO 6090                !end of record reached
      COLO(1:3) = HEADR1(1:3)
      IF (COLO(1:1).EQ.'?') COLO(1:3) = 'WHI'
      CALL EXTRSS(CBUF,' ',N,HEADR1,IAV)
      IF (IAV.LE.0) GOTO 6090                !end of record reached
      IF (HEADR1(1:1).NE.'?') THEN
         CALL GENCNV(HEADR1,1,1,TXTSIZ,RD,DD,N)
         IF (N.NE.1) CALL STETER(14,'Invalid label size...')
      ENDIF
      GOTO 6090                              !skip keyword reading
C 
6060  CALL STKRDC('P3',1,1,1,IAV,DISPMO,UNI,NULO,STAT)
      CALL STKRDC('P1',1,1,100,IAV,LINE,UNI,NULO,STAT)     !get text string
      IF (LINE(1:1).EQ.' ') THEN
         CALL TRUNCC(LINE,100,IOFF,NBYTE)
         IF ((NBYTE.LT.1) .AND. (DISPMO.EQ.'A')) THEN
            CALL IIMCMY(QDSPNO,QALPNO,1,0,STAT)
            GOTO 90000
         ENDIF
      ENDIF
      CALL STKRDC('P2',1,1,80,IAV,FRAME,UNI,NULO,STAT)  
      CALL STKRDC('P4',1,1,3,IAV,COLO,UNI,NULO,STAT)
      CALL STKRDC('P5',1,1,8,IAV,HEADR1,UNI,NULO,STAT)
      CALL GENCNV(HEADR1,1,1,TXTSIZ,RD,DD,N) 
      IF (N.NE.1) CALL STETER(14,'Invalid label size...')
      CALL STKRDC('P6',1,1,1,IAV,KEYFLG,UNI,NULO,STAT)       !get loop flag
C 
6090  INFLAG = 0
      COOCNT = 0
      CALL UPCAS(DISPMO,DISPMO)
      IF ((FRAME(1:1).EQ.'C').OR.(FRAME(1:1).EQ.'c')) THEN
         INFLAG = 1                                        !show cursor input
         GOTO 6360
      ENDIF
      KK = INDEX(FRAME,',F')
      IF (KK.LT.1) KK = INDEX(FRAME,',f')
      IF (KK.GT.0) THEN                           !we have frame pixels
         FRAME(KK:) = ' '            
         KK = INDEX(FRAME,',')                    !flip y,x coords for PIXXCV
         IF (INDEX(FRAME,'@').GT.0) THEN
            TABLE(1:) = FRAME(KK+1:)
            FRAME(KK:) = ' '
            KK = INDEX(TABLE,' ')
            TABLE(KK:) = ','//FRAME(1:)
         ELSE
            TABLE(1:) = '@'//FRAME(KK+1:)
            FRAME(KK:) = ' '
            KK = INDEX(TABLE,' ')
            TABLE(KK:) = ',@'//FRAME(1:)
         ENDIF
         CALL DTGICH(QDSPNO,QIMCH,FRAME,RBUF,STAT)
         IF (STAT.EQ.1) CALL STETER(3,'no image loaded...')
C
         CALL STFOPN(FRAME,D_OLD_FORMAT,0,F_IMA_TYPE,IMNO,STAT)
         CALL PIXXCV('INIT',IMNO,RBUF,STAT)
C
         CALL EXTCO1(IMNO,TABLE,2,N,SUBLO,STAT)
         IF (STAT.NE.0) CALL STETER
     +      (4,'Bad syntax in line,column specification...')
C 
         RBUF(1) = SUBLO(1)
         RBUF(2) = SUBLO(2)
         CALL PIXXCV('_RS',0,RBUF,STAT) 
         ILIN = NINT(RBUF(6))
         IPOS = NINT(RBUF(5))
         GOTO 6360
      ENDIF
C 
      IF ((KEYFLG(1:1).EQ.'K') .OR. (KEYFLG(1:1).EQ.'k')) THEN
         CALL STKRDC('P1',1,1,15,IAV,DESCR,UNI,NULO,STAT)    
         CALL STKRDC(DESCR,1,1,220,IAV,CBUF,UNI,NULO,STAT)  !key for strings
         IF (IAV.LT.220)
     +      CBUF(IAV+1:IAV+2) = '~~'              !make sure we have an end...
         CALL STKRDC('P2',1,1,15,IAV,DESCR,UNI,NULO,STAT)   !key for lengths
         CALL STKRDI(DESCR,1,40,IAV,JM,UNI,NULO,STAT)
         KK = INDEX(CBUF,'~')
         IF (KK.LE.1)
     +      CALL STETER(91,'Wrong string in key "P2"...')
         NOOFF = 1 + KK 
         LINE(1:) = CBUF(1:KK-1)//' '
         NOREC = 3
      ELSE
         DO 6100,N=1,80
            IF (FRAME(N:N).EQ.' ') THEN
               FRAME(N:N) = ','
               GOTO 6160
            ENDIF
6100     CONTINUE
6160     KK = INDEX(FRAME,'.')
         IF (KK.GT.0) THEN
            CALL GENCNV(FRAME,2,2,KK,RBUF,DD,N)
            JM(1) = NINT(RBUF(1)*(QDSZY-1))
            JM(2) = NINT(RBUF(2)*(QDSZX-1))
         ELSE
            CALL GENCNV(FRAME,1,2,JM,RD,DD,N)           !get integers...
         ENDIF
         IF (N.LT.2) 
     +      CALL STETER(7,'invalid start pixels for label')
         NOREC = 0
      ENDIF
      ILIN = JM(1)
      IPOS = JM(2)
C 
C get length of string
6360  CALL TRUNCC(LINE,100,IOFF,NBYTE)

C  
C  if NBYTE < 1, clear alphanumerics
      IF (NBYTE.LT.1) THEN
         IF (DISPMO.EQ.'A') THEN
            CALL IIMCMY(QDSPNO,QALPNO,1,0,STAT)
            GOTO 90000
         ELSE
            CALL STETER(1,'no. of bytes should be > 0 ...')
         ENDIF
      ENDIF
C 
      CALL TSCOLR(COLO,LABCOL)        !color string -> color no.
C
C  write character string to AN board or overlay channel + display it

      IF (INFLAG.NE.1) THEN                          !fixed position on screen
         IF (DISPMO.NE.'A') THEN                              !overlay plane
            CALL IIGTXT(QDSPNO,QOVCH,LINE(IOFF:IOFF+NBYTE-1), 
     +                  IPOS,ILIN,0,0,LABCOL,TXTSIZ,STAT)
         ELSE                                                 !alphanum. plane
            CALL ALPTXT(LINE(IOFF:IOFF+NBYTE-1),IPOS,ILIN,0)
         ENDIF
C 
         IF (NOREC.GT.1) THEN
            KK = INDEX(CBUF(NOOFF:),'~')
            IF (KK.EQ.1) GOTO 90000                    !~~ = that's the end
            IF (KK.LE.0)
     +         CALL STETER(91,'Wrong string in key "P2"...')
            M = NOOFF + KK - 2                        !avoid final ~
            LINE(1:) = CBUF(NOOFF:M)//' '
            NOOFF = NOOFF + KK 
            ILIN = JM(NOREC)
            IPOS = JM(NOREC+1)
            NOREC = NOREC + 2
            GOTO 6360                                 !get next label
         ENDIF
         GOTO 6900                                    !we're done
      ENDIF
C 
C  here we write into the alphanumerics/overlay plane via Cursor 
C  alpha-mem not possible for XWindow environment...
C 
      IF (DISPMO.EQ.'A') 
     +   CALL STETER(2,'Cursor input not possible for alpha memory...')
C 
C  for Cursor input we enable first cursor 0, shape = 0, colour = 0, + loop
      CALL SETCUR(QDSPNO,0,2,0,COOS,STAT) 
6500  CALL CURSIN(QDSPNO,0,0,XY1,MEMO1,STAT,XY2,MEMO2,STAT)   !bind interaction
C 
6600  CALL CURSIN(QDSPNO,1,0,XY1,MEMO1,IAV,XY2,MEMO2,STAT) 
      IF (IAV.EQ.0) THEN
         FRAME(1:) = 'Please, use ENTER not EXIT button ... '
         CALL STTDIS(FRAME,0,STAT)
         CALL IIISTI(QDSPNO,STAT)
         GOTO 6500
      ENDIF
      IPOS = XY1(1) + 1                                      !offset of 1 pixel
      ILIN = XY1(2) + 1
      IF (DISPMO.NE.'A') THEN                                !overlay plane
         CALL IIGTXT(QDSPNO,QOVCH,LINE(IOFF:IOFF+NBYTE-1),IPOS,ILIN,
     +               0,0,LABCOL,TXTSIZ,STAT)
      ELSE                                                   !alphanum. plane
         CALL ALPTXC(LINE(IOFF:IOFF+NBYTE-1),IPOS,ILIN,0)
      ENDIF
C 
      IF (COOCNT.EQ.0) THEN
         COOCNT = 1
         LINE(1:) = 'Keep cursor inside display window!!! '
         CALL STTDIS(LINE,0,STAT)
      ENDIF
      LINE(1:) = 'Type new string + RETURN (only RETURN to exit) '//
     +           '+ use Cursor again: '
      CALL STTDIS(LINE,0,STAT)
      IAV = 76
      CALL GETSTR(LINE,IAV)               !get character string
C 
      IF (IAV.GT.0) THEN
         CALL TRUNCC(LINE,IAV,IOFF,NBYTE)
         GOTO 6600
      ENDIF
C 
6900  IF (FILESW.EQ.1) THEN
         GOTO 6030
      ELSE
         GOTO 90000
      ENDIF
C
6906  CALL STTPUT('Problems opening ASCII file...',STAT)
      CALL STETER(1,CBUF)
C
6909  CLOSE(UNIT=33)
      GOTO 90000


C 
C******************************
C 
C  here we handle the HIS colour stuff
C 
C******************************
C 
C  get start values + steps + incrementers as well as table name
7000  LUTSZ = 256
      RD = LUTSZ - 1
      CALL STKRDR('INPUTR',1,10,IAV,RBUF,UNI,NULO,STAT)
      FI = RBUF(1) 
      IF (FI.LT.0.0) FI = 0.0
      IF (FI.GT.360.0) FI = 360.0
      FIEND = RBUF(2)
      IF (FIEND.LT.FI) FIEND = FI
      IF (FIEND.GT.1.0) FIEND = 1.0
      RINCI = RBUF(3)
      IF (RINCI.LT.0.0) RINCI = (FIEND-FI)/RD
C      
      S = RBUF(4)
      IF (S.LT.0.0) S = 0.0
      IF (S.GT.1.0) S = 1.0
      SEND = RBUF(5)
      IF (SEND.LT.S) SEND = S
      IF (SEND.GT.1.0) SEND = 1.0
      RINCS = RBUF(6)
      IF (RINCS.LT.0.0) RINCS = (SEND-S)/RD
C
      H = RBUF(7)
      IF (H.LT.0.0) H = 0.0
      IF (H.GT.1.0) H = 1.0
      HEND = RBUF(8)
      IF (HEND.LT.H) HEND = H
      IF (HEND.GT.360.0) HEND = 360.0
      RINCH = RBUF(9)
      IF (RINCH.LT.0.0) RINCH = (HEND-H)/RD
C      
      CALL STKRDC('P1',1,1,80,IAV,TABLE,UNI,NULO,STAT)
      KSECT = DAZHLD(10)
C      
C-------
C      
C  here the real processing takes place
C      
C-------
C      
C  now loop
      HVALU = H
      SVALU = S
      IVALU = FI
      IAV = 1
C 
      DO 7700, N=1,LUTSZ
         HSI(IAV) = HVALU
         HSI(IAV+1) = SVALU
         HSI(IAV+2) = IVALU
C      
         HVALU = H + (N*RINCH)
         SVALU = S + (N*RINCS)
         IVALU = FI + (N*RINCI)
         IF (RBUF(10).GT.0.) THEN            !continue cyclical
            IF (HVALU.GT.360.) HVALU = HVALU - 360.
            IF (SVALU.GT.1.0) SVALU = SVALU - 1.0
            IF (IVALU.GT.1.0) IVALU = IVALU - 1.0
         ELSE
            IF (HVALU.GT.360.) HVALU = 360.
            IF (SVALU.GT.1.0) SVALU = 1.0
            IF (IVALU.GT.1.0) IVALU = 1.0
         ENDIF
         IAV = IAV + 3
7700  CONTINUE
C
C  convert from HSI -> RGB and send the LUT table to Display
      CALL HSIRGB(2,HSI,RLUT)
      CALL MAKLUT(1,LUTSZ,RLUT,QLUTSZ,RQ)          !rearrange LUT
      CALL WRLUT(QDSPNO,KSECT,1,QLUTSZ,RQ,STAT)
C
C  finally store the tables in "real" Tablefile
      IF (TABLE(1:1).NE.'+') CALL BLDLUT(TABLE,RLUT,STAT)
      GOTO 90000
C
C 
C******************************
C 
C  here we get a string from the Midas command window
C 
C******************************
C
8800  LINE(1:) = ' '
      IAV = 76
      CALL GETSTR(LINE,IAV)                        !get character string
      CALL STKWRC('GETSTR',1,LINE,1,80,UNI,STAT)
      CALL STKWRI('AUX_MODE',IAV,7,1,UNI,STAT)
      GOTO 90000

C 
C******************************
C 
C  here we compute the distance between two cursor positions
C 
C******************************
C
C  zoom/scroll overlay as image channel
9000  CALL DAZZSC(QDSPNO,QOVCH,ZOOMX,SCROLX,SCROLY,STAT)
      HEADR1(1:30) =  'world coords (xs,ys) '
      HEADR1(26:60) = 'world coords (xe,ye) '
      HEADR1(50:80) = 'distance '
C
C  get descriptor or table name for storage of data
      CALL STKRDC('P3',1,1,2,IAV,DRAW,UNI,NULO,STAT)
      TABFLG = 0
      CALL STKRDC('P1',1,1,60,IAV,TABLE,UNI,NULO,STAT) 
      IF (TABLE(1:1).EQ.'+') GOTO 9200           !neither table nor descriptor
C      
      N = INDEX(TABLE,'/D')
      IF (N.LE.0) N = INDEX(TABLE,'/d')
      IF (N.LE.0) THEN
         TABFLG = 1
         CALL STKRDC('P2',1,1,12,IAV,LINE,UNI,NULO,STAT)      !get ident option
         HEADR1(62:) = 'identifier '
         NOFLAG = 0
         IDFLAG = 0
C      
         IF (LINE(1:2).EQ.'ID') THEN
            IDFLAG = 1
         ELSE IF (LINE(1:2).EQ.'NO') THEN
            NOFLAG = 1
            HEADR1(62:) = 'sequence no. '
            N = INDEX(LINE(1:12),',')                  !look for optional start no.
            IF (N.LE.0) THEN
               NOOFF = 0
            ELSE
               CALL GENCNV(LINE(N+1:12),1,1,NOOFF,RD,DD,N)
               IF (N.LE.0) NOOFF = 1
               NOOFF = NOOFF - 1
            ENDIF
         ENDIF
C      
         NCOLS = 6
         NCOLS1 = NCOLS - 1                        !no. of pure data columns
C      
C  create (NCOLS+10)*100 table to have already columns allocated for later use
C  (for speed reasons)
C 
         CALL TBTINI(TABLE,0,F_O_MODE,NCOLS+10,100,TID,STAT)      
         TABUNI = 'WORLD COORD '
         DO 9100 IAV=1,NCOLS1                  !and define the columns
            CALL TBCINI(TID,D_R4_FORMAT,1,'G12.6',TABUNI,
     +                  TABLAB(IAV),TCOLNM(IAV),STAT)
9100     CONTINUE
C      
C  handle label column
         CALL TBCINI(TID,D_C_FORMAT,8,'A8',TABUNI,
     +               TABLAB(NCOLS+1),TCOLNM(NCOLS+1),STAT)
C      
C  handle optional number column
         IF (NOFLAG.EQ.1)
     +      CALL TBCINI(TID,D_I4_FORMAT,1,'I8',TABUNI,
     +                  TABLAB(NCOLS),TCOLNM(NCOLS),STAT)
C      
C  check option for descriptor business
      ELSE
         DESCR(N:) = ' '                        !clear descriptor name
         CALL STKRDC('P2',1,1,1,IAV,APPFLG,UNI,NULO,STAT)
         IF (APPFLG.EQ.'A') THEN                !see, if data is to be appended
            FELEM = -1
         ELSE
            FELEM = 1
         ENDIF
      ENDIF
C
C  get max. coord readings
9200  CALL STKRDI('CURSOR',1,1,IAV,COOMAX,UNI,NULO,STAT)
C      
C  set up cursor #1 as open white cross
      CALL SETCUR(QDSPNO,0,3,2,COOS,STAT)
      CALL STTPUT(HEADR1,STAT)
      COOCNT = 0
      COOFF = 0
      NOREC = 1
      FRAME(1:) = ' '
C      
C  read cursor position(s)
9300  IF (COOCNT.GE.COOMAX) THEN
         GOTO 9900                              !limit reached...
      ELSE
         IF (IDFLAG.EQ.1) THEN                  !if we use id's,
            CALL STKPRC(PROMPT,'INPUTC',1,1,8,IAV,IDF,
     +                  UNI,NULO,STAT)               !get id + cursor value
            IF (IDF.EQ.' ') IDF = OLDIDF
            OLDIDF = IDF
         ELSE
            WRITE(IDF(3:),10010) COOCNT+1
         ENDIF
      ENDIF
C      
9400  CALL GETCUR
     +     (CACT,FRAME,XY1,PCUR1(1),PCUR1(3),VAL,ST1,
     +                 XYDUM,RBUF(1),RBUF(3),VAL,ST2)
      IF (ST1.EQ.0) THEN
         IF ((COOCNT.EQ.0).AND.(COOFF.EQ.0)) THEN
            FRAME(1:) = ' '                    !reinitialize for GETCUR
            COOFF = 1
            CALL STTDIS
     +      ('switch cursor on - next time we exit...',0,STAT)
            GOTO 9400
         ELSE
            GOTO 9900
         ENDIF
      ENDIF
C 
9440  CALL GETCUR
     +     (CACT,FRAME,XY2,PCUR2(1),PCUR2(3),VAL,ST1,
     +                 XYDUM,RBUF(1),RBUF(3),VAL,ST2)
      IF (ST1.EQ.0) THEN
         IF ((COOCNT.EQ.0).AND.(COOFF.EQ.0)) THEN
            FRAME(1:) = ' '                    !reinitialize for GETCUR
            COOFF = 1
            CALL STTDIS
     +      ('we need 2. cursor input - next time we exit...',0,STAT)
            GOTO 9440
         ELSE
            GOTO 9900
         ENDIF
      ENDIF
C
      COOCNT = COOCNT + 1            !update coordinate counter
      REA(1,NOREC) = PCUR1(3)
      REA(2,NOREC) = PCUR1(4)
      REA(3,NOREC) = PCUR2(3)
      REA(4,NOREC) = PCUR2(4)
C      
C now we compute the distance
      RDX = (REA(1,NOREC) - REA(3,NOREC))
      RDY = (REA(2,NOREC) - REA(4,NOREC))
      REA(5,NOREC) = SQRT( RDX*RDX + RDY*RDY )
C      
C  if desired, draw connecting line into overlay plane
      IF (DRAW(2:2).EQ.'Y') THEN
         XFIG(1) = XY1(1)
         YFIG(1) = XY1(2)
         XFIG(2) = XY2(1)
         YFIG(2) = XY2(2)
         CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,2,255,1,STAT)
      ENDIF
C      
C  display line with complete info
      WRITE(LINE,10001) (REA(N,NOREC),N=1,5),LABL
      CALL STTPUT(LINE,STAT)
C      
C  store info also in keyword LINER(10,...)
      CALL STKWRR('LINER',REA(1,NOREC),10,5,UNI,STAT)
C
C  fill table, if applicable
      IF (TABFLG.EQ.1) THEN
         CALL TBRWRR(TID,COOCNT,NCOLS1,TCOLNM,REA(1,NOREC),STAT)
C      
C  handle label column
         CALL TBEWRC(TID,COOCNT,TCOLNM(NCOLS+1),IDF,STAT)
C      
C  handle optional number column
         IF (NOFLAG.EQ.1) THEN
            N = COOCNT + NOOFF            !determine sequence no.
            WRITE(LABL,10006) N           !put it also into char. string LABL
            CALL TBRWRI(TID,COOCNT,1,TCOLNM(NCOLS),N,STAT)
         ELSE
            LABL = IDF                    !use the IDF
         ENDIF
C      
         GOTO 9300                        !branch to common section
      ENDIF
C      
C  fill descriptor, if applicable
      IF (DESCR(1:1).NE.'+') THEN
         CALL STFOPN(FRAME,D_OLD_FORMAT,0,F_IMA_TYPE,IMNO,STAT)
         IF (NOREC.EQ.10) THEN                        !buffer decriptor LINE...
            CALL STDWRR(IMNO,DESCR,REA,FELEM,50,UNI,STAT)    !fill descriptor
            FELEM = -1
            NOREC = 1
         ELSE
            NOREC = NOREC + 1
         ENDIF
      ENDIF
C      
      GOTO 9300                        !look for more
C
C  That's it folks...
9900  IF (TABFLG.EQ.1) THEN
         CALL TBSINI(TID,STAT)
         CALL TBTCLO(TID,STAT)
      ELSE
         IF ((DESCR(1:1).NE.'?').AND.(NOREC.GT.1)) THEN
            CALL STDWRR(IMNO,DESCR,REA,FELEM,5*(NOREC-1),UNI,STAT)
         ENDIF
      ENDIF
C      
C  save no. of coordinates obtained for subsequent applications
      CALL STKWRI('LINEI',COOCNT,1,1,UNI,STAT)
      GOTO 90000
C 

C
C  that's it folks...
90000 CALL DTCLOS(QDSPNO)
      IF (LABCOL.EQ.0) CALL REFOVR(STAT)     !refresh the overlay, if we delete
      CALL STSEPI
C
C  FORMATS
C 
10000 FORMAT(15X,' ----- image system snapshot -----'//
     +        8X,'Unit = ',A)
10001  FORMAT(2G12.6,1X,2G12.6,G12.6,1X,A)
10006  FORMAT(I4)
10010  FORMAT(I4.4)
10100  FORMAT(A)
C
      END

      SUBROUTINE TRUNCC(LINE,MAXLEN,IOFF,NBYTE)
C 
      IMPLICIT NONE
C      
      INTEGER      IOFF,NBYTE,MAXLEN
      INTEGER      N
C
      CHARACTER    LINE*(*)
C      
C  determine length of string
      NBYTE = 0                        !default to 1 character
C 
      IF (LINE(1:1).EQ.'"') THEN
         IOFF = 2
         DO 100 N=MAXLEN,IOFF,-1
            IF (LINE(N:N).EQ.'"') THEN
               NBYTE = N - 2
               GOTO 500
            ENDIF
100      CONTINUE
      ELSE
         IOFF = 1
         DO 200 N=MAXLEN,IOFF,-1
            IF (LINE(N:N).NE.' ') THEN
               NBYTE = N 
               GOTO 500
            ENDIF
200      CONTINUE
      ENDIF
C 
500   RETURN
      END
