c$DEBUG C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C ASCP - Stick diagrams of predictions from Pickett's program c SPCAT and from ZK's ASROT c C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c This program can display in stick diagram form the predictions made with c Pickett's program SPCAT provided they are first converted into an .ASR c type file with program PISORT c c - many data sets can be displayed simultaneously c - filtering is posssible to exclude lines outside frequency limits c or below an intensity cutoff c - limitations are a total of MAXLIN transitions and quantum number c values within +-127 c c ASC/ASCP have been used in many investigations involving overlapped c vibrational satellites, different isotopomers and complex nuclear c quadrupole structure. C c Publication quality stick diagrams similar to those in this program can c be obtained by using the filtering option and the program ASRGLE, which c produces input for the GLE plotting package. This method has now c been partially superseded by direct GLE output from ASCP itself. C c Stick diagrams produced in this way can be found in: C JMS 184,150(1997) - CHF2Cl, c JMS 189,228(1998) - CH3CCl3, c CPL 276,202(1997) - N2...HCl and c JCP 109,10263(1998) - CHCl=CHCl2 c c Summaries and brief discussions of ASCP are given in the two papers c listed below, which serve as citations of the use of this program: c c Z.Kisiel, E.Bialkowska-Jaworska, L.Pszczolkowski c J.Chem.Phys. 109,10263-10272(1998). c Z.Kisiel, E.Bialkowska-Jaworska, L.Pszczolkowski c J.Mol.Spectrosc. 199,5-12(2000) c c C Version 24.VIII.2000 ----- Zbigniew KISIEL ----- C C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C | http://info.ifpan.edu.pl/~kisiel/prospe.htm | C_________________________/-------------------------------------------------- C C Modification history: C C ca.86: created on HP-150 (XT-compatible) for screen display and printout C on paper ribbon using the HP Thinkjet - the first HP inkjet c printer c 2.92: change from mono MSF5.0 version to colour (routine COLBEE by c L.Pszczolkowski) c 5.10.95: selection of strongest line for first time display of overlaps, C free format input of frequency limits c 30.01.96: addition of CLOSE(2) statement c 23.10.96: patch for input from file converted from SPCAT output c 7.01.97: more fixes for operation on .ASR from .OUT files c 25.03.97: echo file c 2.04.97: default line colour and modified ',' marker option c 10.01.98: creation of ASCP c 23.02.98: modification to also read ASROT files c 16.12.98: use of ANSI.SYS scrapped + port to MSFPS1.0 graphics c 16.01.99: flexible frequency labels c 8.08.99: readable input control file c 5.09.99: graphics compatibility taken up to the level in V32 c 9.08.00: safeguards against crashing out in graphics mode on input c 24.08.00: various incremental modifications + direct GLE output C_____________________________________________________________________________ c c The further down this header the older the comments, though most should c still be applicable. c c ASCP is a derivative of ASC which in turn started as ASPEC and c used only the six asymmetric rotor quantum numbers per transition. C c This program now reads all twelve quantum numbers per transition as c used by SPFIT/SPCAT. This is achieved by reducing NQ from INTEGER*2 c in ASC to INTEGER*1. The downside is that at present the maximum quantum c number value is 127, and 99 (and -9) for the last six quantum numbers c Additional coding still needs be written to extend this, possibly as c used by HMP. c c Note that in the line of output from PISORT the first and third batch c of three quantum numbers are for the upper state and the second and c fourth batch of three are for the lower state. c C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C - program reads standard ASROT results files and allows browsing C through stick diagram representation of calculated spectrum C - altogether up to MAXLIN lines may be read in C - the lines may be in up to MAXFIL files, or in a file concatenated C from a number of ASROT data files C - data from different files may be plotted in different lines styles C and intensities may be scaled by separate population factors c - various highlighting options are available to identify transitions c from the same data set, of same transitions type or with a given value c of a quantum number C - when in graphics mode the H key gives a summary of the available C options C - input of multiple data sets and some filtering can be carried out c on the basis of information placed in a special control file c - output of current graphics for the GLE program can be produced c (files xxx.GLE and xxxn.DAT) which allows Postscript printouts C C----------------------------------------------------------------------------- C C Colour is used to better distinguish C band types and to mark transitions of interest. It is optimized C for 16-colour EGA and VGA modes and widely differing colours are C used to differentiate between a-,b- and c-type transitions, whereas C for a given transition type two different shades of the same colour C differentiate between P- or R- and Q-type transitions. C Transitions with the same value of selected lower state q.number or C from the same data set can be highlighted, the background colour can C also be altered to eliminate a given transition type. C The program will still run on the monochromatic Hercules, in C which case all lines will be plotted in the same colour. C C If control file is to be used instead of interactive input, its contents C should be as follows: C C ---- first column ---- column 29 C | | C filtering (1/0): 1 <- first line C frequency limits: FMIN,FMAX C intensity cutoff: SLIMIT C echo file (1/0): 0 C ------------------------------------------------ C parent data file : PARENT.ASR C more data (1), end (0) : 1 C ------------------------------------------------ C name of data file : STATEA.ASR C intensity rel. to parent: RELINT C line code (1-9) : LSTYLE C more data (1), end (0) : 1 C ------------------------------------------------ C . C . repeat as necessary and terminate input for the last data file as below C . C more data (1), end (0) : 0 C ------------------------------------------------ C C - Fill in appropriate numerical values for FMIN, FMAX, SLIMIT,RELINT c (floating point) and LSTYLE (integer) C - PARENT.ASR and STATEA.ASR are specimen names of data files to be read C in c - RELINT is relative intensity to be used for scaling data relative C to that in file PARENT.ASR c - LSTYLE is line style to be used for plotting scaled data file (1-10) C - if filtering is set to zero then all lines from data files are read in c and the second,third,fourth control lines are ignored C - FSTART,FEND are frequency limits C - SLIMIT is the intensity cutoff, ie lower limit of intensity for C lines to be read in c - the echo file option allows generation of file ECHO.ASC containing c all lines from input .ASR files which satisfy the sort crtiteria C C----------------------------------------------------------------------------- C C S(i) - intensity of line i C SET(i) - number of data set to which the line belongs c NLSET - the number of data sets C NQ(i,1..12) - quantum numbers of line i C NCOLOR(i) - colour for plotting line i C LST(i) - linestyle for plotting line i C DIPOL(i) - dipole type for transition i; 'a', 'b' or 'c' C M(i) - indication of whether the line is an unresolved doublet; 'D' C NLINES - number of lines C F(j) - frequency of j'th line in order of frequency C LNUM(j) - pointer i in S,SET,etc. to information on j'th line in order of C frequency from among all data sets. NOTE that only LNUM C and F are altered on sorting C SETNAM(N) - names of files containing the various data sets C INFSET(N,i)- information on data sets where C i=1 relative intensity, in REAL*4 form via an EQUIVALENCEd c array RELATI() C i=2 linestyle C i=3 number of lines C C----------------------------------------------------------------------------- C C IMPORTANT: C Program uses MSFortran graphics and is optimised for EGA/VGA C graphics. Other SVGA modes can be obtained by modifying the c routine graphicsmode: select the required graphics mode by c uncomenting only one set of MYMODE= and MYROWS= c c Further compilation details below. C_____________________________________________________________________________ C C...Initialization commands for graphics. The three structured C variables contain coordinates: C curpos.row and curpos.col - cursor coordinates (INTEGER*2) C ixy.xcoord and ixy.ycoord - pixel coordinates (INTEGER*2) C wxy.wx and wxy.wy - window coordinates (REAL*8) C C The code in the two INCLUDE files clashes with IMPLICIT statements - so C when using MSF graphics the recomendation is to type everything C explicitly (check with -4Yg compilation switch) C c Uncomment the statements below (and in similar headers in routines c as necessary) MSF5 = MS Fortran 5.0 c PS1 and PS4 = MS Powerstation Fortrans 1.0 and 4.0 c INCLUDE 'FGRAPH.FI' MSF5+PS1 c INCLUDE 'FLIB.FI' PS1 INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 c RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy c c Additional compilation details: c c MSF5 - maximum recommended MAXLIN=12000 c - comment out SUBROUTINE INKEY and link with the ROT5 library c PS1 - MAXLIN tested up to 100000 c - use SUBROUTINE INKEY at the end of listing c - compile without the speed optimisation option c (ie do not use -Ox) c - In WIN95 run from full screen DOS window with Windows detection c turned off and make sure you have the DOSXMSF.EXE extender c PS4 - use the listed SUBROUTINE INKEY c - use the -MWs option on compilation: this selects standard c graphics which works properly only in a window (not c full screen). QuickWin graphics as selected with -MW works c even worse C_____________________________________________________________________________ c PARAMETER (MAXLIN=12000,linmax=maxlin-2,maxfil=20) c CHARACTER L(80),DIPOL(MAXLIN),M(MAXLIN),line*80 CHARACTER FILNAM*30,FILCON*30,CDUMMY CHARACTER*30 SETNAM(maxfil) INTEGER*1 SET(MAXLIN),LST(MAXLIN) REAL*4 S(MAXLIN),SMAX,SLIMIT,relati(maxfil) REAL*8 F(MAXLIN),FMIN,FMAX,FOLD,FSTART,FEND INTEGER*4 LNUM(MAXLIN),INFSET(maxfil,3) INTEGER*2 DUM2 INTEGER*1 NCOLOR(MAXLIN),NQ(MAXLIN,12) EQUIVALENCE (L(1),LINE) COMMON /FRBLK/F/SBLK/S,SMAX,FMIN,FMAX,NLINES COMMON /ORIGLN/SET,LST,NLSET,NCOLOR COMMON /LNUMS/LNUM/DOUBL/M COMMON /QNUMS/NQ COMMON /DIP/DIPOL COMMON /SETINF/INFSET,SETNAM COMMON /limits/maxx,maxy,linofs,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red INTEGER*2 maxx,maxy,linofs,mymode,myrows,mycols INTEGER*4 blue,red equivalence (relati(1),infset(1,1)) C ISORT=0 FOLD=0.D0 RELINT=1.0 NLSET=0 NLINES=0 NLST=1 SMAX=1.E-12 FMIN=1.D30 FMAX=0.D0 NLAST=0 limit=0 C call graphicsmode() if($BLUE.eq.#2a0000)then dummy=setvideomode($DEFAULTMODE) call clearscreen($GCLEARSCREEN) endif c WRITE(*,156)maxlin 156 FORMAT(' Ú',55(1HÄ),'Â',20(1HÄ),'¿'/' ³',T58,'³', * ' ver. 24.VIII.2000',T79,'³'/ * ' ³ A S C P - Stick diagrams of spectra calculated', * T58,'³',' max.',i7,' lines',T79,'³'/ * ' ³ with SPCAT/PISORT or with ASROT', * T58,'³',T79,'³'/' ³',T58,'³',3x,'Zbigniew KISIEL',T79,'³'/ * ' À',55(1HÄ),'Á',20(1HÄ),'Ù'/) c dum2=settextcolor(int2(11)) if($BLUE.ne.#2a0000)then write(*,'(1x,a/)') * ' This program should be run in a maximised window' else write(*,'(1x,a/)') * ' This program should be run in a full screen MS-DOS window' endif dum2=settextcolor(int2(15)) C C C...Read ASROT results file(s) C 70 write(*,1)' Interactive (=1) or batch (=2) input ? ' read(*,*,err=70)iflag if(iflag.lt.1.or.iflag.gt.2)goto 70 c if(iflag.eq.2)then 72 WRITE(*,1)' Name of input control file: ' READ(*,3,ERR=72)FILCON OPEN(4,file=FILCON,ERR=72,status='old') endif c 2 if(iflag.eq.1)then WRITE(*,1)' Name of data file: ' 1 FORMAT(/1X,A\) READ(*,3,ERR=2)FILNAM 3 FORMAT(A) else IF(NLSET.EQ.0)THEN READ(4,300)LIMIT READ(4,301)FSTART,FEND READ(4,301)SLIMIT READ(4,300)IECHO if(IECHO.eq.1)open(5,file='echo.asc',status='unknown') ENDIF READ(4,302)CDUMMY 300 FORMAT(28X,I5) 301 FORMAT(28X,2F20.10) 302 FORMAT(A) READ(4,303)FILNAM 303 FORMAT(28X,A) endif OPEN(2,FILE=FILNAM,access='sequential',form='formatted', * ERR=2,status='old') C NLSET=NLSET+1 SETNAM(NLSET)=FILNAM IF(NLSET.GT.1.AND.IFLAG.EQ.1)THEN 200 WRITE(*,'(1X/'' Population relative to first set: '',$)') READ(*,'(F20.10)',ERR=200)RELINT 201 WRITE(*,'(1X/'' Linestyle to be used for this data set (1-10)'' * /'' (1=continuous, >1 progressively less solid): '',$)') READ(*,'(I5)',ERR=201)NLST IF(NLST.LT.1.OR.NLST.GT.10)GOTO 201 ELSE IF(NLSET.GT.1.AND.IFLAG.EQ.2)THEN READ(4,301)RELINT READ(4,300)NLST IF(NLST.LT.1.OR.NLST.GT.10)NLST=1 ENDIF IF(NLSET.GT.1)THEN relati(NLSET)=RELINT INFSET(NLSET,2)=NLST ELSE relati(NLSET)=1.0 INFSET(NLSET,2)=1 ENDIF C C...read line of data file 5 READ(2,3,ERR=4,END=4)LINE C C...check whether the line begins with a frequency IF(L(8).NE.'.')GOTO 5 NLINES=NLINES+1 IF(NLINES.GT.LINMAX)THEN WRITE(*,41)LINMAX,CHAR(7) 41 FORMAT(1X/' LINE MAXIMUM OF',I6,', REACHED, no more lines', * ' will be read in',A/) NLINES=NLINES-1 INFSET(NLSET,3)=NLINES-NLAST GOTO 40 ENDIF c c...read line information assuming it is a single line: c c......single PICKETT line (ie six quantum numbers per state), as written c by PISORT in pseudo ASROT output c READ(LINE,6,ERR=55)F(NLINES),S(NLINES),(NQ(NLINES,I),I=1,6), *DIPOL(NLINES),(nq(nlines,i),i=7,12) 6 FORMAT(F14.6,1PE10.2,2X,I3,1X,I3,1X,I3,I5,1X,I3,1X,I3,1X,A1, * 1x,i2,1x,i2,1x,i2,2x,i2,1x,i2,1x,i2) goto 56 c c......single genuine ASROT line c 55 READ(LINE,6,ERR=555)F(NLINES),S(NLINES),(NQ(NLINES,I),I=1,6), *DIPOL(NLINES) do 57 i=7,12 nq(nlines,i)=0 57 continue goto 56 c 555 nlines=nlines-1 goto 5 c 56 IF(LIMIT.EQ.1)THEN IF(F(NLINES).GT.FEND.OR.F(NLINES).LT.FSTART.OR. * S(NLINES)*RELINT.LT.SLIMIT)THEN NLINES=NLINES-1 GOTO 5 ENDIF ENDIF if(iecho.eq.1)write(5,'(a)')line c C Column numbers in ASROT results file: C c ,....1....,....2....,....3....,....4....,....5....,....6 c 25661.627755 1.42E-06 21, 1, 20 20, 1, 19 a.R 0, 1 20.952330 9.275 c 25665.205994 1.49E-07 D 21, 19, 20, 19, a.R 0, 1 3.809524 266.428 c 25665.205994 1.49E-07 D 21, , 19 20, , 19 a.R 0, 1 3.809524 266.428 C C...check whether the line is not a doublet and take appropriate action IF(L(26).NE.'D')GOTO 31 C C...implied K+1 IF(L(37).EQ.' ')THEN NQ(NLINES,3)=NQ(NLINES,1)-NQ(NLINES,2) NQ(NLINES,6)=NQ(NLINES,4)-NQ(NLINES,5) ENDIF C C...implied K-1 IF(L(33).EQ.' ')THEN NQ(NLINES,2)=NQ(NLINES,1)-NQ(NLINES,3) NQ(NLINES,5)=NQ(NLINES,4)-NQ(NLINES,6) ENDIF C 31 IF(F(NLINES).LT.FOLD)ISORT=1 FOLD=F(NLINES) M(NLINES)=L(26) IF(L(26).EQ.'D')S(NLINES)=S(NLINES)*0.5 S(NLINES)=S(NLINES)*RELINT IF(S(NLINES).GT.SMAX)SMAX=S(NLINES) SET(NLINES)=NLSET LST(NLINES)=NLST IF(F(NLINES).LT.FMIN)FMIN=F(NLINES) IF(F(NLINES).GT.FMAX)FMAX=F(NLINES) GOTO 5 C 4 WRITE(*,7)NLINES,NLINES-NLAST,FILNAM,FMIN,FMAX,SMAX 7 FORMAT(1X//' ****',I5,' lines read altogether, ', * I5,' from file: ',A/ * ' lowest frequency: ',F10.2,' MHz'/ * ' highest frequency: ',F10.2,' MHz'/ * ' maximum intensity: ',1PE10.2,' cm-1'/) INFSET(NLSET,3)=NLINES-NLAST NLAST=NLINES close(2) IF(IFLAG.EQ.1)THEN 12 WRITE(*,1)' Any more files (1/0) ? ' READ(*,11,ERR=12)I IF(I.LT.0.OR.I.GT.1)GOTO 12 11 FORMAT(I5) ELSE READ(4,300)I ENDIF IF(I.EQ.1)GOTO 2 IF(IFLAG.EQ.2)CLOSE(4) if(iecho.eq.1)close(5) C C...sort C 40 if(nlines.le.0)stop DO 10 I=1,NLINES LNUM(I)=I 10 CONTINUE IF(ISORT.EQ.1)THEN WRITE(*,20) 20 FORMAT(1X//' **** SORTING lines'/) NSTART=1 CALL SORTH(NSTART,NLINES) ENDIF C C...plot and move about on the stick diagram C DUM2=0 CALL COLBEE(SET(1),' ',DUM2,DUM2,DUM2) CALL PLOTS C STOP END C C_____________________________________________________________________________ C SUBROUTINE COLBEE(DUM1,DUMC,DUM2,DDET,JJ) C C...This routine is executed immediately prior to plotting and assigns C colour values to each line (stored in NCOLOR) C C DUM1 = data set number from which lines are to be highlighted C (highlight transitions from all sets if negative) C DUMC = type of dipole transition to be highlighted; 'a','b' or 'c' C DUM2 = type of selection rule in J to be highlighted, or transition C type to be highlighted C DDET = type of quantum number to be highlighted (1 to 6 select the six C lower state quantum numbers) C if set to 0 then colours are reset C if set to -1 then all lines of a given set are highlighted C if set to -2 then all lines of a given transition type are C highlighted C JJ = value of quantum number to be highlighted C c N O T E: DUMC and DUM2 rules are currently disabled C PARAMETER (MAXLIN=12000) c CHARACTER DIPOL(MAXLIN),M(MAXLIN),DUMC INTEGER*1 SET(MAXLIN),LST(MAXLIN),DUM1 REAL*4 S(MAXLIN),SMAX REAL*8 F(MAXLIN),FMIN,FMAX INTEGER*4 LNUM(MAXLIN),I,J INTEGER*2 JJ,DDET,dddet,DUM2 INTEGER*1 NCOLOR(MAXLIN),NQ(MAXLIN,12) COMMON /FRBLK/F/SBLK/S,SMAX,FMIN,FMAX,NLINES COMMON /ORIGLN/SET,LST,NLSET,NCOLOR COMMON /LNUMS/LNUM/DOUBL/M COMMON /QNUMS/NQ COMMON /DIP/DIPOL C C...H i g h l i g h t s e l e c t e d l i n e s C IF(DDET.EQ.0) GOTO 20 C IF(DDET.EQ.-2)THEN DO 22 I=1,NLINES J=LNUM(I) IF(SET(J).NE.DUM1.AND.DUM1.GT.0) GOTO 22 c IF(DIPOL(J).NE.DUMC)GOTO 22 JD=(int2(NQ(J,1))-int2(NQ(J,4)))*100+(int2(NQ(J,2))- * int2(NQ(J,5)))*10+(int2(NQ(J,3))-int2(NQ(J,6))) c IF(JD.NE.DUM2)GOTO 22 NCOLOR(J)=15 22 CONTINUE ENDIF C IF(DDET.EQ.-1.OR.DDET.GT.0)THEN DO 10 I=1,NLINES J=LNUM(I) IF(SET(J).NE.DUM1.AND.DUM1.GT.0) GOTO 10 IF(DDET.NE.-1)THEN c IF(DIPOL(J).NE.DUMC) GOTO 10 JD=int2(NQ(J,1))-int2(NQ(J,4))+2 c IF(JD.NE.DUM2) GOTO 10 dddet=(ddet/4+1)*3+ddet IF( JJ.EQ.int2(NQ(J,ddDET))) NCOLOR(J)=15 ELSE NCOLOR(J)=15 ENDIF 10 CONTINUE ENDIF C RETURN C C C...R e s e t c o l o u r s C C 0 - black 4 - red 8 - dark grey 12 - light red C 1 - blue 5 - magenta 9 - light blue 13 - light magenta C 2 - green 6 - brown 10 - light green 14 - yellow C 3 - cyan 7 - white 11 - light cyan 15 - bright white C 20 DO 11 I=1,NLINES J=LNUM(I) JD=int2(NQ(J,1))-int2(NQ(J,4))+2 C C...assign default colour for transition with unknown selection rules, c defined by DIPOL(J) not equal to a, b or c c NCOLOR(J)=13 C C...a-type transitions (P,R=red, Q=dark red) C IF(DIPOL(J) .EQ.'a' ) THEN if(JD.EQ.2 ) THEN c...Q-type line NCOLOR(J)=4 else c...jd=1 -> 'P' , jd= 3 -> 'R' NCOLOR(J)=12 endif GOTO 11 ENDIF C C...b-type transitions (P,R=green, Q=dark green) C IF(DIPOL(J) .EQ.'b' ) THEN if(JD.EQ.2 ) THEN c...Q-type line NCOLOR(J)=2 else c...jd=1 -> 'P' , jd= 3 -> 'R' NCOLOR(J)=10 endif GOTO 11 ENDIF C C...c-type transitions (P,R=cyan, Q=dark cyan) C IF(DIPOL(J) .EQ.'c' ) THEN if(JD.EQ.2 ) THEN c...Q-type line NCOLOR(J)=1 else c...jd=1 -> 'P' , jd= 3 -> 'R' NCOLOR(J)=9 endif ENDIF 11 CONTINUE C RETURN END C_____________________________________________________________________________ C SUBROUTINE PLOTS C C This routine handles all the operations while in graphics mode, C details of screen refresh are handled by routine STICKS C INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*1 MARK [ALLOCATABLE] (:) C LOGICAL*2 true PARAMETER (MAXLIN=12000,TRUE=.TRUE.,maxfil=20) c REAL*4 S(MAXLIN),SMAX REAL*8 F(MAXLIN),FMIN,FMAX,F1,F2,FMARK,FSTEP,FSHIFT,FL,FH, * FF1,FF2 INTEGER*1 SET(MAXLIN),LST(MAXLIN),DUMSET REAL*8 RMBOT,RMTOP,RSMALL,RLARGE,YSTEP,FCDET,RM INTEGER*4 LNUM(MAXLIN),INFSET(maxfil,3),ifmark,i,ifl,ifh,N, * L,JDET INTEGER*2 IK,inkey,j,JCDET INTEGER*2 INTADD,LINDET,NLDET,DUMmy2,DDET,dddet,JD CHARACTER KK,DIPOL(MAXLIN),M(MAXLIN),TYPETR(4), * OUTSTR*21,DTOP*3 CHARACTER*30 SETNAM(maxfil) INTEGER*2 maxx,maxy,mymode,myrows,mycols,linofs CHARACTER*79 toplin,botlin,emplin,inf,seclin INTEGER*4 imsize,DUMmy4,BKC,CDDET,blue,red,bkcol INTEGER*1 NCOLOR(MAXLIN),NQ(MAXLIN,12) INTEGER*4 bkcolor(8) / + $BLACK, $BLUE , $GREEN, $CYAN, + $RED , $MAGENTA, $BROWN, $WHITE / COMMON /limits/maxx,maxy,LINOFS,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red COMMON /ORIGLN/SET,LST,NLSET,NCOLOR COMMON /FRBLK/F/SBLK/S,SMAX,FMIN,FMAX,NLINES COMMON /QNUMS/NQ COMMON /LNUMS/LNUM/DOUBL/M COMMON /DIP/DIPOL COMMON /LINES/toplin,botlin,emplin,seclin COMMON /SETINF/INFSET,SETNAM real*4 relati(maxfil) equivalence (relati(1),infset(1,1)) C DATA TYPETR/'P','Q','R',' '/ INTADD=-1 lindet=+1 IFMARK=1 L=1 JDET=1 C C...Initialize graphics C call graphicsmode() c F1=FMIN F2=FMAX FMARK=0.5D0*(F1+F2) RLARGE=SMAX C c...various patches to account for differences in FORTRANs and resolutions c BKC=2 if($BLUE.ne.#2a0000)then do 900 L=1,8 bkcolor(L)=L-1 900 continue BKC=4 endif c if(mycols.eq.80)then itxt=0 else itxt=(mycols-80)/2 endif c if(((maxy+1)/myrows)*myrows.eq.maxy+1)then incr=0 else incr=maxy-(maxy/myrows)*myrows endif c c NHORPT=maxx+1 dummy4 = setbkcolor( bkcolor(BKC) ) DUMmy2=settextcolor(15) DDET=0 JCDET=0 C C...Definition of graphics viewport C (note that pixel origin for SETWINDOW command will now be top-left corner C at absolute {0,linofs+1}) C maxxy=maxy-2*linofs-1 call setviewport(0,linofs+1,maxx,maxxy) YSTEP=1.d0/DBLE(maxy-(5*linofs+incr)-2)*RLARGE RSMALL=-(2*linofs+incr)*YSTEP DUMmy2=setwindow(true,F1,RSMALL,F2,RLARGE) C C...generation of dotted cursor bar for future use (this is a leftover C from MSF5 which does not have the $GXOR mode for line drawing as C enabled by routine SETWRITEMODE) C $NODEBUG CALL setlinestyle(int2(#3333)) $DEBUG RMTOP=RLARGE/3.d0 RMBOT=RSMALL CALL clearscreen($GVIEWPORT) if($BLUE.ne.#2a0000)then DUMMY2=SETCOLOR(int2(10)) else DUMMY2=SETCOLOR(int2(14)) endif CALL moveto_w(FMARK,RMBOT,wxy) dummy2=lineto_w(FMARK,RMTOP) imsize=imagesize_w(FMARK,RMTOP,FMARK,RMBOT) ALLOCATE (MARK(imsize)) CALL getimage_w(FMARK,RMTOP,FMARK,RMBOT,MARK) c call putimage_w(FMARK,RMTOP,MARK,$GXOR) $NODEBUG CALL setlinestyle(int2(#FFFF)) $DEBUG DUMMY2=SETCOLOR(int2(15)) C C Beginning of main display loop which is executed each time a change in C the display is performed C (note that in MSPS4.0 the $GVIEWPORT command does not set the background c colour so that only $GCLEARSCREEN is used from now on) C C...Bordering horizontal lines C 7 CALL clearscreen($GCLEARSCREEN) call setviewport(0,0,maxx,maxy) CALL moveto(int2(0),int2(2*linofs+1),ixy) dummy2=lineto(maxx,int2(2*linofs+1)) C call setviewport(1,2*linofs+2,maxx,maxy-linofs-1) C C...PLOT - redefine floating-point window, clear and plot C dummy2=setwindow(true,F1,RSMALL,F2,RLARGE) $NODEBUG CALL setlinestyle(#FFFF) $DEBUG if($BLUE.ne.#2a0000)then bkcol=bkcolor(bkc) else bkcol=0 endif CALL STICKS(F1,F2,FSTEP,RM,RLARGE,YSTEP,INTADD,itxt,bkcol) c c...cursor and heading (if transition information is wanted on the header c then a jump to transition inspection code at label 230 is made - return c is to label 1) C RMTOP=RLARGE/3.d0 call putimage_w(FMARK,RMTOP,MARK,$GXOR) c if(lindet.gt.0)goto 230 WRITE(toplin,120)FMARK 120 FORMAT(' Cursor: ',F11.3) dummy2=settextcolor(15) seclin=emplin CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(toplin) CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(seclin) c C...option selection C 1 IK=INKEY(j) KK=CHAR(IK) IF(KK.EQ.'Q'.OR.KK.EQ.'q')GOTO 11 IF(KK.EQ.'E'.OR.KK.EQ.'e')GOTO 10 IF(KK.EQ.'b'.OR.KK.EQ.'B')GOTO 12 IF(KK.EQ.'a'.OR.KK.EQ.'A')GOTO 14 IF(KK.EQ.'S'.OR.KK.EQ.'s')GOTO 15 IF(KK.EQ.'W'.OR.KK.EQ.'w')GOTO 17 IF(KK.EQ.'Z'.OR.KK.EQ.'z')GOTO 16 IF(KK.EQ.'K'.OR.KK.EQ.'k')GOTO 19 IF(KK.EQ.'L'.OR.KK.EQ.'l')GOTO 18 IF(KK.EQ.',')GOTO 1018 IF(KK.EQ.'O'.OR.KK.EQ.'o')GOTO 20 IF(KK.EQ.'Y'.OR.KK.EQ.'y')GOTO 21 IF(KK.EQ.'F'.OR.KK.EQ.'f')GOTO 22 IF(KK.EQ.'H'.OR.KK.EQ.'h')GOTO 23 IF(KK.EQ.'P'.OR.KK.EQ.'p')GOTO 24 IF((KK.EQ.'-'.or.KK.eq.'_').AND.TOPLIN(21:21).EQ.'.')GOTO 2400 IF((KK.EQ.'+'.or.KK.eq.'=').AND.TOPLIN(21:21).EQ.'.')GOTO 2401 IF(KK.EQ.'C'.OR.KK.EQ.'c')GOTO 25 IF(KK.EQ.'D'.OR.KK.EQ.'R')GOTO 26 IF(KK.EQ.'d'.OR.KK.EQ.'r')GOTO 27 IF(KK.EQ.'I'.OR.KK.EQ.'i')GOTO 28 IF(KK.EQ.'T'.OR.KK.EQ.'t')GOTO 29 IF(KK.EQ.'G'.or.KK.EQ.'g')GOTO 30 IF(IK.NE.13)GOTO 1 C C...exit control C dummy2=settextcolor(15) dummy4 = setbkcolor( RED ) CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(emplin) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(emplin) WRITE(outstr,'(A)')'ARE YOU SURE (Y/N) ?' CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(outstr(1:20)) CALL settextposition(1,int2(itxt+26),curpos) WRITE(*,'(1X,A1,$)')CHAR(7) 916 IK=INKEY(j) KK=CHAR(IK) IF(KK.EQ.'Y'.OR.KK.EQ.'y')GOTO 915 IF(KK.NE.'N'.AND.KK.NE.'n')THEN GOTO 916 ENDIF dummy4 = setbkcolor( bkcolor(BKC) ) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(toplin) CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(seclin) GOTO 7 915 DEALLOCATE(MARK) dummy2=setvideomode($DEFAULTMODE) GOTO 100 C C...zoom-in in frequency C 10 FR=F2-F1 FINCR=0.25D0*FR IF(KK.EQ.'e')FINCR=0.45D0*FR F1=FMARK-FINCR if(f1.lt.0.d0)f1=0.d0 F2=FMARK+FINCR if(f1.lt.0.d0)then f1=0.d0 f2=2.d0*fmark endif GOTO 7 C C...zoom-out in frequency C 11 FR=F2-F1 FINCR=0.25D0*FR IF(KK.EQ.'q')FINCR=0.05D0*FR F1=F1-FINCR IF(F1.LT.0.D0)THEN F1=0.D0 CALL settextposition(1,int2(itxt+1),curpos) WRITE(*,101)CHAR(7) ENDIF 101 FORMAT(1X,A1,$) F2=F2+FINCR GOTO 7 C C...back to original settings C 12 F1=FMIN F2=FMAX FMARK=0.5D0*(F1+F2) RLARGE=SMAX GOTO 161 C C...shift of viewing window to the left C 14 FR=F2-F1 FSHIFT=FR*0.5D0 IF(KK.EQ.'a')FSHIFT=FR*0.1D0 F1=F1-FSHIFT IF(F1.LT.0.D0)THEN F1=0.D0 FSHIFT=F2-(F1+FR) CALL settextposition(1,int2(itxt+1),curpos) WRITE(*,101)CHAR(7) ENDIF F2=F2-FSHIFT FMARK=FMARK-FSHIFT GOTO 7 C C...shift of viewing window to the right C 15 FR=F2-F1 FSHIFT=FR*0.5D0 IF(KK.EQ.'s')FSHIFT=FR*0.1D0 F1=F1+FSHIFT F2=F2+FSHIFT FMARK=FMARK+FSHIFT GOTO 7 C C...zoom-out in height C 16 HMULT=2.D0 IF(KK.EQ.'z')HMULT=1.1D0 RLARGE=HMULT*RLARGE 161 YSTEP=1.d0/DBLE(maxy-(5*linofs+incr)-2)*RLARGE RSMALL=-(2*linofs+incr)*YSTEP GOTO 7 C C...zoom-in in height C 17 HMULT=0.5D0 IF(KK.EQ.'w')HMULT=0.95D0 RLARGE=HMULT*RLARGE GOTO 161 C C...Shift of cursor to the left (with K) C 19 call putimage_w(FMARK,RMTOP,MARK,$GXOR) FMARK=FMARK-8.D0*FSTEP IF(KK.EQ.'k')FMARK=FMARK+7.D0*FSTEP IF(FMARK.LT.F1)FMARK=F1 C 719 call putimage_w(FMARK,RMTOP,MARK,$GXOR) if(lindet.gt.0)goto 230 720 WRITE(toplin,120)FMARK seclin=emplin 721 DUMMY2=SETTEXTCOLOR(15) 722 CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(toplin) CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(seclin) IF(DDET.LE.0 .OR. NLDET.EQ.0) GOTO 1 C C...change colour of selected quantum number when highlighting lines dddet=(ddet/4+1)*3+ddet IF ( JCDET.EQ.int2(NQ(L,DDdET))) THEN WRITE(dtop,'(I3)')NQ(L,DdDET) DUMMY2=SETTEXTCOLOR( CDDET) dddet=ddet-(ddet/4)*3 CALL settextposition(int2(ddet/4+1), * int2(itxt+53+dddet*4),curpos) CALL outtext(dtop) ENDIF GOTO 1 C C...Shift of cursor to the right (with L) C 18 call putimage_w(FMARK,RMTOP,MARK,$GXOR) FMARK=FMARK+8.D0*FSTEP IF(KK.EQ.'l')FMARK=FMARK-7.D0*FSTEP IF(FMARK.GT.F2)FMARK=F2 GOTO 719 C C...Centre cursor on the screen (with ,) C 1018 call putimage_w(FMARK,RMTOP,MARK,$GXOR) I=1+NINT( 4.D0*(FMARK-F1)/(F2-F1) ) IF(I.GE.4)I=1 FMARK=F1+0.25D0*REAL(I)*(F2-F1) GOTO 719 C C...Write information on lines centred on the cursor (with O) C 20 CALL HUNTF(NLINES,FMARK,IFMARK) ihalf=(myrows-5)/2 I=IFMARK IF(I.EQ.0)I=1 IF(I.EQ.NLINES)I=NLINES-1 IF(DABS(F(I+1)-FMARK).LT.DABS(F(I)-FMARK))I=I+1 IST=I-ihalf IF(IST.LT.1)IST=1 IFIN=I+ihalf IF(IFIN.GT.NLINES)IFIN=NLINES 111 CALL clearscreen($GCLEARSCREEN) iline=0 c DO 103 J=IFIN,IST,-1 iline=iline+1 L=LNUM(J) IK=SET(L) IF(IK.LT.10)KK=CHAR(48+IK) IF(IK.GT.9)KK=CHAR(55+IK) JD=int2(NQ(L,1))-int2(NQ(L,4))+2 if(jd.lt.1.or.jd.gt.3)jd=4 JKM=int2(NQ(L,2))-int2(NQ(L,5)) JKP=int2(NQ(L,3))-int2(NQ(L,6)) IF(J.EQ.I .or. J.EQ.I-1 ) iline=iline+1 DUMMY4=NCOLOR(L) if( dummy4.lt.0.or.dummy4.gt.15)dummy4=15 if(jd.lt.1.or.jd.gt.3)jd=4 DUMMY2=SETTEXTCOLOR( DUMMY4 ) c c WRITE(inf,104)KK,F(J),S(L),M(L),(NQ(L,II),II=1,6), c * DIPOL(L),TYPETR(JD),JKM,JKP c104 FORMAT(2X,A1,': ',F14.6,1PE11.2,3X,A1,I6,2(',',I3), c * ' <--',I4,2(',',I3) ,5X,A1,'.',A1,I2,',',I2) c WRITE(inf,1104)KK,F(J),S(L),(NQ(L,II),II=1,3), * (NQ(L,II),II=7,9),(NQ(L,II),II=4,6),(NQ(L,II),II=10,12) 1104 FORMAT(1X,A1,':',F15.6,1PE11.2, * I5,',',I3,',',I3,i4,',',i2,',',i2,' <--', * I4,',',I3,',',I3,i4,',',I2,',',I2 ) 102 CALL settextposition(int2(iline),int2(itxt+1),curpos) CALL outtext(inf) 103 CONTINUE c 231 DUMmy2=settextcolor(15) WRITE(inf,106) 106 FORMAT(' Use W,Z keys to scroll',18X, * 'ENTER returns to the stick display ',$) CALL settextposition(myrows,int2(itxt+1),curpos) CALL outtext(inf) c 107 IK=INKEY(J) IF(IK.EQ.0)GOTO 107 IF(IK.EQ.13)THEN dummy4 = setbkcolor( bkcolor(BKC) ) GOTO 7 ENDIF kk=char(ik) IF(KK.EQ.'W'.or.KK.EQ.'w')THEN IST=IST+20 IFIN=IFIN+20 IF(IFIN.GT.NLINES)THEN IST=NLINES-20 IFIN=NLINES ENDIF GOTO 111 ENDIF IF(KK.EQ.'Z'.or.KK.EQ.'z')THEN IST=IST-20 IFIN=IFIN-20 IF(IST.LT.1)THEN IST=1 IFIN=20 ENDIF GOTO 111 ENDIF GOTO 107 C C...Write the help text (with H) C 23 dummy4=setbkcolor(BLUE) DUMmy2=settextcolor(15) CALL clearscreen($GCLEARSCREEN) write(*,'(1x)') WRITE(*,232) 232 FORMAT( ' SUMMARY OF COMMANDS ACTIVE IN GRAPHICS MODE:'/ * 1x,44(1HÄ)// * ' W/Z - change vertical scaling'/ * ' Q/E - change horizontal scaling'/ * ' A/S - shift spectrum left/right'/ * ' K/L/, - move cursor left/right/quarter'/ * ' caps on/off - fast/slow change in the above'// * ' B - rescale spectrum to initial conditions'/ * ' O/I - information on displayed lines/data sets'/ * ' P - toggle cursor between spot-frequency/line-', * 'information') WRITE(*,2321) 2321 FORMAT( * ' F - change frequency limits'/ * ' Y - add/do-not-add intensities of overlapped ' * 'lines'/ * ' C - toggle background color'/ * ' D/R - higlight lines with selected qn''s from', * ' current/all sets'/ * ' d/r - higlight all lines from current/', * 'all data sets'/ * ' G - produce GLE output of current screen'// * ' M(N,s:L) stands for M unresolved lines under the cursor,' * /15x,'the parameters of line N from set L are currently'/ * 15x,'displayed and N can be toggled with the +/- keys)'// c * ' t/T - higlight selected transition type from', c * ' current/all sets'// * ' Exit from the graphics is by ENTER followed by Y'/ * ' Exit from this help screen is by pressing ENTER ',$) GOTO 107 C C...Toggle addition of intensities of overlapping lines (with 'Y' or 'y') C 21 INTADD=-INTADD GOTO 7 C C...Frequency limits from keyboard (with 'F' or 'f') C 22 dummy4=setbkcolor(blue) DUMmy2=settextcolor(15) CALL clearscreen($GCLEARSCREEN) write(*,'(1x)') WRITE(*,304)FMIN,FMAX,F1,F2,fmark 304 FORMAT(1X//' Frequency limits of data: ',2F12.3/ * ' Frequency limits of display: ',2F12.3/ * ' Frequency of cursor: ',6x,f12.3/// * ' New diplay limits (pressing just ', * 'ENTER keeps previous value):'/) 302 WRITE(*,300)' Lower frequency display limit: ',F1 300 FORMAT(1X,A,F12.3,' --> ',\) READ(*,'(f20.0)',ERR=302)FF1 IF(FF1.LT.0.D0.OR.FF1.GT.FMAX)GOTO 302 IF(FF1.gt.0.d0)F1=FF1 303 WRITE(*,300)' Upper frequency display limit: ',F2 READ(*,'(f20.0)',ERR=303)FF2 If(ff2.ne.0.0d0)then IF(FF2.LE.F1.OR.FF2.LT.FMIN)GOTO 303 F2=FF2 else if(f2.lt.f1)goto 303 endif FMARK=0.5D0*(F1+F2) dummy4 = setbkcolor( bkcolor(BKC) ) GOTO 7 C C C...Toggle display of cursor information (with 'P' or 'p') C C Variable LINDET which is either +1 or -1 is used as pointer - information C on lines underlying the cursor is only displayed for positive values. C 24 LINDET=-LINDET IF(LINDET.EQ.-1)GOTO 720 C C...if JUSTPL=1 then a jump straight to display for cases (such as C highlighting) for which the identification of overlaps has already C been made. 230 IF(JUSTPL.EQ.1)THEN JUSTPL=0 GOTO 235 ENDIF C C...Identify overlapped lines - as range of lines IFL,IFH and set the display C pointer JDET to the strongest line FL=FMARK-0.5D0*FSTEP FH=FMARK+0.5D0*FSTEP CALL HUNTF(NLINES,FL,IFL) IFL=IFL+1 IFH=IFL CALL HUNTF(NLINES,FH,IFH) NLDET=IFH-IFL+1 JDET=IFL IF(NLDET.GT.1)THEN STRONG=S(LNUM(IFL)) DO 2231 N=IFL+1,IFH IF(S(LNUM(N)).GT.STRONG)THEN JDET=N STRONG=S(LNUM(N)) ENDIF 2231 CONTINUE ENDIF C C...Write header line 235 IF(NLDET.EQ.0)THEN WRITE(toplin,228)FMARK seclin=emplin GOTO 721 228 FORMAT('Cursor:',3X,F15.4) ELSE L=LNUM(JDET) IK=SET(L) IF(IK.LT.10)KK=CHAR(48+IK) IF(IK.GT.9)KK=CHAR(55+IK) JD=int2(NQ(L,1))-int2(NQ(L,4))+2 JKM=int2(NQ(L,2))-int2(NQ(L,5)) JKP=int2(NQ(L,3))-int2(NQ(L,6)) if(jd.lt.1.or.jd.gt.3)jd=4 if(dipol(l).eq.'a'.or.dipol(l).eq.'b'.or.dipol(l).eq.'c')then WRITE(toplin,229)NLDET,JDET-IFL+1,KK,F(JDET),S(L),M(L), * (NQ(L,II),II=1,6),DIPOL(L),TYPETR(JD),JKM,JKP else WRITE(toplin,1229)NLDET,JDET-IFL+1,KK,F(JDET),S(L),M(L), * (NQ(L,II),II=1,6) endif 229 FORMAT(I2,'(',I2,',s:',A1,'):',F14.4,1PE11.2,3X,A1,I5,2(',',I3) * ,'<--',I3,2(',',I3),3X,A1,'.',A1,I2,',',I2) 1229 FORMAT(I2,'(',I2,',s:',A1,'):',F14.4,1PE11.2,3X,A1,I5,2(',',I3) * ,'<--',I3,2(',',I3),11(1H )) write(seclin,1230)(nq(l,ii),ii=7,12) 1230 format(40x,I5,2(',',I3),'<--',I3,2(',',I3)) DUMMY4=NCOLOR(L) DUMMY2=SETTEXTCOLOR( DUMMY4 ) GOTO 722 ENDIF C C...Inspect multiple lines at cursor position (with up/down cursor keys) C 2400 JDET=JDET+1 IF(JDET.GT.IFH)JDET=IFL GOTO 235 C 2401 JDET=JDET-1 IF(JDET.LT.IFL)JDET=IFH GOTO 235 C C....Toggle BACKGROUND COLOR (with 'C' or 'c') C 25 BKC=BKC+1 IF(BKC.GE.9) BKC=1 dummy4 = setbkcolor( bkcolor(BKC) ) CALL clearscreen($GCLEARSCREEN) GOTO 7 C C....Highlight selected line family in white ('D' for current, 'R' for all C data sets) C Successive presses select successive quantum numbers out of the six c quantumn numbers for the lower level, while the value of the quantum c number is defined by the current transition. c The seventh keypress cancels highlighting. C 26 DUMMY2=0 JUSTPL=1 IF(DDET.EQ.6.OR.DDET.LT.0) THEN GOTO 226 ELSE DDET=DDET+1 L=LNUM(JDET) IF(DDET.GT.1 .AND. FCDET.NE.F(JDET)) GOTO 226 IF(DDET.EQ.1) THEN CDDET=NCOLOR(L) FCDET=F(JDET) ENDIF dddet=(ddet/4+1)*3+ddet JCDET=NQ(L,dDDET) JD=int2(NQ(L,1))-int2(NQ(L,4))+2 DUMSET=SET(L) IF(KK.EQ.'R')DUMSET=-1 CALL COLBEE(DUMSET,DIPOL(L),JD,DUMMY2,DUMMY2) CALL COLBEE(DUMSET,DIPOL(L),JD,DDET,int2(NQ(L,DDdET))) ENDIF GOTO 7 C C...clear highlighting - reset standard colours 226 CALL COLBEE(SET(L),DIPOL(L),DUMMY2,DUMMY2,DUMMY2) DDET=0 GOTO 7 C C...Highlight selected data set in white ('d' current, 'r' all data sets), C (current data set defined by the line currently or most recently C underneath the cursor) C 27 DUMMY2=0 JUSTPL=1 IF(DDET.LT.0)GOTO 226 DDET=-1 DUMSET=SET(L) IF(KK.EQ.'r')DUMSET=-1 CALL COLBEE(DUMSET,DIPOL(L),DUMMY2,DUMMY2,DUMMY2) CALL COLBEE(DUMSET,DIPOL(L),DUMMY2,DDET, DUMMY2) GOTO 7 C C...Highlight selected transition type ('t' in current, 'T' in all data sets) C (current data set defined by the line currently or most recently C underneath the cursor) C 29 DUMMY2=0 JUSTPL=1 IF(DDET.LT.0)GOTO 226 DDET=-2 DUMSET=SET(L) IF(KK.EQ.'T')DUMSET=-1 JD=(int2(NQ(L,1))-int2(NQ(L,4)))*100+(int2(NQ(L,2))- * int2(NQ(L,5)))*10+(int2(NQ(L,3))-int2(NQ(L,6))) CALL COLBEE(DUMSET,DIPOL(L),DUMMY2,DUMMY2,DUMMY2) CALL COLBEE(DUMSET,DIPOL(L),JD ,DDET, DUMMY2) GOTO 7 C C...Display information on data sets (with I) C 28 continue CALL settextposition(6,int2(1),curpos) DUMmy2=settextcolor(15) WRITE(*,283) 283 FORMAT(13X,'Relative No of Line Name '/ * 14X,'intensity lines style '/ * 11X,'Ú',59(1HÄ),'¿') DO 284 J=1,NLSET WRITE(*,285)J,RELati(j),INFSET(J,3),INFSET(J,2),SETNAM(J) 284 CONTINUE 285 FORMAT(5X,'Set',I2,':³',F10.5,I8,I6,5X,A30,'³') C WRITE(*,281)NLINES 281 FORMAT(11x,'À',59(1HÄ),'Ù'/5X,'Total ',10x,I9,42(1H )/ * 47X,'Press ENTER to continue ',$) 282 IK=INKEY(J) IF(IK.EQ.0)GOTO 282 dummy4 = setbkcolor( bkcolor(BKC) ) GOTO 7 C c...GLE output c 30 continue dummy4=setbkcolor(BLUE) DUMmy2=settextcolor(15) CALL clearscreen($GCLEARSCREEN) call gleout(f1,f2,RM,RLARGE) GOTO 7 C 100 RETURN END C C_____________________________________________________________________________ C SUBROUTINE GLEOUT(F1,F2,RM,RLARGE) c c To produce .GLE and associated .DAT files for the current stick c display. Features: c - separate .DAT files for datasets which have lines on screen c - linetypes of data sets reproduced c - if any lines are highlighted then they are in continuous linetype, c while all other lines are drawn dotted c - plot is only for the NOT ADDED intensities and colour is not c preserved c c F1 - lower frequency limit c F2 - upper frequency limit c RLARGE - Y-axis maximum c RM - marker spacing c c PARAMETER (MAXLIN=12000,MAXFIL=20) c REAL*4 S(MAXLIN),SMAX REAL*8 F(MAXLIN),FMIN,FMAX,F1,F2,RM,RLARGE,tenm,ftenm INTEGER*1 SET(MAXLIN),LST(MAXLIN),NCOLOR(MAXLIN),iflag(maxfil) CHARACTER SETNAM(maxfil)*30,numset*2,filout*12,filgen*6 character*127 marlin INTEGER*4 INFSET(maxfil,3),lnum(maxlin) COMMON /FRBLK/F/SBLK/S,SMAX,FMIN,FMAX,NLINES COMMON /ORIGLN/SET,LST,NLSET,NCOLOR COMMON /SETINF/INFSET,SETNAM COMMON /LNUMS/LNUM INTEGER*2 lstyle(10) integer*2 tday,tmon,tyear,thour,tmin,tsec,t100 data lstyle/1,71,62,31,5111,3212,22,44,11,13/ c base=-.1 maxlab=5 ilight=0 call getdat(tyear,tmon,tday) call gettim(thour,tmin,tsec,t100) c c...determine generic file name (simplest character handling used c to maintain old FORTRAN compatibility) c 21 write(*,20) 20 format(1x/' Six character file name to be used for GLE output'/ * ' (the xxx.GLE and xxxn.DAT files will be written)'// * 30x,'.... ',$) read(*,'(a)',err=21)filgen do 14 nc=6,1,-1 if(filgen(nc:nc).ne.' ')goto 15 14 continue c c...establish which data files have to be used and whether there is c highlighting c 15 do 10 nset=1,nlset iflag(nset)=0 10 continue do 11 ncount=1,nlines if(f(ncount).lt.f1)goto 11 if(f(ncount).gt.f2)goto 12 n=lnum(ncount) nset=set(n) iflag(nset)=1 if(ncolor(n).eq.15)ilight=1 11 continue c c...write the control .GLE file c 12 filout=filgen(1:nc)//'.gle' write(*,*)filout open(3,file=filout,status='unknown',err=21) write(3,7)thour,':',tmin,':',tsec,tday,'/',tmon,'/',tyear 7 format('!',70(1H-)/'!'/'! Stick diagram from ASCP, generated' * i4,a,i2,a,i2,i3,a,i2,a,i4/'!'/ * '!',70(1H-)/'!') c write(3,'(a)')'size 29.5 21' write(3,'(a)')'set lwidth 0.030' write(3,'(a)')'amove -5. 4.' write(3,'(a)')'begin graph' write(3,'(a)')' nobox' write(3,'(a)')' size 37.5 17' write(3,'(a,f10.2,a,F10.2,a,F9.2,a,F9.3)') * ' xaxis min ',F1,' max ',F2,' dticks ',10.d0*RM, * ' dsubticks ',RM write(3,'(a)')' xlabels font texcmr hei 0.7' write(3,'(a)')' xticks length -0.4' write(3,'(a)')' xsubticks length -0.15' write(3,'(a)')' x2ticks off' write(3,'(a,F15.10)')' yaxis min 0.00 max',RLARGE write(3,'(a)')' yticks off' write(3,'(a)')' ylabels off' c if(ilight.eq.0)then do 5 nset=1,nlset if(iflag(nset).eq.0)goto 5 write(3,'(''!''/''! from '',a/''!'')')setnam(nset) write(numset,'(i2)')nset if(nset.lt.10)then numset=numset(2:2) filout=filgen(1:nc)//numset(1:1)//'.dat' else filout=filgen(1:nc)//numset//'.dat' endif write(3,'(4a)')' d',numset,' bigfile ',filout write(3,'(a,a,a,i4,a,a)') * ' d',numset,' lstyle ',lstyle(infset(nset,2)), * ' color black lwidth 0.025' 5 continue else write(3,'(''!''/''! highlighted lines ''/''!'')') filout=filgen(1:nc)//'1.dat' write(3,'(2a)')' d1 bigfile ',filout write(3,'(a)')' d1 lstyle 1 color black lwidth 0.025' write(3,'(''!''/''! remaining lines ''/''!'')') filout=filgen(1:nc)//'2.dat' write(3,'(2a)')' d2 bigfile ',filout write(3,'(a)')' d2 lstyle 12 color black lwidth 0.025' endif c c...deal with too many marker labels c tenm=rm*10.d0 ftenm=dint(f1/tenm)*tenm if(ftenm.lt.f1)ftenm=ftenm+tenm c if(dint((f2-f1)/tenm).gt.real(maxlab))then c write(3,'(a)')'!' write(marlin(1:9),'(a)')' xplaces ' marind=10 22 if(tenm.lt.0.01d0) * write(marlin(marind:marind+8),'(f9.3)',err=25)ftenm if(tenm.lt.0.1d0.and.tenm.ge.0.01d0) * write(marlin(marind:marind+8),'(f9.2)',err=25)ftenm if(tenm.lt.1.d0 .and.tenm.ge.0.1d0) * write(marlin(marind:marind+8),'(f9.1)',err=25)ftenm if(tenm.ge.1.d0) * write(marlin(marind:marind+8),'(i9)',err=25)nint(ftenm) marind=marind+9 if(marlin(marind-9:marind-9).ne.' ')then if(marind.le.127)marlin(marind:marind)=' ' marind=marind+1 endif ftenm=ftenm+tenm if(ftenm.lt.f2.and.marind.lt.119)then goto 22 else write(3,'(a)')marlin(1:marind-1) endif c write(marlin(1:8),'(a)')' xnames ' marind=9 ftenm=dint(f1/tenm)*tenm if(ftenm.lt.f1)ftenm=ftenm+tenm if(dint(ftenm/(2.d0*tenm))*2.d0*tenm.ne.ftenm)then write(marlin(marind:marind+4),'(a)')' " " ' marind=marind+5 ftenm=ftenm+tenm endif 23 if(tenm.lt.0.01d0) * write(marlin(marind:marind+10),'(a,f9.3,a)',err=25) * '"',ftenm,'"' if(tenm.lt.0.1d0.and.tenm.ge.0.01d0) * write(marlin(marind:marind+10),'(a,f9.2,a)',err=25) * '"',ftenm,'"' if(tenm.lt.1.d0 .and.tenm.ge.0.1d0) * write(marlin(marind:marind+10),'(a,f9.1,a)',err=25) * '"',ftenm,'"' if(tenm.ge.1.d0) * write(marlin(marind:marind+10),'(a,i9,a)',err=25) * '"',nint(ftenm),'"' marind=marind+11 if(marind+4.le.127) * write(marlin(marind:marind+4),'(a)',err=25)' " " ' marind=marind+5 ftenm=ftenm+2.d0*tenm if(ftenm.lt.f2.and.marind.lt.117)then goto 23 else write(3,'(a)')marlin(1:marind-1) write(3,'(a)')'!' endif c endif c goto 26 25 write(3,27)char(7) 27 format('!'/'! SORRY - Could not generate xnames/xplaces lines'/ * '!',a) c 26 write(3,'(a)')'end graph' c c...legend lines c if(ilight.eq.0)then write(3,'(1x/a)')' set hei 0.5' n=0 do 40 nset=1,nlset if(iflag(nset).eq.0)goto 40 n=n+1 if(((n-1)/3)*3.eq.(n-1))then x=x+7.0 y=4.0 else y=y-0.7d0 endif if(n.eq.1)x=0.7d0 do 42 i=1,30 if(setnam(nset)(i:i).eq.'\')setnam(nset)(i:i)='/' 42 continue if(n.le.12)write(3,41)'set lstyle ',lstyle(infset(nset,2)), * 'amove ',x,y,'rline 1 0','rmove .5 -.25', * 'set lstyle 1','text ',setnam(nset) 40 continue 41 format(1x/a,i4/a,2f10.5/a/a/a/2a) endif c write(3,'(1x/a/a/a/a,i2,a,i2,a,i2,a,i2,a,i2,a,i4,a)') * 'set font texcmr','set hei 0.7','amove 0.6 20.3', * 'text {\bf ASCP}_{',thour,':',tmin,':',tsec,' \,',tday,'/',tmon, * '/',tyear,'}' c write(3,'(10(a/),a)')'!','! uncomment as necessary','!', * 'set font texcmr','set hei 0.7','amove 0.6 5.3', * '! text MHz','! text cm^{-1}','amove 25.4 5.3','! text MHz', * '! text cm^{-1}' write(3,'(1h!/1H!,70(1h-))') close(3) c c...write the data .DAT file or files c if(ilight.eq.0)then do 8 nset=1,nlset if(iflag(nset).eq.0)goto 8 write(numset,'(i2)')nset if(nset.lt.10)then numset=numset(2:2) filout=filgen(1:nc)//numset(1:1)//'.dat' else filout=filgen(1:nc)//numset//'.dat' endif open(4,file=filout,status='unknown') write(4,7)thour,':',tmin,':',tsec,tday,'/',tmon,'/',tyear write(4,'(''! from data in file: '',a/1h!)')setnam(nset) ncount=0 1 ncount=ncount+1 if(ncount.gt.nlines)goto 2 if(f(ncount).lt.f1)goto 1 if(f(ncount).gt.f2)goto 2 n=lnum(ncount) if(set(n).ne.nset)goto 1 write(4,4)f(ncount),base write(4,4)f(ncount),s(n) write(4,'(f11.4,a)')f(ncount),' *' 4 format(F11.4,1PE11.3) goto 1 2 close(4) 8 continue else filout=filgen(1:nc)//'1.dat' open(4,file=filout,status='unknown') write(4,7)thour,':',tmin,':',tsec,tday,'/',tmon,'/',tyear write(4,'(a/1h!)')'! Highlighed lines' do 30 n=1,nlines if(f(n).lt.f1)goto 30 if(f(n).gt.f2)goto 31 nn=lnum(n) if(ncolor(nn).ne.15)goto 30 write(4,4)f(n),base write(4,4)f(n),s(nn) write(4,'(f11.4,a)')f(n),' *' 30 continue 31 close(4) filout=filgen(1:nc)//'2.dat' open(4,file=filout,status='unknown') write(4,7)thour,':',tmin,':',tsec,tday,'/',tmon,'/',tyear write(4,'(a/1h!)')'! Lines which are not highlighted' do 33 n=1,nlines if(f(n).lt.f1)goto 33 if(f(n).gt.f2)goto 34 nn=lnum(n) if(ncolor(nn).eq.15)goto 33 write(4,4)f(n),base write(4,4)f(n),s(nn) write(4,'(f11.4,a)')f(n),' *' 33 continue 34 close(4) endif c RETURN END C C_____________________________________________________________________________ C SUBROUTINE STICKS(F1,F2,FSTEP,RM,HT,YSTEP,INTADD,itxt,bkcol) C C PLOT STICK DIAGRAM OF THE DATA: C F1,F2 - frequency limits C HT - maximum intensity C FSTEP - frequency step per pixel (returned on exit) C RM - frequency marker spacing (returned on exit) C YSTEP - intensity step per pixel C INTADD - add/do not add intensities at a given pixel C ITXT - horizontal shift in number of characters for the annotation C lines to compensate for different numbers of columns in video c modes C BKCOL - the current background colour C C INTENSITY HT C INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy C PARAMETER (MAXLIN=12000) c REAL*4 S(MAXLIN),SMAX REAL*8 F(MAXLIN),FMIN,FMAX,F1,F2,HT,FSTEP,YSTEP,YSHIFT,H, * RM,FRMARK,FLONG,YY,HBOT,HTOP INTEGER*4 LNUM(MAXLIN),N,bkcol INTEGER*2 LS INTEGER*4 LSTYLE(10),DUMMY4,red,blue INTEGER*1 SET(MAXLIN),LST(MAXLIN),NCOLOR(MAXLIN) INTEGER*2 INTADD,DUMMY2 CHARACTER M(MAXLIN),BUFREQ*8 INTEGER*2 maxx,maxy,mymode,myrows,mycols,linofs CHARACTER*9 INTENS(2) CHARACTER*79 toplin,botlin,emplin,seclin character*127 marlin COMMON /limits/maxx,maxy,LINOFS,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red COMMON /ORIGLN/SET,LST,NLSET,NCOLOR COMMON /FRBLK/F/SBLK/S,SMAX,FMIN,FMAX,NLINES COMMON /LNUMS/LNUM/DOUBL/M COMMON /LINES/toplin,botlin,emplin,seclin C DATA INTENS/'NOT ADDED',' ADDED '/ c c...Linestyles: 1 = xxxxxxxx 2 = xxxxxxx_ 3 = xxxxxx__ c 4 = xxx_xxx_ 5 = xxxxx_x_ 6 = xxx__x__ c 7 = xx__xx__ 8 = xxxx____ 9 = x_x_x_x_ c 10 = x___x___ c DATA LSTYLE/#FFFF,#FEFE,#FCFC,#EEEE,#FAFA,#E4E4,#CCCC, * #F0F0,#AAAA,#8888/ WRITE(emplin,'(79(1H ))') c C...determine markers: RM=marker spacing, FRMARK=frequency of first marker C FSTEP=F2-F1 RM=100000.D0 1 NM=FSTEP/RM IF(NM.LT.15)THEN RM=RM*0.1D0 GOTO 1 ENDIF FRMARK=DINT(F1/RM)*RM IF(FRMARK.LT.F1)FRMARK=FRMARK+RM C C...scales C do 100 n=1,mycols marlin(n:n)=' ' 100 continue FSTEP=(F2-F1)/maxx C C...draw two horizontal baselines C DUMMY2=SETCOLOR(15) CALL moveto_w(F1,-YSTEP,wxy) dummy2=lineto_w(F2,-YSTEP) YSHIFT=-5.d0*ystep CALL moveto_w(F1,YSHIFT,wxy) dummy2=lineto_w(F2,YSHIFT) C C...plot C DO 2 N=1,NLINES IF(F(N).GE.F1)GOTO 3 2 CONTINUE GOTO 5 C 3 IF(F(N).GT.F2.OR.N.GT.NLINES)GOTO 5 H=S(LNUM(N)) IF(INTADD.EQ.1)THEN IF(M(LNUM(N)).EQ.'D')H=H*2.0D0 IF(getpixel_w(F(N),0.0D0).NE.bkcol)THEN HBOT=HTOP HTOP=HBOT+H ELSE HBOT=0.0D0 HTOP=H ENDIF ELSE HBOT=0.0D0 HTOP=H ENDIF IF(HTOP.GT.HT)HTOP=HT IF(HBOT.GT.HT)HBOT=HT IF(NLSET.GT.1)THEN $NODEBUG LS=LSTYLE(LST(LNUM(N))) CALL setlinestyle(LS) $DEBUG ENDIF DUMMY4=NCOLOR(LNUM(N)) DUMMY2=SETCOLOR( DUMMY4 ) CALL moveto_w(F(N),HBOT,wxy) dummy2=lineto_w(F(N),HTOP) N=N+1 GOTO 3 C C...Frequency markers: 1/ draw graphics baseline and ticks C 2/ place labels in MARLIN C 5 IF(NLSET.GT.1)THEN $NODEBUG CALL setlinestyle(#FFFF) $DEBUG ENDIF FLONG=0.D0 C 4 YY=-8.D0*YSTEP H=DNINT(FRMARK/RM) IF(DNINT(10.D0*DINT(H*0.1D0)).EQ.H)THEN YY=-13.D0*YSTEP IF(FLONG.EQ.0.D0)FLONG=FRMARK NBUFER=(FRMARK-F1)/(F2-F1) * real(mycols) IF(NBUFER-3.GE.1.AND.NBUFER+4.LE.mycols-1)THEN WRITE(BUFREQ,'(F8.1)')FRMARK if(frmark.lt.100000.)WRITE(BUFREQ,'(F8.2)')FRMARK if(frmark.ge.1000000.)WRITE(BUFREQ,'(F8.0)')FRMARK IF(NBUFER-3.LE.4)THEN marlin(NBUFER-3:NBUFER+4)=BUFREQ GOTO 10 ENDIF IF(marlin(NBUFER-6:NBUFER-6).EQ.' ')THEN marlin(NBUFER-3:NBUFER+4)=BUFREQ ENDIF ENDIF ENDIF 10 DUMMY2=SETCOLOR(15) CALL moveto_w(FRMARK,YSHIFT,wxy) dummy2=lineto_w(FRMARK,YY) FRMARK=FRMARK+RM IF(FRMARK.LE.F2)GOTO 4 C C...write top, bottom and marker lines of text C WRITE(botlin,6)RM,INTENS((INTADD+3)/2) 6 FORMAT('Markers:',F9.3,12x,'press H for help',12x, * 'Intensities: ',A) DUMMY2=SETTEXTCOLOR(7) CALL settextposition(myrows,int2(itxt+1),curpos) CALL outtext(botlin) DUMMY2=SETTEXTCOLOR(15) CALL settextposition(int2(myrows-1),int2(1),curpos) CALL outtext(marlin(1:mycols-1)) C RETURN END C C_____________________________________________________________________________ C SUBROUTINE SORTH(NSTART,N) c c This routine is based on the SORT2 'heapsort' routine from Numerical c Recipes and sorts the quantities in vector WK from WK(NSTART) to WK(N) C in ascending order of magnitude and also accordingly rearranges vector C IPT of pointers to original positions of sorted quantities. c PARAMETER (MAXLIN=12000) c COMMON /FRBLK/WK COMMON /LNUMS/IPT INTEGER*4 IPT(MAXLIN),IIPT,L,I,J,IR REAL*8 WK(MAXLIN),WWK C L=N/2+1 IR=N 10 CONTINUE IF(L.GT.NSTART)THEN L=L-1 WWK=WK(L) IIPT=IPT(L) ELSE WWK=WK(IR) IIPT=IPT(IR) WK(IR)=WK(1) IPT(IR)=IPT(1) IR=IR-1 IF(IR.EQ.NSTART)THEN WK(1)=WWK IPT(1)=IIPT RETURN ENDIF ENDIF I=L J=L+L 20 IF(J.LE.IR)THEN IF(J.LT.IR)THEN IF(WK(J).LT.WK(J+1))J=J+1 ENDIF IF(WWK.LT.WK(J))THEN WK(I)=WK(J) IPT(I)=IPT(J) I=J J=J+J ELSE J=IR+1 ENDIF GO TO 20 ENDIF WK(I)=WWK IPT(I)=IIPT GO TO 10 c RETURN END C C_____________________________________________________________________________ C C SUBROUTINE graphicsmode() C C This routine determines the graphics card on the PC and sets the C highest resolution graphics mode available with this card. It also C determines the pixel limits on x and y axes (0,maxx), (0,maxy) c c This is a stub version of the full routine with only the VGA mode c left in - see the Microsoft documetation for other possibilities C INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 dummy,maxx,maxy,mymode,myrows,mycols,LINOFS INTEGER*4 dummy4,blue,red RECORD /videoconfig/myscreen COMMON /limits/maxx,maxy,LINOFS,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red C C...Set graphics mode. C CALL getvideoconfig(myscreen) C C...this setting was preferred until graphics cards started showing c it as a ribbon narrower than screen height (640*350 and 25*80 chars. EGA) c mymode=$ERESCOLOR c myrows=25 C C...this setting should have widest compatibility (640*480, 30*80 chars. VGA) c (the 16 color mode usually delivers faster scrolling) c mymode=$VRES256COLOR mymode=$VRES16COLOR myrows=30 C C...this is for 800*600, 37*100 chars. SVGA which is available only for MFPS c (the 256 color mode experiences problems with some cards) c mymode=$SRES256COLOR c mymode=$SRES16COLOR c myrows=37 c dummy = setvideomoderows ( mymode, myrows ) myrows=dummy if(myrows.ne.25.and.myrows.ne.30.and.myrows.ne.37)then write(*,'(1x//i5,a,a//)')myrows, * ' <--- this is the number of text lines in this mode', * ' and it is not yet supported' pause endif C IF( dummy .EQ. 0 ) STOP 'Error: cannot set graphics mode' C C...Determine parameters of the graphics mode that is being used C CALL getvideoconfig( myscreen ) maxx = myscreen.numxpixels - 1 maxy = myscreen.numypixels - 1 linofs=nint(real(maxy)/real(myrows)) mycols = myscreen.numtextcols if(mycols.lt.80)then write(*,'(1x//i5,a,a//)')myrows, * ' <--- this is the number of text columns in this mode', * ' and it is too small' pause endif c c...patch for different use of SETBKCOLOR by MSPS4.0 from MSPS1.0 (and MSF5) c blue=$BLUE red=$RED if($BLUE.ne.#2a0000)then blue=1 red=4 endif c dummy4 = setbkcolor( BLUE ) call clearscreen($GCLEARSCREEN) C RETURN END C C_____________________________________________________________________________ c SUBROUTINE HUNTF(N,X,JLO) C C This is a modification of routine HUNT from Numerical Recipes for C locating a value in an ordered table. The required value is located C by hunting from the latest known position in the table. c C Given an array XX of length N, and given a value X, the routine returns C a value JLO such that X is between XX(JLO) and XX(JLO+1). XX must be C monotonic, either increasing or decreasing. JLO=0 or JLO=N is C returned to indicate that X is out of range. JLO on input is taken as C the initial guess for JLO on output. C PARAMETER (MAXLIN=12000) c real*8 x,xx(MAXLIN) integer*4 n,jlo,jhi,inc,jm LOGICAL ASCND COMMON /FRBLK/xx C ASCND=XX(N).GT.XX(1) IF(JLO.LE.0.OR.JLO.GT.N)THEN JLO=0 JHI=N+1 GO TO 3 ENDIF c INC=1 IF(X.GE.XX(JLO).EQV.ASCND)THEN 1 JHI=JLO+INC IF(JHI.GT.N)THEN JHI=N+1 ELSE IF(X.GE.XX(JHI).EQV.ASCND)THEN JLO=JHI INC=INC+INC GO TO 1 ENDIF ELSE JHI=JLO 2 JLO=JHI-INC IF(JLO.LT.1)THEN JLO=0 ELSE IF(X.LT.XX(JLO).EQV.ASCND)THEN JHI=JLO INC=INC+INC GO TO 2 ENDIF ENDIF c 3 IF(JHI-JLO.EQ.1)RETURN JM=(JHI+JLO)/2 IF(X.GT.XX(JM).EQV.ASCND)THEN JLO=JM ELSE JHI=JM ENDIF GO TO 3 c RETURN END C_____________________________________________________________________________ c cc integer*2 function INKEY(N2) c c By L Pszczolkowski: c c...This emulates for MSF PS1.0 the INKEY function of Z.Czumaj which c in turn emulated for MSF5.0 the INKEY function from IIUWGRAF graphics c library for the Hercules card c c The function GETCHARQQ returns the ASCII character if the corresponding c key was pressed. If function or direction key was pressed then 0 c or hex E0 is returned and another call to GETCHARQQ is required to c get the extended code of the character c cc INCLUDE 'FGRAPH.FD' PS1 cc CHARACTER*1 GETCHARQQ PS1 cc USE MSFLIB PS4 c cc INTEGER*2 IK,n2 cc CHARACTER*1 KK c cc KK=GETCHARQQ() cc IK=ICHAR(KK) cc IF(IK.EQ.0 .OR. IK.EQ.224 ) THEN cc KK=GETCHARQQ() cc IK=-ICHAR(KK) cc ENDIF cc n2=ik cc INKEY=IK cc END C_____________________________________________________________________________ C_____________________________________________________________________________