C$DEBUG $LARGE C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C ASPEC - Stick diagrams of spectra calculated with ASROT 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 12000 lines may be read in C - the lines may be in any number of 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 - when in graphics mode the H key gives a summary of the available C options C - input of multiple data sets can be carried out on the basis of C information placed in a special control file C C----------------------------------------------------------------------------- C This is the first version of ASPEC to use colour to help 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 J, K-1 or K+1 or belonging C to 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 NQ(i,1..6) - 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 F,S,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 rel.intens*10000, i=2 linestyle, i=3 no of lines C C----------------------------------------------------------------------------- C C IMPORTANT: C Program uses MSFortran 5.0 graphics and adapts to common graphics C cards. For Hercules the TSR MSHERC.COM has to be loaded first. C Facilities of ANSI.SYS are also used and this has to be loaded. C C Version 8.VII.1999 ----- Zbigniew KISIEL ----- C ----- Lech PSZCZOLKOWSKI ----- C_____________________________________________________________________________ C C Modification history: C 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 8.08.99: readable input control file as for ASCP 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 INCLUDE 'FGRAPH.FI' INCLUDE 'FGRAPH.FD' C C...The code in the two INCLUDE files clashes with IMPLICIT statements - so C when using MSF5.0 graphics the recomendation is to type everything C explicitly (check with -4Yg compilation switch) C PARAMETER (MAXLIN=12000) c CHARACTER L(80),DIPOL(MAXLIN),M(MAXLIN) CHARACTER*4 BOLD,NORMAL,FILNAM*30,FILCON*30,LINE*80 CHARACTER*30 SETNAM(20) INTEGER*1 SET(MAXLIN),LST(MAXLIN) REAL*4 S(MAXLIN),SMAX,SLIMIT REAL*8 F(MAXLIN),FMIN,FMAX,FOLD,FSTART,FEND INTEGER*2 NLINES,LNUM(MAXLIN),NQ(MAXLIN,6), * NSTART,DUM2,INFSET(20,3) INTEGER*1 NCOLOR(MAXLIN) 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,BOLD,NORMAL COMMON /SETINF/INFSET,SETNAM C LINMAX=11998 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 WRITE(BOLD,'(A1,''[1m'')')CHAR(27) WRITE(NORMAL,'(A1,''[0m'')')CHAR(27) C WRITE(*,155)CHAR(27),'[2J' WRITE(*,155)CHAR(27),'[7m' 155 FORMAT(1H+,A1,A) WRITE(*,156) 156 FORMAT(10X,66(1H )/10X,' ASC - Stick diagrams of spectra calc', 1 'ulated with ASROT '/10X,66(1H )/1X,75(1H_)/ 1 ' version 8.VII.1999',T61,'Zbigniew KISIEL '/ * 1X,T58,'Lech PSZCZOLKOWSKI '/) WRITE(*,155)CHAR(27),'[0m' C write(*,'('' - Compiled for maximum of'',i7,'' lines''/)')maxlin 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,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 INFSET(NLSET,1)=RELINT*10000.D0 INFSET(NLSET,2)=NLST ELSE INFSET(NLSET,1)=10000 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 GOTO 40 ENDIF c c...read line information assuming it is a single line c READ(LINE,6,ERR=55)F(NLINES),S(NLINES),(NQ(NLINES,I),I=1,6), *DIPOL(NLINES) 6 FORMAT(F14.6,1PE10.2,2X,I3,1X,I3,1X,I3,I5,1X,I3,1X,I3,1X,A1) goto 56 55 nlines=nlines-1 goto 5 56 if(nq(nlines,1).eq.0.and.nq(nlines,4).eq.99)nq(nlines,1)=100 if(nq(nlines,1).eq.0.and.nq(nlines,4).eq.0)then nq(nlines,1)=100 nq(nlines,4)=100 endif 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 ? ' 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 DO 10 I=1,NLINES LNUM(I)=I 10 CONTINUE IF(ISORT.EQ.1)THEN WRITE(*,20)BOLD,NORMAL 20 FORMAT(1X//1X,A,'**** SORTING lines',A/) 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=J, 2=K-1, 3=K+1) 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 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*2 NLINES,LNUM(MAXLIN),NQ(MAXLIN,6) INTEGER*2 I,J,JJ,DDET,DUM2 INTEGER*1 NCOLOR(MAXLIN) 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,BOLD,NORMAL 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 IF(DIPOL(J).NE.DUMC)GOTO 22 JD=(NQ(J,1)-NQ(J,4))*100+(NQ(J,2)-NQ(J,5))*10+ * (NQ(J,3)-NQ(J,6)) 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 IF(DIPOL(J).NE.DUMC) GOTO 10 JD=NQ(J,1)-NQ(J,4)+2 IF(JD.NE.DUM2) GOTO 10 IF( JJ.EQ.NQ(J,DDET+3)) 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=NQ(J,1)-NQ(J,4)+2 C C...assign default colour for transition with unknown selection rules 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 C INCLUDE 'FGRAPH.FD' C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*1 MARK [ALLOCATABLE] (:) C PARAMETER (MAXLIN=12000) c REAL*4 S(MAXLIN),SMAX REAL*8 F(MAXLIN),FMIN,FMAX,F1,F2,FMARK,FSTEP,FSHIFT,FL,FH INTEGER*1 SET(MAXLIN),LST(MAXLIN),DUMSET REAL*8 RMBOT,RMTOP,RSMALL,RLARGE,YSTEP,FCDET INTEGER*2 NQ(MAXLIN,6),LNUM(MAXLIN),NLINES,IK,N,inkey,j,JCDET INTEGER*2 INTADD,LINDET,IFL,IFH,NLDET,IFMARK,DUMmy2,DDET,JD, * INFSET(20,3) CHARACTER KK,DIPOL(MAXLIN),M(MAXLIN),TYPETR(4),BOLD*4,NORMAL*4, * OUTSTR*21,DTOP*3 CHARACTER*30 SETNAM(20) INTEGER*2 maxx,maxy,mygmod,linofs CHARACTER*79 toplin,botlin,emplin,inf INTEGER*4 imsize,DUMmy4,BKC,CDDET INTEGER*1 NCOLOR(MAXLIN) INTEGER*4 bkcolor(8) / + $BLACK, $BLUE , $GREEN, $CYAN, + $RED , $MAGENTA, $BROWN, $WHITE / COMMON /limits/maxx,maxy,mygmod,linofs,curpos,ixy,wxy 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,BOLD,NORMAL COMMON /LINES/toplin,botlin,emplin COMMON /SETINF/INFSET,SETNAM C DATA TYPETR/'P','Q','R',' '/ INTADD=-1 linofs=14 lindet=+1 IFMARK=1 L=1 JDET=1 C C...Initialize graphics and set the display up from scratch, this code is C executed at the beginning of the routine and on selection of return C to default conditions C F1=FMIN F2=FMAX FMARK=0.5D0*(F1+F2) RLARGE=SMAX C CALL graphicsmode() DUMmy2=setactivepage(1) DUMmy2=setvisualpage(1) NHORPT=maxx+1 DUMmy2=settextcolor(15) BKC=2 DUMmy4 = setbkcolor( bkcolor(BKC) ) DDET=0 JCDET=0 C C...Definition of graphics viewport C (note that pixel origin is now at absolute {0,linofs+1}) C call setviewport(0,linofs+1,maxx,maxy-linofs-1) YSTEP=1.d0/DBLE(maxy-2*(linofs+1)-28)*RLARGE RSMALL=-28.D0*YSTEP DUMmy2=setwindow(.TRUE.,F1,RSMALL, * F2,RLARGE) C C...generation of dotted marker bar for future use C $NODEBUG CALL setlinestyle(#1111) $DEBUG RMTOP=RLARGE/3.d0 RMBOT=RSMALL CALL clearscreen($GVIEWPORT) 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) call putimage_w(FMARK,RMTOP,MARK,$GXOR) $NODEBUG CALL setlinestyle(#FFFF) $DEBUG C C...Bordering horizontal lines C 7 call setviewport(0,0,maxx,maxy) CALL moveto(0,linofs,ixy) dummy2=lineto(maxx,linofs) C C...bottom line used in previous version commented out C CALL moveto(0,maxy-linofs,ixy) C dummy2=lineto(maxx,maxy-linofs) call setviewport(0,linofs+1,maxx,maxy-linofs-1) C C Beginning of main display loop which is executed each time a change in C the display is performed C C...PLOT - redefine floating-point window, clear and plot C 9 dummy2=setwindow(.TRUE.,F1,RSMALL, * F2,RLARGE) $NODEBUG CALL setlinestyle(#FFFF) $DEBUG CALL clearscreen($GVIEWPORT) CALL STICKS(F1,F2,FSTEP,RLARGE,YSTEP,INTADD) c c...marker 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(' Marker: ',F11.3) dummy2=settextcolor(15) CALL settextposition(1,1,curpos) CALL outtext(toplin) c C...option selection C 1 IK=INKEY(N) 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(IK.EQ.-72.AND.TOPLIN(21:21).EQ.'.')GOTO 2400 IF(IK.EQ.-80.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(IK.NE.13)GOTO 1 C C...exit control C dummy2=settextcolor(15) dummy4 = setbkcolor( $RED ) BKC=1 CALL settextposition(1,1,curpos) CALL outtext(emplin) WRITE(outstr,'(A)')'ARE YOU SURE ?' CALL settextposition(1,1,curpos) CALL outtext(outstr(1:14)) CALL settextposition(1,20,curpos) WRITE(*,'(1X,A1,$)')CHAR(7) 916 IK=INKEY(N) 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( $BLUE ) CALL settextposition(1,1,curpos) CALL outtext(toplin) GOTO 1 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.05D0*FR F1=F1+FINCR F2=F2-FINCR IF(FMARK.LT.F1)FMARK=F1 IF(FMARK.GT.F2)FMARK=F2 GOTO 9 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,1,curpos) WRITE(*,101)CHAR(7) ENDIF 101 FORMAT(1X,A1,$) F2=F2+FINCR GOTO 9 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,1,curpos) WRITE(*,101)CHAR(7) ENDIF F2=F2-FSHIFT FMARK=FMARK-FSHIFT GOTO 9 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 9 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-2*(linofs+1)-28)*RLARGE RSMALL=-28.D0*YSTEP GOTO 9 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 marker 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 721 DUMMY2=SETTEXTCOLOR(15) 722 CALL settextposition(1,1,curpos) CALL outtext(toplin) IF(DDET.LE.0 .OR. NLDET.EQ.0) GOTO 1 C C...change colour of selected quantum number when highlighting lines IF ( JCDET.EQ.NQ(L,DDET+3)) THEN WRITE(dtop,'(I3)')NQ(L,DDET+3) DUMMY2=SETTEXTCOLOR( CDDET) CALL settextposition(1,53+DDET*4,curpos) CALL outtext(dtop) ENDIF GOTO 1 C C...Shift of marker 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 marker 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 marker C 20 CALL HUNTF(NLINES,FMARK,IFMARK) 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-10 IF(IST.LT.1)IST=1 IFIN=I+10 IF(IFIN.GT.NLINES)IFIN=NLINES 111 CALL clearscreen($GCLEARSCREEN) iline=0 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=NQ(L,1)-NQ(L,4)+2 if(jd.lt.1.or.jd.gt.3)jd=4 JKM=NQ(L,2)-NQ(L,5) JKP=NQ(L,3)-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 ) WRITE(inf,104)KK,F(J),S(L),M(L),(NQ(L,II),II=1,6), * DIPOL(L),TYPETR(JD),JKM,JKP 104 FORMAT(2X,A1,': ',F14.6,1PE11.2,3X,A1,1X,2(I6,2(',',I3)),5X, * A1,'.',A1,I2,',',I2) 102 CALL settextposition(iline,1,curpos) CALL outtext(inf) 103 CONTINUE 231 WRITE(*,106) 106 FORMAT(1X,' ',20X, * 'ENTER returns to the stick display ',$) 107 IK=INKEY(J) IF(IK.EQ.0)GOTO 107 IF(IK.EQ.13)THEN dummy4 = setbkcolor( bkcolor(BKC) ) GOTO 7 ENDIF IF(IK.EQ.-73)THEN IST=IST+20 IFIN=IFIN+20 IF(IFIN.GT.NLINES)THEN IST=NLINES-20 IFIN=NLINES ENDIF GOTO 111 ENDIF IF(IK.EQ.-81)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 C 23 dummy4=setbkcolor($BLUE) CALL clearscreen($GCLEARSCREEN) write(*,'(1x)') WRITE(*,232) 232 FORMAT( ' SUMMARY OF COMMANDS ACTIVE IN GRAPHICS MODE:'/ * ' ============================================'// * ' W/Z - change vertical scaling'/ * ' Q/E - change horizontal scaling'/ * ' A/S - shift spectrum left/right'/ * ' K/L/, - move marker 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 marker between spot-frequency/line-', * 'information') WRITE(*,2321) 2321 FORMAT( * ' (parameters of unresolved lines may be obtained'/ * ' with up/down arrow keys)'/ * ' F - change frequency limits'/ * ' Y - add/do-not-add intensities of degenerate ' * 'doublets'/ * ' C - toggle background color'/ * ' D/R - higlighting of lines with selected qn''s from', * ' current/all sets'/ * ' d/r - higlighting of all lines from current/', * 'all data sets'/ * ' t/T - higlighting of selected transition type from', * ' current/all sets'// * ' Exit from the graphics is by ENTER followed by Y'/) GOTO 231 C C...Toggle addition of intensities of overlapping lines (with 'Y' or 'y') C 21 INTADD=-INTADD GOTO 9 C C...Frequency limits from keyboard (with 'F' or 'f') C 22 dummy4=setbkcolor($BLACK) CALL clearscreen($GCLEARSCREEN) write(*,'(1x)') WRITE(*,304)FMIN,FMAX,F1,F2 304 FORMAT(1X//' Frequency limits of data: ',2F12.3/ * ' Frequency limits of display: ',2F12.3/) 302 WRITE(*,300)'New lower frequency display limit: ' 300 FORMAT(1X,A\) READ(*,*,ERR=302)F1 IF(F1.LT.0.D0.OR.F1.GT.FMAX)GOTO 302 303 WRITE(*,300)'New upper frequency display limit: ' READ(*,*,ERR=303)F2 IF(F2.LE.F1.OR.F2.LT.FMIN)GOTO 303 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)NLDET,NLDET,NLDET,FMARK GOTO 721 228 FORMAT(I2,'(',I2,',',I1,'):',2X,F11.3) ELSE L=LNUM(JDET) IK=SET(L) IF(IK.LT.10)KK=CHAR(48+IK) IF(IK.GT.9)KK=CHAR(55+IK) JD=NQ(L,1)-NQ(L,4)+2 JKM=NQ(L,2)-NQ(L,5) JKP=NQ(L,3)-NQ(L,6) if(jd.lt.1.or.jd.gt.3)jd=4 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 229 FORMAT(I2,'(',I2,',s:',A1,'):',F14.4,1PE11.2,3X,A1,I5,2(',',I3) * ,'<--',I3,2(',',I3),3X,A1,'.',A1,I2,',',I2) 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) ) GOTO 1 C C....Highlight selected line family in white ('D' for current, 'R' for all C data sets) C The first press selects lines for which the lower level has C common J, second press selects common K-1, third common K+1, C fourth keypress cancels highlighting. C 26 DUMMY2=0 JUSTPL=1 IF(DDET.EQ.3.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 JCDET=NQ(L,DDET+3) JD=NQ(L,1)-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,NQ(L,DDET+3)) ENDIF GOTO 9 C C...clear highlighting - reset standard colours 226 CALL COLBEE(SET(L),DIPOL(L),DUMMY2,DUMMY2,DUMMY2) DDET=0 GOTO 9 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 9 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=(NQ(L,1)-NQ(L,4))*100+(NQ(L,2)-NQ(L,5))*10+ * (NQ(L,3)-NQ(L,6)) CALL COLBEE(DUMSET,DIPOL(L),DUMMY2,DUMMY2,DUMMY2) CALL COLBEE(DUMSET,DIPOL(L),JD ,DDET, DUMMY2) GOTO 9 C C...Display information on data sets C 28 continue CALL settextposition(6,1,curpos) WRITE(*,283) 283 FORMAT(13X,'Relative No of Line Name '/ * 14X,'intensity lines style '/ * 14X,' ') DO 284 J=1,NLSET RELINT=REAL(INFSET(J,1))/10000.D0 WRITE(*,285)J,RELINT,INFSET(J,3),INFSET(J,2),SETNAM(J) 284 CONTINUE 285 FORMAT(5X,'Set',I2,':',F10.3,I9,I7,4X,A) C WRITE(*,281)NLINES 281 FORMAT(5X,'Total ',10x,I9,41(1H )/ * 40X,' Press ENTER to continue ',$) 282 IK=INKEY(J) IF(IK.EQ.0)GOTO 282 dummy4 = setbkcolor( bkcolor(BKC) ) GOTO 7 C C 100 RETURN END C C_____________________________________________________________________________ C SUBROUTINE STICKS(F1,F2,FSTEP,HT,YSTEP,INTADD) C C PLOT STICK DIAGRAM OF THE DATA FOR FREQUENCY LIMITS F1,F2 AND MAXIMUM C INTENSITY HT C INCLUDE 'FGRAPH.FD' 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*2 LNUM(MAXLIN),NLINES,N,LS INTEGER*4 LSTYLE(10),DUMMY4 INTEGER*1 SET(MAXLIN),LST(MAXLIN),NCOLOR(MAXLIN) INTEGER*2 INTADD,DUMMY2 CHARACTER M(MAXLIN),BUFREQ*8 INTEGER*2 maxx,maxy,mygmod,linofs CHARACTER*9 INTENS(2) CHARACTER*79 toplin,botlin,emplin,marlin COMMON /limits/maxx,maxy,mygmod,linofs,curpos,ixy,wxy 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 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 marlin=emplin 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.0)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...plot markers 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) * 80.D0 IF(NBUFER-3.GE.1.AND.NBUFER+4.LE.79)THEN WRITE(BUFREQ,'(F8.1)')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 WRITE(botlin,6)RM,INTENS((INTADD+3)/2) 6 FORMAT('Markers:',F9.3,17(1H-),'H=help',17(1H-), * 'Intensities: ',A) DUMMY2=SETTEXTCOLOR(7) CALL settextposition(25,1,curpos) CALL outtext(botlin) DUMMY2=SETTEXTCOLOR(15) CALL settextposition(24,1,curpos) CALL outtext(marlin) 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*2 IPT(MAXLIN),IIPT,L,N,NSTART,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 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 INCLUDE 'FGRAPH.FD' C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 dummy,maxx,maxy,mygmod,linofs RECORD /videoconfig/myscreen COMMON /limits/maxx,maxy,mygmod,linofs,curpos,ixy,wxy C C...Find graphics mode. C CALL getvideoconfig(myscreen) SELECT CASE( myscreen.adapter ) CASE( $CGA ) dummy = setvideomode( $HRESBW ) mygmod=$HRESBW CASE( $OCGA ) dummy = setvideomode( $ORESCOLOR ) mygmod=$ORESCOLOR CASE( $EGA, $OEGA ) IF( myscreen.monitor .EQ. $MONO ) THEN dummy = setvideomode( $ERESNOCOLOR ) mygmod=$ERESNOCOLOR ELSE dummy = setvideomode( $ERESCOLOR ) mygmod=$ERESCOLOR END IF CASE( $VGA, $OVGA, $MCGA ) c dummy = setvideomode( $ERESNOCOLOR ) c mygmod=$ERESNOCOLOR c dummy = setvideomode( $VRES16COLOR ) c mygmod=$VRES16COLOR dummy = setvideomode( $ERESCOLOR ) mygmod=$ERESCOLOR CASE( $HGC ) dummy = setvideomode ( $HERCMONO ) mygmod=$HERCMONO CASE DEFAULT dummy = 0 END SELECT C IF( dummy .EQ. 0 ) STOP 'Error: cannot set graphics mode' C C...Set video mode and return pixel limits C CALL getvideoconfig( myscreen ) maxx = myscreen.numxpixels - 1 maxy = myscreen.numypixels - 1 C RETURN END 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*2 jlo,jhi,inc,n,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_____________________________________________________________________________