[Remember, this was before PCs]
This program performs interactive 2 or 2 1/2 dimensional forward gravity modeling along a profile. The user enters the cross-sectional shape and density of up to 20 subsurface bodies to calculate their gravity effect at up to 1024 stations along a profile. The shape of each body can be desribed by up to 18 points in cross section and a length of the body in and out of the profile. Each station is described by an X location along the profile and an elevation. An observed gravity value can be entered along with each station, which can be compared to the calculated gravity. The subroutine to calculate the gravity is based on Cady, 1980. The program is written in VAX/VMS Fortran-77 using the terminal-independent screen input/output routines listed in chapter IV of Appendix A. The program is set up in a menu format. The user can input data, perform the calculations, plot the results, modify the input parameters, and recalculate the gravity without leaving the program.
The program has six menus. The first four menus can be reached from any location in the program by pressing the corresponding PF key 1 through 4. Menu 1's primary function is to perform input and output. This menu also lists all general commands. Menus 2, 3 and 4 allows the user to view and modify the data. In menu 2, the user has access to the plotting parameters. Plotting parameters do not affect the calculations, but how the results are displayed. Menu 3 allows access to the body description data. The user can view and modify the shape of any of the subsurface bodies. A single point can be changed, a point can be deleted, or a new point can be inserted. Similarly, whole bodies can be inserted or deleted into the data set. Menu 4 allows access to the station data. Stations can be modified, deleted, or inserted into the data set. The two remaining menus can be reach by entering the commands STA or PLOT on the command line. The STA menu allows station data to be entered from a previously existing file. The PLOT menu allows the user to select the type of plot to be created, and where it is to be sent. In addition to the PF keys, the arrow keys are used to move the cursor across the screen and select various data parameters. Each menu has a help file that can be accessed by entering the command HELP.
Upon entering the program, menu 1 is displayed. The user is asked for the name of a data file. This may be of a file that already exists, or of a new file to be created. The name of this file is displayed at the top of menu 1. If the user wishes to use the contents of a file that already exists, the file should be read into the program by entering the command LOAD. If a new data set is being created, the user must enter all parameters in menus 2, 3, and 4.
*0
enter menu 1 here
*
Other general commands that are available are described briefly here. Most can be executed from any menu in the program. The command SAVE causes the data in the program to be written to the data file. Note that any changes made to a data set is not made permanent until the data is written to a file with SAVE. The command FILE allows the user to select a new data file name. Thus, a copy of an existing file could be made by loading the first data set, entering a new file name with FILE, and then writting the data to this new file with SAVE. SUM allows the user to create a summary of the data. The summary may be displayed to the screen, or written to a file. If the user writes a summary to a file, the program gives the option of sending the file to the printer. CALC performs the gravity calculations. DCL allows Digital control language commands to be executed from the program. After entering DCL, the user is prompted for the command. Most any command normally entered at the $ prompt may be executed. This can include DELETE, COPY, SET DEFAULT, etc. The command entered is spawned as a subprocess. END exits the program.
Note that when a new file name is entered with the command FILE, the program assumes the data set has not yet been loaded. If the user were to try to use the commands CALC, PLOT, SUM or SAVE, the program would display a message stating that the file has not yet been loaded. This message can be overridden by jumping to menu 2, then back to menu 1.
Menu 2 is reached by pressing PF2. In this menu the user can modify the plotting parameters. To change a parameter, move the cursor to the desired location with the arrow keys. Enter the new vaule. This will be displayed at the bottom of the menu on the command line. When the return key is pressed, the new value will be placed at the location of the cursor. To change the units of the plot, move the cursor to the desired units and press return.
*0
enter menu 2 here
*
Menu 3 is reached by pressing PF3. Here the user can modify the parameters of any of the bodies. If more than one body exists, upon entering this menu the program will ask for the desired body. The user enters a number from 1 to 20, or can press any of the PF keys to select another menu. If a number of a body that does not exist is entered, the program assumes that a new body is being created. If the user does not wish to create a new body, such as if the number was entered incorrectly, the user can press PF3 again to select the proper body. A new body is not made permanent until the user enters the first X, Z point.
*0
enter menu 3 here
*
At the top of menu 3 are three parameters: density contrast, and length of body to the left and right of strike. The density contrast is always entered in grams per cubic centimeter. The length of the body allows the user to select traditional two-dimensional gravity modeling, or two and one half-dimensional modeling. 2-D modeling assumes that the body is infinite in and out of the profile. 2 1/2 - D modeling allows a finite length to the body to be set by adding end corrections to the calculations. Infinite length bodies are selected by entering 0.0 into the left and right length parameters. Although this seems to indicate that the body has no length, this signals the program to perform the 2-D calculations. If the user enters a value other than 0.0 into the length parameters 2 1/2 - D calculations are performed. Note that the values entered here must be positive and that they are in the units selected in PF2.
The lower half of menu 3 shows the points describing the body. The cross-sectional shape of the body is described in a clockwise fashion. Each point in the body is entered in an X, Z coordinate system where X increases from left to right, and Z increases downward. Note that in many commonly used modeling programs, the user must close the body by entering the first point as also the last point. This program assumes that the last point connects to the first, so one should not enter the first point twice.
Menu 4 is reached by pressing PF4. Here station data can be viewed and modified. The X coordinate, elevation, observed gravity, and calculated gravity of 15 stations are displayed. If more than 15 stations exist, the user can scroll through the data using the arrow keys. Commands specific to this menu include the following. The command I allows the user to insert new stations after the current position of the cursor. The user will be promted for the X coordinate, elevation, and observed gravity. To end insert mode, press return when the program prompts for the next X coordinate. D deletes the current line. The user is asked to confirm this before the line is deleted. If a block of lines are to be deleted, the user can enter Dn, where n is the number of lines to be deleted. Ln moves the cursor to line (station) number n. T moves the cursor to the top of the scrolling region. B moves the cursor to the bottom. The command REC allows the X coordinate of each station to be recalculated to evenly spaced stations based on the range of X set in PF2. ELE allows the elevation of each station to be set to a constant. MOV allows the gravity values currently in the calculated column to be moved into the observed column. The command M allows the user to adjust the calculated gravity values by a constant so that when plotted, the calculated curve overlaps the observed curve. Since gravity anomalies are relative, adjusting their values by a constant does not affect the results. The M command or Mn, where n is the station number, allows the user to select at which station the calculated gravity is to be equal to the observed gravity. The difference between the observed and calculated gravity at the matched station is determined, and this amount is subtracted from the calculated gravity of each station.
*0 enter menu 4 here *
Entering STA on the command line accesses the Load Station menu. This menu allows the user to read various types of station data from a secondary file. This includes location, elevation and observed gravity, or any combination of these. The user is prompted for the name of file containing the data, how many records to skip in the file before begining to read, and the format the data is in. Parenthesis must be included in the format statement. For example, if a data file contains four columns in (1X,2F10.3,5X,2F8.3) format, and the user wishes to read the location from the first column, and observed gravity from the fourth column, the user would enter for the format (1X,F10.3,15X,F8.3). This tells the program to read the first column, skip over the second column, and read the third.
*0 enter sta menu here *
The final menu is accessed by entering PLOT on the command line. This menu is used to plot the results of the modeling. On this menu all of the options for the plot are listed. The ones that have been selected are highlighted. To turn on or off an option, the user enters the corresponding number. To begin the plot, the user enters the command SEND.
PROGRAM GRAV_TWO_HALF_MODEL
C
C VERSION 1 WRITTEN BY TIM FOGARTY MAY 79
C VERSION 2 2 1/2 D CADY METHOD DEC 80
C VERSION 3 VAX/VMS SCREEN I/O SEP 83
C VERSION 4 PF KEYS AND ARROWS DEC 84
C
LOGICAL*2 LOADED,CALC
CHARACTER sbuf*2560,FILE*32,ANS*10,CHAR,E*3
common/screenbuf/sbuf
COMMON/BLKFILE/FILE,LOADED,CALC
FILE=' '
E=CHAR(27)//'#6'
LOADED=.FALSE.
CALC=.FALSE.
CALL VT_SETUP
IPF=1
DO WHILE(.TRUE.)
IF(IPF.EQ.1) THEN
CALL IO_PARAM(IPF)
ELSEIF(IPF.EQ.2) THEN
CALL PLOT_PARAM(IPF)
ELSEIF(IPF.EQ.3) THEN
CALL BODY_PARAM(IPF)
ELSEIF(IPF.EQ.4) THEN
CALL STATION_PARAM(IPF)
ELSEIF(IPF.EQ.-1.OR.ANS(1:4).EQ.'PLOT') THEN
CALL PLOT_DATA(IPF)
ELSEIF(IPF.EQ.-2.OR.ANS(1:3).EQ.'END') THEN
CALL ERASE_VT
STOP
ELSEIF(IPF.EQ.0) THEN
istat=lib$set_buffer(sbuf)
CALL ERASE_VT
CALL TEXT_VT(E//'INTERACTIVE 2 1/2 D GRAVITY MODELING',
> 1,1,0)
CALL TEXT_VT('Press PF keys to select page.',5,21,0)
CALL TEXT_VT('1...Input/Output',8,23,0)
CALL TEXT_VT('2...Modify plotting parameters',10,23,0)
CALL TEXT_VT('3...Modify body parameters',12,23,0)
CALL TEXT_VT('4...Modify station parameters',14,23,0)
istat=lib$put_buffer(0)
CALL ASKQPF('What do you wish to do? ',ANS,22,1,IPF)
IF(IPF.EQ.0.AND.LNUMBER(ANS)) CALL TXT2INT(ANS,IPF)
ELSE
CALL TEXT_VT('Unknown command.',24,1,0)
CALL ASKQPF('Press PF key to select page. ',
> ANS,23,1,IPF)
CALL ERASE_LINE(24,1)
ENDIF
END DO
END
C
SUBROUTINE HELP(IQ,IPF)
CHARACTER SBUF*2560,LINE*78,SCREEN(22)*78,ANS*10,CH
common/screenbuf/sbuf
LOGICAL*2 ERROR
OPEN(UNIT=14,FILE='CADY.HLP',STATUS='OLD',READONLY,ERR=30)
ERROR=.TRUE.
DO I=1,IQ-1
READ(14,'(A1)',ERR=20) (CH,J=1,22)
END DO
READ(14,'(2X,A78)',ERR=20) (SCREEN(J),J=1,22)
ERROR=.FALSE.
20 IF(ERROR) THEN
CALL TEXT_VT(' HELP FILE -- NON-EXISTANT RECORD',22,1,1)
ERROR=.FALSE.
ELSE
ISTAT=LIB$SET_BUFFER(SBUF)
CALL ERASE_VT
DO J=1,22
ISTAT=IPURGE_BUFFER(J.EQ.(J/5)*5)
LINE=SCREEN(J)
IL=INDEX(LINE,'@')-1
IF(IL.GT.0) CALL TEXT_VT(LINE(1:IL),J,1,0)
END DO
ISTAT=LIB$PUT_BUFFER(0)
ENDIF
CLOSE(UNIT=14)
30 IF(ERROR) CALL TEXT_VT('HELP FILE NOT FOUND',22,1,1)
CALL ASKQPF(' Press RETURN to continue. ',ANS,23,1,IPF)
RETURN
END
C
INTEGER FUNCTION IPURGE_BUFFER(FLAG)
CHARACTER SBUF*2560
common/screenbuf/sbuf
LOGICAL FLAG
ISTAT=-1
IF(FLAG) THEN
ISTAT=LIB$PUT_BUFFER(0)
ISTAT=LIB$SET_BUFFER(SBUF)
ENDIF
IPURGE_BUFFER=ISTAT
RETURN
END
SUBROUTINE IO_PARAM(IPF)
LOGICAL*2 TFBODY,LNUMBER,LOADED,ERROR,CALC,REPAINT
CHARACTER sbuf*2560,TITLE*64,CHAR,E*3
CHARACTER*32 FILE,ANS
common/screenbuf/sbuf
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE,MATCH
COMMON/BLKFILE/FILE,LOADED,CALC
E=CHAR(27)//'#6'
REPAINT=.TRUE.
DO WHILE(.TRUE.)
IF(REPAINT) THEN
istat=lib$set_buffer(sbuf)
CALL ERASE_VT
CALL TEXT_VT(E//'INTERACTIVE 2 1/2 D GRAVITY MODELING',
> 1,1,1)
CALL TEXT_VT(E//'Input/Output',3,1,1)
CALL TEXT_VT('Data file:',5,1,0)
IFLAG=8
IF(FILE(1:1).GT.' ') IFLAG=1
CALL TEXT_VT(FILE,6,3,IFLAG)
IF(LOADED) THEN
CALL TEXT_VT('Data file has been loaded. ',6,37,0)
ELSE
CALL TEXT_VT('Data file has not been loaded.',6,37,0)
ENDIF
IF(CALC) THEN
CALL TEXT_VT('Gravity has been calculated. ',
> 7,37,0)
ELSE
CALL TEXT_VT('Gravity has not been calculated.',
> 7,37,0)
ENDIF
CALL TEXT_VT('Commands:',10,1,0)
CALL TEXT_VT('LOAD',11,4,1)
CALL TEXT_VT('...Read data file.',11,8,0)
CALL TEXT_VT('SAVE',12,4,1)
CALL TEXT_VT('...Write current data to file.',12,8,0)
CALL TEXT_VT('FILE',13,4,1)
CALL TEXT_VT('...Select new data file name.',13,8,0)
CALL TEXT_VT('CALC',14,4,1)
CALL TEXT_VT('...Calculate gravity.',14,8,0)
CALL TEXT_VT('PLOT',15,4,1)
CALL TEXT_VT('...Create plot of data.',15,8,0)
ISTAT=IPURGE_BUFFER(.TRUE.)
CALL TEXT_VT('STA',16,4,1)
CALL TEXT_VT('....Load new station data.',16,7,0)
CALL TEXT_VT('SUM',17,4,1)
CALL TEXT_VT('....Write summary to file or terminal.',
> 17,7,0)
CALL TEXT_VT('HELP',18,4,1)
CALL TEXT_VT('...Give description of commands.',18,8,0)
CALL TEXT_VT('DCL',19,4,1)
CALL TEXT_VT('....Enter a Digital control language'//
> ' command.',19,7,0)
CALL TEXT_VT('END',20,4,1)
CALL TEXT_VT('....End program.',20,7,0)
C
CALL TEXT_VT(' PF keys select the following: ',
> 13,48,2)
CALL TEXT_VT(' 1...Input/Output ',
> 14,48,2)
CALL TEXT_VT(' 2...Modify plotting parameters ',
> 15,48,2)
CALL TEXT_VT(' 3...Modify body parameters ',
> 16,48,2)
CALL TEXT_VT(' 4...Modify station parameters ',
> 17,48,2)
istat=lib$put_buffer(0)
ENDIF
REPAINT=.FALSE.
IF(FILE(1:1).LE.' ') THEN
CALL ASKQPF('Name of data file? ',FILE,23,1,IPF)
IFLAG=8
IF(FILE(1:1).GT.' ') IFLAG=1
CALL TEXT_VT(FILE,6,3,IFLAG)
IF(LOADED) THEN
CALL TEXT_VT('Data file has been loaded. ',6,37,0)
ELSE
CALL TEXT_VT('Data file has not been loaded.',6,37,0)
ENDIF
ENDIF
CALL ASKQPF('What do you wish to do? ',ANS,23,1,IPF)
CALL ERASE_LINE(24,1)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(ANS(1:4).EQ.'LOAD') THEN ! LOAD DATA
CALL INOUT(1)
IF(LOADED) CALL TEXT_VT('Data file has been loaded. ',
> 6,37,0)
ELSEIF(ANS(1:4).EQ.'SAVE') THEN ! SAVE DATA
IF(LOADED) THEN
CALL INOUT(2)
CALL TEXT_VT('Data file saved.',24,1,0)
ELSE
CALL TEXT_VT('No data file loaded.',24,1,0)
ENDIF
ELSEIF(ANS(1:3).EQ.'DCL') THEN ! ENTER DCL COMMAND
CALL ASKQPF('Enter a DCL command: ',ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(ANS(1:1).NE.'$') ANS='$ '//ANS
CALL ERASE_VT
CALL TEXT_VT(ANS,3,1,0)
CALL MOVE_VT(5,1)
ISTAT=LIB$SPAWN(ANS)
IF(ISTAT.GT.1) CALL LIB$STOP(%VAL(ISTAT))
CALL ASKQPF('Press RETURN to continue. ',ANS,23,1,IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=1
RETURN
ELSEIF(ANS(1:4).EQ.'FILE') THEN ! CHANGE FILE NAME
CALL ASKQPF('Name of new data file? ',ANS,23,1,IPF)
IF(ANS(1:1).GT.' ') THEN
FILE=ANS
LOADED=.FALSE.
CALC=.FALSE.
IFLAG=8
IF(FILE(1:1).GT.' ') IFLAG=1
CALL TEXT_VT(FILE,6,3,IFLAG)
CALL TEXT_VT('Data file has not been loaded.',
> 6,37,0)
CALL TEXT_VT('Gravity has not been calculated.',
> 7,37,0)
ENDIF
ELSEIF(ANS(1:3).EQ.'STA') THEN ! LOAD STATION DATA
REPAINT=.TRUE.
CALL LOAD_STA(IPF)
IF(IPF.NE.0) RETURN
ELSEIF(ANS(1:3).EQ.'SUM') THEN ! CREATE SUMMARY
REPAINT=.TRUE.
CALL SUMMARY(IPF)
IF(IPF.NE.0) RETURN
ELSEIF(ANS(1:4).EQ.'CALC') THEN ! CALCULATE GRAVITY
IF(LOADED) THEN
CALL CADY_SUB
CALL TEXT_VT('Gravity has been calculated. ',
> 7,37,0)
CALC=.TRUE.
ELSE
CALL TEXT_VT('Data set has not been loaded. ',
> 24,1,5)
ENDIF
ELSEIF(ANS(1:4).EQ.'OVER') THEN ! OVERRIDE LOAD SWITCH
LOADED=.TRUE.
CALL TEXT_VT('Data file has been loaded. ',6,37,0)
CALL TEXT_VT('LOAD switch has been over-ridden.',24,1,5)
ELSEIF(ANS(1:4).EQ.'PLOT') THEN ! PLOT DATA
CALL PLOT_DATA(IPF)
IF(IPF.NE.0) RETURN
REPAINT=.TRUE.
ELSEIF(ANS(1:4).EQ.'HELP') THEN ! HELP
CALL HELP(1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
REPAINT=.TRUE.
ELSEIF(ANS(1:3).EQ.'END') THEN ! END
IPF=-2
RETURN
ELSEIF(ANS(1:1).GT.' ') THEN
CALL TEXT_VT('PF1 UNKNOWN COMMAND',24,1,0)
ENDIF
END DO
END
SUBROUTINE LOAD_STA(IPF)
CHARACTER sbuf*2560,ANS*32,FMT*32,E*3
LOGICAL*2 ERROR
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE,MATCH
E=CHAR(27)//'#6'
10 istat=lib$set_buffer(sbuf)
CALL ERASE_VT
CALL TEXT_VT(E//'INTERACTIVE 2 1/2 D GRAVITY MODELING',
> 1,1,1)
CALL TEXT_VT(E//'LOAD STATION DATA FROM ANOTHER FILE',3,1,1)
CALL TEXT_VT('Do you wish to input for each station',5,1,0)
CALL TEXT_VT('1 Location and elevation',7,10,0)
CALL TEXT_VT('2 Location and observed values',9,10,0)
CALL TEXT_VT(
> '3 Location, elevation and observed values',11,10,0)
CALL TEXT_VT('4 Elevation',13,10,0)
CALL TEXT_VT('5 Observed values',15,10,0)
CALL TEXT_VT('6 Elevation and observed values',17,10,0)
istat=lib$put_buffer(0)
CALL ASKQPF('? ',ANS,23,1,IPF)
IF(ANS(1:4).EQ.'HELP') THEN
CALL HELP(6,IPF)
IF(IPF.EQ.0) GOTO 10
ELSEIF(ANS(1:3).EQ.'END') THEN ! END
IPF=-2
ELSEIF(ANS(1:4).EQ.'CALC') THEN ! CALCULATE GRAVITY
CALL CADY_SUB
CALC=.TRUE.
CALL TEXT_VT('Gravity has been calculated. ',22,1,0)
ELSEIF(ANS(1:3).EQ.'PLO') THEN ! PLOT
CALL PLOT_DATA(IPF)
IF(IPF.EQ.0) GOTO 10
ELSEIF(IPF.EQ.0) THEN ! LOAD STATIONS
J=-1
IF(LNUMBER(ANS)) CALL TXT2INT(ANS,J)
IF(J.GT.0.AND.J.LT.7) THEN
99 IF(ERROR) CALL TEXT_VT('FILE NOT FOUND',24,1,0)
CALL ASKQPF('Name of input file? ',ANS,23,1,IPF)
IF(IPF.EQ.0.AND.ANS.GT.' ') THEN
ERROR=.TRUE.
OPEN(UNIT=14,NAME=ANS,TYPE='OLD',READONLY,ERR=99)
ERROR=.FALSE.
CALL ASKQPF('Number of records to skip before '//
> 'reading? (0 or more) ',ANS,23,1,IPF)
ISKIP=0
IF(LNUMBER(ANS)) CALL TXT2INT(ANS,ISKIP)
FMT=' '
DO WHILE(ISKIP.GT.0)
READ(14,'(A1)',ERR=50,END=55) CH
ISKIP=ISKIP-1
END DO
DO WHILE(INDEX(FMT,'(').EQ.0.AND.INDEX(FMT,')').EQ.0)
CALL ASKQPF('Format of data file? '//
> '(include parenthesis) ',FMT,23,1,IPF)
END DO
IF(IPF.EQ.0.AND.FMT.GT.' ') THEN
CALL ASKQPF('How many stations? ',ANS,23,1,IPF)
IF(IPF.EQ.0.AND.LNUMBER(ANS)) THEN
CALL TXT2INT(ANS,NSTA)
IF(J.EQ.1) THEN
READ(14,FMT,ERR=50,END=55) (STA(1,I),STA(2,I),
> I=1,NSTA)
ELSEIF(J.EQ.2) THEN
READ(14,FMT,ERR=50,END=55) (STA(1,I),STA(3,I),
> I=1,NSTA)
ELSEIF(J.EQ.3) THEN
READ(14,FMT,ERR=50,END=55) (STA(1,I),STA(2,I),
> STA(3,I),I=1,NSTA)
ELSEIF(J.EQ.4) THEN
READ(14,FMT,ERR=50,END=55) (STA(2,I),I=1,NSTA)
ELSEIF(J.EQ.5) THEN
READ(14,FMT,ERR=50,END=55) (STA(3,I),I=1,NSTA)
ELSEIF(J.EQ.6) THEN
READ(14,FMT,ERR=50,END=55) (STA(2,I),STA(3,I),
> I=1,NSTA)
ELSE
CALL TEXT_VT('NO DATA LOADED',24,1,0)
ENDIF
ENDIF
ENDIF
CLOSE(UNIT=14)
ENDIF
ENDIF
ENDIF
RETURN
50 CALL TEXT_VT('ERROR READING STATION FILE',22,1,2)
GOTO 60
55 CALL TEXT_VT('END OF FILE REACHED IN STATION FILE',22,1,2)
60 CALL ASKQPF('Press RETURN to continue. ',23,1,IPF)
CLOSE(UNIT=14)
RETURN
END
SUBROUTINE PLOT_PARAM(IPF)
INTEGER COOR1(2,14)
LOGICAL*2 LNUMBER,LOADED,CALC
CHARACTER sbuf*2560,ANS*64,TITLE*64,FILE*32,BLANK*10,
> ARROW*10,CHAR,E*3
common/screenbuf/sbuf
COMMON/BLKBODY/NBODY
COMMON/BLKPRO/PROF(10),TITLE
COMMON/BLKFILE/FILE,LOADED,CALC
DATA BLANK,ARROW/' ',' =====> '/
DATA COOR1/5,10,7,21,7,34,7,48,10,21,10,34,10,48,13,30,13,
> 42,13,56,16,1,17,1,18,1,19,1/
E=CHAR(27)//'#6'
LOADED=.TRUE.
IF(PROF(1).LT.1.) PROF(1)=1.
IUNIT=IFIX(PROF(1))+10
istat=lib$set_buffer(sbuf)
CALL ERASE_VT
CALL TEXT_VT(E//'INTERACTIVE 2 1/2 D GRAVITY MODELING',
> ,1,1,1)
CALL TEXT_VT(E//'PLOTTING PARAMETERS',3,1,1)
CALL TEXT_VT('Title is',5,1,1)
CALL TEXT_VT('Range of profile is',7,1,1)
CALL TEXT_VT('to with intervals.',
> 7,31,1)
CALL TEXT_VT('Range of anomaly is',10,1,1)
CALL TEXT_VT('to with intervals.',
> 10,31,1)
CALL TEXT_VT('Range of depth of profile is',13,1,1)
CALL TEXT_VT('to with intervals.',
> 13,40,1)
CALL TEXT_VT('Units are',15,1,1)
CALL TEXT_VT('Kilometers',16,11,1)
CALL TEXT_VT('Meters',17,11,1)
CALL TEXT_VT('Kilofeet',18,11,1)
CALL TEXT_VT('Miles',19,11,1)
IF(NBODY.NE.1) THEN
CALL TEXT_VT('There are bodies.',22,1,0)
CALL PUTINUM(NBODY,22,11,0,2)
ELSE
CALL TEXT_VT('There is 1 body.',22,1,0)
ENDIF
NUMPOS=14
IPOS=1
CALL TEXT_VT(TITLE,COOR1(1,1),COOR1(2,1),2)
DO J=2,NUMPOS-4
CALL PUTRNUM(PROF(J),COOR1(1,J),COOR1(2,J),0,8,2)
END DO
CALL TEXT_VT(ARROW,COOR1(1,IUNIT),COOR1(2,IUNIT),0)
istat=lib$put_buffer(0)
CALL ASKQPF('Enter value ',ANS,23,1,IPF) ! EDIT
DO WHILE(.TRUE.)
CALL ERASE_LINE(24,1)
IL=IPOS
IF(IPF.EQ.6) THEN ! NEXT POSITION
IF(IPOS.GT.1.AND.IPOS.LT.10) THEN
IPOS=IPOS+3
IF(IPOS.GT.11) IPOS=11
ELSE
IPOS=IPOS+1
IF(IPOS.GT.NUMPOS) IPOS=1
ENDIF
ELSEIF(IPF.EQ.7) THEN
IPOS=IPOS+1
IF(IPOS.GT.NUMPOS) IPOS=1
ELSEIF(IPF.EQ.5) THEN ! PREVIOUS POSITION
IF(IPOS.LT.12.AND.IPOS.GT.2) THEN
IPOS=IPOS-3
IF(IPOS.LE.0) IPOS=1
ELSE
IPOS=IPOS-1
IF(IPOS.LE.0) IPOS=NUMPOS
ENDIF
ELSEIF(IPF.EQ.8) THEN
IPOS=IPOS-1
IF(IPOS.LE.0) IPOS=NUMPOS
ELSEIF(IPF.GT.0.AND.IPF.LT.5) THEN ! PF KEY
RETURN
ELSEIF(ANS(1:4).EQ.'PLOT') THEN ! PLOT
CALL PLOT_DATA(IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=2
RETURN
ELSEIF(ANS(1:4).EQ.'HELP') THEN ! HELP
CALL HELP(2,IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=2
RETURN
ELSEIF(ANS(1:4).EQ.'CALC') THEN ! CALCULATE GRAVITY
CALL CADY_SUB
CALC=.TRUE.
CALL TEXT_VT('Gravity has been calculated. ',22,1,0)
ELSEIF(ANS(1:3).EQ.'DCL') THEN ! ENTER DCL COMMAND
CALL ASKQPF('Enter a DCL command: ',ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(ANS(1:1).NE.'$') ANS='$ '//ANS
CALL ERASE_VT
CALL TEXT_VT(ANS,3,1,0)
CALL MOVE_VT(5,1)
ISTAT=LIB$SPAWN(ANS)
IF(ISTAT.GT.1) CALL LIB$STOP(%VAL(ISTAT))
CALL ASKQPF('Press RETURN to continue. ',ANS,23,1,IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=2
RETURN
ELSEIF(ANS(1:3).EQ.'SUM') THEN ! CREATE SUMMARY
CALL SUMMARY(IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=2
RETURN
ELSEIF(ANS(1:3).EQ.'END') THEN ! STOP
IPF=-2
RETURN
ELSEIF(ANS(1:4).EQ.'LOAD') THEN ! LOAD DATA
CALL INOUT(1)
IF(LOADED) CALL TEXT_VT(
> 'Data file has been loaded. ',24,1,0)
IPF=2
RETURN
ELSEIF(ANS(1:4).EQ.'SAVE') THEN ! SAVE DATA
CALL INOUT(2)
CALL TEXT_VT('Data file saved.',24,1,0)
ELSEIF(ANS(1:3).EQ.'END') THEN ! END
IPF=-2
RETURN
ELSEIF(IPOS.EQ.1.AND.ANS(5:7).GT.' ') THEN ! TITLE
TITLE=ANS
IPOS=IPOS+1
ELSEIF(IPF.EQ.0.AND.IPOS.GT.10) THEN ! SWITCH UNITS
CALC=.FALSE.
CALL TEXT_VT(BLANK,COOR1(1,IUNIT),COOR1(2,IUNIT),0)
IUNIT=IPOS
PROF(1)=IUNIT-10
CALL TEXT_VT(ARROW,COOR1(1,IUNIT),COOR1(2,IUNIT),0)
IPOS=1
ELSEIF(LNUMBER(ANS)) THEN ! NUMBER
CALL TXT2R(ANS,PROF(IPOS))
IPOS=IPOS+1
IF(IPOS.GT.NUMPOS) IPOS=1
ELSEIF(ANS(1:1).GT.' ') THEN
CALL TEXT_VT('ERROR -- UNKNOWN COMMAND',24,1,0)
ENDIF
C ! UPDATE
IF(IL.EQ.1) THEN ! TURN OFF OLD
CALL TEXT_VT(TITLE,COOR1(1,1),COOR1(2,1),0)
ELSEIF(IL.GT.10) THEN
IF(IL.EQ.IUNIT) THEN
CALL TEXT_VT(ARROW,COOR1(1,IL),COOR1(2,IL),0)
ELSE
CALL TEXT_VT(BLANK,COOR1(1,IL),COOR1(2,IL),0)
ENDIF
ELSE
CALL PUTRNUM(PROF(IL),COOR1(1,IL),COOR1(2,IL),0,8,2)
ENDIF
IF(IPOS.EQ.1) THEN ! TURN ON NEW
CALL TEXT_VT(TITLE,COOR1(1,1),COOR1(2,1),2)
ELSEIF(IPOS.GT.10) THEN
IF(IPOS.EQ.IUNIT) THEN
CALL TEXT_VT(ARROW,COOR1(1,IPOS),COOR1(2,IPOS),2)
ELSE
CALL TEXT_VT(BLANK,COOR1(1,IPOS),COOR1(2,IPOS),2)
ENDIF
ELSE
CALL PUTRNUM(PROF(IPOS),COOR1(1,IPOS),COOR1(2,IPOS),
> 2,8,2)
ENDIF
CALL ASKQPF('Enter value ',ANS,23,1,IPF)
END DO
RETURN
END
SUBROUTINE PLOT_DATA(IPF)
INTEGER IFLAG(6),COOR(6)
LOGICAL*2 LNUMBER,LOADED,CALC,VERS,REPAINT
CHARACTER sbuf*2560,FILE*32,ANS*10,LABEL(6)*17,
> STRING*4,CHAR,E*3
common/screenbuf/sbuf
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE,MATCH
COMMON/BLKPRO/PROF
COMMON/BLKFILE/FILE,LOADED,CALC
DATA IFLAG/2,2,2,2,0,0/,COOR/7,9,11,15,17,19/,IPNUM/1/
E=CHAR(27)//'#6'
LABEL(1)='Profile '
LABEL(2)='Observed curve '
LABEL(3)='Calculated curve '
LABEL(4)='Versatec plotter '
LABEL(5)='HP plotter '
LABEL(6)='Ramtek plotter'
VERS=.FALSE.
REPAINT=.TRUE.
DO WHILE(.TRUE.)
IF(REPAINT) THEN
istat=lib$set_buffer(sbuf)
CALL ERASE_VT
REPAINT=.FALSE.
CALL TEXT_VT(E//'INTERACTIVE 2 1/2 D GRAVITY MODELING',
> 1,1,1)
CALL TEXT_VT(E//'PLOT RESULTS',3,1,1)
CALL TEXT_VT('Plot includes the following:',5,10,1)
CALL TEXT_VT('Plot on the following device:',13,10,1)
DO I=1,6
WRITE(STRING,'(I1,A3)') I,'...'
CALL TEXT_VT(STRING,COOR(I),20,0)
CALL TEXT_VT(LABEL(I),COOR(I),24,IFLAG(I))
END DO
IF(LOADED) THEN
IF(.NOT.CALC) CALL TEXT_VT(
> 'Gravity has not been calculated.',22,1,4)
ELSE
CALL TEXT_VT('Data file has not been loaded ',
> 22,1,4)
ENDIF
IF(VERS) CALL TEXT_VT(
> 'Data has been plotted to Versatec.',24,1,0)
VERS=.FALSE.
istat=lib$put_buffer(0)
ENDIF
CALL TEXT_VT('Enter SEND to begin plotting',21,1,0)
CALL ASKQPF('Command ? ',ANS,23,1,IPF)
CALL ERASE_LINE(24,1)
IF(IPF.GT.0.AND.IPF.LT.5) THEN ! PF KEYS
RETURN
ELSEIF(IPF.EQ.0.AND.LNUMBER(ANS)) THEN ! SELECT NUMBER
CALL TXT2INT(ANS,IP)
IF(IP.GT.0.AND.IP.LT.4) THEN
IF(IFLAG(IP).NE.0) THEN
IFLAG(IP)=0
ELSE
IFLAG(IP)=2
ENDIF
WRITE(STRING,'(I1,A3)') IP,'...'
CALL TEXT_VT(STRING,COOR(IP),20,0)
CALL TEXT_VT(LABEL(IP),COOR(IP),24,IFLAG(IP))
ELSE
IF(IP.EQ.4) THEN
IFLAG(4)=2
IFLAG(5)=0
IFLAG(6)=0
ELSEIF(IP.EQ.5) THEN
IFLAG(4)=0
IFLAG(5)=2
IFLAG(6)=0
ELSEIF(IP.EQ.6) THEN
IFLAG(4)=0
IFLAG(5)=0
IFLAG(6)=2
ENDIF
DO I=4,6
WRITE(STRING,'(I1,A3)') I,'...'
CALL TEXT_VT(STRING,COOR(I),20,0)
CALL TEXT_VT(LABEL(I),COOR(I),24,IFLAG(I))
END DO
ENDIF
ELSEIF(ANS(1:4).EQ.'CALC') THEN ! CALCULATE GRAVITY
CALL CADY_SUB
CALC=.TRUE.
CALL TEXT_VT('Gravity has been calculated. ',
> 22,1,0)
ELSEIF(ANS(1:3).EQ.'SUM') THEN ! CREATE SUMMARY
CALL SUMMARY(IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
REPAINT=.TRUE.
ELSEIF(ANS(1:3).EQ.'DCL') THEN ! ENTER DCL COMMAND
CALL ASKQPF('Enter a DCL command: ',ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(ANS(1:1).NE.'$') ANS='$ '//ANS
CALL ERASE_VT
CALL TEXT_VT(ANS,3,1,0)
CALL MOVE_VT(5,1)
ISTAT=LIB$SPAWN(ANS)
IF(ISTAT.GT.1) CALL LIB$STOP(%VAL(ISTAT))
CALL ASKQPF('Press RETURN to continue. ',ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
REPAINT=.TRUE.
ELSEIF(ANS(1:3).EQ.'DEN') THEN
CALL ASKQPF('Density labling (0,1,2) ? ',ANS,23,1,IPF)
IF(LNUMBER(ANS)) READ(ANS,'(I1)') IPNUM
ELSEIF(ANS(1:3).EQ.'BEG'.OR.ANS(1:2).EQ.'SE') THEN ! BEGIN PLOTTING
IF(CALC) THEN
IF(IFLAG(4).NE.0) THEN
CALL VERS_CADY_PLOT(IPNUM)
VERS=.TRUE.
ELSEIF(IFLAG(5).NE.0) THEN
C CALL HMODPLT(IFLAG) ! NOT INTSTALLED
C CALL TEXT_VT('Data has been plotted to HP.',24,1,0)
ELSEIF(IFLAG(6).NE.0) THEN
CALL CADYRAM(IFLAG)
CALL TEXT_VT('Data has been plotted to RAMTEK.',
> 24,1,0)
ENDIF
ELSE
CALL BELL
ENDIF
ELSEIF(ANS(1:4).EQ.'LOAD') THEN ! LOAD DATA
CALL INOUT(1)
IF(LOADED) THEN
CALL TEXT_VT('Data file has been loaded. ',24,1,0)
CALL TEXT_VT('Gravity has not been calculated.',
> 22,1,4)
ENDIF
ELSEIF(ANS(1:4).EQ.'SAVE') THEN ! SAVE DATA
CALL INOUT(2)
CALL TEXT_VT('Data file saved.',24,1,0)
ELSEIF(ANS(1:4).EQ.'HELP') THEN ! HELP
CALL HELP(5,IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=-1
RETURN
ELSEIF(ANS(1:3).EQ.'END') THEN ! STOP
IPF=-2
RETURN
ELSEIF(ANS(1:1).GT.' ') THEN
CALL TEXT_VT('PLOT: UNKNOWN COMMAND',24,1,0)
ELSE
RETURN
ENDIF
END DO
END
C
SUBROUTINE GETCOOR(JJ,IC,JC)
INTEGER COOR2(2,7)
DATA COOR2/5,22, 6,41, 7,42, 10,12, 10,25, 10,50, 10,63/
J=JJ
IF(J.GT.5) THEN
I=4
IF(J.GT.21) THEN
J=J-18
I=6
ENDIF
IC=COOR2(1,4)+JINT(FLOATJ(J-3)/2.+.5)-1
JC=COOR2(2,I+JMOD(J,2))
ELSE
IC=COOR2(1,J)
JC=COOR2(2,J)
ENDIF
RETURN
END
SUBROUTINE BODY_PARAM(IPF)
LOGICAL*2 TFBODY,LOADED,CALC,LNUMBER,ERROR,NEWBODY,LOOP
CHARACTER sbuf*2560,ANS*10,BLANK*10,FILE*32,
> CHAR,TITLE*64,E*3,CH,C*3
common/screenbuf/sbuf
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE,MATCH
COMMON/BLKBODY/NBODY,BODY(25,39),NPTS(25),TFBODY(25)
COMMON/BLKPRO/PROF(10),TITLE
COMMON/BLKFILE/FILE,LOADED,CALC
DATA BLANK/' '/
E=CHAR(27)//'#6'
IF(NBODY.LE.1) THEN
NB=1
DO WHILE(.NOT.TFBODY(NB))
NB=NB+1
END DO
ELSE
CALL ERASE_VT
CALL TEXT_VT(E//'INTERACTIVE 2 1/2 D GRAVITY MODELING',
> ,1,1,1)
NEWBODY=.FALSE.
ERROR=.FALSE.
NB=0
DO WHILE(NB.LT.1.OR.NB.GT.25)
IF(ERROR) CALL TEXT_VT('ERROR - 1 TO 25 BODIES',24,1,0)
CALL ASKQPF(E//'Body? ',ANS,3,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(ANS(1:3).EQ.'END') THEN
IPF=-2
RETURN
ELSEIF(LNUMBER(ANS)) THEN
CALL TXT2INT(ANS,NB)
ERROR=.TRUE.
ENDIF
END DO
ENDIF
DO WHILE(.TRUE.)
CALL ERASE_VT
CALL TEXT_VT(E//'INTERACTIVE 2 1/2 D GRAVITY MODELING',
> 1,1,1)
IF(NBODY.EQ.0) THEN
NB=1
NBODY=1
TFBODY(NB)=.TRUE.
NEWBODY=.TRUE.
NPTS(NB)=0
ELSEIF(.NOT.TFBODY(NB)) THEN
CALL TEXT_VT('BODY DOES NOT EXIST,',4,1,0)
CALL TEXT_VT('CREATING NEW BODY',4,21,0)
CALL BELL
NEWBODY=.TRUE.
NPTS(NB)=0
ENDIF
NUMPOS=NPTS(NB)*2+3
IPOS=1
istat=lib$set_buffer(sbuf)
CALL TEXT_VT(E//'Body ',3,1,1)
CALL PUTINUM(NB,3,6,0,4)
CALL TEXT_VT('Density contrast is',5,1,1)
CALL TEXT_VT('Length of body to the left of strike is',
> 6,1,1)
CALL TEXT_VT('Length of body to the right of strike is',
> 7,1,1)
CALL TEXT_VT('POINT X Z',9,7,1)
C
IF(NPTS(NB).GE.10) CALL TEXT_VT(
> 'POINT X Z',9,44,1)
DO NP=1,NPTS(NB)
IF(NP.GT.9) THEN
IC=NP
JC=44
ELSE
IC=NP+9
JC=7
ENDIF
CALL PUTINUM(NP,IC,JC,1,2)
END DO
ISTAT=IPURGE_BUFFER(.TRUE.)
DO J=1,NUMPOS
CALL GETCOOR(J,IC,JC)
IF(J.EQ.IPOS) THEN
CALL PUTRNUM(BODY(NB,J),IC,JC,2,10,3)
ELSE
CALL PUTRNUM(BODY(NB,J),IC,JC,0,10,3)
ENDIF
END DO
ISTAT=IPURGE_BUFFER(.TRUE.)
CALL TEXT_VT(' Commands: '//
> ' ',19,1,2)
CALL TEXT_VT(' B...Select body C...Create'//
> ' new body IB..Insert point before ',20,1,2)
CALL TEXT_VT(' N...Select next body X...Delete'//
> ' this body current position ',21,1,2)
CALL TEXT_VT(' P...Select previous body I...Insert'//
> ' new point D...Delete curent point ',22,1,2)
istat=lib$put_buffer(0)
CALL ASKQPF('Enter value ',ANS,23,1,IPF) ! EDIT BODY
CH=ANS(1:1)
C=ANS(1:3)
LOOP=CH.NE.'B'.AND.CH.NE.'N'.AND.CH.NE.'P'.AND.CH.NE.'C'
IF(C.EQ.'CAL'.OR.C.EQ.'PLO') LOOP=.TRUE.
C
DO WHILE(LOOP)
IF(.NOT.NEWBODY.OR.IPOS.LT.4) THEN
CALL GETCOOR(IPOS,IC,JC)
CALL PUTRNUM(BODY(NB,IPOS),IC,JC,0,10,3)
ENDIF
CALL ERASE_LINE(24,1)
IF(IPF.EQ.5) THEN ! ARROW UP
IF(IPOS.LT.4) THEN
IPOS=IPOS-1
ELSEIF(IPOS.LE.5.OR.IPOS.EQ.22.OR.IPOS.EQ.23) THEN
IPOS=3
ELSE
IPOS=IPOS-2
ENDIF
ELSEIF(IPF.EQ.6) THEN ! ARROW DOWN
IF(IPOS.EQ.20.OR.IPOS.EQ.21) THEN
IPOS=1
ELSEIF(IPOS.LT.4) THEN
IPOS=IPOS+1
ELSE
IPOS=IPOS+2
ENDIF
ELSEIF(IPF.EQ.7) THEN ! ARROW RIGHT
IF(IPOS.EQ.21) THEN
IPOS=1
ELSEIF(IPOS.GT.3) THEN
IF(NPTS(NB).GT.9) THEN ! MORE THAN 9
IF((IPOS/2)*2.EQ.IPOS) THEN ! EVEN
IPOS=IPOS+1
ELSE ! ODD
IF(IPOS.LT.22) THEN ! LEFT COLUMN
IPOS=IPOS+17
IF(IPOS.GT.NUMPOS) IPOS=IPOS-16
ELSE ! RIGHT COLUMN
IPOS=IPOS-17
ENDIF
ENDIF
ELSE ! LESS THAN 9
IPOS=IPOS+1
ENDIF
ELSE
IPOS=IPOS+1
ENDIF
ELSEIF(IPF.EQ.8) THEN ! ARROW LEFT
IF(IPOS.LE.4.OR.NPTS(NB).LT.10) THEN
IPOS=IPOS-1
ELSE ! MORE THAN 9
IF((IPOS/2)*2.NE.IPOS) THEN ! ODD
IPOS=IPOS-1
ELSE ! EVEN
IF(IPOS.LT.22) THEN ! LEFT COLUMN
IPOS=IPOS+17
IF(IPOS.GT.NUMPOS) IPOS=IPOS-18
ELSE ! LEFT COLUMN
IPOS=IPOS-17
ENDIF
ENDIF
ENDIF
ELSEIF(IPF.GT.0.AND.IPF.LT.5) THEN ! PF 1 TO 4
RETURN
ELSEIF(C.EQ.'DCL') THEN ! ENTER DCL COMMAND
CALL ASKQPF('Enter a DCL command: ',ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(ANS(1:1).NE.'$') ANS='$ '//ANS
CALL ERASE_VT
CALL TEXT_VT(ANS,3,1,0)
CALL MOVE_VT(5,1)
ISTAT=LIB$SPAWN(ANS)
IF(ISTAT.GT.1) CALL LIB$STOP(%VAL(ISTAT))
CALL ASKQPF('Press RETURN to continue. ',ANS,23,1,IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=3
RETURN
ELSEIF(C.EQ.'PLO') THEN ! PLOT
CALL PLOT_DATA(IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=3
RETURN
ELSEIF(C.EQ.'SUM') THEN ! CREATE SUMMARY
CALL SUMMARY(IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=3
RETURN
ELSEIF(C.EQ.'END') THEN ! STOP
IPF=-2
RETURN
ELSEIF(C.EQ.'HELP') THEN ! HELP
CALL HELP(3,IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=3
RETURN
ELSEIF(C.EQ.'CAL') THEN ! CALCULATE GRAVITY
IF(LOADED) THEN
CALL CADY_SUB
CALC=.TRUE.
CALL TEXT_VT('Gravity has been calculated.',24,1,0)
ELSE
CALL TEXT_VT('Data file not loaded. ',24,1,4)
ENDIF
ELSEIF(C.EQ.'LOA') THEN ! LOAD DATA
CALL INOUT(1)
IF(LOADED) THEN
IPF=3
RETURN
ENDIF
ELSEIF(C.EQ.'SAV') THEN ! SAVE DATA
CALL INOUT(2)
CALL TEXT_VT('Data file saved.',24,1,0)
ELSEIF(ANS(1:1).EQ.'I') THEN ! INSERT
IF(ANS(2:2).EQ.'B') IPOS=IPOS-2 ! BEFORE OR AFTER
IF(IPOS.LT.3) IPOS=3
IF(NPTS(NB).GE.18) THEN
CALL TEXT_VT('ERROR -- ONLY 18 POINTS PER BODY',
> 24,1,0)
CALL BELL
ELSE
DO WHILE(ANS.GT.' '.AND.NPTS(NB).LT.18)
istat=lib$set_buffer(sbuf)
CALL GETCOOR(IPOS,IC,JC)
CALL PUTRNUM(BODY(NB,IPOS),IC,JC,0,10,3)
IPOS=IPOS-JMOD(IPOS,2)+2
DO L=NUMPOS,IPOS,-1
BODY(NB,L+2)=BODY(NB,L)
END DO
NPTS(NB)=NPTS(NB)+1
NUMPOS=NUMPOS+2
CALL GETCOOR(IPOS+1,IC1,JC1)
CALL TEXT_VT(BLANK,IC1,JC1+1,0)
CALL GETCOOR(IPOS,IC0,JC0)
CALL TEXT_VT(BLANK,IC0,JC0+1,3)
IF(NPTS(NB).GT.9) THEN
IF(NPTS(NB).EQ.10) CALL TEXT_VT(
> 'POINT X Z',9,44,1)
JC=44
IC=NPTS(NB)
ELSE
JC=7
IC=NPTS(NB)+9
ENDIF
CALL PUTINUM(NPTS(NB),IC,JC,1,2)
DO L=IPOS+2,NUMPOS
CALL GETCOOR(L,IC,JC)
CALL PUTRNUM(BODY(NB,L),IC,JC,0,10,3)
END DO
istat=lib$put_buffer(0)
CALL ASKQPF(' X? ',ANS,23,1,IPF)
IF(IPF.EQ.0.AND.LNUMBER(ANS)) THEN
istat=lib$set_buffer(sbuf)
CALL TXT2R(ANS,BODY(NB,IPOS))
CALL PUTRNUM(BODY(NB,IPOS),IC0,JC0,0,10,3)
IPOS=IPOS+1
CALL TEXT_VT(BLANK,IC1,JC1+1,3)
ANS='Y'
ERROR=.FALSE.
istat=lib$put_buffer(0)
DO WHILE (.NOT.LNUMBER(ANS))
IF(ERROR) CALL BELL
CALL ASKQPF(' Z? ',ANS,23,1,IPF)
ERROR=.TRUE.
END DO
istat=lib$set_buffer(sbuf)
CALL TXT2R(ANS,BODY(NB,IPOS))
IF(NEWBODY) THEN
NBODY=NBODY+1
TFBODY(NB)=.TRUE.
CALL ERASE_LINE(4,1)
NEWBODY=.FALSE.
ENDIF
CALC=.FALSE.
istat=lib$put_buffer(0)
ENDIF
END DO
IF(NPTS(NB).LT.18) THEN
DO L=IPOS,NUMPOS-2
BODY(NB,L)=BODY(NB,L+2)
END DO
IF(NPTS(NB).GT.9) THEN
IC=NPTS(NB)
JC=36
ELSE
IC=NPTS(NB)+9
JC=1
ENDIF
IF(NPTS(NB).EQ.10) CALL ERASE_LINE(9,36)
CALL ERASE_LINE(IC,JC)
NPTS(NB)=NPTS(NB)-1
NUMPOS=NUMPOS-2
DO L=IPOS,NUMPOS
CALL GETCOOR(L,IC,JC)
CALL PUTRNUM(BODY(NB,L),IC,JC,0,10,3)
END DO
ENDIF
ENDIF
ELSEIF(ANS(1:1).EQ.'X') THEN ! DELETE BODY
CALL BELL
CALL ASKQPF('DELETE BODY---Are you sure? (Y/N) ',
> ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) THEN
RETURN
ELSEIF(ANS(1:1).EQ.'Y') THEN
TFBODY(NB)=.FALSE.
NBODY=NBODY-1
IPF=3
RETURN
ENDIF
ELSEIF(IPOS.GT.3.AND.ANS(1:1).EQ.'D') THEN ! DELETE
IDEL=1 ! POINT
IC=2
IF(ANS(2:2).LE.' ') IC=3
ANS=ANS(IC:IC+3)
IF(LNUMBER(ANS)) CALL TXT2INT(ANS,IDEL)
IPOS=IPOS-JMOD(IPOS,2)
IF(NPTS(NB)-(IPOS-4)/2.LT.IDEL) IDEL=
> NPTS(NB)-(IPOS-4)/2
istat=lib$set_buffer(sbuf)
DO L=1,IDEL
IP=(L-1)*2
CALL GETCOOR(IPOS+IP,IC,JC)
CALL PUTRNUM(BODY(NB,IPOS+IP),IC,JC,3,10,3)
CALL GETCOOR(IPOS+IP+1,IC,JC)
CALL PUTRNUM(BODY(NB,IPOS+IP+1),IC,JC,3,10,3)
END DO
istat=lib$put_buffer(0)
CALL ASKQPF('DELETE VERIFY? ',ANS,23,1,IPF)
IF(ANS(1:1).EQ.'Y') THEN
NUMPOS=NUMPOS-2*IDEL
DO L=IPOS,NUMPOS
BODY(NB,L)=BODY(NB,L+2*IDEL)
END DO
DO L=1,IDEL
IF(NPTS(NB).GT.9) THEN
IC=NPTS(NB)
JC=36
ELSE
IC=NPTS(NB)+9
JC=1
ENDIF
IF(NPTS(NB).EQ.10) CALL ERASE_LINE(9,36)
CALL ERASE_LINE(IC,JC)
NPTS(NB)=NPTS(NB)-1
END DO
IF(NUMPOS.LE.3) THEN
CALL TEXT_VT('ALL POINTS DELETED',24,1,0)
CALL ASKQPF('Do you wish to delete this body? ',
> ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) THEN
RETURN
ELSEIF(ANS(1:1).EQ.'Y') THEN
NBODY=NBODY-1
TFBODY(NB)=.FALSE.
IPF=3
RETURN
ELSE
NUMPOS=3
NEWBODY=.TRUE.
ENDIF
ENDIF
CALC=.FALSE.
ENDIF
IF(TFBODY(NB)) THEN
DO L=IPOS,NUMPOS
CALL GETCOOR(L,IC,JC)
CALL PUTRNUM(BODY(NB,L),IC,JC,0,10,3)
END DO
IF(IPOS.GT.NUMPOS) IPOS=NUMPOS-1
ENDIF
ELSEIF(LNUMBER(ANS)) THEN ! NEW VALUE
CALL TXT2R(ANS,BODY(NB,IPOS))
CALC=.FALSE.
CALL GETCOOR(IPOS,IC,JC)
CALL PUTRNUM(BODY(NB,IPOS),IC,JC,0,10,3)
IPOS=IPOS+1
ELSEIF(ANS(1:1).GT.' ') THEN ! UNKNOWN COMMAND
CALL TEXT_VT('PF3 UNKNOWN COMMAND',24,1,0)
CALL BELL
ELSE
IPOS=IPOS+1
ENDIF
IF(IPOS.GE.4.AND.NEWBODY) THEN
IPF=0
ANS='IB' ! ENTER DATA FIRST TIME FOR THIS BODY
LOOP=.TRUE.
ELSE
IF(IPOS.GT.NUMPOS) IPOS=1
IF(IPOS.LT.1) IPOS=NUMPOS
CALL GETCOOR(IPOS,IC,JC)
CALL PUTRNUM(BODY(NB,IPOS),IC,JC,2,10,3)
CALL ASKQPF('Enter value ',ANS,23,1,IPF)
CH=ANS(1:1)
C=ANS(1:3)
LOOP=CH.NE.'B'.AND.CH.NE.'N'.AND.
> CH.NE.'C'.AND.CH.NE.'P'
IF(C.EQ.'CAL'.OR.C.EQ.'PLO') LOOP=.TRUE.
ENDIF
END DO
IF(CH.EQ.'B') THEN ! SELECT BODY
NB=0
ANS=ANS(2:10)
IF(LNUMBER(ANS)) THEN
CALL TXT2INT(ANS,NB)
ELSE
ERROR=.FALSE.
DO WHILE(NB.LT.1.OR.NB.GT.25)
IF(ERROR) CALL TEXT_VT('ERROR -- 1 TO 25 BODIES',
> 24,1,0)
CALL ASKQPF(E//'Body? ',ANS,3,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(ANS(1:3).EQ.'END') THEN
IPF=-2
RETURN
ELSEIF(LNUMBER(ANS)) THEN
CALL TXT2INT(ANS,NB)
ERROR=.TRUE.
ENDIF
END DO
ENDIF
ELSEIF(CH.EQ.'N') THEN ! NEXT BODY
NB=NB+1
DO WHILE(.NOT.TFBODY(NB))
NB=NB+1
IF(NB.GT.25) NB=1
END DO
ELSEIF(CH.EQ.'P') THEN ! PREVIOUS BODY
NB=NB-1
IF(NB.LT.1) NB=25
DO WHILE(.NOT.TFBODY(NB))
NB=NB-1
IF(NB.LT.1) NB=25
END DO
ELSEIF(CH.EQ.'C') THEN ! CREATE NEW BODY
NB=1
DO WHILE(TFBODY(NB))
NB=NB+1
IF(NB.GT.25) THEN
CALL TEXT_VT('LIMIT OF 25 BODIES',22,1,1)
CALL ASKQPF('Press RETURN to continue. ',
> ANS,23,1,IPF)
IF(IPF.LT.1.AND.IPF.GT.5) IPF=3
RETURN
ENDIF
END DO
NEWBODY=.TRUE.
ENDIF
END DO
END
SUBROUTINE STATION_PARAM(IPF)
LOGICAL*2 LOADED,CALC,LNUMBER,LTEST
CHARACTER sbuf*2560,TEXT*32,FILE*32,ANS*10,CHAR,E*3
common/screenbuf/sbuf
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE,MATCH
COMMON/BLKPRO/PROF(10)
COMMON/BLKFILE/FILE,LOADED,CALC
DATA ICOL,ISTOP,ISBOT/1,5,20/
E=CHAR(27)//'#6'
istat=lib$set_buffer(sbuf)
CALL ERASE_VT
CALL TEXT_VT(E//'INTERACTIVE 2 1/2 D GRAVITY MODELING',
> 1,1,1)
CALL TEXT_VT('STATIONS',3,7,1)
CALL TEXT_VT('match station',3,29,1)
CALL TEXT_VT('STATION LOCATION ELEVATION',
> 4,1,1)
CALL TEXT_VT(' OBSERVED CALCULATED',4,41,1)
CALL PUTINUM(NSTA,3,2,0,3)
CALL PUTINUM(MATCH,3,42,0,4)
istat=lib$put_buffer(0)
IF(.NOT.LOADED.OR.NSTA.LE.0) THEN
DO WHILE(NSTA.LE.0.OR.NSTA.GT.1024)
CALL ASKQPF('How many stations? ',ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(ANS(1:3).EQ.'LOA') THEN
CALL INOUT(1)
CALL PUTINUM(NSTA,3,2,0,3)
CALL PUTINUM(MATCH,3,42,0,4)
ELSEIF(LNUMBER(ANS)) THEN
LOADED=.TRUE.
CALL TXT2INT(ANS,NSTA)
CALL PUTINUM(NSTA,3,2,0,3)
ENDIF
END DO
ENDIF
ISDIF=ISBOT-ISTOP
CALL SCROLL(ISTOP+1,ISBOT)
IF(ISDIF.GT.NSTA) ISDIF=NSTA
NTOP=1 ! TOP LINE NUMBER
CALL DIS_STA(ISDIF,ISTOP,NTOP)
NBOT=ISDIF+1 ! BOTTOM LINE NUMBER
NLINE=1 ! CURRENT LINE NUMBER
ILINE=ISTOP+1 ! CURRENT SCREEN LINE
CALL WRITELINE(ILINE,NLINE,ICOL)
istat=lib$put_buffer(0)
CALL ASKQPF('Enter value ',ANS,23,1,IPF)
DO WHILE(.TRUE.)
istat=lib$set_buffer(sbuf)
CALL ERASE_LINE(22,1)
CALL ERASE_LINE(24,1)
IF(IPF.EQ.7) THEN ! NEXT COLUMN
ICOL=ICOL+1
IF(ICOL.GT.3) ICOL=1
CALL WRITELINE(ILINE,NLINE,ICOL)
ELSEIF(IPF.EQ.8) THEN ! PREVIOUS COLUMN
ICOL=ICOL-1
IF(ICOL.LT.1) ICOL=3
CALL WRITELINE(ILINE,NLINE,ICOL)
ELSEIF(IPF.EQ.5) THEN ! UP ONE LINE
CALL WRITE_LINE2(ILINE,NLINE,0) ! TURN OFF OLD LINE
IF(NLINE.LE.1) THEN
CALL BELL
CALL TEXT_VT('TOP OF DATA SET',24,1,0)
ELSE
NLINE=NLINE-1
IF(NLINE.GE.NTOP) THEN
ILINE=ILINE-1
ELSE
CALL DOWN_VT
NTOP=NLINE
NBOT=NBOT-1
ENDIF
ENDIF
CALL WRITELINE(ILINE,NLINE,ICOL) ! TURN ON NEW LINE
ELSEIF(IPF.EQ.6) THEN ! DOWN ONE LINE
CALL WRITE_LINE2(ILINE,NLINE,0) ! TURN OFF OLD LINE
IF(NLINE.GE.NSTA) THEN
CALL BELL
CALL TEXT_VT('BOTTOM OF DATA SET',24,1,0)
ELSE
NLINE=NLINE+1
IF(NLINE.LT.NBOT) THEN
ILINE=ILINE+1
ELSE
CALL UP_VT
NTOP=NTOP+1
NBOT=ISDIF+NTOP
ENDIF
ENDIF
CALL WRITELINE(ILINE,NLINE,ICOL) ! TURN ON NEW LINE
ELSEIF(IPF.GT.0.AND.IPF.LT.5) THEN ! PF KEY
istat=lib$put_buffer(0)
CALL SCROLL(1,22)
RETURN
ELSEIF(ANS(1:1).EQ.'T') THEN ! TOP OF SCROLL
CALL WRITE_LINE2(ILINE,NLINE,0) ! TURN OFF OLD LINE
ILINE=ISTOP+1
NLINE=NTOP
CALL WRITELINE(ILINE,NLINE,ICOL) ! TURN ON NEW LINE
ELSEIF(ANS(1:1).EQ.'B') THEN ! BOTTOM OF SCROLL
CALL WRITE_LINE2(ILINE,NLINE,0) ! TURN OFF OLD LINE
ILINE=ISBOT
NLINE=NBOT-1
CALL WRITELINE(ILINE,NLINE,ICOL) ! TURN ON NEW LINE
ELSEIF(ANS(1:4).EQ.'LOAD') THEN ! LOAD DATA
CALL INOUT(1)
IF(LOADED) CALL TEXT_VT('Data file has been loaded. ',
> 24,1,0)
CALL DIS_STA(ISDIF,ISTOP,NTOP)
CALL WRITELINE(ILINE,NLINE,ICOL)
ELSEIF(ANS(1:4).EQ.'SAVE') THEN ! SAVE DATA
CALL INOUT(2)
CALL TEXT_VT('Data file saved.',24,1,0)
ELSEIF(ANS(1:4).EQ.'CALC') THEN ! CALCULATE GRAVITY
CALL CADY_SUB
CALC=.TRUE.
CALL TEXT_VT('Gravity has been calculated.',24,1,0)
CALL DIS_STA(ISDIF,ISTOP,NTOP)
CALL WRITELINE(ILINE,NLINE,ICOL)
ELSEIF(ANS(1:3).EQ.'STA') THEN ! LOAD STATION DATA
istat=lib$put_buffer(0)
REPAINT=.TRUE.
CALL SCROLL(1,22)
CALL LOAD_STA(IPF)
IF(IPF.EQ.0) IPF=4
RETURN
ELSEIF(ANS(1:3).EQ.'DCL') THEN ! ENTER DCL COMMAND
istat=lib$put_buffer(0)
CALL SCROLL(1,22)
CALL ASKQPF('Enter a DCL command: ',ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(ANS(1:1).NE.'$') ANS='$ '//ANS
CALL ERASE_VT
CALL TEXT_VT(ANS,3,1,0)
CALL MOVE_VT(5,1)
ISTAT=LIB$SPAWN(ANS)
IF(ISTAT.GT.1) CALL LIB$STOP(%VAL(ISTAT))
CALL ASKQPF('Press RETURN to continue. ',ANS,23,1,IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=4
RETURN
ELSEIF(ANS(1:3).EQ.'SUM') THEN ! CREATE SUMMARY
istat=lib$put_buffer(0)
CALL SCROLL(1,22)
CALL SUMMARY(IPF)
IF(IPF.EQ.0) IPF=4
RETURN
ELSEIF(ANS(1:3).EQ.'END') THEN
istat=lib$put_buffer(0)
CALL SCROLL(1,22)
IPF=-2
RETURN
ELSEIF(ANS(1:1).EQ.'L') THEN ! JUMP TO LINE n
ANS=ANS(2:10)
IF(.NOT.LNUMBER(ANS)) THEN
istat=lib$put_buffer(0)
CALL ASKQPF('Line number? ',ANS,23,1,IPF)
istat=lib$set_buffer(sbuf)
ENDIF
IF(LNUMBER(ANS)) THEN
CALL TXT2INT(ANS,LNUM)
IF(LNUM.GE.1.AND.LNUM.LE.NSTA) THEN
CALL WRITE_LINE2(ILINE,NLINE,0) ! TURN OFF OLD LINE
NLINE=LNUM
IF(NLINE.LT.NTOP.OR.NLINE.GE.NBOT) THEN
NTOP=ISTOP+NLINE-ILINE+1
IF(NTOP.LT.1) NTOP=1
IF(NTOP.GT.NSTA-ISDIF+1) NTOP=NSTA-ISDIF+1
CALL DIS_STA(ISDIF,ISTOP,NTOP)
NBOT=ISDIF+NTOP
ENDIF
ILINE=ISTOP+NLINE-NTOP+1
CALL WRITELINE(ILINE,NLINE,ICOL)
ELSE
CALL TEXT_VT('ERROR -- OUT OF RANGE',24,1,0)
CALL BELL
ENDIF
ENDIF
ELSEIF(ANS(1:4).EQ.'HELP') THEN ! HELP
istat=lib$put_buffer(0)
CALL SCROLL(1,22)
CALL HELP(4,IPF)
IF(IPF.LT.1.OR.IPF.GT.4) IPF=4
RETURN
ELSEIF(LNUMBER(ANS)) THEN ! NEW VALUE
CALL TXT2R(ANS,STA(ICOL,NLINE))
IF(ICOL.LT.3) STA(4,NLINE)=-414.1959
CALL WRITE_LINE2(ILINE,NLINE,0)
NLINE=NLINE+1
IF(NLINE.LT.NBOT) THEN
ILINE=ILINE+1
ELSE
IF(NLINE.LE.NSTA) THEN
CALL UP_VT
NBOT=NBOT+1
NTOP=NTOP+1
ELSE
NLINE=NSTA
ENDIF
ENDIF
CALL WRITELINE(ILINE,NLINE,ICOL)
ELSEIF(ANS(1:1).EQ.'I') THEN ! INSERT BEFORE OR AFTER
CALL WRITE_LINE2(ILINE,NLINE,0)
IF(ANS(2:2).NE.'B') THEN
NLINE=NLINE+1
ILINE=ILINE+1
ENDIF
DO WHILE(IPF.EQ.0.AND.ANS.GT.' ')
IF(NSTA.GE.1024) THEN
CALL TEXT_VT(
> 'ERROR -- ONLY 1024 STATIONS ALLOWED',24,1,0)
CALL BELL
ANS=' '
ELSE
istat=lib$put_buffer(0)
IF(NLINE.GT.NBOT) THEN ! BOTTOM OF SCROLL
CALL UP_VT
NBOT=ISDIF+NTOP
ILINE=ISBOT
ELSE ! MOVE EVERYTHING DOWN IN SCROLL
L1=0
istat=lib$set_buffer(sbuf)
DO L=NLINE+1,NBOT-1
L1=L1+1
IL=(L1/5)*5
ISTAT=IPURGE_BUFFER(IL.EQ.L1)
CALL WRITE_LINE2(ILINE+L1,L,0)
END DO
istat=lib$put_buffer(0)
ENDIF
CALL ERASE_LINE(ILINE,1)
CALL WRITELINE(ILINE,NLINE,10)
CALL ASKQPF(' LOCATION? ',ANS,23,1,IPF)
IF(IPF.GT.0.AND.IPF.LT.5) RETURN
IF(LNUMBER(ANS)) THEN
DO L=NSTA,NLINE,-1 ! MOVE EVERYTHING DOWN
DO K=1,4 ! IN ARRAY
STA(K,L+1)=STA(K,L)
END DO
END DO
NSTA=NSTA+1
CALL PUTINUM(NSTA,3,2,0,3)
CALL TXT2R(ANS,STA(1,NLINE))
STA(4,NLINE)=-414.1959
801 CALL WRITELINE(ILINE,NLINE,11)
CALL ASKQPF(' ELEVATION? ',ANS,23,1,IPF)
DO WHILE(IPF.EQ.8) ! ALLOW CORRECTION
CALL WRITELINE(ILINE,NLINE,10)
CALL ASKQPF(' LOCATION? ',ANS,23,1,IPF)
TEMP=0.0
IF(LNUMBER(ANS)) CALL TXT2R(ANS,TEMP)
IF(IPF.EQ.0) STA(1,NLINE)=TEMP
CALL WRITELINE(ILINE,NLINE,11)
CALL ASKQPF(' ELEVATION? ',ANS,23,1,IPF)
END DO
TEMP=0.0
IF(LNUMBER(ANS)) CALL TXT2R(ANS,TEMP)
IF(IPF.EQ.0) STA(2,NLINE)=TEMP
CALL WRITELINE(ILINE,NLINE,12)
CALL ASKQPF(' OBSERVED VALUE? ',ANS,23,1,IPF)
IF(IPF.EQ.8) GOTO 801
istat=lib$set_buffer(sbuf)
TEMP=0.0
IF(LNUMBER(ANS)) CALL TXT2R(ANS,TEMP)
STA(3,NLINE)=TEMP
CALL WRITE_LINE2(ILINE,NLINE,0)
NLINE=NLINE+1
ILINE=ILINE+1
ANS='X'
ENDIF
ENDIF
END DO ! END OF INSERT
IF(NLINE.LT.NBOT) THEN
L1=-1
DO L=NLINE,NBOT-1 ! MOVE EVERYTHING UP IN SCROLL
L1=L1+1
IL=(L1/5)*5
ISTAT=IPURGE_BUFFER(IL.EQ.L1)
CALL WRITE_LINE2(ILINE+L1,L,0)
END DO
ENDIF
CALL WRITELINE(ILINE,NLINE,ICOL)
ELSEIF(ANS(1:1).EQ.'D') THEN ! DELETE LINES
IDEL=1
ANS=ANS(2:10)
IF(ICHAR(ANS(1:1)).EQ.32) ANS=ANS(2:10)
IF(LNUMBER(ANS)) CALL TXT2INT(ANS,IDEL)
IF(IDEL.LT.1) IDEL=1
ITO=NLINE+IDEL-1
IF(NSTA.LT.ITO) ITO=NSTA
IDEL=ITO-NLINE+1
DO L=1,IDEL
NL=NLINE-1+L
IF(NL.LT.NBOT) THEN
JP1=ILINE-1+L
ISTAT=IPURGE_BUFFER(JP1.EQ.(JP1/5)*5)
CALL WRITE_LINE2(JP1,NL,3)
ENDIF
END DO
WRITE(TEXT,407) IDEL
istat=lib$put_buffer(0)
407 FORMAT('DELETE ',I3,' STATIONS -- VERIFY ? ')
IF(IDEL.EQ.1) TEXT(19:20)=' -'
CALL ASKQPF(TEXT,ANS,23,1,IPF)
istat=lib$set_buffer(sbuf)
IF(ANS(1:1).EQ.'Y') THEN
NSTA=NSTA-IDEL
CALL PUTINUM(NSTA,3,2,0,3)
DO L=NLINE,NSTA
DO K=1,4
STA(K,L)=STA(K,L+IDEL)
END DO
END DO
IF(NBOT.GT.NSTA+1) NBOT=NSTA+1
ENDIF
JP1=ILINE-1
DO L=NLINE,NBOT-1
JP1=JP1+1
ISTAT=IPURGE_BUFFER(JP1.EQ.(JP1/5)*5)
CALL WRITE_LINE2(JP1,L,0)
END DO
CALL WRITELINE(ILINE,NLINE,ICOL)
DO WHILE(JP1.LT.ISBOT)
JP1=JP1+1
CALL ERASE_LINE(JP1,1)
END DO
ELSEIF(ANS(1:3).EQ.'REC') THEN ! RECALCULATE STATIONS
istat=lib$put_buffer(0)
CALL ASKQ('RECALCULATE VERIFY? ',ANS,23,1)
istat=lib$set_buffer(sbuf)
IF(ANS(1:1).EQ.'Y') THEN
CALC=.FALSE.
DELX=(PROF(3)-PROF(2))/FLOAT(NSTA)
X1=PROF(2)
DO L=1,NSTA
STA(4,L)=-414.1959
STA(1,L)=X1
X1=X1+DELX
END DO
CALL DIS_STA(ISDIF,ISTOP,NTOP)
CALL WRITELINE(ILINE,NLINE,ICOL)
ENDIF
ELSEIF(ANS(1:3).EQ.'ELE') THEN ! SET TO CONSTANT ELEV.
CALL TEXT_VT('Set to constant elevation.',22,1,0)
istat=lib$put_buffer(0)
CALL ASKQPF('Elevation? ',ANS,23,1,IPF)
istat=lib$set_buffer(sbuf)
IF(LNUMBER(ANS)) THEN
CALL TXT2R(ANS,ELE)
DO L=1,NSTA
STA(2,L)=ELE
STA(4,L)=-414.1959
END DO
CALL DIS_STA(ISDIF,ISTOP,NTOP)
CALL WRITELINE(ILINE,NLINE,ICOL)
ENDIF
ELSEIF(ANS(1:3).EQ.'MOV') THEN ! MOVE CALC INTO OBS
CALL TEXT_VT(
> 'Move calculated values into observed values.',22,1,0)
istat=lib$put_buffer(0)
CALL ASKQPF('Verify move: (Y/N) ',ANS,23,1,IPF)
istat=lib$set_buffer(sbuf)
IF(IPF.NE.0) RETURN
IF(ANS(1:1).EQ.'Y') THEN
DO L=1,NSTA
STA(3,L)=STA(4,L)
END DO
CALL DIS_STA(ISDIF,ISTOP,NTOP)
CALL WRITELINE(ILINE,NLINE,ICOL)
ENDIF
ELSEIF(ANS(1:1).EQ.'M') THEN ! SET MATCH
C MATCH OBSERVED WITH CALCULATED AT STATION n
ANS=ANS(2:10)
IF(ICHAR(ANS(1:1)).EQ.32) ANS=ANS(2:10)
LTEST=LNUMBER(ANS)
IF(.NOT.LTEST) THEN
istat=lib$put_buffer(0)
CALL ASKQPF('Match station? ',ANS,23,1,IPF)
LTEST=LNUMBER(ANS)
istat=lib$set_buffer(sbuf)
ENDIF
IF(LTEST) THEN
CALL TXT2INT(ANS,MATCH)
RAVE=0.0
IF(MATCH.NE.0) RAVE=STA(4,MATCH)-STA(3,MATCH)
CALL PUTINUM(MATCH,3,42,0,4)
CALL DIS_STA(ISDIF,ISTOP,NTOP)
CALL WRITELINE(ILINE,NLINE,ICOL)
ENDIF
ELSEIF(ANS(1:4).EQ.'PLOT') THEN ! PLOT DATA
istat=lib$put_buffer(0)
CALL SCROLL(1,22)
CALL PLOT_DATA(IPF)
IF(IPF.EQ.0) IPF=4
RETURN
ELSEIF(ANS(1:1).GT.' ') THEN
CALL TEXT_VT('PF4 UNKNOWN COMMAND',24,1,0)
CALL BELL
ENDIF
istat=lib$put_buffer(0)
CALL ASKQPF('Enter value ',ANS,23,1,IPF)
CALL ERASE_LINE(24,1)
END DO
RETURN
END
C
SUBROUTINE DIS_STA(ISDIF,ISTOP,NTOP)
CHARACTER SBUF*2560
COMMON/SCREENBUF/SBUF
N=NTOP-1
DO I=1,ISDIF
IL=(I/5)*5
ISTAT=IPURGE_BUFFER(IL.EQ.I)
CALL WRITE_LINE2(I+ISTOP,I+N,0)
END DO
RETURN
END
C
SUBROUTINE WRITE_LINE2(IC,I,IFLAG)
CHARACTER*68 TEXT
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE
TEMP=STA(4,I)
WRITE(TEXT,10) I,(STA(K,I),K=1,3),TEMP-RAVE
10 FORMAT(I4,3X,4(5X,F10.3))
IF(TEMP.EQ.-414.1959) TEXT(58:68)=' ...... '
CALL TEXT_VT(TEXT,IC,3,IFLAG)
RETURN
END
C
SUBROUTINE WRITELINE(IC,I,ICOL)
CHARACTER*65 TEXT
INTEGER COOR(4)
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE
DATA COOR/14,29,44,59/
IF(ICOL.GE.10) THEN
KEND=ICOL-10
WRITE(TEXT,10) I,(STA(K,I),K=1,KEND)
10 FORMAT(I4,3X,3(5X,F10.3))
CALL TEXT_VT(TEXT,IC,3,0)
CALL TEXT_VT(' ',IC,COOR(KEND+1),2)
ELSE
CALL WRITE_LINE2(IC,I,0)
CALL PUTRNUM(STA(ICOL,I),IC,COOR(ICOL),2,10,3)
ENDIF
RETURN
END
SUBROUTINE SUMMARY(IPF)
CHARACTER DEVICE*32,FILE*32,TITLE*64,ANS*32
LOGICAL*2 TFBODY,LOADED,CALC
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE,MATCH
COMMON/BLKBODY/NBODY,BODY(25,39),NPTS(25),TFBODY(25)
COMMON/BLKPRO/PROF(10),TITLE
COMMON/BLKFILE/FILE,LOADED,CALC
C
CALL ASKQPF('Print summary on screen or to a file? (S/F) ',
> ANS,23,1,IPF)
IF(ANS(1:1).EQ.'S') THEN ! TO TERMINAL
CALL ERASE_VT
DEVICE='TT:'
ELSEIF(ANS(1:1).EQ.'F') THEN ! TO FILE
CALL ASKQPF('NAME OF OUTPUT FILE? ',DEVICE,23,1,IPF)
IF(IPF.NE.0.OR.DEVICE(1:1).LE.' ') RETURN
ELSE
RETURN
ENDIF
C
OPEN(UNIT=14,NAME=DEVICE,TYPE='NEW')
WRITE(14,30) FILE
30 FORMAT(' SUMMARY OF ',A32)
K=4
WRITE(14,*) ' TWO AND A HALF DIMENSIONAL GRAVITY MODELING'
WRITE(14,*) ' '
WRITE(14,35) TITLE
35 FORMAT(' TITLE: ',A64)
WRITE(14,*) ' '
IUNIT=PROF(1)
IF(IUNIT.EQ.1) THEN
WRITE(14,*) ' UNITS ARE IN KILOMETERS'
ELSEIF(IUNIT.EQ.2) THEN
WRITE(14,*) ' UNITS ARE IN METERS'
ELSEIF(IUNIT.EQ.3) THEN
WRITE(14,*) ' UNITS ARE IN KILOFEET'
ELSE
WRITE(14,*) ' UNITS ARE IN MILES'
ENDIF
WRITE(14,*) ' '
WRITE(14,*) ' THERE ARE ',NBODY,' BODIES.'
DO I=1,NBODY
WRITE(14,*) ' '
WRITE(14,*) ' BODY NUMBER ',I
WRITE(14,*) ' DENSITY CONTRAST',BODY(I,1)
WRITE(14,*) ' LENGTH TO THE LEFT OF STRIKE',BODY(I,2)
WRITE(14,*) ' LENGTH TO THE RIGHT OF STRIKE',BODY(I,3)
K=NPTS(I)
WRITE(14,*) ' NUMBER OF POINTS IN THIS BODY',K
WRITE(14,*) ' '
WRITE(14,*) ' POINT X Z'
DO J=1,K
IC=3+J*2
WRITE(14,65) J,BODY(I,IC-1),BODY(I,IC)
65 FORMAT(3X,I3,2F14.6)
END DO
END DO
IF(CALC) THEN
WRITE(14,75)
75 FORMAT('1STATION LOCATION ELEVATION OBSERVED',
> ' CALCULATED')
WRITE(14,*) ' NUMBER ',
> 'VALUE VALUE'
DO I=1,NSTA
WRITE(14,85) I,(STA(J,I),J=1,3),STA(4,I)-RAVE
85 FORMAT(2X,I3,3X,4(1X,F10.4))
END DO
ELSE
WRITE(14,77)
77 FORMAT('1STATION LOCATION ELEVATION OBSERVED')
WRITE(14,*)' NUMBER VALUE'
DO I=1,NSTA
WRITE(14,85) I,(STA(J,I),J=1,3)
END DO
ENDIF
IF(DEVICE(1:3).NE.'TT:') THEN
CLOSE(UNIT=14)
CALL ASKQPF('Do you wish to send this file to printer? ',
> ANS,23,1,IPF)
IF(ANS(1:1).EQ.'Y') THEN
ISTAT=LIB$SPAWN('$ PRINT/NOTIFY '//DEVICE)
IF(ISTAT.GT.1) CALL LIB$STOP(%VAL(ISTAT))
ENDIF
ELSE
WRITE(14,*)
CLOSE(UNIT=14)
CALL ASKQPF('Press RETURN to continue. ',ANS,23,1,IPF)
ENDIF
RETURN
END
SUBROUTINE CADY_SUB
REAL KAP(5)
LOGICAL*2 TFBODY,FINITE
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE,MATCH
COMMON/BLKBODY/NBODY,BODY(25,39),NPTS(25),TFBODY(25)
COMMON/BLKPRO/PROF1
DATA KAP/6.67,6.67E-3,2.0318,2.0318E-3,10.72664/
IUNIT=PROF1
DO L=1,NSTA
STA(4,L)=0.0
END DO
C
C DO FOR EACH BODY
C
L=0
DO LL=1,NBODY
L=L+1
DO WHILE (.NOT.TFBODY(L))
L=L+1
END DO
Y1=BODY(L,2)
Y2=BODY(L,3)
Y1S=Y1*Y1
Y2S=Y2*Y2
FINITE=Y1*Y2.NE.0.0
C
C DO FOR EACH STATION
C
DO K=1,NSTA
FZ=0.0
RLOC=STA(1,K)
RELE=STA(2,K)
C
C CALCULATE FOR LAST POINT IN BODY L
C
J=NPTS(L)
X1=BODY(L,2+J*2)-RLOC
Z1=RELE+BODY(L,3+J*2)
IF(Z1.EQ.0.0) Z1=.0001
RSQ1=X1*X1+Z1*Z1
IF(RSQ1.EQ.0.0) RSQ1=.001
C
C CALCULATE FOR SECOND POINT IN BODY L
C
DO J=1,NPTS(L)
X2=BODY(L,2+J*2)-RLOC
Z2=RELE+BODY(L,3+J*2)
IF(Z2.EQ.0.0) Z2=.0001
RSQ2=X2*X2+Z2*Z2
IF(RSQ2.EQ.0.0) RSQ2=.001
IF(X2.EQ.X1) X1=X1+.0001
RM=(Z2-Z1)/(X2-X1)
THETA=ATAN2(Z2-Z1,X2-X1)
C=1.0/COS(THETA)
Z0=Z2-X2*RM
A=Z0/C
Q=A/C
X0=A*SIN(THETA)
S=X1+X0
T=X2+X0
C
FZ=FZ+T*ALOG(RSQ2)-S*ALOG(RSQ1)+
> 2.*Q*(ATAN2(T,Q)-ATAN2(S,Q))
C
IF(FINITE) THEN
R11=SQRT(Y1S+RSQ1)
R21=SQRT(Y2S+RSQ1)
R12=SQRT(Y1S+RSQ2)
R22=SQRT(Y2S+RSQ2)
A=A*A
FZ=FZ+S*ALOG((Y1+R11)*(Y2+R21))
> -T*ALOG((Y1+R12)*(Y2+R22))
> +(Y1*ALOG((C*S+R11)/(C*T+R12))
> + Y2*ALOG((C*S+R21)/(C*T+R22)))/C
FZ=FZ+(ATAN2(A+Y1S+Y1*R12,Z0*T)
> - ATAN2(A+Y1S+Y1*R11,Z0*S)
> + ATAN2(A+Y2S+Y2*R22,Z0*T)
> - ATAN2(A+Y2S+Y2*R21,Z0*S))*Q
ENDIF
X1=X2
Z1=Z2
RSQ1=RSQ2
END DO
C
C ADD ANOMALY OF BODY L TO ANOMALY AT STATION K
C
STA(4,K)=STA(4,K)-KAP(IUNIT)*BODY(L,1)*FZ
END DO
END DO
RAVE=0.0
IF(MATCH.NE.0) RAVE=STA(4,MATCH)-STA(3,MATCH)
RETURN
END
SUBROUTINE INOUT(N)
CHARACTER TITLE*64,FILE*32
LOGICAL*2 TFBODY,LOADED,CALC
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE,MATCH
COMMON/BLKBODY/NBODY,BODY(25,39),NPTS(25),TFBODY(25)
COMMON/BLKPRO/PROF(10),TITLE
COMMON/BLKFILE/FILE,LOADED,CALC
C
C READ OR WRITE DATA FILE
C
IF(N.EQ.1) THEN
OPEN(UNIT=13,NAME=FILE,TYPE='OLD',READONLY,ERR=99)
READ(13,10) TITLE
10 FORMAT(1X,A64)
READ(13,20) (PROF(I),I=2,10)
20 FORMAT(9F8.2)
READ(13,30) NBODY,NSTA,IUNIT,MATCH
30 FORMAT(4I3)
PROF(1)=IUNIT
DO I=1,NBODY
TFBODY(I)=.TRUE.
READ(13,40) BODY(I,1),NPTS(I),BODY(I,2),BODY(I,3)
40 FORMAT(F8.3,I2,2F10.3)
K=NPTS(I)
DO J=1,K
JJ=3+J*2
READ(13,50) BODY(I,JJ-1),BODY(I,JJ)
50 FORMAT(2F10.3)
END DO
END DO
DO I=1,NSTA
STA(4,I)=-414.1959
READ(13,70) (STA(J,I),J=1,3)
70 FORMAT(3F10.3)
END DO
LOADED=.TRUE.
C
ELSE
OPEN(UNIT=13,NAME=FILE,TYPE='NEW')
WRITE(13,10) TITLE
WRITE(13,20) (PROF(I),I=2,10)
IUNIT=PROF(1)
WRITE(13,30) NBODY,NSTA,IUNIT,MATCH
I=0
DO L=1,NBODY
I=I+1
DO WHILE (.NOT.TFBODY(I))
I=I+1
END DO
WRITE(13,40) BODY(I,1),NPTS(I),BODY(I,2),BODY(I,3)
K=NPTS(I)
DO J=1,K
WRITE(13,50) BODY(I,3+J*2-1),BODY(I,3+J*2)
END DO
END DO
IF(N.EQ.2) THEN
DO I=1,NSTA
WRITE(13,71) (STA(J,I),J=1,3)
71 FORMAT(4F10.3)
END DO
ELSE
DO I=1,NSTA
WRITE(13,71) (STA(J,I),J=1,3),STA(4,I)-RAVE
END DO
ENDIF
ENDIF
CLOSE(UNIT=13)
RETURN
99 CALL ASKQ('FILE NOT FOUND, PRESS RETURN TO CONTINUE',
> ANS,23,1)
RETURN
END
SUBROUTINE VERS_CADY_PLOT(INUM)
CHARACTER TITLE*64,FILE*32,CH
LOGICAL*2 TFBODY,LOADED,CALC
LOGICAL*1 STRING(64)
COMMON/BLKSTA/STA(4,1024),NSTA,RAVE,MATCH
COMMON/BLKBODY/NBODY,BODY(25,39),NPTS(25),TFBODY(25)
COMMON/BLKPRO/PROF(10),TITLE
COMMON/BLKFILE/FILE,LOADED,CALC
YL=1.4 ! RANGE OF Y
YR=9.65
X1T=2.1 ! RANGE OF X FOR TOP
X2T=X1T+2.75
X1B=X2T+.25 ! RANGE OF X FOR BOTTOM
X2B=X2T+2.75
ISTAT=LIB$SPAWN('$ DELETE *.PLV;*') ! PREVIOUS PLOT FILES
IF(ISTAT.GT.1) CALL LIB$STOP(%VAL(ISTAT))
DO I=1,64 ! REPLACE ALL O WITH 0
CH=TITLE(I:I)
IF(CH.EQ.'O') CH='0'
STRING(I)=ICHAR(CH)
END DO
C
CALL PLOTS(0,0,0) ! BEGIN PLOT
CALL NEWPEN(3)
CALL SYMBOL(X1T-.2,YL,.14,STRING,90.,64)
CALL NEWPEN(2)
CALL SYMBOL(X1T+1.4,YL-.2,.07,'MILLIGALS',180.,9)
CALL SYMBOL(X2T+1.8,YL-.3,.07,'DEPTH IN ',180.,9)
IUNIT=PROF(1)
IF(IUNIT.EQ.1) THEN
CALL SYMBOL(X2T+1.9,YL-.2,.07,'KILL0METERS',180.,11)
ELSEIF(IUNIT.EQ.2) THEN
CALL SYMBOL(X2T+1.6,YL-.2,.07,'METERS',180.,6)
ELSEIF(IUNIT.EQ.3) THEN
CALL SYMBOL(X2T+1.6,YL-.2,.07,'MILES',180.,5)
ELSE
CALL SYMBOL(X2T+2.,YL-.2,.07,'KILOFEET',180.,8)
ENDIF
CALL SYMBOL(X2T+.18,YL+(YR-YL)/2.-.5,.07,'DISTANCE',90.,8)
CALL NEWPEN(3)
CALL MOVE(X1T,YL) ! DRAW TOP HALF
CALL DRAW(X1T,YR)
CALL DRAW(X2T,YR)
CALL DRAW(X2T,YL)
CALL DRAW(X1T,YL)
CALL NEWPEN(2)
CALL NUMBER(X1T,YL-.5,.07,PROF(6),90.,0)
CALL NUMBER(X2T,YL-.5,.07,PROF(5),90.,0)
ITIC=PROF(7)-1
DELTA=(X2T-X1T)/PROF(7)
XORIG=X1T
DO I=1,ITIC ! LEFT Y AXIS
XORIG=XORIG+DELTA
CALL MOVE(XORIG,YL)
CALL DRAW(XORIG,YL+.1)
END DO
XORIG=X1T
DO I=1,ITIC ! RIGHT Y AXIS
XORIG=XORIG+DELTA
CALL MOVE(XORIG,YR)
CALL DRAW(XORIG,YR-.1)
END DO
CALL NUMBER(X2T+.18,YL,.07,PROF(2),90.,0)
CALL NUMBER(X2T+.18,YR-.2,.07,PROF(3),90.,0)
ITIC=PROF(4)-1
DELTA=(YR-YL)/PROF(4)
YORIG=YL
DO I=1,ITIC ! X AXIS
YORIG=YORIG+DELTA
CALL MOVE(X2T,YORIG)
CALL DRAW(X2T-.1,YORIG)
END DO
C
CALL NEWPEN(3)
CALL MOVE(X1B,YL) ! DRAW BOTTOM HALF
CALL DRAW(X1B,YR)
CALL DRAW(X2B,YR)
CALL DRAW(X2B,YL)
CALL DRAW(X1B,YL)
CALL NEWPEN(2)
CALL NUMBER(X1B,YL-.5,.07,PROF(8),90.,0)
CALL NUMBER(X2B,YL-.5,.07,PROF(9),90.,0)
ITIC=PROF(10)-1
DELTA=(X2B-X1B)/PROF(10)
XORIG=X1B
DO I=1,ITIC ! LEFT Y AXIS
XORIG=XORIG+DELTA
CALL MOVE(XORIG,YL)
CALL DRAW(XORIG,YL+.1)
END DO
XORIG=X1B
DO I=1,ITIC ! RIGHT Y AXIS
XORIG=XORIG+DELTA
CALL MOVE(XORIG,YR)
CALL DRAW(XORIG,YR-.1)
END DO
ITIC=PROF(4)-1
DELTA=(YR-YL)/PROF(4)
YORIG=YL
DO I=1,ITIC ! X AXIS
YORIG=YORIG+DELTA
CALL MOVE(X2B,YORIG)
CALL DRAW(X2B-.1,YORIG)
END DO
CALL NEWPEN(1) ! PLOT TOP HALF
CALL VIEW(X1T,X2T,YL,YR)
CALL WIND(PROF(6),PROF(5),PROF(2),PROF(3))
DO I=1,NSTA
CALL W2V(STA(4,I)-RAVE,STA(1,I),X,Y)
N=1
IF(X.LT.X1T) THEN ! WITHIN RANGE ?
X=X1T
N=3
ELSEIF(X.GT.X2T) THEN
X=X2T
N=3
ENDIF
CALL MARK(N,X,Y) ! PLOT CALC VALUES
CALL W2V(STA(3,I),STA(1,I),X,Y)
N=2
IF(X.LT.X1T) THEN ! WITHIN RANGE ?
X=X1T
N=3
ELSEIF(X.GT.X2T) THEN
X=X2T
N=3
ENDIF
CALL MARK(N,X,Y) ! PLOT OBS VALUES
END DO
CALL VIEW(X1B,X2B,YL,YR) ! PLOT BOTTOM HALF
CALL WIND(PROF(8),PROF(9),PROF(2),PROF(3))
I=1
DO II=1,NBODY ! PLOT EACH BODY
DO WHILE(.NOT.TFBODY(I)) ! FIND NEXT BODY
I=I+1
END DO
NUMPTS=NPTS(I)
J=4+(NUMPTS-1)*2
CALL W2V(BODY(I,J+1),BODY(I,J),X,Y)
CALL PRANGE(X,Y,X1B,X2B,YL,YR)
XSUM=0.
YSUM=0.
CALL MOVE(X,Y) ! MOVE TO LAST POINT IN BODY
DO JJ=1,NUMPTS
J=4+(JJ-1)*2
CALL W2V(BODY(I,J+1),BODY(I,J),X,Y)
CALL PRANGE(X,Y,X1B,X2B,YL,YR)
XSUM=XSUM+X
YSUM=YSUM+Y
CALL DRAW(X,Y) ! DRAW TO EACH POINT IN BODY
END DO
XSUM=XSUM/FLOAT(NUMPTS) ! PLOT DENSITY ANNOTATION
YSUM=YSUM/FLOAT(NUMPTS)
IF(INUM.EQ.1) THEN ! SMALL PRINT
CALL NUMBER(XSUM,YSUM,.035,BODY(I,1),90.,3)
ELSEIF(INUM.EQ.2) THEN ! LARGE
CALL NUMBER(XSUM,YSUM,.07,BODY(I,1),90.,3)
ENDIF ! OR NOT AT ALL
I=I+1
END DO
CALL PLOT(0.,0.,+999)
ISTAT=LIB$SPAWN('$ RASM') ! SEND PLOT FILE TO VERSATEC
IF(ISTAT.GT.1) CALL LIB$STOP(%VAL(ISTAT))
RETURN
END
C
SUBROUTINE PRANGE(X,Y,X1B,X2B,YL,YR)
IF(X.LT.X1B) THEN
X=X1B
ELSEIF(X.GT.X2B) THEN
X=X2B
ENDIF
IF(Y.LT.YL) THEN
Y=YL
ELSEIF(Y.GT.YR) THEN
Y=YR
ENDIF
RETURN
END
C
SUBROUTINE MOVE(X,Y)
CALL PLOT(X,Y,3)
RETURN
END
SUBROUTINE DRAW(X,Y)
CALL PLOT(X,Y,2)
RETURN
END
C
SUBROUTINE MARK(N,X,Y)
DEL=.03
IF(N.NE.2) THEN
CALL PLOT(X-DEL,Y+DEL,3)
CALL PLOT(X+DEL,Y-DEL,2)
CALL PLOT(X-DEL,Y-DEL,3)
CALL PLOT(X+DEL,Y+DEL,2)
ENDIF
IF(N.NE.1) THEN
CALL PLOT(X,Y-DEL,3)
CALL PLOT(X,Y+DEL,2)
CALL PLOT(X-DEL,Y,3)
CALL PLOT(X+DEL,Y,2)
ENDIF
RETURN
END
C
SUBROUTINE VIEW(X1,X2,Y1,Y2)
COMMON/BLK/VX0,VY0,WX0,WY0,FACTX,FACTY,VX2,VY2
VX0=X1
VY0=Y1
VX2=X2
VY2=Y2
RETURN
END
C
SUBROUTINE WIND(X1,X2,Y1,Y2)
COMMON/BLK/VX0,VY0,WX0,WY0,FACTX,FACTY,VX2,VY2
WX0=X1
WY0=Y1
FACTX=(VX2-VX0)/(X2-WX0)
FACTY=(VY2-VY0)/(Y2-WY0)
RETURN
END
C
SUBROUTINE W2V(WX,WY,RX,RY)
COMMON/BLK/VX0,VY0,WX0,WY0,FACTX,FACTY
RX=(WX-WX0)*FACTX+VX0
RY=(WY-WY0)*FACTY+VY0
RETURN
END
Next Chapter: Appendix B
Previous Chapter: Appendix A, sections 1-4