C @(#)idfunc.for 17.1.1.1 (ESO-DMD) 01/25/02 17:39:59 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 000627 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 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:IDIDEV.INC' INCLUDE 'MID_INCLUDE:IDIMEM.INC' C INCLUDE 'MID_INCLUDE:ST_DEF.INC' 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 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