C
C Subroutine file 'scro' - screen output subroutines with graphics C C Date: 2004, June 11 C Coded by Ludek Klimes C C....................................................................... C C Description of input data: C C Input parameters taken from the input SEP parameter file for the C Complete Ray Tracing program C SCRPLUS=integer C SCRANSI=integer C SCRWIDTH=integer C SCRHEIGHT=integer C SCRBBOX1=real, SCRBBOX2=real, SCRBBOX3=real, SCRBBOX4=real C SCRLINE=real C CRTSCRO='string' C CRTPAUSE=integer C are described in file crtin.for. C C....................................................................... C C This file consists of: C SCROB...Block data subroutine defining auxiliary common block C /SCROC/ to configure the screen output. C SCROB C SCRO1...Screen output subroutine called when starting the complete C ray tracing program, and when starting the computation of C a new elementary wave. C SCRO1 C SCRO2...Screen output subroutine called when starting the complete C tracing of a new ray. C SCRO2 C SCRO3...Screen output subroutine called with constant step STORE C of the independent variable along the ray, and at the C points of intersection with interfaces either before and C after the transformation. C SCRO3 C SCRO4...Screen output subroutine called after termination of C tracing the ray. C SCRO4 C SCRO5...Screen output subroutine called after termination of the C computation of an elementary wave, and when terminating C the complete ray tracing program. C SCRO5 C CURSOR..Character function that returns the ANSI escape sequence C positioning the cursor at the beginning of the given line. C CURSOR C Specification of the used CalComp graphics subroutines. C CalComp C C Attention: If setting input parameter CRTPAUSE=1, C subroutine SCRO5 may require an input from the keyboard C (external unit *) to proceed to the next elementary wave. This C should be taken into account if linking 'crt.for' and wishing to C redirect the standard input * unit into a file. C C C Brief description of the output screen: C The output screen is split into the left-hand column (1/4 of C the screen) and the right-hand column (3/4 of the screen). The C left-hand column is reserved for the text output of the width of C 20 characters and the height of 24 lines, controlled by the ANSI C escape sequences. The right-hand column is reserved for the C graphical output. C The graphical output is completed by invocation of the CalComp C subroutines PLOTS, PLOT, and NEWPEN. Since the CalComp plot units C are centimetres (maybe inches in U.S.A.), the screen is assumed to C have the dimensions of A4 sheet (29.7cm*21.0cm). If the CalComp C subroutines you are using assume other screen dimensions, it is C necessary to change the values HMIN,HMAX,VMIN,VMAX,WIDTH in block C data SCROB below. C Left-hand column - textual output: C The left-hand column contains the sequential indices of the C elementary wave and ray being traced, two take-off ray parameters, C and the indices of simple blocks, complex blocks, and surfaces C covering structural interfaces, at all points of incidence and C reflection/transmission, and at the ray endpoint. Also the reason C of the termination of the computation of the ray, see C C.R.T.5.4, C is written to the screen. C Right-hand column - graphical output: C The right-hand column is split into 2*2 rectangles. The upper C right-hand rectangle contains the initial points of rays, the C upper left-hand and the two bottom rectangles contain the C projections of rays onto the top and the sides of the model. C Three graphical panels with ray projections: C The upper left-hand rectangle contains the projection of rays onto C the top horizontal side of the model volume (plane X1X2). The C bottom left-hand rectangle contains the front view of rays C (projection of rays onto the front side X1X3 of the model volume). C The bottom right-hand rectangle contains the projection of rays C onto the right-hand vertical side X2X3 of the model volume. The C rays increase their colour index by one at each point of C reflection or transmission. The model side of generally different C dimensions and aspect ratios are scaled into the rectangles of C equal size. Moreover, in curvilinear coordinates the model volume C limited by curved coordinate surfaces is scaled into cube for the C purposes of the screen output. C Upper rightmost graphical panel: C The upper rightmost rectangle contains the initial points of rays. C The horizontal screen axis corresponds to shooting parameter A and C the vertical axis corresponds to shooting parameter B, see the C description of the input data (5) in 'rpar.for'. In other words, C the bottom left-hand corner of the rectangle corresponds to the C ray take-off parameters PAR1L,PAR2L, the bottom right-hand corner C to PAR1A,PAR2A, and the upper left-hand corner to PAR1B,PAR2B. C The different color indices at the upper rightmost panel C correspond to different ray histories. C C Configuration of the screen output: C The quantities specifying the scale and other properties of the C simple graphic output are stored in the common block /SCROC/ C defined in the following subroutine: C ------------------------------------------------------------------ C C BLOCK DATA SCROB INCLUDE 'scro.inc' C scro.inc END C ------------------------------------------------------------------ C HMIN, HMAX... Horizontal coordinates of the vertical boundaries of C the plotting area in the plot coordinates. C The leftmost 1/4 of the screen area is reserved for the C text output. C VMIN, VMAX... Vertical coordinates of the horizontal boundaries of C the plotting area in the plot coordinates. C WIDTH...Estimated thickness of the plotted line. C C======================================================================= C C C SUBROUTINE SCRO1(ISRC,IWAVE) INTEGER ISRC,IWAVE C C This screen output subroutine is called when starting the complete ray C tracing program, and when starting the computation of a new elementary C wave. C C Input: C IWAVE...Zero when starting the complete ray tracing program, C otherwise the index of the elementary wave which will be C computed (i.e. the output of the subroutine CODE1 from the C file 'code.for'). C ISRC... Index of the source. The sources are indexed by positive C integers. C C No output. C C Common block /DCRT/ (see subroutine file 'ray.for'): INCLUDE 'dcrt.inc' C dcrt.inc C None of the storage locations of the common block are altered. C C Common block /RPARD/ (defined in file 'rpar.for'): INCLUDE 'rpard.inc' C rpard.inc C Storage locations of the common block are not altered. C C Common block /SCROC/: INCLUDE 'scro.inc' C scro.inc C Storage locations H1B,H2A,H2B,V2A,V2B,V3A,V3B,JWAVE of the common C block are defined in this subroutine. C C Subroutines and external functions required: EXTERNAL SCROB,CURSOR,RSEP3I,RSEP3R,RSEP3T,PLOTS,PLOT,NEWPEN C SCROB.. Block data subroutine of this file. C CURSOR... This file. C RSEP3I,RSEP3R,RSEP3T... File 'sep.for'. C PLOTS,PLOT,NEWPEN... CalComp graphics subroutines. C C Date: 2003, May 12 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER MTEXT,I PARAMETER (MTEXT=120) CHARACTER*(MTEXT) TEXT CHARACTER*(NSCR) CRTSCR REAL STREET,H1,H2,V1,V2,AUX1,AUX2 C C Reading the input data: IF(IWAVE.EQ.0) THEN CALL RSEP3I('SCRPLUS' ,KPLUS,1) CALL RSEP3I('SCRANSI' ,KANSI,1) CALL RSEP3I('SCRWIDTH' ,NWIDTH,79) IF(NWIDTH.LT.20) THEN C 541 CALL ERROR('541 in SCRO1: Screen lines shorter than 20 char.') C The number SCRWIDTH of characters per one line of the screen C output should be at least 20. Adjust the input data. END IF CALL RSEP3I('SCRHEIGHT',NLINES,25) CALL RSEP3R('SCRBBOX1' ,HMIN , 2.77) CALL RSEP3R('SCRBBOX2' ,VMIN , 0.02) CALL RSEP3R('SCRBBOX3' ,HMAX ,10.98) CALL RSEP3R('SCRBBOX4' ,VMAX , 8.48) CALL RSEP3R('SCRLINE' ,WIDTH, 0.017) CALL RSEP3T('CRTSCRO' ,CRTSCR,'SW') CALL RSEP3I('CRTPAUSE' ,IPAUSE,0) IF(IPAUSE.NE.0) THEN IPAUSE=1 END IF DO 11 I=1,NSCR KSCR(I)=0 11 CONTINUE DO 12 I=1,NSCR IF(CRTSCR(I:I).EQ.'S'.OR.CRTSCR(I:I).EQ.'s') KSCR(1)=1 IF(CRTSCR(I:I).EQ.'W'.OR.CRTSCR(I:I).EQ.'w') KSCR(2)=1 IF(CRTSCR(I:I).EQ.'R'.OR.CRTSCR(I:I).EQ.'r') KSCR(3)=1 IF(CRTSCR(I:I).EQ.'A'.OR.CRTSCR(I:I).EQ.'a') KSCR(4)=1 IF(CRTSCR(I:I).EQ.'P'.OR.CRTSCR(I:I).EQ.'p') KSCR(5)=1 IF(CRTSCR(I:I).EQ.'H'.OR.CRTSCR(I:I).EQ.'h') KSCR(6)=1 IF(CRTSCR(I:I).EQ.'E'.OR.CRTSCR(I:I).EQ.'e') KSCR(7)=1 IF(CRTSCR(I:I).EQ.'G'.OR.CRTSCR(I:I).EQ.'g') KSCR(8)=1 12 CONTINUE END IF C JWAVE=IWAVE JSRC=ISRC IF(IWAVE.EQ.0) THEN C C Erasing screen: IF(KANSI.GE.1.OR.KPLUS.GE.3) THEN WRITE(TEXT,'(A)') 'CRT: Computing.' CALL CURSOR(-3,TEXT(1:20)) END IF KSCR(NSCR)=NLINES-1 C ELSE C C Space between frames: STREET=2.*WIDTH C C Coefficients of the linear projections onto the screen: AUX1=BOUNDR(2)-BOUNDR(1) IF(AUX1.EQ.0.) THEN AUX1=1. END IF H1A=((HMAX-HMIN-STREET)/2.-3.*WIDTH)/AUX1 H1B=HMIN+1.5*WIDTH-BOUNDR(1)*H1A AUX1=BOUNDR(4)-BOUNDR(3) IF(AUX1.EQ.0.) THEN AUX1=1. END IF H2A=((HMAX-HMIN-STREET)/2.-3.*WIDTH)/AUX1 H2B=HMAX-1.5*WIDTH-BOUNDR(4)*H2A V2A=((VMAX-VMIN-STREET)/2.-3.*WIDTH)/AUX1 V2B=VMAX-1.5*WIDTH-BOUNDR(4)*V2A AUX1=BOUNDR(6)-BOUNDR(5) IF(AUX1.EQ.0.) THEN AUX1=1. END IF V3A=((VMAX-VMIN-STREET)/2.-3.*WIDTH)/AUX1 V3B=VMIN+1.5*WIDTH-BOUNDR(5)*V3A C C Screen graphics: IF(KSCR(8).NE.0) THEN C C Plot initialization: CALL PLOTS(0,0,0) CALL NEWPEN(1) C C Plotting frames: C Left-hand top H1=HMIN+WIDTH/2. H2=(HMIN+HMAX-STREET-WIDTH)/2. V1=(VMIN+VMAX+STREET+WIDTH)/2. V2=VMAX-WIDTH/2. CALL PLOT(H1,V1,3) CALL PLOT(H2,V1,2) CALL PLOT(H2,V2,2) CALL PLOT(H1,V2,2) CALL PLOT(H1,V1,2) C Left-hand bottom V1=VMIN+WIDTH/2. V2=(VMIN+VMAX-STREET-WIDTH)/2. CALL PLOT(H1,V1,3) CALL PLOT(H2,V1,2) CALL PLOT(H2,V2,2) CALL PLOT(H1,V2,2) CALL PLOT(H1,V1,2) C Right-hand bottom H1=(HMIN+HMAX+STREET+WIDTH)/2. H2=HMAX-WIDTH/2. CALL PLOT(H1,V1,3) CALL PLOT(H2,V1,2) CALL PLOT(H2,V2,2) CALL PLOT(H1,V2,2) CALL PLOT(H1,V1,2) C Right-hand top V1=(VMIN+VMAX+STREET+WIDTH)/2. V2=VMAX-WIDTH/2. CALL NEWPEN(6) CALL PLOT(H1,V1,3) CALL PLOT(H2,V1,2) CALL PLOT(H2,V2,2) CALL PLOT(H1,V2,2) CALL PLOT(H1,V1,2) C C Plotting receivers CALL NEWPEN(1) DO 51 I=1,NREC IF(ISRFX(1).EQ.-1.AND.ISRFX(2).EQ.-2) THEN AUX1=XREC(1,I)*H1A+H1B AUX2=XREC(2,I)*V2A+V2B ELSE IF(ISRFX(2).EQ.-1.AND.ISRFX(1).EQ.-2) THEN AUX1=XREC(2,I)*H1A+H1B AUX2=XREC(1,I)*V2A+V2B ELSE IF(ISRFX(1).EQ.-1.AND.ISRFX(2).EQ.-3) THEN AUX1=XREC(1,I)*H1A+H1B AUX2=XREC(2,I)*V3A+V3B ELSE IF(ISRFX(2).EQ.-1.AND.ISRFX(1).EQ.-3) THEN AUX1=XREC(2,I)*H1A+H1B AUX2=XREC(1,I)*V3A+V3B ELSE IF(ISRFX(1).EQ.-2.AND.ISRFX(2).EQ.-3) THEN AUX1=XREC(1,I)*H2A+H2B AUX2=XREC(2,I)*V3A+V3B ELSE IF(ISRFX(2).EQ.-2.AND.ISRFX(1).EQ.-3) THEN AUX1=XREC(2,I)*H2A+H2B AUX2=XREC(1,I)*V3A+V3B ELSE GO TO 52 END IF CALL PLOT(AUX1-2.*WIDTH,AUX2-2.*WIDTH,3) CALL PLOT(AUX1+2.*WIDTH,AUX2-2.*WIDTH,2) CALL PLOT(AUX1+2.*WIDTH,AUX2+2.*WIDTH,2) CALL PLOT(AUX1-2.*WIDTH,AUX2+2.*WIDTH,2) CALL PLOT(AUX1-2.*WIDTH,AUX2-2.*WIDTH,2) 51 CONTINUE 52 CONTINUE DO 53 I=1,NREC IF(ISRFX(1).EQ.-1.AND.ISRFX(2).EQ.0.) THEN AUX1=XREC(1,I)*H1A+H1B CALL PLOT(AUX1,BOUNDR(3)*V2A+V2B,3) CALL PLOT(AUX1,BOUNDR(4)*V2A+V2B,2) CALL PLOT(AUX1,BOUNDR(5)*V3A+V3B,3) CALL PLOT(AUX1,BOUNDR(6)*V3A+V3B,2) ELSE IF(ISRFX(1).EQ.-2.AND.ISRFX(2).EQ.0.) THEN AUX1=XREC(1,I)*H2A+H2B AUX2=XREC(1,I)*V2A+V2B CALL PLOT(AUX1,BOUNDR(5)*V3A+V3B,3) CALL PLOT(AUX1,BOUNDR(6)*V3A+V3B,2) CALL PLOT(BOUNDR(1)*H1A+H1B,AUX2,3) CALL PLOT(BOUNDR(2)*H1A+H1B,AUX2,2) ELSE IF(ISRFX(1).EQ.-3.AND.ISRFX(2).EQ.0.) THEN AUX2=XREC(1,I)*V3A+V3B CALL PLOT(BOUNDR(1)*H1A+H1B,AUX2,3) CALL PLOT(BOUNDR(2)*H1A+H1B,AUX2,2) CALL PLOT(BOUNDR(3)*H2A+H2B,AUX2,3) CALL PLOT(BOUNDR(4)*H2A+H2B,AUX2,2) ELSE GO TO 54 END IF 53 CONTINUE 54 CONTINUE C END IF END IF RETURN END C C======================================================================= C C C SUBROUTINE SCRO2(IRAY) INTEGER IRAY C C This screen output subroutine is called when starting the complete C tracing of a new ray. C C Input: C IRAY... The index of the ray which will be computed (i.e. the C output of the subroutine RPAR2 from the file 'rpar.for'). C C No output. C C Common block /INITC/ (see subroutine file 'init.for'): INCLUDE 'initc.inc' C initc.inc C None of the storage locations of the common block are altered. C C Common block /SCROC/: INCLUDE 'scro.inc' C scro.inc C Storage locations H1OLD,H2OLD,V2OLD,V3OLD of the common block are C defined in this subroutine. C C Subroutines and external functions required: EXTERNAL CURSOR C CURSOR..This file. C C Date: 2003, May 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER MTEXT,NCHAR,K1,K2,NWORD,NSPACE,N1,N2 PARAMETER (MTEXT=120) CHARACTER*(MTEXT) TEXT C C Writing to the screen: K1=1 10 CONTINUE C Determining items K1 to K2 for the current output line: NWORD=0 NCHAR=0 IF(K1.LE.1.AND.KSCR(1).NE.0) THEN IF(NCHAR+NWORD+11.LE.NWIDTH) THEN NWORD=NWORD+1 NCHAR=NCHAR+11 ELSE K2=0 GO TO 20 END IF END IF IF(K1.LE.2.AND.KSCR(2).NE.0) THEN IF(NCHAR+NWORD+9.LE.NWIDTH) THEN NWORD=NWORD+1 NCHAR=NCHAR+9 ELSE K2=1 GO TO 20 END IF END IF IF(K1.LE.4.AND.KSCR(3)+KSCR(4).NE.0) THEN IF(NCHAR+NWORD+12*KSCR(3)+7*KSCR(4).LE.NWIDTH) THEN NWORD=NWORD+MAX0(KSCR(3),KSCR(4)) NCHAR=NCHAR+12*KSCR(3)+7*KSCR(4) ELSE K2=2 GO TO 20 END IF END IF IF(K1.LE.5.AND.KSCR(5).NE.0) THEN IF(K1.EQ.5) THEN NWORD=1 NCHAR=19 ELSE IF(NCHAR+NWORD+35.LE.NWIDTH) THEN NWORD=NWORD+2 NCHAR=NCHAR+34 ELSE K2=4 GO TO 20 END IF END IF END IF K2=5 20 CONTINUE IF(NWORD.GT.0) THEN C Writing items K1 to K2 to string TEXT(1:N2) N2=0 IF(NWORD.LE.1) THEN NSPACE=0 ELSE NSPACE=MIN0((NWIDTH-NCHAR)/(NWORD-1),8) END IF IF(K1.LE.3.AND.4.LE.K2) THEN IF(KSCR(3).NE.0) THEN IF(KSCR(4).NE.0) THEN N1=N2+1 N2=N2+11 WRITE(TEXT(N1:N2),'(A,I4)') 'Tracing ray' ELSE N1=N2+1 N2=N2+4 WRITE(TEXT(N1:N2),'(A,I4)') 'Ray:' END IF N1=N2+1 N2=N2+8+NSPACE WRITE(TEXT(N1:N2),'(I8)') IRAY ELSE IF(KSCR(4).NE.0) THEN N1=N2+1 N2=N2+7+NSPACE WRITE(TEXT(N1:N2),'(A,I4)') 'Tracing' END IF END IF END IF IF(K1.LE.5.AND.5.LE.K2.AND.KSCR(5).NE.0) THEN IF(K1.EQ.5) THEN N1=1 N2=19 WRITE(TEXT(N1:N2),'(A,F14.6)') 'Par1:',YI(20) CALL CURSOR(0,TEXT(1:N2)) KSCR(NSCR)=KSCR(NSCR)-1 WRITE(TEXT(N1:N2),'(A,F14.6)') 'Par2:',YI(21) N2=19+NSPACE ELSE N1=N2+1 N2=N2+17+NSPACE WRITE(TEXT(N1:N2),'(A,F12.6)') 'Par1:',YI(20) N1=N2+1 N2=N2+17+NSPACE WRITE(TEXT(N1:N2),'(A,F12.6)') 'Par2:',YI(21) END IF END IF IF(IRAY.EQ.1) THEN IF(K1.LE.2.AND.2.LE.K2.AND.KSCR(2).NE.0) THEN N1=N2+1 N2=N2+9+NSPACE WRITE(TEXT(N1:N2),'(A,I4)') 'Wave:',JWAVE END IF IF(K1.LE.1.AND.1.LE.K2.AND.KSCR(1).NE.0) THEN N1=N2+1 N2=N2+11+NSPACE WRITE(TEXT(N1:N2),'(A,I4)') 'Source:',JSRC END IF END IF N2=N2-NSPACE IF(N2.GT.NWIDTH) THEN C 542 CALL ERROR('542 in SCRO1: Too long output line') C This error should not appear. Contact the authors. END IF IF(K1.GT.2.AND.N2.LE.0) THEN C 544 CALL ERROR('544 in SCRO1: Too long output line') C This error should not appear. Contact the authors. END IF IF(IRAY.LE.1.AND.N2.LE.0) THEN C 543 CALL ERROR('543 in SCRO1: Too long output line') C This error should not appear. Contact the authors. END IF IF(IRAY.LE.1.AND.K1.LE.4.AND.4.LE.K2) THEN KSCR(NSCR-1)=KSCR(NSCR) END IF C Writing string TEXT(1:N2) to the screen IF(IRAY.LE.1.AND.K1.LE.1) THEN IF(N2.LT.15) THEN TEXT(N2+1:15)=' ' N2=15 END IF CALL CURSOR(-1,TEXT(1:N2)) ELSE IF(IRAY.GT.1.AND.K1.LE.3) THEN IF(N2.GT.0) THEN IF(K2.LE.3) THEN IF(KSCR(NSCR-1)+1.EQ.KSCR(NSCR)) THEN CALL CURSOR(-1,TEXT(1:N2)) ELSE CALL CURSOR(NLINES-KSCR(NSCR-1)-1,TEXT(1:N2)) END IF KSCR(NSCR)=KSCR(NSCR-1)+1 ELSE IF(KSCR(NSCR-1).EQ.KSCR(NSCR)) THEN CALL CURSOR(-1,TEXT(1:N2)) ELSE CALL CURSOR(NLINES-KSCR(NSCR-1),TEXT(1:N2)) END IF KSCR(NSCR)=KSCR(NSCR-1) END IF END IF ELSE CALL CURSOR(0,TEXT(1:N2)) KSCR(NSCR)=KSCR(NSCR)-1 END IF END IF K1=K2+1 IF(K1.LE.5) GO TO 10 C IF(KSCR(6).NE.0) THEN WRITE(TEXT,'(A)') ' ' CALL CURSOR(0,TEXT(1:20)) WRITE(TEXT,'(A)') ' ISB ICB ISRF' CALL CURSOR(0,TEXT(1:20)) KSCR(NSCR)=KSCR(NSCR)-2 END IF C C Initial position for plotting the ray: H1OLD=YI(3)*H1A+H1B H2OLD=YI(4)*H2A+H2B V2OLD=YI(4)*V2A+V2B V3OLD=YI(5)*V3A+V3B RETURN END C C======================================================================= C C C SUBROUTINE SCRO3(YL,Y,YY,IY) REAL YL(6),Y(35),YY(5) INTEGER IY(12) C C This screen output subroutine is called with constant step STORE of C the independent variable along the ray, and at the points of C intersection with interfaces either before and after the C transformation. It plots the part of the ray computed in the last C step of the numerical integration. It is called by the subroutine C WRIT31. C C Input: C YL... Array containing local quantities at the point of the ray. C Y... Array containing basic quantities computed along the ray. C YY... Array containing real auxiliary quantities computed along C the ray. C IY... Array containing integer auxiliary quantities computed C along the ray. C None of the input parameters are altered. C C No output. C C Common block /SCROC/: INCLUDE 'scro.inc' C scro.inc C Storage locations H1OLD,H2OLD,V2OLD,V3OLD of the common block are C redefined in this subroutine. C C Subroutines and external functions required: EXTERNAL CURSOR EXTERNAL NSRFC,PLOT,NEWPEN INTEGER NSRFC C CURSOR..This file. C NSRFC... File 'model.for'. C PLOT,NEWPEN... CalComp graphics subroutines. C C Date: 2003, May 12 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER MTEXT PARAMETER (MTEXT=120) CHARACTER*(MTEXT) TEXT REAL H1NEW,H2NEW,V2NEW,V3NEW C C Writing to the screen: IF(KSCR(6).NE.0) THEN IF(IY(6).NE.0) THEN IF(KSCR(NSCR).GE.2+IPAUSE) THEN IF(IY(8).NE.0) THEN WRITE(TEXT,'(A,3I4)') '.......',IY(4),IY(5),IY(6) CALL CURSOR(0,TEXT(1:20)) ELSE WRITE(TEXT,'(A,3I4)') ' ',IY(4),IY(5),IY(6) CALL CURSOR(0,TEXT(1:20)) END IF KSCR(NSCR)=KSCR(NSCR)-1 ELSE IF(IY(8).NE.0) THEN WRITE(TEXT,'(A,3I4)') '.......',IY(4),IY(5),IY(6) CALL CURSOR(-1,TEXT(1:20)) ELSE WRITE(TEXT,'(A,3I4)') ' ',IY(4),IY(5),IY(6) CALL CURSOR(-1,TEXT(1:20)) END IF END IF END IF END IF C C Screen graphics: IF(KSCR(8).NE.0) THEN C Plotting the ray at the screen: H1NEW=Y(3)*H1A+H1B H2NEW=Y(4)*H2A+H2B V2NEW=Y(4)*V2A+V2B V3NEW=Y(5)*V3A+V3B CALL NEWPEN(IY(11)+2) CALL PLOT(H1OLD,V2OLD,3) CALL PLOT(H1NEW,V2NEW,2) CALL PLOT(H1OLD,V3OLD,3) CALL PLOT(H1NEW,V3NEW,2) CALL PLOT(H2OLD,V3OLD,3) CALL PLOT(H2NEW,V3NEW,2) H1OLD=H1NEW H2OLD=H2NEW V2OLD=V2NEW V3OLD=V3NEW END IF C RETURN END C C======================================================================= C C C SUBROUTINE SCRO4(IRAY,YL,Y,YY,IY,IEND,ISHEET) C INTEGER IRAY,IY(12),IEND,ISHEET REAL YL(6),Y(35),YY(5) C C This screen output subroutine is called after termination of tracing C the ray. C C Input: C IRAY... The index of the ray which has been computed (i.e. the C output of the subroutine RPAR2 of the file 'rpar.for'). C YL... Array containing local quantities at the point of the ray. C Y... Array containing basic quantities computed along the ray. C YY... Array containing real auxiliary quantities computed along C the ray. C IY... Array containing integer auxiliary quantities computed C along the ray. C IEND... Reason of the termination of the computation of a ray, see C C.R.T.5.4. C See subroutine RAY in the subroutine file 'ray.for' for C detailed description of IEND. C ISHEET..Ray-history index. The different ray histories are C consecutively indexed by positive integers 1,2,3,... C According to their appearance during ray tracing. C The ray histories are indexed independently within each C elementary wave. C The ray-history indices are complemented with sign: C positive - successful ray (crossing reference surface), C negative - unsuccessful ray (terminating before crossing C reference surface). C C No output. C C Common block /RPARD/ (defined in file 'rpar.for'): INCLUDE 'rpard.inc' C rpard.inc C Storage locations of the common block are not altered. C C Common block /RPARC/ (defined in file 'rpar.for'): INCLUDE 'rparc.inc' C rparc.inc C Storage locations of the common block are not altered. C C Common block /SCROC/: INCLUDE 'scro.inc' C scro.inc C Storage locations of the common block are not altered. C C Subroutines and external functions required: EXTERNAL CURSOR C CURSOR..This file. C C Date: 2003, May 12 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER MTEXT PARAMETER (MTEXT=120) CHARACTER*(MTEXT) TEXT INTEGER I REAL STREET,H1,H2,V1,V2,AUX1,AUX2 C IF(KSCR(7).NE.0) THEN IF(IEND.LT.70) THEN WRITE(TEXT,'(A,I3,3I4)') 'END:',IEND,IY(4),IY(5),IY(6) ELSE WRITE(TEXT,'(A,I3,3I4)') 'END:',IEND END IF IF(KSCR(6).EQ.0) THEN CALL CURSOR(0,TEXT(1:19)) KSCR(NSCR)=KSCR(NSCR)-1 END IF ELSE WRITE(TEXT,'(A)') ' ' END IF IF(KSCR(6).NE.0) THEN IF(KSCR(NSCR).GE.2+IPAUSE) THEN CALL CURSOR(0,TEXT(1:19)) KSCR(NSCR)=KSCR(NSCR)-1 WRITE(TEXT,'(A)') ' ' C Erasing the rest of the history of the previous ray DO 10 I=1,KSCR(NSCR)-1 CALL CURSOR(0,TEXT(1:19)) KSCR(NSCR)=KSCR(NSCR)-1 10 CONTINUE END IF CALL CURSOR(-5,TEXT(1:19)) KSCR(NSCR)=NLINES END IF IF(KSCR(4).NE.0) THEN WRITE(TEXT,'(A)') 'Aiming' IF(KSCR(NSCR-1).EQ.KSCR(NSCR)) THEN IF(KSCR(3).NE.0) THEN CALL CURSOR(-1,TEXT(1:11)) ELSE CALL CURSOR(-1,TEXT(1:7)) END IF ELSE IF(KSCR(3).NE.0) THEN CALL CURSOR(NLINES-KSCR(NSCR-1),TEXT(1:11)) ELSE CALL CURSOR(NLINES-KSCR(NSCR-1),TEXT(1:7)) END IF END IF KSCR(NSCR)=KSCR(NSCR-1) END IF C C Screen graphics: IF(KSCR(8).NE.0) THEN C Plotting the normalized shooting parameters at the screen: C (a) Scaling the parameters IF(ISRFX(2).EQ.0) THEN C Initial-value or one-parametric shooting IF(ANUM.GT.0.) THEN AUX1=G1/ANUM ELSE AUX1=0.5 END IF IF(BNUM.GT.0.) THEN AUX2=G2/BNUM ELSE AUX2=0.5 END IF ELSE C Two-parametric shooting AUX1=G1 AUX2=G2 END IF C (b) Plotting STREET=2.*WIDTH H1=(HMIN+HMAX+STREET+WIDTH)/2.+STREET+WIDTH H2=HMAX-WIDTH/2. -STREET-WIDTH V1=(VMIN+VMAX+STREET+WIDTH)/2.+STREET+WIDTH V2=VMAX-WIDTH/2. -STREET-WIDTH AUX1=H1+(H2-H1)*AUX1 AUX2=V1+(V2-V1)*AUX2 CALL NEWPEN(IABS(ISHEET)+1) CALL PLOT(AUX1-WIDTH,AUX2 ,3) CALL PLOT(AUX1+WIDTH,AUX2 ,2) CALL PLOT(AUX1 ,AUX2 ,2) CALL PLOT(AUX1 ,AUX2-WIDTH,2) CALL PLOT(AUX1 ,AUX2+WIDTH,2) C C Check for non-existing rays: IF(IEND.GE.70) THEN RETURN END IF C C4.10 (c) Endpoints (or points at the reference surface) C4.10 IF(ISHEET.GT.0) THEN C4.10 IF(ISRFX(1).EQ.-1.AND.ISRFX(2).EQ.-2.) THEN C4.10 AUX1=X1*H1A+H1B C4.10 AUX2=X2*V2A+V2B C4.10 ELSE IF(ISRFX(2).EQ.-1.AND.ISRFX(1).EQ.-2.) THEN C4.10 AUX1=X2*H1A+H1B C4.10 AUX2=X1*V2A+V2B C4.10 ELSE IF(ISRFX(1).EQ.-1.AND.ISRFX(2).EQ.-3.) THEN C4.10 AUX1=X1*H1A+H1B C4.10 AUX2=X2*V3A+V3B C4.10 ELSE IF(ISRFX(2).EQ.-1.AND.ISRFX(1).EQ.-3.) THEN C4.10 AUX1=X2*H1A+H1B C4.10 AUX2=X1*V3A+V3B C4.10 ELSE IF(ISRFX(1).EQ.-2.AND.ISRFX(2).EQ.-3.) THEN C4.10 AUX1=X1*H2A+H2B C4.10 AUX2=X2*V3A+V3B C4.10 ELSE IF(ISRFX(2).EQ.-2.AND.ISRFX(1).EQ.-3.) THEN C4.10 AUX1=X2*H2A+H2B C4.10 AUX2=X1*V3A+V3B C4.10 ELSE C4.10 AUX1=Y(3)*H1A+H1B C4.10 AUX2=Y(4)*V2A+V2B C4.10 END IF C4.10 CALL PLOT(AUX1-WIDTH,AUX2 ,3) C4.10 CALL PLOT(AUX1+WIDTH,AUX2 ,2) C4.10 CALL PLOT(AUX1 ,AUX2 ,2) C4.10 CALL PLOT(AUX1 ,AUX2-WIDTH,2) C4.10 CALL PLOT(AUX1 ,AUX2+WIDTH,2) C4.10 END IF C (c) Endpoints AUX1=Y(3)*H1A+H1B AUX2=Y(4)*V2A+V2B CALL PLOT(AUX1-WIDTH,AUX2 ,3) CALL PLOT(AUX1+WIDTH,AUX2 ,2) CALL PLOT(AUX1 ,AUX2 ,2) CALL PLOT(AUX1 ,AUX2-WIDTH,2) CALL PLOT(AUX1 ,AUX2+WIDTH,2) AUX2=Y(5)*V3A+V3B CALL PLOT(AUX1-WIDTH,AUX2 ,3) CALL PLOT(AUX1+WIDTH,AUX2 ,2) CALL PLOT(AUX1 ,AUX2 ,2) CALL PLOT(AUX1 ,AUX2-WIDTH,2) CALL PLOT(AUX1 ,AUX2+WIDTH,2) AUX1=Y(4)*H2A+H2B CALL PLOT(AUX1-WIDTH,AUX2 ,3) CALL PLOT(AUX1+WIDTH,AUX2 ,2) CALL PLOT(AUX1 ,AUX2 ,2) CALL PLOT(AUX1 ,AUX2-WIDTH,2) CALL PLOT(AUX1 ,AUX2+WIDTH,2) END IF C RETURN END C C======================================================================= C C C SUBROUTINE SCRO5(IWAVE) INTEGER IWAVE C C This screen output subroutine is called after termination of the C computation of an elementary wave, and when terminating the complete C ray tracing program. C C Input: C IWAVE...Zero when terminating the complete ray tracing program, C otherwise the index of the elementary wave which has been C computed (i.e. the output of the subroutine CODE1 from the C file 'code.for'). C C No output. C C Common block /SCROC/: INCLUDE 'scro.inc' C scro.inc C Storage locations of the common block are not altered. C C Subroutines and external functions required: EXTERNAL CURSOR,PLOT C CURSOR..This file. C PLOT... CalComp graphics subroutine. C C Date: 2003, May 12 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER MTEXT PARAMETER (MTEXT=120) CHARACTER*(MTEXT) TEXT C IF(IWAVE.EQ.0) THEN C Erasing text screen: IF(KANSI.GE.1.OR.KPLUS.GE.3) THEN WRITE(TEXT,'(A)') ' ' CALL CURSOR(-3,TEXT(1:20)) KSCR(NSCR)=NLINES-1 END IF ELSE IF(IPAUSE.GT.0) THEN C Waiting to confirm erasing of the ray diagram WRITE(TEXT,'(A)') 'PRESS ENTER' CALL CURSOR(0,TEXT(1:19)) READ(*,*) KSCR(NSCR)=KSCR(NSCR)-1 END IF IF(KSCR(NSCR).LT.NLINES-1) THEN WRITE(TEXT,'(A)') ' ' CALL CURSOR(-2,TEXT(1:20)) KSCR(NSCR)=NLINES-1 END IF C C Screen graphics: IF(KSCR(8).NE.0) THEN C Closing down plotting CALL PLOT(0.0,0.0,999) END IF C END IF RETURN END C C======================================================================= C C C SUBROUTINE CURSOR(MOVE,TEXT) INTEGER MOVE CHARACTER*(*) TEXT C C This function moves the cursor and writes the given line of text. C C Input: C MOVE... Indication of the required cursor movement. C MOVE.GT.0: Move the cursor to line MOVE. C MOVE=0: No special action, sequential writing. C MOVE=-1: Move the cursor 1 line upwards in order to C overwrite the preceding line. C MOVE=-2: Return the cursor to the home position. C MOVE=-3: Erase the screen and return the cursor to the C home position. C MOVE=-5: No action, sequential writing. Return the cursor C to the home position after writing. C TEXT... String to be written. C C No output: C C Common block /SCROC/: INCLUDE 'scro.inc' C scro.inc C Storage locations of the common block are not altered. C C Date: 2003, April 24 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C No auxiliary storage locations. C IF(KANSI.EQ.1) THEN IF(MOVE.GT.0) THEN IF(KPLUS.EQ.0) THEN WRITE(*,'(2A)') CHAR(27)//CHAR(91)//CHAR(48+MOVE/10)// * CHAR(48+MOD(MOVE,10))//';1H',TEXT ELSE WRITE(*,'(2A)') ' '// * CHAR(27)//CHAR(91)//CHAR(48+MOVE/10)// * CHAR(48+MOD(MOVE,10))//';1H',TEXT END IF ELSE IF(MOVE.EQ.0) THEN IF(KPLUS.EQ.0) THEN WRITE(*,'(2A)') TEXT ELSE WRITE(*,'(2A)') ' ',TEXT END IF ELSE IF(MOVE.EQ.-1) THEN IF(KPLUS.EQ.0) THEN WRITE(*,'(2A)') CHAR(27)//CHAR(91)//'1A',TEXT ELSE WRITE(*,'(2A)') ' '//CHAR(27)//CHAR(91)//'1A',TEXT END IF ELSE IF(MOVE.EQ.-2) THEN IF(KPLUS.EQ.0) THEN WRITE(*,'(2A)') CHAR(27)//CHAR(91)//'0;0H',TEXT ELSE WRITE(*,'(2A)') ' '//CHAR(27)//CHAR(91)//'0;0H',TEXT END IF ELSE IF(MOVE.EQ.-3) THEN IF(KPLUS.EQ.0) THEN WRITE(*,'(2A)') CHAR(27)//CHAR(91)//'2J',TEXT ELSE WRITE(*,'(2A)') ' '//CHAR(27)//CHAR(91)//'2J',TEXT END IF ELSE IF(MOVE.EQ.-5) THEN IF(KPLUS.EQ.0) THEN WRITE(*,'(2A)') TEXT,CHAR(27)//CHAR(91)//'0;0H' ELSE WRITE(*,'(3A)') ' ',TEXT,CHAR(27)//CHAR(91)//'0;0H' END IF ELSE C 545 CALL ERROR('545 in CURSOR: Icorrect value of argument MOVE') C This error should not appear. Contact the authors. END IF ELSE IF(MOVE.EQ.-1) THEN IF(KPLUS.GE.1) THEN WRITE(*,'(2A)') '+',TEXT ELSE WRITE(*,'(2A)') TEXT C Preceding line cannot be overwritten if KPLUS.EQ.1. END IF ELSE IF(MOVE.EQ.-2.OR.MOVE.EQ.-3) THEN IF(KPLUS.GE.3) THEN WRITE(*,'(2A)') '1',TEXT ELSE IF(KPLUS.GE.1) THEN WRITE(*,'(2A)') ' ',TEXT C No cursor positioning available. ELSE WRITE(*,'(2A)') TEXT C No cursor positioning available. END IF ELSE IF(KPLUS.GE.1) THEN WRITE(*,'(2A)') ' ',TEXT ELSE WRITE(*,'(2A)') TEXT END IF END IF END IF RETURN END C C======================================================================= C C C C Specification of the used CalComp graphics subroutines: C C SUBROUTINE PLOTS(I1,I2,I3)... Initializes plotting. It is called C when starting the computation of the new elementary wave. C I1,I2,I3... Set to zeros. C SUBROUTINE PLOT(XPAGE,YPAGE,IPEN)... Moves pen or plots a line. C XPAGE, YPAGE... Coordinates, often in centimetres, C sometimes in inches. C IPEN... Controls the plotting: C IPEN=2... The pen is down during the movement, thus C drawing a line. C IPEN=3... The pen is up during the movement. C IPEN=999... Terminates plotting initialized by the C subroutine PLOTS. C SUBROUTINE NEWPEN(INP)... Changes the colour. C INP... Specifies the index of colour to be selected. C The colours are indexed 1,2,3,4,... . C All parameters are input parameters and should not be modified. C C The plotting area is defined by variables HMIN,HMAX,VMIN,VMAX, and C WIDTH of the common block /SCROC/ and may be adjusted in the block C data subroutine SCROB. C SCROB C C======================================================================= C