1

• j A111DD TflMSflT

auto mm



UNITED STATES DEPARTMENT OF COMMERCE • Maurice H. Stans, Secretary

NATIONAL BUREAU OF STANDARDS • Lewis M. Branscomb, Director

Source Listing of OMNITAB II Program

Sally T. Peavy, Ruth N. Varner, and David Hogben

Statistical Engineering Laboratory

Applied Mathematics Division

Institute for Basic Standards

National Bureau of Standards

Washington, D.C. 20234

> • » Nat. Bur. Stand. (U.S.), Spec. Publ. 339, 371 pages (Dec. 1970)

CODEN: XNBSA

Issued December 1970

For sale by the Superintendent of Documents, U.S. Government Printing Office, Washington, D.C. 20402 (Order by SD Catalog No. C 13.10:339), Price $4.75
NATIONAL BUREAU OF STANDARDS

APR & 1971

180322

Q CIOO

.U 51

Library of Congress Catalog Card Number: 79-609406
Contents

Page Introduction 1 Description 1 Programming Techniques 2

OMNITAB II Operating System Routines 3

References 4

Table of Contents for Subprogram Listings 5

Listing of Subprograms 7

Appendix-OMNIT Flow Chart 346

III

Source Listing of OMNITAB II Program

Sally T. Peavy, Ruth N. Varner, and David Hogben

OMNITAB II is a general-purpose interpretive computing system designed to allow a nonprogram- mer to use a high-speed computer easily, accurately and effectively. The system permits the user to perform arithmetic operations including complex arithmetic, trigonometric calculations, miscellaneous

function calculations, statistical analysis, Bessel function calculations, and operations on matrices and

arrays.

The OMNITAB II system contains 177 subprograms written in the ANSI FORTRAN language.

Every effort has been made to make the system transportable. This publication contains a complete

listing of all these subprograms. The listing is preceded by a brief introduction which describes the programming techniques used; the use of system library functions; and the subprograms used to control the flow of operations in the OMNITAB system.

Key words: Accuracy; algorithms; ANSI FORTRAN; documentation; error checking; machine in- dependent; OMNITAB II operating system subprograms; OMNITAB II source listing; programming

techniques; transportable; user-oriented computing system.

1. Introduction

The OMNITAB II computing system enables

the nonprogrammer to use a large digital computer

to perform data, statistical, and numerical analysis

without having any prior knowledge of computers

or computer languages. The user writes simple

English instructions to obtain accurate results

easily and effectively. The instructions reference

reliable, varied, and sophisticated algorithms for

analysis and manipulation. The tedious task of

formatting data for input and output is alleviated

by OMNITAB II through free field input, readable

printing, and automatic printouts. Formatting capability exists, if more flexibility is desired. The

system permits the user to perform: arithmetic

operations including complex arithmetic, trigonometric calculations, data manipulations, miscellaneous function calculations, statistical analysis,

numerical analysis, Bessel function calculations,

operations on matrices and arrays, and thermodynamic calculations. Although OMNITAB has

been specifically designed for nonprogrammers,

many experienced programmers find uses for

OMNITAB.

OMNITAB was developed at the National Bureau

of Standards under the guidance of Joseph Hilsenrath who contributed the basic ideas and

philosophy, see Hilsenrath et al. [1966]. The program

was written initially in a mixture of symbolic

machine language and FORTRAN. With the advent

of third generation computers and the success of

OMNITAB, it became necessary to rewrite the

program and to make it as machine independent

as possible. Walter J. Gilbert undertook this task

in 1966 and initiated a number of changes and new

features. Since 1968, the Statistical Engineering

Laboratory, Applied Mathematics Division, has

been responsible for the development, maintenance,

and management of OMNITAB. NBS OMNITAB II Version 5.0 (Hogben et al. [1970]) is the result

of this effort.

2. Description

This publication is one of four which constitute

the documentation for OMNITAB II. A user's

guide is given in Hogben et al. [1970]. A systems

programmer's guide is contained in Peavy et al. [1970]. Problems and results for assessing the suc- cess of implementing OMNITAB II are given in

Varner et al. [1970]. No attempt is made to make

this publication independent of the other three.

In particular, the reader should consult Hogben

et al. [1970] for a general understanding of OMNITAB

II and for an explanation of terms used in conjunction with OMNITAB II. The OMNITAB II software system contains 177

subprograms written in American National Standard

(ANSI) FORTRAN language. This publication contains a listing of all of these subprograms in section

7. The subprograms are listed alphabetically by the

subprogram name; except for the main program

which appears first. Each subprogram has a unique

identification in columns 73-75. Sequential line

numbers appear in columns 76-79. This provides

a means of easily updating the subprogram when

improvements are made. Each subprogram has

been tidied using the program of Murphy [1966].

A table of contents giving the subprogram name,

subprogram identification, and page number is given in section 6 on pages 5 and 6. Along with the

identification, symbols are used to indicate the main

function of each subprogram. The symbol denotes

the main purpose and not necessarily the sole

function of the subprogram. For example, OMNIT is an executive subprogram, but it also executes the

command NOTE.

The material contained herein is a complete

listing of the OMNITAB II program with some ex- ceptions. Subprograms which compute the square

root, sin, cos, tan, input and output and other subprograms which are normally part of the operating

system library are not included; see Peavy et al. [1970].

1
Each subprogram has been tested as thoroughly

as possible. A few errors which escaped detection

in the preliminary testing were subsequently

detected in extensive use and corrected. Despite

considerable effort to make OMNITAB II error

free, a few errors are to be expected in such a large

system. We believe that any errors that remain are few in number. Any reader who finds errors or has

any comments is encouraged to write to us so that

improvements can be passed on to other users.

3. Programming Techniques

The subprograms which comprise the OMNITAB

II system were the efforts of many individuals working independently with considerable latitude. Thus,

the programming techniques used in the subprograms are varied. However, each subprogram

had to satisfy the following criteria.

(a) Programming language. All subprograms are

written in the ANSI FORTRAN language. Thus,

the routines which scan the OMNITAB II instructions, manipulate and pack characters, and involve

input-output are lengthy and to a limited extent

inefficient. These routines could be written in

machine language for a particular computer installation if efficiency were sufficiently important.

However, more attention has been devoted to developing a system which is transportable and easily

used. Since OMNITAB II is designed primarily

for the analysis of small-to-moderate amounts of

data, these considerations are far more important

than machine efficiency up to a certain point.

Every effort was made to produce machine in- dependent subprograms in order to make the entire

system transportable. Where it was necessary to supply alphanumeric information, a maximum of

three characters per machine word was permitted.

The only exception is in the case where user defined

formats are packed to a full capacity of the machine

word. Formats containing information for printout were restricted to 120 characters per line. Variable

names were used in all references to input-output

devices. These special features are discussed

further in Peavy et al. [1970]. All FORTRAN compilers do not accept every ANSI FORTRAN

statement and efforts were made to avoid the use

of such statements.

(b) Algorithms. The policy is to use the most

reliable and accurate algorithms. In some instances

it was not feasible to adhere to this policy completely.

Sometimes, a good algorithm was accepted with

the intention of improving it at a later date. This is particularly true for the commands with comprehensive automatic printing. Again, efficiency was

subordinated to accuracy when necessary. Most

calculations are performed using single precision

floating-point arithmetic. In a few instances, where

more accuracy was deemed desirable, double precision floating-point arithmetic was used. Double

precision arithmetic was used primarily to obtain

full single precision accuracy.

(c) Error checking. Every subprogram which exe- cutes a command is required to do extensive error checking. Besides checking for correct number and

type of arguments and previous errors, the subprograms have to perform unique checks for the

particular command that is to be executed. Specific

messages are printed and execution of further

OMNITAB instructions may be affected depending

upon the severity of the error. However, this does

not prevent OMNlTAB from scanning the remaining instructions for errors unless the instruction

is stored. See Hogben et al. [1970] and Peavy et al. [1970] for further details.

(d) Elementary functions. The original OMNITAB

had its own programs to compute the elementary

functions (SIN, LOGE, etc.) which were of known

accuracy. In order to make OMNITAB II as transportable as possible, this procedure was not

followed and the system library functions of the

particular computer system are used. The accuracy

of system library subroutines varies from one computer to another. Some are quite accurate;

others are surprisingly inaccurate as was explained

excellently by Cody [1970].

Many system library functions terminate execution if an arithmetic fault is encountered; for

example, in computing the square root of a negative

number. This confuses and hinders the nonprogrammer since the messages upon termination are

cryptic and often the fault is not significant. Efforts

have been made to eliminate this nuisance in

OMNITAB II. The subprograms are not permitted

to use any of the library functions directly. Instead,

they reference other function routines which check

the values of the arguments to be used by the

system library functions. See Peavy et al. [1970]

for a list of these function routines. Only if the values

are arithmetically legitimate and within certain

bounds will the system library functions be used.

Otherwise, a very explicit diagnostic message will

be printed. The result is set equal to zero and ex- ecution is continued.

(e) Input-output routines. Input-output conversion routines were also part of the old OMNITAB,

but again these had to be dropped in favor of using

operating system routines to make OMNITAB more

transportable. There is one important exception.

The subprogram RFORMT does the necessary

output conversion for many of the basic printing

commands. RFORMT does its own conversion to enable the printing of numbers in a more readable

form. The conversion is as accurate as or more

accurate than the standard operating system output

conversion routines. See Hogben [1970] for further

details.

(f) Division by zero. Computer operating systems

handle division by zero in many different ways.

In some instances a run may be terminated, in

other cases it may be ignored, and sometimes just

2
a message is printed that division by zero was at- tempted. The OMNITAB II commands which

specifically call for division, such as DIVIDE and

ADIVIDE, provide a check on zero before division

is attempted. If the divisor is zero, the result is set equal to zero, a message is printed, and execution is continued.

In some commands division by zero can occur

in nonobvious places depending upon the algorithm

which is used, as in the FIT command. When it is known that a divisor can equal zero, a check

on the divisor was provided. However, a check

on the divisor is not made in every instance that

division is used. It is possible that an error termination could occur, but it is not likely.

(g) Comment statements. Comments in the form

of FORTRAN comment statements are dispersed

in most subprograms. Some of the comments are very detailed and complete while others are rather

limited. The use of comments was at the discretion

of the programmer and no standard style or format

was required. Due to recent changes in OMNITAB

II, some of the comments may not be pertinent.

No effort has been made to edit the comments.

(h) Stand alone subprograms. Some of the subprograms may be used separately outside the

context of the OMNITAB II system. More often,

the programmer took advantage of the OMNITAB

II system when writing a particular subprogram.

A list of all the stand alone programs is given below.

Some use the OMNITAB II elementary function

routines and would have to be modified accordingly.

These exceptions are shown in parentheses. A

number of other subprograms, not listed here, such

as RFORMT could be easily modified to make them

stand alone.

ACCDIG (FLOG10)

computes the accuracy of one number compared to another

BEZERO (FDSQRT)

computes zeros of Bessel function

of order zero BEZONE computes zeros of Bessel function of order one BJORCK least squares quadratic fit for

CORRELATION

CBEI (FDSIN, FDCOS, FDSQRT, FDEXP)

computes Bessel functions of

complex argument, with and

without scale factors

DETRNK computes the determinant and

rank of a matrix

FREQCY (FLOG10)

computes the frequency distribution of a column of numbers

HDIAG (FSQRT)

computes eigenvalues and eigenvectors of a matrix

INTRP provides n-point Lagrangian in- terpolation

MXTXP (calls SORTSM below) performs matrix multiplication

X 'X or XX

PVTRI determines if matrix is upper or lower triangular

RANKO (equivalent to RANKX below)

RANKX determines ranks of a set of

numbers

RCSUM computes row and column sums

of a matrix

RNJBK machine independent pseudo ran- dom number generator

SKSYMV tests for skew symmetry of a matrix

SORTSM sorts products of matrix multiplication and sum

SPINV matrix inversion with minimum

round-off error accumulation

SYMV test for matrix symmetry

4. OMNITAB II Operating System

Routines

The main program of the OMNITAB II system is small and contains one call to the OMNIT subprogram. The OMNIT and XECUTE subprograms are the two major routines in the OMNITAB II system.

A detailed flow chart of OMNIT, prepared using

CAL-COMP [1968], is given in the appendix.

A capsule summary of the chief function of each

of the 34 executive subprograms is given below.

In addition, there are four block data subprograms

which are BLOCK, LBCONS, LOOKTB and

PHYSIC. The reader can consult Peavy et al. [1970] for further details.

Main Program

AARGS

ADRESS

AERR

ASTER

CHKCOL

CKIND

ERROR

EXPAND

INFERR

INPUT

LOCATE

LOOKUP

calls OMNIT

converts arguments of an in- struction

computes memory location of

first row of worksheet column

tallys and prints arithmetic

faults

checks proper use of asterisks

checks for valid column numbers and computes memory

locations

checks mode of instruction arguments

prints fatal errors sets up IARGS, ARGS and

KIND for use of arguments by

subprograms

prints informative diagnostics

reads all cards

locates stored instructions

assigns values to Ll and L2

which are used by XECUTE

3
MTXCHK determines if matrix fits in worksheet and computes memory

location

NNAME converts command name to a unique number

NONBLA looks for next non-blank character in scanning card

OMCONV converts input card images to standard code

OMNIT main subprogram which controls flow of operations

OUTPUT outputs card images to scratch

unit

PACK packs or unpacks alphanumeric

characters

PREPAK controls packing/unpacking of

characters for OMNITAB II system

READQ converts and stores data

RNDOWN prints location of error in stored

instructions

SETQ converts and stores data

SETUP initializes system at the very

beginning

STMT assembles and checks an in- struction number

STORE stores numbered instructions

TAPOP sets up arguments for tape operation commands

VARCON checks for legitimate variables

within asterisk

VECTOR vectorizes a constant

XECUTE calls appropriate subprogram to execute an instruction

XOMNIT initializing for OMNITAB command

XPND sets up IARGS, ARGS and KIND

for stored instructions

XSTOP terminates use of OMNITAB and

returns control to operating

system

OMNITAB II is a large system and its success is due in no small part to the fact that many specialists

have contributed to its development. We especially

thank J. Hilsenrath for his continued interest and

advice. Walter J. Gilbert laid the foundation for

OMNITAB II by developing the scan routine, many

of the basic subroutines, and by adding several new

features. Joseph M. Cameron formulated the set of

instructions for matrix and array operations in

addition to providing guidance, particularly in the

development of the least squares curve fitting instructions. The following individuals, besides the

authors, not only programmed many of the subprograms, but checked them out as well: Robert C.

McClenon, Carla G. Messina, Bradley A. Peavy,

and Philip J. Walsh. M. Stuart Scott did a fine job

of developing CORRELATION. Irene A. Stegun

and Ruth Zucker provided the subroutine ERRINT

which is used for the commands ERROR and CERF;

see Stegun and Zucker [1970]. Roy H. Wampler and

William J. Hall provided the subroutine BJORCK

for use with the subprogram CORREL. We thank

John Mandel for providing an approximation to

percentage points of the studentized range, which is used in the subprogram ONEWAY. Shirley G.

Bremer gave valuable assistance in general maintenance and housekeeping. We thank Bruce W.

Ramsay and Robert J. Arms of the Computer

Services Division for their administrative and technical support. The staff of the Statistical Engineering

Laboratory, under Joan R. Rosenblatt, made invaluable contributions and suggestions arising out of

their varied experiences in statistical consulting.

Carla G. Messina merits additional thanks for preparing section 7 for computerized phototypesetting.

Last, but not least, special thanks are given to all the users who made valuable comments and

stimulated modifications and additions to the

system.

5. References

American Standard Fortran (1966). American National Standards

Institute, New York.

CAL-COMP (1968). Flowgen/F— A Fortran Flowchart Generator.

California Computer Products, Inc. Cody, W. J. (1970). Software for the elementary functions. Presented at Mathematical Software Symposium, Purdue

University, April 1-3. Hilsenrath, J., Ziegler, G. G., Messina, C. G., Walsh, P. J., and

Herbold, R. J. (1966). OMNITAB: A Computer Program For

Statistical And Numerical Analysis. Nat. Bur. Stand. (U.S.), Handb. 101, Superintendent of Documents, U.S. Government

Printing Office, Washington, D.C. 20402. Reissued January

1968 with corrections. Hogben, David (1970). Readable printing of single precision numbers. To be submitted to J. Res. Nat. Bur. Stand.

Hogben, David, Peavy, S. T., and Varner, R. N. (1970). OMNITAB

II User's Reference Manual. Nat. Bur. Stand. (U.S.), Tech.

Note 552. Superintendent of Documents, U.S. Government

Printing Office, Washington, D.C. 20402. Murphy, H. M., Jr. (1966). Tidy, a computer code for renumbering

and editing Fortran source programs. Air Force Systems

Command, Kirkland Air Force Base, New Mexico.

Peavy, S. T., Varner, R. N., and Bremer, S. G. (1970). A Systems Programmer's Guide For Implementing OMNITAB II. Nat. Bur. Stand. (U.S.), Tech. Note 550, Superintendent of Documents, U.S. Government Printing Office, Washington,

D.C. 20402. Stegun, Irene A., and Zucker, Ruth (1970). Automatic computing

for special functions. J. Res. Nat. Bur. Stand. (U.S.), 74B

(Math. Sci.), No. 3. 211-225, July-Sept.

Varner, R. N., and Peavy, S. T. (1970). Test Problems And Results For OMNITAB II. Nat. Bur. Stand. (U.S.), Tech. Note

551, Superintendent of Documents, U.S. Government Printing

Office, Washington, D.C. 20402.

4
6. Table of Contents for Subprogram Listings

The following symbols are used to indicate the main function of each subprogram. The number of subprograms in each category is given in parentheses on the extreme right.

E OMNITAB II executive system control subprogram (34)

B Block data executive subprogram ( 4)

F Function routine as defined in 3 (d) (14)

I executes instruction(s) (and performs calculations) (77)

C performs computations for subprogram(s) which execute instruction(s) (48)

Subprogram name Identification Page Subprogram name Identification Page

Main Program OMS E 7 EXCHNG EXC I 77

AARGS AAR E 8

X"*1 a r TTl A TV T T\ EXPAND EXD E 78

ABRIDG ABR I 10

X~i X r TTT» /~i y~v TV T EXPCON EXN I 80

ACCDIG ACC C 11 EXTREM EXT I 82

ADRESS ADR E 11 FCOS FCO F 83

AERR AER E 12 FDCOS FDC F 83

ALLSUB ALL I 14 FDEXP FDE F 83

APRINT APR I 17 FDLOG FDL F 84

ARITH ARI I 20 FDPCON FDP F 84

A X~» X TX T ~m—1 s~^1 ARYVEC ARY I 22 FDSIN FDS F 84

A /TMi r i in x-* ASTER AST E 25x""^X~v n y "v xx m FDSQRT FDQ F 85

BEGIN BEG I 27 FEXP FEX F 85

BEJN BEJ C 28 FEXP2 FX2 F 85

BESSEL BES I 30 FIXFLO FIX I 86

BEZERO BEZ c 36 FLIP FLI I 87

BEZONE BEO c 37 FLOG FLE F 88

BINTJO BIN c 38 FLOG10 FLT F 88

BJORCK BJO c 39 FNEC FNE I 89

BLOCK BLO B 41 FNEIC FNC I 90

CBEI CBI C 42 FNKC FKC I 91

CBEK CBK c 44 FOURIA FOU C 92

CHANGE CHA I 46 FPPT FPP C 93

CHKCOL CHK E 46 FPROB FPR I 94

CKIND CKI E 47 FRDIST FRD I 95

CMPARA CMP C 47 FREQCY FRE C 96

CMSEPA CMS I 48 FSIN FSI F 97

COALES COA I 51 FSQRT FSQ F 97

COMELL COM C 54 FTANH FTA F 97

COMPLX COX I 55 FUNCT FUN I 98

CORREL COR I 57 GENER GEN I 102

Lor UN V CSP c 62 QUA I

i no 103

DBEJ DBE c 64 HDIAG HDI C 104

DEFINE DEF I 66 HEADS HEA C 108

DETRNK DET c 67 HISTGM HIS I 110

DHRND DHR c 68 IFS IFS I 111

DIMENS DIM I 69 INFERR INF E 113

DUMMYA DMA I 70 INPUT INP E 116

DUMMYB DMB I 70 INTERP INT I 117

DUMMYC DMC I 70 INTRP INR C 119

DUMMYD DMD I 70 INVCHK INK C 121

DUMMYE DME I 70 INVCOR INC C 123

DUMMYF DMF I 70 INVERT INV I 125

ERASE ERA I 71 ITERAT ITE I 127

ERRINT ERT c 72 LBCONS LBC B 132

ERROR ERR E 74 LIST LIS I 133

5
6. Table of Contents for Subprogram Listings (continued)

Subprogram name Identification Page Subprogram name Identification Page

T OTATF LOC E 110033 PUNCH PUN I zoo 9^

T

i j OOKTR v7 v / rv 1 1 > LOT B 1 34 iPVTRT V l rvl PVT C zoo 9^6

i a7 v / 1\ u r LOU E R A NKO RKO C ZO9^7i MATRTX lV_L.il. 1 lll/V MAT I 14^ RANKS H.-T1.1 1 l\kj RAS I 9

C18 MDAMAn ivx uriivx rvi_/ MDA I 140 RAX C

MFTCFN MEI I

1 =il 1\V^ o U 1V1 RCS C

IVlio \_*Z MIS I

1lOO^3 RF ADO REQ E __-Ul MTST IVXiO 1 MST C 1 ^6 RFADX REX I 969

1VXI\.XIV_/1

1

MKR I 1±00^8 llllil RFPTNC 11 i Vj

T". T» REP I 964,

MMTIT T

H /fH ITT T MMU I 160 RFSFT RES I 968

MOP MOP I 169 lUL 111 RFORMT \_/lll"l 1 RFO /—

i

c 96Q

MOVF MOV I lfvl 111 RNDOWN li/V/ Vr 1 1 RND E 973

MPROP 1V11 llV-Jl MPR 1 lOO RNTRK 111 1 J XJXY

¥~» ATT RNJ C 973

MRIVL 1 lilATSF 1 OJL_r MRA I 11 73iO RPR 111 IV TNT 11 1 A RPR c 274

MSCROW MSC I ]X lf\ 1 \) SFI FCT SEL I 970

1V1 1YTTRTAN 1 lll-TVl 1 MTR I 11 7ft l o SFT SET I zoz 989

MCK E 1181Ol OHj SFTO1 V_/ STQ E 983

MXTX IVlyV 1 TV MXT I 189 io_ JLi SFTUP 1 Ul STP E ZOt 9841 MXTXP MXP C 1 84 kjJ\0 SKSYMV 1 1V1 V SKS C 98^

NNAMF 1 i 1 X .Tl.lVl.i_j NNA E JV/111/1j SORDFRIX- SOD I LOU 986

NONRT 1 i V/liDl-AA NON E 1loo86 SORTSM OV^ll 1 oivi SOM C 988 zoo NOTFPR NOT I 1loo86 OXSPATF Avj j__ SPA I 980

DANDVA VjAllV/ V -TV OAN C 1 87 OlSPTNV 111 V SPI c 900

OrOFFF OCO C 1 8Q _ZJ STATTS 1 A 1 lj STA I Z9097Z

ornvAR V / V * V 7 V 1 1 \ OCV c 1 Ql OSTMT X ivx X STM E 300

OMCONV V 7 1V1 V ^ V 7 1 > V OMC E 1 Q9 OSTORF X \_/Xl.X_j STO E 301

OMNTT V7J.V11 1 1 1 OMN E 1 Q3 O X V/XV1VX X STT _—

»

C OwZ 309

ONFWAY ONE I 1QQ 1 77 kJSTRUVF X XV U V Xli STR c 303

V 7 .'. V 7 ^ > 17 0P0 C 906 JSYMV X IVX V SYM _—

1

c 303

1 1 1 V7 ORT I ZvyO 908 TAPOP X -TV1 V_/X TAP E (JUT 304

ORTHRV v_7 1 V 1 1111 V ORV C ZZO 99^ TAPOP9 X Al v_7 l Zj TP2 I 30S

ORTPT T ORP c 997 THFRMO X XXI_jX\1VX\_/ THE I 307

\J U 1 I U 1 OUT E zoo 930 X X v>4 X X X TPC c 31 3

PACK PAC E zoi 931 TRx xx_ri.ii ANSFor TRA c 314

PAGF PAG I zoz 939 TWOWAY X W KJ W A X TWO I 316

PDMOTF 1 JL/1V1V-/ 1 Hi PDM I zoo 933 VARCON V _Ti.X\\_>iV_/l 1 VAR E 332

X 11 X \_jV_71 1 PHY I zoo 93^ VFTTOR V J_j\_. X v/ 1

1

VEC E 339

1 1 1 1 JIVj PHC B zoo 936 XFCTITF XEC E 333

PT OT PLO I zoo 938 jvr YFORMT v_/x\ivx x XFO I 341

PRFPAK PRE E 94=1 XHF AD XHE I 341

PRINTX PRI I 248 XOMNIT XOM E 342

PROB PRB C 250 XPND XPN E 344

PROCHK PRK C 252 XSTOP XST E 345

PROROW PRO I 253

6
7. Listing of Subprograms

C THIS IS THE MAIN PROGRAM OF OMNITAB OMS 10

C VERSION 5.00 OMNSYM 5/15/70 OMS 20

C OMS 30

CALL OMNIT OMS 40

STOP OMS 50

END OMS 60

7
SUBROUTINE AARGS

VERSION 5.00 AARGS 5/15/70

COMMON /BLOCKA/ MODE , M, KARD (83 ), KARG , ARG , ARG2 , NEWCD (80 ), KRDEND

COMMON /CONSTS/ PI ,E ,HALFPI ,DEG ,RAD ,XALOG

THIS SUBROUTINE ASSEMBLES A FLOATING POINT NUMBER FROM A STRING

DIGITS ETC. M INITIALLY POINTS AT THE FIRST NUMBER. IT IS LEFT

POINTING AT THE FIRST CHARACTER AFTER THE NUMBER.

VALUE RETURNED IN ARG

KARG = 1 = FLOATING POINT, = 0 = INTEGER, -1 = ERROR.

ARG=KARD (M)

SIGN=1.

JEXP=0

IXS=1

IEXP=0

KARG=0

LOOK BACK FOR MINUS SIGN AND/OR DECIMAL POINT

K=KARD (M-l

)

IF (K.NE.37) GO TO 10

KARG=1

IEXP=-1

K=KARD (M-2

)

IF (K.EQ.38) SIGN=-1.

M=M+1

K=KARD (M)

IF (K.GE.10) GO TO 30

IEXP=IEXP-KARG

ARG=10 . *ARG+FLOAT (K)

GO TO 20

IF (K.NE.37) GO TO 50

DECIMAL POINT FOUND

IF (KARG.EQ.O) GO TO 40

CALL ERROR (3)

KARG=-1

RETURN

KARG-1

GO TO 20

CHECK FOR EXPONENT E X, E+X , E-X , +X , -X

IF (K.NE.14) GO TO 65

M=M+1

K=KARD (M)

IF (K.NE.44) IF (K-10) 70,65,65

M=M+1

K=KARD(M)

IF (K-10) 70,90,90

IF (K.NE.38) IF (K-39) 90,60,90

IXS=-1

GO TO 60

KARG=KARG+1

JEXP=10*JEXP+K

AAR

AAR

AAR

AAR

AAR

OFAAR

AAR

AAR

AAR

10

20

30

40

50

60

70

80

90

AAR 100

AAR 110

AAR 120

AAR 130

AAR 140

AAR 150

AAR 160

AAR 170

AAR 180

AAR 190

AAR 200

AAR 210

AAR 220

AAR 230

AAR 240

AAR 250

AAR 260

AAR 270

AAR 280

AAR 290

AAR 300

AAR 310

AAR 320

AAR 330

AAR 340

AAR 350

AAR 360

AAR 370

AAR 380

AAR 390

AAR 400

AAR 410

AAR 420

AAR 430

AAR 440

AAR 450

AAR 460

AAR 470

AAR 480

AAR 490

AAR 500

AAR 505

AAR 510

AAR 520

AAR 530

AAR 535

AAR 540

AAR 550

AAR 560

AAR 570

8
M=M+1 AAR 580

K=KARD (M) AAR 590

IF (K.LT.10) GO TO 80 AAR 600

c AAR 610

c DONE WITH ARGUMENT AAR 620

c AAR 630

90 IF (KARG.NE .0) GO TO 110 AAR 640

100 ARG=SIGN*ARG AAR 650

RETURN AAR 660

110 KARG=1 AAR 670

IEXP=IXS*JEXP+IEXP AAR 680

C AAR 690

C THE FOLLOWING CODING YIELDS MORE ACCURATE RESULTS THAN THE AAR 700

c OBVIOUS ARG = ARG * 10

.

* IEXP AAR 710

c AAR 720

JEXP=IABS ( IEXP) AAR 730

IF (J EXP . GT . I F I X (XALOG) ) GO TO 140 AAR 740

IF (IEXP) 120,100,130 AAR 750

120 ARG=ARG/FEXP2 (10.0, FLOAT (JEXP)

)

AAR 760

GO TO 100 AAR 770

130 ARG=ARG*FEXP2 (10.0, FLOAT (JEXP)

)

AAR 780

GO TO 100 AAR 790

140 CALL ERROR (102) AAR 800

ARG=0. AAR 810

GO TO 100 AAR 820

END AAR 830

9
SUBROUTINE ABRIDG ABR 10

C VERSION 5.00 ABRIDG 5/15/70 ABR 20

C ABR 30

C THE COMMAND ABRIDGE MAY BE USE IN THE FOLLOWING WAYS ABR 40

C ABRIDGE ROW,, OF COL ++,++, (USE RPRINT UNLESS IOSWT HAS BEEN ABR 50

C SET BY FIXED OR FLOATING) ABR 60

C ABRIDGE // ROW,, OF COL ++,++ (USE SPECIFIED FORMAT) ABR 70

C ABRIDGE WITH FLOATING PT . ARGS USES RPRINT ABR 80

C IOSWT IS NOT RESET ABR 90

C ABR 100

COMMON /BLOCKE/ NAME (4 ), LI , L2 , I SRFLG ABR 110

COMMON /BLOCRC/ NRC ,RC (12600) ABR 120

DIMENSION ARGS(IOO) ABR 130

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 )

) ABR 140

COMMON /FMAT / I FMTX (6 ) , IOSWT , IFMTS (6 )

, LHEAD (96 ) ABR 150

COMMON /HEADER/ NOCARD (80 )

, ITLE (60 , 6 )

, LNCNT , I PRINT , NPAGE , I PUNCH ABR 160

COMMON /BLOCKD / I ARGS ( 100 ), KIND ( 100 )

, ARGTAB ( 100 ), NRMAX , NROW, NCOL , NABR 170

1ARGS , VWXYZ (8 ) ,NERROR ABR 180

COMMON /KFMT / KFMT(IOO) ABR 190

IF (NARGS.NE.O) GO TO 15 ABR 200

10 CALL ERROR (205) ABR 210

RETURN ABR 220

15 IF (L2.EQ.1) IF (IOSWT) 70,70,80 ABR 225

CALL PREPAK (4 , IND ,L2 , IND ,KFMT) ABR 230

IF (IND.NE.O) GO TO 90 ABR 240

IP=1 ABR 250

IF (NARGS.LE.l) GO TO 10 ABR 260

20 LL=IARGS(1) ABR 270

IARGS(1)=1 ABR 280

IF (LL.LE.O.OR.LL.GT.NROW) GO TO 10 ABR 290

CALL CHKCOL (I) ABR 300

IF (I .NE.O) GO TO 10 ABR 310

IF (NERROR.NE.O) RETURN ABR 320

DO 30 I=2,NARGS ABR 330

J=IARGS(I)+LL ABR 340

30 ARGS(I)=RC(J-1) ABR 350

IF (NPAGE. EQ.O) CALL PAGE(O) ABR 355

GO TO (40,50) , IP ABR 360

40 WRITE (IPRINT ,KFMT) (ARGS ( I ), 1=2 , NARGS ) ABR 370

GO TO 60 ABR 380

50 WRITE (IPRINT, IFMTX) (ARGS ( I ), 1=2 , NARGS) ABR 390

60 RETURN ABR 400

70 IF(NPAGE.EQ.O) CALL PAGE(O) ABR 410

CALL RPRINT ABR 420

RETURN ABR 430

C USE SPECIFIED FIXED OR FLOATING FORMAT ABR 470

80 IP=2 ABR 480

GO TO 20 ABR 490

90 CALL ERROR (222) ABR 500

GO TO 70 ABR 510

END ABR 520

10
SUBROUTINE ACCDIG (AX,X,AD,N) ACC 10

C VERSION 5.00 ACCDIG 5/15/70 ACC 20

C RETURNS NUMBER OF ACCURATE DIGITS, AD, IN AX AN APPROXIMATION TO XACC 30

C WRITTEN BY DAVID HOGBEN , SEL , NBS . 10/29/69. ACC 40

DATA ADMAX /8.0/ ACC 50

DIMENSION AX(1) ,X(1) ,AD(1) ACC 60

DO 100 1=1, N ACC 70

DIFF = AX(I)-X(I) ACC 80

IF (DIFF) 20,10,20 ACC 90

10 AD (I ) = ADMAX ACC 100

GO TO 100 ACC 110

20 AD ( I

) = -FL0G10 (ABS (DIFF) ) + FL0G10 (ABS (X ( I ) ) ) ACC 120

AO ( I

) = AMIN1 (ADMAX , AD ( I ) ) ACC 130

AD ( I

) = AMAX1 (-ADMAX ,AD (I )) ACC 140

100 CONTINUE ACC 150

RETURN ACC 160

END ACC 170

SUBROUTINE ADRESS (I, J) ADR 10

C VERSION 5.00 ADRESS 5/15/70 ADR 20

COMMON /BLOCRC/ NRC , RC ( 12600 ) ADR 30

COMMON /BLOCKD / I ARGS ( 100 ) ,KIND ( 100 )

, ARGTAB ( 100 ), NRMAX , NROW, NCOL , NADR 40

1ARGS ,VWXYZ (8) ,NERROR ADR 50

DIMENSION ARGS(IOO) ADR 60

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 ) ) ADR 70

C ADR 80

C CALCULATE ADDRESS OF ARGUMENT ( I ). IF ARGUMENT ( I ) IS A ADR 90

C FLOATING POINT NUMBER, J = -(1+ NRC). IF ILLEGAL COLUMN NUMBERADR 100

C J = 0. IF OK, J = ADDRESS ADR 110

C ADR 120

IF (KIND (I ) .EQ.O) GO TO 10 ADR 130

J=-(I+NRC) ADR 150

GO TO 30 ADR 160

10 IF (IARGS(I) .GE. LAND. IARGS(I) .LE. NCOL) GO TO 20 ADR 170

J=0 ADR 180

GO TO 30 ADR 190

20 J=NR0W*(IARGS(I)-1)+1 ADR 200

30 RETURN ADR 210

END ADR 220

13
cc

cc

cc

c

cc

cc

cc

c

cc10

20

c

c

c30

c

c

c

c

40

50

60

70

80

90

100

110

120

130

SUBROUTINE AERR (I)

VERSION 5.00 AERR 5/15/70

COMMON /BLOCKC/ KIO,INUNIT, I SCR AT , KBDOUT ,KRDKNT , LL I ST

COMMON /BLOCKX/ INDEX (6 ,8) , LEVEL

COMMON /SPRV/ NERCON ,NERR , ISWERR

AER

AER

AER

AER

AER

AER

WHEN ARITHMETIC TROUBLES DEVELOP, THIS ROUTINE TALLIES THEM AND THAER

PRINTS THE RESULTS WHEN THE COMMAND IS DONE. AER

AER

ARIHMETIC MESSAGES MUST HAVE THE FOLLOWING TYPE OF FORMAT: AER

1) THE FIRST TWO CHARACTERS MUST BE ** AER

2) MESSAGE PLUS OTHER INFO MUST NOT BE LONGER THAN 84 CHARACTERSAER

3) IF MESSAGE IS LESS THAN 84 CHAR , ADD NX AT END OF FORMAT AER

AER

IF MORE THAN 10 ARITHMETIC ERROR MESSAGES ARE NEEDED THEN AER

DIMENSION OF MESS (10) MUST BE CHANGED AND KMESS MUST BE SET = AER

TO DIMENSION SIZE OF MESS. AER

ALSO COMPUTED GO TO MUST BE CHANGED. SEE NOTEAER

DIMENSION MESS(IO) AER

DATA KMESS/ 10/ AER

IF (I) 160,30,10

DATA COMING IN

J=MINO ( I, KMESS)

MESS(J)=MESS(J)+1

RETURN

DUMP RESULTS, END OF COMMAND

IF(LLIST.LT.2.0R.LLIST.EQ.4) GO TO 160

DO 150 J=l, KMESS

IF (MESS(J) .EQ.O) GO TO 150

WRITE (ISCRAT,250)

WRITE (ISCRAT,180) MESS(J)

THIS COMPUTED GO TO MUST BE CHANGED IF MORE THAT 10 ARITHMETIC

ERRORS ARE ADDED

GO TO

WRITE

GO TO

WRITE

GO TO

WRITE

GO TO

WRITE

GO TO

WRITE

GO TO

WRITE

GO TO 140

WRITE

GO TO

WRITE

GO TO

WRITE

GO TO 140

WRITE

40,50,60,70,80,90,100

ISCRAT,101)

40

ISCRAT.102)

40

ISCRAT,103)

40

ISCRAT,104) MESS(J)

40

ISCRAT,105) MESS(J)

40

ISCRAT,106) MESS(J)

110,120,130) , J

ISCRAT,107) MESS(J)

140

ISCRAT,108) MESS(J)

140

ISCRAT,109) MESS(J)

10

20

30

40

50

60

70

80

90

100

110

120

130

140

150

160

170

180

190

200

AER 210

AER 220

AER 230

AER 240

AER 250

AER 260

AER 270

AER 280

AER 290

AER 300

AER

AER

AER

AER

AER

310

320

330

340

350

AER 360

AER 370

AER 380

AER 390

AER 400

AER 410

AER 420

AER 430

AER 440

AER 450

AER 460

AER 470

AER 480

AER 490

AER 500

AER 505

AER 510

AER 515

AER

AER

AER

AER

AER

517

520

525

530

535

ISCRAT,240) J AER 540

12
140

150

C

C

C

160

170

C

180

101

102

103

104

105

240

250

106

107

108

109

IF (LEVEL .NE . 0 ) CALL RNDOWN

WRITE (ISCRAT,250)

MESS(J)=0

CONTINUE

IF (LEVEL. NE.O) GO TO 20

ISWERR=0

NERR=0

GO TO 20

INITIALIZATION SECTION

DO 170 J=1,KMESS

MESS(J)=0

ISWERR=0

NERR=0

GO TO 20

16H TIMES, 23X)

FORMAT (42H**

AER 550

AER 560

AER 570

AER 580

AER 590

AER 600

AER 610

AER 620

AER 630

AER 640

AER 650

AER 660

AER 670

AER 680

AER 690

AER 700

AER 710

FORMAT (51H** ARITHMETIC FAULT IN ABOVE COMMAND, ZERO RETURNED , 14 , AER 720

' AER 730

NEGATIVE ARGUMENT TO SQRT, LOG OR RAISE, 42X) AER 740

FORMAT (43H** EVALUATION OF EXPONENT PRODUCES OVERFLOW, 41X) AER 750

FORMAT (45H** ARGUMENT OUT OF BOUNDS TO INVERSE FUNCTION , 39X) AER 760

FORMAT (51H**ARGUMENT TOO LARGE FOR SIN OR COS, ZERO. RETURNED , 14 , AER 770

16H TIMES, 23X) AER 780

FORMAT (61H**BESSEL ARGUMENTS SCALED TO AVOID OVER/UNDER FLOW. RE AER 790

1TURNED,I4,6H TIMES, 13X) AER 800

FORMAT (16H** ERROR MESSAGE , 1 2 , 66X ) AER 810

FORMAT (84X) AER 820

FORMAT (33H** DIVISION BY ZERO, RESULT SET=0,I4,6H TIMES,41X) AER 830

FORMAT (44H** TRIG FUNCTIONS NOT DEFINED, RESULTS SET=0,I4, 6H TIMEAER 840

IS, 30X) AER 850

FORMAT (66H** ONE OF THE VALUES COMPARED IS ZERO, ABSOLUTE TOLERANCAER 860

IE WAS USED, 14, 6H TIMES, 8X) AER 870

FORMAT (71H* X FOR ELLIPTICAL INTEGRALS IS = 1.0 OR GREATER. RESULTAER 880

1 IS SET TO 0.0.,I4,6H TIMES, 3X) AER 890

END AER 900

409-118 OL - 71 - 2

13
SUBROUTINE ALLSUB ALL 10

C VERSION 5.00 ALLSUB 5/15/70 ALL 20

COMMON /BLOCRC/ NRC , RC ( 12600 ) ALL 30

COMMON /BLOCKD / I ARGS ( 100 )

, KIND ( 100 ), ARGTAB ( 100 ), NRMAX , NROW, NCOL , NALL 40

1ARGS , VWXYZ (8) ,NERROR ALL 50

DIMENSION ARGS(IOO) ALL 60

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 ) ) ALL 70

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG ALL 80

COMMON /SCRAT/ NS , NS2 , A ( 13500 ) ALL 90

DIMENSION SCRA(l) ALL 100

EQUIVALENCE (SCRA,A) ALL 110

EQUIVALENCE (L11,LL1), (L22.LL2) ALL 120

C PROGRAMMED BY PHILIP J. WALSH (NBS 453.40) MAY, 1967 ALL 130

C ALL 140

C ALL 150

C COMMAND IS OF THE FORM XXXX OF ORDER ++ OF COL ++, STORE IN ++ ALL 160

C XXXX MAY BE (A) NLSUB FOR NORMALIZED LAGUERRE POLYNOMIALS ALL 170

C (B) LSUB FOR LAGUERRE POLYNOMIALS ALL 180

C (C) HSUB FOR HERMITE POLYNOMIALS ALL 190

C (D) USUB FOR CHEBYSHEV POLYNOMIALS ALL 200

C (E) PSUB FOR LEGENDRE POLYNOMIALS ALL 210

C (F) TSUB FOR CHEBYSHEV POLYNOMIALS ALL 220

C SEE RECURSIVE FORMULAE FOR THESE POLYNOMIALS FURTHER IN CODE ALL 230

C EACH OF THE COMMANDS REQUIRE THREE ARGUMENTS ALL 240

IF (NARGS.EQ.3) GO TO 10 ALL 250

CALL ERROR (10) ALL 260

GO TO 210 ALL 270

10 IF (KIND(1)+KIND(3) .EQ.O) GO TO 30 ALL 280

20 CALL ERROR (3) ALL 290

GO TO 210 ALL 300

C CHECK THAT X IS WITHIN WORKSHEET AND GET ADDRESS OF ARGUMENT COLUMALL 310

30 CALL ADRESS (2,L11) ALL 320

IF (Lll) 20,40,50 ALL 330

40 CALL ERROR (11) ALL 340

GO TO 210 ALL 350

50 IARGS(4)=IARGS(1)+IARGS(3)-1 ALL 360

KIND(4)=0 ALL 370

CALL ADRESS (4.L22) ALL 380

IF (L22.LE.0) GO TO 40 ALL 390

CALL ADRESS (3,L22) ALL 400

IF (NRMAX. NE.O) GO TO 60 ALL 410

CALL ERROR (9) ALL 420

GO TO 210 ALL 430

60 IF (NERROR.NE.O) GO TO 210 ALL 440

I JK=LL1 ALL 450

IJ=LL2 ALL 460

DO 110 1=1, NRMAX ALL 470

SCRA(1)=RC(IJK) ALL 480

GO TO (70,70,80,80,90,90), L2 ALL 490

70 RC(IJ)=1.-SCRA(1) ALL 500

GO TO 100 ALL 510

80 RC (IJ)=2 .*SCRA(1) ALL 520

GO TO 100 ALL 530

90 RC(IJ)=SCRA(1) ALL 540

100 IJK=IJK+1 ALL 550

110 IJ=IJ+1 ALL 560

IF (IARGS(l) .EQ.l) GO TO 210 ALL 570

N=IARGS(1)-1 ALL 580

DO 200 J=l, NRMAX ALL 590

14
c

cc

c

c

c

cc

c120

c

cc

cc

c

c

cc

c

c

c

c

c

c130

c

c

c

c

c

c

c140

c

cc

c

IJK=LL1+J

IJ=LL2+J

SCRA(1)=1 .0

SCRA(2)=RC(IJK-1)

SCRA(3)=RC(IJ-1)

SCRA(4)=1 .0

SCRA(5)=2 .0

DO 190 1=1,

N

IARGS(4)=IARGS(3)+I

CALL AORESS (4,LL22)

GO TO (120,130,140,150,160,170), L2

NORMALIZED LAGUERRE POLYNOMIALS

L(N+1) =(1 .+2 .*N-X)*L(N)-N**2 *L(N-1)

L2 = 1 NLSUB

RECURSION FORMULA

L(0) = 1.

L(l) = -X+l.

L(2) = X**2 - 4.0*X +2.

L(3) =-X**3 + 9 .0*X**2-18 .0*X+6

.

L(N)= EXP(X)* (DN/DXN(X**N*EXP(-X) )

)

SCRA(4)=I

SCRA(6)=1.0+2.0*SCRA(4)

SCRA(7)=SCRA(4)*SCRA(4)

SCRA(8)=(SCRA(6)-SCRA(2) ) *SCRA (3 )-SCRA (7 ) *SCRA (1

)

GO TO 180

L2 = 2 LSUB

RECURSION FORMULA

LAGUERRE POLYNOMIALS

L(N+1)=( ( (2.*N+1)-X)*L(N)-N*L(N-1) )

/

(N+l)

L(0) =

L(l) =

L(2) =

L(3) =

1.

-X+l.

.5 (XX*2

(-X**3 +

- 4.*X +2)

9.*X**2 - 18.* X +6.)/6

ALL 600

ALL 610

ALL 620

ALL 630

ALL 640

ALL 650

ALL 660

ALL 670

ALL 680

ALL 690

ALL 700

ALL 710

ALL 720

ALL 730

ALL 740

ALL 750

ALL 760

ALL 770

ALL 780

ALL 790

ALL 800

ALL 810

ALL 820

ALL 830

ALL 840

ALL 850

ALL 860

ALL 870

ALL 880

ALL 890

ALL 900

ALL 910

SEE

ALL 920

ABRAMOWITZ, M. AND STEGUN, I. A., HANDBOOK OF MATHEMATICAL ALL 930

FUNCTIONS, NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICSALL 940

SERIES 55, SUPERINTENDENT OF DOCUMENTS, U.S. GOVERNMENT

PRINTING OFFICE, WASHINGTON, D.C. 20402

SEE HILSENRATH, ZIEGLER, MESSINA, WALSH, HERBOLD, , OMNI TAB , NBS

HANDBOOK 101 (MARCH 4, 1966) - FOR FORMULAE USED

SCRA(4)=I

SCRA(6)=SCRA(4)+1.0

SCRA(7)=SCRA(4)+SCRA(6)

SCRA(8)=( (SCRA(7)-SCRA(2) ) *SCRA (3 ) -SCRA (4 ) *SCRA ( 1 ) ) /SCRA (6

)

GO TO 180

HERMITE POLYNOMIALS

H(N+1) = 2.0*X*H(N)-2.0*N*H(N-1)

L2 = 3 HSUB

RECURSION FORMULA

H(0) = 1.

H(l) = 2.0*X

H(2) = 4.0*X**2-2.

H(3) = 8.0*X**3-12.*X

SCRA(8)=2.0*(SCRA(2)*SCRA(3)-SCRA(4)*SCRA(1)

)

SCRA(4)=SCRA(4)+1.0

GO TO 180

L2 =4 USUB CHEBYSHEV POLYNOMIALS

RECURSION FORMULA U(N) = 2 . 0*X*U (N-l ) -U (N-2

)

ALL 950

ALL 960

ALL 970

ALL 980

ALL 990

ALL1000

ALL1010

ALL1020

ALL1030

ALL1040

ALL1050

ALL1060

ALL1070

ALL1080

ALL1090

ALL1100

ALL1110

ALL1120

ALL1130

ALL1140

ALL1150

ALL1160

ALL1170

ALL1180

15
C U(0) = 1. ALL1190

C U(l) = 2.0*X ALL1200

C U(2) = 4.0*X**2-1.0 ALL1210

C U(3) = 8.0*X**3-4.0*X ALL1220

C ALL1230

150 SCRA(8)=2 .0*SCRA(2)*SCRA(3)-SCRA(1) AlL1240

GO TO 180 ALL1250

C L2 = 5 PSUB LEGENDRE POLYNOMIALS ALL1260

C ALL1270

C RECUSION FORMULA P(N+1) =X*P(N)+(N/N+1)*(X*P(N)-P (N-l )

) ALL1280

C ALL1290

C P(0) = 1. ALL1300

C P(l) = X. ALL1310

C P(2) = (3./2.)*X**2-(l./2.) ALL1320

C P(3) = 2.5*X**3-1.5*X ALL1330

C ALL1340

160 SCRA(6)=SCRA(4) /SCRA(5) ALL1350

SCRA(8) = (1 .0+SCRA(6) ) *SCRA (2 ) *SCRA (3 ) -SCRA (6 ) *SCRA ( 1 ) ALL1360

SCRA(4)=SCRA(5) ALL1370

SCRA(5)=SCRA(5)+1 .0 ALL1380

GO TO 180 ALL1390

C L2 =6 TSUB CHEBYSHEV POLYNOMIALS ALL1400

C ALL1410

C RECURSION FORMULA ALL1420

C ALL1430

C T(0) = 1. ALL1440

C T(l) = X ALL1450

C T(2) = 2.*X**2-1. ALL1460

C T(3) = 4.*X**3-3.*X ALL1470

170 SCRA(8)=2.0*SCRA(2)*SCRA(3)-SCRA(1) ALL1480

180 CONTINUE ALL1490

LJMN=LL22+J ALL1500

RC(LJMN-1)=SCRA(8) ALL1510

16
SUBROUTINE APRINT APR 10

C VERSION 5.00 APRINT 5/15/70 APR 20

COMMON /BLOCRC/ NRC , RC ( 12600 ) APR 30

COMMON /BLOCKD / I ARGS ( 100 )

, KIND ( 100 ), ARGTAB ( 100 )

, NRMAX , NROW, NCOL , NAPR 40

1ARGS ,VWXYZ (8) ,NERROR APR 50

DIMENSION ARGS(IOO) APR 60

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )) APR 70

COMMON /BLOCKE/ NAME (4 ), LI , L2 , I SRFLG APR 80

COMMON /ABCDEF / L(48) APR 90

COMMON /HEADER/ NOCARD (80 )

, ITLE (60 ,6 )

, LNCNT , IPRINT ,NPAGE , I PUNCH APR 100

COMMON /FMAT/ IFMTX (6 ), IOSWT , I FMTS (6 ), LHEAD ( 96 ) APR 110

COMMON /SCRAT/ NS ,NS2 ,A (13500) APR 120

COMMON /KFMT / KFMT(IOO) APR 130

DIMENSION IFRV(3) APR 140

DATA IFRV(l) , IFRV (2) , IFRV (3 ) /3H1X , ,3HI5, ,3H2X,/ APR 150

C LI = 4 APRINT APR 160

C LI = 7 MPRINT APR 170

C MPRINT PRINTS ROW/COL TITLE, APRINT DOES NOT. APR 180

C ALL READABLE IF POSSIBLE, OTHERWISE ALL FLOATING. APR 190

C WRITTTEN BY DAVID HOGBEN, SEL, NBS . 8/18/69. APR 200

C ***** APR 210

C 6 FORMAT STATEMENTS FOLLOW WHICH MAY NEED MODIFY IF CHANGES MADE APR 220

C ***** APR 230

IF (NARGS.EQ.4) GO TO 30 APR 240

10 CALL ERROR (205) APR 250

20 RETURN APR 260

30 J=l APR 270

1=4 APR 280

CALL CKIND (I) APR 290

IF (I .NE.O) GO TO 10 APR 300

K=IARGS(1) APR 310

CALL MTXCHK (J) APR 320

IF (J. NE.O) GO TO 10 APR 330

IF (NERROR.NE.O) RETURN APR 340

C CHECK TO SEE IF NPAGE=0 . IF YES, BEGIN A NEW PAGE. CALL PAGE(O) APR 342

IF (NPAGE.EQ.O) CALL PAGE(O) APR 344

C IF L2=l IOSWT=0 USE READABLE FORMAT APR 350

IF (L2.EQ. LAND. IOSWT. EQ.O) GO TO 190 APR 360

C IF L2=l I0SWT=1 USE FIXED OR FLOATING APR 370

IF (L2.EQ. LAND. IOSWT. EQ.l) GO TO 60 APR 380

C IF (L2.NE.1) USE SPECIFIED FORMAT APR 390

C FORMAT SHOULD SPECIFY FORMAT FOR ONLY ONE ROW APR 400

CALL PREPAK (4 , IND , L2 , IND , KFMT ) APR 410

IF (IND. NE.O) GO TO 50 APR 420

IA=IARGS(3) APR 440

J1=IARGS(1) APR 450

J2=J1+(IARGS(4)-1)*NR0W APR 460

DO 40 I=1,IA APR 470

WRITE (IPRINT, KFMT) (RC (J )

, J=J1 , J2 ,NROW) APR 480

J 1=J 1+1 APR 490

J2=J2+1 APR 500

40 CONTINUE APR 510

RETURN APR 520

C NO FORMAT IS FOUND SO USE READABLE FORMAT APR 530

50 CALL ERROR (222) APR 540

GO TO 190 APR 550

C FIXED OR FLOATING FORMAT USED APR 560

60 DO 70 1=1,100 APR 570

70 KFMT(I)=L(45) APR 590

17
lr (Ll.ty./) bU IU vo ADD irtrt APK 600

nn on T i l UU oU 1=1 , o ADD L 1

n

ArK 010

80 1/ C HAT / T \ T C MT V / T \ KrMI ( 1 )=irMI A ( 1

)

ADD L 1

n

ArK 620

bU 1 U 111) ADD L

1

n ArK 030

a n C MT / 1 \ I C MT Y / 1 \ KrMI ( 1 )=1 rml a ( 1

)

ADD L A A ArK 040

KrMI (£. )=lr KV ( i

)

ADD L C n ArK ODD

V C MT I W ICDW (1\ l\r M I (3 ) =1 r It V (c ) ADD L

L

n ArK ooU

V C MT t A \ I CDW ( I

\

KrMI (4 ) =1 r K V ( 3 ; ADD L 7 n ArK 670

nn inn T

o a UU 1UU l = c , 0 ArK ADD L Q n 080

inn 100 VNrMI C MT ( T i 3 \ TC MT Y / T \

( 1 +3 ) = 1 r M 1 A ( 1 ) ADD L o n ArK 070

1 iU V A T A DT C / 1 \ l\A=lAKbo (1 ) add 7 n n ArK 700

II T A DP C / 1

\

l_L=l AKbo ( 3 ) ADD 7 1 rt ArK / 10

TDD TADTC/JIN 1 DD=1 AKbb (4 ) ADD 7 9 A APK 7Z0

T DDD Q

1 DDr=8 ADD 7 1 A ArK 730

TC /I l Cn 7\ TRDD 7 lr (.Li.ty./) 1 Bur= / ADD 7 A A ArK / 4U

T1A 1 ADPC (1 \ l lA=l AKbb ( Z ) inn » c A AHK 750

1 O A 1Z0 TC /TDD r*T TDDD\ rfl TO Tin lr (iDD.bl . I dor ) bU IU 130 ADD ArK 760

T D T DO 1 D=l DD ADD 7 7 A ArK 770

TDD n 1 DD=U ADD 7 0

A

ArK /oO

r n Tn i a n bU 1 U 14U ADD 7 Q A ArK /VO

130 TDD TDD TDDD 1 DD=1 DD— 1 OOP ADD AAA APK 800

T

1 D T DDD D=l DDK ADD O 1 A ArK 810

'\ An 140 k D I IB 1 \ * MDftUI . V A l\D= ( ID — 1 ) NKUW+lsA ADD O 1

A

ArK 8Z0

j/OD I/O . KIDDU1 l\Dr=l\B+IMKU n ADD 0 1 A ArK 830

T 9 A — T lA ,!R l 1 & A= 1 ift + lD-1 ArK ADD 840 Q A A IF (L1.EQ.4) GO TO 150 APR 850

WRITE (IPRINT,280) L (28 ) , L (25 )

, L (33 ), L (37 )

, L ( 13 ), L (25 ), L (22 ) , ( J J , JAPR 860

1 J=l 1A , 1 2A

)

APK 870

MK v=K. ADD AAA ArK 880

1 DU r\ A ion if i II UU 180 M=l , LL A H D AAA APR 890

tclr i\

l L

i1 . cnty . a\ rn Tn un

4

) bU IU loo A DD OA

A

ArK 900

WRITE ( I PR I NT ,KFMT) MRV , (RC(K) ,K=KA , KB , NR0W) APR 910

MRV=MRV+1 APR 920

GO TO 170 APR 930

i ou WRITE (IPRINT ,KFMT) (RC(K) , K=KA , KB , NR0W) APR 940

1/0 KA=KA+1 APR 950

KB=KB+1 APR 960

ion 180 CONTINUE APR 970

IF (IBB.EQ.0) RETURN APR 980

WRITE (IPRINT, 330) APR 990

C PRINT NEXT SET OF COLUMNS APR1000

KA=KBP APR1010

I1A=I2A+1 APR1020

GO TO 120 APR1030

c THE NEXT CARD MUST BE CHANGED IF WIDTH OF COLUMN CHANGED APR1040

c THE CARD AFTER IT MUST BE CHANGED IF NUMBER OF COLUMNS CHANGES APR1050

c 2 CALLS TO RF0RMT LATER NEED TO BE CHANGED IF NO. OF SD NOT 8. APR1060

c NWMX IS DETERMINED BY 120/8-2 WHERE 120 IS THE NUMBER OF APR1070

c CHARACTERS PER PRINTED LINE APR1080

1 OA 190 NWMX=13 APR1100

MC0L=8-Ll/7 APR1110

NSTART=IARGS (1) APR1120

KSTART=K-1 APR1130

KR=IARGS(3) APR1140

KC=IARGS(4) APR1150

Kl=l APR1160

K2=NSTART APR1170

DO 210 I=1,KC APR1180

DO 200 J=1,KR APR1190

18
240

C

250

GO TO 240

i AND NWIDTH GT NWMAX

A(K1)=RC(K2)

K1=K1+1

200 K2=K2+1

210 K2=K2+NROW-KR

KSIZE=KR*KC

CALL RFORMT (A (1 ) ,KSIZE , 8 , NWIDTH ,NDECS , NWMX+1 ,A(1) ,A(1) ,0,0)

C MINIMUM OF TWO BLANK SPACES ON LEFT

NBLANK=NWMX+2 -NWIDTH

11=1

I1A=IARGS(2)

K1=NSTART-1

C LOOP ON BLOCKS

220 I2=I1+MC0L-1

I2=MIN0(I2,KC)

I2A=IARGS(2)+I2-1

K2=K1+(I2-I1)*NR0W

K4=K2

IF (L1.EQ.4) GO TO 230

WRITE (I PR I NT, 280) L (28 )

, L (25 ), L (33 ), L (37 ), L ( 13 ), L ( 25 ), L ( 22 ) , ( J

J

1J=I1A,I2A)

C LOOP ON ROWS

230 DO 270 JJ=1,KR

K1=K1+1

K2=K2+1

JJJ=KSTART+JJ

IF (NWIDTH . LE .NWMX .OR .LI .NE .7

)

C WRITE FLOATING IF MPRINT (Ll=7;

WRITE (IPRINT,300) J J J , (RC (K3 ), K3=K1 , K2 , NROW)

GO TO 270

LL=1

K=K1

LOOP ON COLUMNS

DO 250 11=11,12

CALL RFORMT (A , 1 , 8 , NWIDTH , NDECS , 0 , RC (K) , A (LL ), NBLANK , 0

)

K=K+NROW

LL=LL+NWMX+2

NL=LL-1

IF (L1.EQ.7) GO TO 260

WRITE (IPRINT,310) (A (LL ), LL=2 , NL

)

GO TO 270

260 WRITE (IPRINT,290) J J J , (A (LL ), LL=2 ,NL

)

270 CONTINUE

K1=K4+NR0W

I1=I1+MC0L

I1A=I1A+MC0L

IF (I2.GE.KC) GO TO 20

C LOOP ON BLOCKS

C PUT IN BLANK LINE BETWEEN BLOCKS

WRITE (IPRINT,320)

GO TO 220

C

280 FORMAT (IX , 7A1 , 7 (6X , 1 5 ,4X )

)

290 FORMAT (IX , 1 5 , 2X , 112A1

)

300 FORMAT (IX , 15 , 2X , 1P7E15 . 6

)

310 FORMAT (1X.119A1)

320 FORMAT (1H ) 330 FORMAT (IX)

END

APR1200

APR1210

APR1220

APR1230

APR1240

APR1250

APR1260

APR1270

APR1280

APR1290

APR1300

APR1310

APR1320

APR1330

APR1340

APR1350

APR1360

APR1370

,JAPR1380

APR1390

APR1400

APR1410

APR1420

APR1430

APR1440

APR1450

APR1460

APR1470

APR1480

APR1490

APR1500

APR1510

APR1520

APR1530

APR1540

APR1550

APR1560

APR1570

APR1580

APR1590

APR1600

APR1610

APR1620

APR1630

APR1640

APR1650

APR1660

APR1670

APR1680

APR1690

APR1700

APR1710

APR1720

APR1730

APR1740

APR1750

APR1760

APR1770

19
10

20

30

40

50

60

70

80

90

SUBROUTINE ARITH ARI

VERSION 5.00 ARITH 5/15/70 ARI

COMMON /BLOCRC/ NRC , RC ( 12600 ) ARI

COMMON /BLOCKD / IARGS(IOO) , KIND (100) , ARGTAB (100 )

, NRMAX ,NROW,NCOL ,NARI

1ARGS , VWXYZ (8 ) ,NERROR ARI

DIMENSION ARGS(IOO) ARI

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 )) ARI

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG ARI

DIMENSION 11(5) ,KK(5) ARI

EQUIVALENCE (11(1) ,11) , (11(2) ,12) , (II (3) ,13) , ARI 100

1 (II (4) ,14) , (II (5) ,15) ARI 105

ARI 110

THIS SUBROUTINE PERFORMS ADD , SUB , MULT , DIV AND RAISE FOR ARI 120

THREE, FOUR AND FIVE ARGUMENTS ARI 130

L2=l ADD ARI 140

L2=2 SUBTRACT ARI 150

L2=3 MULTIPLY ARI 160

L2=4 DIVIDE ARI 170

L2=5 RAISE ARI 180

L2=6 ACCURATE DIGITS ARI 190

ARI 200

I F (NARGS . LT . 3 .OR . NARGS .GT . 5 ) CALL ERROR(IO) ARI 210

IF (NARGS. EQ.4)CALL ERROR (29) ARI 215

IF (KIND (NARGS) .NE .0) CALL ERROR (20) ARI 220

IF (L2.NE.6) GO TO 5 ARI 222

IF (NARGS. EQ. 3) GO TO 5 ARI 224

CALL ERROR (212) ARI 226

NARGS=3 ARI 228

DO 30 1=1, NARGS ARI 230

KK(I)=1 ARI 240

CALL ADRESS (I , II (I )

) ARI 250

I F ( 1 1 ( I ) ) 20,10,30 ARI 260

CALL ERROR(ll) ARI 270

RETURN ARI 280

KK(I)=0 ARI 290

1 1( I )=-1 1(1) ARI 300

CONTINUE ARI 310

IF (NRMAX . LE . 0 ) CALL ERROR (9 ) ARI 320

IF (NERROR .NE . 0) RETURN ARI 330

J J=I I (NARGS ) +NRMAX-1 ARI 380

I F (NARGS .NE . 3 ) GO TO 120 ARI 390

DO 110 1=13, JJ ARI 400

GO TO (50,60,70,80,90,95) ,L2 ARI 410

RC(I)=RC(I1)+RC(I2) ARI 420

GO TO 100 ARI 430

RC ( I )=RC ( 12 )-RC (II) ARI 440

GO TO 100 ARI 450

RC ( I )=RC(I1)*RC(I2) ARI 460

GO TO 100 ARI 470

IF (RC (12) .NE.O.O) GO TO 85 ARI 480

RC(I)=0.0 ARI 490

CALL ERROR (106) ARI 500

GO TO 100 ARI 510

RC ( I )=RC (II) /RC (12) ARI 520

GO TO 100 ARI 530

RC ( I )=FEXP2 (RC ( 1 1 ), RC ( 12 ) ) ARI 540

GO TO 100 ARI 545

CALL ACCDIG (RC ( 1 1 ), RC (12) ,RC ( I ) , 1 ) ARI 547

1 1=1 1+KK ( 1 ) ARI 550

20
ARI 560

110 I2=I2+KK(2) ARI 570

RETURN ARI 580

120 IF (NARGS .EQ . 5 ) GO TO 130 ARI 590

15=14 ARI 600

KK(5)=KK(4) ARI 610

130 DO 200 1=15, JJ ARI 620

GOTO (140,150,160,170,180) ,L2 ARI 630

140 X=RC(I1)+RC(I2) ARI 640

GO TO 190 ARI 650

150 X=RC(12)-RC(ID ARI 660

GO TO 190 ARI 670

160 X=RC(I1)*RC(I2) ARI 680

GO TO 190 ARI 690

170 IF(RC(I2) .NE.O.O) GO TO 175 ARI 700

X=0.0 ARI 710

CALL ERROR (106) ARI 720

GO TO 190 ARI 730

175 X=RC(I1) /RC(I2) ARI 740

GO TO 190 ARI 750

180 X=FEXP2(RC(I1) ,RC(I2) ) ARI 760

190 RC(I)=X*RC(I3)+RC(I4) ARI 765

I1=I1+KK(1) ARI 770

I2=I2+KK(2) ARI 775

I3=I3+KK(3) ARI 780

I4=I4+KK(4) ARI 785

200 CONTINUE ARI 790

RETURN ARI 800

END

21
SUBROUTINE ARYVEC ARY 10

C VERSION 5.00 ARYVEC 5/15/70 ARY 20

C SUBROUTINE ARYVEC R.VARNER 9/27/67 ARY 30

C * ARY 40

C SUBROUTINE TO MULTIPLY MATRIX TIME VECTOR ARY 50

C OR VECTOR TRANSPOSE TIME MATRIX ARY 60

C L2=l MULTIPLY MATRIX TIME VECTOR ARY 70

C GENERAL FORM OF COMMAND ARY 80

C M(AV) A (,) N,K VECTOR IN COL I STORE IN COLUMN J ARY 90

C M(AV) A (,) N,K VECTOR IN COL I STORE IN ROW K COL J ARY 100

C N AND K MUST BE SPECIFIED ARY 110

C L2=2 MULTIPLY VECTOR TRANSPOSE TIMES MATRIX ARY 120

C GENERAL FORM OF COMMAND ARY 130

C M(V/A) A (,) N,K VECTOR IN COL I STORE IN ROW J ARY 140

C M(V/A) A (,) N,K VECTOR IN COL I STORE IN ROW K COL J ARY 150

C N AND K MUST BE SPECIFIED ARY 160

C IF ONLY ROW IS GIVEN FOR STORAGE COL 1 IS ASSUMED ARY 170

C * ARY 180

COMMON /BLOCRC/ NRC , RC ( 12600 ) ARY 200

COMMON /BLOCKD / I ARGS ( 100 ), KIND ( 100 )

, ARGTAB ( 100 )

, NRMAX , NROW, NCOL , NARY 210

1ARGS , VWXYZ (8 ) ,NERROR ARY 220

DIMENSION ARGS(IOO) ARY 230

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )

) ARY 240

COMMON /SCRAT/ NS ,NS2 ,A (13500 ) ARY 250

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG ARY 260

DIMENSION X(l) ARY 270

DOUBLE PRECISION X ( SUM ARY 280

EQUIVALENCE (X,A) ARY 290

C * ARY 310

C CHECK FOR CORRECT NUMBER OF ARGUMENTS ARY 320

C * ARY 330

IF (NARGS . NE . 6 . AND . NARGS . NE . 7 ) CALL ERROR (10) ARY 340

C * ARY 350

C CHECK TO SEE IF ALL ARGUMENTS ARE INTEGERS ARY 360

C * ARY 370

J=NARGS ARY 380

CALL CKIND (J) ARY 390

IF (J.NE.O) CALL ERROR (3) ARY 400

C * ARY 410

C CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE ARY 420

C * ARY 430

GO TO (10,20) , L2 ARY 440

10 IADD=IARGS(4) ARY 450

IADD2=IARGS(3) ARY 460

ICOMP=NROW ARY 470

GO TO 30 ARY 480

20 IADD=IARGS(3) ARY 490

I ADD2=I ADD ARY 500

ICOMP=NCOL ARY 510

IF (NARGS. NE. 6) GO TO 30 ARY 520

IF (IARGS(6) .GT. NROW. OR. IARGS(4) .GT. NCOL) CALL ERROR (17) ARY 530

C * ARY 540

C COMPUTE ADDRESSES OF COLUMNS ARY 550

C * ARY 560

30 IARGS(10)=IARGS(NARGS) ARY 570

IARGS(8)=1 ARY 580

GO TO (70,40) , L2 ARY 590

40 IF (NARGS. EQ. 7) GO TO 50 ARY 600

J=2 ARY 610

22
T r»

A IIICWT lore / z \ IR0W5V=IARGb (6)

anw /oa AKY 620

AATA Z.A GU IU 60 AKY 030

50

t adpc / n\ TADPC/>1\ IAKb:>(l<i) = lAKbb(4)ADVLAA AKY o40

T ADPC / 1 1 \ 1 1 AKGb ( 1 1 )=1

ADV itn AKY 000 I ARGS (9 )=IARGb (6 ) A D \J Z Z A ARY 660 1 1 J=3 A D V L 7 A AK Y 0/0

60 IARGS (7 )=IARGb (3 )

inw / A

A ARY 680

ATA Art GO TO 90 an

v / aa ARY 690 7 a 7 0 J =3 ad v 7 n n

AK I /uu

TA DPC / 1 7 \ 1 1 AKlao ( 1 c ) =1

ADV 71n Alt I / 1 U

TADPC/11\ 1 ADTC /l

\ 1 AKGb (ll)=lAKGb (3 ) A DV 7 0 (1 AKY / tCO TAOPC/7X T ADPC / X \ lAKGb(7)=lAKGb(4) A DV 7 "3 A AKY / 30

TC iklADTC cn z \ on Tfl qa lr (NAKtoo . t(J . O ) GU IU oU

A

D

V Tin Ai\ I / IU

TADOC/AX TAD/*C / i\ lAKGb (9)=lAKGb(6) ft

n

V 7 CA AKY 750

rn

TA

q

n GU IU VU AKY A DV 7 AA / OU 0 A 1 AKGb (9 )=1 A D V 7 7 A AKY / / U A A 90 IARGS (6)=IARGS (5) A D V 7 O A AKY 780 T A DP C / C \ 1 1 AKGb (5 )=1 A D V 7 A A AKY 790 p A 1 1 AIT V P U 1/ / 1 \ LALL Ml ALrlN ( J ) A D V O A A AKY 800

TC /I 1 \ lOATAA 1 1 A lr (J-l) 120,100,110

ADV 01

n AKY 810 1 A A 100 PAI 1 rnnnn /o\ LALL LKKUR (3) A D V O A A AKY 820 D CT1 1 D M Kb ! URN ft D V flirt AKY 830

110 LALL tKRUK (17)

ft

DVOAA AKY 840

DCTIIDM Kt 1 UKN ft

nW OCA AKY 850

pADV QftA AKY 000

pL purpi/ CAD DDCV/TAIIC CDDADC LrltLK rUK KKtvlUUb tKRUKb

ADVO 7 A AKY 870

pL * A

DVOOA AKY 880 1 7 A 12U TC /MCDDOD KIC A\ DCTIIDM lr ( NtKKUK . IMt . 0 ) Kt 1 UKN A D V Q A A AKY 890

PA TA

n l/i "i

an\ lo GU 1 U ( 130 , 140 ) , L2

ADV ft ftA AKY 900 1 i u T P C T ADrC / O \

lLo=lAKbo (7 ) A

DV ft l ft AKY 910

TADTA DPC / 1 N 1 Ar=iAKbo ( 1 ) A

DV flirt AKY 9^0

TDTA DPC 1 1 \ lr=lAKlao (3 ) A

OVA 1 A AKY 930

IDTA DPC / il\ Jr=l AKGb (4 )

ADV ftA ft ARY 940

TAniMDA Uf 1AU1=NKUW ftDVACA ARY 950

Tan 0 1 1 AU £=i

ADVQLA AKY VoO

TDD TADPC/E\ 1 br=l AKGb ( 5 )

ft

D

w

A 7 A AKY 970

pn ta i 7 a GU 1 U 170

ADVAOA AKY 980

14U TDD TADPC/1

\ lDr=lAKGb ( 1 )

ft

DV AAA AKY 990

TAD TADPC/C\ 1 Ar=l AKGb ( 5 ) A

D

V 1 AAA AKY 1000

TDT ADPC 1 A\ 1 r=l AKiao ( 4 ) A

DV 1 A 1 A AKY1010

TC / MA DPC CA 7\ PA TA 1CA lr ( IMAKlaO . tU. . / ) GU IU lbU

ADV 1 AAA AKY 1020

in

TA DPC / O.\ Jr=lAKGb (3 ) « n

W 1 ft

O ft AKY1030

TPCTDA UiCW ILb=lKUWbV AO\/i

aA ft AKY1040

PATA lift GU IU 160A DV 1 AC

A

AKY 1050

TEA 150 Jr=lAKGb ID T A DP C / a

\ (3 )

ADVlALA AKY 1060

TPC TADPC/AX ILb=lAKGb (9 )

AQUl ft "T ft ARY1070 1 Z. A 160 1AU1=1 A QUI ft ft ft ARY1080 T A n A Al D A Uf 1 AU2=NKUW A D V 1 AAA ARY 1090 1 7 A 170 TP 1 1L=1 A O \J 1 1 ft ft ARY1100

AA 11nT 1 TD UU 210 1=1 , lrADV 1 1 1 A AKY1110

TA TAD 1 A=l Ar

ADV 1 1 AA AKY1120

TD TDD 1 D= 1 br

ADV 1 1 1 A AKY1130

TC IIC1 l b=Nb2

An \f I 1 in ARY1140

nA l OA I l ID UU 1B0 J=l , J rADV 1 1 CA AKY 1 150

V/TC\ D/^ / TA\ ADA / TD\

X ( IS )=RC { I A) *RC ( IB)

AOV 1 1 / A ARY1160

TCTC ^ I b=l b-l ft

DV 1 1 7 A ARY1170

TA TA.TAAl lA=lA+lADl

AD V/ 1 1 AA ARY1180 i on TO T D i 1 I B= i D + l A D V 1 1 OA AKY 11VU

CALL S0RTSM (JP,SUM) ARY1200

23
A / T P \ C 1 1 M A ( lb )=bUM A D V 1 1 l f\ AKY 12 10

TP TP , 1 lb=lb+l AK Y 1 2 20

PA TP /inn OAA \ 1

0

bU IU (190, 2UU), L2 AKY 1 230

190 TAD T A D . 1 1 AH=lAr' + l AKY 1240

PA T A oin bl) ID 210 AKY 1 2 50

1 A A 200 TDD TDD.MDAUJ lDr=lbr+NKUW ADVl 1 L A AKY1260

O 1 A 210 P A M T T M 1 1

C

bUN 1 1 NUt ADVl O "7 A AKY1270

pb ADVl O O A AKY 1280

pb o 1 UKt KtbULIO IN WUKISonttl ADVl OOP AKY 12VU

pb

* AKY 1 3UU

T C 1 1 b = l ADVl Q 1 A AKY1310

HA OOP T 1 TD UU C£.\J 1 =1 , lr ADVl 7 O A AK Y 1 3 e. U Dp / IPC 1 A/TC\ Kb ( 1 Lb ) =A ( 1 o

)

ADVl "3 O A AKY133U

T C T C , 1 1 0=1 O+l ADVl "5 A A AKY 1340

TPC Ibb=lbb+1AU2 IPC , nni ADVl "J C A AKY13bU

o o a £20 bUN 1 1 NUt ADVl 1

L

A AKY 1360

nr ti mil RETURN ARY1370

END ARY1380

24
SUBROUTINE ASTER AST 10

C VERSION 5.00 ASTER 5/15/70 AST 20

COMMON /BLOCKA/ MODE , M, KARD (83 )

, KARG , ARG , ARG2 , NEWCD (80 )

, KRDEND AST 30

DIMENSION NAM(2) AST 40

C AST 50

C ASTERISKS HAVE BEEN FOUND, LOOK FOR A SPECIAL FORM OF ARGUMENT. AST 60

C AST 70

C FORMS CAN BE. . AST 80

C AST 90

C *PHYSCON* A PHYSICAL CONSTANT NAME, FL.PT. AST 100

C **VARCON** A -VARIABLE- CONSTANT TO BE USED AS AN INTEGER (TRUN ) AST 110

C *VARCON* A -VARIABLE- CONSTANT TO BE USED AS A FL.PT. NUMBER AST 120

C **ROW, COLUMN** A WORKSHEET ENTRY TO BE TRUNCATED AND USED AS INTAST 130

C *ROW, COLUMN* A WORKSHEET ENTRY TO BE USED AS FLOATING POINT AST 140

C AST 150

C NONBLA IS A FUNCTION WHICH RETURNS THE NEXT NON-BLANK CHARACTER AST 160

C IN THE CARD AND ALSO POINTS M AT IT AST 170

C AST 180

C KARG = 1, SINGLE *. KARG = 0, DOUBLE *. AST 190

C AST 200

L=KARG AST 210

K=NONBLA(M) AST 220

IF (K.NE.40) GO TO 20 AST 230

C AST 240

C A LONG LINE OF ASTERISKS FOUND, SKIP OVER THEM AND IGNORE AST 250

C AST 260

KARG=7 AST 270

10 M=M+1 AST 280

IF (KARD(M)-40) 100,10,100 AST 290

20 IF (K.GE.36) GO TO 60 AST 300

IF (K.GE.10) GO TO 40 AST 310

C AST 320

C NUMBER IS FIRST NON-BLANK CHARACTER, SET N = COMMA AST 330

C AST 340

N=43 AST 350

30 CALL AARGS AST 360

IF (KARG.NE.O) GO TO 60 AST 370

IF (NONBLA (M) .EQ .N) IF (N-40) 35,37,35 AST 375

GO TO 60 AST 380

35 IF (NONBLA (M+l ) .GE. 10) GO TO 60 AST 390

C AST 400

C SET N = ASTERISK AST 410

C AST 420

N=40 AST 430

T=ARG AST 440

GO TO 30 AST 450

37 ARG2=ARG AST 460

ARG=T AST 470

KARG=5 AST 480

GO TO 90 AST 490

C AST 500

C LETTER FOUND FIRST AST 510

C AST 520

40 CALL NNAME (NAM(l) ) AST 530

CALL PHYCON (NAM(l) ) AST 540

IF (ARG.EQ.O.) GO TO 50 AST 550

C AST 560

C PHYSICAL CONSTANT FOUND, SET KARG = 1 AST 570

C AST 580

25
KAKb=l ACT Ab 1 370

ir / 1 \ A A A A OA

1 r (L ) 60,60,80 ACT Ab 1 L A A 600

c ACT Ab 1 / 1 A 610

c

Al A MC Mf»T TM D U V C T r

- A 1 rflMCTAMT 1 ICT TDV WADI ADI C NAMt NU 1 IN rniblLAL LUIMblANI Llbl , IKY V AK 1 ADLt 1 T CT Llol ACT Ab 1 A 1 A 6 a0

c ACT fli 1 A 1 A 630

50 AAII \/ADPAM /MAM/1 \\ LALL VAKLUN (NAM(l)) ACT Ab 1 L A A 640

rr /AD/* Al C A \ r* A Trt 7A lr (AKb.Nt.0.) bU IU 70 ACT Ab 1 A C A 630

l n 60 KAKb=l ACT Ab 1 AAA 660

DCTI IDM Kt 1 UKN ACT Ab 1 A 7 A 6 / U

7 A 70 If" A DP 1 ACT Ab 1 A Q A 6oU

80 tr fiintiQI > >U) M C Af\\ Ct\ TA Art lr (IMUIMdLA(M) . IMt . 4U ) bU IU 60 ACT Ab 1 AAA 6 V0

A A vo M=M+1 ACT Ab 1 7 A A 700

t ACT Ab 1 7 1 A 710

L PUCPV TUAT TUC Ml 1MB CD AC ACTTD1CI/C AT TUC run AC L-ntL-K 1 HA 1 IHt NUNlbtK Ur AbltKlbKb Al 1 hit tNU Ur TUC 1 CVDDCCCTAM nt tArKtbblUN ACT Ab 1 7 1 A 7 ^0

TC TUC CAMf AC AT TUC DCTTKIMTKir 1 (\ MCAMC t 1 10 1 nil b AMt A j Al Int. Dtb 1 NN 1 Nb . L =U Nit AN b L, L= 1 MtANb 1 AbACT1 75(1

L ACT Ab 1 7 il A 740

TC / 1 M C A\ TC /l/ADh rkl\ >IA\ QC A A OC lr (L.Nt.0) lr (KAKU (M) -40 ) 73,60,73 ACT Ab 1 7 /! C 743

TC / 1/ A D n / M \ MC /in AD V ADD / U i I \ cn /in \ rn jn /a

1 r (IsAKU (Wl) .Nt.4U.UK.KAKU (M+l ) . tU. . 41) ) bU 1 U 60 ACT Ab 1 7 C A/ 30

7 3 NI=IVI+1 ACT Ab 1 7 A A / 6U

KAKb=l\AKb+L ACT Ab 1 7 7 A / / 0

1 A A 100 DrTIIDII RETURN ACT AST 780

END AST 800

26
SI IRRnilT T NF RFGTN BEG U L \J 10

VPRCinN R on RFGTN R/15/70 BEG 20

COMMON /RIOPKA/ MODE M KARD(8H KARG ARG ARG2 NEWCD(80) KRDEND BEG 30

PL» 0U MMO IflmU IfN // RDLUvlXL 1 0 P K F // NIf AH MPIfIL (\f4 ^

) , 11L 1 , 1Lt? , TSRFLG 1JI\I Lu BEG 40

POMMflN L< \J IfllVIU If //RlflPKR/ DLvwIND / NSTMT 11 J 1 llll NSTMTX J 1 III 1 A NSTMTH J Mil 1 II ( NCOM lluvl*l ( LCOM vvlll / I0VFL i v * 1 I— , C0M(2000} O v III ^ t U U U J BEG 50

COMMON /BLOCRC/ NRC , RC ( 12600

)

BEG 60

COMMON /BL0CKD / IARGS(IOO) ,KIND(100) ,ARGTAB (100 )

, NRMAX , NR0W , NC0L , NBEG 70

1ARGS VWXYZ(8) NERR0R BEG 80

DIMENSION U 1 lilLIU 1 vll ARGS(IOO) ni\\J J \ A. \J \J i BEG 90

EQUIVALENCE (ARGS(l) RC(12501U BEG 100

c BEG 110 XIV

r THIS SUBROUTINE CONTAINS THE CODING FOR BEGIN AND SCAN BEG 120 JL (L. U r\j BEG 140

IF (L2 EQ 1) GO TO 20 BEG 150

r BEG 160

rV/ SCAN (CARD UP TO AND INCLUDING CARD COLUMN ++ ) BEG 170

IF (NARGS.GT.l) CALL ERROR (221) BEG X o w IF (NARGS .GE . 1 .AND . KIND (1 ) . EQ . 0 . AND . I ARGS ( 1 ) .GE . 6 . AND . IARGS (1

)

LE .BEG 190

180) GO TO 10 BEG 200 L V V K=205 BEG 210

GO TO 30 BEG 220

1 u KRDEND=IARGS (1) BEG ? 30

GO TO 40 BEG 240

c BEG 250

c BEGIN STORING INSTRUCTIONS AT NUMBER ++ BEG 260

r IF NO NUMBER IS GIVEN 1 IS ASSUMED BEG 270 x. I W rw BEG &= "J> V ?o IF (MODE . EQ . 1 ) GO TO 50 BEG 790 b 7 v K=5 BEG 100

CALL ERROR (K) BEG 310

40 RETURN BEG 320

R0 IF (NARGS-1) 70 90 60 BEG ^ u AO K=10 BEG "T w GO TO 30 BEG ji350J> %s 70 NSTMT=0 BEG 360

fin M0DE=3 BEG ? 7 0

GO TO 40 BEG o y Q0 TF ^ K TNn M '\ FO O* tlfl TO 100 REG j i\j K=20 BEG 400

GO TO 30 BEG 4 1

0

"V JL W

i on IF (IARGS(l) .GT.0. AND. IARGS(l) .LT. 1000) GO TO 110 BEG 420 T fc W K=7 BEG 410

GO TO 30 BEG 4 4 0

1 1 n NSTMT=10*(IARGS(1)-1) BEG 31 U GO TO 80 BEG Hs Q U END BEG 470

27
CllDDAIlT 1 MC nr III / T

CTD *7\ SUBROUIINc dcJN ( lb 1 , K g L)DC 1 BEJ 10

c wrnf

t ahcaa nr i m c/tt/ta VERSION 5.00 BEJN 5/15/70a r* i BEJ 20

c

t r" TfTar1 nta v/tc i~an or mi IF IST=0 ENTRY IS FOR BEJN BEJ 30

c tc TCT

t riiTOU TC rnn nriii

IF I5T=1 tNIRY IS rOK BtlN

DC 1 BEJ

AA 40

at nr nrt Amn / i \ DIMENSION R(l)

DC 1 BEJ 50

HAIIDIT ADCATCTAMVD "7ADAACCAAA \J DOUBLE PRECISION X , R , Z , A , B , C , D , E , F , G , P , Q , Y

BEJ 60

V/TAA Y=l . DO

DC 1 BEJ ~T

A 70

tc /tct Kira\ \/ i nn lr (lbl.Nt.0) Y=-1.00DC 1 BcJ

OA 80

X

=

Z

DC 1 DC J

AA 90

AATAM 1 1 AA DU 10 N=l ,100

DC 1 DCJ 1 A

A 100

10

A / hi\AA

R (N )=0 . 0 n

r i BEJ 110 1 A A LA=0 D C 1 BEJ 120

TC /V 1 C Z.A\ rn TA *3A IF ( X . Lt . 60 . ) bU I U 30DC 1 BEJ 1 O

A 130 1 A 1 LA=1 D C 1 BEJ 140

TC /V IC 1 AA\AA TA OA lr (X.Lt.100.) bU 1 U 20DC 1 BEJ 1 C

A 150

AAI 1 CODAD / 1 ac\ CALL tKKOK ( 225 ) a r" i BEJ 160 A A T A 1 1 A bU IU 130 D C 1 DCJ 1 T A 170

AVV / 1 AA A=A / 2 . UODC 1 BLJ 1 O

A 180 1 a 30 A V / *> A A A=X / 2 . UO D C 1 DCJ 1 A A 190

TC /V AT IC\AA TA 1 AA lr (X.bl.15.) bU IU 100DC 1 DCJ

*>

AA 200

D 1 AA B=l . 00

DC 1 BEJ

A 1 A 210

O 1 HA L=l . 00DC 1 BEJ AAA 220

rVA /IA KlT 1 AA UO 40 N=l ,100DC 1 BEJ

AOA 230 1 M J =N D C 1 DC.J

">

AA 240

B=B A/L

DC 1 DC.J OCA 250

AA 1 AA C=C+1 . DO

DC 1 BEJ

A / A 260

TC / D ITCA } A\ AA TA CA IF (B .LT . .50-30) GU TU 50DC 1 BEJ 270

40 PAilTTHIIC LUN 1 INUc

DC 1 DCJ AAA 280

ca 50

AD * A / A D=D A / UDC 1 BEJ AAA 290

AA * * O A=A**2DC 1 BEJ

OAA 300

1/V Z.AA K=X+6 . DODC 1 BEJ 1 1 A 310

C 1/ c=KDC 1 BEJ 1 A

A 320

C 1/ . 1 BtJ 330 A C.I A A b=r+l . 00 D C 1 BtJ 340 d i n a r=l . 00 DC 1 btJ "3 C A 350 A 1 A A 0=1 . DO D C 1 BEJ "> / A 360

DO 60 N=1,K

DC i BEJ OTA 370

A 1 AA D*A//C*C\*\/ r=l . D0-r*A/ (c*r ) * Y A 1 AA A*A//fT*Av*W Q=1.D0-QA/(EG)YC 1 BtJ

O

A

A 380

DC 1 BtJ

AA 390

CC 1 AA E=E-1 . DO DC 1 BtJ 400 P C 1 A A F=F-1 . DO DC 1 BtJ A 1 A 410 / A 60 A A 1 A A G=G-1 . DO DC 1 BtJ /tin 4Z0 D / 1 1 \ D * A R ( J+l )=B r DC 1 BtJ 430 A / 1 A \ AAA R (J+2 )=D*Q C 1 BtJ 440

70

AAAA hi 1 1 DO 80 N=l , J

DC 1 BEJ 450

K=J -N+l

DC 1 BEJ

a / n 460

A 1/ A=K DC 1 BtJ Jl 7 A 4/0

OA 80 R(K)=2.D0A*R(K+1) /X-R (K+2 ) *Y

DC 1 BtJ 480

T ^ /I

A r*

A A\ AA TA "1A IF (LA.EQ.0) GO TO 130 BEJ AAA 490 1 A 1 A 1 LA=LA-1 DC 1 BtJ C A A A D/l \£D/1AA\ A=R ( 1 ) R ( 100 )

DC 1 BtJ CIA 510

D AAA B= . 0D0 BEJCOA 520

AA AA hi ^ AA DO 90 N=l,99

DC 1 BEJ

r *iA 530

1/ 1 AA Al K=100-N DC 1 BtJ

C JlA 540

AA D/AI 1 \ * D / 1/\ A=A+R (N+l ) *R (K ) DC 1 BtJ CCA 550

90

DD D/AI\#D/l/\ B=B+R (N) *R (K)DC 1 BtJ

C£A 560 1 AO J=98 DC 1 BtJ C 7 A 570 D / 1 A A \ A K ( 100 )=A DC 1 BtJ C O A 580

R(99)=B BEJ 590

28
100

110

120

130

x=z BEJ 600

GO TO 70 BEJ 610

K=l .5*X BEJ 620

B=l .DO BEJ 630

C=K BEJ 640

DO 110 N=1,K BEJ 650

B=A*B/C BEJ 660

C=C-1 .DO BEJ 670

P=2 .D-9 BEJ 680

IF (LA.EQ.l) P=5.D-20 BEJ 690

C=K+1 BEJ 700

DO 120 N=l,30 BEJ 710

J=K+N BEJ 720

B=B*A/C BEJ 730

C=C+1 .DO BEJ 740

IF (B.LT.P) GO TO 50 BEJ 750

IF (J.EQ.98) GO TO 50 BEJ 760

CONTINUE BEJ 770

GO TO 50 BEJ 780

RETURN BEJ 790

END BEJ 800

29

409-118 OL - 71 - 3
cc

c

c

c

c10

20

SUBROUTINE BESSEL

VERSION 5.00 BESSEL 5/15/70

COMMON /BLOCKD / IARGS(IOO) , KIND (100) ,ARGTAB(100) ,NRMAX ,NROW ( NCOL

1ARGS,VWXYZ(8) ,NERROR

COMMON /BLOCRC/ NRC , RC ( 12600

)

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )

)

DIMENSION ARGS(IOO)

COMMON /SCRAT/ NS ,NS2 ,A (13500

)

DOUBLE PRECISION DBEJ , X , Y , E , P ,Q , S , T , BINTJO ,COMELL , Z , DXEX , XEX

DOUBLE PRECISION FDCOS,FDEXP

DOUBLE PRECISION AA ( 1000 ), B ( 1000 ), W( 100

)

EQUIVALENCE (A(1),AA), (A(2001),B), (A(4001),W)

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG

DIMENSION R(l) , IA(1) , KI (1)

EQUIVALENCE (R,RC), (IA, IARGS)

COMMON /ABEKI / X,Y,P,Q,S,T

DOUBLE PRECISION DSNCOS,DXEXP

COMMON /CONSLB/ XTRIG,XEXP

COMMON /DCONLB/ DSNCOS,DXEXP

(KI ,KIND) , (NR ,NRMAX)

WJG PATCH )())()()())()()()() ()()()()()()()()()

XEX=XEXP-3.0

DXEX=DXEXP-4.0D0

IF (NARGS.GE.2) GO TO 10

CALL ERROR (10)

RETURN

END PATCH )()()()()()()()()())()()()()()

IF (L2.GT.28) GO TO 250

N=0

=L2/2

=2*L

F (L.EQ.L2) N=l

F (L2.GT.12) GO TO 110

F (NARGS.GT.2) CALL ERROR (10)

CALL ADRESS (NARGS , J

)

F (J.LE.O) CALL ERROR (11)

T=l

F (KI (1) .EQ.l) GO TO 20

CALL ADRESS (1,JA)

F (JA.LE.O) CALL ERROR (11)

T=2

M=l

(NERROR.NE.O) RETURN

(L2.GT.2) M=5

(L2.GT.4) M=3

(L2.GT.6) M=7

(L2.GT.8) M=3

(L2.GT.10) M=7

F

F

F

FF

F=0

F (L2.GT.4) L=l

F (L2.GT.8) L=2

F (LT.EQ.l) GO TO 70

DO 50 1=1, NR

X=R(JA)

A=JA+1

=1 .DO

BES

BES

,NBES

BES

BES

BES

BES

BES

BES

10

20

30

40

50

60

70

80

90

BES 100

BES 110

BES 120

BES 130

BES 140

BES 150

BES 160

BES 170

BES 180

BES 190

BES 200

BES 210

BES 220

BES 225

BES 227

BES 230

BES 240

BES 250

BES 260

BES 270

BES 280

BES 290

BES 300

BES 310

BES 320

BES 330

BES 340

BES 350

BES 360

BES 370

BES 380

BES 390

BES 400

BES 410

BES 420

BES 430

BES 440

BES 450

BES 460

BES 470

BES 480

BES 490

BES 500

BES 510

BES 520

BES 530

BES 540

BES 550

BES 560

BES 570

30
c

c

cc

c

c

30

33

35

C

C

C

C

C

C

C

C

C

C

C

C

40

50

60

70

C

80

C

C

C

C

C

C

C

C

C

C

C

C

C

90

IF (L.EQ.O) GO TO 33 BES 580

IF (L.EQ.2) GO TO 30 BES 590

IF(DABS(X) .LT.XEX) GO TO 33 BES 600

IF 1X1 IS GREATER THAN XEXP AND LESS THAN DXEXP THE RESULTS BES 610

WILL BE SCALED BY EXP (X) OR EXP(-X). BES 620

IF 1X1 IS GREATER THAN DXEXP THE SUBROUTINE DBEJ DOES THE SCALINGBES 630

GO TO 33

IF (X) 35,35,40

AND A MESSAGE IS PRINTED.

THIS APPLIES TO THE FOLLOWING COMMANDS BIZERO

BKONE

CALL ERROR (105)

IF (DABS(X) .GT.DXEX)

Y=FDEXP(X)

IF (M.EQ.-3) Y=1.D0/Y

IF (M.EQ.5.0R.M.EQ.7)

GO TO 40

R(J)=0.

CALL ERROR (101)

GO TO 50

L2=1,M=1,N=0,LT=2,L=0

L2=2,M=1,N=1,LT=2,L=0

L2=3,M=5,N=0,LT=2,L=0

L2=4,M=5,N=1,LT=2,L=0

L2=5,M=3,N=0,LT=2,L=1

L2=6,M=3,N=1,LT=2,L=1

L2=7,M=7,N=0,LT=2,L=1

L2=8,M=7,N=1,LT=2,L=1

L2=9,M=3,N=0,LT=2,L=2

L2=10,M=3,N=1,LT=2,L=2

L2=11,M=7,N=0,LT=2,L=2

L2=12 ,M=7 ,N=1 ,LT=2 ,L=2

R(J)=Y*DBEJ (X,N,M)

J=J+1

RETURN

X=ARGS(1)

Y=1.D0

IF (L.EQ.O) GO TO 90

IF (L.EQ.2) GO TO 80

IF (DABS(X) .LT.XEX) GO TO 90

SEE COMMENTS ABOVE ON BOUNDS OF

CALL ERROR (105)

IF (DABS(X) .GT.DXEX) GO TO 90

Y=FDEXP(X)

IF (M.EQ.3) Y=1.D0/Y

L2=1,M=1,N=0,LT=1,L=0

L2=2,M=1,N=1 LT=1,L=0

L2=3,M=5,N=0,LT=1,L=0

L2=4,M=5,N=1,LT=1 ,L=0

L2=5,M=3,N=0,LT=1,L=1

L2=6,M=3,N=1,LT=1,L=1

L2=6,M=3,N=1,LT=1,L=1

L2=7,M=7,N=0,LT=1,L=1

L2=8,M=7,N=1,LT=1,L=1

L2=9,M=3,N=0,LT=1,L=2

L2=10,M=3,N=1,LT=1,L=2

L2=11,M=7,N=0,LT=1,L=2

L2=12,M=7,N=1,LT=1,L=2

X=Y*DBEJ(X,N,M)

DO 100 1=1, NR

R(J)=X

BIONE , BKZERO

X BEFORE DBEJ IS CALLED

BJZERO OF ** STORE IN ++

: BJONE OF ** STORE IN ++ BYZERO OF ** STORE

BYONE OF ** STORE

BIZERO OF ** STORE

BIONE OF ** SOTRE

BIONE OF ** STORE

BKZERO OF ** SOTRE

BKONE OF ** STORE

EXIZERO OF ** STORE

EXIONE OF ** EXKZERO OF ** EXKONE OF * *STORE

STORE

STORE

IN

IN

IN

IN

IN

IN

IN

IN

IN

IN

IN

++

++++

++

++

++++

++++

++

++

BES 640

BES 650

BES 660

BES 670

BES 680

BES 690

BES 700

BES 705

BES 710

BES 720

BES 730

BES 740

: BJZERO OF ++ STORE IN ++ BES

:BJONE OF ++ STORE IN ++ BES

: BYZERO OF ++ STORE IN ++ BES

: BYONE OF ++ STORE IN ++ BES

:BIZERO OF ++ STORE IN ++ BES

:BIONE OF ++ STORE IN ++ BES

: BKZERO OF ++ SOTRE IN ++ BES

: BKONE OF ++ STORE IN ++ BES

:EXJZERO OF ++ STORE IN ++ BES

:EXIONE OF ++ STORE IN ++ BES

:EXKZERO OF ++ STORE IN ++ BES

: EXKONE OF ++ STORE IN ++ BES

BES 870

BES 880

BES 890

BES 900

BES 910

BES 920

BES 930

BES 940

BES 950

BES 960

BES 970

BES 980

BES 990

BES1000

BES1010

BES1020

BES1030

BES1040

BES1050

BES1060

BES1070

BES1080

BES1090

BES1100

BES1110

BES1120

BES1130

BES1140

BES1150

31
100 J=J+1

GO TO 60

110 IF (L2.GT.20) GO TO 210

IF (NARGS.GT.3) CALL ERROR (10)

M=l

IF (L2.GT.14) M=2

IF (L2.GT.16) M=l

IF (L2.GT.18) M=2

L=0

IF (L2.GT.16) L=l

Y=.785398163397D0

LV=0

JX=0

120 CALL ADRESS (NARGS , J2)

IF (J2.LE.0) CALL ERROR (11)

CALL ADRESS (NARGS-1J1)

IF (Jl.LE.O) CALL ERROR (11)

LT=0

IF (KI (1) .EQ.l) GO TO 130

CALL ADRESS (1,JA)

IF (JA.LE.O) CALL ERROR (11)

LT=1

130 K=0

KA=0

IF (LT+LV.EQ.O) GO TO 200

IF (LV.EQ.O) GO TO 230

IF (LT.EQ.O) GO TO 240

140 IF (NERROR.NE.O) RETURN

DO 190 1=1 ,NRMAX

IF (KA.EQ.O) X=R(JA)

JA=JA+1

E=1.D0

IF (JX.NE.O) Y=R(JB)

JB=JB+1

L2=15,M=2,N=0,L=0

L2=16,M=2,N=1,L=0

L2=19,M=2,N=0,L=1

L2=20 ,M=2,N=1,L=1

L2=23 ,M=2 ,N=0 ,L=0

L2=24,7=2 ,N=1 ,L=0

L2=27 ,M=2 ,N=0 ,L=1

L2=28,M=2,N=1,L=1

IF (M.EQ.2) CALL CBEK

L2=13 ,M=1 ,N=0 ( L=0

L2=14,M=1,N=1,L=0

L2=18 ,M=1 ,N=1 ,L=1

L2=21 ,M=1 ,N=0 ,L=0

L2=22 ,M=18N=1 ,L=0

L2=25,M=1,N=0,L=1

L2=26,M=1,N=1 ,L=1

IF (M.EQ.l) CALL CBEI

Z=X*FDCOS(Y)

IF (L.EQ.l) GO TO 150

IF (DABS(Z) .LT.XEX) GO TO 160

CALL ERROR (105)

150 E=FDEXP(Z)

IF (M.EQ.l) E=1.D0/E

160 IF (N.EQ.O) GO TO 170

C STORE INTO WORK SHEET RESULTS OF COMMANDS KBIONE, KBKONE

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

KBKZERO OF $$ PUT REAL IN ++ IMAGINARY ++ KBKONE OF $$ PUT REAL IN ++ IMAGINARY ++ KEXKZR OF $$ PUT REAL IN ++ IMAGINARY ++ KEXKONE OF $$ PUT REAL IN ++ IMAGINARY ++ CKZERO OF $$ OHI $$ UT REAL ++ I MAG ++ CKONE OF $$ PHI $$ PUT REAL ++ IMAG ++ CEKZERO OF $$ PHI $$ PUT REAL ++ IMAG ++ CEKONE OF $$ PHI $$ PUT REAL ++ IMAG ++

KBIZERO OF $$ PUT REAL IN ++ IMAGINARY ++ KBIONE OF $$ PUT REAL IN ++ IMAGINARY ++ KEXIONE OF $$ PUT REAL IN ++ IMAGINARY ++ CIZERO OF $$ PHI $$ PUT REAL ++ IMAG ++ CIONE OF $ PHI $ PUT REAL ++ IMAG ++ CEIZERO OF $$ HI $ UT REAL ++ IMAG ++ CEIONE OF $$ PHI $$ PUT REAL ++ IMAG ++

BES1160

BES1170

BES1180

BES1190

BES1200

BES1210

BES1220

BES1230

BES1240

BES1250

BES1260

BES1270

BES1280

BES1290

BES1300

BES1310

BES1320

BES1330

BES1340

BES1350

BES1360

BES1370

BES1380

BES1390

BES1400

BES1410

BES1420

BES1430

BES1440

BES1450

BES1460

BES1470

BES1480

BES1490

BES1500

BES1510

BES1520

BES1530

BES1540

BES1550

BES1560

BES1570

BES1580

BES1590

BES1600

BES1610

BES1620

BES1630

BES1640

BES1650

BES1660

BES1670

BES1680

BES1690

BES1700

BES1710

BES1720

BES1730

BES1740

32
c KEXIONE, 1 <EXK0NE, CIONE, CEIONE, ^ r i/ a 1 1 r CEKONE BES1750

R (J1)=E*S BES1760

R (J2)=E*T BES1770

GO TO 180 BES1780

c STORE INTO WORK SHEET RESULTS OF COMMANDS KBIZERO, KBKZERO, BES1790

c KEXIZER, 1 /CVI/7CD nTirnrt T 7CDH \EXKZtK , L1ZLKU , LLlZtKU r i/ 7 r n n

, CEKZERO pi P" f i ft ft ft BES1800

170 R (J 1 )=h*P BEbl810

R ( J2 )=t Q

pi P* tf" ^ n ft ft BES1820

180 J 1=J 1+1

n r" f i a *} a BES1830

190 J2=J2+1 BES1840

nrTiinu RETURN BES1850

200 IF (JX.EQ A \ A A T f\ O A rt .0) GO TO 240 Btbl860

v/ a p» a p* / f\ \ Y=ARGS (2

)

D C C 1 OTA BEbl8 7

0

X=ARGS ( 1

)

BES1880

KA=1 n p* a t ft ft. /\ BES1890

JX=0

ft r~ ft ^ ft ft ft BES1900

GO TO 140 BES1910

210 IF (NARGS .GT.4) CALL ERROR (10) BES1920

JX=1 P\ P* P" ^ ft ft ft BES1930

LV=0 BE51940

IF (KI (2) .EQ.l) GO TO 220 BES1950

CALL ADRESS (2 , JB)

A P" P* i ft y « BES1960

IF (JB.LE .0) CALL ERROR (11)

PI P" P" ^ ft ^ ft BES1970

LV=1 pi r~ A ^ a ft ft BES1980

220 M=l nr f i aaa BES1990

IF (L2.GT .22) M=2 BES2000

IF (L2.GT .24) M=l BES2010

IF (L2.GT .26) M=2 BES2020

L=0 BES2030

IF (L2.GT .24) L=l ft ^ ft ft J-\ M ft BES2040

GO TO 120 n P" A ft ft p ft BES2050

230 IF (JX.EQ .0) GO TO 140 PI I"

1 f* ft. A / A BES2060

Y=ARGS(2) BES2070

JX=0 BES2080

GO TO 140 PI P p « ft A ft BES2090

240 KA=1 BES2100

X=ARGS(1) p* ft ^ ^ ft BES2110

GO TO 140 a p

- p1 ft *i ft ft BES2120

250 IF (L2.GT .32) GO TO 350 a p

- p* ft ^ ft ft BES2130

260 IF (NARGS .GT.2) CALL ERROR (10)

pi r p ft i * ft BES2140

CALL ADRESS (NARGS, J) BES2150

IF (J.LE.i3) CALL ERROR (11) BES2160

LT=0 p* f- p* ft ^ ^ ft BES2170

IF (KI (1) .EQ.l) GO TO 270 a p* p* ft ^ ft ft BES2180

CALL ADRESS (1,JA) pi p* f ft i ft ft BES2190

IF (JA.LE .0) CALL ERROR (11) BES2200

LT=1 r\ P P ft ft i ft BES2210

270 IF (NERROR.NE.O) RETURN pi p" p

1 ft ft ft ft BES2220

IF (LT.EQ .0) X=ARGS(1)

p* a a a a BES2230

IF (L2.GT .37) GO TO 310 p> p" p* ft ft j ft BES2240

IF (L2.EQ .32) GO TO 310 O P* P" ft ft p pi BE52250

IF (L2.GT .29) GO TO 290 BES2260

DO 280 N= L ,NR

pi p* p* ft ft ^ ft BES2270

IF (LT.EQ .1) X=R(JA) BES2280

JA=JA+1 BES2290

AC L2=29 :INTJ0 OF $$ STORE IN ++

nrPfti ft ft BES2300

R(J)=BINTJO(X,W,Z) BES2310

280 J=J+1 BES2320

RETURN BES2330

33
290 K=l n r r i 1 >i r\ BES2340

T C / 1 a rrt i i \ 1/ o IF ( L2 . bU. . 3 1 ) K=2 BES2350

DU 300 N=l , NK D C C O ^ L rt BE52360

T C /IT Crt 1 \ V D / 1 A \ IF (LT.bQ.l) X=K(JA) BES2370

JA=JA+1 opp i i nn BES2380

C L2=30,K=1 : ELLIPTICAL FIRST OF $$ STORE IN ++

D C* P *1 *5 Art BES2390

0 L2=31,K=2 : ELLIPTICAL SECOND OF $!$ STORE IN ++ DLTCOil Art

R t 1 )-P0MELL (X K) D C C 1 VI 1 A dtb24 10

"5 A A 300 J —J + X Dtb2420

RFTIIRN tr c o >i i n Btb243 0

310 TF1 r M^ L T1 . FO . "M1 PAN FRROR 0(\\ ) l/WLL Cr\ i\U r\ \ c.\J ) DPP 1 ^ A rt Bbb2440

i_ A

D C C 1 A C A Bto2450

K—MR BtbZ460

if i f inn) go to 33n Btb2470

K—IN — iA onU U Bhb2480

1 a— i j. l no T~\ t~ C A rt rt BES2490

DO 320 I-K MR n r c i r rt rt BES2500

R ( JA)=Q 0 BES2510

ion 3<:0 JA-JA+l Btb2520

p L2=32 BESJN X- ** STORE I N . X 11 rt DtbZ530

o ^ a 330 IF f 12 E0 32) CALL BEJN (0 W Z) DTP O C J( A p L2-38 BESTN X- ** STORE TN1 I* Tt ore i c c rt IF (L2 E0 38) CALL BEJN (1 W Z) D LT C O C L rt IF (L2 E0 39) GO TO 460 btbZ570

DO 340 N-l K

R < U-W(N) D C C C A A BEb2590

340 J-J+l D C C O Z rt A BES2600

RETURN i\ l. i \j i\ n QPPn/ T rt

3 50 TF (\ 7 GT 34) GO TO 390 D (~ C 1 Z OA Btb2620

L=NR BtbZ630

TF (NR GT 1000) 1—1000 QPPO / yi A BLb2640

TF fNARGS GT ?) PAI 1 FRROR M0) Utb2650

CALL ADRESS (NARGS J) BLb2660

IF M LE 0) PALL ERROR HI) DtbZo /

0

TF fKTd) FO 1) PAN FRROR f?n) DtbiOoO

PAI 1 ADRF^ ( 1 1 A

)

btbZ690

TF MA IF m P Al 1 FPPOP Ml \ D C C O 7 A A btb2700

TF rNFRROR NF 0) RFTIIRN btb2710

TF CI ? FO 33) GO TO %f\(\ Dtb2720

p 17—34 -7FR0^ R I7FR0 II uN ++ a m n i j_ Mill/ ++ D C C O 7 "2 A bbbZ / 30

PAI 1 RF70WF /AA R l 1

\

bbb2740

p n TP \ 7 il D C C o ^ c n bbb2750

C 19—33 .7FR0<; R IONF J 1 UI\L T N ++ MIlU Awn +

i _L+ bbbZ760

360 PAI IMLL1 RF7FRO DC£.Ht\U /

\ MMAA , RD , 11, ML ) Bbb2770

"3 7 A 3/0 no 3fto N— i i DC C O 7 Q

A

DC OC

1

OU

P M A \_AA \ tl ( J M ) =MM ^ n ) DF C O 7 Q A bbbZ /V0

K ( J )=D (IM ) D C C O O A A bbbZoOO

1 A— 1 A i 1 J H=J M + l orcooi a bbb2810

380 1— bbb2820

PFTI KL IPM 1 URN D C C O O 1 ft bbb2o30

IF (LZ.bl .36) bU 1 U 430 DC C O Q A ft

IF (NARGS.GT.2) CALL ERROR (10) D F C O Q C A bbbZobO

CALL ADRESS (NARGS , J

)

D C C O O Z A BEb2860

IF (J.LE.O) CALL ERROR (11)

D C C O O T A Bb52870

LT=0 D C C O O O rt

IF (KI (1) .EQ.l) GO TO 400 DC C O O Q rt DC j^oVU

CALL ADRESS (1,JA) D C C o rt rt rt BtbZVOO

IF (JA.LE.O) CALL ERROR (11)

n C C O A 1 A BES2910

LT=1 BES2920

34
400 IF (LT.EQ.O) X=ARGS(1) BES2930

IF (NERROR .NE .0) RETURN BES2940

K=0 BES2950

IF (L2.EQ.36) K=l BES2960

DO 420 N=1,NR BES2970

IF (LT.NE.O) X=R(JA) BES2980

JA=JA+1 BES2990

C L2=35,K=0 :STRUVE ZERO OF $$ STORE IN ++ BES3000

C L2=36,K=1 :STRUVE ONE OF $$ STORE IN ++ BES3010

CALL STRUVE (X,Y,Z,W) BES3020

IF (K.EQ.O) GO TO 410 BES3030

C STORE RESULTS FOR STRUVE ONE BES3040

R(J)=Z BES3050

GO TO 420 BES3060

C STORE RESULTS OF STRUVE ZERO BES3070

410 R(J)=Y BES3080

420 J=J+1 BES3090

RETURN BES3100

430 IF (L2.GT.37) GO TO 260 BES3110

IF (NARGS.GT.3) CALL ERROR (10) BES3120

CALL ADRESS (NARGS , J

)

BES3130

IF (J .LE.O) CALL ERROR (11) BES3140

IF (KI(l).EQ.l) CALL ERROR (20) BES3150

CALL ADRESS (1,JA) BES3160

IF (JA.LE.O) CALL ERROR (11) BES3170

JB=IA(2) BES3180

IF (KI (2) .NE.O) CALL ERROR (3) BES3190

IF (NERROR .NE .0) RETURN BES3200

K=IA(2) BES3210

LNR=NRMAX BES3220

IF (LNR .GT . 1000) LNR=1000 BES3230

DO 440 N=l ,LNR BES3240

A ft j ft 1 t r% , t A i AA (N)=R (JA) BES3250

440 JA=JA+1 BES3260

C L2=37 : HARMONIC OF ++ STORE IN ++ BES3270

CALL FOURIA (AA ,B ( 1 )

, B ( 2 ) ,K , L

)

BES3280

DO 450 N=1 ( JB BES3290

R(J)=B(N) BES3300

450 J=J+1 BES3310

RETURN BES3320

460 IF (X.LT.XEXP) GO TO 470 BES3330

CALL ERROR (225) BES3340

RETURN BES3350

C L2=39 : BESKN X= ** STORE IN ++ BES3360

470 AA(1)=DBEJ (X,0,7) BES3370

AA(2)=DBEJ (X, 1 ,7) BES3380

R(J)=AA(1) BES3390

R (J+1)=AA(2) BES3400

J=J+2 BES3410

DO 480 1=3,

K

BES3420

Z=I-2 BES3430

A A t 9 ft A 4 V At a -X- ft A * IF * i J \£ AA(I )=AA(I-2)+2 .*Z*AA(I-1) /X BES3440

R(j)=AA(I) BES3450

IF (AA(I) .GT.3.E37) GO TO 490 BES3460

480 J=J+1 BES3470

RETURN BES3480

490 DO 500 JA=I,K BES3490

R(J)=0.0 BES3500

500 J=J+1 BES3510

RETURN BES3520

END BES3530

35
SUBROUTINE BEZERO (A ,B ,M,L) BEZ 10

c VERSION 5.00 BEZERO 5/15/70 BEZ 20

DOUBLE PRECISION A(1),B(1),X, Y , AA , AB , AC , FDSQRT BEZ 30

KB=1 BEZ 40

N=M BEZ 50

10 J=4*N-1 BEZ 60

IF (J .GT.44) GO TO 130 BEZ 70

GO TO (20,30,40,50,60,70,80,90,100,110,120) , N BEZ 80

20 X=2 . 404825577D0 BEZ 90

Y= . 5191474973D0 BEZ 100

ft f\ x a lift GO TO 140 BEZ 110

30 V £ rftftftTOITftOHft X=5 .520078110300 BEZ 120

Y=- .340264806500 BEZ 130

ft A T A 1 A ft bU IU 140 BEZ 140

40 V O ZCOTftTftlftftnft X=8 .653727912900 BEZ 150

\J ftTlJlCftftftftftAft Y= . 2714522999D0 BEZ 160

OA T A i a e\ bU IU 140 BEZ 170

50 X=ll .7915344391U0 BEZ 180

Y=— . Z3Z459o31'HJ0 BEZ 190

bU IU 140 BEZ 200

60 X=14 .930917708600 BEZ 210

V *3 A £ C A / A 1 1 1 Pi A Y=.Z065464331U0 BEZ 220

o a Trt i >! a bU IU 140 BEZ 230

70 X=lo .07106396/9L/0 BEZ 240

Y=- . Lot 1 Zoo03L)0 BEZ 250

OA T A 1 A A bU IU 140 BEZ 260

80 X=Z 1 .Z116366Z9900 BEZ 270

Y=. 173Z65894ZU0 BEZ 280

OA T A 1 A A bU IU 140 BEZ 290

90 V *i A OCO>ITTCOftOr\ft X=Z4 .35Z47 1530800 BEZ 300

Y=- .161701550700 BEZ 310

OA T A 1 A A bU IU 140 BEZ 320

100 V IT vlft^jl"7ft*l ,3ftn.ft X=Z7 .49347913200 BEZ 330

Y=. 152181213800 BEZ 340

OA T A 1 vl A bU IU 140 BEZ 350

110 V Oft /«)jt/ft / A / ft jl ft ft X=30 . 6346064684D0 BEZ 360

Y=- . 1441659777U0 BEZ 370

ft A T ft i <a GO TO 140 BEZ 380

120 X=33 . 7758202136D0 BEZ 390

Y= . 1372969434D0 BEZ 400

GO TO 140 BEZ 410

130 X=J BEZ 420

V V4:i iviirftftzcozftft X=X*3 .1415926536D0 BEZ 430

A A 1 ft ft / V A A AA=1 . DO /X**2 BEZ 440

AD 1 ft ft ft ftft&AA&zl AB=1.D0+2.D0AA*(1 ft ft A A Jfc / O 1

. D0-AA* (31

.

T\ ft DO -AA* (3779 .D0--AA*6277237 . DO /7 . DO )

/

ft r

- t BEZ 450

15 .DO) /3 .00) BEZ 460

J=N/2 BEZ 470

J=2*J BEZ 480

AC=1 .DO BEZ 490

IF (J.EQ.N) AC—1. DO BEZ 500

Y=AC*1.595769122D0 * (1 .D0-AA** 2* 56.D0/3.D0)/FDSQRT(X) BEZ 510

X=X*AB/4.00 BEZ 520

140 A(KB)=X BEZ 530

B (KB)=Y BEZ 540

N=N+1 BEZ 550

KB=KB+1 BEZ 560

IF (KB.LE.L) GO TO 10 BEZ 570

RETURN BEZ 580

END BEZ 590

36
SUBROUTINE BEZONE (A B M L) BE0 10

r VERSION 5 00 BEZONE 5/15/70 BE0 20

DOUBLE PRECISION A(l) B(l) R S T X Y , FDSQRT BE0 30

KB-1 BE0 40

N=M BEO 50

1 0 j-4*N+l BEO 60

IF (J.GT.46) GO TO 130 BEO 70

GO TO (20,30,40,50,60,70,80,90,100,110 ,120) N BEO 80

20 X=3 .831705970200 BEO 90

Y=-.4027593957D0 BEO 100

GO TO 140 BEO 110

30 X=7 .0155866698D0 BEO 120

Y=.3001157525D0 BEO 130

GO TO 140 BEO 140

40 X=10 .1734681351D0 BEO 150

Y=-.2497048771D0 BEO 160

GO TO 140 BEO 170

50 X=13.3236919363D0 BEO 180

Y=.2183594072D0 BEO 190

GO TO 140 BEO 200

60 X=16.4706300509D0 BEO 210

Y=-.1964653715D0 BEO 220

GO TO 140 BEO 230

70 X=19.6158585105D0 BEO 240

Y=.180063375D0 BEO 250

GO TO 140 BEO 260

80 X=22 .7600843806D0 BEO 270

Y=-.1671846005D0 BEO 280

GO TO 140 BEO 290

90 X=25.9036720876D0 BEO 300

Y=.1567249863D0 BEO 310

GO TO 140 BEO 320

100 X=29 .046828534900 BEO 330

Y=-.1480111100D0 BEO 340

GO TO 140 BEO 350

110 X=32.1896799110D0 BEO 360

Y=.1406057982D0 BEO 370

GO TO 140 BEO 380

120 X=35 .332307550100 BEO 390

Y=-.1342112403D0 BEO 400

GO TO 140 BEO 410

130 X=J BEO 420

X=X*3 .1415926536D0 BEO 430

R=l .00/X**2 BEO 440

S=l .00-6 .D0*R* (1 .D0-R* (1 .00-R* (157 . 2D0 -130080 .6D0*R/7 .DO) )

)

BEO 450

J=N/2 BEO 460

J=2*J BEO 470

T=l .DO BEO U Im. V 480w \J IF (J NE N) T=-l DO BEO 490

Y=T* 1.595769 122D0* (1 .D0+R**2 *24.D0* (1. DO-81 . 6D0*R) ) /FDSQRT (X) BEO 500

X=S*X/4.D0 BEO 510

140 A(KB)=X BEO 520

B (KB)=Y BEO J530J V N=N+1 BEO 540

KB=KB+1 BEO 550

IF (KB.LE.L) GO TO 10 BEO 560

RETURN BEO 570

END BEO 580

37
FUNCTION dINIJU ( X # A ,L

)

DTM BIN 10

wrilC T AM C A A T M T 1 A C / 1 C / 7 A VERblON 5.00 dINIJU 5/15/70 D T Al BIN O A 20

a t tar* kl f T A M A / 1 \ DIMENSION A(l) D T Al BIN 1 ft 30

DAIIDI C DDCPTCTAM D T KIT lf\ A 7 Y D f HOC 1 UUUDLt rKtLlblUlM D i IM 1 JU , A

,

L , A , D , L , Dot

J

DTM D 1 IM A ft IU

Z=DABS (X) D T Al BIN C A 50

T FT / 7 AT 1 A A \ AA TA OA IF (Z . ti 1 . 100 . ) tiU 1 U 20 D T Al BIN L A 60

AAli nr ui /n A 7 \ CALL BEJN (0,A,Z) O T Al BIN 1 A 70

IE i 7 AT Z. A \ AA TA 1 A IF (Z .til .60 . ) tiU IU 30 D T Al BIN O A 80

n n r\ a D= . 000 D T Al BIN Q A 70

A, A 1 A Al O 1 A A O UU 10 N=Z , 10U ,

Z

DTM Din 1 AA 1UU

B=B+A (N

)

D T Al BIN 1 1 A 110

n O A A * O B=2 . D0*B D T Al BIN 1 1 A 120

A A TA A A

tiU IU 40 D 1 f\ A / 1 \ noc 1 / 7 A 1 \ A ( 1 )=UBtJ (Z , 0 , 1

)

DTM D 1 IM 1 A ft

A / *) \ AO C 1 / 7 1 1 \ A ( 2

) =DBtJ (L

,

1 , 1)

DTM D J. IM 15U

L=l . U0 /Z Z DTM DIN 1 L ft loU

D 1 AA A /

**» \ Jfc / 1 AA A5k/TI AA A * / A AA A Jfc / O *> C B=l . D0+A ( 2 ) (1 . D0-L (1 . D0-L (9 . D0-L (225 AA A * *1 1 A 1 C AA\\\\ . D0-L 1 1025 . U0 ) ) )

)

D T Al BIN 1 1 ft 170

0=1 . UU-L \5 . UU—L (45 . UU-L (15/5 . UU -772 23 •DO L) )

)

DTM D I IM loU

B=B-A (1 ) *C/£ D T Al BIN 1 O A 190

D T AIT lt\ D

1 N 1 J (J=D D T Al BIN O A A 200

RETURN BIN 210

END BIN 220

38
c

cc

cc

c

c

c

cc

cc

10

20

30

40

50

60

70

80

90

SUBROUTINE BJORCK (X,B,NP,A,F) BJO

VERSION 5.00 BJORCK 5/15/70 BJO

INPUT IS X,B AND NP . BJO

OUTPUT IS F. BJO

THIS SUBROUTINE WAS ADAPTED BY ROY H. WAMPLER AND M. STUART SCOTT, BJO

NATIONAL BUREAU OF STANDARDS, WASHINGTON, D . C . , JULY 1969, FROM BJO

A SUBROUTINE CALLED 'BJORCK' WHICH WAS WRITTEN BY WILLIAM J. HALL, BJO

NATIONAL BUREAU OF STANDARDS, BOULDER, COL. THIS ROUTINE USES THEBJO

MODIFIED GRAM-SCHMIDT ALGORITHM GIVEN BY AKE BJORCK IN 'SOLVING

LINEAR LEAST SQUARES PROBLEMS BY GRAM-SCHMIDT ORTHOGONAL I ZAT I ON'

'BIT' VOL. 7 (1967) , PAGES 1-21.

DOUBLE PRECISION C , D , R , Y , FDSQRT

DIMENSION X(l) , B(l) , A(3,l)

DIMENSION C(3,3), D(3), R(3), Y(4)

INITIALIZE A AND FORM SUM OF SQUARES OF THE B VECTOR

Y(4)=0.D0

DO 10 1=1, NP

A(1,I)=1.0

A(2,I)=X(I)

A(3,I)=X(I)*X(I)

Y(4)=Y(4)+B(I)*B(I)

NF=3

D(1)=0.D0

Y(1)=0.D0

DO 20 1=1, NP

D(1)=A(1,I)*A(1,I)+D(1)

Y(1)=A(1,I)*B(I)+Y(1)

Y(1)=Y(1)/D(1)

IR=0

DO 60 K=2,NF

DO 40 J=K,NF

IR=IR+1

R(IR)=O.DO

DO 30 1=1, NP

R(IR)=A(K-1,I)*A(J,I)+R(IR)

R(IR)=R(IR) /D(K-l)

DO 40 1=1, NP

A(J,I)=A(J,I)-A(K-1,I)*R(IR)

D(K)=O.DO

Y(K)=O.DO

DO 50 1=1, NP

B(I)=B(I)-A (K-1,I)*Y(K-1)

Y(K)=A(K,I)*B(I)+Y(K)

D(K)=A(K,I)*A(K,I)+D(K)

Y(K)=Y(K)/D(K)

IRS=-NF

DO 90 K=1,NF

IRS=IRS+NF-K+1

IR=IRS

DO 90 JJ=1,K

J=K-JJ+1

C(K,J)=Y(J)

IF (JJ-1) 90,90,70

DO 80 1=2, JJ

C(K ( J)=C(K,J)-C(K,K-I+2)*R(IR)

IR=IR-1

IR=IR_NF+K

DO 100 1=1, NF

10

20

30

40

50

60

70

80

BJO 90

BJO 100

BJO 110

BJO 115

BJO 120

BJO 130

BJO 140

BJO 150

BJO 160

BJO 170

BJO 180

BJO 190

BJO 200

BJO 210

BJO 220

BJO 230

BJO 240

BJO 250

BJO 260

BJO 270

BJO 280

BJO 290

BJO 300

BJO 310

BJO 320

BJO 330

BJO 340

BJO 350

BJO 360

BJO 370

BJO 380

BJO 390

BJO 400

BJO 410

BJO 420

BJO 430

BJO 440

BJO 450

BJO 460

BJO 470

BJO 480

BJO 490

BJO 500

BJO 510

BJO 520

BJO 530

BJO 540

BJO 550

BJO 560

BJO 570

BJO 580

39
100 Y(I)=Y(I)*FDSQRT(D(I) ) BJO 590

F=Y(3)*Y(3)*FL0AT(NP-3) / (Y (4)-Y (1 j *Y (1 )-Y (2 ) *Y (2 )-Y (3

) *Y (3 )

) BJO 600

RETURN BJO 610

END BJO 620

40
C BLOCK DATA BLOCK BLO 10

C VERSION 5.00 BLOCK 5/15/70 BLO 20

BLOCK DATA BLO 30

COMMON / ABCDEF / L ( 48 ) BLO 40

COMMON /HEADER /NOCARD (80 ) ,ITLE(60,6) , LNCNT , I PR I NT ,NPAGE , I PUNCH BLO 50

COMMON /FMAT/ I FMTX ( 6 ), IOSWT , IFMTS ( 6),LHEAD(96) BLO 60

C BLOCK BLO 70

C ABCDEF BLO 80

C L(l) =1H0 L(2) =1H1 L(3) =1H2 L(4) =1H3 L(5) =1H4 BLO 90

C L(6) =1H5 L(7) =1H6 L(8) =1H7 L(9) =1H8 L(10)=1H9 BLO 100

C L(11)=1HA L(12)=1HB L(13)=1HC L(1J)=1HD L(15)=1HE BLO 110

C L(16)=1HF L(17)=1HG L(18)=1HH L(19)=1HI L(20)=1HJ BLO 120

C L(21)=1HK L(22)=1HL L(23)=1HM L(24)=1HN L(25)=1H0 BLO 130

C L(26)=1HP L(27)=1HQ L(28)/1HR L(29)=1HS L(30)=1HT BLO 140

C L(31)=1HU L(32)=1HV L(33)=1HW L(34)=1HX L(35)=1HY BLO 150

C L(36)=1HZ L(37)=1H/ L(38)=1H. L(39)=1H- L(40)=1H+ BLO 160

C L(41)=1H* L(42)=2H( L(43)=1H) L(44)=1H, L(45)=1H BLO 170

C L(46) = 1H= L(47)=1H$ ( 48)=1H/ BLO 180

DATA L(l) ,L(2) ,L(3) ,L(4) ,L(5) ,L(6) ,L(7) ,L(8) ,L(9) ,L(10)/ BLO 190

1 1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7 ( 1H8,1H9/ BLO 200

DATA L(ll) ,L(12) ,L(13) ,L(14) ,L(15) ,L(16) ,L(17) ,L(18) ,L(19) ,L(20)/BL0 210

1 1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH ( 1HI,1HJ/ BLO 220

DATA L(21) ,L(22) ,L(23) ,L(24) ,L(25) ,L(26) ,L(27) ,L(28) ,L(29) ,L(30) /BLO 230

1 1HK,1HL,1HM,1HN,1H0,1HP,1HQ,1HR,1HS,1HT/ BLO 240

DATA L(31) ,L(32) ,L(33) ,L (34) , L (35

)

( L(36) , L (37 )

, L (38 ) ,L(39) ,L(40) /BLO 250

1 1HU,1HV,1HW,1HX,1HY,1HZ,1H/,1H. ,1H-,1H+/ BLO 260

DATA L(41) ,L(42) ,L(13) ,L(44) ,L(45) ,L(46) ,L(47) ,L(48)/ BLO 270

1 1H*,1H(,1H) ,1H, ,1H ,1H=,1H$ ,1H// BLO 280

C NOCARD CONTAINS THE MESSAGE WRITTEN SAVED FROM THE OMNITAB CARD BLO 290

DATA NOCARD(l) ,N0CARD(2) ,N0CARD(3) ,N0CARD(4) ,N0CARD(5) ,N0CARD(6) , BLO 300

1N0CARD(7) , NOCARD (8) , NOCARD (9) , NOCARD (10) , NOCARD (11) , NOCARD (12) , BLO 310

2N0CARD(13) , NOCARD (14) , NOCARD (15) , NOCARD (16) , NOCARD (17) , NOCARD (18) ,BLO 320

3N0CARD(19) , NOCARD (20) , NOCARD (21) , NOCARD (22) , NOCARD (23) , NOCARD (24) ,BLO 330

4N0CARD(25) , NOCARD (26) , NOCARD (27) , NOCARD (28) , NOCARD (29) , NOCARD (30) ,BLO 340

5N0CARD(31) ( N0CARD(32) ,N0CARD(33) ,N0CARD(34) ,N0CARD(35) ,N0CARD(36) ,BLO 350

6N0CARD(37) ,N0CARD(38) ,N0CARD(39) ,N0CARD(40) / BLO 360

71H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ( 1H ,1H ,1H ,1H ,1H , BLO 370

81H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H , BLO 380

9 1H ,1H ,1H ,1H ,1H0,1HM,1HN ( 1HI/ BLO 390

DATA N0CARD(41) ,N0CARD(42) ,NQCARD(43) ,N0CARD(44) ,N0CARD(45) , BLO 400

1 N0CARD(46) ,N0CARD(47) ,N0CARD(48) ,N0CARD(49) ,N0CARD(50) , BLO 410

2 N0CARD(51) ,N0CARD(52) ,N0CARD(53) ,N0CARD(54) ,N0CARD(55) , BLO 420

3 N0CARD(56) ,N0CARD(57) ,N0CARD(58) ,N0CARD(59) ,N0CARD(60) , BLO 430

4 N0CARD(61) ,N0CARD(62) ,N0CARD(63) ,N0CARD(64) ,N0CARD(65) , BLO 440

5 N0CARD(66) ,N0CARD(67) ,N0CARD(68) ,N0CARD(69) ,N0CARD(70) , BLO 450

6 N0CARD(71) ,N0CARD(72) ,N0CARD(73) ,N0CARD(74) ,N0CARD(75) , BLO 460

7 N0CARD(76) ,N0CARD(77) ,N0CARD(78) ,N0CARD(79) ,N0CARD(80)/ BLO 470

81HT,1HA,1HB ( 1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H , 1H ,1H ,1H ,1H ,1H , BLO 480

91H ,1H ,1H ,1H ( 1H ,1H ,1H ,1H ,1H ,1H ,1H , 1H ,1H ,1H ,1H ,1H , BLO 490

A1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H / BLO 500

C IFMTS CONTAINS FORMAT USED BY PRINT BLO 510

DATA IFMTS(l) , IFMTS (2) , IFMTS (3) , IFMTS (4) ,IFMTS(5) ,IFMTS(6)/ BLO 520

1 1H(,2H1P,2H8E,3H15. ,1H6,1H)/ BLO 530

END BLO 540

41
CIIRDP.IITTMP PRFT nit LB I

1 A 11) VERSION 5.00 CBEI 3/13/ / O PD T LCI O A COMPUTES 10 (Z) AND IKZ) FOR PftMPI FY ARGIIMFNT P*f fH\-7 PRLB TI i n i O

POMMON / ARFK T / R s, A,B,C,D POT LB 1 A A

DOIIBl F PRECISION A, B,C, D,R,S f pi LB 1 C A 30

E, F ,G

,

H,P,Q ,T,X,Y,Z,V,U ( W,AA PR T L A 60

DOIIRI F PRFPTSTON FDSIN , FDC0S , FDEXP , FDSQRT PRLB T

1 7 A f—Fnpo<; i ^ ^ PRT LB 1 o n 0 u F-Fn^TN r —r u j in \ 3 ) PRT LB 1 Q A vo

1 r ,13 1 . J. D . J 1 V3\J TO 30 PRLB T1

i1 nnu u P—r-ii , nouu~t? .uudo*f**? r c PRT LB 1

1 1 A 110

AA—

P

PRT LB 1

1 O A 1ZO

\jI —c . u u ll r PRT LB i

i xn 1 JO

IK—

Q

PRT LB 1 ifi Anu A— i nn PRT LB 1

1 en 130

PRT LB 1 loO

C=l DO PRT LB 1

1 7A 1/0

U—0 DO PRT LB 1

i on loO

g— i Dn PRT LB i

1 OA 170

PRT LD 1 X— iR/2 D0^**2 PRT LB 1 O 1 A £ 1 0 v=x PRT LB 1 ^ ^ A Y-X PRT LB 1 Z J 0

DOU \J XV10 N-l l« — X t 60U V PRT LD 1 7_i nn/G**2 TBI ? ^n

H— 1 Dn / (G*T ^ A—Aj-X*7*P

PRT LB 1 O L A ZoO

PRT LB 1 7 7 n B—Bj-X*7*0 PRT LB 1 O Q A ZoO r~r o—V/ j.v*h*p + v n r PRT LB 1 oon Z70

ll-IUV*H*0 u—u + v n \4 PRT LB 1 inn j 0 0

A—A 1 L. PRT LB 1 n n J 1

0

IF (X LT 5D-10} GO TO 20 PRT LB 1 ion

u_v*Y*H PRT LB 1 7_p PRT LB 1 i An

P=Z*AA-Q*W PRT LD 1 ? <;n Q=Q*AA+Z*W PRT LB 1 1 tn

G=G+1.D0 PRT LB 1 1 7 n J / 0

T=T+1.D0 PRT LD 1

-a 0 n D=R*(C*F+U*E)/2.D0

C=R*(C*E-U*F)/2.D0

PRT LD 1 ion

PRT LD 1 Ann

GO TO 60 PRT at n Z=FDEXP(R*E)/FDSQRT(6 . 283185307D0*R

)

LBPRT1 a 9 n X=S/2.D0-R*F PRT A3n

Y=Z*FDC0S(X) PRT LD 1 AAn

Z=Z*FDSIN(X) PRT LD 1 a«ooc n W=-1.D0 PRT LD 1 AAn

G=l .DO PRT LD 1 A7n «t / 0

H=3 .DO PRT LB I a q n P=E PRT LB 1 Aon 47O

Q=F PRT LD 1 enn T=l .DO PRT

U=0.D0 PRT LD I 3QonZ 0

V=1.D0 PRT LD I 3 J 0

X=0.D0 PRLD T

1 kDhOAn

A=1.D0 PRT ^sn

B=1.D0/(8.D0*R) PRT LD 1 tin 300

C=B PRT LD 1 c7n 3/0

D=B CBI L7 O U DO 40 N=l,20 CBI 590

42
CBI 600

AA=B*G**2/A CBI 610

T=T+AA*P CBI 620

U=U+AA*Q CBI 630

AA=C*W*H/A CBI 640

V=V+AA*P CBI 650

X=X+AA*Q CBI 660

B=B*D*G**2/A CBI 670

IF (B.LT. .5D-10) GO TO 50 CBI 680

C=C*D*W*H/A CBI 690

W=W+2.D0 CBI 700

G=G+2.D0 CBI 710

H=H+2.00 CBI 720

A=A+1.D0 CBI 730

AA=P*E-Q*F CBI 740

Q=F*P+E*Q CBI 750

P=AA CBI 760

A=Y*T-Z*U CBI 770

B=-(Y*U+T*Z) CBI 780

C=Y*V-Z*X CBI 790

D=-(Y*X+Z*V) CBI 800

RETURN CBI 810

END

43
SUBROUTINE CBEK

C VERSION 5.00 CBEK 5/15/70

C COMPUTES KO(Z) AND K1(Z) FOR COMPLEX ARGUMENT Z=R*E(IS)

COMMON /ABEKI / R,S,A,B,C,D

DOUBLE PRECISION A,B,C,D,R,S

DOUBLE PRECISION E , F ,G ,H , P ,Q ,T ,U , V , W,X , Y , Z , AA (40 ), AB (40 )

, AC , AD , AE

DOUBLE PRECISION FDLOG , FDCOS , FDEXP , FDSIN , FDSQRT

COMMON /SCRAT/ NS ,NS2 , SCRAT (13500

)

EQUIVALENCE (SCRAT (1700) ,AA) , (SCRAT (1800) ,AB)

IF (R.LE.O.O) GO TO 80

E=FDCOS(S)

F=FDSIN(S)

IF (R.GT.8.) GO TO 40

P=l .DO-2 .D0*F**2

Q=2.D0*E*F

W=P

Z=Q

X=(R/2 .D0)**2

Y=X

V=X

G=E*(4.D0*E**2-3.D0)

H=F*(3.D0-4.D0*F**2)

T=FDL0G(R/2 . DO ) + . 5772156649D0

A=-T

B=-S

C=E*(T-0.5D0)-S*F

U=F*(T-0.5D0)+S*E

AC=1.D0

AD=2.D0

AA(1)=1.D0

AB(1)=1 .25D0

DO 10 N=2,40

AE-N

AA(N)=AA(N-1)+1.D0/AE

10 AB(N)=AA(N)+1.D0/(2.D0*(AE+1.D0)

)

DO 20 N=l,40

AE=T-AA (N)

D=P*AE-S*Q

AE=Q*AE+S*P

A=A-D*X/AC**2

B=B-AE*X/AC**2

AE=T-AB(N)

D=G*AE-H*S

AE=H*AE+G*S

C=C+D*Y/(AC*AD)

U=U+AE*Y/(AC*AD)

X=X*V/AC**2

IF (X.LT. .5D-10) GO TO 30

Y=Y*V/(AC*AD)

AC=AC+1.D0

AD=AD+1.00

AE=P

P=AE*W-Q*Z

Q=Q*W+AE*Z

AE-G

G=AE*W-H*Z

20 H=H*W+AE*Z

30 C=E/R+R*C/2.D0

D=-F/R+R*U/2.D0

CBK

CBK

CBK

CBK

CBK

CBK

CBK

CBK

CBK

10

20

30

40

50

60

70

80

90

CBK 100

CBK 110

CBK 120

CBK 130

CBK 140

CBK 150

CBK 160

CBK 170

CBK 180

CBK 190

CBK 200

CBK 210

CBK 220

CBK 230

CBK 240

CBK 250

CBK 260

CBK 270

CBK 280

CBK 290

CBK 300

CBK 310

CBK 320

CBK 330

CBK 340

CBK 350

CBK 360

CBK 370

CBK 380

CBK 390

CBK 400

CBK 410

CBK 420

CBK 430

CBK 440

CBK 450

CBK 460

CBK 470

CBK 480

CBK 490

CBK 500

CBK 510

CBK 520

CBK 530

CBK 540

CBK 550

CBK 560

CBK 570

CBK 580

CBK 590

44
40

GO TO 70 CBK 600

U=FOEXP(-R*E)*FDSQRT (1 .570796326800 /R) CBK 610

V=R*F+S/2 .DO CBK 620

Y=U*FDCOS (V) CBK 630

7-ll*FDSIN (\M CBK 640

W— 1 DO CBK 650

G-l DO CBK 660

u_i n no 

j * v \j CBK 670

P=E CBK 680

0=F CBK 690

T-l DO CBK 700

CBK 710

V=l . DO CBK 720

X=0 . DO CBK 730

A=l .DO CBK 740

B—1 DO / (8 D0*R) CBK 750

C-B CBK 760

D=B CBK 770

AC=-1 .DO CBK 780

DO 50 N=l,12 CBK 790

AD=AC*B*G**2/A CBK 800

AE=AC*C*W*H/A CBK 810

T=T+AD*P CBK 820

U=U-AD*Q CBK 830

V=V+AE*P CBK 840

X=X-AE*Q CBK 850

AD=B CBK 860

B=B*D*G**2/A CBK 870

IF (B.GT.AD) GO TO 60 CBK 880

IF (B.LT. .5D-10) GO TO 60 CBK 890

C=C*D*W*H/A CBK 900

W=W+2 .DO CBK 910

H=H+2 .DO CBK 920

G=G+2 .DO CBK 930

A=A+1 .DO CBK 940

AC=-1 D0*AC CBK 950

AD=P CBK 960

P=AD*E-Q*F CBK 970

Q=Q*E+AD*F CBK 980

A=Y*T+U*Z CBK 990

B=Y*U-T*Z CBK1000

C=Y*V+X*Z CBK1010

D=Y*X-V*Z CBK1020

RETURN CBK1030

A=0 DO CBK1040

B=- 785398163397D0 CBK1050

C-0 DO CBK1060

D=0 .DO CBK1070

CALL vnLL ERROR Lit IWI» (101) \ X V A J CBK1080

RETURN CBK1090

END CBK1100

409-118 OL - 71 - 4

45
SUBROUTINE CHANGE CHA 10

C VERSION 5.00 CHANGE 5/15/70 CHA 20

C CHA 30

C CHANGE SIGNS OF COLS ++, ++, ++, ETC. CHA 40

C CHA 50

COMMON /BLOCRC/ NRC ,RC (12600) CHA 60

COMMON /BLOCKD / IARGS ( 100 ), KIND ( 100 ) ,ARGTAB (100 ), NRMAX , NROW, NCOL , NCHA 70

1ARGS , VWXYZ (8 ) ,NERROR CHA 80

DIMENSION ARGS(IOO) CHA 90

EQUIVALENCE (ARGS (1) ,RC (12501) ) CHA 100

IF (NARGS) 50,50,10 CHA 110

10 DO 30 1=1, NARGS CHA 120

CALL ADRESS (I, J) CHA 130

IF (J) 40,60,20 CHA 140

20 IF (NERROR.NE.O) RETURN CHA 150

DO 30 N=l , NRMAX CHA 160

JJ=J+N-1 CHA 170

30 RC(JJ)=-RC(JJ) CHA 180

GO TO 70 CHA 190

40 CALL ERROR (3) CHA 200

GO TO 70 CHA 210

50 CALL ERROR (10) CHA 220

GO TO 70 CHA 230

60 CALL ERROR (11) CHA 240

70 RETURN CHA 250

END CHA 260

SUBROUTINE CHKCOL (J) CHK 10

C VERSION 5.00 CHKCOL 5/15/70 CHK 20

COMMON /BLOCRC/ NRC,RC(12600) CHK 30

COMMON /BLOCKD/ IARGS (100) ,KIND (100) ,ARGTAB (100) , NRMAX , NROW, NCOL ,NCHK 40

IARGS ,VWXYZ (8) ,NERROR CHK 50

DIMENSION ARGS(IOO) CHK 60

EQUIVALENCE (ARGS (1) ,RC (12501) ) CHK 70

C CHK 80

C THIS ROUTINE CHECKS THAT ALL /NARGS/ ARGUMENTS ARE LEGAL CHK 90

C COLUMN NUMBERS AND CONVERTS THEM IN IARGS TO THEIR BEGINNING CHK 100

C ADDRESSES. CHK 110

IF (NARGS. GT.O) GO TO 20 CHK 120

10 J=l CHK 130

GO TO 40 CHK 140

20 DO 30 I=1,NARGS CHK 150

CALL ADRESS (I, IARGS (I)) CHK 160

IF (IARGS(I) .LE.O) GO TO 10 CHK 170

30 CONTINUE CHK 180

J=0 CHK 190

40 RETURN CHK 200

END CHK 210

46
SUBROUTINE CKIND (J) CKI 10

c VERSION 5.00 CKIND 5/15/70 CKI 20

c CKIND CKI 30

c S PEAVY 5/22/67 CKI 40

c THE FIRST J VALUES OF KIND ARE CHECKED CKI 50

c IF ALL ARE =0 THEN J=0 CKI 60

c IF ALL ARE =1 THEN J=l CKI 70

c IF SOME ARE 0 AND SOME 1 J=2 CKI 80

COMMON /BLOCRC/ NRC , RC ( 12600

)

CKI 90

COMMON /BLOCKD/ IARGS(IOO) ,KIND(100) ,ARGTAB (100 )

, NRMAX ,NROW,NCOL ,NCKI 100

1ARGS,VWXYZ(8) ,NERROR CKI 110

DIMENSION ARGS(IOO) CKI 120

EQUIVALENCE (ARGS (1 ), RC (12501 )

)

CKI 130

JA=J CKI 140

J=0 CKI 150

DO 10 1=1, JA CKI 160

IF (KIND ( I ) .NE.O) GO TO 20 CKI 170

10 CONTINUE CKI 180

RETURN CKI 190

20 J=l CKI 200

DO 30 1=1 , JA CKI 210

IF (KIND(I) .NE.l) GO TO 40 CKI 220

30 CONTINUE CKI 230

RETURN CKI 240

40 J=2 CKI 250

RETURN CKI 260

END CKI 270

SUBROUTINE CMPARA (XI ,X2,X3 ,Y1 ,Y2 ,Y3 ,X,Y) CMP 10

C VERSION 5.00 CMPARA 5/15/70 CMP 20

C PROGRAM CMPARA WRITTEN BY MRS. CARLA MESSINA NBS-NSRDS JUNE 68 CMP 30

C CMPARA IS USED BY THE INSTRUCTION MAXMIN IN PROGRAM CMSEPA CMP 40

A=( (Y2-Y3)*(X2-X1)-(Y2-Y1)* (X2-X3) ) / ( (X2-X1 ) * (X2**2-X3**2 )- (X2-X3 )CMP 50

1* (X2**2-X1**2) ) CMP 60

B=((Y2-Y1)-A*(X2**2-X1**2))/(X2-X1) CMP 70

C=-A*X3**2-B*X3+Y3 CMP 80

X=-B/(2.*A) CMP 90

Y=A*X**2+B*X+C CMP 100

RETURN CMP 110

END CMP 120

47
SUBROUTINE CMSEPA CMS 10

C VERSION 5.00 CMSEPA 5/15/70 CMS 20

COMMON /BLOCRC/ NRC , RC ( 12600 ) CMS 30

COMMON /BLOCKD/ I ARGS ( 100 ), KIND ( 100 ) ,ARGTAB ( 100 ), NRMAX , NROW, NCOL , NCMS 40

1ARGS , VWXYZ (8 ) ,NERROR CMS 50

DIMENSION ARGS(IOO) CMS 60

EQUIVALENCE (ARGS (1) ,RC (12501) ) CMS 70

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG CMS 80

COMMON /SCRAT/ NS ,NS2 , A (13500 ) CMS 90

C L2=2 SEPARATE FROM COL ++ EVERY , , ROW START WITH ROW STORE INCMS 100

C L2=3 INSERT IN COL ++ FROM COL ++ AT EVERY ,, ROW STARTING AS CMS 120

C STORE IN COL ++ CMS 130

C L2=4 MAXMIN X IN ++ Y IN ++ , XMAX IN ++ YMAX IN ++, XMIN ++ YMIN CMS 140

C PROGRAM CMSEPA WRITTEN BY MRS. CARLA MESSINA NBS-NSRDS JUNE 196CMS 150

GO TO (10,10,30,310), L2 CMS 160

10 NARGS=NARGS+1 CMS 170

J=NARGS CMS 180

DO 20 I=2,NARGS CMS 190

IARGS(J)=IARGS(J-1) CMS 200

KIND(J)=KIND(J-1) CMS 210

20 J=J-1 CMS 220

30 CALL CKIND (J) CMS 230

IF (J) 40,70,40 CMS 240

40 K=3 CMS 250

50 CALL ERROR (K) CMS 260

60 RETURN CMS 270

70 IF (NARGS-5) 80,100,80 CMS 280

80 K=10 CMS 290

IF (L2-2) 90,90,50 CMS 300

90 NARGS=NARGS-1 CMS 310

GO TO 50 CMS 320

100 M=IARGS(3) CMS 330

N=IARGS(4) CMS 340

DO 120 1=3,4 CMS 350

IF (IARGS (I ) ) 130,130,110 CMS 360

110 IF (IARGS(I)-NROW) 120,120,130 CMS 370

120 IARGS ( I )=IARGS (1 ) CMS 380

CALL CHKCOL (J) CMS 390

IF (J) 40,140,40 CMS 400

130 K=16 CMS 410

GO TO 50 CMS 420

140 IF (NERROR.NE.O) GO TO 60 CMS 430

IF (NRMAX) 150,150,160 CMS 440

150 K=9 CMS 450

GO TO 50 CMS 460

160 DO 170 I=1,NARGS CMS 470

170 IARGS ( I )=IARGS ( I

) -1 CMS 480

L=IARGS(5) CMS 490

IF (L2-2) 180,180,210 CMS 500

C SEPARATE CMS 510

180 DO 190 1=1 , NRMAX CMS 520

J=IARGS(1)+I CMS 530

190 A(I)=RC(J) CMS 540

DO 200 K=N, NRMAX, M CMS 550

L=L+1 CMS 560

200 RC(L)=A(K) CMS 570

GO TO 60 CMS 580

C INSERT CMS 590

210 M=M-1 CMS 600

48
IF (M) 130,130,220

220 N=N-1

IF (N) 130,130,230

230 KA=0

I=IARGS(1)

DO 240 K=1,N

1=1+1

KA=KA+1

240 A(KA)=RC(I)

NN=KA+IARGS (1)

MM=IARGS(2)

DO 260 K=N , NRMAX , M

KA=KA+1

MM=MM+1 A (KA)=RC (MM)

DO 250 LL=1,M

KA=KA+1

NN=NN+1

250A (KA)=RC (NN)

260 CONTINUE

I=(NRMAX-N) /M+l

IF (I+NRMAX-NROW) 270,270,280

270 NRMAX=NRMAX+I

GO TO 290

280 NRMAX=NROW

CALL ERROR (219)

290 DO 300 K=l, NRMAX

L=L+1

300 RC(L)=A(K)

GO TO 60

310 IF (NARGS-6 ) 80,320,80

320 CALL CHKCOL (J)

IF (J) 40,330,40

330 IF (NERROR.NE.O) GO TO 60

KA=0

IUP=-1

IF (NRMAX) 150,150,340

340 IF (NRMAX-2) 350,350,390

350 IF (KA) 370,370,360

360 CALL ERROR (220)

370 IF (IUP) 380,60,60

380 K=219

GO TO 50

390 DO 400 K=l, NRMAX

I=IARGS(1)+K-1

J=IARGS(2)+K-1

A(K)=RC(I)

K2=K+NRMAX

400 A(K2)=RC(J)

I1=IARGS(3)-1

J1=IARGS(4)-1

K1=IARGS(5)-1

L1=IARGS(6)-1

IF (NRMAX-4) 410,520,520

410 K2=NRMAX+1

IF (A(K2)-A(K2+1) ) 420,380,430

420 IF (A(K2+l)-A(K2+2) ) 380,380,440

430 IF (A(K2+l)-A(K2+2) ) 450,380,380

440 IUP=IUP+1

CMS 610

CMS 620

CMS 630

CMS 640

CMS 650

CMS 660

CMS 670

CMS 680

CMS 690

CMS 700

CMS 710

CMS 720

CMS 730

CMS 740

CMS 750

CMS 760

CMS 770

CMS 780

CMS 790

CMS 800

CMS 810

CMS 820

CMS 830

CMS 840

CMS 850

CMS 860

CMS 870

CMS 880

CMS 890

CMS 900

CMS 910

CMS 920

CMS 930

CMS 940

CMS 950

CMS 960

CMS 970

CMS 980

CMS 990

CMS1000

CMS1010

CMS1020

CMS1030

CMS1040

CMS1050

CMS1060

CMS1070

CMS1080

CMS1090

CMS1100

CMS1110

CMS1120

CMS1130

CMS1140

CMS1150

CMS1160

CMS1170

CMS1180

CMS1190

49
450 T 1 ID T 1 ID . 1

1 Ur=iUr+l A MC 7 O A A b Mo 1 Z 0 0

tr / A / 1 \ A / 9 \ \ /I A A A Q A /I in lr (A(l)-A(Z)) 460,480,460 A MC 7 9 7 A LMolZlO

A / A 4 6 01 r / A / 7 \ A / 9 \ \ JI7A JQA ain lr (A(l)-A(3)) 470,480,470 A MC 7 9 9 A b Wlj 1 z z 0

4 / 0

T C / A / 9 \ k 1 1 \ \ A A A Jl OA ilQA lr (A(Z)-A(3)) 490,480,490 A MC 7 9 5 A b Mb 1230

480 KA=1 A MC 7 9 /I A bMblZ40

A A T A "3 C A bU 1 U 350 A MC 7 9 C A b Mb 1250

J3 A A All I p IAD ADA / A / 1 \ A / 9 \ A / 1 \ A / 1/ 9 \ A / 1/ 9 . 7 \ A / 1/ 9 . 9 \ VI V 7 \ CALL bMrAKA ( A ( 1 ) , A ( 2 ) , A (3 ) , A (K2 ) , A (K2 + 1 ) , A (K2+2 ) , XI , Y 1

)

A MC 7 9 A A bMblZ60

1 r / T 1 ! D \ CAA CAA CIA lr (lUr) 500,500,510 AUC bMb 7 9 7 A 1 2 7 0

500 DP /l/l . 1 \ VI Kb (Kl+1 ) =A i A MC 7 9 O A bMblZoO

Kb(Ll+l)=Yl A MC 7 9 Q A bMb 1290

A A T A A

A

bO IU 60 A MC 7 1 A A bMb 1300

CIA QA / T 1 . 7 \ VI KL ( 1 1+1 )=X1 A mc 111 n b Mb 1 3 1

0

Kb (Ll+1 )=Y1 A MC 137/1 bMbl320

A A T A ifl bU IU 60 A MC 1 11/1 bMb 1330

c "i A 520 T AID AAA V 9 1=NKMAX-Z A MC 1 1A/I bMb 1340

fT^A Tin 1/ 1 T 00 7 30 K=i ,

1

A MC 7 1 C A bMb 13 50

T PAH A I 1 1 tQUAL=l AMC 7 1 A A bMb 1360

Lf o 1/ , MDMA V KZ=K+fliKMAA AbMbl MC 1 7 7(1 i

1

U TC / A

/

V 9 \ A / V9 1 \ \ CIA ilft CAA lr (A (KZ ) -A (K2+1 ) ) 530,610,540 A MC lion b Mb 1 3 O 0

E. 1 A TC / A / If 9 i 7 \ A /I/O . A \ \ 71A 71(1 CCA lr (A (N2+1 ; —A (l\2+2 ) ) /3U,/3U,550 a Mci 7on b IflJ 1)7U

5 4 0 TC /A/1/1. 1\ A/I/O. 0\\ CIA Tlrt =J A lr (A (KZ+1 ) -A (KZ+Z ) ) 560,730,730 A MC T A A A bMbl400

r a

5 5 0

T 1 ID 1 iUr=l A MC l/lin bMbl410

A A T A ETA bO 1 U 5 7 0 A MC 1 A7A bMb 14 20

E A A T 1 ID A 1 Ur=U AMC 7 A1(\

3 / U

1 C / A / 1/ \ A / If i 7 \ \ CQn /Art EQA 1 r (A IN J —A (K+l

J

) 58U , oUU , DoU AMC7 A A ft 5BU I r / A / V \ A / V 9 \ \ CAA / ftrt E Q A lr ( A (K ) —A (K+Z ) ) 590,600,590 AMC lAcn bMb 1450

590 TC / A / 1/ . 1 \ A / 1/ . 1 \ \ /OA Z A A ZQA lr (A (K+l ) -A (K+Z ) ) 680,600,680 A MC 7 A A A bMbl460

/L A A

6 0 U

1/ A ^ A . 7 KA=KA+1 AMC 1 Jl 7 A bMb!4 1 0

PA T A 7 1

A

bU 1 U 7 30 A MC 7 A O A b Mb 1 4 8 0

A 7 A oiO lr ( K—1 ) 730,730,620 A MC 1 VI O A b Mb 1 4 V 0

ion 6/0 T c A.1 1 A 1 "? A MC 1 end b Mb 1500

TC / A / V 7\ A / If \ \ ilA /nft / irt lr (A (K—1 ) —A (K ) ) 630,600,630 A MC 7 c 7 A bMbl 5 10

63 U TC 1 k 1 ii 1\ A / If . 7 \ \ / >1 A /ftft A yS A lr I A (K—1 ) —A (K+l ) ) 640,600,640 A MC 1 con bMb!52U

4 4 A 6>4U TC / A /If 7 \ A / If i 9 \ \ £CA / AA iEA lr (A (K— 1 ) —A (K+Z ) ; 650,60U,oSU AMC ltlfi

TCir 1(AA f(K2If 9 — 11\ A / If 9 \ \ AAA 7 7 A ATA

J —A (KA ) ) OOU , OU , O/U AMC 7 CAft

o (o 0 TC / A / If 9 1 \ A /If 7 i 7 \ \ 71A 7 1 A CCA lr ( A (K2+1 ) —A (KZ+Z ; ) 73U,73U,55U A UC 1 E C A bmo

o / 0 TC / A / If 9 * 1 \ A /If 9 • 9 \ \ CAA 77A 7 1 A lr (A (KZ+1 ) —A (KZ+Z ) ) 560,730,730 AMCl bMbl CAA SOU

£ ® A ooU AA| 1 A MD ADA / A / If \ A / If . 7 \ A / If . 9 \ A / If 9 \ A / If 9 . 1 \ A / If 9 i 9 \ VI VI \ LALL LMPAKA (A (K) ,A (K+l ) ,A (K+Z )

, A (KZ ) ,A (KZ+1 ) ,A (KZ+2 ), Al , YI

)

AMCl c 7 A b Mb 15/0

TC /TCABIAft *i\ 7 A A /Oft / AA lr (ItQUAL-Z) 700,690,690 PbMbMC 1 con 1580

/. 10) A 690 pii i A UD ADA 1 k IV 7 \ A / 1/ \ A / 1/ , 7 \ A / If 9 1 1 A / If 9 \ A / V 9 T A Y7 V9\ LALL LMrAKA (A (K-l )

, A (K) , A (K+I ), A (K2-1 ) ,A (KZ )

, A (KZ + 1 ) ,AZ , YZ

)

AMCl EQn

VI A ct / VI .V*5\ X 1=0 .5 (Xl+XZ

)

C MC 1 A A A bMb 1600

V 1 A / VI .V*7\ Y 1=0 . 5 ( Yl+YZ

)

A MC 7 A 7 A bMb 16 10

T Art

7 00 T C /T0IIT>\ "flirt T 1 A IF (IUP) 710,710,720 A MC 7 A 9 A bMb!620

710 ir h o n A A MC 7 A 1 A bMbl630

K1=K1+1 AMC 7 A A A bMbi640

11 1 1 . 1 L1=L1+1 A MC 7 A C n b Mb 1650

D/* / M 1 \ VI KL (Kl )=X1 A MC 7 A A A b Mb 1 6 6 0

RC (LI )=Y1 A MC 1 A 7 A bMbl670

GO TO 730 A MC 7 A O A brabl680

720 T 1 T 1 1 I 1=1 1+1 A MC 7 A O A bMb 1690

i 7 D 7 . 7 J 1=J 1+1 P MC. 7 7 A A b WlJ 1/UU

nA

/

t 1

1

Kb ( 11 )=X1 A MC 1 71

n

b Mj 1 / i U RC ( Jl )=Y1 A MC 7 7 9 A bMbl 7 20

730 AAUT t ft I II IT COM riKlUE A MC 1 7 1 A bMbl730

jA ^\ jA a -<v (SO It) 350 A MC 7 7 A A bmbl740

EWD CMS1750

50
SUBROUTINE COALES COA 10

C VERSION 5.00 COALES 5/15/70 COA 20

C ACOALESCE AND AAVERAGE COMMANDS COA 30

C WRITTEN BY R. MCCLENON , NSRDS-NBS , NOV. 1969 COA 40

C LI = ACOALESCE L2 = AAVERAGE COA 50

C COMMAND FORM IS — COA 60

C ACOALESCE MATRIX STARTING IN R++ C++ COA 70

C ACOALESCE ON FIRST COL OF ARRAY IN ,

, ++ R=,, C= (( START STORING COA 80

C IN ++ COA 90

C AAVERAGE ON FIRST COL OF ARRAY IN ,

, ++ R=,, C=, , START STORING COA 100

C IN ,, ++ COA 110

C OR COA 120

C ACOALESCE ON ** IN FIRST COL OF ,

, ++ R= (( C= ,

, START STORING COA 130

C IN ,

, ++ COA 140

C AAVERAGE ON ** IN FIRST COL OF ,

, ++ R=, , C=,, START STORING COA 150

C IN ,

, ++ COA 160

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG COA 170

COMMON /BLOCKD / IARGS (100 ), KIND (100 ) ,ARGTAB ( 100 ) ,NRMAX , NROW, NCOL ,NCOA 180

1ARGS ,VWXYZ (8 ) ,NERROR COA 190

COMMON /SCRAT/ NS ,NS2 ,A (13500) COA 200

COMMON /BLOCRC/ NRC,RC(12600) COA 210

DIMENSION ARGS(IOO) COA 220

EQUIVALENCE (ARGS (1) ,RC (12501) ) COA 230

L2=L2-8 COA 240

IF (NARGS-6) 410,10,20 COA 250

10 KL=1 COA 260

1=6 COA 270

CALL CKIND (I) COA 280

IF (1-1) 60,420,420 COA 290

20 KL=2 COA 300

DO 30 J=2,7 COA 310

IF (KIND(J)) 420,30,420 COA 320

30 CONTINUE COA 330

IF (NARGS-8 ) 40,410,410 COA 340

40 IF (KIND(l) ) 420,420,50 COA 350

50 Y=ARGS(1) COA 360

60 KL5=KL+5 COA 370

DO 70 J=KL,KL5 COA 380

IF (IARGS(J)) 430,430,70 COA 390

70 CONTINUE COA 400

LR0W=IARGS(KL+2) COA 410

LC0L=IARGS(KL+3) COA 420

KROW=I ARGS (KL ) COA 430

KC0L=IARGS(KL+1) COA 440

IF (KROW+LROW-NROW-1) 80,80,440 COA 450

80 IF (KCOL+LCOL-NCOL-1) 90,90,440 COA 460

90 MR0W=IARGS(KL+4) COA 470

MC0L=IARGS(KL+5) COA 480

IF (MROW+LROW-NROW-1) 100,100,440 COA 490

100 IF (MCOL+LCOL-NCOL-1) 110,110,440 COA 500

110 IF (NERROR) 400,120,400 COA 510

120 KRR=KR0W+LR0W-1 COA 520

KCC=KC0L+LC0L-1 COA 530

MRR=MR0W+LR0W-1 COA 540

MCC=MC0L+LC0L-1 COA 550

N=0 COA 560

IF (KL-1) 230,230,130 COA 570

130 DO 140 J=2,LC0L COA 580

140 A(J)=0.0 COA 590

51
A(1)=Y

DO 170 J=1,LR0W

I=KR0W+J-1

II=NR0W*(KC0L-1)+I

IF (RC(II)-Y) 170,150,170

150 DO 160 JJ=2,LC0L

I=II+(JJ-1)*NR0W

160 A(JJ)=A(JJ)+RC(I)

N=N+1

170 CONTINUE

IF (N) 460,460,180

180 M=l

GO TO (190,200) , L2

190 DIV=1.0

GO TO 210

200 DIV=N

210 DO 220 JJ=2,LC0L

220 A(JJ)=A(JJ) /DIV

GO TO 380

230 MAT=LCOL*LROW

IF (MAT-NS+LROW) 240,240,450

240 M1=MAT+1

M2=MAT+LR0W

DO 250 J=M1,M2

250 A(J)=0.

M=0

DO 370 J=1,LR0W

M1=MAT+J

IF (A(M1)) 370,260,370

260 K1=LC0L*M+1

K2=LC0L* (M+l)

DO 270 K=K1,K2

270 A(K)=0.0

N=0

L=NR0W*(KC0L-1)+J

Y=RC(L)

A(K1)=Y

DO 300 JJ=J,LROW I I=NROW* (KCOL-1 ) +KROW+J J-l

IF (RC(II)-Y) 300,280,300

280 K3=K1+1

M1=MAT+JJ

A(M1)=1.0

DO 290 K=K3,K2

I=II+(K-K1)*NR0W

290 A(K)=A(K)+RC(I )

N=N+1

300 CONTINUE

IF (N) 370,370,310

310 W=M+1

320 GO TO (330,340) , L2

330 DIV=1.0

GO TO 350

340 DIV=N

350 DO 360 K=K3,K2

360 A(K)=A(K) /DIV

370 CONTINUE

380 DO 390 J=1,M

DO 390 JJ=1,LC0L

COA 600

COA 610

COA 620

COA 630

COA 640

COA 650

COA 660

COA 670

COA 680

COA 690

COA 700

COA 710

COA 720

COA 730

COA 740

COA 750

COA 760

COA 770

COA 780

COA 790

COA 800

COA 810

COA 820

COA 830

COA 840

COA 850

COA 860

COA 870

COA 880

COA 890

COA 900

COA 910

COA 920

COA 930

COA 940

COA 950

COA 960

COA 970

COA 980

COA 990

C0A1000

C0A1010

C0A1020

C0A1030

C0A1040

C0A1050

C0A1060

C0A1070

C0A1080

C0A1090

C0A1100

COA1110

COA1120

C0A1130

C0A1140

C0A1150

C0A1160

C0A1170

C0A1180

52
I=LC0L* ( J- 1)+JJ

I I=NR0W* (MC0L-2+JJ )+J+MR0W-l LUA1190

RC(II)=A(I) C0A1200

390 CONTINUE C0A1210

400 RETURN C0A1220

410 CALL ERROR (10) C0A1230

GO TO 400 C0A1240

A O A 420 CALL ERROR (20) C0A1250

GO TO 400 C0A1260

A1 t\ CALL ERROR (11) C0A1270

GO TO 400 COA1280

A A f\ CALL ERROR (17) C0A1290

GO TO 400 C0A1300

A C ft CALL ERROR (23) C0A1310

GO TO 400 C0A1320

CALL ERROR (203) C0A1330

M=l C0A1340

GO TO 380 C0A1350

END C0A1360

C0A1370

53
FUNCTION COMELL (Z,I) COM 10

C VERSION 5.00 COMELL 5/15/70 COM 20

C COMPLETE ELLIPTIC INTEGRALS - FIRST AND SECOND KIND COM 30

DOUBLE PRECISION Z,X,A,B,C,D,E,P ( Q COM 40

DOUBLE PRECISION FDLOG , FDSQRT , COMELL COM 50

X=Z COM 60

IF (DABS(Z) .LT.l.DO) GO TO 10 COM 70

IF(DABS(Z) .EQ.l.DO.AND.I .EQ.2) GO TO 10 COM 80

CALL ERROR (109) COM 83

Z=O.ODO COM 85

RETURN COM 90

10 A=X COM 100

B=FDSQRT(1 .DO-A) COM 110

IF (X.GT. .996D0) GO TO 50 COM 120

B=(l .DO-B) / (1 .DO+B) COM 130

A=B**2 COM 140

B=1.D0+B COM 150

C=1.D0 COM 160

D=C COM 170

E=2 . DO COM 180

IF (I.EQ.l) GO TO 20 COM 190

B=1.D0/B COM 200

D=-1.D0 COM 210

20 P=A COM 220

DO 30 N=l,90 COM 230

C=C+P*(D/E)**2 COM 240

P=P*A*(D/E)**2 COM 250

IF (P.LT..1D-9) GO TO 40 COM 260

D=D+2.D0 COM 270

30 E=E+2.D0 COM 280

40 A=B*C*1 .570796326D0 COM 290

GO TO 70 COM 300

50 A=FDL0G(4.0D0/B) COM 310

Q=B**2 COM 320

IF (I .GT.l) GO TO 60 COM 330

B=.25D0* (A-l.DO) COM 340

C=.140625D0*(A-1.666666666D0) COM 350

D=9.765625D-2*(A-1.233333333D0) COM 360

E=1255.D0*(A-1 .27904761904D0) / 16384. DO COM 370

A=A+Q* (B+Q* (C+Q* (D+Q*E) )

) COM 380

GO TO 70 COM 390

60 B=.5D0* (A-.5D0) COM 400

C=.1875D0*(A-1.083333333D0) COM 410

D=.1171875D0*(A-1.2D0) COM 420

E=175.D0*(A-1.251190476D0)/2048.D0 COM 430

A=1.+Q*(B+Q*(C+Q*(D+Q*E))) COM 440

70 COMELL=A COM 450

RETURN COM 460

C COM 470

EM) COM 490

54
CIIDDDIITTMP P fi MP 1 Y oUtJKUUI INC. L.UNIrLA pay X u L X/PDCTHM 5 nn POMP! Y E/ic/Tn 90

c-L- ***** POMMflN ***** V/ u nn (flu ll rox 30

COMMON /BLOCRC/ NRC ,RC (12600) COX 40

COMMON /BLOCKD / IARGS(IOO) ,KIND(100) ,ARGTAB(100) , NRMAX ,NR0W,NC0L ,NC0X 50

1 ARG<\ VWXY7rfn MFRRflR rox AO

UlUlLliJlvli nnuj \ lUv J COX 70

EQUIVALENCE (ARGS (1) ,RC (12501)

)

COX oftOu COMMON /SCRAT/ NS , NS2 , A (13500

)

cox 907 U COMMON /BL0CKE/ NAME (4) ,L1 ,L2 , ISRFLG cox 1x 00u u COMMON /C0NSTS/ PI ,E ,HALFPI ,DEG ,RAD ,XAL0G cox 1X1'

p ***** cox 190 i c \j DIMENSION KK(6) cox 1 30

EQUIVALENCE (11 , IARGS (1) ) , ( 1 2 , 1 ARGS (2 ) ) , ( 13 , IARGS (3 )

)

, (I4,IARGSC0X 1 40

1(4)), (I5,IARGS(5)) , (I6,IARGS(6)) cox X1 J50w DOUBLE PRECISION D (5 ) ,X , Y , FDC0S , FDSIN , FDSQRT cox 1 AO

p ***** cox x170/ u p WRITTEN BY DAVID H0GBEN , SEL, NBS . 4/24/70 cox lOU 1 RO

p CADD (E).(E), TO (E) , (E) AND PUT IN COLUMNS (C),(C) cox X1 907 V p CSUBTRACT (E) . (E) , FROM (E) , (E) AND PUT IN COLUMNS (C)

,

(C) cox 900

p C MULTIPLY (E),(E) BY (E) , (E) AND PUT IN COLUMNS (C),(C) cox 910

p CDIVIDE (E),(E) BY (E) , (E) AND PUT IN COLUMNS (C),(C) cox 990

p CRECTANGULAR R IN (E) THETA IN (E) , PUT X IN COL (C) , Y IN COL (C)COX 930

p CP0LAR OF X IN (E) Y IN (E) PUT R IN COL (C) THETA IN COL (C) cox 940

r cox 950

p FIRST ARGUMENT OF EACH PAIR IS REAL SECOND IS IMAGINARY cox 9towAO

p cox 970

p VALUES OF L2 ARE *** cox 9RO

p 1=CADD, 2=CSUB, 3=CMULT, 4=CDIV, 5-CRECTAN 6=CP0LAR COX 990 £ 7 U p cox 300

p NARGS = 6 FOR ADD , SUB , MULT , DIV cox 3 1 n p NARGS = 4 FOR CRECTANGULAR AND CP0LAR cox 390

p ***** cox 330

p ERROR CHECKING cox 340

IF (NARGS NE 6 AND L2 LT 5) CALL ERROR (10) cox 350

IF (NARGS NF 4 AND L2 GT 4^ CALL ERROR (10^ cox 3 AO

IF (KIND (NARGS) . NE . 0 . AND . KIND (NARGS-1 ) .NE .0) CALL ERROR (20) cox 370

IF (NRMAX. EQ.0) CALL ERROR (9) cox 3R0

DO 30 1=1, NARGS cox 3Q0

KK(I)=1 cox 400

CALL ADRESS (I,IARGS(I)) cox 410 t X V IF (IARGS(I)) 20,40,30 cox 490 *T 4. U

9(1 KK(I)=0 cox 430

IARGS(I)=-IARGS(I) cox 440

3n CONTINUE cox 450

GO TO 50 cox 4A0

tu CALL ERROR (11) cox 470

IF (NERROR.NE.O) RETURN cox 4R0

JJ=IARGS(NARGS)+NRMAX-1 cox 4Q0

IF (L2.GT.4) GO TO 140 cox 500

DO 130 1=16, JJ cox 510 -JAW DO 60 J=l ,4 cox 590

MM=IARGS(J) cox 530 J J V An D(J)=RC(MM) cox 540

GO TO (70,80,90,100) , L2 cox J550J VI p CADD cox 560

7n/ u X=D(1)+D(3) cox 570

Y=D(2)+D(4) cox

GO TO 120 cox 590

55
c CSUBTRACT COX 600

80 X=D(3)-D(1) COX 610

Y=D(4)-D(2) COX 620

GO TO 120 COX 630

C CMULTIPLY COX 640

90 X=D(1)*D(3)-D(2)*D(4) COX 650

Y=D(1)*D(4)+D(3)*D(2) COX 660

GO TO 120 COX 670

C CDIVIDE COX 680

C ZERO RETURNED IF DIVISION BY ZERO, DIAGNOSTIC GIVEN. ERR0R(104). COX 690

100 D(5)=D(3)**2+D(4)**2 COX 700

IF (D(5) .GT.O . ) GO TO 110 COX 710

CALL ERR0R(106) COX 720

X=0.0D0 COX 730

Y=0.0D0 COX 740

GO TO 120 COX 750

110 X=(D(1)*D(3)+D(2)*D(4))/D(5) COX 760

Y=(D(3)*D(2)-D(1)*D(4))/D(5) COX 770

120 RC(I5)=FDPC0N(X) COX 780

RC(I)=FDPCON(Y) COX 790

I1=I1+KK(1) COX 800

I2=I2+KK(2) COX 810

I3=I3+KK(3) COX 820

I4=I4+KK(4) COX 830

130 I5=I5+KK(5) COX 840

RETURN COX 850

C CRECTANGULAR AND CPOLAR COX 860

140 MM=L2-4 COX 870

DO 260 1=14, JJ COX 880

D(1)=RC(I1) COX 890

D (2 )=RC (12) COX 900

GO TO (150,190) , MM COX 910

C CRECTANGULAR - R,THETA TO X,Y COX 920

150 IF (RC(I1)) 180,160,180 COX 930

160 X=0 .ODO COX 940

170 Y=O.ODO COX 950

GO TO 250 COX 960

180 X=D(1)*FDC0S(D(2)

)

COX 970

Y=D(1)*FDSIN(D(2)) COX 980

GO TO 250 COX 990

C CPOLAR X,Y TO R,THETA C0X1000

190 IF (RC ( 12 ) ) 220,200,220 C0X1010

200 IF (RC(I1)) 210,160,210 C0X1020

C Y=0, X NE 0 C0X1030

210 X=DABS(D(1)) C0X1040

GO TO 170 C0X1050

220 IF (RC(I1) ) 240,230,240 C0X1060

C X=0, Y NE 0 C0X1070

230 X=DABS (D (2)

)

C0X1080

C IF X=0.0, THEN THETA=HALFPI*SIGN (Y) C0X1090

Y=SIGN (HALFPI ,RC(I2)) COX1100

GO TO 250 C0X1110

240 X=FDSQRT(D(1)**2+D(2)**2) C0X1120

Y=DATAN2 (D (2 ) ,D (1)

)

C0X1130

250 RC(I3)=FDPC0N(X) C0X1140

RC(I)=FDPCON(Y) C0X1150

I1=I1+KK(1) C0X1160

I2=I2+KK (2

)

C0X1170

260 I3=I3+KK(3) C0X1180

RETURN C0X1190

END C0X1200

56
SUBROUTINE CORREL COR 10

c VERSION 5.00 CORREL 5/15/70 COR 20

COMMON /BLOCKD / IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX ,NROW,NCOL ,NCOR 30

1ARGS,VWXYZ(8) ,NERROR COR 40

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG COR 50

COMMON /BLOCRC/ NRC , RC ( 12600

)

COR 60

DIMENSION ARGS(IOO) COR 70

EQUIVALENCE (ARGS (1 ) ,RC (12501 ) ) COR 80

COMMON /HEADER / NOCARD (80) , ITLE (60 , 6) , LNCNT , I PR I NT ,NPAGE , I PUNCH COR 90

COMMON /SCRAT/ NS ,NS2 ,A (13500) COR 100

DIMENSION ERR (3 ) , AVG(IOO), SD(IOO), T(100) COR 110

EQUIVALENCE (A ( 13301 ), AVG ( 1 ) ) , (A ( 13401 )

, SD ( 1 )

, T ( 1 )

)

COR 120

L2=L2-10 COR 122

IF (L2.EQ.1.0R.NARGS.NE.IARGS(1) +1) GO TO 10 COR 124

CALL ERROR (233) COR 126

RETURN COR 128

10 MVAR=99 COR 130

IF (NARGS.LT.3) CALL ERROR (10) COR 140

NVAR=IARGS(1) COR 150

IF (NVAR.LT.2.0R.NVAR.GT.MVAR) CALL ERROR (3) COR 160

KEEP=(NARGS-NVAR+l)/2 COR 170

IF (KEEP . LT . 1 .OR .KEEP .GT . 3 .OR .MOD (NARGS-NVAR 2 ) .EQ . 0 ) CALL ERROR COR 180

110) COR 190

GO TO (40,30,20) , KEEP COR 200

20 K2=IARGS(NVAR+4) COR 210

IF (K2.LT.1.0R.K2.GT.NR0W) CALL ERROR (16) COR 220

IARGS(NVAR+4)=1 COR 230

30 Kl=IARGS(NVAR+2) COR 240

IF (K1.LT.1.0R.K1.GT.NR0W) CALL ERROR (16) COR 250

IARGS(NVAR+2)=1 COR 260

40 CALL CHKCOL (J) COR 270

IF (J.EQ.O) GO TO 50 COR 280

CALL ERROR (11) COR 290

RETURN COR 300

50 GO TO (80,70,60) , KEEP COR 310

60 IARGS (NVAR+4)=IARGS (NVAR+5 )+K2-l COR 320

70 IARGS (NVAR+2 )=IARGS (NVAR+3 )+Kl-l COR 330

80 LOTTE=NVAR*NVAR COR 340

KURT=2*L0TTE COR 350

C LOT IS SPACE IN ARRAY A RESERVED FOR RANKED DATA COR 360

LOT=MAXO (NRMAX* (NVAR+1) ,3*L0TTE+8*NVAR+8 ,4*L0TTE) COR 370

IF (NRMAX. LT. 3) CALL ERROR (9) COR 380

IF (NRMAX*NVAR.GT.NRC) CALL ERROR (15) COR 390

IF (MAXO (LOT+LOTTE+100 ,NRMAX*4+3*L0TTE) .GT .NS) CALL ERROR (23) COR 400

IF (NERROR.NE.O) RETURN COR 410

NVA=NVAR-1 COR 420

IF (L2.EQ.2) GO TO 130 COR 430

C RANKS OF OBSERVATIONS COR 440

IND = NVAR *NRMAX+1 COR 450

DO 90 I=1,NVAR COR 460

K1=(I-1)*NRMAX+1 COR 470

K2=IARGS(I+1) COR 480

90 CALL RANKX (NRMAX ,RC (K2 )

, A ( IND) , A (Kl ) ,T ( I )

)

COR 490

C SPEARMAN RANK CORRELATION COEFFICIENT COR 500

F=( (NRMAX-1 ) *NRMAX* (NRMAX+1) ) /6 COR 510

I1=L0T+L0TTE COR 520

A(I1)=1. COR 530

DO 120 J=1,NVA COR 540

IND=(J-1)*NVAR+L0T COR 550

57
T 1 T KB

n . 1 1 1=1 NU+Jpnd c/ft

A ( 1 1 )=1 . A f\

R£T f\ COR 570 I J=J+1 COR 580

r\A innT Tl KIV/AD DO 120 1 = 1 J ,NVAK OAR

c ft ft LUR 590

T 1 T Kin . T I 1=1ND+1 nnn / ft ft LUR 600 T 1 / T 1 \ *M\/AD I.I AT 1 2= ( 1-1 ) NVAK+J+LU 1

nnn

x i

ft LUR 610

l/i ft sfcT / T\ . AA K1=Z .1 ( 1 ) +0 . 4

Ann /in LUR 6Z0

I/O 1 #T / 1 \ . AA KZ=Z .1 ( J ) +0 . 4PnD i in LUK 630 i r / T C T Y ^ C \ 1 P T A AMD ICTV / C\ V t i 1 r (lrlA(r) —M .LI . U . AIMU . 1 r 1 A ( r ; —l\Z . 1 pt ni b 1 . U ) bU 1 U 1UU PAD C A f\ LUK 64U A / T 1 \ A A ( 1 1 ) =0 .

PAD / cn LUR 650

aAxA inn GO TO 120

A

A

O f f ft LUR 660

100 r\

a D=0 . OAR / ~n ft COR 670

nn i i n 1/ i mdmav UU 110 K=l ,

NKMAa

AAD /OA LUR 680

1/1 / T 1 \ * (VID h#AV . 1/ K1=(1-1)NKMAX+K PADLOA LUR 690

I/O / I 1 \ * MDMAY i V Is. 2= ( J — 1 ) NKIVIA a+i\ PAD 7nn LUK /UU 1 10 D=D+(A(K1)-A(K2) ) * (A (Kl )-A (K2 ) )

PAD 71

n

LUK 710

A(I1)=(F-D-T(I)-T(J))/(FSQRT(F-2.*T(I))* rbQK 1 (r—

L . 1 ( J ) ) )

PAD 7 OA LUK /ZU

IF (ABS(A(I1) ) .GT.l . ) A(I1)=AINT(A(I1) )

PAD 7in LUK 730

120A ( 1 2 ) =A ( 1 1 ) nnn ~n

a ft LUK 740

pL MEANS OF OBSERVATIONS PAD 7 C

A

LUK 750

13U nn i t—l nvar PAD 7 Z.

A LUK 760

AVG (H-0 nnn -7 ~i r\ LUK 770

SUMPOS-0

AA

D 1 ft ft LUK 780

SUMNEG-0 nnn ^ a

a LUK 790

no 140 1—1 NRMAY PHD QAH LUK oUU 1 l=lMi\l3j ( l +1 ; — l+J PAD 01 n

LUK olU

^IIMPnC—<^l IM.pnC-i_AM.AY1 CRT I T 1 ^ (\ ^ A

AO flln LUK 820 1i4uA (\ jU IVIIilCVa— OUIVIIHCo+MIVIH A 1 \—i\U \ 1 X J ,U . j pad oin LUK o^U

*ica 150 HVU AX/ft 1\ 11 \) —= l( jUIVIr IMP HQU j —JUIVHM IMNFfl c.u

N / Fl P, AT f NRMAY ) / rLUHl ^ liliMVIHA ) A

AD ftA ft LUK 840

L ^TAMnADn j 1 AIM UMrv U nFVTATTnNC UlV 1M 1 iUliJ

AAD OCA LUK 850

nn 1 7 AT 1 MWAD UU 1/U 1 =1,IMVAK PAD

OLA LUK 860

cn i t\n bU ( 1 ) =U . A

AD OTA LUK 870

nn 1 Ut\ 1 1 MDMAY UU 16U J =l , IMKIVIAA PAD

OOA LUK 880

T 1 T ADPC il.li Til 1 1 = 1 AKbb ( 1 +1 ) — l+J PAD OQ

A

LUK 07U

lou cn/ii _cn / t

\ _i_ / or / t i \ avg /T\\*/Rr/Tii -AVG ( I ) )

pad bUK onn 7UU 1 T A 170 bU ( 1 )=rbtiK 1 (bU ( 1 ) ) PAD nin LUK 910 pL CbllvlrLt T MD 1 C rnDDCI ATinM rncrcTPTCMT LUKKtLAIlUlM UUtr r 1 1/ 1 tIM 1 pad oon LUK 7£U A / 1 nTTC \ 1 A ( LU 1 1 t )=I .

pad LUK om93U 7 CI AAT / MDfkMV O \ Z=rLUAI (NKMAX—i.) PAD njin LUK 940

nnUU onn tUU i— i mua J =X,I»VM PAD OCA LUK 7DU

IND=(J-1)*NVAR PAD flirt LUK 96U

I1=IND+J PAD Q7A LUK 9/U

A(I1)=1. nnn

n

aA LUK 980

IJ=J+1

AAD AAA COR 990

DO 200 I=IJ,NVAR

A AD 1 AAA LUK1000

I1=IND+I

A AD 1 A 1 A LUK101U

I2=(I-1)*NVAR+J

A AD 1 AOA LUK1U20

IF (SD(I) .GT.0. .AND.SD(J) .GT.0.) GO TO 180

A AD 1 A 1 A LUKlOiO

A(I1)=0.

AAO 1 ftA ft LUK1040

GO TO 200 PAD 1 A

CA LUK1050 i o a 180 SUMP0S=0. PAD1 A L A LUK1U6U

SUMNEG=0. PAD 1 A 7 A LUK10 70

DO 190 K=l , NRMAX pad LUKlUoU i n on K1=IARGS(I+1)-1+K PAD 1 AO ft LUKIU7U

K2=IARGS(J+1)-1+K pari inn

CP=(RC(K1)-AVG(I) )*(RC(K2)-AVG(J) )

rnp i 1 1 n

1>UI\XXx

u SUMP0S=SUMP0S+AMAX1 (CP , 0 . )

pad lion 1i on7U SUMNEG=SUMNEG+AMAX1 (-CP , 0 . )

TORI 1 30

A(I1)=(SUMP0S-SUMNEG)/(SD(I)*SD(J) )

C0R1140

58
IF (ABS (A ( 1 1 )

) .GT.l.) A (11) =AINT(A(I1)

)

C0R1150

200 A(I2)=A(I1) C0R1160

IF (NVAR.LE.2) GO TO 210 C0R1170

C PARTIAL CORRELATION COEFFICIENT C0R1180

CALL INVCOR (A (1 ) ,NVAR , NVAR , A (LOTTE+1 )

, NVAR+2 , A (1 ), 1 ,ERR , IND

)

C0R1190

IF (IND.EQ.O) GO TO 220 C0R1200

WRITE (IPRINT,480) C0R1210

210 KEEP=MIN0(KEEP,2) C0R1220

A (LOTTE+1 )=0. C0R1230

IF (L2.EQ.1) GO TO 300 C0R1240

GO TO 420 C0R1250

220 DO 230 J=2,NVAR C0R1260

K1=2*(J-1) C0R1270

K2=L0TTE+(J-1)*NVAR C0R1280

DO 230 I=1,NVAR C0R1290

I1=K2+I COR1300

I2=I1+K1 C0R1310

230 A(I1)=A(I2) C0R1320

DO 240 J=1,NVA C0R1330

IND=L0TTE+(J-1)*NVAR C0R1340

K1=IND+J C0R1350

IJ=J+1 COR1360

DO 240 I=IJ,NVAR COR1370

K2=L0TTE+(I-1)*NVAR+I C0R1380

I1=IND+I C0R1390

I2=L0TTE+(I-1)*NVAR+J COR1400

A(I1)=-A(I1)/(FSQRT(A(K1))* FSQRT (A (K2) )

)

C0R1410

IF (ABS(A(I1) ) .GT.l.) A(I1) =AINT(A(I1)) C0R1420

240 A(I2)=A(I1) C0R1430

DO 250 I=1,NVAR C0R1440

I1=L0TTE+(I-1)*NVAR+I C0R1450

250 A(I1)=1. C0R1460

IF (L2.EQ.2) GO TO 420 C0R1470

IF (NRMAX.LE.NVAR) GO TO 300 C0R1480

C SIGNIFICANCE LEVEL OF PARTIAL CORRELATION COEFFICIENT C0R1490

Z=FLOAT (NRMAX-NVAR

)

C0R1500

DO 290 J=1,NVAR C0R1510

IJ=(J-1)*NVAR+L0TTE C0R1520

IND=IJ+KURT C0R1530

DO 290 I=J,NVAR C0R1540

Il=IND+I COR1550

I2=(I-1)*NVAR+J+3*L0TTE C0R1560

K1=IJ+I C0R1570

IF (A(K1)) 270,260,270 C0R1580

260 A(I1)=1

.

C0R1590

GO TO 290 C0R1600

270 IF (ABS(A(K1)) .LT.l.) GO TO 280 C0R1610

A(I1)=0. COR1620

GO TO 290 C0R1630

280 F=A(K1)*A(K1) C0R1640

F=Z*F/(1.-F) C0R1650

CALL PROB (1. ,Z,F,A(I1)) COR1660

290 A(I2)=A(I1) C0R1670

300 Z=FLOAT (NRMAX-2

)

C0R1680

DO 340 J=1,NVAR COR1690

IJ=(J-1)*NVAR C0R1700

IND=IJ+KURT C0R1710

DO 340 I=J,NVAR C0R1720

I1=IND+I C0R1730

59
To / T 1 \ # Al W A D . I.I/IIDT

1 2= ( 1-1 ) *NVAK+J+KUK

1

A A D 1 T A A LUK1740

1/ n T 1 . T PAD 1 7 C A LUK1750

lr (A(K1)) 320,310,320 PAD 1 7 L A LUK1760

310 A ( 1 1 )=1

.

A A D 1 7 H A LOK1770

A A X A O x n GU IU 340 A A D 1 7flrt LOK1780

320 T C /ADC / A / I/I \\ IT 1 \ PA TA lin lr ( Abb ( A (Kl ) ) . L 1 . 1 . ) bU IU 330 A A D 1 "7 A A L0K1790

A / T 1 \ A A ( 1 1 )=0

.

A AD 1 O A A LOKloOO

pA T A 7 A A bU IU 340 A AD 1 Ol A LUK 1810

inn 330 C A/I/1\*A/I/1\ r=A (M) A(Kl) A AD 1 O O A LOKloZO

r 7 * C / / 1 C \ r=Z*r / (1 .-r

)

A AD 1 O 1 A UUK loi U PAI 1 DD AD /I 7 C A/T1\\ LALL PKUd (l.,Z,r,A(ll)) A A D 1 O A A L0K1840

"5 A A 340 A ( 1 2

) =A ( 1 1

)

A AD 1 OCA LOK1850

p

L CTDCT DDTMTIMT CTAPC iCTr DAP CTPAITCTPAAIPC 1 CWCI C CDPP\ r I Kb 1 rKlNllNb b 1 Abb ( bLL , rLL , b 1 bN 1 r 1 LANLt LtvtLb , bKLL) A A D 1 O L A LOKlooO

M 1 A 1 NLA=1 A AD 1 O 7 A LOKlo/0

PAII D A P C t A \ LALL rAbt (4)

A A D 1 O Q A LOKlooO

UIDITC /TDDTAIT A A A \ All/AD AIDAIAV WK1IL ( 1 HK IN 1 , 490 ) NVAK, NKMAX A AD 1 OOA UOK1890

PAII UT CT / Al W A D A/l\ 1 AHA 1\ LALL Mlbl (NVAK , A ( 1 ) , 1 , NLA , 1

)

A AD 1 AAA L0K1900

PAII LIT CT / All/ A D A / 1/ 1 IDT . 1 \ 1 AHA 7 \ LALL Mlbl (NVAK , A (KUK 1 +1 )

, 1 , NLA , 2

)

A AD 1 AT A L0K1V10

TC (All (1TTC i 1 1 | r n \ p A TA 5tn lr ( A ( LU 1 1 t + i ) . Lt . 0 . ) bU IU 350 A AD 1 O 1

A

U0K1V20

PAII UICT 1 Al \/ A D A/IATTCill 1 Ml t 7 \ LALL Mlbl (NV AK , A ( LU 1 1 t + 1 ) , 1 , NLA , 5 ) pno loin l/OKl V30

C ADC / A II AVI / COD / 1 \ rnD / 1 l CDD/7\\\ r=Abb (AMAXl(tKK(l) , tKK (2 ) ,tKK(3) )

)

A A D 1 A A A LUK1940

p C A 1 1 AUJTAIP CTATC AIC AIT 111 T 1 1 DC DCCTADCfl 1 ATCD rULLUWINb b 1 A 1 tMtN 1 WILL bt KtblUKtU LA 1 tK A AD 1 A C A LUK1950

pL

win T TC /T DDT AIT AC\ C WK 1 1 1 ( IrKIN 1 , 45 ) r PAD! Q £ A LUK1960

pL AC CADMAT / / 1 U 77UCDDAD DAIIAIA CAD TAIWCDCTAAI AC AIATDTV AC 45 rUKMAI (/In , 72HtKKUK bUUNU rUK INVtKblUN Ur MAIK1X Ur C T AID 1 C PADIOTA blMrLt LUK1970

pL1lKtLAIlUN DCI ATTAAl PACCC LUtrrlLltNIb T P T CWTC C 1 A A\ =, C14.4) PAD 1 Q o n LUKlVoO

All A All A . 7 NLA=NLA+2 PAD 1 A A

A

LUK1990

TC /AIDAIAV 1 C AI\/AD\ PA TA 7CA lr (NKMAX . Lt . NVAK ) bU IU 350 PAD 1 A A A LUK2000

PAII UICT /All/ AD A/7*IATTC.1\ 1 AHA A \ LALL Mlbl (NVAK , A (3 LU 1 1 1+1 ) , 1 , NLA , 4

)

P AD 1 A 1 A LUK2010

350 PAII LA T CT /AIWAD A/I AT . 1 \ 1 Al 1 A C \ LALL Mlbl (NVAK , A (LU 1 +1 )

, 1 , NLA , 5

)

P AD 1 A

A

LUK2020

TC /AIDAIAV PT 7\ PA TA 1 £. f\ lr (NKMAX. bl .3) bU IU 360 P AD 1

A

1 A LUK2030

IAIDTTC /T DDT AIT CAA\ AIDAIAV WKlIt ( 1 KK 1 N 1 , 500 ) NKMAX P AD 1 A Jl A LUK2040

PA TA A 7

A

bU IU 420 PAD 1 A C A LUK2050

1 L A 360 "7 CI AAT/AIDAJAV 7\ £=rLUAI (NKMAX-3) P A D O A L A LUKZ060

TAin 7 * 1 ATTC .AIDAIAV . 1 1NU=3 LUI 1 t+NKMAX+1 P AD 1 A T A LUKZ070

da Ann i i aii/ a

d

UU 400 J=1,NVAK pad 0 non

Ti T A DP C / 1 . 1 \ 1 1=1 AKbb ( J+l

)

P AD 1 A A A LUK2090

TI /I 1 \ * All/ A D

1 J= ( J-l ) NVAK P AD 1 1 A A LUK2100

l\A i An T i All/ AD UU 400 1=1,NVAK P AD O 1 1 A LUKZ110

TC /T AIC l\ A A TA 17rt lr (l.Nt.J) bU IU 3/0 PAD*) 1 OA LUK11Z0

TI l/IIDT.T 1. 1 1 2=I\UK 1 +1J+J PAD O 1 7 A LUK1130

A / T A \ 1! A(I2)=1. P AD O 1 /I A LUK2140

A A TA A A A GO 10 400 PADO T C A LUK2150

1 "T A 370 T A T A D A C / T 1 \ 1 I2=IARGb ( I +1 ) —

1

prtnfti / a LUK2 160

nA i o a i/ i hiDiJAV DO 380 K=l, NKMAX P AD 1 1 7 A LUK2170

1/1 1/ , TO K1=K+1

2

P AD O 1 OA LUK2180

1/ A 1/ 1 * n ATTC K2=K+3*L0 1 1

t

PADO 1 A

A

LUK2190

*> A A 380 A / 1/ A \ DjA/I/IV A (K2 )=RC (Kl

)

P AD 1 *> A A LUK2200

TA l/MDT.T I.T LUKZZ10

AAII D 1 ADAl/ / D A / T l v A / ATTC . 1 \ AID MA V A / T Al A \ C \ CALL BJORCK (RC (11) , A

(3 'LOT T t+1

)

( NKMAX , A ( 1ND )

, r

)

PAD 1 O O A LUK2220

TC /C AT A \ AA TA O A A IF (F.GT.0.) GO TO 390 p AD o 7 in LUKZZ^O

A / T O \ 1 A(I2)=1

.

A A T A A A A GO TO 400 PADO 1 C

A

LUKZZ5U

1 A A 390 A A 1 1 AD AD / 1 7 C A / T A \ \ CALL PR0B (1 . ,Z , r , A ( 12 )

)

PAD 7 7 £. A LUKZ260

A A A 400 A AAIT T All IC CONTINUE PAD 7 O 7 A LUKZZ70

AAII lit CT /All/ AD A/l/llDT 1\ A All A L\ CALL MIST (NVAR , A (KURT+1 )

, 0 ,NLA , 6

)

PAD 7 7 O A LUK2Z80

L

P AAIC T nCAIPC 1 TIITTC cad C T AID 1 C PADDCI ATTAAl PACCCTPTCaIT LUNrlUtNLt L 1 Ml lb r UK blMrLt LUKKtLA 1 1 UN LUthrlLltNl A AD 7 7 A A LUK££7U

C CCrtDT / CI AAT/AID AAA V 7 \ \ F=rbQKI (FLOAT (NRMAX-3)

)

PAD 7 I AA L-UKZ j00

Ml 1—9 l»7Qfl9Q1/P n l L—L . o i jo t.7 j / r HL2=1.9599640/F COR2320

60
410

420

C

430

440

450

460

470

C

480

490

500

SCC CONFIDENCE LIMITS (99 PER CENT LEVEL)

A(3*L0TTE)-99.

A(5*L0TTE)=95.

DO 410 J=1,NVA

IND=(J-1)*NVAR

K1=IND+J+KURT

K2=K1+KURT

A(K1)=99.

A(K2)=95.

IJ=J+1

DO 410 I=IJ,NVAR

INDEX OF SCC

Il=IND+I

INDICES OF UPPER, LOWER

K1=(I-1)*NVAR+J+KURT

K2=K1+KURT

Z=.5*FL0G((1.+A(I1))/(1.-A(I1)))

A (Kl )=AMIN1 (FTANH (Z+HL1 )

, 1 .

)

A (K2 )=AMAX1 (FTANH (Z-HL1 ) ,-1.)

INDICES OF UPPER, LOWER SCC CONFIDENCE

K1=I1+KURT

K2=K1+KURT

A (K1)=AMIN1 (FTANH (Z+HL2 )

, 1 .

)

A (K2 )=AMAX1 (FTANH (Z-HL2 ) ,-1 .

)

CALL MIST (NVAR ,A (KURT+1 ) ,0 ,NLA ,7

)

GO TO (470,450,430) , KEEP

STORE SIMPLE AND PARTIAL CORRELATION COEFFICIENTS

I 1=MIN0 (NVAR, NCOL-( IARGS (NVAR+5)-l) /NROW)

I 2=MIN0 (NVAR ,NROW-( IARGS (NVAR+4 ) -IARGS (NVAR+5) )

)

IF (II. LT.NVAR.0R.I2.LT. NVAR) CALL ERROR (213)

DO 440 J=1,I1

DO 440 1=1,12

K1=(J-1)*NVAR+I+L0TTE

K2=IARGS(NVAR+4)-l+(J-l)*NR0W+I

RC(K2)=A(K1)

I 1=MIN0 (NVAR , NCOL- (IARGS (NVAR+3 ) -1 ) /NROW)

I 2=MI NO (NVAR , NROW- (IARGS (NVAR+2 ) -IARGS (NVAR+3 ) )

)

IF (II. LT.NVAR.0R.I2.LT. NVAR) CALL ERROR (213)

DO 460 J=l ,11

DO 460 1=1,12

K1=(J-1)*NVAR+I

K2=IARGS (NVAR+2 )-l+( J-l ) *NROW+I

RC(K2)=A(K1)

RETURN

LIMITS (95 PER CENT LEVEL)

IN WORKSHEET

(1H ,32X,54HMATRIX IS SINGULAR. NO PARTIAL CORRELATIONS

)

FORMAT

IMPUTED

FORMAT (/30X,24HC0RRELATI0N ANALYSIS F0R,I3,15H VARIABLES

113H OBSERVATIONS)

FORMAT (1H ,18X,83HN0NLINEARITY TEST AND APPROXIMATION OF

ICE INTERVALS NOT DEFINED FOR NRMAX =,12)

END

C0R2330

C0R2340

C0R2350

C0R2360

C0R2370

C0R2380

C0R2390

C0R2400

C0R2410

C0R2420

C0R2430

C0R2440

C0R2450

C0R2460

C0R2470

C0R2480

COR2490

C0R2500

C0R2510

C0R2520

C0R2530

C0R2540

C0R2550

C0R2560

C0R2570

C0R2580

C0R2590

C0R2600

C0R2610

C0R2620

C0R2630

C0R2640

C0R2650

C0R2660

C0R2670

C0R2680

C0R2690

COR2700

C0R2710

C0R2720

C0R2730

C0R2740

C0R2750

C0R2760

C0C0R2770

COR2780

WITH,I5,COR2790

COR2800

C0NFIDENC0R2810

C0R2820

C0R2830

409-118 OL - 71 - 5

61
CIIGDnilTIMC rCDTMW /A U l//lf IC If \ bUBKUUIlNt CbPlNV ( A

,

m

,

KK , 1 b lb

)

CSP 10

c \/COCTAM C A A PCDTMW C / 1 c (7ft VtKblUN 5.00 CbPlNV 5/15/70 f\ C r\ CSP 20

AC TACQMT MATDTY TMUCDCinM UITTU UTMTUIIU DnilkinnCC rnnnn APPIIMIII ATTPkl 7058M1 MAIK1A INVtKblUN W1IH MINIMUM KUUNUUr r LKKUK ACLUMULA 1 1 UN .CSP 30

PPUUPM /PP. Ml DO /CD TCTPn 1>UMMUN /UUNLD2/tK, 1 b 1 uu A C D C5P 35

a AT A PMC/1 a; 7CDP/ft ni UA 1 A UNt / 1 . U / , /LtKU / U . 0 / PCD C5P A A 40

nTMCMCTAM A/l\ v l mt.no l UN A (i

)

C5P 50

T C T P n PCD CbP Z A 60

MN=MU PCD CbP H A 70

nn=m\ PCD CbP

MO—M .HI PCD 90 nn in i_i w UU 3 U J =1 ,

N

PCD CbP 1 A A 100

MNJLUL= IPPI /Mil 1 \ *mm (N+J—1 ) NN A C D Cbr 1 1 A 110

r\n in Titi UU 3U 1=1 ,

N

PCD Ubr 120

K T W I Kl IPPI . T

l\ 1 N J=NJUUL+

1

PCD Cbr 1 9 A 130

TC / T 1 \ 1 A 1ft 1ft Ir (1—J; 1U,2U,1U PCD Cbr 1 Jl A 140

i n 1U A 1 V T Kl 1 \ 7COn A C D CSP i e a 150 uu IU 3U A C D C5P 1 Z A 160

2U A

a <(IV1NJ i/ I w 1 v PMC J=UNt PCD CbP 1 t A 170

in PPMTTMIIC UUN 1 1 NUt PCD CbP 1 Q A 180

nPTPDMTMP L/C 1 tKNIl Nt UAMAAIMUM V T Ml 1 II ADj ADC PIT Ur UADTARI VAKlADLtP OCT DC. 1 MPNo CItLlMlNAItU. T MT MATCH TUTC DCPPUPC IHlb DtLUMtb PCD CbP 190

ft L=U PCD CbP *t A A 200

40 1 l.l L=L+1 A C D CSP O 1 A 210

1LOUL=NN PPI MM * 1L—MMNN PCD CbP 1 O A 220

Ul 1 _l PPI .1 PCD CbP 1 1 A 230

t c i\ m \ cn inn inn PCD CbP 1 A ft 240

p PTMft riNU TUP 1 HE 1LAnutj ADPPCT1 PI CIICMT TM TUC 1 TU PPI MUM tLtmtNl IN Inc. LIM LULUMN . PCD CbP OCA 250

enDU 1 1 _l PCD CbP 1 £ A 260

P—ADC / A fl(l 1 \ \ PCD CbP O 7 A 270

1 1 _l 1 PCD CbP O O A 280 nnUU 7a t_i i m / U 1=L1 ,

N

PCD CbP O A A 290

UU —I PPI T

l\ 1 L=LLUL+ 1 PCD CbP 1 ftft 300

¥A=ADb ADC / A /If T 1 \ \ (A(hlLJ

)

PCD CbP 1 1 A 310

T C /P Y\ Cft 7A 7A 1 r (I.—A ) OU , #0 , / 0 PCD CbP 1 O A 320

pC DCmon KtCUKU TUP MIIUDPD PC TUC DPI!/ UAWTMP TUC PDCATCD CI CUCMT IHt NUMdLK Ur 1 He KUW HAVINu 1 Ht bKtAltK cLbMcN 1 . PCD CbP lift 330

ou 1 1 _T J 1=1 PCD CbP a VI A 340

pCP DCPPUCC TUC PDCATCD C btCUMtb 1 Ht uKtA 1 tK

.

PCD CbP OCA 350

P Y C=A PCD CbP 1 L A 360

y a 70 CONTINUE CSP OTA 370

pC INTERCHANGE ROW Jl WITH ROW L . Jl IS THE ROW WITH THE LARGEST ELEMCSP 1 Oft 380

p TEST TO SEE IF INTERCHANGING IS NECESSARY. CSP ion 390

IF (Jl-L) 80,100,80 CSP A ft ft 400

80 DO 90 J=L,N2 CSP A 1 ft 410

JC0L=NN*J-NN CSP A O A 420

KJIJ=JC0L+J1 CSP A O A 430

H0LD=A(KJIJ) CSP A A ft 440

KLJ=JC0L+L CSP Ann

A(KJIJ)=A(KLJ) CSP A Cft 4 to 0

A (KLJ )=H0LD CSP AT ft 470

A A 90 CONTINUE CSP A O ft 480

a

C IF THE LARGEST ABSOLUTE ELEMENT IN A COLUMN IS MACHINE ZERO WE CSP AQft 47U

p HAVE A SINGULAR MATRIX CSP *t73

1 A A 100 -IF (ABS (A (KLL) )-ER) 110,110,120 CSP Cftft 500

1 1 A 110 ISIG=4 CSP CIA 510

GO TO 200 CSP C O A 520

Ac ZERO ALL THE ELEMENTS IN THE LTH COLUMN BUT THE PIVOTAL ELEMENT. CSP con 530

1 0 A 120 Ll=l CSP

L2=L-1 CSP CCA DDU

IF (L2) 130,130,150 CSP CiLA

130 IF (L-N) 140,170,140 CSP 570

62
140 L1=L+1 CSP 580

L2=N CSP 590

150 DO 160 I=L1,L2 CSP 600

KIL=LCOL+I CSP 610

Z=-A(KIL) /A(KLL) CSP 620

DO 160 J=L,N2 CSP 630

JCOL=NN*J-NN CSP 640

KIJ=JCOL+I CSP 650

KLJ=JCOL+L CSP 660

160 A(KIJ)=A(KIJ)+Z*A(KLJ) CSP 670

IF (N-L2) 40,40,130 CSP 680

c DIVIDE BY DIAGONAL ELEMENTS

.

CSP 690

170 DO 180 1=1,

N

CSP 700

KKK=NN*I-NN+I CSP 710

ZZ=A(KKK) CSP 720

DO 180 J=1,N2 CSP 730

KKI=NN*J-NN+I CSP 740

180 A(KKI)=A(KKI) /ZZ CSP 750

c RETURN AFTER PUTTING A INVERSE INTO B CSP^ 760

DO 190 J=1,N CSP 770

JCOL=NN*J-NN CSP 780

NJCOL=NN*N+JCOL CSP 790

DO 190 1=1,

N

CSP 800

KIJ=JCOL+I CSP 810

KINJ=NJCOL+I CSP 820

190 A(KIJ)=A(KINJ) CSP 830

200 RETURN CSP 840

END CSP 850

63
10

20

30

40

50

60

70

80

90

CIIMPTTAM nDC I / YM M\ rUNLIlUN UDtJ (A,N,M) noc out 1 A UCDC TAU C A A nDC 1 C / 1 C / 7 A VtKblUN 5.00 UDtJ 5/13/70 ADC Dot 20

aai idic DDcncinM nnc i cuvaqpnvc / 1 on\t / i •>a\ DUUDLt rKtL 1 b 1 UN UDtJ , t , n , a , A , D , V* , U , Y , 5 ( 1ZU ) , 1 ( 1Z0 ) ADC out

OA 30

nnnoir ddcp i c

t

nw cnciN enpne cm op cnsnoT enevo UUUDLt rKtLlblUN r U J IN , rUUUj , r ULuU , r U 1 ,rUtAr noc UDt

AA 40

LUMNIUN / bLKA 1 / n) ,nj£ , 1 (1.5DUU) noc UDt cn5U

cQUlVALtNLt ( bLKA 1 ( 120 1 ) , b ) , (bLKA 1 (1451 ) , 1 )

nnr Dot 60

nnnoic Doer ici nu ncurnc nvcYO UUUDLt rKtL 1 b 1 UN UbNLUb , UAt Ar noc UDt 7 A 70

LUMNIUN /ULUNLD/ UbNLUb ,UALAr noc UDt OAoU

tplr /nAR^/y\ (UKDj^AJ . ctVa i .10. u c\ go, Tn on D; uu iu 7U nnc UDt on7U

A=a ty i o nn

\ * * o ( A / c . UU ) £ nnc UDt i nn 1UU 1 V / A . A O J=A / . 4+0 . o

noc UDt 1 1 A 110

D 1 D=J noc UDt 1Z0 p i . w L=J +N noc UDt 1 1 A 130 nU=— inn 1 . uu noc UDt 1 A A 140

lr (M.bl.l) U=1.UU noc UDt l en 150

tc i u rT 7\ rn to in 1 r (M.b 1 . 3 ) bU 1 U 30 ADC UDt 1 L

A 160

Y=l . U0 ADC UDt 1 7 A 170 nnUU on t_i i t U 1=1 , J

noc UDt i on loU

vY=li nn v*a / n*p

\ *n . UU+Y A/ (B b) U noc UDt 1 DA 1 VU

D=D— DDi nn 1 . UU noc UDt onn ZOO

p_p L=L

— i nn 1 . uu noc UDt )i

n Z1U

TC IW rT A\v y*v/o nn lr (N.bl.0) Y=A Y/Z.UU ADC UDt 1 *i

A 2Z0

pn Tn onn bU IU ZOU noc UDt Z30 c i nnn t=l . UUU noc UDt Z40 c / 1 \ _ C7701 c a AAon i enn noc UDC i cn A3U

C/£i\ C/i\ enn b ( o 1 ) =b ( 1 ) — . 5 U 0 noc UDt 1 LA ZoO nnUU AnIU i_o An 1 =c , ou noc UDt 7 7 n 1 1 0

C/T\—</T i \ i nn /c 3 i 1 ) =J ( 1 —l )— 1 . uu / c noc UDtoAoUon

c / t 1 a

n\

c / t

\ i nn / / o nn* / c 1 1 nn\\

b ( 1 +oU )=b (1 ) — 1 .UU/ (Z .UU (t+1 . UU ) ) noc UDt Z7O

P—Fj.i nn nRP UDC inn c cm np / y / o nn \

t=r ULUb ( A / Z . UU) noc UDt 1 1 A 310

nnUU cn t_i i )n D U 1=1 , 1 AU nnc UDt 3ZU 1 ( 1 ) =b ( 1 ) +t noc UDt 33U

tc iu i t a\ an Tn An lr (M.LI . 0 ) uu iu ou nnc UDt 34U

tc pta nn\ rn Tn on lr (A.bl.o.UU) bU IU 7U nnc UDt j cn 35U t a n 1 A=U noc UDt 1 An 3oU

tc /ki pt n\ ta An 1 r ( N . b 1 . 0 ; 1 A=oU noc UDt i7n 3 70

tc / u ct

c

\n i nn lr (M.bl.5) U=-1.U0 noc UDt ion 380 T 1 • T A 1 1=J+1 A+l noc UDt ion 3VU V T / T \ Y=T (1) noc UDt Ann 400

nnta id i i UU 70 1D=1,J noc UDt Jin 410

T_ i in , I A . l

1=J—1D+1 A+l nRP UDC Atn 1 AU V T/T\ n * A * V / 1 D * p \ Y=l ( 1 ) —U A T / ( D L )

noc UDt il "2

A 430 DDI f\A B=D-1 . U0 noc UDt Jt Jt A 440 pL=L—p i nn 1 . UU nRP UDC HDU a cn

tc / m rTa\v v*v/o nn lr (N.bl.0) Y=A Y/Z.UU nnc UDCa An 40U

TC / U PT C\ PA TA OA 1 r (M.bl.5) bU 1 U 80 tn P<

P

A 7 A 470

v_v* ai aa i 077 ">

\

T

=

T . 030017 // A300UU Aonn nRP UDC *»ou

IF (N.Nc.0) Y=- . o3ool777Z3ooU0 /A+Y noc UDt jinn 490

TAOAA bU IU ZOO noc UDt enn 50U T =— T nRP UDC CIA 31V

TC I u UCA\V 1 f\A/VV lr (N.Nt.0) Y=1.D0/a-Y noc UDt con 5Z0

GO TO 200 noc UDt

C 1 A

530 • m f\ni V A=8 . D0*X ADC Dot C Jl A 540 U M n=N nnc UDC CCA

rt= (a . n)

Z nRP UDC 1 ( 1 )= (n-1 . DO ) /A nRP UDC C7ft D / U A T / 1 \ U= 1(1) nnc UDU 3 ou 00 100 1-2,20 DBE 590

64
K-I DBE 600

B-I DBE 610

C=(2*I-1)** 2

r\ f\ r~m

aA DBE 620

T(I)-(H-C)/(A*B) DBE 630

E=D DBE 640

D=T(I)*D DBE 650

E=DABS (D/E) DBE 660

IF (DABS (D) .LT. .50-10) GO TO 110 DBE 670

IF (E.GT. .91D0) 60 TO 110 DBE 680

100 T(I+2)=0.0D0 DBE 690

110 A=-1.D0 DBE 700

IF (M.LE.l) GO TO 150 DBE 710

IF (M.LE.3) GO TO 120

nn ^ aa DBE 720

IF (M.LE.5) GO TO 150 DBE 730

A=1.D0 DBE 740

120 Y=1.D0 DBE 750

DO 130 1=1,

K

DBE 760

J=K-I+1 DBE 770

130 Y=1.D0+A*Y* T(J) DBE 780

A=1.D0 DBE 790

IF (X.LT.DXEXP) A=FDEXP(X) DBE 800

IF (M.LE.5) GO TO 140 DBE 810

Y=Y/ (A*FDSQRT ( . 636619772368D0*X) )

DBE 820

GO TO 200

nn f aaa DBE 830

140 Y=Y*A/FDSQRT(6.283185307D0*X) DBE 840

GO TO 200 ^% ^m

aaa DBE 850

150 Y=FDSQRT(3 .

1415926536D0*X) DBE 860

J=K/2

A ^% ^mA ^ A DBE 870

K=2*J DBE 880

J=J-1

nn it*aaa DBE 890

A=1.D0 DBE 900

H=A DBE 910

DO 160 1=1,

J

DBE 920

IA=K-2*I+1 DBE 930

A=1.D0-A*T(IA)*T(IA+1) DBE 940

160 H=1.D0-H*T(IA)*T(IA-1) DBE 950

A=(1.D0-T(1)*T(2)*A)/Y DBE 960

H=T(1)*H/Y DBE 970

B=FDSIN(X) DBE 980

C=FDCOS(X)

A

A AAA DBE 990

D=A-H DBE1000

E=A+H DBE1010

IF (M.GT.2) GO TO 180 DBE1020

IF (N.EQ.O) GO TO 170 DBE1030

Y=E*B-D*C DBE1040

GO TO 200 DBE1050

170 Y=D*B+E*C

A

A ^ mA * A DBE1060

GO TO 200 DBE1070

180 IF (N.EQ.O) GO TO 190 DBE1080

Y=-D*B-E*C

A

A ^ « AAA DBE1090

GO TO 200 DBE1100

190 Y-E*B-D*C DBE1110

GO TO 200 DBE1120

200 DBEJ=Y DBE1130

RETURN DBE1140

END DBE1150

65
SUBROUTINE DEFINE DEF 10

c VERSION 5.00 DEFINE 5/15/70 DEF 20

COMMON /BLOCRC/ NRC ,RC (12600) DEF 30

COMMON /BLOCKD/ IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX ,NR0W,NCQL ,NDEF 40

1ARGS,VWXYZ(8) ,NERR0R DEF 50

DIMENSION ARGS(IOO) DEF 60

EQUIVALENCE (ARGS (1) ,RC (12501)

)

DEF 70

c DEF 80

c DEFINE $$ INTO COLUMN ++ DEF 85

c DEFINE $$ INTO ROW ++, COL ++. DEF 90

c DEFINE ROW ++, COL ++ INTO ROW ++, COL ++ . DEF 100

c DEFINE ROW ++, COL ++ INTO COL ++. DEF 110

c DEF 120

IF(NARGS.NE.2) GO TO 5 DEF 122

J=l DEF 124

IF (KIND (1) .EQ .0) CALL ADRESS(IJ) DEF 125

CALL ADRESS (2,1) DEF 126

IF (I ) 120,130,2 DEF 127

2 IF (J ) 120,130,60 DEF 128

5 IF(NARGS.NE.3) IF(NARGS-4) 115,40,115 DEF 129

IF (KIND(l) .EQ.O) GO TO 40 DEF 130

10 I=NARGS DEF 140

GO TO 90 DEF 150

20 IF (NERROR.EQ.O) RC (L)=ARGS (1

)

DEF 160

30 RETURN DEF 170

40 1=2 DEF 180

GO TO 90 DEF 190

50 ARGS(1)=RC(L) DEF 200

IF (NARGS.EQ.4) GO TO 10 DEF 210

CALL ADRESS (3,1) DEF 220

IF (I) 120,130,60 DEF 230

60 IF (NERROR.NE.O) GO TO 30 DEF 240

IF (NRMAX. EQ.O) GO TO 70 DEF 250

IF (KIND (1) . EQ . 0 . AND . NARGS . EQ . 2 ) GO TO 140 DEF 255

CALL VECTOR (ARGS(l) ,1) DEF 260

GO TO 30 DEF 270

70 1=9 DEF 280

80 CALL ERROR (I) DEF 290

GO TO 30 DEF 300

c DEF 310

c CHECK AND CALCULATE WORKSHEET ENTRY LOCATION INTO L DEF 320

c DEF 330

90 CALL ADRESS (I,L) DEF 340

IF (L) 120,130,100 DEF 350

100 IF (KIND(I-l) .EQ.O. AND. IARGS(I-l) .GT.O .AND.IARGS(I-l) .LE.NROW) GO DEF 360

1T0 110 DEF 370

1=16 DEF 380

GO TO 80 DEF 390

110 L-L+IARGS(I-1)-1 DEF 400

IF (1-2) 50,50,20 DEF 410

115 1=10 DEF 420

GO TO 80 DEF 430

120 1=20 DEF 440

GO TO 80 DEF 450

130 1=11 DEF 460

GO TO 80 DEF 470

140 DO 150 IJ-1, NRMAX Utr 480

RC(I)=RC(J) DEF 490

1=1+1 DEF 500

150 J=J+1 DEF 510

RETURN DEF 520

END 66 DEF 530
CIIRPHIITTMP flFTRNK (L NRftW N OFT RANK \ 1 0

p ufdcton <; on nFTRNk «wi«;/7o V C.i\ J 1 UN 3 . UU UL. 1 j 1 ID 1 1 V lit 1 ?0

pL WRTTTFN IVlXlllCIl RVDl 0

<\ PFAVY rCHVl 7C 1 1 /Aft

j l/OO DET VU 1 p FVAHIATF^ THF OFTFRMT N AIIT AND RANK f)F A DFT 40

p A LOCATION OF MATRIX DET 50

pL NROW THE DIMENSION OF A IN DIMENSION STATEMENT DET AO

p N11 SIZE JILL OFvi nA DET 70

pL DET L' 1— 1 -THE MIL VALUE V L. \J L- ORWli DETERMIMANT VL 1 Ll\ 111 X llinil 1 OFVI A*» DET ftO p RANK-RANK i\ ry i» i> i \ ni« i « OFv i A~ DET 90

r\j ORIGANAL VALUES OF A ARE DESTROYED DET 1X 00v VI Pi> DET 110 X x u DIMENSION AfNROW NROW) DET l/L 1 190 X C v NK=N DET 1X J30u NN=N-1 DET 1 40

VAL=1 .0 DET 1 50

DO1/ V 60V V 1=1 * -L ^ NN111* DET 1xouAO

1& 1A = 1+1 ATA DET X1701 V

I B=I DET 1xouRO

DO 10 J=II N DET 1X 907 U IF (ABS(A(IB I)) GE ABS(A(J I))) GO TO 10 DET 700 c u u IB—

J

DET ? 1 0

Xi ou CONTINUE DET ??0

IF (ABS(A(IB in GE 1 E-7) GO TO 20 DET ? 30

NK=NK-1 DET 740

GO TO 40 DET 750 & J V 90 IF (IB EQ I) GO TO 40 DET 0£OUAO

DO 30 J=I N DET ?70 CIV

T=A(I J) DET 7ft0 LOU

A ( I J )=A ( IB J) DET 9L 97 Uill 30 A(IB J)=T DET 300

VAL=-VAL DET 310xu DO 50 J=II N DET J£U 390

DET J330^ u DO 50 K=I N DET 340

50 A(J K)=A(J K)-X*A(I K) DET 350

AO CONTINUE DET 3 AO

RANK-NK r\ n n i\—ni\ DET l/L 1 370

IF f NK-N ) 90 70 90 l/L DET1 3 AO

1 U PR—i n DFT 390

DO 80 1=1,

N

DET 400

ftO PR=PR*A(I,I) DET 41HXU0

DET=VAL*PR DET 490 t£U

RETURN QO ..a 3 0

QO DET=0.0 DET 440

RETURN DET *tDU

EM DET 460

67
DHR 10

SUBROUTINE DHRND (X,N,XT) DHR 20

C VERSION 5.00 DHRND

5/J5/70 OHR 30

C SUBROUTINE TO ROUND X TO M SO AND STORE

I J

XT

4Q

C WRITTEN BY DAVID HOGBEN, SEL, NBS . 4/09/70.

DHR 5Q

DOUBLE PRECISION Z DHR 60

IF (X) 20,10,20 DHR 70

10 XT=0.0 DHR 80

RETURN DHR 90

20 IF (N.LT.l) N=l DHR 100

IF (N.GT.8) N=8 DHR 110

Y=ABS(X) DHR 120

M=FL0G10(Y) DHR 130

IF (Y.LT.1.0) l*=M-l DHR 140

Z=Y DHR 150

Z=Z*10.D0**(8-M) DHR 160

IF (Z.LT.1.0D+9) GO TO 30 DHR 170

M=M+1 DHR 180

Z=Z/10.0D0 DHR 190

GO TO 40 DHR 200

30 IF (Z.GE.1.0D+8) GO TO 40 DHR 210

M=M-1 DHR 220

Z=10.0D0*Z DHR 230

40 X1=Z DHR 240

LL1=X1 DHR 250

X2=Z-DBLE(X1) DHR 260

LL2=X2 DHR 270

LL=LLl+LL2+5 DHR 280

LL1=LL/(10**(9-N)) DHR 290

LL2=LL1*10**(9-N) DHR 300

LL2=LL-LL2 DHR 310

IF (N.EQ.8) GO TO 70 DHR 320

IF(LL2/10-5*10**(7-N)) 70,50,60 DHR 330

50 LL2=M0D(LL1,2) DHR 340

IF (LL2) 70,70,60 DHR 350

60 LL1=LL1+1 DHR 360

70 XT=FLOAT (LL1) DHR 370

IF (M.EQ.N-1) GO TO 80 DHR 380

C DHR 390

Z=XT DHR 400

Z=Z*10.0D0**(M-N+1) DHR 410

XT=FDPCON(Z) DHR 420

80 XT=SIGN(XT,X) DHR 430

RETURN DHR 440

END

68
10

20

25

27

30

SUBROUTINE D I MENS

VERSION 5.00 D I MENS 5/15/70

COMMON /BLOCRC/ NRC ,RC (12600)

COMMON /BLOCKD / IARGS (100) ,KIND (100) .ARGTAB (100)

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS (1 ), RC (12501 )

)

IF (NARGS.EQ.2) IF (KIND(1)+KIND(2) ) 25,27,25

K=10

CALL ERROR (K)

RETURN

K=20

GO TO 10

IF (IARGS (1) .GT.0.AND.IARGS(2) .GT . 0 .AND . IARGS ( 1

)

1G0 TO 30

K=3

GO TO 10

NR0W=IARGS(1)

NC0L=IARGS(2)

NRMAX=MINO (NROW,NRMAX)

GO TO 20

END

DIM 10

DIM 20

DIM 30

,NRMAX ,NROW,NCOL ,NDIM 40

DIM 50

DIM 60

DIM 70

DIM 75

DIM 80

DIM 90

DIM 100

DIM 110

DIM 120

*IARGS(2) . LE .NRC) DIM 130

DIM 140

DIM 150

DIM 160

DIM 170

DIM 180

DIM 190

DIM 200

DIM 210

69
SUBROUTINE DUMMYA DMA 10

VERSION 5.00 DUMMYA 5/15/70 DMA 20

PRINT 10 DMA 30

FORMAT (55H * OMNI TAB COMMAND DUMMYA IS NOT AVAILABLE AT THIS TIME) DMA 40

RETURN DMA 50

END DMA 60

SUBROUTINE DUMMYB DMB 10

VERSION 5.00 DUMMYB 5/15/70 DMB 20

PRINT 10 DMB 30

FORMAT (55H * OMNITAB COMMAND DUMMYB IS NOT AVAILABLE AT THIS TIME) DMB 40

RETURN DMB 50

END DMB 60

SUBROUTINE DUMMYC DMC 10

VERSION 5.00 DUMMYC 5/15/70 DMC 20

PRINT 10 DMC 30

FORMAT (55H * OMNITAB COMMAND DUMMYC IS NOT AVAILABLE AT THIS TIME) DMC 40

RETURN DMC 50

END DMC 60

SUBROUTINE DUMMYD DMD 10

VERSION 5.00 DUMMYD 5/15/70 DMD 20

PRINT 10 DMD 30

FORMAT (55H * OMNITAB COMMAND DUMMYD IS NOT AVAILABLE AT THIS TIME) DMD 40

RETURN DMD 50

END DMD 60

SUBROUTINE DUMMYE DME 10

VERSION 5.00 DUMMYE 5/15/70 DME 20

PRINT 10 DME 30

FORMAT (55H * OMNITAB COMMAND DUMMYE IS NOT AVAILABLE AT THIS TIME) DME 40

RETURN DME 50

END DME 60

SUBROUTINE DUMMYF DMF 10

VERSION 5.00 DUMMYF 5/15/70 DMF 20

PRINT 10 DMF 30

FORMAT (55H * OMNITAB COMMAND DUMMYF IS NOT AVAILABLE AT THIS TIME) DMF 40

RETURN DMF 50

END DMF 60

70
SUBROUTINE ERASE ERA 10

C VERSION 5.00 ERASE 5/15/70 ERA 20

C ERA 30

C ERASE COL (C) , (C) , (C) , ETC. ERA 40

C IF NO COLS SPECIFIED ALL OF WORKSHEET IS ERASED ERA 45

C ERA 50

COMMON /BLOCRC/ NRC , RC ( 12600 ) ERA 60

COMMON /BLOCKD / I ARGS ( 100 )

, KIND ( 100 ), ARGTAB ( 100 ) ,NRMAX ,NROW,NCOL ,NERA 70

1ARGS ,VWXYZ (8) ,NERROR ERA 80

DIMENSION ARGS(IOO) ERA 90

EQUIVALENCE (ARGS (1 ) ,RC (12501 )

) ERA 100

IF (NARGS.EQ.O) GO TO 40 ERA 110

CALL CHKCOL (I) ERA 120

IF (I.EQ.O) GO TO 20 ERA 130

1=20 ERA 140

CALL ERROR (I) ERA 150

10 RETURN ERA 160

20 IF (NERROR . NE . 0 . OR . NRMAX . EQ . 0 ) GO TO 10 ERA 170

DO 30 I=1,NARGS ERA 180

30 CALL VECTOR (0 . , IARGS ( I )) ERA 190

GO TO 10 ERA 200

C ERA 210

C CLEAR ALL OF DIMENSIONED WORKSHEET. ERA 220

C ERA 230

40 IF (NERROR. NE.O) GO TO 10 ERA 240

NRMAX=NROW*NCOL ERA 250

CALL VECTOR (0.,1) ERA 260

NRMAX=0 ERA 270

GO TO 10 ERA 280

END ERA 290

71
SUBROUTINE ERRINT (X ,ERF ,ERFC) CDT CR 1 1 A 10

c VERSION 5.00 ERRINT 5/15/70 ERT O A zo DOUBLE PRECISION AN ,BN ,CONS ,C1 ,DN ,ERF ,ERFC ,F ,FN ,FNM1 ,FNM2 ,FOUR ,6N ,ERT CO

16NM1 ,GNM2 ,ONE ,P ,PREV ,RNBC ,SCF ,SUM,TN ,TOLER ,TRRTPI ,TWO ,ULCF ,ULPS , WNERT 3 A 30

o y v v^n pnFyp FRT A A 40

POMMDN /nPONI ? /TRRTPT MRP NRM FRT n a 90

DATA um i m (IMF uric TWO POUR III PftHK/l (

i nu , ruun ,ul"j ,\<unj/ 1 . on o no a no i no o?nn / FRT CR 1 1 A A 100

RNP.P—NRP FRT CR 1 1 OA 110

Tfll PR—TWO** I NRM\ FRT CR 1 i in 130

TF f Y\ 70 10 70 FRT i An 140

10 FRF—

n

FRT cn i 1 C A 150

FRFP— cr r u—O.NF unc FRT CR 1 1 L A 160

RPTIIRN rc i ui\n FRT CR 1 1 7 A 1/0

Oft Y—AR^ ( X

I —HDJ \ A ^ FRT CR 1 1 DA 100

i j v(— i c FRT CR 1 i on I7O

TP i Y ill P^ ^ «»n 10 FRT Cn 1 O AA ZOO

30 PI—TftTi** f i RNRP ONP \ /TWO \ Xf x — i nu ^ \ kiidu —ubic j / i nu j FRT CR 1 O 1 A Z10

iii ucurr F——piivii aak*pi j ux FRT CR 1 O 1 A ecu

our ^PF——TWO** IC\ **? RNRP >i nu \U± c —imidu/ FRT Cn 1 O 7 A Z30

T F 1 Y III PF ^ 1 1 (1 1 1 tl 40 FRT tlx 1 Z4U

a n 40 FRF— Li\r —wilt 0NF FRT ci\ i OCA Z50

ERFP-0 Ll\r w—

v

FRT O Z. A ZoO

GO TO AO ERT 07A Z / 0 en3 0' J U 111— V ERT 0 on ZoO

L/ 11—vll L» ERT oon TN— i r—ONE unt FRT inn 300

P—r —TBIO*Y^O i nu i jy FRT a 1 n 310

L A 00 UWsUI1t nu FRT tlx 1 a 0 n 3Z0

TN—P*TN /DN FRT 7 in 33U

<*IIMUTNx^llM FRT 340 1 An

TF iTN_T0IFR^ 70 n0 AO ERT 1 cn 330

7 A / 0 FRF— ( SUM-t-ONF \ *TRRTPT *Y*FDEY.P 1-•i ju. ; ERT i^n 300

FRFP— li\ r u—ONF ubv c —FRF c 1\ r ERT 17(1 3/0

0 A BO TirF IY\ \ a OO 100 100 / 7U,xuu,xuu FRT Cn 1 1QA 300

on FRF— c n r —FRF cr r ERT ion

FRFP— unru—TWO i nu—FRFP crtu FRT Cn 1 Ann 4UU

1 A A 100 RPTIIRM rc i ui\n FRT Cn 1 A 1

A

410

1 1 A 110 FRT Cn 1 Aon 4Z0

£NMo_ONF FRT Cn 1 430 a in

FMM1 r ni mi=—TltfO* i nu VT FRT Cn I AAn

£NM1 —TWO* V^Oj-flNF FRT Cn 1 Acn 430

ri\t v=rnwix /umiwx - FRT Cn 1 400

(UN— immune ONF ERT A7n 4 / M

BN=GNM1+F0UR ERT Aon 40U

1 O A 120 AN=-WN* (WN+ONE) FRT Cn 1 Aon 47U

FN=BN*FNM1+AN*FNM2 FRT Cn 1 enn DOO

GN=BN*GNM1+AN*6NM2 ERT

F=FN/GN ERT tin

IF (ABS(ONE-(F/PREV))-TOLER) 170,170,130 ERT ein 330

130 IF (PREV-F) 140,140,160 ERT Cn 1 3*»U

5 a a 140 IF (GN.LT.SCF) GO TO 150 ERT cn I FN=FN/SCF FRT Cn 1 C300Aft GN-GN/SCF FRT cn i K7ft

FNM1=FNM1 /SCF FRT CR 1 COft 30U

GNM1=GNM1/SCF ERT con 37U

1 C A 150 FNM2=FNM1 ERT AOO p VI u GNM2=GNM1 ERT a0101 n FNM1-FN ERT ozo

GNM1-GN ERT 630

72
WN=WN+TWO ERT 640

BN=BN+F0UR ERT 650

PREV=F ERT 660

GO TO 120 ERT 670

160 F=PREV ERT 680

170 ERFC=F*FOEXP(-YSQ)*TRRTPI/TWO ERT 690

ERF=ONE-ERFC ERT 700

GO TO 80 ERT 710

END ERT 720

73
SUBROUTINE ERROR (I) ERR 10

C VERSION 5.00 ERROR 5/15/70 ERR 20

COMMON/BLOCRC/NRC.RC (12600) ERR 30

COMMON /BLOCKD/ IARGS(IOO) , KIND (100) ,ARGTAB(100) , NRMAX, ERR 40

1 NROW,NCOL ,NARGS ,VWXYZ (8) ,NERROR ERR 50

DIMENSION ARGS(IOO) ERR 60

EQUIVALENCE (ARGS(l) ,RC(12501) ) ERR 70

COMMON/BLOCKC/KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST ERR 80

COMMON / BLOCKX / INDEX ( 6, 8 ), LEVEL ERR 90

COMMON/SPRV/NERCON,NERR,ISWERR ERR 100

DIMENSION IL( 2 ) ERR 110

DATA IBL , IL (1 ) ,IL(2)/2H ,2H/I,2H/F/ ERR 120

ISCRUN=ISCRAT ERR 130

C ERR 140

C IF 1 .LE. I .LE. 100, FATAL ERROR ERR 150

C IF 101 .LE. I .LE. 200, ARITHMETIC ERROR ERR 160

C IF 201 .LE. I .LE. INFORMATIVE DIAGNOSTIC ERR 170

C ERR 180

NERR=NERR+1 ERR 190

7003 IF( I .GT. 100 ) GO TO 200 ERR 200

NERR0R=NERR0R+1 ERR 210

WRITE( ISCRUN, 800 ) ERR 220

800 FORMAT (/32H*** FATAL ERROR IN ABOVE COMMAND, 52X) ERR 230

IF(LLIST.NE.O) GO TO 710 ERR 240

WRITE(ISCRUN,700) ERR 250

700 FORMAT (66H*** COMMAND WAS NOT LISTED BECAUSE NO LIST OR LIST 0 WASERR 260

1 IN EFFECT, 18X) ERR 270

710 LLIST=3 ERR 280

GO TO (801, 802, 803, 804, 805, 806, 807, 808, 809, 810, 811, 812, 813, 814, 815ERR 290

1,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830), I ERR 300

801 WRITE(ISCRUN,1) ERR 310

1 FORMAT (29H*** NAME NOT FOUND IN LIBRARY, 55X) ERR 320

GO TO 900 ERR 330

802 WRITE (ISCRUN, 2) ERR 340

2 FORMAT (28H*** ILLEGAL STATEMENT NUMBER, 56X) ERR 350

GO TO 900 ERR 360

803 WRITE(ISCRUN,3) ERR 370

3 FORMAT (28H*** ILLEGAL ARGUMENT ON CARD,56X) ERR 380

GO TO 900 ERR 390

804 GO TO 900 ERR 400

805 WRITE(ISCRUN,5) ERR 410

5 FORMAT (38H*** COMMAND NOT ALLOWED IN REPEAT M0DE,46X) ERR 420

GO TO 900 ERR 430

806 WRITE(ISCRUN,6) ERR 440

6 FORMAT (74H*** STATEMENT NUMBER MAY NOT BEGIN ANY CARD BETWEEN BEGIERR 450

IN AND FINISH CARDS, 10X) ERR 460

GO TO 900 ERR 470

807 WRITE(ISCRUN,7) ERR 480

7 FORMAT (23H*** ILLEGAL *STATEMENT* ,61X) ERR 490

GO TO 900 ERR 500

808 WRITE(ISCRUN,8) ERR 510

8 FORMAT (34H*** PHYSICAL CONSTANT NOT IN TABLE, 50X) ERR 520

GO TO 900 ERR 530

809 WRITE(ISCRUN,9) ERR 540

9 FORMAT (13H*** NRMAX - 0,71X) ERR 550

GO TO 900 ERR 560

810 WRITE(ISCRUN,10) NARGS ERR 570

10 F0RMAT(3H***,I4,34H IS AN ILLEGAL NUMBER OF ARGUMENTS ,43X) ERR 580

GO TO 900 ERR 590

74
811 WRITE(ISCRUN,11) ERR 600

11 FORMAT (40H*** COLUMN NUMBER TOO BIG OR LESS THAN 1 ( 44X) ERR 610

GO TO 900 ERR 620

812 WRITE(ISCRUN ( 12) ERR 630

12 FORMAT (33H*** COMMAND STORAGE AREA OVERFLOW, 51X

)

ERR 640

GO TO 900 ERR 650

813 WRITE(ISCRUN,13) ERR 660

13 FORMAT (30H*** STATEMENT NUMBER NOT FOUND, 54X) ERR 670

GO TO 900 ERR 680

814 WRITE(ISCRUN,14) ERR 690

14 FORMAT (35H*** ILLEGAL OR NO FORMAT DESIGNATOR ,49X) ERR 700

GO TO 900 ERR 710

815 WRITE(ISCRUN,15) ERR 720

15 FORMAT (34H*** DIMENSIONED AREA EXCEEDS LIMIT, 50X) ERR 730

GO TO 900 ERR 740

816 WRITE(ISCRUN,16) ERR 750

16 FORMAT (27H*** ILLEGAL SIZE ROW NUMBER, 57X) ERR 760

GO TO 900 ERR 770

817 WRITE(ISCRUN,17) ERR 780

17 FORMAT (39H*** DEFINED MATRIX OVERFLOWS WORKSHEET ,45X) ERR 790

GO TO 900 ERR 800

818 WRITE(ISCRUN,18) ERR 810

18 FORMAT (36H*** INTEGER ARGUMENT LESS THAN -8191, 48X) ERR 820

GO TO 900 ERR 830

819 WRITE(ISCRUN,19) ERR 840

19 FORMAT (48H*** STORED PERFORM STATEMENT WILL EXECUTE ITSELF, 36X) ERR 850

GO TO 900 ERR 860

820 WRITE(ISCRUN,20) ERR 870

20 FORMAT (29H*** IMPROPER TYPE OF ARGUMENT , 55X) ERR 880

GO TO 900 ERR 890

821 WRITE(ISCRUN,21) ERR 900

21 FORMAT (26H*** COMMAND MUST BE STORED, 58X) ERR 910

GO TO 900 ERR 920

822 WRITE(ISCRUN,22) ERR 930

22 FORMAT (31H*** MATRIX IS (NEARLY) SINGULAR ,53X) ERR 940

GO TO 900 ERR 950

823 WRITE(ISCRUN,23) ERR 960

23 F0RMAT(28H***INSUFFICIENT SCRATCH AREA,56X) ERR 970

GO TO 900 ERR 980

824 WRITE(ISCRUN,24) ERR 990

24 FORMAT (49H*** DEGREE IS LARGER THAN NO. OF NON-ZERO WEIGHTS, 35X) ERR1000

GO TO 900 ERR1010

825 WRITE(ISCRUN,25) ERR1020

25 FORMAT (35H***NEGAT I VE WEIGHTS MAY NOT BE USED,49X) ERR1030

GO TO 900 ERR1040

826 WRITE(ISCRUN,26) ERR1050

26 FORMAT (51H***NUMBER OF COLUMNS IS GREATER THAN NUMBER OF R0WS,33X)ERR1060

GO TO 900 ERR1070

827 WRITE (ISCRUN,27) ERR1080

27 FORMAT (19H***F0RMAT NOT FOUND, 65X) ERR1090

GO TO 900 ERR1100

c**** THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS ERR1110

828 WRITE(ISCRUN,28) ERR1120

28 FORMAT (47H* INCORRECT TAPE UNIT. COMMAND IS NOT EXECUTED ,37X) ERR1130

GO TO 900 ERR1140

'ERR1150

829 NSB = NARGS+1 ERR1160

WRITE (ISCRUN ,29) NSB ERR1170

29 FORMAT (31H* NUMBER OF ARGUMENTS SHOULD BE,I2,51X) ERR1180

75
GO TO 900 ERR1185

830 WRITE(ISCRUN,30) ERR1190

30 FORMAT (48H* AN INCREMENT COMMAND CAN NOT INCREMENT ITSELF. ( 36X) ERR1200

900 IF( LEVEL .NE. 0 ) CALL RNDOWN ERR1220

C FORCE OUT OF REPEAT MODE IF FATAL ERROR ERR1230

IF( I .LE. 100 ) LEVEL = 0 ERR1240

WRITE( ISCRUN, 901 ) ERR1250

901 FORMAT (84X) ERR1260

RETURN ERR1270

200 IF (NERR .LE .NERCON .OR .LLIST .NE .3 ) GO TO 201 ERR1280

IF(ISWERR.NE.O) RETURN ERR1290

ISWERR=1 ERR1300

WRITE(ISCRUN / 9999)NERC0N ERR1310

9999 FORMAT (/1H*, 15, 62H INFORMATIVE AND ARITHMETIC DIAGNOSTICS HAVE BEEERR1320

IN ENCOUNTERED. ,16X/ ERR1330

284H* ANY SUCH ADDITIONAL DIAGNOSTICS FOR THIS COMMAND OR REPEAT MERR1340

30DE ARE DISREGARDED. ) ERR1350

RETURN ERR1360

201 IF(I.GT.200) GO TO 400 ERR1370

C ERR1380

C ERR1390

C ARITHMETIC TROUBLES, SET FLAGS ERR1400

C ERR1410

CALL AERR(I-IOO) ERR1420

250 RETURN ERR1430

C ERR1440

C INFORMATIVE DIAGNOSTIC ERR1450

C ERR1460

400 IF( MOD( LLIST, 2 ) .EQ. 0 ) GO TO 250 ERR1470

IF(LLIST.EQ.O) GO TO 250 ERR1475

CALL INFERR (I ) ERR1480

GO TO 900 ERR1490

END ERR1500

76
SUBROUTINE EXCHNG EXC 10

C VERSION 5.00 EXCHNG 5/15/70 EXC 20

C EXC 30

C EXCHANGE COL ++ WITH ++, COL ++ WITH ++, ETC. EXC 40

C EXC 50

COMMON /BLOCRC/ NRC ,RC (12600) EXC 60

COMMON /BLOCKD / I ARGS ( 100 )

, KIND ( 100 ), ARGTAB ( 100 ), NRMAX , NROW, NCOL , NEXC 70

1ARGS ,VWXYZ (8) ,NERROR EXC 80

DIMENSION ARGS(IOO) EXC 90

EQUIVALENCE (ARGS (1) ,RC (12501) ) EXC 100

IF (NARGS) 70,70,10 EXC 110

10 IF (NARGS. NE. (NARGS/2)*2) GO TO 70 EXC 120

DO 50 1=1, NARGS, 2 EXC 130

CALL ADRESS (I, J) EXC 140

IF (J) 60,80,20 EXC 150

20 CALL ADRESS (I+l.K) EXC 160

IF (K) 60,80,30 EXC 170

30 IF (NERROR.NE.O) RETURN EXC 180

DO 40 N=l , NRMAX EXC 190

JJ=J+N-1 EXC 200

KK=K+N-1 EXC 210

WORK=RC(JJ) EXC 220

RC(JJ)=RC(KK) EXC 230

RC(KK)=WORK EXC 240

40 CONTINUE EXC 250

50 CONTINUE EXC 260

GO TO 90 EXC 270

60 CALL ERROR (3) EXC 280

GO TO 90 . EXC 290

70 CALL ERROR (10) EXC 300

GO TO 90 EXC 310

80 CALL ERROR (11) EXC 320

90 RETURN EXC 330

END EXC 340

409-118 OL - 71 - 6

77
SUBROUTINE EXPAND (J, WHERE) EXD 10

C VERSION 5.00 EXPAND 5/15/70 EXD 20

COMMON /BLOCRC/ NRC ,RC (12600) EXD 30

COMMON /BLOCKD / IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ( NEXD 40

1ARGS ,VWXYZ (8) ,NERROR EXD 50

DIMENSION ARGS(IOO) EXD 60

EQUIVALENCE (ARGS (1) ,RC (12501) ) EXD 70

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG EXD 80

DIMENSION WHERE (1) EXD 90

C EXD 100

C THIS ROUTINE EXPANDS STORED COMMANDS FROM WHERE TO A USABLE EXD 110

C FORM IN ARGS, IARGS AND KIND. EXD 120

C EXD 130

11=0 EXD 140

1=0 EXD 150

JJJ=J EXD 160

C CONVERT ONLY FIRST ARGUMENT IF COMMAND IS INCREMENT OR RESTORE EXD 170

IF (L1.NE.14) GO TO 10 EXD 180

IF (L2.GE.6.AND.L2.LE.8) JJJ=2 EXD 190

10 11=11+1 EXD 200

20 1=1+1 EXD 210

IF (I.GE.JJJ) GO TO 80 EXD 220

T=WHERE (I ) EXD 230

IF (T) 50,40,30 EXD 240

30 KIND (I I )=0 EXD 250

IARGS(II)=T-8192. EXD 260

GO TO 10 EXD 270

40 KIND ( 1 1 )=1 EXD 280

1=1+1 EXD 290

ARGS(II)=WHERE(I) EXD 300

GO TO 10 EXD 310

50 IF(T.EQ. (-1) ) GO TO 100 EXD 320

CALL XPND (WHERE ( I ) ,K , ARGS (II) ,KND ) EXD 330

IF (K.GE.O) GO TO 90 EXD 340

60 K=-K EXD 350

70 CALL ERROR (K) EXD 360

80 RETURN EXD 370

90 KIND(II)=KND EXD 380

IF (KND.EQ.O) IARGS(II)=ARGS(II) EXD 390

I=I+K EXD 400

GO TO 10 EXD 410

C EXD 420

C IF STORED VALUE = -1, THEN ARGS (INTEGER) ARE TO BE EXPANDED FROM EXD 430

C PREVIOUS ARG TO FOLLOWING WITH A MAXIMUM TOTAL OF 100 EXD 440

C EXD 450

100 1=1+1 EXD 460

C PICK UP NEXT ARG EXD 470

IU=WHERE(I) EXD 480

IF (KIND(II-l) .NE.O.OR.I .GE.J) GO TO 190 EXD 490

IF (IU) 170,190,110 EXD 500

110 IU=IU-8192 EXD 510

120 K=IU-IARGS(II-1) EXD 520

NARGS=NARGS+IABS (K)-l EXD 530

IF(NARGS.GT.IOO) GO TO 200 EXD 540

IF (K) 130,20,140 EXD 550

130 INC=-1 EXD 560

K=-K N EXD 570

GO TO 150 ' EXD 580

140 INC=1 EXD 590

78
150 DO 160 IT=1,K EXD 600

KIND ( 1 1 )=0 EXD 610

IARGS (II )=IARGS (II-1)+INC EXD 620

160 11=11+1 EXD 630

GO TO 20 EXD 640

C EXD 650

C EXPAND FORM IARG *** /,ARG// EXD 660

C EXD 670

170 CALL XPND (WHERE (I ) ,K,ARGS (II ) ,KND) EXD 680

IF (K.LT.O) GO TO 60 EXD 690

I=I+K EXD 700

IF (KND.EQ.O) GO TO 180 EXD 710

K=20 EXD 720

GO TO 70 EXD 730

180 IU=ARGS(II) EXD 740

GO TO 120 EXD 750

190 CALL ERROR (211) EXD 760

GO TO 10 EXD 770

200 K=10 EXD 780

GO TO 70 EXD 790

END EXD 800

79
SUBROUTINE EXPCON EXN 10

c VERSION 5.00 EXPCON 5/15/70 EXN 20

c runAAii f i inn Ai it T nr c n> r* a » f v/ a i a i i n EXPCON SUBROUTINE S PEAVY 4/4/68 r* \t ll EXN 30

c COMMANDS r- w ll EXN 40

c

1 A i inip A A T A A L2=l: MVECDIA6 EXN 50

c

lll/r AA T 1 A lit TO T \J T kl O A f t t r ft 1 MVECDIAG MATRIX IN R , C SIZE N , MO 1 1 T PUT DIAGONAL IN C EXN 60

c

iiurAn tip in Tn t u t n n a r t tt ii MVECDIAG MATRIX IN R , C SIZE N , M PUT DIAGONAL IN R , C EXN 70

c

i a a inirAiii t L2=2: MVECMAT EXN 80

c MVECMAT MATRIX IN R , C SIZE N ,

llMO 1 IT PUT ROW BY EXN 90

Ac

AC* A AS A VECTOR IN

Ac

P° \J ll EXN 100

Ac

lit I r A 111 T" 111 TO T V/ f|| o A C T ^ r* ft! MVECMAT MATRIX INR,C SIZEN, M PUT ROW BY ROW 1 f AS A EXN 110

c VECTOR IN R , c EXN 120

A

c

i a **i tiiii Turn L2=3: MMATVEC r" \j ii EXN 130

c

AllA A Tl/TA l/r ATAn A nilT AC O A 111 V/ o O III MMATVEC VECTOR C PUT AS ROW X ROW MATRIX IN R , C SIZE Al ill" M 11 N , MEXN 135

c

AAAA IT\/TA I f F A TA 0. O A ni IT If O /\ 111 W MMATVEC VECTOR R , C PUT AS ROW X ROW MATRIX IN R

A

, c run EXN 1 1 A 140

Ac SIZE N X M EXN 145

COMMON /BL0CRC/ NRC ,RC (12600) EXN 160

COMMON /BL0CKD / IARGS(IOO) ,KIND(100) ,ARGTAB (100) ,NRMAX ,NR0W,NC0L ,NEXN 170

1 ARK*; VWYY7rfl\ NFRROR U AM 180

CAN 190

EQUIVALENCE (ARGS (1 ), RC (12501 )

)

LAn 200

COMMON /SCRAT/ NS,NS2 ,A(13500) u All 210

COMMON /BL0CKE/ NAME (4) ,L1 ,L2 , ISRFLG CAN 220

IF (NARGS.EQ.5.0R.NARGS.EQ.6) GO TO 10 can

A A 230

CALL ERROR (10) F¥C AllM AAA 240

RETURN LAN 250

10 J=NARGS rvM t AN 260

KRR=0 CAN 270

CALL CKIND (J) ryu LAN 280

IF (J.EQ.0) IF (L2-2) 15,65,125 cyu LAN 285

CALL ERROR (3)

ruM LAN 290

RETURN LAN 300

c VEC DIAG **** ryu LAN 310

15 I ARGS (7 )=MIN0 ( IARGS (3 )

, IARGS (4)

)

LAN 320

IARGS(8)=1 ryu LAN O A A 330

IF (NARGS.EQ.6) GO TO 20 EXN 340

IARGS(6)=IARGS(5) r* vai EXN 350

IARGS(5)=1 IT V Al EXN 360

MKKR=226 C V Al EXN 1 "T A 370

20 IF (IARGS(5)+IARGS(7)-1.LE.NR0W) GO TO 30 C V Al EXN 1 A A 380

IARGS(7)=NR0W-IARGS(5)+1 EXN 390

KRR=MKKR EXN 400

Ac ERROR 226: COLUMN NOT LONG ENOUGH TO STORE ALL ELEMENTS. ONLY NR0WEXN A 1 A 410

c WILL BE STORE EXN 420

30 J=2 EXN 430

CALL MTXCHK (J) EXN 440

IF (J.NE.0) CALL ERROR (17) EXN A F A 450

IF (NERR0R.NE.0) RETURN EXN A £ A 460

IF (KRR.NE.0) CALL ERROR (KRR) EXN 470

GO TO (40,80,140) , L2 EXN 4 A A 480

40 IA=IARGS(1) EXN i AA 490

IB=IARGS(7) EXN p A A 50©

DO 50 1=1, IB EXN p 1 A 510

A(I j-RC(IA) EXN p A A 520

50 IA=IA+NR0W+1 EXN 530

IA=IARGS(5) EXN C A A 540

DO 60 1=1, IB EXN IT B A 550

RC(IA)=A(I) EXN p/A 560

60 I A=I A+l EXN 570

80
RETURN EXN 580

c 65 VECTORIZE A MATRIX *** EXN 590

65 IARGS(7)=IARGS(3)*IARGS(4) EXN 600

IARGS(8)=1 EXN 610

IF (NARGS.EQ.6) GO TO 70 EXN 620

IARGS(6)=IARGS(5) EXN 630

IARGS(5)=1 EXN 640

70 MKKR=226 EXN 650

GO TO 20 EXN 690

80 IB=IARGS(7) EXN 700

IA=IARGS(1) - EXN 710

N=IARGS(3) EXN 720

M=I ARGS (4

)

EXN 730

IC=1 EXN 740

DO 100 1=1 ,N EXN 750

IAA=IA EXN 760

DO 90 J=1,M EXN 770

A(IC)=RC(IAA) EXN 780

IF (IC.EQ.IB) GO TO 110 EXN 790

IC=IC+1 EXN 800

90 IAA=IAA+NROW EXN 810

100 IA=IA+1 EXN 820

110 IA=IARGS(5) EXN 830

DO 120 1=1, IB EXN 840

RC(IA)=A(I) EXN 850

120 IA=IA+1 EXN 860

RETURN EXN 870

C 125 TAKE A COLUMN AND RESTORE IT TO A MATRIX OR ARRAY. EXN 880

125 IARGS (8)=IARGS(NARGS) EXN 890

IARGS(7)=IARGS(NARGS-1) EXN 900

IARGS (6 )=I ARGS (NARGS-2

)

EXN 910

IARGS(5)=IARGS(NARGS-3) EXN 920

IF (NARGS.EQ.6) GO TO 130 EXN 930

IARGS(2)=IARGS(1) EXN 940

IARGS(1)=1 EXN 950

130 IARGS(3)=IARGS(7)*IARGS(8) EXN 960

IARGS(4)=1 EXN 970

IF (IARGS(1)+IARGS(3)-1.LE NROW) GO TO 30 EXN 980

IARGS (3 )=NROW-I ARGS ( 1 ) +1 EXN 990

C KRR=227 EXN1000

C 227 ERROR: /NOT ENOUGH ELEMENTS IN COL TO RESTORE MATRIX OR ARRAY. EXN1010

C ELEMENTS AVAILABLE WILL BE USED. EXN1020

GO TO 30 EXN1030

140 IA=IARGS (1) EXN1040

IB=IARGS(3) EXN1050

DO 150 1=1, IB EXN1060

A(I)-RC(IA) EXN1070

150 IA=IA+1 EXN1080

IA=IARGS(5) EXN1090

N=IARGS(7) EXN1100

M=IARGS(8) EXN1110

IC=1 EXN1120

DO 170 1=1,

N

EXN1130

IAA=IA EXN1140

DO 160 J=1,M EXN1150

RC(IAA)=A(IC) EXN1160

IF (IC.EQ.IB) RETURN EXN1170

IC-IC+1 EXN1180

160 IAA-IAA+NROW EXN1190

170 IA=IA+1 EXN1200

RETURN EXN1210

END

81

EXN1220
bUDKUUIlNL CIIDDHIITTMr CVTDCU LA 1 KLM C VT t A 1 1 A 10

L WCDCTAM C AA CVTBFU C/1C/7A CVT LA 1 9 A

(JO COMMON /BLOCRC/ NRC , RC ( 12600

)

EXT 1 A COMMON /BLOCKD/ IARGS (100) , KIND (100) ,ARGTAB (100 ) ,NRMAX ,NR0W,NC0L , NEXT A A 1ARGS,VWXYZ(8) ,NERR0R FYT CA 1 C A DIMENSION ARGS(100) fyt LA 1 L A 60

EQUIVALENCE (ARGS(l) ,RC(12501)

)

FYT LA 1 7 A COMMON /BL0CKE/ NAME (4) ,L1 ,L2 , ISRFLG FYT LA 1 a a p FYT LA 1 OA7U

p L2 = 4,5 MAX L2 = 6,7 MIN FYT LA 1 1 AA

p FYT LA 1 I 1 A I I u p MAX OF ++ TO ++ FYT LA 1 1 c U p MAX OF ++ TO ++, CORRESP ENTRY OF ++ TO ++, . . TP. , , CTP ++ 1 v ++ , Lib. FYT LA 1 1 1 A p LIKEWISE FOR MIN. FYT LA 1 1 A A p FYT LA 1 i13U

IF (NARGS.GT . 0 .AND . MOD (NARGS , 2 ) . EQ . 0 ) GO TO in FYT LA 1 1 L A 1=10 FYT LA 1 1 7 A

i a CALL ERROR (I) FYT LA 1 i on

9 n RETURN FYT LA 1 1 OA

in CALL CHKC0L (I) EYT CA 1 o no

IF (I.EQ.0) GO TO 40 EYT CA 1 1 1 A L 1U

1=20 EXT CA 1 1 1 A GO TO 10 EXT CA 1 tin

An IF (NERROR.NE.O) GO TO 20 EXT CA 1 9 AA

J=0 EXT CA 1 IF (NRMAX-1) 50,110,60 EXT CA 1 COM

1=9 EXT CA 1 L I U GO TO 10 FXT CA 1 3QA

OU J=IARGS(1) FXT CA 1 9QA

K=J+1 EXT CA 1 inn

L=K+NRMAX-2 EXT CA 1 n n IF (L2.GT.5) GO TO 80 EXT CA 1 ion i c. u p EXT CA 1 nn

P FIND MAXIMUM FXT CA 1 7 An

p EXT CA 1 i^n

DO 70 I=K,L EXT CA 1 i An

IF (RC(J).LT .RC(I)) J=I FXT LA 1 .? / u CONTINUE EXT CA 1 5Qft

GO TO 100 EXT CA 1 ion

p EXT CA 1 Ann

p FIND MINIMUM FXT LA 1 A 1 A p FXT LA 1 a? n

a a DO 90 I=K,L EXT CA 1 Ain

IF (RC(J).GT .RC(I)) J=I FXT LA 1 AAn

CONTINUE FYT LA 1 A^n

1 AA J=J-IARGS(1) FYT LA 1 AAn

1 1 A DO 120 I=1,NARGS,2 EXT A7n

K=IARGS(I)+J EXT Ann

1 A 120 CALL VECTOR (RC(K) ,IARGS(I+1)) EXT Aon

GO TO 20 EXT cnn END EXT 510

82
FUNCTION FCOS (X) FCO 10

c VERSION 5.00 FCOS 5/15/70 FCO 20

c FCO 30

c THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THAN 3.3E7 IN FCO 40

c ABSOLUTE VALUE BEFORE SYSTEM DOES. RESULT SET =0.0 FCO 50

c FCO 60

COMMON /CONSLB/ XTRIG,XEXP FCO 70

IF (ABS(X) .GT.XTRIG) GO TO 20 FCO 80

FCOS=COS(X) FCO 90

10 RETURN FCO 100

20 CALL ERROR (104) FCO 110

FCOS=0. FCO 120

GO TO 10 FCO 130

END FCO 140

DOUBLE PRECISION FUNCTION FDCOS(X) FDC 10

C VERSION 5.00 FDCOS 5/15/70 FDC 20

C FDC 30

c THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THAN 3.5016 IN FDC 40

c ABSOLUTE VALUE BEFORE SYSTEM DOES. RESULT SET =0 WITH DIAGNOSTIC. FDC 50

c FDC 60

DOUBLE PRECISION DSNCOS,DXEXP FDC 70

COMMON /DCONLB/ DSNCOS,DXEXP FDC 80

DOUBLE PRECISION X,DCOS FDC 90

IF (DABS(X) .GT.DSNCOS) GO TO 20 FDC 100

FDCOS=DCOS(X) FDC 110

10 RETURN FDC 120

20 CALL ERROR (104) FDC 130

FDCOS=O.DO FDC 140

GO TO 10 FDC 150

END FDC 160

DOUBLE PRECISION FUNCTION FDEXP (X) FDE 10

C VERSION 5.00 FDEXP 5/15/70 FDE 20

C FDE 30

C THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THAN 704. DO FDE 40

C BEFORE SYSTEM DOES. RESULT IS SET =0.0 AND DIAGNOSTIC IS PRINTED .FDE 50

c FDE 60

DOUBLE PRECISION DSNCOS ( DXEXP FDE 70

COMMON /DCONLB/ DSNCOS,DXEXP FDE 80

DOUBLE PRECISION X,DEXP FDE 90

IF (X.GT.DXEXP) GO TO 20 FDE 100

FDEXP=DEXP(X) FDE 110

10 RETURN FDE 120

20 CALL ERROR (102) FDE 130

FDEXP=0.0D0 FDE 140

GO TO 10 FDE 150

END FDE 160

83
DOUBLE PRECISION FUNCTION FDLOG(X) FDL 10

C VERSION 5.00 FDLOG 5/15/70 FDL 20

C FDL 30

C THIS FUNCITON IS TO TRAP ILLEGAL ARGUMENT FDL 40

C BEFORE SYSTEM DOES. RESULT SET 0.0 AND DIAGNOSTIC IS PRINTED FDL 50

C FDL 60

DOUBLE PRECISION X,DLOG FDL 70

IF (X.GT.O.DO) GO TO 10 FDL 80

CALL ERROR (101) FDL 90

FDLOG=O.DO FDL 100

GO TO 20 FDL 110

10 FDLOG=DLOG (X) FDL 120

20 RETURN FDL 130

END FDL 140

FUNCTION FDPCON (X) FDP 10

C VERSION 5.00 FDPCON 5/15/70 FDP 20

C WRITTEN BY DAVID HOGBEN , SEL, NBS . 8/16/69. FDP 40

DOUBLE PRECISION X,D FDP 50

Y=X FDP 60

D=Y FDP 70

FDPCON=X+(X-D) FDP 80

RETURN FDP 90

END FDP 100

DOUBLE PRECISION FUNCTION FDSIN(X) FDS 10

C VERSION 5.00 FDSIN 5/15/70 FDS 20

C FDS 30

C THIS FUNCITON IS TO TRAP IF ARGUMENT IS GREATER THAN 3.5D16 IN FDS 40

C ABSOLUTE VALUE BEFORE SYSTEM DOES. RESULT SET =0.0 FDS 50

C FDS 60

DOUBLE PRECISION DSNCOS,DXEXP FDS 70

COMMON /DCONLB/ DSNCOS.DXEXP FDS 80

DOUBLE PRECISION X.DSIN FDS 90

IF (DABS(X) .GT.DSNCOS) GO TO 20 FDS 100

FDSIN=DSIN(X) FDS 110

10 RETURN FDS 120

20 CALL ERROR (104) FDS 130

FDSIN=O.DO FDS 140

GO TO 10 FDS 150

END FDS 160

84
DOUBLE PRECISION FUNCTION FOSQRT (X) FDQ 10

C VERSION 5.00 FOSQRT 5/15/70 FDQ 20

C FDQ 30

C THIS FUNCTION TRAPS IF ARGUMENT IS NEGATIVE BEFORE SYSTEM DOES. FDQ 40

C RESULT SET =0.0 AND DIAGNOSTIC IS PRINTED FDQ 50

C FDQ 60

DOUBLE PRECISION X.DSQRT FDQ 70

IF (X.LT.O.DO) GO TO 10 FDQ 80

FDSQRT=DSQRT (X) FDQ 90

RETURN FDQ 100

10 CALL ERROR (101) FDQ 110

FDSQRT=0 .DO FDQ 120

RETURN FDQ 130

END FDQ 140

FUNCTION FEXP (X) FEX 10

C VERSION 5.00 FEXP 5/15/70 FEX 20

C FEX 30

C THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THAN 88.0 BEFORE FEX 40

C SYSTEM DOES. RESULT SET =0.0. FEX 50

C FEX 60

COMMON /CONSLB/ XTRIG,XEXP FEX 70

IF (X.GT.XEXP) GO TO 20 FEX 80

FEXP=EXP(X) FEX 90

10 RETURN FEX 100

20 CALL ERROR (102) FEX 110

FEXP=0. FEX 120

GO TO 10 FEX 130

END FEX 140

FUNCTION FEXP2 (B,E) FX2 10

C VERSION 5.00 FEXP2 5/15/70 FX2 20

DATA IEXP/60/ FX2 30

C FX2 40

C THIS FUNCTION IS INCLUDED TO CATCH EXPONENTIATION ERRORS BEFORE FX2 50

C THE SYSTEM DOES FX2 60

C FX2 70

IE=E FX2 80

IF (E.EQ.FLOAT(IE) .AND . IE .LT . IEXP) GO TO 20 FX2 90

FEXP2=FEXP(E*FL0G(B)) FX2 100

10 RETURN FX2 110

20 FEXP2=B**IE FX2 120

GO TO 10 FX2 130

END FX2 140

85
SUBROUTINE FIXFLO FIX 10

C VERSION 5.00 FIXFLO 5/15/70 FIX 20

COMMON /ABCDEF / L(48) FIX 30

COMMON /BLOCRC/ NRC ,RC (12600) FIX 40

COMMON /BLOCKD / IARGS(IOO) ( KIND (100) , ARGTAB (100 ) ,NRMAX ,NROW,NCOL ( NFIX 50

1ARGS ,VWXYZ (8) ,NERROR FIX 60

DIMENSION ARGS(IOO) FIX 70

EQUIVALENCE (ARGS (1 ) ,RC (12501 )

) FIX 80

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG FIX 90

C0MM0N/C0NLB2/ER,ISIGD FIX 95

COMMON /FMAT / IFMTX (6 ), IOSWT , IFMTS (6 )

, LHEAD (96 ) FIX 100

DIMENSION IB (3 ) FIX 110

DATA IB(1),IB(2),IB(3)/2H8F,2H8E,2H1P/ FIX 120

C FIX 130

C L2 = 3 FOR FIXED, L2 = 4 FOR FLOAT FIX 140

C L2=12 FOR FLEXIBLE FIX 150

C FIX 160

IF (L2.NE.12) GO TO 5 FIX 170

IOSWT=0 FIX 180

RETURN FIX 190

5 IF (L2.NE.4.0R.NARGS.NE.0) GO TO 8 FIX 192

1=6 FIX 194

GO TO 50 FIX 196

8 IF (NARGS.EQ.l) IF (KIND(l)) 30,40,30 FIX 198

1=10 FIX 200

10 CALL ERROR (I) FIX 210

20 RETURN FIX 220

30 1=20 FIX 230

GO TO 10 FIX 240

40 I=IARGS(1) FIX 250

IF (I .GE.O.AND.I .LE.ISIGD) GO TO 50 FIX 260

I=ISIGD FIX 270

CALL ERROR (237) FIX 280

50 I0SWT=1 FIX 290

IFMTX(5)=L(I+1) FIX 300

IF (L2.EQ.4) GO TO 60 FIX 310

C SET UP FIXED FORMAT FIX 320

IFMTX(3)=IB(1) FIX 330

IFMTX(2)=L(45) FIX 340

RETURN FIX 350

C SET UP FLOATING FORMAT FIX 360

60 IFMTX(3)=IB(2) FIX 370

IFMTX(2)=IB(3) FIX 380

RETURN FIX 390

END FIX 400

86
cc

c

c

10

20

30

40

50

60

70

80

C

C

C

90

100

110

SUBROUTINE FLIP

VERSION 5.00 FLIP 5/15/70

COMMON /BLOCRC/ NRC , RC ( 12600

)

COMMON /BLOCKD / IARGS(IOO) ,KIND(100) , ARGTAB ( 100 )

, NRMAX , NROW , NCOL ,

N

IARGS, VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS (1 ), RC (12501 )

)

EQUIVALENCE (I , IARGS (100) ) , ( J , IARGS (99 ) ) , (K , IARGS (98 ) ) , (KK , IARG

1S(97)), (M,IARGS(96)) , (MM, IARGS (95 )) , (MMM, IARGS (94 )) , (N,IARGS(9

23)), (NN,IARGS(92) ) , (A,ARGS(1))

FLIP COL ++ INTO COL ++, ++ INTO ++, ETC.

IF NARGS = 0, FLIP THE ENTIRE ARRAY (WORKSHEET).

IF (NARGS. EQ.O) GO TO 40

IF (MOD (NARGS, 2) .EQ.O) GO TO 30

1=10

CALL ERROR (I)

RETURN

CALL CHKCOL (I)

IF (I. EQ.O) GO TO 40

1=20

GO TO 10

IF (NERROR.NE.O) GO TO 20

IF (NRMAX-1 ) 50,20,60

1=9

GO TO 10

KK=NRMAX-1

K=KK/2

IF (NARGS. EQ.O) GO TO 90

DO 80 1=1 , NARGS ,

2

M=IARGS(I)

N=IARGS(I+1)

MM=M+KK

NN=N+KK

DO 70 J=M,MMM

A=RC(J)

RC(N)=RC(MM)

RC(NN)=A

N=N+1

MM-^MM— \

NN-NN-l

CONTINUE

GO TO 20

FLIP ENTIRE ARRAY

N=l

DO 110 1=1, NCOL

M=N

MM=M+KK

DO 100 J=1,K

A=RC(M)

RC(M)=RC(MM)

RC(MM)-A

M=M+1

MM*MM1

N=N+NROW

GO TO 20

END

87

10

20

30

40

50

60

70

80

90

100

110

120

130

140

150

160

170

180

190

200

210

220

230

240

250

260

270

280

290

300

310

320

330

340

350

360

370

380

390

400

410

420

430

440

450

460

470

480

490

500

510

520

530

540

550

560

570

580

590

600

610
FUNCTION FLOG (X)

C VERSION 5.00 FLOG 5/15

C FLOG CHECKS TO SEE IF ARGUMENT IS

C LIBRARY FUNCTION FOR NATURAL LOG.

C IF X IS ZERO OR NEG., RESULT IS =

IF (X.GT.O.) GO TO 10

CALL ERROR (101)

FLOG=0

.

GO TO 20

10 FLOG=ALOG (X)

20 RETURN

EM

FLE 10

70 FLE 20

GREATER THAN 0, BEFORE USING FLE 23

FLE 25

0 AND DIAGNOSTIC IS PRINTED. FLE 27

FLE 30

FLE 40

FLE 50

FLE 60

FLE 70

FLE 80

FLE 90

FUNCTION FL0G10 (X) FLT 10

C VERSION 5.00 FL0G10 5/15/70 FLT 20

C FLT 30

C THIS FUNCTION CHECKS TO SEE IF X IS ZERO OR NEGATIVE BEFORE USINGFLT 40

C LIBRARY AL0G10. INFORMATIVE DIAGNOSTIC IS PRINTED AND 0 RETURNED. FLT 50

C FLT 60

IF (X.GT.O.O) GO TO 20 FLT 70

CALL ERROR (101) FLT 80

FL0G10=0.0 FLT 90

10 RETURN FLT 100

20 FL0G10=AL0G10(X) FLT 110

GO TO 10 FLT 120

El\JD FLT 130

88
SUBROUTINE FNEC FNE 10

C VERSION 5.00 FNEC 5/15/70 FNE 20

C THIS SUBROUTINE HANDLES MISC FUNCTION COMMANDS WITH TWO ARGUMENTS , FNE 30

C THE FIRST IS (E) (A CONSTANT, OR COLUMN NUMBER) AND THE SECOND IS FNE 40

C (C) A COLUMN NUMBER FNE 50

C WRITTEN BY DAVID HOGBEN , SEL, NBS . 3/27/70. FNE 60

COMMON /BLOCKD / I ARGS (100) ,KIND (100 )

, ARGTAB (100 ) ,NRMAX ,NROW,NCOL ,NFNE 70

1ARGS,VWXYZ(8) ,NERROR FNE 80

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG FNE 90

COMMON /BLOCRC/ NRC ,RC (12600) FNE 100

DIMENSION ARGS(IOO) FNE 110

EQUIVALENCE (ARGS (1 ) ,RC (12501 ) ) FNE 120

COMMON /SCRAT/ NS ,NS2 ( A (13500) FNE 130

DOUBLE PRECISION Y,Z FNE 140

C ***** COMMANDS ***** FNE 150

C ERROR (E), (C) L2=18 BY I. STEGUN , 3/25/70. FNE 160

C CERF (E), (C) L2=19 BY I. STEGUN, 3/25/70. FNE 170

C ***** FNE 180

10 IF (NARGS.NE.2) CALL ERROR (10) FNE 190

IF (NRMAX.EQ.O) CALL ERROR (9) FNE 200

CALL ADRESS (1,J1) FNE 210

IF (Jl.LT.O) J1=-J1 FNE 220

IF (Jl.EQ.O) CALL ERROR (11) FNE 230

CALL ADRESS (2,J2) FNE 240

IF (J2.EQ.0) CALL ERROR (11) FNE 250

IF (J2.LT.0) CALL ERROR (20) FNE 260

IF (NERROR.NE.O) GO TO 70 FNE 270

LL=L2-17 FNE 280

DO 60 I=1,NRMAX FNE 290

IF (KIND(l) .EQ.l.AND.I .GT.l) GO TO 50 FNE 300

GO TO (20,30) , LL FNE 310

20 CALL ERRINT (DBLE (RC ( Jl ) ), Y ,Z) FNE 320

X=FDPCON(Y) FNE 330

GO TO 40 FNE 340

30 CALL ERRINT (DBLE (RC (Jl) ) ,Z,Y) FNE 350

X=FDPCON(Y) FNE 360

GO TO 40 FNE 370

40 J1=J1+1 FNE 380

50 RC(J2)=X FNE 390

60 J2=J2+1 FNE 400

70 RETURN FNE 410

END FNE 420

89
SUBROUTINE FNEIC FNC 10

C VERSION 5.00 FNEIC 5/15/70 FNC 20

C THIS SUBROUTINE HANDLES INSTRUCTIONS OF THE FORM (E), (I), (C) FNC 30

C WRITTEN BY DAVID HOGBEN , SEL, NBS. 4/21/70. FNC 40

C ***** COMMON ***** FNC 50

COMMON /BLOCKD / I ARCS (100) , KIND (100) , ARGTAB (100 ) ,NRMAX , NROW.NCOL ,NFNC 60

1ARGS ,VWXYZ (8) ,NERROR FNC 70

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG FNC 80

COMMON /BLOCRC/ NRC ,RC (12600) FNC 90

DIMENSION ARGS(IOO) FNC 100

EQUIVALENCE (ARGS (1) ,RC (12501) ) FNC 110

COMMON /SCRAT/ NS ,NS2 ,A (13500) FNC 120

C ***** FNC 130

IF (NRMAX.EQ.O) CALL ERROR (9) FNC 140

IF (NARGS.NE.3) CALL ERROR (10) FNC 150

IF (KIND(2) .NE.O) CALL ERROR (20) FNC 160

CALL ADRESS (1,J) FNC 170

IF (J.LT.O) J=-J FNC 180

CALL ADRESS (3,K) FNC 190

IF (J.EQ.O.OR.K.EQ.O) CALL ERROR (11) FNC 200

IF (K.LT.O) CALL ERROR (20) FNC 210

IF (NERROR.NE.O) RETURN FNC 220

N=IARGS(2) FNC 230

DO 10 I=1,NRMAX FNC 240

C ROUND X EQUAL TO (E) TO (I) SIGNIFICANT DIGITS, PUT IN COLUMN (C) FNC 250

C SUBROUTINE TO ROUND. WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/21/68. FNC 260

CALL DHRND (RC (J ) ,N ,RC (K) ) FNC 270

IF (KIND(l) .EQ.O) J=J+1 FNC 280

10 K=K+1 FNC 290

RETURN FNC 300

END FNC 310

90
c

cc

c

c

10

FNKC

00 FNKC 5/15/70

TREATS INSTRUCTIONS OF THE FORM (K)

DAVID HOGBEN, SEL, NBS . 4/22/70.

(C)

*****

SUBROUTINE

VERSION 5

SUBROUTINE

WRITTEN BY ***** COMMON

COMMON /BLOCKD / IARGS (100) , KIND (100) ,ARGTAB(100) ,NRMAX ,NROW,NCOL

,

1ARGS,VWXYZ(8) ,NERROR

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG

COMMON /BLOCRC/ NRC ,RC (12600)

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS (1 ), RC (12501 )

)

COMMON /SCRAT/ NS ,NS2 ,A (13500)

FKC

FKC

FKC

FKC

FKC

NFKC

FKC

FKC

FKC

***** RETURN

(9)

(10)

IF (L1.NE.24.0R.L2.NE.15)

CALL ERROR (235)

F (NRMAX.EQ.O) CALL ERROR

F (NARGS.NE.2) CALL ERROR

CALL ADRESS (2, J)

F (J.EQ.O) CALL ERROR (11)

F (J.LT.O) CALL ERROR (20)

F (NERROR.NE.O) RETURN

NST=ARGS(1)

F (NST.LE.O) NST=8192.0*ARGS(1)+0.1

F (KIND(l) .EQ.O) NST=IARGS(1)

NST=M0D(NST,8192)

DO 10 1=1 ,NRMAX

RNJBK SHOULD BE REPLACED BY MORE RELIABLE

CALL RNJBK (RC (J ) ,NST ,NST)

J=J+1

RETURN

END

AND EFFICIENT GENERATOR

10

20

30

40

50

60

70

80

90

FKC 100

FKC 110

FKC 120

FKC 130

FKC 140

FKC 150

FKC 160

FKC 170

FKC 180

FKC 190

FKC 200

FKC 210

FKC 220

FKC 230

FKC 240

FKC 250

FKC 260

FKC 270

FKC 280

FKC 290

FKC 300

FKC 310

91
n inn ai it t ti r rAi in ? a / \t a r> >i 1/ a a v SUBROUTINE FOURIA (Y , A ,R ,N ,KAA) F0U 10

VERSION 5.00 FOURIA 5/15/70 F0U 20

nnuni r nnPATCT^Ai \j / t \ r\ / t \ a a a ad * n n a n n An DOUBLE PRECISION Y ( 1 ) ,R (1 )

, A , AA , AB , AC ,BA ,BB , AD PAH F0U 30

DOUBLE PRECISION FDC0S,FDSIN FOU 40

M=N/2

K=2*M

FOU 50

FOU 60

L=0 FOU 70

TP /Al A U \ A A TA 1 A IF (N.EQ.K) GO TO 10

rni i FOU 80

L=l PAI

1

FOU A A 90

An ai AB=N PAI 1 FOU i nn 100

A A X AAAIAF'AA'Vm^nA 1 A n AA=6 .283 185307 1700/ AB

1" A 1 1 FOU 110

A=0 .0

r ai i FOU 120

n /|i> a R (M)=.0 PAII FOU 130

a a « AC=1

.

taii FOU 140

|N f\ a f\ T <» Al DO 20 1=1 ,

N

PAI 1 FOU 150

A A \J I T \ A=A+Y ( I

)

PAII FOU 160

n 1 AA \ n / AA \ 1 AiU / T v R (M)=R (M)+AC*Y (I

)

PAII FOU 170

A A ^ i in AC=-1 . AC PAII FOU 180

A i jin A=A /AB PAI 1 FOU 1 A A 190

D / Afl \ D/Al\ /AD K (M)=R (M) /AB PAI 1 FOU AAA 200

1 AA 1 ^ J=M+L-1 PAI I FOU 210

1/ A AA ^ KA=M+1 PAII FOU 220

f\ A A A 1/ 1 1 DO 40 K=l ,

J

pAl 1 FOU A ** A 230

DA W / T \ BA=Y ( 1

)

PAH FOU 240

n n a A BB=0 .

0

FOU n r n 250

AC=K PAII FOU 260

A A A A A A A AC=AC*AA PAII FOU 270

A A A A T A Al DO 30 1=2,

N

PAII FOU 280

Aft T 4 AD=I-1 PAII FOU 290

AD=AD*AC PAII FOU AAA 300

DA DA W / T v trn^Af / A A \ BA=BA+Y ( I

) *FDC0S (AD

)

PAI 1 FOU A 1 A 310

DD DD w / T \ i r f\T T II / Af\\ BB=BB+Y (I )*FDSIN (AD) PAII FOU AAA 320

n / / \ a Ada iad

R (K)=2 . 'BA/AB PAII FOU AAA 330

D/i/Av a Add / a d R(KA)=2 . BB/AB PAII FOU AAA 340

1/ A 1/ A 1 KA=KA+1 cm i FUU 1 C A 350

T p / i p n n \ ^ A T A f a IF (L.EQ.l) GO TO 50 PAII FOU 360

n / is a \ a R (KA)=0

.

PAII FOU A ^ A 370

RETURN FOU 380

END FOU 390

92
SUBROUTINE FPPT (Vll V12,P10,XA) FPP 10

r VERSION 5.0 FPPT 5/15/70. FPP 20

V1=V11 FPP 30

V2=V12 FPP 40

P0=P10 FPP 50

c CALLS PROB AND THEN USES ISOLATE METHOD FOR SOLVING ITERATIVELY FPP 60

DIMENSION X (5) , P (5) FPP 70

IF (Vl-1.5) 10,10,20 FPP 80

c USE STUDENT'S T FPP 90

c ONLY GOOD FOR P0=0.05 FPP 100

10 CALL TPCTPT (V2,XA) FPP 110

XA=XA**2.0 FPP 120

GO TO 70 FPP 130

20 IF (V2-1.5) 30,30,40 FPP 140

c ONLY GOOD FOR P0=0.05 FPP 150

c SHOULD USE STUDENT'S T FPP 160

30 XA = 225.0 FPP 170

GO TO 70 FPP 180

c TUKEY APPROXIMATION TO NORMAL PERCENT POINT FPP 190

40 YP=-4.91*(P0**.14-(1.-P0)**. 14) FPP 200

c AMS 55 APPROXIMATION 26.5.22 FPP 210

H=2. 0/(1.0 /(Vl-1.0) +1.0/ (V2- 1.0)) FPP 220

XLMBDA=(YP**2-3.0)/6.0 FPP 230

W=YP*FSQRT (H+XLMBDA) /H FPP 240

IF (V1-V2) 50,60,50 FPP 250

50 W=W-(1.0/(V1-1.0)-1.0/(V2-1. 0))*(XLMBDA+0. 833333--0. &66667/H) FPP 260

c AMS 55 APPROXIMATION 26.6.16 FPP 270

60 XA=FEXP(2.*W) FPP 280

70 XMIN=0.5*XA FPP 290

XMAX=2.0*XA FPP 300

CALL PROB (V1,V2,XMAX,Q) FPP 310

IF (Q.LE.PO) GO TO 80 FPP 320

XA=1.9999*XMAX FPP 330

GO TO 70 FPP 340

80 CALL PROB (V1,V2,XMIN,Q) FPP 350

IF (PO.LE.Q) GO TO 90 FPP 360

XA=0.5001*XMIN FPP 370

GO TO 70 FPP 380

90 XO=XA FPP 390

DO 140 1=1,5 FPP 400

X ( I )=XMIN+FLOAT ( I -1 ) * (XMAX-XMI N ) /4

.

FPP 410

100 CALL PROB (V1,V2,X(I) ,P(I)) FPP 420

110 IF (PO-P(I)) 140,130,120 FPP 430

120 XMAX=X ( I

)

FPP 440

XMIN=X(I-1) FPP 450

GO TO 150 FPP 460

130 XA=X(I) FPP 470

GO TO 160 FPP 480

140 CONTINUE FPP 490

150 XA=(XMIN+XMAX) /2. FPP 500

c EXIT IF EITHER TOLERANCE IS SATISFIED * ABSOLUTE 5E -6, REL. 5E-7 FPP 510

IF (ABS(XO-XA) .GT.5.E-6.AND.ABS(X0-XA)/XA.GT .5.E--7) GO TO 90 FPP 520

160 X V V RETURN FPP 530

END FPP 540

93

409-118 OL - 71 - 7
SUBROUTINE FPROB rno FPR 1 A 10

c

\«rnr t Aki r aa rnDAD C ltd / "7 A VERSION 5.00 FPROB 5/15/70 rnn FPR A A 20

c

tun TTTCll DU CDCAVIV 1 ft 11 1 lil WRITTEN BY 5 PtAVY 10/13/67 FPR *> A 30

c COMMAND IS AS FULLUWlNb FPR A A 40

c

rfiQAQ A D T 1 T TV 111 & \l O A C £ CTADC A TU rrtl FPR0BABILIIY VI » ,VZ * , r $ , blUKt (J IN LUL ++ FPK C A 50

COMMON /BL0CRC/ NRC ,RC (12600) FPR / A 60

COMMON /BL0CKD/ IARGS(IOO) , KIND ( 100 ) ,ARGTAB ( 100 )

, NRMAX , NR0W,NC0L , NFPR T A 70

lAKu O , V WA I L \ 0 ) , t»i_r\r\Ur\ rrR FPR O A 80

n T MPkK T DM AR£C./inm rrl\ FPR A A 90

pniiTV/AiFwrF (ADC? ii i RPii9<;nii\ FPR 1 A A 100

TCIP I( MADPC NAKbO . MTnt . AH\ P A 1 1 F DROP nni ) LALL C.KKUK tlUJ rrl\ FDP 1 1 A 110

tcy r iv(mnu T kin its

\ nAnuj ARCC. \) . MFnz. . n\u ) PAI l all1 FRRDR crrur IWijj FDP 1 A A 120

T 1 —

1

FPR r r f\ 1 ^ A 130

T 9 —1 1 t=l FPR 1 A A 140

1 J=l FPR rrR 1 C A PAI LALL1 MAnRFC-C URL J J

/

( 11 TARftC.MXl , lAnuj \I| ) FPR r rR T L A 160

tf iiAPr^nu in 9n ^n FPR r r r\ T ^ A 170

1 A 10 T1 1—1 —9c FPR r r l\ 1 O A 180

VI —ARK 0, i 1 \ FPR rrl\ 1 A A 190

cn to An FPR rrR *> A A 200

20 PAI vALL1 FRROR LnnUIV ill (11 \

j FPR rrR OTA 210

O A 30 IL—— TLHRuJ ARC?. ( 1 \ V 1 J FPR rrR AAA 220

A A 40 PAI 1 ATiRF 0. 0. 17 TARGCti?!^ FPR r r i\ 1 1 A 230

tf n&RC*\r?i i sn An 7n FPR rrn *i A A 240

C A 50 T 9—9 FPR rrR OCA 250

V9—ARfA r 9 * FPR rrn

A Z A 260

cn to an FPR r r r\ A 7 A 270

£ A 60 PAI 1 FRROR Mil FPR rr r\ AAA 280

7 A 70 M-T Aprc / o

\

III— 1 nl\U J \L ) FPR r r rt inn 290

O A 80 PAN AflRF 0. 0. i % !ARC<;nn FPR r r l\ 1 A A 300

tflr MiRC^/^u \ InnUJ ) gn inn lin / 7v,lUv,llU FPR rrR 9 1 A 310

n a 90 1 3—L rrR FPR O A A 320

F—ARfi^ 1"K \ rrR FPR 4)A 330

GOUU TO1 U 19n 1 c u FPR rrR •a a a 340

1 AA 100 PAI 1 FRROR Mil FPR OCA

1 1 A 110 W—T ADC< ' 7 \ FPR r r i\ o / A 360

1 A 120 PAI oALL1 AUKCjj AflPFCC /(NAKoj^) M ADCC If \ FPR r r l\ 370

TFlr IKIrv.LC.U; 1 F Al PAI LALL1 FRROR CKrwr1 nil (11 j rrR FPR O O A 380

if in aUxH mf a \ cn Tn 14(1 lr ( 1 1 + 1 1 + 1 > . Nt .

6

) uU IU 11U FPR r r fx

Jl A A 400

PAI UALL1 DDHR r KUD t\11 (VJ. ,¥tU9 ,rF H\ rrR FPR A 1 A 410

nn i in t i mpuay UU 13\l 1=1,NKWIAa FPR P rl\ Jl *5 A 4Z0

DP 1 If \ t\ KL (Is. )=y FPD P rl\ 430

130 V If 1 FPR P rR Jl Jl A 440

DFTIIQN KL 1 UKN FPR rrn Jl C A 450

140 nn 9i n t i mduay UU 11U 1 =1 , NKWIAA FPR P rl\ Jl L A 460

pn Tn /left i / a \ ti bU IU (130, 16U), 11 FPD P rl\ Jl 7 A 470

150 w i DP / 1 \ Vl=Kt (L

)

FPP PrK » OA 480

L=L+1 rPrKDD Jl A A 490

1 jf A 160 Pf\ TA /Mil l Oftl TO bU 1 U ( 1/0 , 180 ) , 1 L CDD PrK C A A 500

1 "f A 170 DO / Alt V2=K(y (M) TDD PrK CI A 310

M=M+1 FPR R9n

1 A A 180 GO TO (190,200), 13 FPR C 9 A 530

190 F=RC(N) FPR C Jl A 540

N=N+1 FPR CCA 550

200 CALL PR0B (V1,V2,F,RC(K)) FPR C L A 560

A 1 A 210 K=K+1 FPR C 7 A 570

RETURN FPR con 580

epjb FPR 590

94
SUBROUTINE FRDIST FRD 10

C VERSION 5.00 FRDIST 5/15/70 FRD 20

COMMON/BLOCRC/NRC,RC(12600) FRD 30

C0MM0N/BL0CKD/IAR6S(100) ( KIND(100) ,ARGTAB(100) ,NRMAX ,NROW,NCOL , FRD 40

1NARGS ,VWXYZ (8) ,NERROR FRD 50

DIMENSION ARGS(IOO) FRD 60

EQUIVALENCE (ARGS (1 ), RC ( 12501 )) FRD 70

COMMON /BLOCKE /NAME (4) ,L1 ,L2 , ISRFLG FRD 80

C WRITTEN BY DAVID HOGBEN , SEL, NBS . 10/25/69. FRD 90

C ***** FORMS OF COMMAND ***** FRD 100

C 1 FREQUENCY OF COLUMN (C) , PUT IN COLUMN (C) FRD 110

C 2 FREQUENCY OF COL (C) , USE (I) CELLS, PUT IN COLUMN (C) FRD 120

C 3 FREQUENCY OF COL (C) , USE (I) CELLS, OF LENGTH (A), PUT IN COL (C)FRD 130

C 4 FREQUENCY OF COL (C) , CELLS (I), LENGTH (A), START (A), IN COL (C)FRD 140

C 5 FREQUENCY OF COL (C), LOWER (C) , UPPER IN (C) , FREQ IN (C) FRD 150

C 7 FREQUENCY OF COL (C) , CELLS (I), LENGTH (A), PUT IN (C) , (C), (C) FRD 160

pb 0 r KtyUtlML Y Ur (b), LCLLi (1), LtNb 1 nlA\ CTAPT /A\ IU ir\ IC\ (A) , 5 1 AK 1 (A) , IN (L) , (L) / p \ con (b ) r KU 1 7A 1 / u

pb RCQFTQ KID MAY Tfl. MO AC PFI 1 C P p Tt r K V loU

b ***** cpn r ku I7U

TP 1 M APC< CT 1 AMR MARTS 1 T Q\ CC\ TA l nn 1 U 1UU cpn P KU onn tUU

p A 1 1 FODAD nni cpn P KU 0 1 A

L IU

PPTIIRM cpn P 1 1 u

O O A

o n rbALL Al 1 CDDAD LKKUK 1 1 \ (3 ) C R ft 0 1

A

£3U

PPTIIDM « KU OA A 3U pLALL ai I cDonD tKKUK n i \ (11) con r KU OCA

DCTIIDM Kt 1 UKN cpn rKU Al A 260

i aa 1UU PbALL A 1 1 AUKbbb AHDCCC / 1 M\ (1,J1) cdh rKU OTA Z70

T F / 1 1 \ OA 1 A 1 1 A lr (Jl) ZU , 3U , 110 ET 0 fi r h 0

O O A 110 PAI 1 ADDCCC /MADPC 1 0 \ LALL AUKtob (NAKbo , J Z ) C P> Pi P li i 0

AAA

z » 0

TF / In \ OA 1 f\ 1 O A lr (JZ) 20 ,30 , 1Z0 c d rs

Ir h U

1 A A 300

1 OA 1ZU No 1 =1 con rKU Q 1 A 310

l T III T A LIMIT = 0 FRD O t A 320

pb rUKM (1) C D [TS'i rKU lift 330

ir /UAD^C rn o\ pa Tfl QA1 lr (NAKbb . tQ . Z ) bU IU 901 r O ir,, rKU 3 4 0

200 1/ IU T A DP C / O \ KN = lAKbb(Z) r :© ?>, rKU OCA 350

p

c rUKM (3) rnn FRD 360

t r" /llADrf PA o\ PA TA A AO IF (NARbS . EQ . 3 ) GO TO 902 FRD 370

IF (KIND (3) .EQ .0) GO TO 500 1" A A FRD 380

A PI 1 A A A ^ / \ CELL = ARGS (3

)

CO A

lr Ir. D

*4 A A 390

Ac

i~ Ann / «i v FORM (3)IF* Ira (Fi\ 400

IF (NARGS.EQ.4) GO TO 903 C D Ft FRD A 1 A 410

A A A 400 IF (KIND(4) .EQ.0) GO TO 500 C O Ri rKU Jl O A 4Z0

NST = 0 FRD 430

STRT = ARGS (4) FRD 440

C FORM (4) FRD 450

IF (NARGS.EQ.5) GO TO 904 FRD 460

C FORMS (5), (6), (7), (8) FRD 470

500 CALL ADRESS (NARGS-2 , J3

)

FRD 480

IF (J3) 20,30,510 FRD 490

510 CALL ADRESS (NARGS-1 , J4

)

FRD 500

IF (J4) 20,30,520 FRD 510

520 LIMIT = 1 FRD 520

JJ = NARGS-3 FRD 530

GO TO (901,902,903,904) , JJ FRD 540

901 KN = 0 FRD 550

902 CELL = 0.0 FRD 560

903 STRT =0.0 FRD 570

904 CALL FREQCY (RC(J1) ,RC(J2) ,NRMAX,KN, CELL, NST, STRT, LIMIT, FRD 580

1 RC(J3) ,RC(J4)) FRD 590

95
NRMAX=KN

RETURN

END

FRO 600

FRD 610

FRD 620

SUBROUTINE FREQCY (X,F,N,K,C,NSTART, START, LIMITS, XL, XU) FRE 10

c VERSION 5.00 FREQCY 5/15/70 FRE 20

c SUBROUTINE TO CONSTRUCT FREQUENCY DISTRIBUTION IN VECTOR F FOR FRE 30

c VECTOR OF OBSERVATIONS X OF LENGTH N USING K CELLS OF LENGTH C. FRE 40

c IF C=0.0, THEN C IS DETERMINED BY SUBROUTINE. IF BOTH K AND C=0

.

0 , FRE 50

c THEN BOTH K AND C ARE DETERMINED BY THE SUBROUTINE FRE 60

c IF NSTART=1 , START DETERMINED. IF NSTART=0, START IS GIVEN

.

FRE 70

c 1C 1 TilTTC T 1 AUirD PCI 1 D A 01 fell I> A O T C C IF LIMIT5=1, LOWER CELL BOUNDARIES ARE PUT IN XL AND UPPER IN XU . FRE 80

c IUDITTCM D\/ nt\(Tn unrDCll en hi DC WKlTItN BY DAVID HUbbtN , StL , Nob. 10/25/69 • FRE 90

A T IJC HI C T A Al V / "1 \ VI / 1 \ V 1 1 / 1 \ D 1 MtNb 1UN X ( 1 )

, r ( 1 ), XL ( 1 )

, XU ( 1

)

FRE 100

100 IF (K.ST.0) GO TO 200 FRE 110

K = 1.5 + 3 . 3 r LUblO (r LUA 1 (N )

)

FRE 120

K = MAXO (K , 5 ) FRE 130

200 V II T Al V / 1 \ XM1N=X ( 1

)

FRE 140

V MA V V / 1 \ XMAX=X ( 1

)

FRE 150

UU 250 1=1 ,

N

FRE 160

TC/V/Tx IT V &1 T 11 \ V II T Al V/T\ 1 r (X ( 1 ) . L 1 . XM1N ) XM1N=X ( 1

)

FRE 170

T C / V / T \ PT V U A V \ V MA V V/T\ 1 r ( X ( 1 ) . b 1 . A MAX ) XMAX=X ( 1

)

FRE 180

250 f ftMT T All IC LUN 1 I NUt I" r> r FRE 190

T r /A\ 1AA o C A 3AA Ir (L) 300,260,300 r" n f~ FRE 200

260 RANGE=XMAX-XMI

N

FRE 210

C=RANGE/FL0AT (K-l

)

rnr FRE 220

300 IF (NSTART.EQ.O) 60 TO 500 FRE 230

START=XMIN-0.5*C pnr FRE 240

500 DO 510 1=1,

K

FRE 250

510 F(I)=0.0 FRE 260

DO 520 1=1,

N

FRE 270

J=(X(I)-START)/C+1.0 FRE 280

520 F(J)=F(J)+1.0 FRE 290

IF (LIMITS. EQ.0) RETURN FRE 300

600 XL(1)=START FRE 310

XU(1)=XL(1)+C FRE 320

DO 610 1=2,

K

FRE 330

XL(I)=XL(I-1)+C FRE 340

610 XU(I)=XL(I)+C FRE 350

RETURN FRE 360

END FRE 370

96
FUNCTION FSIN (X) FSI ,10

C VERSION 5.00 FSIN 5/15/70 FSI 20

C FSI 30

C THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THAN 3.3E7 IN FSI 40

C ABSOLUTE VALUE BEFORE SYSTEM DOES. RESULT SET =0.0 FSI 50

C FSI 60

COMMON /CONSLB/ XTRIG,XEXP FSI 70

IF (ABS(X) .GT.XTRIG) GO TO 20 FSI 80

FSIN=SIN(X) FSI 90

10 RETURN FSI 100

20 CALL ERROR (104) FSI 110

FSIN=0. FSI 120

GO TO 10 FSI 130

END FSI 140

FUNCTION FSQRT (X) FSQ 10

C VERSION 5.00 FSQRT 5/15/70 FSQ 20

C FSQRT CHECKS X FOR NEGATIVE VALUES. FSQ 23

C IF X.LT. ZERO, RESULT IS ZERO, AND DIAGNOSTIC IS PRINTED. FSQ 25

IF (X.LT.O.) GO TO 20 FSQ 30

FSQRT=SQRT (X) FSQ 40

10 RETURN FSQ 50

20 CALL ERROR (101) FSQ 60

FSQRT=0 . FSQ 70

GO TO 10 FSQ 80

END FSQ 90

FUNCTION FTANH (X) FTA 10

C VERSION 5.00 FTANH 5/15/70 FTA 20

C FTA 30

C SINCE TANH FUNCTION USES EXP FUNCTION FTANH CHECKS TO SEE IF THEFTA 40

C ABSOLUTE VALUE OF 2*X IS GREATER THAN XEXP (OR 88.3). IF THISFTA 50

C IS THE CASE, AND ERROR MESSAGE IS PRINTED AND FTANH=0 . FTA 60

C FTA 70

COMMON /CONSLB/ XTRIG,XEXP FTA 80

IF (ABS(2.*X) .LE.XEXP) GO TO 20 FTA 90

FTANH=0 .0 FTA 100

10 RETURN FTA 110

20 FTANH=TANH (X) FTA 120

GO TO 10 FTA 130

END FTA 140

97
CIIDDAIITTUC CIIMPT 5UdkUUI1Nl rUNul r UN 1 A 10

c tlTDCTAM C A A CIIMPT r n r lift VtKblUN b.OO rUNLI 5/15/70 Fl IM

r UN *5 A 20

COMMON /BL0CRC/NRC,RC(12600) Fl IM

r UN i n 3U

COMMON /BLOCKD/IARGS (100) ,KIND(100) ,ARGTAB(1Q0) ,NRMAX ,NR0W, NCOL

,

Fl IM r UN a n 10

1 MADP.C USIVV7 / (I \ NFPPOP Fl IM r UN DU

U 1 ML No lun HI\UJ(JLUU/ Fl IM

r UN L A 60

Fflll TVAI FWPF / A R 0 <. / l \ RP/1 95.01 \\ Fl IM r UN 7 A 70

roMunki /ri opkf / ma up i a \ i i i j t cppi r Fl IM r UN q n oU

pommon /pon^t^ / pt p mai ppt ofg par yai nc Fl IM r UN on70

COMMON /SCRAT/ NS ,NS2 , A (13500

)

Fl IM r UN i nn DIMENSION II (4) ,KK(4) Fl IM

r UN 1 1 A 110

EQUIVALENCE (1 1(1) ,11) ,(11(2), 12), (I I (3) ,13), (11(4), 14) Fl IM r UN 1 1 A 120

p FUN 1 1 A 130

p THIS SUBROUTINE HANDLES ALL TWO, THREE, AND 1 FOUR ARGUMENT FUNCTI0NFUN 1 A A 140

p IF THE FIRST ARGUMENT IS A CONSTANT, THE FUNCION IS EVALUATED FUN 1 C A 15U

p ONLY ONCE FUN 1 L A 160

p FUN 1 7 A 170

p L2= 1 SIN L2= 2 COS 12= 3 TAN FUN 1 Q A 1H0

pI* L2= b> b 4» COT V v I 1! 2=b ~~ 5 ARCSIN r» 1 \ W •# X 1 V 12= bi b 6w ARCC0S FUN ion 1VU

pU L2= 7 ARCTAN L2= 8 ARCC0T L2= 9 SIND FUN o nn 2UU

p 1 2=10 C0SD 1 2=11 TAND l 2=12 C0TD W 1 V FUN 0 1 A 210

p 1 2=13 ASIND 1 2=14 AC0SD l 2=15 ATAND FUN 220

p Ib> 2=16 b X V AC0TD TM W 1 1/ 1Lfa2=17 —X f SORT *J v( • \ 1

lLib2=18 —" X V EXPONENT b> f\ 1 WllLH 1 FUN 230

p ! 2=19 NEGEXP 1 2=20 L0GE l 2=2

1

b>b —""X 0 llb>Wvb>/\r bib>~b V L VUU b>b —bX LOGTEN VW 1 b> 11 FUN o a n 2*tU

p Ib.tb^"»b». 2=22 ANTIL0 nil i a b> v 12=2 bifc^tb./3 SINH ^ i in i

lb>b^~b~ 2=24 COSH WWJl I FUN o2DUun

p 12— t- b —25b J TANH 1 nllll L2-26 Lb—bw COTH wv 1 (1 L2-27 wb—b r ASINH FUN O L A 260

p 12—28 AC0SH L2—29 ATANH L2-30 ACOTH FUN 0 7 A

2 7 0

p I 2—31 ABSOLU 1 2—3? TNTFGF 1 2-33 FRAfTT FUN o o n 2oU

p rFUNuu O Q A 2V0

p run FUN inn 3UU

IFINARGS LT ? OR NAR^S fiT A\ PAN FRROR M01 FUN 1 \J li ii n 31U

TP fNAPf.^ FO %\ PAI 1 FRROR FUN 1 V 11 11C 315

HO 30 T—1 NAPOC FUN r vli ion 32U

( l ) =1 FUN run iin 3 JU

PAI OHLLI AUnt AnRF^JJ rT(1,11(1)) TT^T^^ FUN run i An

[ClTT lr Mil 1(1 1 n in (11 (1) J CU

,

IU

,

PUN run i en 35U

10 PAI 1 PRROP / o n

\

l/HLL Crciwtv (£U ) PUN run i^n 360 rn xn in PUN r uii 1 7 n 3 / U

1 A

l\l\ ( 1 ) =u PUN run i q n 3oU

TT/T\_ TT/T\ 11(1 )=-! 1(1) PUN r un ion 3VU

o a 30 CONTINUE PUN run iinn 1UU

IF (KK (NARGS) .EQ.O) CALL ERROR (11) PUN run A 1 A 410

IF(NRMAX.LE.O) CALL ERROR (9) pun r un >l 1 A 420

IF (NERR0R .NE .0) RETURN FUN r un 430

NR=NRMAX FUN AAI\ 44U

IF (NARGS .EQ .4) GO TO 36 FUN Ann 45U

KK(4)=1 FUN A L A 460

14=12 FUN VI 7 A 4 / U

IF (NARGS .EQ .3 ) 14=13 FUN VI O A 480

36 IL=I4 FUN vion 4VU

ILL=1 FUN

IF(KK(1) .EQ.l) GO TO 40 FUN enn 5UU

IF(NARGS.EQ.2) NR=1 FUN con 520

DO 1010 1=1, NR FUN CIA 530

GO TO (50,1005) , ILL FUN C 1 K 535

C A 50 X=RC(I1) FUN c vin GO TO (110,120,130,140,150,160,170,180,190,200, FUN CCA

1 210,220,230,240,250,260,270,280,290,300, FUN >A0 J o u

2 310,320,330,340,350,360,370,380,390,400, FUN 570

98
t « t <*\

4A ft i 1 AAAA\ I A 3 410 ,420 ,430 ,440) ,L2

C II AlCOA FUN 580

110 X=FSIN (X) CI 1 M

C ft ft PUN 590

AA TA 1 AAA GO TO 1000 CI IU

LAA FUN 600

120

X

= FC0S(X)

C 1 1 ML 1 A FUN 610

AA TA 1 AAA GO TO 1000 CI IM

LOA FUN 620

130 AX=FC05 (X)

C 1 | kl /.OA FUN 630

TC / AV AlCA A\

AA TA TIC IF (AX .Nt .0 .0) GO TO 135

C 1 1 MLAA FUN 640

132

VAA

X

= 0 . 0 C 1 1 il

LCA FUN 650

A

A 1 1 c

DDAD / 1 A "7\ CALL ERROR (107)C IIMLLA FUN 660

A

A TA 1 AAA GO TO 1000 CI IM

LTA FUN 670

135X

= F5IN (X) /AX CI 1 M / A

A FUN 680

A

A TA 1 AAA GO TO 1000

C 1 1 M Z.AA FUN 690 1 A ft 140 A V rf TM / V \ AX=F5IN (X) C 1 1 M 7 A A FUN 700

tt / »V

CAA A\AA TA 1 O

A I F (AX . EQ . 0 . 0 ) 60 TO 132

C 1 1 MT 1 A FUN 710

V CAAC/V\IAV X = FC05 (X) /AXC 1 1 M Tin FUN 720

A

A TA 1 AAA GO TO 1000 r* 1 1 M

TOA FUN 730 i c a 150 Y=X Z C 1 1 Ml 1 A ft FUN 740 T C / V AT / C\\ A A TA 1C1 1 r ( Y . G I . ( . 5 ) ) GO 10 151 CI IM T C A FUN 750

X=A I AN (X/rbQR 1 ( 1 . -Y ) ) C 1 1 M 1 L ft FUN 760 a a TA 1 C 1 GO 10 153 CI 1 M 17rt FUN 770

TCI Z.=XC 1 1 MTAA FUN 780

IF(X.Nt.O.O) IF (ABS(X)-l.) 154,158,159

r 1 111

TAA FUN 790

V UAI CDT X=HALrPlC 1 1 MOAA FUN 800

fr / I <l CA

C AD 11 CA 10\V UAICDTV lr(LZ.tU..5.UK.LZ.tQ.13) X=HALFr 1-XC 1 1 MO 1 A FUN 810

153 Tc/i

o at ia\

y ncrtv lr(LZ.ul.lO) X=Utb X

CI IMOO ft FUN 820

r\ TA 1 AAA GO 10 1000

C 1 1 AlOOA FUN 830

154 YY=1 . 0 C 1 1 M

OAA FUN 840

aA i cc i l ^ 00 155 J=l,3C 1 1 M OCA FUN 850

Y=XZ

C 1 1 MaL ft FUN 860

TC/V 1 C 1 C\\AA TA 1 C£ 1 r ( Y . Lt . ( . 5 ) ) GO 10 156 Ci i m <\n ft FUN 870

WW WW . WW YY=YY+YY CI 1 M AAA FUN 880

ICC 155 X=Y+Y-1 .CI 1 Al AAA FUN 890

v v* *o CUM AAA FUN 900

156

VC f PU / ATA ll / CC ADT / 1 \f\ fV\ /W 1 \ X=b IbN ( A 1 AN ( r bU.K 1 (1.—Y)/X)/YY,Z)C 1 1 M

A 1 A FUN 910 1 C 7 157 TC/7 IT A A \ V DTiV 1 r ( Z. . L 1 . u , (J ) X=rl+X CUM AAA FUN 920 A A T A 1 c 1 GO 10 152 C 1 1 M A O A FUN 930

ICO 158VAA X=0 . 0 C 1 IM ftA ft FUN 940

AATA 1 CT GO TO 157C 1 1 MACA FUN 950 1 n A 159 V A A X=0 . 0 C 1 1 M ft £ ft FUN 960

AAI 1 CDDAD /1A?\ LALL tKKUK (103)C 1 1 M ATA FUN 970

A

A TA 1 AAA GO TO 1000

C 1 1 MAOA FUN 980 1 Z A 160 A A TA 1 C 1 GO TO 151 C 1 IM AAA FUN 990

170 X=A TAN (X)

C 1 1 M 1 AAA FUN1000

AA TA 1 AAA GO TO 1000C 1 1 M 1 A 1 A FUN1010

ion 180 TC/V CAA A\ AA TA. 10*5 Ir(X.tQ.O.O) GO 10 132C 1 IM 1 AAA FUN1020

V ATAU /I / V\ X=A 1 AN (1 . /X)C 1 1 M 1 AOA FUN1030

AA TA T. AAA GO 10 1000C 1 1 M 1 A ilA FUN1040 1 A A 190 X=F5IN (RAD X) r* 1 1 bi i a p a FUN1050

AA TA 1 AAA GO TO 1000r i ill i a / ft FUN1060

AAA 200

V CAAC/DAA*V\ X=r UOb (RAD X )

riUM ATA FUN1070

AA TA 1 AAA ou IU 1000 rij Al 1 A

OA FUN1080

210

VV#DAA X=X RAD

n Itl 1 AAA FUN1090

AATA 1 9 A GO 10 130

n in i i aa FUN1100 1 1 A 220 V V * D A A X=X*RAD run i % * a FUN1110 A A TA l 4 A GO TO 140 r* 1 1 ai i i a /\ FUN1120

Z30

AA TA 1 CA GO 10 150 r* 1 1 fct i i •) ft FUN1130

Z40

AA TA l El GO TO 151 FUN1140

ft f*

A 250 X=DEG ATAN (X) FUN1150

GO TO 1000 FUN1160

99
260 1 r (X . b(j . 0 . 0 ) bU IU 132 1 C 1 1 Al 1 1 f A rUNll/0 V A.CP*ATAAI!/1 A/V\ X=DEG ATAN (1 .0/X) CI 1 Al 1 1 OA FUN1180

PA Trt 1 AAA bU IU 1000 CI IU 1 1 OA r UN11VU

270

V C"C ADT / V\ X=r bQK 1 (X )

rilMI 1 A

A

r UN1200

aa Tn iaaa bU IU 1000 CI IM 1 1 1 A r UN1210

280 X=rtXr (X)

C 1 1 kt 1 lift r UN1220

PA TA IAAA GU IU 1000C 1 1 M 1 1 1 A r UN1230 1 A A V CCVO / V \

X=rtXr (-X)

C 1 1 M 1 OJIft r UN1240

AA TA 1 AAA bU IU 1000 CI IM 1 OCA rUN1250 V C 1 AP / V \

X=rLUb (X) CI IM 1 1 L

A

r UN1260

pft TA IAAA bU IU 1000

C 1 1 M 1 lift r UN1270

liftTC / V ATAA\ AA TA Ol

c

ir(X.bl.O.O) bU IU 315 CI 1 M 1 IQft r UN1280 V A A X=0 . 0 C 1 IM 1 Iftft r UN1290

AAII CDDAD (inn LALL tKKUK (101) CI IM 1 1 AA FUN1300

AA TA 1 AOn bU IU 1000 CI IM 1 11

A

r UN1310

315

VC 1 AA 1 A / V\ X=r LUblO (X) FUN1320

AA TA 1 AAA bU IU 1000 CI 1 Al 1 ))A FUN1330

320 ic ly pt VAI AP

\ PA TA lie 1 r ( X . b 1 . XALUb ) bU IU 325

C 1 IM 1 1 AA

r UN1340

Y 1 A * * Y X=10 . X

CI IM 1 OCA r UN1350

AA TA IAAA bU IU 1000 ci im i l in r UN1360

325

Y

AA

X

=0 . 0 C 1 1 Al 1 17ft r UN1370

AAI 1' rnnnn /iai\ LALL tKKUK (102)C 1 1 AM 1 OA FUN1380

AA TA IAAA bU IU 1000C 1 1 Al 1 1 ftA I-UN1390

330

AV CT AMU / V

\

AX=r 1 ANn (X )

CI IM 1 A AA r UN1400

PATA liic bU IU 345 CI IM 1 /I 1 A r UN1410 1 A A 340 A V 1 A AX=1 . 0

CI IM 1 /1A r UN1420

1ACV CC YD / Y

\

Y=r tXr (X)

C 1 1 Al 1 A 1 A r UN1430

VC * / V . 1 / V\ * AV X= .5 ( Y+l . / Y ) AXC 1 1 Al 1 Jl ilA

r UN1440

AA TA IAAA bU IU 1000C 1 1 Al 1 ACA

r UN1450 1 C A 330 V CT A UU / V \

X=r 1 ANn (X )

CI IM 1 ALA

r UN1460

PA TA IAAA bU IU 1000 CI IM 1 Jllrt rUN1470 1 £ A 360 V CT A MU / V \ Y=r 1 ANn (X )

CI IM 1 JlOA

r UN1480

T1 Cr /( VY . CAtU. . A0 . 0A\ AA TA HI ) bU IU 132 CI IM 1 Jl ftA

I- UN1490

X—1 . 0 / Y

CI IM1C AA rUN1500

AA: TA 1 AAA bU IU 1000 CIIMl CIA rUlMlDlU

O 7 A 370V CTPAI/CIAA/ADC/V\.CCADT/V*#1.1 A\\ V\ X=b IbN ( r LUb ( Abb (X ) +rbU.K l(X 2+1.0)),X) ciimi con rUN1520

AA TA IAAA bU IU 1000 CIIMl CIA r UN1530

380

V CIAA/ADC/V\.CCADT/V**1 1 A\\ X=r LUb (Abb (X ) +rbU.K 1 (X 2-1 . 0 ) ) CIIMlCAA rUN1540

AA TA IAAA bU IU 1000 CIIMl CCA r UN1550 1 A A 390 TC/ADC/V\ AC 1 A\ AA TA 1 n 1 r ( Abb (X ) . bt . 1 . 0 ) bU IU 13i rUN1560 V e skci AA / / 1 ,V \ HI A V\\ X= . 5 r LUb ( ( 1 . +X ) / ( 1 . 0-X ) )

CIIMlC 7 A

r UN1570

AA TA IAAA bU IU 1000 CIIMl

COA rUN1580

AAA 400 TC/ADC/Vv IC 1 A\ AA TA 1 Ol 1 r (Abb (X ) . Lt . 1 . 0 ) bU IU 132 ciimi can r UN1590 V C*CIAA//V.l A\//V 1 A\\ X= . 5 FLOG ( (X+l . 0 ) / (X-l . 0 ) )

CIIMlLAA rUN1600

PA TA IAAA GO TO 1000 CIIMl /II

A

r UN1610

A 1 A

VADC / V\ X=AB5 (X )

ciimi /.on rUN1620

PATf\ l AAA GO TO 1000 CIIMl

L 1 A

r UN1630

J

AA 420

V 1 TUT / VV X=AINT (X) CI IM 1 JL/I

A

r UN1640

/*

A TA 1 AAA GO TO 1000 ciimi / cn rUN1650

430

VV AT AIT / V\ X=X-A1N \ ( A )

rUNlOoO

PATA IAAA bU 10 1000 CIIMI 47

A

run lo / o

AAA 440 X=X

X

ciimi ten rUNlooO 1 ft A A 1000 V A V XA=X CIIMI /IOC TUN1685

YCyAIADPC CAA\ PA TA 1 AAT I F (NAKGS .EQ . 2 ) GO TO 1007 ciimi /.on r UN16V0 1 A A F 1005 X=XA*RC ( 12 ) +RC ( 13 )

CIIMl roc rUN1695

1007

DA / TA\V RL ( I4)=X CIIMl 7 AA rUNl/00 T 1 fl .I/I//1V I1=I1+KK(1) CIIMI 7 A C rUNl/03

CIIMI rum7 1 A / iu

I3=I3+KK(3) FUN1715

100
I4=I4+KK(4) FUN1720

IF (I .EQ . 1 .AND . NARGS .NE . 2 .AND .KIND (1 ) . EQ . 1 ) ILL=2 FUN1722

1010 CONTINUE FUN1725

IF (KIND (1 ) .EQ . 1 .AND .NR . EQ . 1 ) CALL VECTOR (RC(IL).IL) FUN1730

RETURN FUN1740

END FUN1750

101
SUdKUU 1 INt bcNcK GEN 10

c UCDC TAM C ftft P C AI C D C / 1 C / 7 ft VcKbluN 5.00 btNtK 5/15/70 GEN 20

COMMON /BLOCRC/ NRC ,RC (12600) GEN 30

COMMON /BLOCKD/ IARGS(IOO) ,KIND(100) , ARGTAB (100 )

, NRMAX ,NR0W, NCOL , NGEN A A 40

1ADPC WIVVV7 rd \ MITDDnD lAKbo , VWaYZ. (o ) ,NtKKUK PPM btN C A 50

ft T MFMC T HRI AOPC / 1 Oft \ btN 60 rnn t u ai pkipf /arpqmi rp / i 9k ai i

i

tyUlVALLNLL (AKUJ (1 ) ,ltt (liJUl ) ) PFW btN 70

pc UC.Lc.lt DLULIVt btN O A 80

p PFMFRATF OlNlKA 1

L

PFN btN A A 90

p MADrc NSKuj MIICT MUj 1 RPDC CP A AMD Fl/FN . Ut . «t AHU CV CN PPM UtN i ft ft 100

TP1 r fMARPC: (NAROJ .ULCP . AH . MIMU AMD . UDD NIUU f(HAnuj N ARPC 91 PO ft\ CO TO in , £ ) . Cw. . U ; uU 1 U IU PPM lift 110

PLALL AI 1 CDBflP tKKUK M ft 1

( 1 U ) PPM btN lift 120 rnoU Tft oft 1 U 7U PPM btN 1 1 ft 130

p PPT Ol 1 CTO.P AP.F rni IIMM AfinPFCC O 1 UnAuC LULUMN AUUHlj j PPM btN 1 A ft 140

1 ft r AI 1 AflPFQQ /MAPPQ 1 \ CALL AUnCjj ( IMMftU j ( J J PPM Otll 1 C ft 15U

tp i i pt n\ pn th oft I r ( J . b I . u ) oU IU c. u PPM btN T L ft 160

Pl/ALL AI 1 FRRO.R r 1 \ CI\I\UI\ \J) PPM 17ft 170

pnOU to1 U on7U PPM btn 1 O ft 180

1 ft ZQ TP /KIPRROR NP ft\ P(l TO Qft PPM i A ft 190

p mNVFRT TNTFPFRC Tfl Fl flAT T NP PP.TNT PFN *> ft ft 200

nn %n t_9 nappc PFN 1 1 ft 210

TF fKTNfWT 1 \ PO ft\ ARPC M 11 — TARPCM 11 PFN 1 1 /\ 220

i n 30 mNTTNIIF PFN *5 1 ft 230

RP / 1 \ _ARPC Ml PFN 2*»0

KinPOUf— NUKU n= 1 ^MRHUI 1 J II—

1

PFN O C ft 25U

fin UU 7ft /U T—1=1,I1ARuJ,i A NARPC 9 PFN Utll 1 L ft 260

TFlr /(AKuj ARPC (/ T1 —^1J ) . PTb 1 .Al\b5(l— ARPC/T 1\\ ARC? l! 9 \ _C T PM / ARPC / T 91 11 1) ) AKbo ( 1 —c) =5 lbN(AKbo(l—c ) , — 1 . ) PFN *i i ft 2/0

J—Q—CTPNM ARPC 1 T 91 1 J 1 uN ( 1 . , AKb i ( 1 —i) ) PFN utli O O ft 2o0

FMnPR— CNUCl\=Ml\u3 ARPC/T 11 ft1*ARPCM 9 1

\ 1 — 1 ; — . U 1 AI\uj(1 —C) PFN ucn O ft ft 290

40 1— 1 1 PFN 3ftft RP 1 1 1—RP M 11 , ARr,< / T 9 1 KVs ( J ; =l\U v J — 1 ; +Mi\« j \ 1 —£ ) PFN Olft 310

TF fC*/RP/!l FMnPRll Cft Aft Aft PPN 1 O ft 320

p mot nu i nnniF uurac CPN 330

C ft 50 tf /i it unRnufi pn Tn a<\ lr (j.li .nuKuwj ou iu *?u PFN 1 A ft 340

p FYrppnpn CALCCUCU rni LULUIWI mum iLlIIU fnpth1 n PPN

p A 1 I FPRO.R / O ft 1 1 PFN ucn 1 L ft 360

f n Tft Oft bU IU 80 PFN 17ft 3/0

pC DACCFC PFMFDATP 1 IDDPD Qftl IMft CFT IU IIDDFR DPI IMn

r Aooco btNtKA 1 c UrrtK DUUNU , be 1 IN UrrtK DUUNII PPM bCN i on 3o0

60 RC(J)=ARGS(I-1) GEN ion 3V0

70 CONTINUE GEN Ann

80 NRMAX=MAX0 (NRMAX , J-NDR0W+NR0W) GEN A 1 ft 410

90 RETURN GEN A 1 ft 420

END GEN 430

102
SUBROUTINE GOUAD QUA 10

r VERSION 5.00 GQUAD 5/15/70 QUA 20

r WRITTEN BY DAVID HOGBEN SEL , NBS . 8/18/69. QUA 30

COMMON /BLOCKD/ IARGS(IOO) ,KIND(100) ,ARGTAB(100) , NRMAX ,NR0W,NC0L ,NQUA 40

1ARGS,VWXYZ(8) ,NERR0R QUA 50

COMMON /BLOCRC/ NRC , RC ( 12600

)

QUA 60

DIMENSION ARGS(IOO) QUA 70

EQUIVALENCE (ARGS (1) ,RC (12501)

)

QUA 80

c DOUBLE PRECISION USED TO AVOID NOISE IN 8TH DIGIT. QUA 100

c SLIGHT NOISE MAY BE LEFT DUE TO CONVERSION FROM DP TO SP QUA 110

DOUBLE PRECISION C ,B , BPA , BMA , DELGQ , STORE 1 ,ST0RE2 QUA 120

c TAKEN FROM SYMBOLIC LISTING PAGE 251 (YELLOW COVER) JULY, 1965 QUA 130

c A GOES TO C BECAUSE A DIMENSIONED QUA 1 4 0 10 IF (NARGS.EQ.5) GO TO 20 QUA 150

CALL ERROR (10) QUA 160

RETURN QUA 17 0 c N MUST BE AN EXACT MULTIPLE OF 4 AND LESS THAN NROW QUA 180

20 NGQ=INT (ARGS (1) ) *KIND (1 )+IARGS (1) * (1-KIND (1 )

)

QUA 1

€>0 IF (M0D(NGQ,4) . EQ . 0 . AND . NGQ .GT . 0 ) GO TO 50 QUA 2 O 0 30 CALL ERROR (3) QUA 210

RETURN QUA 2 2

0

40 CALL ERROR (10) QUA 230

RETURN QUA 240

50 IF (NGQ. GT. NROW) GO TO 30 QUA 250

c RESET NRMAX IF NECESSARY QUA 260

NRMAX=MAXO (NGQ , NRMAX

)

QUA 270

CALL ADRESS (4 , JPGQ) QUA 2 8 0 IF (JPGQ) 30,40,60 QUA 290

60 JPGQ=JPGQ-1 QUA 300

CALL ADRESS (5,JWGQ) QUA 310

IF (JWGQ) 30,40,70 QUA 3 2 O 70 JWGQ=JWGQ-1 QUA 330

IF (NERROR.NE.O) RETURN QUA 340

C=ARGS(2)*FL0AT(KIND(2) ) +FLOAT ( IARGS (2 ) * (1-KIND (2) )

)

QUA 350

B=ARGS(3)*FL0AT(KIND(3) ) +FLOAT ( I ARGS (3 ) * (1-KIND (3) )

)

QUA 360

DELGQ=NGQ QUA 370

DELGQ=4 .DO* (B-C) /DELGQ QUA 380

DO 80 1=1, NGQ,

4

QUA 390

B=C+DELGQ QUA 400

BPA=(B+C) /2 . DO QUA 410

BMA=(B-C) /2 .DO QUA 420

K1=I+JPGQ QUA 430

K2=I+JWGQ QUA J 4 p ST0RE1=-. 86 11363 11594053 DO*BMA QUA 450

ST0RE2=-. 33998 1043584856D0*BMA QUA 460

RC (Kl )=FDPCON (ST0RE1+BPA) QUA 470

RC(K1+1)=FDPC0N(ST0RE2+BPA) QUA 48©

RC (Kl+2 )=FDPC0N (BPA-ST0RE2

)

QUA 490

RC (Kl+3 )=FDPCON (BPA-ST0RE1

)

QUA 500

RC (K2)=FDPC0N ( . 347854845 137454D0*BMA) QUA 510

RC(K2+1)=FDPC0N( . 652145154862546D0*BMA) QUA 520

RC(K2+2)=RC(K2+1) QUA 530

RC(K2+3)=RC(K2) QUA 540

80 C=B QUA 5 30

RETURN QUA 560

END QUA 570

103
c

c

cc

cc

cc

c

c

cc

c

c

c

c

c

c

cc

c

c

c

c

c

c

10

20

30

40

50

C

60

C

C

C

C

C

70

SUBROUTINE HDIAG (A ,N , IEGEN ,U , COL , VECTOR ,NROW,H)

VERSION 5.00 HDIAG 5/15/70

DIMENSION A(NR0W,1), H(54,54), U(54,54), X(54), IQ(54), COL(l),

1CT0R(NR0W,1) , IEGEN (2

)

MIHDI3, FORTRAN II DIAGONALIZATION OF A REAL SYMMETRIC MATRIX BY

THE JACOBI METHOD.

MAY 19, 1959

CALLING SEQUENCE FOR DIAGONALIZATION

CALL HDIAG ( H, N , IEGEN, U, NR)

WHERE H IS THE ARRAY TO BE DIAGONALIZED

.

N IS THE ORDER OF THE MATRIX, H.

IEGEN MUST BE SET UNEQUAL TO ZERO IF ONLY EIGENVALUES ARE

TO BE COMPUTED.

IEGEN MUST BE SET EQUAL TO ZERO IF EIGENVALUES AND EIGENVECTORS

ARE TO BE COMPUTED.

U IS THE UNITARY MATRIX USED FOR FORMATION OF THE EIGENVECTORS.

NR IS THE NUMBER OF ROTATIONS.

A DIMENSION STATEMENT MUST BE INSERTED IN THE SUBROUTINE.

DIMENSION H(N,N), U(N,N) , X(N), IQ(N)

THE SUBROUTINE OPERATES ONLY ON THE ELEMENTS OF H THAT ARE TO THE

RIGHT OF THE MAIN DIAGONAL. THUS, ONLY A TRIANGULAR

SECTION NEED BE STORED IN THE ARRAY H.

DO 10 1=1,

N

DO 10 J=l ,N

H(I,J)=A(I,J)

CONTINUE

IF ( IEGEN (1) ) 60,20,60

DO 50 1=1,

N

DO 50 J=1,N

IF (I-J) 40,30,40

U(I ,J)=1.0

GO TO 50

U(I,J)=0.

CONTINUE

NR=0

IF (N-l) 440,440,70

80

90

SCAN FOR LARGEST OFF DIAGONAL ELEMENT IN EACH ROW

X(I) CONTAINS LARGEST ELEMENT IN ITH ROW

IQ ( I ) HOLDS SECOND SUBSCRIPT DEFINING POSITION OF ELEMENT

NMI1=N-1

DO 90 I=1,NMI1

X(I)=0.

IPL1=I+1

DO 90 J=IPL1,N

IF (X(I)-ABS(H(I,J))) 80,80,90

X(I)=ABS(H(I,J))

IQ(D=J

CONTINUE

HDI

HDI

VEHDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

HDI

10

20

30

40

50

60

70

80

90

100

110

120

130

140

150

160

170

180

190

200

210

220

230

240

250

260

270

280

290

300

310

320

330

340

350

360

370

380

390

400

410

420

430

440

450

460

470

480

490

500

510

520

530

540

550

560

570

580

590

104
cc

c

c

cc100

110

120

130

C

C

140

150

160

170

180

C

C

C

190

C

C

c

c

c

200

HDI 600

HDI 610

HDI 620

HDI 630

HDI 640

HDI 650

HDI 660

HDI 670

HDI 680

HDI 690

HDI 700

HDI 710

HDI 720

HDI 730

HDI 740

HDI 750

HDI 760

HDI 770

HDI 780

HDI 790

HDI 800

HDI 810

HDI 820

HDI 830

HDI 840

HDI 850

HDI 860

HDI 870

HDI 880

HDI 890

HDI 900

HDI 910

COMPUTE TANGENT, SINE AND COSINE ,H (I , I ) ,H (J , J ) HDI 920

TANG=SIGN(2.0, (H (IPIV , IPIV) -H (JPIV JPIV) ) )*H (IPIV , JPIV) / (ABS (H (IPIHDI 930

1V,IPIV)-H(JPIV ( JPIV))+FSQRT((H(IPIV,IPIV)-H(JPIV,JPIV) ) **2+4 . 0*H ( IHDI 940

2PIV,JPIV)**2))

C0SINE=1./FSQRT(1.0+TANG**2)

SINE=TANG*COSINE

HII=H(IPIV, IPIV)

H(IPIV,IPIV)=C0SINE**2*(HII+TANG*(2.*H(IPIV,JPIV)+TANG*H(JPIV / JPIVHDI 990

1))) HDI 1000

H( JPIV ,JPIV)=C0SINE**2*(H( JPIV, JPIV) -TANG* (2. *H ( IPIV, JPIV) -TANG*HIHDI1010

SET INDICATOR FOR SHUT-OFF .RAP=2**-27 ,NR=NO . OF ROTATIONS

HDTEST=1.0E37

RAP=7 .45058059E-9

FIND MAXIMUM OF X(I) S FOR PIVOT ELEMENT AND

TEST FOR END OF PROBLEM

DO 130 I=1,NMI1

IF (1-1) 120,120,110

IF (XMAX-X(I)) 120,130,130

XMAX=X(I)

IPIV=I

JPIV=IQ(I)

CONTINUE

IS MAX. X(I) EQUAL TO ZERO, IF LESS THAN HDTEST, REVISE HDTEST

IF (XMAX) 440,440,140

IF (HDTEST) 160,160,150

IF (XMAX-HDTEST) 160,160,190

HDIMIN=ABS(H(1,1))

DO 180 1=2,

N

IF (HDIMIN-ABS(H(I ,1) ) ) 180,180,170

HDIMIN=ABS(H(1 ,1)

)

CONTINUE

HDTEST=HDIMIN*RAP

RETURN IF MAX .H (I , J )LESS THAN (2**-27 ) ABSF (H (K ,K)-MIN

)

IF (HDTEST-XMAX) 190,440,440

NR=NR+1

HDI 950

HDI 960

HDI 970

HDI 980

210

C

C

C

ID)

H(IPIV,JPIV)=0.

PSEUDO RANK THE EIGENVALUES

ADJUST SINE AND COS FOR COMPUTATION OF H(IK) AND U(IK)

IF (H(IPIV,IPIV)-H(JPIV,JPIV)) 200,210,210

HTEMP=H(IPIV,IPIV)

H(IPIV,IPIV)=H(JPIV,JPIV)

H(JPIV,JPIV)=HTEMP

RECOMPUTE SINE AND COS

HTEMP=SIGN (1.0, -SINE) *COSINE

COSINE=ABS(SINE)

SINE=HTEMP

CONTINUE

INSPECT THE IQS BETWEEN 1+1 AND N-l TO DETERMINE

WHETHER A NEW MAXIMUM VALUE SHOULD BE COMPUTED SINCE

HOI 1020

HDI1030

HDI1040

HDI1050

HDI1060

HDU070

HDI1080

HDU090

HDI1100

HDI1110

HDI 1120

HDI1130

HDI1140

HDI1150

HDI1160

HDI1170

HDU180

105
a tuc DDCCCWT MAYTMIIM TC TM TUC

T t\Q 1 DP.11I 1 Ht rKtbtra 1 MAAIMUM lb in IHt 1 UK J KUW. LI

AT 1 1 AA HU1 1190

C

LIAT 1 1 AA HU1 1200

T\f\ OQto T_l KIMT 1 U

AT 1 1 1 A HU 1 12 10

TC / T I D

T

M\ lift ogn oon lr (1— lrlV) 23U,2oU,22U MAT! 1 1 A

HU 1 1220

220 tc / t idtv/\ nn ion iin lr (1-Jrlv) 23U , 2oU ,230 LI

AT 1 1 1 A HU 1 1230

23U TC / T

A / T\ TDT\/\ OylA OCAO vlA Ir (114(1)— lrlV) 24 U , 2DU , 24U LIAT 1 1 A t\ HU 11240

o ylA 240 TC

nA / T\ 1 DT

W\

OOA OCA ion Ir (iy(l)—JrlV) 2oU,25U,2ou

UAT 1 1 CA HU 1 1250

25U

KK=iyT P. / T\ (i ) U

AT 1 1 £A HU 1 1260

UTCMDU IfV

\

n 1 LIVIr=n ( 1 , a. ) U

AT 1 1 7 A HU1 1270

U / TV\ to

n ( l , r\ ) =u . HU 1 12o0 TlrLl=l+l DI 1 Til LI A T 1 1 A A HU 1 1290 Y / T \ A X (1 )=0 .

LIAT 1 1 AA HU1 1300

L

UAT 1 1 1 A HU1 1310

rii CCADPU ItAKln TM nCDI CTCn DAill COD MCUf MAYTMIIM Ira UtrLt I lu KUW r UK nc.fl MAaIMUM

unT 1 1 1 A HU1 1320 U A T 1 11 to HU1 1330

nn nn 1 TDIl

M UU 2 / U J = l rLl , IM

UAT 1 1 A to HU1 1340

TC (V ( I \ ADC ;LJ / I 1/,n 1i

n 17(1 IT ( A ( 1 ) —ADO (H ( 1 , J ) ) ) 26U,26U,2/U un

t i i cn HU1 13DU

20U

Y 11\ ARC / U / T 1 \\

A ( 1 )=ADb (n ( 1 , J ) )

unT 1 1 L to HU 1 1360 1 U. ( 1 ) =J

LIAT 1 51A HU1 1370 7 7 ft PO.MT ? Ml IIP \»ura i i rauc LI A T i ion HU 1 13oU U 1 T V \ UTCMD n ( 1 ,r\ )=H I tMr LI A T 1 1 Q to HU 1 1390 9 a n & o y POMT T Ml IC UUN 1 1 rout LI A T 1 A A A HU 1 1400 p u n T 1 A 1 A HU 1 14 1U YA /( TDTU\_n 1 r 1 V ) =U .

un

T

t ao to HU 1 142U

Ay i ipivi —to ( J r 1 V ) =U .

unT 1 A 1 to nUl 143U

p

UAT 1 AA to HU1 1440

r>t PUAMPC TUC P.TUCD CI CMCMTC P.C

U UHArabt Int U IHtK tLtMtn 1 b Ur H

UAT 1 ACA HU1 1450

p Un

T 1 A L. to HU 1 1460

r\A liftt i kj UU 410 1=1 , n Un

T 1 Alto HU 1 1470

pUHUA

T i a

OA 1 14oU

TC /T TDT\/\ OQA Alto 11 to Ir (1-lrlv) 290,410,33U unT 1 AQ

A

HU 1 149U I a n UTCMD—U/T TDTW\ tl 1 tMr=n ( 1 , 1 r 1 V ) unHU i1 i cnn 15UU

U/TTDT

W

\ PP.C

T MC *UTCMDCT MC *U / T 1 DTM\

n ( 1 , 1 r 1 V ) =viUj 1 rat HltMr+oirit n(l,Jrlv)

4 umi ci

n HU 1 ID 1U

TCir /Y/T\ ARC/UM TDTUV\\ Itoto 11 to ]in I A ( 1 ) —ADJ ( H ( 1 , 1 r 1 V ) ) ) 3UU,31U,31U untt con

inn 3UU Y/T\ ARC/U/T IDTUl

\

A ( 1 ) =ADJ (H(l , 1 r 1 V ) ) un

t i cin HU 1 153U

T n. / T\ IDIV lU. ( 1 ) = lrl V unt ican

J

J

u U/T IDTl/V

CT MC*UTCMD PP.CT MC *U 11 1 D I U\

H ( 1 , Jr 1 V ) =—

b 1 rat HltMr+LUblrat n(l,JrlV) un

t i

nu 1 c cn 1 D DU

TC /Y/T\ ARC/U/T 1 DT 1/\\\ ion Alto Alto Ir (A (1 )—AD5 (n (1 , Jri V ) ) J «l),liu,'tiu unT nu i i130U sin

lift 320 V/T\ ARC/U/T IDT\/\\ A ( 1 )=Abb (H ( 1 , J r 1 V ) )

uni i C7n HU 1 15 / U f A / f \ IDTW Hi ( 1 )=Jr 1 V

unHUt i c fin 1 15oU

Pn TrtA 1 A bU IU 410 unt icon HU 1 159U

p untt Ann HU 1 lOUU 1 1 A 33U TC it IDT\/\ 1 A to illA nto Ir (1-JrlV) 340,410,3/0 un Tiiin HU 1 10 1U

lAto 34U UTCMD U/TDTW T\ H 1 1 Mr=n ( 1 r 1 V , 1 )

un TiAin HU 1 10 tu

U/TDTU T\ PACT MC

+ UTCMD i C

T WC*UM !DT\/^

n ( 1 r 1 V , 1 )

=LUj 1 Nt nltMr+Dlrat n(l,JrlV) unr i A3rt

TC fVMDTUl ARC (U/TDTV T\\\ ten 1.k{\ %kfi ir (A(lrlV) —AD j (n(lriv,i))) >j\>, >o\j , jou UnnuTi 1lotu AAA

left 350 V/TDTU\ ADC /U/TDTU

\ \\

A ( 1 r 1 V ) =Abj (H(lrlV,l) )

unT i

nu i loa cnju

Tft/TDTX/\T 1U. ( lrlv)=l unT i

nu

a An i

ioou

360 U/T | n

Tw

\

c

TUC * UTC MD Pf\CT MC * U / T IDTW)

H ( 1 , JrlV)=-blNtH ItMr+LUMNt

n (1 , Jrlv) un

t i

nu i l A7n o / u

TC / V / f \ ADC/U/T 1 DT 1/\V\ lift Alto VITA IF (X (I )-AB5 (H (I , JPIV) ) ) 320,410,410 unnu

t i aan i ioou

p Un

T 1 AO

A

nu i 10 7U 1 7 A 370 UTCMD U/TDTW T\ H 1 tMr=H ( Ir 1 V , I )

unnu i ii 7nn / uu

U/Tniii T\ PrtC

T MC tUTCUD . CT MC *U / IDTU 1\

H ( I r 1 V , 1 ) =LUb INt HI tMr +3 Irat

n ( Jr 1 V , 1 J

HOT 1 71

n

nu 11/ xu

TC /V /IDTW) ADC /U/TDTU I ) \ ) IQto XQft IQto lr (A ( 1 r 1 V ) -Abo (n ( Ir 1 V , 1 ) ) ) 3oU,37U,37U un

t l 79a nu i i / c u

Oftft 380

v /IDTW) ADC /U/TDTW T\\ A ( 1 r 1 V )

=Ado ( M ( I r 1 V , 1 ) )

null/ j u in / TDTW) T 1IJ ( Ir 1 V )=»! HDT n u 1 11 74ft / *t v

OAA 390 Ill IDTW T\

CT MC *UTCMD . PACT MC *U 1 IDTU I 1 H ( J r 1 V , I ) =-b Irat n 1 tMr+LUb 1 Nt n(Jrlv,l) HOT 1750

lrTC /( Ay (/ J1 Dr lT

WV

\ ARC/UMPTV 1 \

\\ d.(\fi AT 0 410 ) —ADb (ri ( J r I v , i ) ) ) huu , hiu , tin HDI1760

400 X(JPIV)=ABS(H(JPIV,I)) HDI1770

106
IQ(JPIV)=I HDI1780

410 CONTINUE HDI1790

C HDI1800

C TEST FOR COMPUTATION OF EIGENVECTORS HDI1810

C HDU820

IF (IEGEN(l)) 100,420,100 HDI1830

420 DO 430 1=1, N HDI1840

HTEMP=U(I ,IPIV) HDI1850

U(I ,IPIV)=COSINE*HTEMP+SINE*U(I , JPIV) HDI1860

430 U (I , JPIV)=-SINE*HTEMP+COSINE*U (I , JPIV) HDI1870

GO TO 100 HDI1880

440 IF (IEGEN(2)-2) 450,470,450 HDI1890

450 DO 460 1=1, N HDI1900

COL(I)=H(I ,1) HDI1910

460 CONTINUE HDI1920

IF (IEGEN(2) .NE.3) GO TO 490 HDI1930

470 DO 480 J=1,N HDI1940

DO 480 1=1, N HDU950

VECTOR(I,J)=U(I,J) HDI1960

480 CONTINUE HDI1970

490 RETURN HDI1980

END HDI1990

107
c

c

c

cc

c

c

c

c

c

c

cc

c

cc

c

c

c

10

20

30

40

50

60

70

80

SUBROUTINE HEADS (LOC ,N00 , IN , 10)

VERSION 5.00 HEADS 5/15/70

REWRITEN BY S PEAVY 8/8/69

THIS SUBROUTINE INSERTS HEADINGS (IF AVAILABE) OVER THE COLUMNS

WHEN NO FORMAT IS SPECIFIED

LOC LOCATION WHERE COL NUMBERS ARE

NOO NO OF COLUMN HEADINGS TO LOOK FOR. NOO LESS THAN OR = 8

.

IN IF IN =0 NEW HEADINGS

IF IN =1 PRINT OUT HEADINGS FROM RREVIOUS PAGE

IF A HEADING EXISTS THE 12 CHARACTER HEADING WILL BE PRINTED.

OTHERWISE THE HEADING COLUMN XXXX IS TO BE USED WHERE XXXX IS THE

NUMBER CONVERTED FOR DECIMAL PRINTOUT. THE HEADINGS ARE PRINTED

OVER THE DATA WHICH IS IF FORMAT 1PBE15.6

10 =0 PRINT HEADINGS

10 NOT =0 DO NOT PRINT HEADINGS

COMMON /ABCDEF/ L(48)

COMMON /HEADER/ NOCARD (80 )

, ITLE (60,6) ,LNCNT , IPRINT ,NPAGE , I PUNCH

COMMON /FMAT / IFMTX (6 ), IOSWT , IFMTS (6 ), LHEAD (96

)

DIMENSION LOC(l)

DIMENSION IC0LHD(7)

DATA ICOLHD(l) ,IC0LHD(2) ,IC0LHD(3) ,IC0LHD(4) ,IC0LHD(5) ,IC0LHD(6)

,

1C0LHD (7 ) / 1HC , 1H0 , 1HL , 1HU , 1HM, 1HN , 1H / NO=NOO

IF (N0.GT.8) N0=8

IF (IN.NE.O) GO TO 80

IR=1

DO 70 1=1, NO

CALL PREPAK (5 , IND , I , LOC ( I ), LHEAD ( IR )

)

IF (IND.NE.O) GO TO 10

IR=IR+12

GO TO 70

DO 20 IS=1,7

LHEAD(IR)=ICOLHD(IS)

IR=IR+1

K=LOC(I)

KC=1000

KD=0

DO 60 IS=1,4

KA=K/KC

IF (KA.NE.O) GO TO 30

IF (KD.NE.O) GO TO 40

LHEAD(IR)=L(45)

GO TO 50

KD=1

KAP=KA+1

LHEAD ( IR)=L (KAP)

IR=IR+1

K=K-KA*KC

KC=KC/10

LHEAD(IR)=L(45)

IR=IR+1

CONTINUE

IF (IO.NE.O) RETURN

IS=N0*12

HEA

HEA

HEA

HEA

HEA

HEA

HEA

HEA

HEA

10

20

30

40

50

60

70

80

90

HEA 100

HEA 110

HEA 120

HEA 130

HEA 140

HEA 150

HEA 160

HEA 170

HEA 180

HEA 190

HEA 200

HEA 210

HEA 220

HEA 230

HEA 240

HEA 250

IHEA 260

HEA 270

HEA 280

HEA 290

HEA 300

HEA 310

HEA 320

HEA 330

HEA 340

HEA 350

HEA 360

HEA 370

HEA 380

HEA 390

HEA 400

HEA 410

HEA 420

HEA 430

HEA 440

HEA 450

HEA 460

HEA 470

HEA 480

HEA 490

HEA 500

HEA 510

HEA 520

HEA 530

HEA 540

HEA 550

HEA 560

HEA 570

HEA 580

HEA 590

108
WRITE (IPRINT,90) (LHEAD ( I )

, 1=1 , I S ) HEA 600

RETURN HEA 610

c HEA 620

90 FORMAT (8(3X,12A1)) HEA 630

END HEA 640

409-118 OL - 71 - 8

109
SUBROUTINE HISTGM HIS 10

c VERSION 5.00 HISTGM 5/15/70 HIS 20

c WRITTEN BY DAVID HOGBEN , SEL, NBS . 10/24/69. HIS 30

C0MM0N/ABCDEF/L(48) HIS 40

COMMON/BLOCRC/NRC,RC( 12600) HIS 50

COMMON/BLOCKD / IARGS(IOO) ,KIND(100) , ARGTAB ( 100 ), NRMAX

,

HIS 60

1 NR0W,NCQL,NARGS,VWXYZ(8) ,NERROR HIS 70

DIMENSION ARGS(IOO) HIS 80

EQUIVALENCE ( ARGS(l), RC(12501)) HIS 90

COMMON/BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG HIS 100

COMMON/HEADER/NOCARD (80 ), ITLE (60,6) , LNCNT , IPRINT ,NPAGE , IPUNCH HIS 110

C0MM0N/SCRAT/NS,NS2,A(13500) HIS 120

c HISTOGRAM FOR MIDPOINTS IN COLUMN (C) , FREQUENCIES IN COLUMN (C) HIS 130

c NHISTOGRAM (C) , (C) L2=2 DOES NOT CALL NEW PAGE OR PRINT BLANK HIS 140

c LINE BETWEEN CELLS OR HEADING. HIS 150

L2=L2-7 HIS 160

10 IF (NARGS.EQ.2) GO TO 20 HIS 170

CALL ERROR (10) HIS 180

RETURN HIS 190

20 CALL ADRESS (1,J1) HIS 200

IF (Jl) 30,40,50 HIS 210

30 CALL ERROR (3) HIS 220

RETURN HIS 230

40 CALL ERROR (11) HIS 240

RETURN HIS 250

50 CALL ADRESS (2,J2) HIS 260

IF (J2) 30,40,60 HIS 270

60 IF (NRMAX. GT.O) GO TO 70 HIS 280

CALL ERROR (9) HIS 290

RETURN HIS 300

70 IF (NERROR.NE.O) RETURN HIS 310

80 FORMAT (// 25X,35HHIST0GRAM FOR FREQUENCIES IN COLUMN , 15 , 22H

,

MID -HIS 320

1P0INTS IN COLUMN, I5//3X,10HMID-P0INTS,7X,9HFREQUENCY/) HIS 330

85 FORMAT (1X,14A1,2X,I5,3X, 95A1) HIS 340

90 FORMAT (25X, 95A1) HIS 350

100 CALL RFORMT (RC(J1) , NRMAX , 8 , NW1 , NDECl , 13 , A ( 1 ) ,A(1) ,0,0) HIS 360

NBLANK = 15-NW1 HIS 370

IF (L2.EQ.2) GO TO 110 HIS 380

CALL PAGE (4) HIS 390

WRITE (IPRINT, 80) IARGS (1) , IARGS (2

)

HIS 400

110 L0C1=J1 HIS 410

L0C2=J2 HIS 420

DO 200 1=1, NRMAX HIS 430

CALL RFORMT (A (1 ), 1 , 8 ,NW1 , NDECl , 0 , RC (LOCI )

, A (1 ), NBLANK , 1

)

HIS 440

LFREQ = RC(L0C2) + 0.001 HIS 450

IF (LFREQ. GT.O) GO TO 140 HIS 460

WRITE (IPRINT, 85) (A ( 1 1 ), 1 1=2 , 15 )

, LFREQ HIS 470

GO TO 150 HIS 480

140 I2END = MINO (LFREQ, 95) HIS 490

WRITE (IPRINT, 85) (A ( I 1 ), I 1=2 , 15 )

, LFREQ , (L (40 ) , 12=1 , I2END) HIS 500

IF (LFREQ. LE. 95) GO TO 150 HIS 510

I3END = LFREQ-95 HIS 520

WRITE (IPRINT, 90) (L(40) ,13=1, BEND) HIS 530

150 LOCI = L0C1+1 HIS 540

200 L0C2 = L0C2+1 HIS 550

RETURN HIS 560

END HIS 570

110
c

c

c

cc

c

c

c

c

c

c

c

c

c

cc

cc

c

c

cc

c

c

cc

c

c

c

cc

c

c

cc

c

cc

c

c

10

SUBROUTINE IFS

VERSION 5.00 IFS 5/15/70

COMMON /BLOCRC/ NRC ,RC (12600)

COMMON /BLOCKD/ IARGS(IOO) ,KIND(100) ,AR6TAB(100) ,NRMAX ,NROW,NCOL

,

1ARGS ( VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )

)

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG

COMMON /BLOCKX/ INDEX (6 , 8 ), LEVEL

DIMENSION II (3) ,K(3) ,NNN(7)

EQUIVALENCE (11,11(1)), (12,11(2)), (13,11(3))

LOGICAL TWOARG

THIS COMMAND MAY APPEAR ONLY AS A STORED COMMAND.

IFLT, IFEQ, IFGT, IFGE, IFNE, IFLE CORRESPOND TO L2 = 9, 14

COMPARE L2 = 15

COMMANDS MAY HAVE 2 OR 3 ARGUMENTS (ONLY IFEQ AND IFNE MAY HAVE 3

ANY ARGUMENT MAY BE OF ANY TYPE, COLUMN NUMBER OR CONSTANT.

COMPARE MUST HAVE 3 ARGUMENTS

IN COMPARE THE TEST IF FOR RELATIVE ERROR AND GOES

I ARG1-ARG2 I I

I I .LT. I

I ARG2 I I

ARG3

IF ARG2 OR ARG1 IS 0., THEN ABSOLUTE ERROR WILL BE COMPUTED

ABS (ARG2-ARG1 ) .LT. ARG3 AND INFORMATIVE DIAGNOSTIC

WILL BE PRINTED.

IF IFEQ AND IFNE CONTAIN A THRID ARGUMENT (TOLERANCE) ABSOLUTE

ERROR WILL BE COMPUTED

ABS (ARG1-ARG2 ) .LT. ABS (ARG3)

A GIVEN TOLERANCE IS IGNORED ON IFLT, IFLE, IFGT, IFGE

EXAMPLES OF HOW COMMANDS READ.

IFLT 8.32 LT EVERY ENTRY OF COL 34, CONDITION IS TRUE

IFGE EACH ELEM COL 1 .GE. CORRESP. ELEM. COL 5, COND. IS TRUE

IFEQ 2. .EQ. 5. CONDITION TRUE (USEFUL WHEN INCREMENTING ARGS. )

IF CONDITION IS FALSE, NO ACTION IS TAKEN.

IF CONDITION IS TRUE, THERE ARE TWO POSSIBILITIES..

1. IF THE TEST COMMAND IS THE LAST ONE IN THE REPEAT LOOP

CURRENTLY BEING EXECUTED, THE LOOP IS TERMINATED (DROPPED

BACK TO THE NEXT OUTER LEVEL IF MORE THAN ONE LEVEL DEEP).

2. IF THE TEST COMMAND IS NOT THE LAST ONE, ALL THAT HAPPENS IS

THAT THE REST OF THE LOOP IS NOT PERFORMED. THAT IS, IF THE

LOOP COUNTER HAS NOT REACHED ITS UPPER LIMIT, IT IS ADVANCED

ONE AND THE LOOP IS BEGUN FROM THE TOP AGAIN.

IF (LEVEL. GT.O) GO TO 10

CALL ERROR (21)

GO TO 120

IF(NARGS.EQ.2) IF(L2-15) 40,150,40

IF (NARGS.EQ.3) GO TO 30

CALL ERROR (10)

GO TO 120

IFS

IFS

IFS

NIFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

) IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

IFS

10

20

30

40

50

60

70

80

90

100

110

120

130

140

150

160

170

175

180

190

200

205

210

220

230

240

250

260

270

272

273

278

280

282

284

286

290

300

310

320

330

340

350

360

370

380

390

400

410

420

430

440

450

460

470

480

490

500

510

111
A A 20 ft A 1 1 CDDftD / 1 1 \ LALL EKKUK (11) TPP

IF 5

C *i A 520

Tft i o

A

bU IU LIU rrc Irb 530

1 A 30 tc/io rn in no io en 1 1 no io en ic\ rn Tn /in

1 r ( Lt . ty . 11) . UK . L<: . ty . I 3 . UK . Li. . t(J . 1 5 ) bU IU 4U irr Irb 540

ftAI 1 CDDAD 1 1 1 0 \ CALL tKKUK ( <£ 1 Z ) Irb CCA 550

M A D r C O NAKbb=2 t rrc

I r b 560

A A 40 nn aa t i u Aorc UU 60 1=1 , NAKbb TPP

I r b

C ? A 570

ft A 1 1 AnDCCC It TT/T\\ LALL AUKtbb (1,11(1)) I PC Irb C O A 580

T C / T T / T \ \ c A *y A en Ir (11(1)) 5U , ZU , OU ire Irb C A A 370

c n 3U T I / I \ _ 11/11 1 1 ( 1 )=-l 1 ( 1

)

T PC Irb 000

Anou If / T \—1 KIMn M 1 TirbPC a i n 0 IU

T C / MDMA Y KIT A O D V T Mn / 1 \ , V T Mh / O \ cn o \ IC iMCDDDD \ 1 r (NKMAa . Nt . U . UK . MNU (1 ) +M vtv ( L ) . tv. . Z ) lr (NtKKUK) lOA L C 1 120 ,03 ,120 T CC Irb 615

ft A 1 1 FDDHD 1 Q

\

LALL LKKUK ( 7

)

T CC Irb L 1 A 620

oU 1 U 1 Z U

T PC irb L 1 A 630

A c 03 MMM / A \ A nnn (4 ) =u T CC Irb L A A 640 mmm nnn /e\ _n (3 ) =u T CC 1 r b

A C A 630 www NNN { l \ n ( o ) =0 T C C Irb L L A 660

t u/n Aor w a

d

r c cn o 1 WUAKb=NAKbb . ty .

2

TPP Irb L 7 A 670

nn i

i

n t_i md ma

y

UU 11U 1=1 , NKmAA T CC Irb A O A 6o0

1 C / T UIA A D ft \ IC IDPM1 1 Df> | TO \ \ 7 C 77 OA lr ( 1 WU AKb) lr (KL ( 1 1

) —KL (

1

a ) ) 15, II, ou T CC Irb 603

pU PHFPK FPi MP WTTMTN RPillMnC T PC Aon 07U

1 =flu j ( KL ( 1 1

) —KL ( 1 A ) ) T CC Irb L Q O 67 A TP/i 7 MP ki rn Tn aa 1 r ( La . NL . ID ) bU IU 00 T CC Irb L Q A 6V4

tclr(KL(ll) rRr n i \ .NL.U.U.ANU.KL(IZ) mp n n amh orno\ .IML.U.U) wp n n\ rnbU mIU 63 T CC irb A O O 670

ftLALL A 1 1 PDDHD LKKUK imoi (luo) T CC irb 7 A A / 00

(If) UU Tn A A 1 u oo T FC 7n? IMC

0 J T—ARC IT /DP / 1 9 \

\

1 =ADo 1 1 / KL ( 1 A ) ) TirbCC 7 n a 1 U4

00 TP/T 1 ARC/DP/T3\\\7n on on r (

1 -AD3 ( KL ( 1 .5 ) ) ) / U , o U , o U

TirbCC 7 n a / uo

7 n / 0 MMM / C \ WWW/CN .1 nnn ( a

)

=nnn ( d ) +i T CC Irb 7 1 A 7 10 nn Tn qa bU IU V0 T CC Irb 7 O A

7 20

pL PMPPk TPC UfTTUnilT Dniiwnc Iri T PC 7ift

/ JU

7 C WWW 1 A \ WWW 1 A \ il NNN (4 ) =NNN (4 ) +1 T CC Irb 7 A A / 4U rnuU Tn i nn 1 U 1UU TirbCC 7i;n / 3U

7 7

1 1 MMM/CX MMM IC \ il NNN ( D )=NNN ( 3 ) +1 T CC Irb 7 A A / 60

ruUn T(1 i nn 1 U 1UU TlrPCj 77n / / u on MMM 1 A \ —MMM li \ ,1 NNNlO)=liliNlO)+l TlrPCj 7on

on 1 J = l J+l^ ( J ) TIriPC 7on / 7U

1 A A 100 11 T 1 i If / 1 \ 1 1=1 l+K ( 1

)

T PC i r bo nn OUU

1 1 n 11U TO T O If / O \ 1 A=l A+l\ ( A ) T PC o i n MMM /l \ MMM (CI , MMM I A

\

NNN ( 1

) =NNN ( 3 ) +NNN ( 0

)

TlrPCj o?n O AU

MMM 1 0

\

—MMM t A \ .MMM 1 A

\

NNN ( i. ) =NNN \ 4 ) +NNN ( O ) lrT FCj

MMM / 7 \ MMM 1 0

\

NNN ( /

) =NNN ( A

)

TlrFCj 0 J 3 MMM/1X MMM 1 A \ . MMM 1 C

\

NNN (J ) =NNN (4 ) +NNN (3

)

TlrFCJ ojn 04U

ir /Mkiki /i i o\ en a\ TC/TMncv/o ic\/ci\ t wnc v / 1 ic\/cri\\ lr ( NNN ( L2-8 ) .b(j.0) lr (lNUtA(2,LtVtL)-lNUtA(3 ,LtVtL) ) l^A I^A 1>IA 130 , 130 , 140 T PC Irb Q VI C 043

120 DrTIIDII RETURN T CC Irb OCA 030

C

T CC Irb O A A 860

C

tc rnuuAu n unT at run nc DCDrnou i nnD ahwamtt i nno 1 r -LUMMANU NU 1 Al tNU Ur rtKrUKM LUUr , AUVANLt LUUr rni LUUNimt1 . T CC l r b0 7 n nL

TlrFCj son sou

130 INDEX (2 , LEVEL )=INDEX (3 , LEVEL )+l T CC Irb O O A 07O

O ft Tft T A f\ GO TO 120 T CC Irb AAA 900

ftc

T CC irb 0 1 n 7 IU

L tc rnuiiAun tc at cwn nc DPDPnoM i nnD tpdmt m atp i nnD lr—LUMMANU lb Al tNU Ur rtKrUKM LUUr, ILKmlNAIL LUUr TlrFCj 09 n 7 AU

AC

TirbFC 0 1 n

1 A A 140 1 ri/ri i rupi i LEVEL=LEVEL-1 T FC irb o/in 74U

GO TO 120 T

i FCr b OCA 73U

150 CALL ERROR (10) T CC Irb 0 An 76O

DrTIIDU RETURN TirbCC 07n 7 / U END IFS 980

112
SUBROUTINE INFERR (I ) INF 10

C VERSION 5.00 INFERR 5/15/70 INF 20

C INFORMATIVE DIAGNOSTICS 200 AND UP INF 30

COMMON /BLOCKC /KIO , INUNIT , ISCRAT ,KBDOUT ,KRDKNT , LLIST INF 40

C0MM0N/C0NLB2/ER,ISIGD INF 45

ISCRUN=ISCRAT INF 50

WRITE(ISCRUN,500) INF 60

500 FORMAT ( /41H* INFORMATIVE DIAGNOSTIC IN ABOVE COMMAND, 43X) INF 70

11=1-200 INF 80

GO TO (401, 402, 403, 404, 405, 406, 407, 408, 409, 410, 411, 412, INF 90

1 413,414,415,416,417,418,419,420, INF 100

2 421,422,423,424,425,426,427,428,429,430,431,432,433,434,435, INF 105

3 436,437) ,11 INF 110

401 WRITE(ISCRUN,201) INF 120

201 FORMAT (52H* TOO MUCH DATA IN SET, READ OR GENERATE, SPILL LOST, INF 130

132X) INF 140

GO TO 900 INF 150

402 WRITE(ISCRUN,202) INF 160

202 FORMAT (61H* COMMAND NOT ALLOWED IN REPEAT MODE. EXECUTED BUT NOT SINF 170

1T0RED,23X) INF 180

GO TO 900 INF 190

403 WRITE( ISCRUN, 203 ) INF 200

203 FORMAT (61H* VALUE REQUESTED IN SHORTEN, ACOALESCE OR AAVERAGE NOT INF 210

1F0UND,23X) INF 220

GO TO 900 INF 230

404 WRITE( ISCRUN, 204 ) INF 240

204 FORMAT (32H* BAD HEAD. COLUMN GT 50 OR NO /,52X) INF 250

GO TO 900 INF 260

405 WRITE( ISCRUN, 205 ) INF 270

205 FORMAT (68H* THIS COMMAND WAS NOT EXECUTED BECAUSE ITS MEANING WAS INF 280

1QUESTI0NABLE , 16X) INF 290

GO TO 900 INF 300

406 WRITE(ISCRUN,206) INF 310

206 FORMAT (24H* F LESS THAN 0, SET = 0,60X) INF 320

GO TO 900 INF 330

407 WRITE(ISCRUN,207) INF 340

207 FORMAT (24H* NU1 OR NU2 LESS THAN 1,60X) INF 350

GO TO 900 INF 360

408 WRITE(ISCRUN,208) INF 370

208 FORMAT (33H* NU1 OR NU2 TRUNCATED TO INTEGER, 51X) INF 380

GO TO 900 INF 390

409 WRITE(ISCRUN,209) INF 400

209 FORMAT (34H* IMPROPER TITLE NUMBER, ASSUMED 1,50X) INF 410

GO TO 900 INF 420

410 WRITE(ISCRUN,210) INF 430

210 FORMAT (54H* NO OF ROWS NOT = TO COLS. MATRIX USED LARGEST SQUARE, INF 440

1 20X) INF 450

GO TO 900 INF 460

411 WRITE(ISCRUN,211) INF 470

211 FORMAT (52H* ASTERISK STRING IMPLYING /THRU/ INCORRECT, IGNORED, INF 480

1 32X) INF 490

GO TO 900 INF 500

412 WRITE(ISCRUN,212) INF 510

212 FORMAT (43H* UNNECESSAYY ARGUMENTS IN COMMAND IGNORED . ,41X) INF 520

GO TO 900 INF 530

413 WRITE(ISCRUN,213) INF 540

213 FORMAT (27H* PARTIAL STORAGE OF MATRIX, 57X) INF 550

GO TO 900 INF 560

414 WRITE (ISCRUN, 214) INF 570

113
O 1 A Z14 CftDMAT rUKMAI / 9 QU* * * T WCIIFF T P T CUT CPDATfU A DC A ciVl (2on inoUrrlulc.ni iLKAILH AKcA ,56a) Tlir con INr 580 ro to onn uU 1 U 7UU INr 585

A 1 C 415 WRITE (ISCRUN,215) INF 590

I 15 FORMAT (48H* NRMAX IS NOT LARGE ENOUGH TO ALLOW ITERATION ,36X) INF 600

pobU toIU onn 7UU T MF tlfl INr olU

4 lo U/RTTF hr lie /T^PRIIN 9 1 A\

i i jv«nun ( tiD ) TINrmf ton 02U

9 1 A £ 10 FORMAT rUrvMMI /

( ASH* Oon 11 <^T J 1 POI l/ULUMn IIMN (IF ur T^FTIIP lOClUr ORUt\ T<OI 1 jULKATF1 L 1 j NOT NU 1 MONOTONTP MUNUIUIilU ORUrv T^TNF

1 PON^TANT 1 AY \ 1 LUIIj 1 WW 1 . , IDA ) TNF inr LAf\ oiu

poUU to1 U onn 7UU TWF INr iKn 03U

A11/1 7 U/RTTF /T^PRIIN 9^7^ TNF INr OOU tin

21/ FORMAT MAM* TTFRATTON MA^ FOUNT! NO UAI 1 IF ^ cny\ r Ul\ MM 1 (Jin 1 1 CRM 1 1 UN nft j r UUPl U HU V ML U C j . , DUA ) TWF t7fl INr o /

U

bU l u 7l)U Tur con INr ooU

110 A 1 Q U/RTTF Wl\ 1 1 C /TCPRIIW 91Q\ ( 1 jL-KUIM , i. 1 0 .1 T mc can INr 07U

910 FORMAT /Q1I4* UIORIfCUFFT TC TOO CUnQT TO APPOMMOnATF Al 1 TUF \/AI IICC rUKNIfl 1 (Bin nUKNjntl: 1 1 o 1 UU inUK 1 IU AuUUIVIMUUA 1 t ALL Inc. VALUto r t m c 7 n ft olNr /UU

IFNFRATFn ICIiCKMICU RVDT THTQ POMMAWn 1Y \

1 n 1 j MMMN V . , J A ) TWF 7 1ft iNr / iu

UU IU 7UU T W C 7 9ft INr / 2U

117 U/RTTF HR 1 IC(,lj^t\Uri,£i7; 1 TCPQIIN 91Q\ T MC 7 1ft INr 1 i\i

£ 17 FORMAT /IflH* MAYMTW UAC COIIWn MPl FYTRFMA cay \ rurcmMi pun mm ami n riMj ruunu nu laikcmm. ,3haj TWF 7 Aft INr / 4U

POuu TPi i u onn 7UU T WF 7 Cft INr / 5U

A9fl WRTTF /T^PRIIN 77(\\ TWF 7Aft i rar / ou 99n FORMAT runniMi /P.4H* (oin MAXMTN mmami n HA^ riMj FOUNT) ruunu mwu ANT) TPNORFF1 lununcu mA TRTAn i rv i mu OFur V.^ a/o UITTH hi i n miAT 1Linr T WF 77ft / /

u

IFA^T ILMj TWO TnFNTTPAl VAI 1 1 P Q \ 1 1 ITU 1ULI1 1 1UHL VHLUlj . ) TWF 70ft i nr / ou GOUU TO1 U Qflfl 7UU TNF i nr 7Qft / 7U

A9Hcl1 WRTTF / T^PRIIN 991 * TNF Qftft irar ouu

991 FORMATION* rUnWIM 1 lJ7M MORF MUnL THAN 1 nMPI ONF UriC MrxVaUMCHI ARPIIMFNT1 TinM POMMANfl UUMMMrvU . ONI UIMLYY FTR^T r ll\j 1 ONF UntL T^1 j IITNF Olft u i nr o iu

TWF INr 02U 09ft

GOUU TO1 U onn 7UU TWF Q 3 ft iNr oju

A99 U/RTTF nl\ 1IC M^PRIIN ( 1 jLHUH 999\ , t til ] TWF OAft inr ohu

9 9 9 FORMAT rUTvMMI 1 d%U* FORMAT NOT FOUND RFADARI F FORMAT T^ liccri iiyi ( tin rUI\MMI l»U 1 TUUIlU. nCMUMDLC TUIxMMI 1 j UjlU , H 1 A J tnf inr sen odu

gouu toi u onn 7UU TWF inr OAft oou

A9 1 IBRTTF Hi\ 1 1 C M^PRIIN 993^ ( 1 }ui\un , CC J ) TNF inr 07ft o /

u

9 9 3 FORMAT r UI\MM \ <%HU* (jon ONF UIMC , ^OMF jUDIl ORUrv MLL Al 1 UIFTGMT^ HC lun 1 J MI\C ARF NFGATTVF NluM 1 1 Vl , AkY\ 4DA ) TNF inr oou oon GO TO 900 INF 890

WRITE(ISCRUN,224) INF 900

99A FORMAT (48H* ALL WEIGHTS ARE ZERO. COMMAND IS NOT EXECUTED ,36X) INF 910

GO TO 900 INF 920

A4259 K WRITE(ISCRUN,225) INF 930

9 9 C FORMAT (81H* ARG FOR BESIN ,BESJN ,BESKN GIVES A RESULT TOO LARGE/SMAINF 940

ILL. COMMAND NOT EXECUTED . ,3X) INF 950

GO TO 900 INF 960

420 WRITE(ISCRUN,226) INF 970

9 9 A 2 20 FORMAT (73H* COLUMN NOT LONG ENOUGH TO STORE ALL ELEMENTS. ONLY NROINF 980

1W WILL BE STORED. ,11X ) INF 990

GO TO 900 INF1000

A 9 7 42 / WRITE(ISCRUN,227) INF1010

9 9 7 LCI FORMAT (78H* NOT ENOUGH DATA ON COL TO RESTORE MATRIX/ARRAY. DATA AINF1020

1VAILABLE WILL BE USED . ,6X) INF1025

GO TO 900 INF1030

A O 428 WRITE (ISCRUN < 228) INF1040

990 FORMAT (84H* SUM OF SQRS DO NOT ADD UP-ABS. VALUE OF (TOTAL-ROW-COLINF1050

1-RES.) /TOTAL EXCEEDS 5.E-7 ) INF1060

GO TO 900 INF1070

429 WRITE (ISCRUN,229) INF1080

229 FORMAT (51H* MORE THAN 50 HEAD COLUMN COMMANDS HAVE BEEN USED . ,33X) INF1090

GO TO 900 INF1100

>i 7 n 4 JO WRITE (ISCRUN,230) INF1110

230 FORMAT (72H* ATTEMPT TO PROMOTE FROM BELOW NRMAX. FIRST ARGUMENT IINF1120

IS RESET TO NRMAX., 12X) INF1130

GO TO 900 INF1140

114
431 WRITE (ISCRUN,231) INF1150

231 FORMAT (53H* ATTEMPT TO DEMOTE OFF THE WORKSHEET . SPILL IS LOST., INF1160

131X) INF1170

GO TO 900 INF1180

432 GO TO 900 INF1220

433 WRITE (ISCRUN,233) INF1230

233 FORMAT (76H* NEGATIVE VALUE(S) WERE ENCOUNTERED BY PARTITION FUNCTI INF1240

ION. ZEROES STORED. ,8X) INF1250

GO TO 900 INF1260

434 WRITE (ISCRUN,234) INF1270

234 FORMAT ( 45H* NEGATIVE ABSOLUTE TEMPERATURES CONVERTED. ,39X) INF1280

GO TO 900 INF1290

435 WRITE (ISCRUN,235) INF1300

235 FORMAT (76H* CAUTION, USE EXPERIMENTALLY ONLY. NOT OPTIMUM IN 0RDEINF1310

1R TO MAKE IT MACHINE , 10X/84H INDEPENDENT. REFERENCES - J.B. KRUSINF1320

2KAL,ACM,12,92. AND J.H. HALTON , SI AM REV . , 12 , 1 . ) INF1330

GO TO 900 INF1340

436 WRITE (ISCRUN,236) INF1350

236 FORMAT (78H* COMMAND IGNORED - S BEFORE COMMAND NAME MEANINGLESS IINF1360

IF NO STORAGE REQUESTED.) INF1370

GO TO 900 INF1380

437 WRITE(ISCRUN,237) ISIGD INF1390

237 FORMAT (63H* NUMBER OF SIGNIFICANT DIGITS AFTER DECIMAL PT HAS BEENINF1400

1 SET TO ,I3,18X) INF1405

900 RETURN INF1410

END INF1420

115
SUBROUTINE INPUT INP 10

C VERSION 5.00 INPUT 5/15/70 INP 20

COMMON /BLOCKA/ MODE ,M,KARD (83 ) ,KARG , ARG , ARG2 , NEWCD (80 )

, KRDEND INP 30

COMMON /BLOCKB/ NSTMT / NSTMTX,NSTMTH,NC0M ( LCOM,I0VFL,C0M(2000) INP 40

COMMON /BLOCKC/ KIO , I NUN IT , ISCRAT ,KBDOUT ,KRDKNT ,LLIST INP 50

C INP 60

C THIS ROUTINE HANDLES THE READING OF INPUT RECORDS. INP 70

C IF KIO = 0, INPUT IS CARD IMAGE FROM CARD READER OR TAPE. INP 80

C IF KIO = 1, INPUT IS REAL-TIME FROM A KEYBOARD. INP 90

C INP 100

KRDKNT=KRDKNT+1 INP 110

IF (KIO.EQ.O) GO TO 20 INP 120

IF (M0DE.EQ.3) GO TO 10 INP 130

WRITE (KBD0UT,30) INP 140

GO TO 20 INP 150

10 WRITE (KBD0UT,40) NSTMT INP 160

GO TO 20 INP 170

20 READ (INUNIT.50) NEWCD INP 180

KARD(1)=0 INP 190

KARD(2)=0 INP 200

KARD (KRDEND+3 )=46 INP 210

CALL OMCONV (NEWCD , KARD (3 ), KRDEND) INP 220

RETURN INP 230

C INP 240

30 FORMAT (9H READY ) INP 250

40 FORMAT (9H READY ,I3,3H / ) INP 260

50 FORMAT (80A1) INP 270

END INP 280

116
cc

c

cc

c

c

c

c

c

c

c

c

c

c

c

c

cc

c

10

20

30

SUBROUTINE INTERP

VERSION 5.00 INTERP

* GENERAL FORM OF COMMAND IS

INTERPOLATE X IN COL ++ Y

, , VALUES OF XP IN COL ++

5/15/70

IN COL 33 LENGTH=, , FOR THE FIRST

USE ,, POINTS STORE IN COL 33

COMMON /BLOCRC/ NRC , RC ( 12600

)

COMMON /BLOCKD/ IARGS(IOO) ,KIND(100) ,ARGTAB (100) ,NRMAX ,NR0W,NC0L

,

1ARGS,VWXYZ(8) .NERROR

COMMON /BLOCKC/ KIO , I NUN IT , ISCRAT ,KBDOUT ,KRDKNT , LLIST

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS (1 ) ,RC (12501 )

)

COMMON /SCRAT/ NS ,NS2 ,A (13500)

INT

INT

INT

INT

INT

INT

INT

INT

NINT

10

20

30

40

50

60

70

80

90

CHECK TO SEE IF WE HAVE CORRECT NUMBER AND MODE OF ARGUMENTS

IF (NARGS.NE.7) CALL ERROR (10)

J=NARGS

CALL CKIND (J)

IF (J.NE.O) CALL ERROR (3)

CHECK NO. OF POINTS LESS THAN OR EQUAL TO NRMAX AND POSITIVE

*IF (IARGS(3) .LT.0.0R.IARGS(4) .LT.O) CALL ERROR (3)

IF (IARGS(3) .GT.NROW. OR. IARGS(4) .GT. NRMAX) CALL ERROR (3)

CHECK TO SEE IF WE HAVE MORE THAN TWO ENTRIES IN TABLE

COMPUTE COLUMN ADDRESSES

IF (IARGS(3) .LT.2) CALL ERROR (3)

LXY=IARGS(3)

LXP=IARGS(4)

IARGS(3)=IARGS(5)

IARGS(4)=IARGS(7)

NARGS=4

CALL CHKCOL (J)

IF (J.NE.O) CALL ERROR (11)

*CHECK TO SEE IF WE EXCEED SCRATCH AREA

CHECK FOR PREVIOUS ERRORS

INDRV=0

IF (IARGS(6)-LXY) 20,20,10

IARGS(6)=LXY

INDRV=1

IF (IARGS(6)**2+3*IARGS(6)+LXP.LE.NS) GO TO 30

C=1.0-4.0*FL0AT(NS-LXP)

I=FSQRT(C)

IARGS(6)=(-l+I)/2

INDRV=2

IA1=IARGS(1)

IA2=IARGS(2)

IA3=IARGS(3)

IA4=3*IARGS(6)+LXP+1

CALL INTRP (RC(IAl) ,RC(IA2) ,LXY,RC(IA3) ,A(1) ,LXP, IARGS (6) ,A(LXP+1

1,A(IA4) ,IND)

STORE RESULTS

IA3=IARGS(4)

INT 100

INT 110

INT 120

INT 130

INT 140

INT 150

INT 160

INT 170

INT 180

INT 190

INT 200

INT 210

INT 220

INT 230

INT 240

INT 250

INT 260

INT 270

INT 280

INT 290

INT 300

INT 310

INT 320

INT 330

INT 340

INT 350

INT 360

INT 370

INT 380

INT 390

INT 400

INT 410

INT 420

INT 430

INT 440

INT 450

INT 460

INT 470

INT 480

INT 490

INT 500

INT 510

INT 520

INT 530

INT 540

INT 550

)INT 560

INT 570

INT 580

INT 590

117
DO 40 I=1,LXP INT 600

RC(IA3)=A(I) INT 610

IA3=IA3+1 INT 620

40 CONTINUE INT 630

IF ( INDRV .EQ .0 .AND . IND .EQ . 0 ) RETURN INT 640

IF (INDRV-1) 70,50,60 INT 650

50 WRITE (ISCRAT,80) INT 660

GO TO 70 INT 670

60 WRITE (ISCRAT,90) INT 680

70 IF (IND.EQ.O) RETURN INT 690

WRITE (ISCRAT,100) INT 700

RETURN INT 710

C INT 720

80 FORMAT (6X , 20 ( 1H+) ,39H0RDER OF INTERPOLATION EQUALS LIST SIZE,19X)INT 730

90 FORMAT (6X , 20 (1H+) , 53H0RDER OF INTERP WAS RESET DUE TO SIZE OF SCRINT 740

1ATCH AREA , 5X) INT 750

100 FORMAT (6X,20(1H+) ,42HEXTRAP0LATI0N DONE FOR MORE THAN ONE DELTA , 1INT 760

16X) INT 770

END INT 780

118
SUBROUTINE INTRP (X ,Y ( NLIST ,X1 .RESULT ,NX1 ,NORD , S , SA , IND

)

INR 10

c VERSION 5.00 INTRP 5/15/70 INR 20

c CALLING SEQUENCE INR 30

c SUBROUTINE INTRP (X , Y ,NLIST ,X1 , RESULT ,NX1 ,NORD ,S ,SA , IND) INR 40

c INR 50

c X THE INDEPENDENT VALUE OF THE TABLE. MUST BE IN ASCENDING OR INR 60

c DESCENDING ORDER. NEED NOT BE EVENLY SPACED INR 70

c Y THE DEPENDENT VALUE OF THE TABLE INR 80

c NLIST LENGTH OF X OR Y INR 90

c XI VALUES TO BE INTERPOLATED INR 100

c RESULT RESULT FROM INTERPOLATION INR 110

c NX1 LENGTH OF XI VECTOR INR 120

c NORD ORDER OF INTERPOLATION INR 130

c S SCRATCH AREA S(3*N0RD) INR 140

c SA SCRATCH AREA SA (NORD ,N0RD

)

INR 150

c IND INDICATOR INR 160

c IND=0 EVERYTHING FINE INR 170

c IND=2 EXTRAPOLATION AND MORE THEN ONE DELTA INR 180

c INR 190

DIMENSION X(l), Y(l), Xl(l), RESULT(l), S(l) , SA (NORD , NORD) INR 200

INDA=0 INR 210

IND=0 INR 220

NRD=N0RD-1 INR 230

NDIR=1 INR 240

IF (X(l) .GE.X(2)) NDIR=2 INR 250

1=1 INR 260

DO 220 11=1, NX1 INR 270

IC=0 INR 280

XA=X1(II) INR 290

GO TO (10,180) , NDIR INR 300

10 IF (XA-X(l)) 20,160,30 INR 310

20 IF (ABS(XA-X(1)) .GT.ABS(X(1)-X(2))) INDA=2 INR 320

IC=1 INR 330

IA=1 INR 340

GO TO 80 INR 350

30 DO 40 IA=I, NLIST INR 360

IF (X(IA)-XA) 40,170,60 INR 370

40 CONTINUE INR 380

50 IF (ABS(X(NLIST)-XA) .GT .ABS (X (NLIST)-X (NLIST -1))) INDA=2 INR

IE=1 INR 400

IA=NLIST-NRD INR 410

IC=1 INR 420

GO TO 80 INR 430

60 IA=IA-1 INR 440

IF (X(IA)-XA) 70,170,60 INR 450

70 IF (IA+NRD.LE. NLIST) GO TO 80 INR 460

IC=1 INR 470

IA=NLIST-NRD INR 480

80 IF (NRD.GT.l) GO TO 90 INR 490

TEMP=(XA-X ( IA) ) / (X ( I A+l ) -X ( IA )

)

- INR 500

RESULT(II)=Y(IA)+(Y(IA+1)-Y(IA))*TEMP INR 510

GO TO 220 INR 520

90 IF (IC.NE.O) GO TO 100 INR 530

IA=IA-NRD/2 INR 540

IF (IA.LE.O) IA=1 INR 550

100 NA=IA+NRD INR 560

PR0D=1. INR 570

IZ=1 INR 580

IZA=N0R0+1 INR 590

119
DO 110 IB=IA,NA INR 600

S(IZ)=X(IB) INR 610

S(IZA)=XA-X(IB) INR 620

PROD=PROD*S(IZA) INR 630

IZ=IZ+1 INR 640

110 IZA=IZA+1 INR 650

NB=NRD+1 INR 660

DO 120 IAR=2,NB INR 670

DO 120 IBR=IAR,NB INR 680

SA ( IBR-1 , IAR-1 )=S ( IAR-1 )-S (I BR) INR 690

120 SA(IAR-1,IBR)=(-SA(IBR-1,IAR-1)

)

INR 700

IZB=IZA INR 710

IZC=N0RD+1 INR 720

DO 140 IAR=1,NB INR 730

SUM=S(IZC) INR 740

DO 130 IBR=1 ,NRD INR 750

130 SUM=SUM*SA(IBR,IAR) INR 760

S (IZA)=PR0D/SUM INR 770

IZC=IZC+1 INR 780

140 IZA=IZA+1 INR 790

R=0 .0 INR 800

I AX=I A INR 810

DO 150 IX=1 , NORD INR 820

R=R+S(IZB)*Y(IAX) INR 830

IAX=IAX+1 INR 840

150 IZB=IZB+1 INR 850

RESULT(II)=R INR 860

GO TO 220 INR 870

160 RESULT (II )=Y(1) INR 880

IA=1 INR 890

GO TO 220 INR 900

170 RESULT(II)=Y(IA) INR 910

GO TO 220 INR 920

180 IF (XA-X(l)) 190,160,30 INR 930

190 DO 200 IA=I ,NLIST INR 940

IF (XA-X(IA)) 200,170,210 INR 950

200 CONTINUE INR 960

GO TO 50 INR 970

210 I A=I A-l INR 980

IF (XA-X(IA)) 70,170,210 INR 990

220 I=IA INR1000

IND=IND+INDA INR1010

RETURN INR1020

END INR1030

120
c

c

cc

cc

c

c

c

cc

cc

c

cc

cc

c

c

c

c

c

c

c

cc

c

c

10

20

30

40

50

60

SUBROUTINE INVCHK (A ,M,N , AINV , Ml , Y , L2 , ERR , IND

)

VERSION 5.00 INVCHK 5/15/70

INVCHK FOR OMNI TAB UNIVAC 1108 S. PEAVY 5/24/67

THIS SUBROUTINE INVERTS A MATRIX AND PROVIDES ALL THE CHECKS DESCR

IN PAC-1

A IS THE MATRIX TO BE INVERTED

M IS THE SIZE OF A AS DIMENSIONED IN THE CALLING PROGRAM A ( M , M)

N IS THE SIZE OF A TO BE INVERTED

N LESS THAN OR =M-1

AINV WILL CONTAIN THE INVERTED MATRIX IF INVERSION IS OBTAINABLE

Ml IS THE SIZE OF AINV AS DIMENSIONED IN THE CALLING PROGRAM

AINV(M1,2*M1) Ml MUST BE GREATER OR =N+1

AINV MUST HAVE TWICE AS MANY COLUMNS AS ROWS

A AND AINV CANNOT BE SAME OR EQUIVALENT

ERR WILL CONTAIN THE 3 WAYS OF EVALUATING NORM CHECKS

ERR IS A DIMENSIONED AS ERR (3

)

IND IS AN INDICATOR

IND=0 MATRIX INVERTED AND ERROR CHECKS MADE

IND=1 MATRIX SINGULAR

COLUMN AINV(N+1,I)

THE SUM CHECKS+1.

1=1, N WILL CONTAIN THE ERROR BOUND OF

70

DIMENSION A (M,M) , AINV(Ml.Ml), ERR (3 ) , AN0RM(2,3)

DIMENSION Y (N)

DATA ZERO/0.0/, ONE/1. 0/

NA=N

DO 20 1=1, NA

DO 20 J=1,NA

AINV(J,I)=A(J,I)

NB=NA

IF (L2.EQ.1) GO TO 40

NB=NB+1

DO 30 1=1, NA

AINV(I,NA+1)=Y(I)

AINV(NA+1,I)=ZER0

AINV(NA+1,NA+1)=-0NE

NA=NA+1

DO 60 1=1, NA

SUM-ZERO

AINV(NA+1,I)=ZER0

DO 50 J=1,NA

SUM=SUM+AINV(I,J)

AINV(I,NA+1)=-SUM

AINV(NA+1,NA+1)=0NE

NB=NB+1

CALL SPINV (AINV, NB , Ml, IND)

IF (IND.NE.O) RETURN

DO 140 K=l,2

DO 70 1=1,3

ANORM(K,I)=ZERO

DO 130 1=1,

N

INK

INK

INK

INK

INK

INK

INK

INK

INK

10

20

30

40

50

60

70

80

90

INK 100

INK 110

INK 120

INK 130

INK 140

INK 150

INK 160

INK 170

INK 180

INK 190

INK 200

INK 210

INK 220

INK 230

INK 240

INK 250

INK 260

INK 270

INK 280

INK 290

INK 300

INK 310

INK 320

INK 330

INK 340

INK 350

INK 360

INK 370

INK 380

INK 390

INK 400

INK 410

INK 420

INK 430

INK 440

INK 450

INK 460

INK 470

INK 480

INK 490

INK 500

INK 510

INK 520

INK 530

INK 540

INK 550

INK 560

INK 570

INK 580

INK 590

121
SUM=ZER0 INK 600

00 120 J=1,N INK 610

60 TO (80 ,90) , K INK 620

80 TEMP=ABS(AINV(I ,J)

)

INK 630

60 TO 110 INK 640

90 TEMP=ZERO INK 650

DO 100 L=l ,N INK 660

100 TEMP=TEMP+A ( I , L) *AINV (L , J

)

INK 670

IF (I.EQ.J) TEMP=ONE-TEMP INK 680

TEMP=ABS (TEMP) INK 690

110 AN0RM(K,1)=AN0RM(K,1)+TEMP**2 INK 700

IF (AN0RM(K,2) .LT.TEMP) ANORM(K , 2 )=TEMP INK 710

120 SUM=SUM+TEMP INK 720

IF (AN0RM(K,3) .IT. SUM) ANORM(K , 3 )=SUM INK 730

130 CONTINUE INK 740

AN0RM(K,1)=FSQRT(AN0RM(K,1)

)

INK 750

140 AN0RM(K,2)=FL0AT(N)*AN0RM(K,2) INK 760

DO 150 K=l,3 INK 770

150 ERR (K)=(AN0RM(1 ,K)*AN0RM(2 ,K) ) / (1 .-AN0RM(2 ,K)

)

INK 780

RETURN INK 790

END INK 800

122
c

cc

cc

c

c

cc

c

c

c

cc

c

cc

c

c

c

cc

c

c

c

cc

c

c

10

20

30

40

50

60

SUBROUTINE INVCOR (A , M, N , AINV , Ml , Y , L2 , ERR , IND

)

VERSION 5.00 INVCOR 5/15/70

INVCOR FOR OMNITAB UNIVAC 1108 S. PEAVY 5/24/67

THIS SUBROUTINE INVERTS A MATRIX AND PROVIDES ALL THE CHECKS DESCR

IN PAC-1

A IS THE MATRIX TO BE INVERTED

M IS THE SIZE OF A AS DIMENSIONED IN THE CALLING PROGRAM A (M,M)

N IS THE SIZE OF A TO BE INVERTED

N LESS THAN OR =M-1

AINV WILL CONTAIN THE INVERTED MATRIX IF INVERSION IS OBTAINABLE

Ml IS THE SIZE OF AINV AS DIMENSIONED IN THE CALLING PROGRAM

AINV(M1,2*M1) Ml MUST BE GREATER OR =N+1

AINV MUST HAVE TWICE AS MANY COLUMNS AS ROWS

A AND AINV CANNOT BE SAME OR EQUIVALENT

ERR WILL CONTAIN THE 3 WAYS OF EVALUATING NORM CHECKS

ERR IS A DIMENSIONED AS ERR (3

)

IND IS AN INDICATOR

IND=0 MATRIX INVERTED AND ERROR CHECKS MADE

IND=1 MATRIX SINGULAR

COLUMN AINV(N+1,I)

THE SUM CHECKS+1.

1=1 N WILL CONTAIN THE ERROR BOUND OF

70

DIMENSION A (M,M) , AINV(M1,M1) , ERR (3 ) , AN0RM(2,3)

DIMENSION Y (N)

DATA ZERO/0.0/, ONE/1.0/

NA=N

DO 20 1=1, NA

DO 20 J=1,NA

AINV(J,I)=A(J,I)

NB=NA

IF (L2.EQ.1) GO TO 40

NB=NB+1

DO 30 1=1, NA

AINV(I,NA+1)=Y(I)

AINV(NA+1,I )=ZERO

AINV(NA+1,NA+1)=-0NE

NA=NA+1

DO 60 1=1, NA

SUM=ZERO

AINV(NA+1,I)=ZER0

DO 50 J=1,NA

SUM=SUM+AINV(I ,J)

AINV(I,NA+1)=-SUM

AINV(NA+1,NA+1)=0NE

NB=NB+1

CALL CSPINV (AINV, NB, Ml, IND)

IF (IND.NE.O) RETURN

DO 140 K=l,2

DO 70 1=1,3

ANORM(K,I)=ZERO

DO 130 1=1,

N

INC

INC

INC

INC

INC

INC

INC

INC

INC

10

20

30

40

50

60

70

80

90

INC 100

INC 110

INC 120

INC 130

INC 140

INC 150

INC 160

INC 170

INC 180

INC 190

INC 200

INC 210

INC 220

INC 230

INC 240

INC 250

INC 260

INC 270

INC 280

INC 290

INC 300

INC 310

INC 320

INC 330

INC 340

INC 350

INC 360

INC 370

INC 380

INC 390

INC 400

INC 410

INC 420

INC 430

INC 440

INC 450

INC 460

INC 470

INC 480

INC 490

INC 500

INC 510

INC 520

INC 530

INC 540

INC 550

INC 560

INC 570

INC 580

INC 590

123
bUM=£tKU T MP 1NL L ft A 600

DU izo J=i ,

N

T MP 1 NL L 1 ft 610

pn jn ion q(\\ w laU 1 U ( 00 , 70 ) , N 1 NL L. 7

A

610

BO

tciio ADC/ATM\//T l\\ 1 tMr=ABo (A1NV (1 , J )

)

t hir 1NL 630

P A TA 1 1ft bU IU 110 T MP 1 NL L A A 640

A A

9 0 Tryn 7PDP. 1 tMr=Z.tKU T MP 1NL /PA 650

nn i Aft i l hi UU 100 L=l , NT hIP 1 NL L L A 660

i ft ft 100 T P UD T P MD iA/T 1 \ * A T hi V/ M 1 \

1 tMr= 1 LMr +A (1 ,L) AINV ( L , J ) T MP 1 NL 6/0

ic / y Cf\ |\ TPMD—OMP TPMD T MP AQA OOU

TPMD—ARC 1 TPMD

\

T1 NPlib 07U a on

1 10 AMA.DM/1^ 1 \ AMP.DM 1 V 1 \ . TP MD **0 ANUKM ( l\ , 1 ) =A11 UKHI ( N , 1 ) + 1 LMr c

T MP 1NL 7 Aft

/ 00

TP /Ahlft.DM/lf 0\ 1 T TP MD \ A hlHDM 1 V 0\ TPMD 1 r ( ANUKM ( 2

)

.LI . ItMr) ANUKM (

K

,

i

)= 1 tMr T MP 1NL 71ft 710

1 7rt CI IM—CI IM i TPMD T MP 1 Nl> 1 i.\J TPIr (ANUKM(N 1 AhlftDM I V 1\ IT CIIM\ AMP.DM/1/ 1\ CUM , 3 ) .LI . bUM) ANUKM (K ,3 ) =bUM T MP 1 NL 7 3 ft 730

uu rONTTMIIP uun i l Nut T MP 7 An

hunouiu , ANUKM \ \ penDT / amadm / v i \ \

t , 1 ) =r iyiK I (ANUKM(I\,1; ; T MP 1 NL / DO

i a n 140 A M ft D M / 1/ 1 \ CI AAT/U\#AMADII/U *> \ ANUKM (K , Z )=rLUA 1 (N ) *ANUKM(K , Z

)

T MP 1NL 7 £ A 760

UU 1DU T\=l , 3

T MP 1 Nl> 77ft

150 CDD tKK ;|/ \ /AMADM/l l/\*AMP.DM/0 |/ \ \ / / 1 AhlHDM/O U \ \ (K ) = (ANUKM ( 1 , K ) ANUKM

(

Z

,

K ) ) / ( 1 . -ANUKM

(

L

,

K )

)

T MP 1NL 7 O A 780

DCTl IDU Kb 1 UKN T MP 1NL 7 ft ft 790

END INC 800

124
SUBROUTINE INVERT INV 10

c VERSION 5.00 INVERT 5/15/70 INV 20

c MATRIX INVERSION, SOLUTION OF SYSTEM OF EQUATIONS INV 30

c S PEAVY 5/22/67 INV 40

c MINVERT (+++,+++) SIZE +++,+++ STORE (+++,+++) INV 50

c

ft 1 » 1 ^ * \ ^ T ^ I*" v / \ i f ft *W A A ft ft r"\ n~ SOLVE (+++,+++,) SIZE +++,+++ Y VECTOR +++ STORE +++ INV 70

c

A ft m^ mm m, — a , m mm mm T y/ v |-i f— T »l 1/ T ft T 1"" ft Aft ft V / ft f ft m M ~T A ft ft ft ft I 1 i T ft Tft f .-1 LARGEST MATRIX TO BE INVERTED OR SYSTEM TO BE SOLVED IS 50 INV 90

c INV 100

c

I a - i 111 IT ft T L2=l INVERT INV 110

c L2=2 SOLVE T ml \ 1 INV 120

/-\ r\ iiiia ft j - r a ri a ~T j ft t (* ft. 1 ^ ^ ft / n r* ft ft \ COMMON /SCRAT/ NS ,NS2 ,A (13500) INV 130

^ aiiiiaii mi Arti/r i ftiftftir- / a \ i <-i t c n i- i iTM1 COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG T 111/ INV 140

COMMON /BL0CRC/ NRC , RC ( 12600

)

INV 150

COMMON /BL0CKD / IARGS(IOO) ,KIND(100) , ARGTAB (100 ), NRMAX , NR0W,NC0L ,NINV 160

J. AKoj , V WA T L ( o ) ,NLKKUK INV 170

TinvMU 180

tyu 1 V ALC.NUC. (AKoj (1 ) ,KL(1^3U1) ) T MU IN V 190

PO.MMO.N /Rl C\CVC 1 \C T 0, TMIIMTT TQPRAT Rnfll IT k'Rnk'WT 1 1 TCT TINVMU 200

T

i MUra v 210

T F 1 N APPQ Ffl ti PP. TP 1ft TINVMU 220

TINVMU 230

PFTMPN r\ c i ur\N TINVMU 240

10 TINVNU 250

P A 1 1 CU T un 1 \ \ T MU INV 260

T F M nf fin to inn T MU ATA 270

TFiTARPQi^ lr ^IMftUo^Jj — TARP^id\\ "\ (\-\ on 1 fl7 I MRU J pJJ 1U3,£U,1Ui TINVMU 275

20 MAPPC O NAKbJ=0 T Mil INV 320

v t wn / 7 \ _ft T MU INV 330

vitin / at ft rs 1 NU ( O ) =U T M\/ INV 340

tf i\ o fp i \ pp tp in TINVMU 350

i jprc /o\_TAPPQ / A\ 1 flKuj J 7 J = lAr\bj (o ; TINVMU 360

TINVMU 370

MNU V T M n / O \ ft (V )=U INV 380

TINVMU 390

TC / IF IC ft\ Pft Tft left lr (Jt.Lt.0) bU IU 150 T MU INV 400

lAKbb (6 )=lAKbo (5) INV 410

lAKbb (5 )=1 T WW INV 420

1 AKbb (o )=1 T M\/

1 NV 430

Pft Tft >l ft bU IU 4U T MU INV 440

30 1 AKbb (8 )=lAKbb (3

)

T WW INV A C A 450

40 IARGS (7 )=I ARGS (3

)

T WW INV 460

1 t J=2 T WW INV 470

ft i i i trrv ai ii/ / i \ CALL MTXCHK (J) T WW INV 480

TC / 1 MC ft\ Pft Tft 1 X A lr (J.Nt.0) bU IU 140 T MU INV A A A 490

JA=IARGS(1) INV C A A 500

JB=IARGS(5) INV CIA 510

IF (2* ( (IARGS (3)+2)**2) .GT .NS) GO TO 120 INV 520

IF (NERR0R.NE.0) RETURN INV C O A 530

M1=IARGS(3)+1 INV 540

IF (L2.EQ.2) M1=M1+1 INV CCA 550

CALL INVCHK (RC ( JA) ,NR0W , IARGS (3 )

, A ,M1 ,RC ( JB) ,L2 , ERR , IND) INV C L A 560

C CHECK TO SEE IF MATRIX WAS INVERTED. YES, IF IND=0 INV 570

IF (IND.NE.0) GO TO 130 INV C O A 580

IA=IARGS(3) INV 590

IF (L2.EQ.2) GO TO 70 INV 600

c STORE INVERTED MATRIX INV 610

DO 60 1=1, IA INV 620

JC=JB INV L. 1 ft 630

JD=(I-1)*M1+1 INV 640

125

4AQ1 1 R r\I 71 Q
Art C A 1 1 T A OU 50 J=l , 1A T M v/ l c n 1NV 650

dp/ i p \ a / i n \ KL (JL )=A ( JO

)

T Mil L L A INV 660

JL=JL+1 T MW iin INV 670

50 J U=J 0+1 T kit/ /OA INV 680

60 ID 1 D . kl D A Ul JbJ=Jb+NKUW T k\\l L A A INV 690

PA T A A A bU IU 90 t in/ -7 n a INV 700

C

C T A D C D C C 1 1 1 TC AC CAI 1 1 T T A M blUKt KtbULIb Ur bULUIlUN T lllf 7 1 A INV 710

7 A 70 IP AJ1*TADPC/1\ .1 J L=M1 lAKbb(3)+l T M l# 71ft INV 7Z0

nn OA T 1 TA UU oU 1=1 , 1

A

T Ml/ 71ft INV 730

DP / 1 C \ A / 1 P \ KL ( Jt )=A ( JL

)

Tl|\/ 7 A A INV 740

ip i p . i JL=JL+1 T Ml/ 7 C A INV 750

80 Jt=Jt+l T M 1/ 7 L A INV 760

pL ncTCOuimc cmai i cct cddad qaiima. Ut 1 tKMI Nt b MALL to 1 tKKUK bUUNU T Ml/ 7 7 A INV 770

Q A 90 CCDD AIITMl / TDD / l \ C D D / 1 \ C D D / 1 \ \ btKK=AM!Nl (tKK ( 1 ) , tKK ( Z )

, tKK (3 )

)

T Ml/ 7 O A INV 780

IUDTTC ( 1CPOAT 1 L A \ CCDD WKlIb (lbLKAI,160) btKK T Ml/ 7 Q A INV 790

DCTIIDM Kt 1 UKN T All/ O A A INV 800

1 A A 100 P A 1 1 CDDAD / 1 \ LALL tKKUK (3) T All/ Alft INV 810

DCTIIDM Kt 1 UKN T All/ O 1 A INV 8Z0

1 A C 10b TADPC/>S\ lAKbb(4)=lAKbb(3) TADOC / H T All/ Olft INV 830

PA TA 1 1 A bU 1 U 110 T M 1/ O A A INV 84U

1 A 7 10 / TADPC/ls lAOTC / J \ lAKbb (3)=iAKbb (4) T All/ OCA INV 850

1 1 A 110 PAI 1 CDDAD /iifli LALL tKKUK (Z10) T Ml/ O L A INV 860

PL DDTMT DA 111 AWn PAI IIMMC r\A WAT APDCC CT7C AC PAI IIMMC TC CCT TA DA 111 rKINI KUW AND LULUMNb UU NU 1 AbKtt , b 1 Zt Ur LULUMNb lb bt 1 IU KUW T Ml/ O 7 A INV 870

PA T A *5 A bU 1 U Z0 T Ml/ 00 A INV 880

1 0 A 1Z0 PAI 1 CDDAD (15

\

LALL tKKUK (Z3) T MW O Q

A

INV 890

pL DDTAIT IIATDTV TAA 1 ADPC TA TMWCDT PKINI MA 1 K 1 X 1 UU LAKbt IU INVtKI T All/ AAA INV 900

DCTIIDM Kt 1 UKN T All/ A 1 A INV 910

T 1 A 130 PAS 1 CDDAD / 1 1 \ LALL tKKUK (ZZ) T All/ A 1 A INV 9Z0

pL DDTMT UATDTV TC CTAIPIII AD AD M C A D CTAIPIII AD MA TMWCDCC KK1NI MAIKIX lb b INbULAK UK NtAK blNbULAK-NU INvtKbt T Ml/ Gift INV 930

DCTIIDM Kt 1 UKN T MW Q A A INV 94U

1 A A 140 TC /I CA 11 PA TA 1 C A Ir (J.tU.,1) bU IU 150 TMW OCA INV 950

PAI 1 CDDAD / 1 7 \ LALL tKKUK (17) TMW OA

A

INV 960

D C T 1 1 D Al TMW Q 7 ft INV 9 / U 150 PAII CDDAD /111 LALL tKKUK (11) T Ml/ ft o A INV 980

DCTIIDM Kt 1 UKN TMW OQft INV 99U

p T MW 1 ft ft ft 1 NV 1UUU

1 Z A 160 CAD 11 AT / £ V 1 A / 1 LI . \ Alii CAIAI 1 CCT CDDAD D A 1 1 AB ft AM TMV/CDTCH AJATDTV TC rUKMAI (6X , Z0 ( 1H+) , 43H bMALLtbl tKKUK bUUNU UN INvtKItU MAIK1X lb, T M W 1 ft 1 ft 1NV1U1U

1E8.1,7H ++++) T All/ 1 A 1 A INV10Z0

END INV1030

126
SUBROUTINE HERAT ITE 10

c VERSION 5.00 ITERAT 5/15/70 ITE 20

COMMON /BLOCRC/ NRC , RC ( 12600

)

ITE 30

COMMON /SCRAT/ NS ,NS2 , A (13500 ) ITE 40

COMMON /BLOCKD / IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX ,NROW,NCOL ,NITE 50

1ARGS,VWXYZ(8) ,NERROR ITE 60

DIMENSION ARGS(IOO) ITE 70

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 )

)

ITE 80

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG ITE 90

c L2=l ITERATE X IN ++ , Y IN ++ , DESIRED Y IN ++ START STORIN ITE 100

c L2=2 ISETUP X IN ++, Y IN ++, DESIRED Y IN ++ STORE STARTIN ITE 110

c COLUMN ++ ITE 120

c IN COLUMN ++ ITE 130

c L2=3 ISOLATE X IN ++ FOR Y IN COL ++=** STORE IN ++ AND ++ ITE 140

c ISOLATE X IN ++ FOR Y IN COL ++=** USE ,

,

POINTS, STORE ITE 150

c IN ++ AND ++ ITE 160

c ITERATE AND ISETUP USE THREE COLUMNS AFTER THE INDICATED STORE ITE 170

c STORAGE FOR ITERATE AND ISETUP ARE NEW X , AVERAGE BRACKETING X,ITE 180

c AVERAGE BRACKETTING Y , AND SUCCESSFUL Y

T TC 1 1 £ 190

c CODE BY MRS. CARLA G. MESSINA NSRDS- WR^ OPT 1 Q A 7 [YD J Uul 170/ T TP 200

T UCCPT 7 Tx TF1 L 210

lr (NAKbb-4) 10,40,80 TTF 220

10 T TF 230

20 LALL tKKUK (K) T TF 240

30 DrTIIDU RL 1 UKN TTF 1 1 t 250

40 TC / 1 O 1 \ C ft C ft 1 ft lr (LZ-2 ) 50,50,10 T T C

I 1 t 260

50 M A DC C "7 t t rr 1 Tt 270

DO 60 1=5,7 TTF 280

KIND (I )=0 T TF 1 1 t 290

60 IARGS (I )=IARGS (I-l)+l T TC 1 1 t 300

IF (NROW-5) 70,180,180 T T C ITE 310

70 K=17 T T C 320

GO TO 20 T TC 1 I L 330

80 IF (L2-3) 10,90,10 TTF 1 1 t 340

90 IARGS(7)=IARGS(5) TTF 1 1 t 350

KIND(7)=KIND(5) ITE 360

IF (NARGS-6 ) 100,110,10 t t r~ ITE 370

100 NARGS=6 ITE 380

IARGS(6)=IARGS(5) ITE 390

KIND(6)=KIND(5) ITE 400

IARGS(5)=IARGS(4) ITE 410

KIND(5)=KIND(4) ITE 420

GO TO 140 ITE 430

110 IF (KIND(4)) 120,130,120 ITE 440

120 K=3 ITE 450

GO TO 20 ITE 460

130 INSERT=IARGS(4) ITE 470

IARGS(4)=IARGS(5) ITE 480

140 IF (INSERT-1) 120,150,150 ITE 490

150 IF (NROW-INSERT-2) 70,160,160 ITE 500

160 IF (KIND(3)) 170,120,170 ITE 510

170 P0INT=ARGS(3) ITE 520

IARGS(3)=IARGS(2) ITE 530

KIND(3)=0 ITE 540

180 CALL CHKCOL (J) ITE 550

IF (J) 120,190,120 ITE 560

190 IF (NERROR.NE.O) GO TO 30 ITE 570

IF (NRMAX-1) 200,210,220 ITE 580

200 K=9 ITE 590

127
GO TO 20 ITE 600

210 K=215 ITE 610

GO TO 20 ITE 620

220 IF (L2-2) 300,230,230 ITE 630

230 1 1=1 ARGS { 1

) -1 ITE 640

DO 240 1=2 , NRMAX ITE 650

K=I1+I ITE 660

IF (RC(K-l)-RC(K) ) 250,240,270 ITE 670

240 CONTINUE ITE 680

GO TO 290 ITE 690

250 DO 260 1=2, NRMAX ITE 700

K=I1+I ITE 710

IF (RC(K-l)-RC(K) ) 260,260,290 ITE 720

260 CONTINUE ITE 730

GO TO 300 ITE 740

270 DO 280 1=2, NRMAX ITE 750

K=I1+I ITE 760

IF (RC(K-l)-RC(K) ) 290,280,280 ITE 770

280 CONTINUE ITE 780

GO TO 300 ITE 790

290 CALL ERROR (216) ITE 800

300 DO 310 1=1 , NRMAX ITE 810

1 1=1 ARGS ( 1 ) +1 -1 ITE 820

I2=IARGS(2)+I-1 ITE 830

I3=IARGS (3 ) +1-1 ITE 840

A(I)=RC(I1) ITE 850

it w ii r\ in »

#

M=I+NRMAX ITE 860

A(M)=RC (12) ITE 870

id i limn u M=M+NRMAX ITE 880

310 A(M)=RC(I3) ITE 890

M=0 ITE 900

M1=0 ITE 910

I0VFL=0 ITE 920

IND2=INSERT+2 ITE 930

DIV=INSERT+1 ITE 940

IDIV=INSERT+1 ITE 950

I1=IARGS(4)-1 ITE 960

I2=IARGS (5)-l ITE 970

I3=IARGS(6)-1 ITE 980

I4=IARGS(7)-1 ITE 990

I5=IARGS(4)-1 ITE1000

IF (L2-2) 500,500,320 ITE1010

C ISOLATE ITE1020

320 K1=NRMAX+1 ITE1030

L1=2*NRMAX ITE1040

I5=IARGS(5)-1 ITE1050

IF (POINT-A(Kl) ) 340,330,340 ITE1060

330 M=M+1 ITE1070

12=12+1 ITE1080

RC(I2)=A(1) ITE1090

M1=M1+1 ITE1100

13=13+1 ITE1110

RC(I3)=A(1) ITE1120

340 K1=K1+1 ITE1130

1=1 ITE1140

DO 440 K=K1,L1 ITE1150

1=1+1 ITE1160

IF (POINT-A (K-l) ) 350,440,360 iTtmn

350 IF (POINT-A(K)) 440,390,370 ITE1180

128
360 IF (POINT-A(K)) 370,390,440 ITE1190

370 IF (NR0W-M-IND2 ) 380,400,400 ITE1200

380 I0VFL=1 ITE1210

GO TO 430 ITE1220

390 A(I-1)=A(I) ITE1230

IF (NROW-M-1) 430,420,420 ITE1240

400 M=M+1 ITE1250

12=12+1 ITE1260

RC(I2)=A(I-1) ITE1270

DELT=(A(I)-A(I-1) ) /DIV ITE1280

DO 410 11=1, INSERT ITE1290

M=M+1 ITE1300

12=12+1 ITE1310

410 RC(I2)=RC(I2-1)+DELT ITE1320

420 M=M+1 ITE1330

12=12+1 ITE1340

RC(I2)=A(I) ITE1350

430 M1=M1+1 ITE1360

13=13+1 ITE1370

RC(I3)=(A(I-l)+A(I))/2.0 ITE1380

IF (NR0W-M1) 470,470,440 ITE1390

440 CONTINUE ITE1400

IF (M) 480,480,450 ITE1410

450 NRMAX=M ITE1420

460 IF (IOVFL) 470,30,470 ITE1430

470 K=218 ITE1440

GO TO 20 ITE1450

480 K=217 ITE1460

DO 490 I=1,NRMAX ITE1470

15=15+1 ITE1480

490 RC(I5)=A(I) ITE1490

GO TO 20 ITE1500

500 K1=2*NRMAX+1 ITE1510

L1=3*NRMAX ITE1520

DO 510 K=1,NRMAX ITE1530

IF (A(L1)) 520,510,520 ITE1540

510 L1=L1-1 ITE1550

L1=3*NRMAX ITE1560

520 NEWY=L1-K1+1 ITE1570

IF (L2-2) 780,530,10 ITE1580

C ISETUP ITE1590

530 DO 740 K=K1,L1 ITE1600

1=1 ITE1610

L=NRMAX+1 ITE1620

IF (A(K)-A(I)) 590,540,590 ITE1630

540 IF (NR0W-M-IND2 ) 550,560,560 ITE1640

550 I0VFL=1 ITE1650

GO TO 580 ITE1660

560 DO 570 11=1, IND2 ITE1670

M=M+1 ITE1680

11=11+1 ITE1690

570 RC(I1)=A(I) ITE1700

580 M1=M1+1 ITE1710

12=12+1 ITE1720

RC(I2)=A(I) ITE1730

13=13+1 ITE1740

RC(I3)=A(L) ITE1750

14=14+1 ITE1760

RC(I4)=A(K) ITE1770

129
ilrc iMDnui (IMKUn—Mimi.)\ A7n H/U,H/U,37U A7n ^on

T TC 1 7 0ft 1 1 Li / HO con nnUU 7^n / U t—1 =A? , nrmay PI l\ IflA A T TF 1 7 Q ft 1 1 Li / 7U 1L=Pl —NRMAYj.T l\IVIM A + 1 T TF 1 a n n 1 1 LloUU

tf i h i\ ] \A ( K\\ Ann 7 7,n AinT TF 1 D 1 n 1 1 L 10 1 U

Ann ouu TP (AM

\

A / 1^

\ 1 r ^ A

-\ Tin A?n A7n I L ; —A ( N / J f >U , 0 A U , 0 / U

T TF 1 Q 9 n 1 1

LIoaU

a 1 n iftk 1 1 \A mo i A7na ? n Tin

T TC 1 Q 1 ft I 1 L

loiU

aon 0 AU TF (MPniMMTNn ? \A 1 ftAAnAan

T TC 1 0 A ft

an Tf(\/F! _T 1 u v r L= 1 T TF 1 QK ft 1 1 t lODU

pnOU Tn1 uaoouAnT TF 1 QA ft 1 1 LiOOU

aao nnuu A«;n 03U j=i i— i , nun? inut

T TF 1 07(1 1 1 Lxo / U M—IVI=ltl+i Mj.1 T TF 1 Q Q n 1 1 tloBU T I T 1.1 1 1=1 1+1 T1 TF1 L107U 1 son i cn u jU DP ( T 1 l —A 1 T \ R Li (, 1 J. ) =A ( I ) T TF 1 Oftft 1 1 L17UU aoouAn Ml —Ml , 1 IV11=!VI1 + 1 T TF 1 0 1 ft 1 1 L 1 7 1 U T ? — T ? j.1 1 A — 1 A + 1 TTF1 Qon 1 1 L 1 7 A U RP / T 9 1 —A ( T \ ( I c. ) =A ( 1 ) T TF 1 05(1 1 1 Ll7 Jl) T 1— T 3 j.1 i j — l j + i T1 TF1 L17HU 1 0 An

RP / T 5 \ _A ( 1 \T TF 1 ocn 1 1 L173U

CO JO 7?n

T1 TF1 L170U 1 0 An

A7f> o / u TFir (^ ni\u NRflWw—Mnn—Ti ND? n 1 A«nAqn Aon

u

a ) oou , o 7U , 07U

T TF 1 Q 7 ft 1 1 Ll7 / U ash TOVFI i u v r l=i—l T TF 1 0 Q n 1 1 LI70U

(in to 7 1 n

T1 TF1 L177U i oon Aon O 7 u npi ULLI=(A(1 T— fj/ii a ( t i \ \ /n t v j —A ^ 1 — X ) ) / U 1 V t1 tf 9 nnn 1

LaUUU

IVP=lfl+l

T TF9n 1 ft 1 1 L A U 1U

T1 1-1 X— 1 1+1 X X x

TTF?n?n 1 1

LlulU

RP / T 1 1 —A ( T 1 \T TF 0 1 1 LaUjU

nnUU 7nn /UU J=l i_i tn^frt ,

IHjlK 1 T1 TF1 LAUnU 9 n An

M—lft=m+l Mj.1

T TC 9 ft

C ft 1 1 L A U D U

T 1 —T i j.1 1 1 — 1 1+1 TTFOnAtt 1 1 L. A U 0 U 7nn RP/T11— rv 1 / \ 1 1 RP/T1 1 \j_nFI T ) =i\ ^ 1 1 — 1 J +U£L 1 T TF 0 (17 ft 1 1 L A U 1 U M—M L 1 i»i=iyi+i T TF 9 n s n 1 1

LaUOU

T 1 —T 1 j.1 1 X — 1 X + X TTF?non 1 1 CAU7U

RP (Til _A 1 T 1

KKj ( 1 1 ;=A ( 1 ) t1 tf1 L 9A inn 1 u u 7 1 n Ml —Ml j.1 r»ll=!Vll + 1 TTF91 1 n 1 1 LL 1 1U T 2 — T 1 A — 1 A + 1 TTF?1 20

BP / T9V-/AM 1 ±i / I 1 \\ / ? n KI* l i A ;= (A \ i ; +A (l—L) } 1 A . UT TF 0 1 3 n

T 1 —

T 3 j.1 1 J — I .? +x TTF?1 AO

RP / T 7 1 / A / 1 \ _lAM l\\/7n KUtl.3) = lAtL) +A \ L — 1 ) ) / A . UT TF 0 1 5 n 1 1 L A 1 D U 7?n 1 CM T A— T A j.1 1 LT= 1 H + l T1 tf? 1 U A 1X AnO U RP / Til —A ^ 1^ \ TTF21 7ft 1 1 C A 1 / U TF /MRftUf Ml \ A7n 47(1 7Art T1 TF? 1 Z.L 110Unn 7 1ft PriWT uun T Ml IF i i nut TTF? 1 1 LA17U i on 7 Aft pnwT T Ml IF TTF??nn 1 1 CA AUU 7 £ n TF ^M\ AQn AQn 71(1 lr (Wij *toU , lou , / OU TTF571 n 1 1 L A A 1 U 7 a n / OU TF / M MriilVl 77(1 77(1 4C(1 lr (M—Ntni ] f / U , / / U , *r3U T TF? 9 ? ft 1 1 La A A u 7 7 n / / 0 NKN!AA=!Mt WY T TF? ? ft 1 1 LA A JU

Pri TOAA ft oU 1 U HOUT TF? ? Aft 1 1 L A AHU

p ITERATE ITE2250 7 q n TT T Wno * ( MDMA Y / T Wfl 0 \ I 1 = 1NUa (WKIVIAa / 1 IMU L ) TTF??Aft 1 1 C A A 0 U TF (III ii(i Olft 70n T1 TF??7n 1 U A A / U 7on / 7U nnUU o a n x—Vi i l 7 0 U l\=M , L 1 TTF??ftO 1 1

LllOU

nn ocn \tt i tt Twn? UU 730 l\ J =l , 1 1 , 1 rlV A TTF??Qft 1 1 i- C A 7 U UU 830 J=l , 1 U I V t1 tf? 1 LA JUU % nn 1=K3+J t tf? ^ 1 n 1 1 C A J X U 1 MRMAV i T

L=NKMAa+1 TTF?^?n

TC /A/I 1\A / 1/\\ Old Oftft Q7(l TTF?'?'?n 1 1 C A J J U

OAA 800

TT 1 1 = 1-1

T TF? 'iAft 1 1 LA J*JU 1 1 7 L=L-1 T TF? % fi(\ 1 1 LA J D U GO TO 840 ITE2360

130
810 IF (A(L)-A(K)) 830,840,890 ITE2370

820 IF (A(L)-A(K)) 890,840,830 ITE2380

830 CONTINUE ITE2390

GO TO 950 ITE2400

840 IF (NR0W-M-IND2 ) 850,860,860 ITE2410

850 I0VFL=1 ITE2420

GO TO 880 ITE2430

860 DO 870 J=1,IND2 ITE2440

M=M+1 ITE2450

11=11+1 ITE2460

870 RC(I1)=A(I) ITE2470

880 M1=M1+1 ITE2480

12=12+1 ITE2490

RC(I2)=A(I) ITE2500

13=13+1 ITE2510

RC(I3)=A(L) ITE2520

GO TO 940 ITE2530

890 IF (NR0W-M-IND2 ) 900,910,910 ITE2540

900 I0VFL=1 ITE2550

GO TO 930 ITE2560

910 DELT=(A(I)-A(I-1) ) /DIV ITE2570

M=M+1 ITE2580

11=11+1 ITE2590

RC(I1)=A(I-1) ITE2600

DO 920 J=l, INSERT ITE2610

M=M+1 ITE2620

11=11+1 ITE2630

920 RC(I1)=RC(I1-1)+DELT ITE2640

M=M+1 ITE2650

11=11+1 ITE2660

RC(I1)=A(I) ITE2670

930 M1=M1+1 ITE2680

12=12+1 ITE2690

RC(I2)=(A(I)+A(I-l))/2.0 ITE2700

13=13+1 ITE2710

RC(I3)=(A(L)+A(L-1) ) /2.0 ITE2720

940 14=14+1 ITE2730

RC(I4)=A(K) ITE2740

IF (NR0W-M1) 470,470,960 ITE2750

950 CONTINUE ITE2760

960 CONTINUE ITE2770

GO TO 750 ITE2780

END ITE2790

131
cc

c

cc

c

c

cc

c

c

c

c

c

ccc

c

c

c

c

cc

c

c

c

c

c

c

c

c

BLOCK DATA

VERSION 5.00

BLOCK DATA

LBCONS

LBCONS 5/15/70

Cc

c

c

c

c

cc

cc

THESE CONSTANTS MAY HAVE TO BE CHANGED FOR OTHER COMPUTERS OR

LIBRARY ROUTINES

LBC

LBC

LBC

LBC

LBC

LBC

LBC

10

20

30

40

50

60

70

80

90

DSNCOS IS USED BY DOUBLE PRECISION SIN AND COS FUNCTIONS IN ORDER LBC

TO TRAP IF ARGUMENT BECOMES TOO LARGE LBC

LBC 100

XTRIG IS USED BY FSIN,FCOS FUNCTIONS IN ORDER TO TRAP IF ARGUMENTLBC 110

BECOMES TOO LARGE

XEXP

DXEXP

ER

NBM

TRRTPI

ISIGD

LBC 120

LBC 130

LBC 140

LBC 150

LBC 160

LBC 170

LBC 180

LBC 190

LBC 210

LBC 220

LBC 230

LBC 240

LBC 250

LBC 260

LBC 270

LBC 280

IS USED BY SUBROUTINE ERRINT AND IS THE VALUE 2.0/SQRT(PI) LBC 290

LBC 300

IS USED BY SUBROUTINE FIXFLO AND INFERR, NO. OF SIGNIFICANTLBC 310

IS USED BY FEXP FUNCION IN ORDER TO TRAP IF ARGUMENT

BECOMES TOO LARGE

IS USED BY FDEXP FUNCTION IN ORDER TO TRAP IF ARGUMENT

BECOMES TOO LARGE

IS USED BY SUBROUTINE CSPINV TO CHECK ON A COMPUTER ZERO

IS USED BY SUBROUTINE ERRINT AND IS THE NUMBER OF BINARY

BITS IN THE CHARACTERISTIC OF A DOUBLE PRECISION NUMBER

IS USED BY SUBROUTINE ERRINT AND IS THE NUMBER OF BINARY

BITS IN THE MANTISSA OF A DOUBLE PRECISION NUMBER

DIGITS I/O SUB. CAN PRINT AFTER DECIMAL POINT ISIGD=8

DOUBLE PRECISION DSNCOS , DXEXP , TRRTPI

COMMON /CONSLB/XTRIG , XEXP

COMMON /C0NLB2 /ER , ISIGD

COMMON/CONSTS/PI ,E ,HALFPI , DEG , RAD , XALOG

COMMON/DCQNLB/DSNCOS, DXEXP

C0MM0N/DC0NL2 /TRRTPI ,NBC ,NBM

DATA DSNCOS/3 .5D16/ .DXEXP/704 .000/

DATA NBC/ 11 / ,NBM/60/ , TRRTPI /l . 128379167095512574D0

/

DATA XTRIG/3.3E7/,XEXP/88.0 / DATA ER/l.E-8/,ISIGD/8/

THIS BLOCK DEFINES CONSTANTS TO BE USED THROUGHOUT OMNI TAB

WHOSE VALUE (ACCURACY) WILL HAVE TO BE CHANGED FOR OTHER

COMPUTERS

PI=3. 14159265 (VALUE OF PI)

E, 2.71821818 (BASE OF NATURAL LOGS)

HALFPI=1. 5707963 (VALUE OF PI/2)

DEG= 57.2957795 (NUMBER OF DEGREES IN ONE RADIAN)

RAD= .0174532925 (NUMBER OF RADIANS IN ONE DEGREE)

XALOG= 38. (EXPONENT BOUND)

DATA PI ,E,HALFPI ,DEG,RAD, XALOG/

1 3.14159265,2 .7182818,1.5707963,57 .2957795, .0174532925,38./

END

LBC 320

LBC 330

LBC 340

LBC 350

LBC 360

LBC 370

LBC 380

LBC 390

LBC 400

LBC 410

LBC 420

LBC 430

LBC 440

LBC 450

LBC 460

LBC 470

LBC 480

LBC 490

LBC 500

LBC 510

LBC 520

LBC 530

LBC 540

LBC 550

LBC 560

132
SUBROUTINE LIST (K) LIS 10

C VERSION 5.00 LIST 5/15/70 LIS 20

C WRITTEN BY R VARNER 3/14/68 LIS 30

C K=0 COMMAND IS LIST LIS 40

C K=l COMMAND IS NOLIST LIS 50

COMMON /BLOCKC/ KIO , INUNIT , ISCRAT , KBDOUT ,KRDKNT , LLI ST LIS 60

COMMON /BLOCRC/ NRC , RC (12600 ) LIS 70

COMMON /BLOCKD/ IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NLIS 80

1ARGS ,VWXYZ (8) ,NERROR LIS 90

DIMENSION ARGS(IOO) LIS 100

EQUIVALENCE (ARGS (1) ,RC (12501) ) LIS 110

IF (K.EQ.O) GO TO 20 LIS 120

C NO LIST OR NOLIST LIS 130

IARGS(1)=0 LIS 140

10 IF (NERROR.EQ.O) LLI ST=I ARGS ( 1 ) LIS 150

WRITE (ISCRAT, 30) IARGS(l) LIS 160

RETURN LIS 170

C LIS 180

C LIST (WITH NO ARGUMENTS) = LIST 3 LIS 190

C LIST 0 = NO LISTING LIS 200

C LIST 1 = LIST ONLY INFORMATIVE DIAGS. LIS 210

C LIST 2 = LIST ONLY ARITH. ERR LIS 220

C LIST 3 = LIST BOTH TYPES OF ERRORS LIS 230

C LIST=4 SUPPRESS BOTH ARITHMETIC ERRORS AND INFORMATIVE DIAGNOSTICSLIS 235

C IF A FATAL ERROR OCCURS, LLIST IS SET TO AND KEPT AT 3 LIS 240

20 IF (NARGS .EQ . 0 .OR . IARGS (1 ) . LT . 0 .OR . IARGS (1 ) .GT .4) IARGS(1)=3 LIS 250

GO TO 10 LIS 260

C LIS 270

30 FORMAT (1H,,I1,82X) LIS 280

END LIS 290

FUNCTION LOCATE (L) LOC 10

C VERSION 5.00 LOCATE 5/15/70 LOC 20

COMMON /BLOCKB / NSTMT , NSTMTX , NSTMTH ,NCOM, LCOM, IOVFL , COM ( 2000 ) LOC 30

C LOC 40

C THIS FUNCTION SEARCHES THE LIST OF STORED COMMANDS TO SEE IF ONE LOC 50

C WITH STATEMENT NUMBER L EXISTS. IF IT DOES, RETURN ITS LOCATION. LOC 60

C IF IT DOESN'T EXIST, RETURN NEGATIVE THE LOCATION OF THE NEXT LOC 70

C HIGHER STATEMENT NUMBER. LOC 80

C LOC 90

1=1 LOC 100

AL=L LOC 105

10 IF (COM(I)-AL) 20,30,40 LOC 110

20 I=I+IFIX(C0M(I+1)) LOC 120

GO TO 10 LOC 130

30 LOCATE=I LOC 140

GO TO 50 LOC 150

40 LOCATE=-I LOC 160

50 RETURN LOC 170

END LOC 180

133
C BLOCK DATA LOOKTB

C VERSION 5.00 LOOKTB 5/15/70

BLOCK DATA

COMMON /I CODE/ NIR ,NID ,NIRD ( LIR , LID ,LIRD

COMMON/CODE/IALPH (6),NALPH (5), ID (9 ,3 ) , 1 IR (300,4) ,IRD(30,6)

C **** THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS

COMMON/ICODTP/NITP, LITP

C0MM0N/C0DETP/ITP(10,4)

LOT

LOT

LOT

LOT

LOT

LOT

LOT

LOT

LOT

10

20

30

40

50

60

70

80

90

C

c

ADD SUB SUBTRA MULT MULTIP DIV DIVIDE RAISE

Ccc

C

c

C

cc

DATA IR(1,1),IR(1,2),IR(1,3),IR(1,4),IR(2,1),IR(2,2),IR(2,3),

1 IR (2 ,4) , IR (3 , 1) ,IR(3,2) , IR (3 ,3) ,IR(3,4) ,IR(4,1) ,IR(4,2) ,IR(4,3)

,

2IR(4,4) ,IR(5,1) ,IR(5,2) ,IR(5,3) ,IR(5,4) ,IR(6,1) ,IR(6,2) ,IR(6,3)

,

3 IR(6,4) , IR (7 ,1) , IR (7,2) ,IR(7,3) ,IR(7,4) ,IR(8,1) ,IR(8,2) , IR (8 ,3)

,

4IR(8,4) / 5 841,0,11,1,14420, 0,11,2,14420,15067,11,2,

6 10056,14580,11,3,10056,14839,11,3,3181, 0,11,4,

7 3181,6674,11,4,13158,13986,11,5/

SIN COS TAN

ATAN ACOT

5IND COSD TAND

SQRT EXP

SINH COSH TANH

ABSULO INTEGE FRACTI

COT ASIN ACQS

COTD ASIND ACOSD ATAND ACOTD

EXPONE NEGEXP LOG LOGE LOGTEN ANTILO

COTH ASINH ACOSH ATANH ACOTH ABS

DATA

IR(10

IR (12

IR(14

IR (15

IR (17

IR (19

IR (21

8 IR (22

9 IR (24

A 14108

B 2612

0

1270

14108

2612

DATA

IR

IR

I

R

IIR

I R IP

IR

IR

IR

0

0

0

,10206

, 2916

, 2916

IR

,3)

,2)

,1)

,4)

,3)

,2)

,1)

,4)

,3)

IR (27

IR (29

IR (31

IR (32

IR(34

IR (36

IR (38

8 IR (39

9 IR (41

A IR(43

B IR(45

C 825

DE

,3)

,2)

,1)

,4)

,3)

,2)

,1)

,4)

,3)

,2)

,1)

IR

IR

IR

IR

IR

IR

IR

IR

IR

IR

IR

9,1)

10,4)

12,3)

14,2)

16,1)

17,4)

19,3)

21,2)

23,1)

24,4)

12,1,

12

0

12

12

,13959,

12,12

26,1)

27,4)

29,3)

31,2)

33,1)

34,4)

36,3)

38,2)

40,1)

41,4)

43,3)

45,2)

12,14

IR( 9,

IR (11

,

IR (12,

IR(14,

IR (16

,

IR (18,

IR (19

IR (21

IR (23 , IR(25,

2611,

0,

825,

0,

2611,

1251,

IR (26

,

IR (28

IR (29

IR (31

IR(33,

IR (35

,

IR (36

IR (38

,

IR(40,

IR(42,

IR (43 , IR (45

,

1270,

2)

1)

4)

3)

2)

1)

4)

3)

2)

1)

IR( 9

IR (11

IR (13

IR(14

IR (16

IR (18

IR (20

IR (21

IR (23

IR (25

0,12,

0, 0

13851,12

0, 0

2916,12

10314,12

2) , IR (26

, IR (28

,IR(30

, IR (31

, IR (33

, IR (35

, IR (37

, IR (38

, IR (40

, IR (42

,IR(44

,IR(45

10314,12

1)

4)

3)

2)

1)

4)

3)

2)

1)

•I) 3)

4309 0,12,18, 4309,11318,12

,3),IR( 9

,2) , IR (11

,1) , IR (13

,4) , IR (15

,3) , IR (16

,2) , IR (18

,1) ,IR(20

,4) , IR (22

,3) ,IR(23

,2) ,IR(25

2,14621,

, 0, 1251

, 6, 0

, 0, 825

,10,14621

,13/

,3) , IR (26

,2) , IR (28

,1) ,IR(30

,4) , IR (32

,3),IR(33

,2) , IR (35

,1) ,IR(37

,4) , IR (39

,3) ,IR(40

,2) ,IR(42

,1) ,IR(44

,4)/

,15, 825

14328

,18,10348

IR

IR

IR

IR

IR

IR

IR

IR

IR

IR

0,

,10206

0

,14580

, 2916

,4)

,3)

,2)

,1)

,4)

,3)

,2)

,1)

,4)

,3)

12

,4)

,3)

,2)

,1)

,4)

,3)

,2)

,1)

,4)

,3)

,2)

IR

IR

IR

IR

IR

IR

IR

IR

IR

IR

IR

,14688

,14580

, 4309

10,1)

11,4)

13,3)

15,2)

17,1)

18,4)

20,3)

22,2)

24,1)

25,4)

, 3,

12, 5 0, 0

12, 8

12,11

27,1)

28,4)

30,3)

32,2)

34,1)

35,4)

37,3)

39,2)

41,1)

42,4)

44,3)

12,16

12,17

12,19

IR (10 , 2

)

IR (12 , 1)

IR(13,4)

IR (15 ,3)

IR(17,2)

IR(19,1)

IR(20,4)

IR (22 ,3)

IR(24,2)

/

IR(27,2)

IR(29,1)

IR(30,4)

IR (32 ,3)

IR(34,2)

IR (36 , 1)

IR(37,4)

IR(39,3)

IR(41,2)

IR(43,1)

IR(44,4)

*LOT 100

LOT 110

LOT 120

LOT 130

LOT 140

LOT 150

LOT 160

LOT 170

LOT 180

LOT 190

LOT 200

LOT 210

LOT 220

LOT 230

LOT 240

LOT 250

LOT 260

LOT 270

LOT 280

LOT 290

LOT 300

LOT 310

LOT 320

LOT 330

LOT 340

LOT 350

LOT 360

LOT 370

LOT 380

LOT 390

LOT 400

LOT 410

LOT 420

LOT 430

LOT 440

LOT 450

LOT 460

LOT 470

LOT 480

LOT 490

LOT 500

LOT 510

LOT 520

LOT 530

LOT 540

LOT 550

LOT 560

LOT 570

LOT 590

LOT 600

134
cc

c

c

c

cc

c

c

c

c

c

c

c

c

F 9160, 0,12,20, 9160, 3645,12,20, 9160,14729,12,21,

G 1127, 6900,12,22,14108, 5832,12,23,2611, 5832,12,24,

H 14621, 5832,12,25, 2612, 5832,12,26, 1251,10422,12,27,

I 825,14067,12,28, 1270,10422,12,29,

J 825,14796,12,30, 802, 0,12,31/

DATA IR (46,1) ,IR (46,2) ,IR (46,3) ,IR (46,4) ,IR (47,1) ,IR (47,2)

,

1 IR (47,3) ,IR (47,4) ,IR (48,1) ,IR (48,2) ,IR (48,3) ,IR (48,4)/

2 802,11280,12,31,

3 6959, 3839,12,32, 4861, 2736,12,33/

GENERA SET FIXED FLOATI PLOT SPACE CGS

DATA

IR (50

IR (52

IR (54

IR (55

IR (57

5252

4713

8 14284

9 0

,3)

,2)

,1)

,4)

,3)

IR(49

, IR (50

, IR (52

,IR(54

, IR (56

, IR (57

4132 ,13

1278,13

2322,13

0, 0

,D

,4)

,3)

,2)

,1)

,4)

, 1

, 4

, 9

, 0/

IR(49,

IR (51

,

IR (52

IR (54

IR (56

IR (58

14006,

12003,

2395,

2) ,IR(49,3)

1) , IR (51 ,2)

4) ,IR(53,1)

3) ,IR(54,4)

2) ,IR(56,3)

1) ,IR(58,2)

0,13, 2 14580,13, 5 0,13,10

IR (49 ,4)

IR (51 ,3)

IR (53,2)

IR(55,1)

IR(56,4)

IR(58,3)

4641

0

14094

, IR (50 ,1)

,IR(51,4)

,IR(53,3)

,IR(55,2)

,IR(57,1)

,IR(58,4)/

3753,13, 3

0, 0, 0

0,13,11

SI

IR (50 ,2)

IR (52 , 1

)

IR(53,4)

IR (55 ,3)

IR (57 ,2)

BEGIN SCAN

IFGT IFGE

REPEAT EXECUT PERFOR INCREM RESTOR IFLT

IFNE IFLE

DATA IR (59 , 1

)

IR(60,3) ,IR(60,4)

IR (62 ,2) , IR (62 ,3

)

IR(64,1) ,IR(64,2)

IR(65,4) ,IR(66,1)

IR (67 ,3) ,IR(67,4)

IR (69 ,2) ,IR(69,3)

IR(71,1) ,IR(71,2)

IR (59 , 2

)

IR (61 ,1)

IR(62,4)

IR(64,3)

IR (66 ,2)

IR (68 , 1

)

IR(69,4)

IR(59,3)

IR(61,2)

IR(63,1)

IR(64,4)

IR(66,3)

IR(68,2)

IR(70,1)

IR(71,4)/

IR (59 , IR (61

,

IR (63 , IR (65 , IR (66

,

IR (68

,

IR(70,

IR (71 ,3)

1600,6939,14, 1,13933,10206,14, 2,13273,

4298, 2774,14, 3,11817, 4797,14, 3, 6942,

13276,15003,14, 8, 6735,14580,14, 9, 6728

B 6730,14580,14,11, 6730, 3645,14,12, 6737,

C 6735, 3645,14,14/

4) ,IR(60,1)

3) ,IR(61,4)

2) ,IR(63,3)

1) ,IR(65,2)

4) ,IR(67,1)

3) ,IR(68,4)

2) ,IR(70,3)

3692,14, 3,

13270,14, 6,

,12393,14,10

3645,14,13,

IFEQ

IR (60 ,2

)

IR (62 ,1)

IR(63,4)

IR (65 ,3)

IR(67 ,2)

IR (69 , 1)

IR(70,4)

MDEFIN ADEFIN AERASE MZERO AZERO MERASE MIDENT MSUBTR MDIAGO

DATA IR (72 , 1) ,IR (72,2) ,IR (72,3) ,IR (72,4) ,IR (73,1) ,IR (73,2)

1 IR (73,3) ,IR(73, 4) ,IR (74,1) ,IR (74,2) ,IR (74,3) ,IR (74,4) ,IR (75,1)

2 IR (75,2) ,IR (75,3) ,IR (75,4) ,IR (76,1) ,IR (76,2) ,IR (76,3) ,IR (76,4)

3 IR (77,1) ,IR(77,2) ,IR (77,3) ,IR (77,4) ,IR (78,1) ,IR(78,2) ,IR (78,3)

4 IR(78,4) ,IR (79,1) ,IR (79,2) ,IR (79,3) ,IR (79,4) ,IR (80,1) ,IR (80,2)

5 IR(80,3) ,IR(80,4)/

6 9590,4631,15,1, 842, 4631,15, 1, 882, 1247,15, 2,

7 10184,13527,15, 2, 1436,13527,15, 2, 9630, 1247,15, 2,

8 9724, 4043,15, 3,10011, 2016,18, 2, 9594, 933,15, 4/

MINVER INVERT MMULTI

DATA IR (81, 1) ,IR (81,2) ,IR (81,3) ,IR (81,4) ,IR (82,1) ,IR (82,2) , 1 IR(82,3) ,IR (82,4) ,IR (83,1) ,IR (83,2) ,IR (83,3) ,IR (83, 4)/

2 9734,16191,16, 1, 6961, 4151,16, 1, 9849, 9297,17, 1/

MMULT MRAISE

LOT 610

LOT 620

LOT 630

LOT 640

LOT 650

LOT 660

LOT 665

LOT 670

LOT 680

LOT 690

LOT 700

LOT 710

LOT 720

LOT 730

LOT 740

LOT 750

LOT 760

LOT 770

LOT 780

LOT 790

LOT 800

LOT 810

LOT 820

LOT 830

LOT 840

LOT 850

LOT 860

LOT 870

LOT 880

LOT 890

LOT 900

LOT 910

LOT 920

LOT 930

LOT 940

LOT 950

LOT 960

LOT 970

LOT 980

LOT 990

LOT1000

L0T1010

L0T1020

L0T1030

L0T1040

LOT1050

L0T1060

L0T1070

L0T1080

L0T1090

L0T1100

L0T1110

L0T1120

L0T1130

L0T1140

L0T1150

L0T1160

L0T1170

L0T1180

135
C LQT1190

DATA IR(84,1) ,IR (84,2) ,IR (84,3) ,IR (84,4) ,IR (85,1) ,IR (85,2) , L0T1200

1 IR (85 ,3) ,IR(85,4)/ L0T1210

2 9849, 9288,17, 1, 9964, 7079,17, 2/ L0T1220

C L0T1230

C MADD MSUB MTRANS ATRANS AADD ASUB A MULT AMULTI ASUBTR L0T1240

C MSCALA ADIVIO ADIV ARAISE L0T1250

C L0T1260

DATA I R (86,1) ,IR (86,2) ,IR (86,3) ,IR (86,4) ,IR (87,1) ,IR (87,2) , L0T1270

6 IR(87,3) ,IR (87,4) ,IR (88,1) ,IR (88,2) ,IR (88,3) ,IR (88,4) , L0T1280

7 IR (89 , 1) ,IR (89,2) ,IR (89,3) ,IR (89,4) ,IR (90,1) ,IR (90,2) ,IR (90,3) , L0T1290

8 IR (90,4) ,IR (91,1) ,IR (91,2) ,IR (91,3) ,IR (91,4) ,IR (92,1) ,IR (92,2) , L0T1300

9 IR(92,3) ,IR (92,4) ,IR (93,1) ,IR (93,2) ,IR (93,3) ,IR (93,4) ,IR (94,1) , L0T1310

A IR(94,2) ,IR (94,3) ,IR (94,4) ,IR (95,1) ,IR (95,2) ,IR (95,3) ,IR (95,4) , L0T1320

B IR (96,1) ,IR (96,2) ,IR (96,3) ,IR (96,4) ,IR (97,1) ,IR (97,2) ,IR (97,3) , L0T1330

C IR(97,4) ,IR(98,1) ,IR(98,2) ,IR(98,3) ,IR(98,4)/ L0T1340

D 9508, 2916,18, 1,10011, 1458,18, 2,10035, 1126,18, 3, L0T1350

E 1287, 1126,18, 3, 760, 2916,18, 4, 1263, 1458,18, 5, L0T1360

F 1101, 9288,18, 6, 1101, 9297,18, 6, 1263, 2016,18, 5, L0T1370

G 9993, 1054,18, 6, 846,16285,18, 7, 846,16038,18, 7, L0T1380

H 1216, 7079,18, 8/ L0T1390

C L0T1400

C L0T1410

C L0T1420

DATA IR( 99,1),IR( 99,2),IR( 99,3),IR( 99 ,4 )

, IR ( 100 , 1 ) , L0T1430

1 IR (100,2) ,IR (100,3) ,IR (100,4) ,IR (101,1) ,IR (101,2) ,IR (101,3) , L0T1440

2 IR (101,4) ,IR (102,1) ,IR (102,2) ,IR (102,3) ,IR (102,4) ,IR (103,1) , L0T1450

3 IR(103,2) ,IR( 103,3) ,IR (103,4 ) ,IR( 104,1) ,IR( 104,2) ,IR( 104,3 ) , L0T1460

4 IR(104,4)/ L0T1470

5 0, 0,0,0, 0, 0,0,0, 0, 0,0,0, L0T1480

6 0, 0,0,0, 0, 0,0,0, 0, 0,0,0/ L0T1490

C L0T1500

C PARSUM PARPRO RMS AVERAG SUM LOT1510

C L0T1520

DATA IR (105 , 1 ) ,IR(105,2) ,IR(105,3) ,IR(105,4) ,IR(106,1) , L0T1530

1 IR (106,2) ,IR( 106,3) ,IR (106,4 ) ,IR( 107,1) ,IR (107,2) ,IR (107,3) , L0T1540

2 IR(107,4) ,IR (108,1) ,IR( 108,2) ,IR( 108,3) ,IR (108,4) ,IR( 109,1) , L0T1550

3 IR(109,2) ,IR(109,3) ,IR(109,4) / L0T1560

4 11709,14431,20, 1,11709,12165,20, 2,13492, 0,20, 3, L0T1570

5 1328,13156,20, 4,14431, 0,20, 5/ L0T1580

C L0T1590

C ROWSUM PRODUC DEFINE MAX MAXIMU MIN MINIMU SORT ORDER L0T1600

C ERASE EXCHAN FLIP CHANGE HIERAR LIST NULL L0T1610

C L0T1620

DATA IR(110,1) ,IR(110,2) ,IR(110,3) ,IR(110,4) ,IR(111,1) , LOT1630

1 IR (111,2) ,IR (111,3) ,IR (111,4) ,IR (112,1) ,IR (112,2) ,IR (112,3) , L0T1640

2 IR(112,4) ,IR (113,1) ,IR( 113,2) ,IR( 113,3) ,IR( 113,4 ) ,IR (114,1 )

, L0T1650

3 IR (114,2) ,IR( 114,3) ,IR( 114,4 ) ,IR (115,1) ,IR( 115,2) ,IR( 115,3) , LOT1660

4 IR (115,4) ,IR (116,1 ) ,IR (116,2 ) ,IR (116,3 ) ,IR (116,4) ,IR (117,1) , L0T1670

5 IR (117,2) ,IR (117,3) ,IR(117,4) ,IR (118,1) ,IR (118,2) ,IR (118,3) , L0T1680

6 IR(118,4) ,IR (119,1) ,IR( 119,2) ,IR( 119,3) ,IR( 119,4 ) ,IR( 120,1) , L0T1690

7 IR (120,2) ,IR (120,3) ,IR (120,4) ,IR (121,1) ,IR (121,2) ,IR (121,3) , L0T1700

8 IR (121,4) ,IR (122,1) ,IR (122,2) ,IR (122,3) ,IR (122,4) ,IR (123,1) , L0T1710

9 IR (123,2 ) ,IR (123,3) ,IR (123,4) ,IR (124,1) ,IR (124,2) ,IR (124,3) , L0T1720

A IR (124,4) ,IR (125,1) ,IR( 125,2) ,IR( 125,3 ) ,IR( 125,4 ) ,IR (126,1) , L0T1730

B IR (126 ,2) ,IR(126,3) , IR (126 ,4) / L0T1740

C 13550,14431,21, 1,12165, 3486,21, 2, 3057, 6944,21, 3, L0T1750

D 9528, 0,21, 5, 9528, 6933,21, 5, 9734, 0,21, 6, LOT1760

E 9734, 6933,21, 6,14274,14580,21, 8,11425, 4131,21, 9, L0T1770

136
F 4132,13986,21,10, 4296, 5873,21,11, 4707,11664,21,12, LOT1780

G 2404,10400,21,13, 6080,13167,21,14, 9010,14580,21,15, L0T1790

H 0, 0, 0, 0,10785, 8748,21,17/ L0T1800

C L0T1810

C POLYFI SPOLYF FIT SFIT SOLVE MORTHO L0T1820

C L0T1830

DATA IR (127 , 1 ) ,IR(127,2) ,IR(127,3) ,IR(127,4) ,IR(128,1) , L0T1840

1 IR (128,2) ,IR (128,3) ,IR (128,4) ,IR (129,1) ,IR (129,2) ,IR (129,3 ), L0T1850

2 IR (129,4) ,IR (130,1) ,IR (130,2) ,IR (130,3) ,IR (130,4) ,IR (131,1) , L0T1860

3 IR (131,2) ,IR (131,3 ) ,IR (131,4) ,IR (132,1) ,IR (132,2) ,IR (132,3) , L0T1870

4 IR(132,4)/ L0T1880

5 12081,18396,22, 1,14298, 9429,22, 2, 4637, 0,22, 3, LOT1890

6 14022,14580,22, 4,14268,16173,16, 2, 9900,14811,22, 5/ LOT1900

C L0T1910

C COUNT SHORTE EXPAND DUPLIC MOVE DIM AMOVE L0T1920

C MMOVE PROMOT DEMOTE DIMENS L0T1930

C L0T1940

DATA IR (133 , 1) ,IR(133,2) ,IR(133,3) ,IR(133,4) ,IR(134,1) , L0T1950

1 IR (134,2) ,IR (134,3) ,IR (134,4) ,IR (135,1) ,IR (135,2 ) ,IR (135,3 )

, L0T1960

2 IR (135,4) ,IR (136,1) ,IR (136,2) ,IR (136,3) ,IR (136,4) ,IR (137,1) , LOT1970

3 IR(137,2) ,IR(137,3) , IR (137 , 4 ), IR (138 , 1 ), IR ( 138 , 2 ), IR ( 138 , 3 )

, L0T1980

4 IR (138,4) ,IR (139,1) ,IR (139,2) ,IR (139,3) ,IR (139,4) ,IR (140,1) , L0T1990

5 IR (140,2) ,IR (140,3) ,IR (140,4) ,IR (141,1) ,IR (141,2) ,IR (141,3) , L0T2000

6 IR (141,4) ,IR (142,1) ,IR (142,2) ,IR (142,3) ,IR (142,4) ,IR (143,1) , L0T2010

7 IR(143,2) ,IR(143,3) ,IR(143,4) , IR ( 144 , 1 )

, IR (144 , 2 ), IR (144 , 3 ) , L0T2020

8 IR(144,4) ,IR(145,1) ,IR(145,2) ,IR(145,3) ,IR(145,4) / L0T2030

9 0, 0, 0, 0, 0, 0, 0, 0, 2613,10746,23, 2, L0T2040

A 14082,13667,23, 3, 4309, 1111,23, 4, 3499, 8994,23, 5, L0T2050

B 9904, 3645,23, 6, 3172, 0,23,12, 1095,16173,23, 6, L0T2060

C 9843,16173,23, 6,12165, 9902,23,10, 3064,11480,23,11, L0T2070

D 3172, 4042,23,12/ L0T2080

C L0T2090

C STATIS SSTATI RANKS ACCURA L0T2100

C L0T2110

DATA IR(146,1) ,IR(146,2) ,IR(146,3) ,IR(146,4) ,IR(147,1) , L0T2120

1 IR (147,2) ,IR (147,3 ) ,IR (147,4) ,IR (148,1) ,IR (148,2) ,IR (148,3) , L0T2130

2 IR (148,4) ,IR (149,1) ,IR (149,2) ,IR( 149,3) ,IR (149,4 ) ,IR (150,1 )

, L0T2140

3 IR(150,2) ,IR(150,3) ,IR(150,4) / L0T2150

4 14392,14842,24, 1,14384, 1278,24, 2,13163, 8532,24, 3, L0T2160

5 813,15796,11, 6, 0, 0, 0, 0/ L0T2170

C L0T2180

C SELECT SEARCH CENSOR L0T2190

C L0T2200

DATA IR (151 ,1) ,IR(151,2) ,IR(151,3) ,IR(151,4) ,IR(152,1) , L0T2210

1 IR (152,2) ,IR (152,3) ,IR (152,4) ,IR (153,1) ,IR (153,2) ,IR (153,3) , L0T2220

2 IR(153,4)/ L0T2230

3 13998, 3746,25, 1,13987,13211,25, 2, 2336,14274,25, 3/ L0T2240

C L0T2250

C MVECDI MVECMA MMATV L0T2260

C L0T2270

DATA IR(154,1) ,IR(154,2) ,IR(154,3) ,IR(154,4) ,IR(155,1) , L0T2280

1 IR (155,2) ,IR (155,3) ,IR (155,4) ,IR (156,1) ,IR (156,2) ,IR (156,3) , LOT2290

2 IR (156,4) ,IR (157,1) ,IR (157,2) ,IR (157,3) ,IR (157,4) ,IR (158,1) , L0T2300

3 IR (158,2 ) ,IR (158,3 ) ,IR (158,4) ,IR (159,1) ,IR (159,2) ,IR (159,3) , L0T2310

4 IR(159,4)/ L0T2320

5 10076, 2304,26, 1, 0, 0, 0, 0,10076, 2539,26, 2, L0T2330

6 0, 0, 0, 0, 9829,15179,26, 3, 0, 0, 0, 0/ L0T2340

C L0T2350

C MKRONE MTRIAN MEIGEN L0T2360

137
C L0T2370

DATA IR (160 , 1 ) ,IR(160,2) , IR (160 ,3 ) , IR (160 ,4 ) ,IR(161,1) , LOT2380

1 IR (l&l ,2) ,IR (161,3) ,IR (161,4) ,IR (162,1) ,IR (162,2) ,IR (162,3) , L0T2390

2 IR(162,4)/ L0T2400

3 9792,11318,17, 3,10035, 6602,17, 4, 9621, 5252,17, 5/ L0T2410

C L0T2420

C INTERP L0T2430

C L0T2440

DATA IR(163,1) ,IR(163,2) ,IR(163,3) ,IR(163,4) / L0T2450

1 6959, 4147,25, 4/ L0T2460

C L0T2470

C MPROPE APROPE SMPROP SAPROP L0T2480

DATA IR(164,1) ,IR(164,2) ,IR(164,3) ,IR(164,4) , IR ( 165 , 1 )

, L0T2490

1 IR ( 165,2) ,IR( 165,3) ,IR (165,4) ,IR (166,1) ,IR (166,2) ,IR (166,3) , L0T2500

2 IR(166,4) ,IR(167,1) ,IR(167,2) ,IR(167,3) ,IR(167,4)/ LOT2510

3 9927,11372,27, 1, 1179,11372,27, 2, L0T2520

4 14218,13543,27, 3,13894,13543,27, 4/ L0T2530

C L0T2540

C ITERATE ISETUP ISOLATE L0T2550

C L0T2560

DATA IR(168,1) ,IR(168,2) ,IR(168,3) ,IR(168,4) ,IR(169,1) , L0T2570

1 IR (169,2) ,IR (169,3 ) ,IR (169,4) ,IR (170,1) ,IR (170,2) ,IR (170,3 )

, L0T2580

2 IR(170,4)/ L0T2590

3 7106,13169,28, 1, 7079,15163,28, 2, 7089, 8795,28, 3/ L0T2600

C L0T2610

C EXTREMA SEPARATE INSERT MAXMIN L0T2620

C L0T2630

DATA IR (171 , 1 ) ,IR(171,2) , IR (171 ,3 ) ,IR(171,4) f IR (172 , 1) , L0T2640

1 IR (172,2) ,IR (172,3 ) ,IR (172,4) ,IR (173,1) ,IR (173,2) ,IR (173,3 ) , L0T2650

2 IR(173,4) ,IR(174,1) ,IR(174,2) ,IR(174,3) ,IR(174,4)/ L0T2660

3 4313,13270,29, 4,14002, 1216,29, 2, 6958, 4151,29, 3, L0T2670

4 9528, 9734,29, 4/ L0T2680

C LOT2690

C LAGUER NORMLA HERMIT UCHEBY TCHEBY LEGEND LOT2700

C L0T2710

DATA IR (175 , 1) ,IR(175,2) , IR (175 ,3 ) ,IR(175,4) ,IR(176,1) , L0T2720

1 IR (176,2) ,IR (176,3 ) ,IR (176,4) ,IR (177,1) ,IR (177,2) ,IR (177,3) , L0T2730

2 IR (177,4) ,IR (178,1) ,IR (178,2) ,IR (178,3) ,IR (178,4) ,IR (179,1) , L0T2740

3 IR (179,2) ,IR (179,3) ,IR (179,4) , IR (180,1) ,IR (180,2 ) ,IR (180,3) , L0T2750

4 IR(180,4)/ L0T2760

5 8782,15462,19, 2,10629, 9802,19, 1, 5985, 9740,19, 3, L0T2770

6 15398, 3724,19, 4,14669, 3724,19, 6, 8890, 4027,19, 5/ L0T2780

C L0T2790

C BJZERO BJONE BYZERO BYONE BIZERO BIONE BKZERO BKONE L0T2800

C EXIZER EXIONE EXKZER EXKONE KBIZER KBIONE KBKZER KBKONE L0T2810

C L0T2820

DATA IR(181,1) ,IR(181,2) ,IR(181,3) ,IR(181,4) ,IR(182,1) , L0T2830

1 IR (182,2 ) ,IR (182,3) ,IR (182,4) ,IR (183,1) ,IR (183,2 ) ,IR (183,3) , L0T2840

2 IR (183,4) ,IR (184,1) ,IR (184,2) ,IR (184,3) ,IR (184,4) ,IR (185,1) , L0T2850

3 IR (185,2) ,IR (185,3) ,IR (185,4) ,IR (186,1) ,IR (186,2) ,IR (186,3 )

, L0T2860

4 IR (186 ,4) ,IR (187,1) ,IR (187,2 ) ,IR (187,3 ) ,IR (187,4) ,IR (188,1) , L0T2870

5 IR (188,2) ,IR (188,3) ,IR (188,4) ,IR (189,1) ,IR (189,2) ,IR (189,3) , L0T2880

6 IR(189,4) ,IR( 190,1) ,IR( 190,2 ) ,IR( 190,3) ,IR( 190,4 ) ,IR( 191,1) , L0T2890

7 IR (191,2 ) ,IR (191,3) ,IR (191,4) ,IR (192,1) ,IR (192,2 ) ,IR (192,3) , L0T2900

8 IR (192,4) ,IR (193,1) ,IR (193,2) ,IR (193,3 ) ,IR (193,4) ,IR (194,1) , L0T2910

9 IR(194,2) ,IR (194,3) ,IR (194,4) ,IR (195,1) ,IR( 195,2) ,IR( 195,3) , L0T2920

A IR(195,4) ,IR(196,1) ,IR(196,2) ,IR(196,3) ,IR(196,4) / L0T2930

B 1754, 4146,30, 1, 1743,10341,30, 2, 2159, 4146,30, 3, L0T2940

C 2148,10341,30, 4, 1727, 4146,30, 5, 1716,10341,30, 6, L0T2950

138
D 1781, 4146,30, 7, 1770,10341,30, 8, 4302,19107,30, 9, L0T2960

E 4302,11318,30,10, 4304,19107,30,11, 4304,11318,30,12, LOT2970

F 8082,19107,30,13, 8082,11318,30,14, 8084,19107,30,15, L0T2980

G 8084,11318,30,16/ L0T2990

C L0T3000

C KEXIZE KEXION KEXKZE KEXKON CIZERO CIONE CKZERO CKONE L0T3010

C CEIZER CEIONE CEKZER CEKONE INTJO BESJN HARMON BESIN L0T3020

C BESKN L0T3030

C L0T3040

DATA IR(197,1) ,IR(197,2) ,IR(197,3) ,IR(197,4) ,IR(198,1) , L0T3050

1 IR (198,2) ,IR (198,3) ,IR(198,4) ,IR (199,1) ,IR (199,2) ,IR (199,3) , L0T3060

2 IR (199,4) ,IR (200,1) ,IR (200,2) ,IR (200,3 ) ,IR (200,4) ,IR (201,1) , L0T3070

3 IR (201,2) ,IR (201,3) ,IR (201,4) ,IR (202,1 ) ,IR( 202,2 ) ,IR (202,3) , L0T3080

4 IR (202,4 ) ,IR (203,1) ,IR (203,2) ,IR (203,3) ,IR(203, 4) ,IR (204,1) , L0T3090

5 IR (204,2) ,IR (204,3) ,IR (204,4) ,IR (205,1) ,IR (205,2) ,IR (205,3) , L0T3100

6 IR (205,4) ,IR (206,1) ,IR (206,2) ,IR (206,3 ) ,IR (206,4) ( IR (207,1) , L0T3110

7 IR (207,2 ) ,IR (207,3 ) ,IR (207,4) ,IR (208,1) ,IR (208,2) ,IR (208,3 ), L0T3120

8 IR (208,4) ,IR (209,1) ,IR (209,2 ) ,IR (209,3 ) ,IR (209,4) ,IR (210,1) , L0T3130

9 IR (210 ,2) ,IR (210,3) ,IR (210,4) ,IR (211,1) f IR (211,2) ,IR (211,3) , L0T3140

A IR(211,4),IR(212,l),IR(212 f 2),IR(212,3),IR(212,4),IR(213,l), L0T3150

B IR(213,2) , IR (213 ,3 ) ,IR(213,4)/ L0T3160

C 8178, 7268,30,17, 8178, 6980,30,18, 8178, 8726,30,19, L0T3170

D 8178, 8438,30,20, 2456, 4146,30,21, 2445,10341,30,22, L0T3180

E 2510, 4146,30,23, 2499,10341,30,24, 2331,19107,30,25, L0T3190

F 2331,11318,30,26, 2333,19107,30,27, 2333,11318,30,28, L0T3200

G 6959, 7695,30,29, 1612, 7668,30,32, 5877, 9896,30,37, L0T3210

H 1612, 6939,30,38, 1612, 8397,30,39/ L0T3220

C L0T3230

C TWOWAY L0T3240

C L0T3250

DATA IR(214,1) ,IR(214,2) ,IR(214,3) ,IR(214,4) / L0T3260

1 15216,16819,24,6/ L0T3270

C L0T3280

C FLEXIB L0T3290

C L0T3300

DATA IR (215 , 1 ), IR (215 ,2 ), IR (215 ,3) ,IR(215,4)/ L0T3310

1 4703,17741,13,12/ L0T3320

C LOT3330

C SQUARE L0T3340

C L0T3350

DATA IR(216,1) , IR (216 ,2) ,IR(216,3) ,IR(216,4) / L0T3360

1 14331, 1220,12,34/ L0T3370

C L0T3380

C ACOALE AAVERA L0T3390

C L0T3400

DATA IR (217 , 1 )

, IR (217 , 2 ), IR (217 ,3 ) ,IR(217,4) , IR (218 , 1 ) , L0T3410

1 IR (218 ,2) ,IR(218,3) ,IR(218,4)/ L0T3420

2 825, 1058,18, 9, 778, 4132,18,10/ L0T3430

C L0T3440

C MATCH L0T3450

C L0T3460

DATA IR (219 ,1) , IR (219 ,2) , IR (219 ,3 ) ,IR(219,4)/ L0T3470

1 9524,2403,25,5/ LOT3480

C L0T3490

C HISTOG NHISTO FREQUE L0T3500

C L0T3510

DATA IR (220,1) ,IR (220,2) ,IR (220,3 ) ,IR (220,4) ,IR (221,1) , L0T3520

1 IR (221 ,2) , IR (221 ,3 )

, IR (221 , 4 ), IR ( 222 , 1 ) , IR (222 , 2 )

, IR (222 , 3 )

, L0T3530

2 IR (222 ,4) / L0T3540

139
3 6094,14992,24, 8,10431,14406,24, 9, 4865,12965,24,10/ L0T3550

C LOT3560

C CORREL SCORRE L0T3570

C L0T3580

DATA IR(223,1) ,IR(223,2) , IR (223 ,3 ) ,IR(223,4) ,IR(224,1) , L0T3590

1 IR(224,2) ,IR(224,3) ,IR(224,4)/ L0T3600

2 2610,13269,24,11,13947,13613,24,12/ L0T3610

C L0T3620

C COMPARE, ONEWAY, SONEWAY , ERROR, CERF,STWOWAY L0T3630

C L0T3640

DATA IR (225,1) ,IR (225,2) ,IR (225,3) ,IR (225,4) ,IR (226,1) ,IR (226,2) , L0T3650

1 IR (226,3) ,IR (226,4) ,IR (227,1) ,IR (227,2 ) ,IR (227,3) ,IR (227,4) , L0T3660

2 IR (228,1) ,IR (228,2) ,IR (228,3 ) , IR (228,4) ,IR (229,1) ,IR (229,2) , L0T3670

3 IR (229,3 ) ,IR (229,4) ,IR (230,1) ,IR(230,2) , IR (230 ,3 ) , IR (230,4 ) / L0T3680

4 2605,11709,14,15,11318,16819,24,13,14270, 4267,24,14, L0T3690

5 4149,11421,21,18, 2340, 4374,21,19,14414,11557,24, 7/ L0T3700

C L0T3710

C CTOF,FTOC, ATOMIC, MOLWT, EINSTEIN, PFTRANS ,PFATOMIC ,PARTFUNCT ,B0LDISTL0T3720

DATA IR (231, 1) ,IR (231,2) ,IR (231,3 ) ,IR (231,4) , IR (232 , 1) ,IR(232,2) ,L0T3730

1 IR (232 ,3 ) ,IR(232,4) ,IR (233,1) , IR (233 , 2 ) , IR (233 , 3 ) ,IR(233,4) ,L0T3740

2 IR (234,1) ,IR(234,2) ,IR (234,3) , IR (234 , 4 ) , IR (235 , 1 )

, IR (235 ,2) ,L0T3750

3 IR (235 ,3 ) ,IR(235,4) , IR (236 , 1 ) , IR (236 , 2 ) , IR (236 , 3 )

, IR (236 , 4 ) ,L0T3760

4 IR (237, 1) ,IR (237,2) ,IR (237,3) ,IR (237,4) ,IR (238,1) ,IR (238, 2) ,L0T3770

5 IR(238,3) ,IR(238,4) , IR (239,1) ,IR(239,2) ,IR(239,3) , IR (239 ,4 ) /L0T3780

6 2742, 4374,31, 1, 4929, 2187,31, 2, 1284, 9723,31, 3, 9894 , 17307L0T3790

7 ,31, 4, 3902,14396,31,5,11846,13163,31, 6,11827,14998,31, 7 , 11709L0T3800

8 ,14763,31, 8, 1875, 3178,31, 9/ L0T3810

C L0T3820

C ROUND L0T3830

C L0T3840

DATA IR (240,1) ,IR(240,2) , IR (240 , 3 )

, IR (240 , 4 ) / 13548 , 10314 , 13 , 14/ L0T3850

C L0T3860

C COMPLEX ARITHMETIC - CADD, CSUBTRACT, CMULTIPLY , CDIVIDE, L0T3870

C CRECTANGULAR, CPOLAR L0T3880

C L0T3890

DATA IR (241,1) ,IR(241,2) ,IR(241,3) ,IR(241,4) ,IR (242,1) ,IR(242,2) ,L0T3900

1 IR(242,3) ,IR(242,4) ,IR (243,1) , IR (243 , 2 ) , IR (243 , 3 ) ,IR(243,4) ,L0T3910

2 IR (244,1) ,IR(244,2) ,IR(244,3) , IR (244 ,4 )

, IR (245 , 1 ) , IR (245 , 2 ) ,L0T3920

3 IR(245,3) ,IR(245,4) ,IR (246,1) ,IR(246,2) ,IR(246,3) , IR (246 ,4) /L0T3930

4 2218, 2916,32, 1, 2721, 2016,32, 2, 2559, 9297,32, 3, L0T3940

5 2304,16285,32, 4, 2678, 2728,32, 5, 2634, 8793,32, 6/ L0T3950

C L0T3960

q **** * ********************** ************* *************** **»*********|^Qj2 9 7Q

C * *L0T3980

C * USED THUR IR (246,4) : AVAILABLE IR(247,1) THRU IR(300,4) *LOT3990

C * *L0T4000

q ******************************************************** ***********|_q-|-4q^q

C L0T4020

C RESET PRINT PUNCH READ ABRIDG APRINT MPRINT L0T4030

C L0T4040

DATA ID (1, 1) , ID (1,2) , ID (1,3) , ID (2,1) , ID (2,2) , ID (2,3) , ID (3,1) , L0T4050

1 ID (3,2), ID (3,3), ID (4,1) , ID (4,2) , ID (4,3) , ID (5,1) , ID (5,2) , ID (5,3) , L0T4060

2 ID(6,1),ID(6,2),ID(6,3),ID(7,1),ID(7,2),ID(7,3)/ L0T4070

3 13276, 4185,1,12159,10746,2,12245, 2403,3,13258, 2916,5, L0T4080

4 801, 6676,6, 1179, 6959,4, 9927, 6959,7/ L0T4090

C LOT4100

C NPRINT L0T4110

C L0T4120

DATA ID (8 ,1) , ID (8 ,2) , ID (8 ,3) / LOT4130

140
1 10656, 6959,8/ L0T4140

C L0T4150

C A B C D E F L0T4160

C L0T4170

DATA IALPH(l) ,IALPH(2) ,IALPH(3) ,IALPH(4) ,IALPH(5) ,IALPH(6)/ L0T4180

1 729, 1458, 2187, 2916, 3645, 4374/ L0T4190

C L0T4200

C V W X Y Z L0T4210

C L0T4220

DATA NALPH (1 ) ,NALPH (2 ) ,NALPH (3 ) ,NALPH (4 ) ,NALPH (5 ) / L0T4230

1 16038,16767,17496,18225,18954/ L0T4240

C L0T4250

C NO LIST CLOSE UP NEW PAGE LOT4260

C M(XX/) M(X/AX)=M(X/X) M(XAX/) M(AD) M(DA) M(AV) M(V/A) L0T4270

C L0T4280

DATA IRD ( 1,1),IRD( 1,2),IRD( 1,3), IRD ( 1,4),IRD( 1,5), L0T4290

1 IRD ( 1,6) , IRD ( 2,1) , IRD ( 2,2), IRD ( 2,3) , IRD ( 2,4),IRD( 2,5), L0T4300

2 IRD ( 2,6),IRD( 3,1) , IRD ( 3,2) ,IRD( 3,3),IRD( 3,4),IRD( 3,5), L0T4310

3 IRD ( 3,6),IRD( 4,1),IRD( 4,2),IRD( 4,3),IRD( 4,4),IRD( 4,5), L0T4320

4 IRD ( 4,6),IRD( 5,1),IRD( 5,2),IRD( 5,3),IRD( 5,4),IRD( 5,5), L0T4330

5 IRD { 5,6),IRD( 6,1),IRD( 6,2),IRD( 6,3),IRD( 6,4),IRD( 6,5), L0T4340

6 IRD ( 6,6),IRD( 7,1), IRD ( 7,2) , IRD ( 7,3),IRD( 7,4),IRD( 7,5), L0T4350

7 IRD { 7,6),IRD( 8,1),IRD( 8,2),IRD( 8,3),IRD( 8,4),IRD( 8,5), L0T4360

8 IRD ( 8,6),IRD( 9,1),IRD( 9,2),IRD( 9,3),IRD( 9,4),IRD( 9,5), L0T4370

9 IRD { 9,6) ,IRD(10,1) ,IRD(10,2) ,IRD(10,3) ,IRD(10,4) ,IRD(10,5) , L0T4380

A IRD(10,6)/ L0T4390

B 10611, 0, 9010,14580,21,16, 2526,13986,15741, 0,23, 1, L0T4400

C 10364, 0,11698, 3645,13, 8, 9477, 0,18144, 0,51, 1, L0T4410

D 9477, 0,17496, 0,51, 2, 9477, 0,17547, 0,51, 3, LOT4420

E 9477, 0, 837, 0,52, 1, 9477, 0,2943, 0,52, 2, LOT4430

F 9477, 0, 1323, 0,53, 1, 9477, 0,16038, 0,53, 2/ L0T4440

C L0T4450

C DUMMY A B C D L0T4460

C L0T4470

DATA IRD(11,1) , IRD (11 ,2) ,IRD(11,3) ,IRD(11,4) ,IRD(11,5) , LOT4480

1 IRD (11,6) , IRD (12,1) , IRD (12,2) , IRD (12,3) , IRD (12,4) , IRD (12,5) , L0T4490

3 IRD (12,6) , IRD (13,1) , IRD (13,2) , IRD (13,3) , IRD (13,4) , IRD (13,5) , LOT4500

3 IRD (13,6) , IRD (14,1) , IRD (14,2) , IRD (14,3) , IRD (14,4) , IRD (14,5) , L0T4510

4 IRD (14,6) , IRD (15,1) , IRD (15,2) , IRD (15,3) , IRD (15,4) , IRD (15,5) , L0T4520

5 IRD(15,6)/ L0T4530

6 0, 0, 0, 0, 0, 0, 3496,10152, 729, 0,54, 2, L0T4540

7 3496,10152, 1458, 0,54, 3, 3496,10152,2187, 0,54, 4, L0T4550

8 3496,10152, 2916, 0,54, 5/ L0T4560

C L0T4570

C ROW SUM F PROBAB L0T4580

C L0T4590

DATA IRD(16,1) ,IRD(16,2) ,IRD(16,3) ,IRD(16,4) ,IRD(16,5) , L0T4600

1 IRD (16,6) , IRD (17,1) , IRD (17,2) , IRD (17,3) , IRD (17,4) , IRD (17,5) , L0T4610

2 IRD(17,6)/ L0T4620

3 13550, 0,14431, 0,21,1, 4374, 0,12165, 1487,24,5/ L0T4630

C L0T4640

C ELLIPT FIRST ELLIPT SECOND ZEROS BJZERO ZEROS BJONE L0T4650

C STRUVE ZERO STRUVE ONE L0T4660

C LOT4670

DATA IRD (18 ,1) ,IRD(18,2) ,IRD(18,3) ,IRD(18,4) ,IRD(18,5) , LOT4680

1 IRD (18,6) , IRD (19,1) , IRD (19,2) , IRD (19,3) , IRD (19,4) , IRD (19,5) , LOT4690

2 IRD (19,6 ), IRD (20,1) , IRD (20,2) , IRD (20,3) , IRD (20,4) , IRD (20,5) , L0T4700

3 IRD (20,6) , IRD (21,1) , IRD (21,2) , IRD (21,3) , IRD (21,4) , IRD (21,5) , L0T4710

4 IRD (21, 6) , IRD (22,1) , IRD (22,2) , IRD (22,3) , IRD (22,4) , IRD (22, 5) , L0T4720

141

409-118 OL - 71 - 10
5 IRD (22,6) ( IRD (23,1) ,IRD (23,2) ,IRD (23,3) , IRD (23,4) ,IRD (23,5) , L0T4730

6 IRD (23 ,6) / L0T4740

7 3981, 7013, 4635,14391,30,30, 3981, 7013,13989,11317,30,31, L0T4750

8 19107,11448, 1754, 4146,30,33,19107,11448, 1743,10341,30,34, L0T4760

9 14409,15908,19107,10935,30,35,14409,15908,11318, 0,30,36/ L0T4770

C L0T4780

C L0T4790

C LOT4800

DATA IRD (24 , 1 )

, IRD (24 , 2 ) ,IRD(24,3) ,IRD(24,4) ,IRD(24,5) , L0T4810

1 IRD(24,6)/ L0T4820

2 0, 0, 0, 0, 0, 0/ L0T4830

C LOT4840

C PAGE PLOT L0T4850

C L0T4860

DATA IRD (25 , 1 )

, IRD (25 , 2 )

, IRD (25 ,3) ,IRD(25,4) ,IRD(25,5) , L0T4870

1 IRD(25,6)/ L0T4880

2 11698, 3645,12003,14580,13, 6/ L0T4890

C LOT4900

C GAUSS QUADRATURE L0T4910

C L0T4920

DATA IRD(26,1) ,IRD(26,2) ,IRD(26,3) ,IRD(26,4) ,IRD(26,5) , LOT4930

1 IRD(26,6)/ L0T4940

2 5151,14364,12961, 3403,24, 4/ L0T4950

C LOT4960

C DUMMY E F UNIFOR RANDOM L0T4970

C L0T4980

DATA IRD(27,1) ,IRD(27,2) ,IRD(27,3) ,IRD(27,4) ,IRD(27,5) , L0T4990

1 IRD (27,6 ), IRD (28,1) , IRD (28,2) , IRD (28,3) , IRD (28,4) , IRD (28,5) , L0T5000

2 IRD (28, 6) , IRD (29,1) , IRD (29, 2) , IRD (29,3) , IRD (29,4) , IRD (29,5) , L0T5010

3 IRD(29,6)/ 3496,10152, 3645, 0,54, 6, 3496,10152, 4374, 0, L0T5015

4 54, 7,15696, 4797,13163, 3334,24,15/ L0T5020

C L0T5030

Q ********************** ********************* ****************** ******|^Q-|-£Q^Q

C * *L0T5050

C * USED THRU IRD(29,6): AVAILABLE IRD(30,1) THRU IRD(30,6) *L0T5060

C * *L0T5070

Q *******************************************************************^QJ(JQgQ

c   THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS LOT5090

C LOT5100

C READ TAPE ,CREAD TAPE, WRITE TAPE , SETTAPE ,CSET TAPE ,ENDFILE TAPE, L0T5110

C REWIND TAPE, SKIP TAPE , BACKSPACE TAPE L0T5120

C L0T5130

DATA ITP(1,1) ,ITP(1,2) ,ITP(1,3) ,ITP(1,4) ,ITP(2,1) , L0T5140

1 ITP(2,2) ,ITP(2,3) ,ITP(2,4) ,ITP(3,1) ,ITP(3,2) ,ITP(3,3) , L0T5150

2 ITP(3,4) ,ITP(4,1) ,ITP(4,2) ,ITP(4,3) ,ITP(4,4) ,ITP(5,1) , L0T5160

3 ITP(5,2) ,ITP(5,3) ,ITP(5,4) ,ITP(6,1) ,ITP(6,2) ,ITP(6,3) , L0T5170

4 ITP(6,4) ,ITP(7,1) ,ITP(7,2) ,ITP(7,3) ,ITP(7,4) ,ITP(8,1) , L0T5180

5 ITP(8,2) ,ITP(8,3) ,ITP(8,4) ,ITP(9,1) ,ITP(9,2) ,ITP(9,3) , LOT5190

6 ITP(9,4)/ LOT5200

7 13258, 2916,45,1, 2678, 837,46,1,17262,14715,47,1, LOT5210

8 14006, 0,48,1, 2705,14580,49,1, 4027, 4629,50,1, L0T5220

9 13280, 6943,50,2,14157,11664,50,3, 1488, 8548,50,4/ L0T5230

£** *********************************************************************I_qj5240

C L0T5250

q********************************************************************* * * LOT 5 260

q***********************************************************************I_qj^270

C ***** USED THRU ITP(9,4): AVAILABLE ITP(10,1) THRU ITP (10 ,4 ) ********L0T5280

£***********************************************************************LQj5290

Q***********************************************************************|_QJ^3QQ

END L0T5310

142
SUBROUTINE LOOKUP LOU 10

C VERSION 5.00 LOOKUP 5/15/70 LOU 20

C WRITTEN BY S PEAVY 3/14/68 LOU 30

COMMON /BLOCKE/ NAME (4 ), LI , L2 , I SRFLG LOU 40

COMMON /ICODE/ NIR,NID,NIRD,LIR,LIO,LIRD LOU 50

COMMON /CODE/ I ALPH (6 ), NALPH (5 ), ID (9 ,3 )

, IR (300 , 4 ) , IRD (30 , 6 ) LOU 60

C THE FOLLOWING CARDS ARE NEEDED ONLY FOR THE OPERATIONS LOU 70

COMMON /ICODTP/ NITP,LITP LOU 80

COMMON /CODETP/ ITP(10,4) LOU 90

COMMON /TAPE/ NAME4 (2) , NTPCT , IPUNCP , I NUN IP ( L1TP LOU 100

C THIS SUBROUTINE CHECKS TO SEE IF FIRST WORD AND SOMETIMES SECOND LOU 102

C WORD ON COMMAND CARD IS A LEGITIMATE COMMAND LOU 104

C IF COMMAND IS FOUND LI AND L2 ARE ASSIGNED A VALUE LOU 106

C IF COMMAND IS NOT FOUND IN THE DICTIONARY LI IS SET EQUAL TO ZERO LOU 108

q ************************************************************* LOU 110

L1=0 LOU 120

DO 10 1=1, NIR LOU 130

IF (NAME (1) . NE . IR ( I ,1) .OR .NAME (2 ) . NE . IR ( I , 2 ) ) GO TO 10 LOU 140

L1=IR(I,3) LOU 150

L2=IR (I ,4) LOU 160

C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS LOU 170

IF (NAME(l) .NE.IR(50,1) ) RETURN LOU 180

C NAME (3 )=TAP NAME (4 )=E LOU 190

IF (NAME(3) .EQ. 14623 .AND. NAME(4) .EQ. 3645) GO TO 40 LOU 200

C ************************************************************* LOU 210

RETURN LOU 220

10 CONTINUE LOU 230

DO 20 1=1, NID LOU 240

IF (NAME (1 ) .NE . ID ( I , 1 ) .OR . NAME (2 ) . NE . ID ( I , 2 )

) GO TO 20 LOU 250

L1=ID(I,3) LOU 260

GO TO 80 LOU 270

20 CONTINUE LOU 280

DO 30 I=1,NIRD LOU 290

IF (NAME(l) .NE. IRD (1,1) .OR. NAME (2) .NE . IRD (1 ,2) .OR. NAME (3) .NE. IRD (I LOU 300

1,3) .OR .NAME (4) .NE . IRD ( I ,4) ) GO TO 30 LOU 310

L1=IRD(I,5) LOU 320

L2=IRD(I,6) LOU 330

RETURN LOU 340

30 CONTINUE LOU 350

C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS LOU 360

40 DO 50 I=1,NITP LOU 370

IF (NAME (1 ) . NE . ITP ( I , 1 ) .OR .NAME (2 ) . NE . ITP ( I , 2 )

) GO TO 50 LOU 380

L1=ITP(I,3) LOU 390

L2=ITP(I,4) LOU 400

GO TO 60 LOU 410

50 CONTINUE LOU 420

RETURN LOU 430

60 IF (L1.GT.47) RETURN LOU 440

DO 70 1=1,6 LOU 450

IF (NAME4 (1 ) . NE . I ALPH ( I )) GO TO 70 LOU 460

L2=I+1 LOU 470

RETURN LOU 480

70 CONTINUE LOU 490

Q ********************************** ********************************|_Q(J 5 QQ

RETURN LOU 510

C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS LOU 520

80 IF (L1.NE.5) GO TO 90 LOU 530

C NAME (3 )=TAP NAME (4 )=E LOU 540

IF (NAME(3) .EQ. 14623. AND. NAME(4) .EQ. 3645) GO TO 40 LOU 550

143
c TMTf ^inn 111 * c r A A 11 1 THIS CARD YYA5 500 L2=l 1 All LOU 560

90 L2=l LOU 570

/»C **************************************************************** i nil LUU con 580

lr (Ll.tU..!) bU IU 11U 1 All LUU C A A 590

UU 1UU 1=1 ,

o

LUU /Aft 600

T C / M A MC / 3 \ KIT T A 1 D U / T \ \ I

s A Tfl 1 A A lr (NAMt (3 ) . Nt . lALrn ( 1 )

) bU IU 100 1 All LOU Z 1 A 610

L2=l+1 1 All LUU L *> A 620

DCTIIDU Kt 1 UKN 1 All LUU LI f\ 630

1 A A 100 nAMT T Ml IC LUN 1 1 nut 1 Al 1 LUU L A A 640

TC <\ ^ MC 0 \ DCTIIDM lr (Ll.Nt.2) Kt 1 UKN 1 Al 1 LUU 641

TC H 0 MC 1 \ DCTIIDM lr (L2.Nt.l) KtlUKN 1 All LUU L A 1 642

Tr / U A MC / Q \ MC 1 A £ 3 1 A M A. MA MC / A \ MC 1 L A ZL \ DCTIIDM lr (NAMt (3 ) . Nt . 1063 1 . AND . NAMt (4 ) . Nt . 3645 ) KtlUKN 1 All LUU LAI 643

0 tuc rnuuAun tc ddtmt matc 1 nt LUMMANU lb rKlNI NU 1

1

1 All LUU L A A 644

L 1=13 1 All LUU LAC 645

1 1 1 1 L2=13 1 All LUU L A L 646

Kt 1 UKN 1 All LUU L C A 650

1HO1 A UU 120 1=1

,

b

1 All LUU L L A 660

TC / hi A MC / O \ KIC II A 1 DU / T \ \ prt TA 1 1 A lr (NAMt (3 ) . Nt . NALrrl ( 1 ) ) liU IU 120 1 All LUU £ 7 A 670

1 1 T . 1 L2=l +2 1 All LUU /on 680

DCTIIDM Kt 1 UKN 1 All LUU L Q A 690

1 1 A 120 AAUT T Ml IC LUN 1 1 NUt 1 All LUU 7 A A 700

nrn mil RETURN LOU 710

END LOU 720

144
c

c

ccc

c

cc

c

c

cc

c

c

cc

c

SUBROUTINE MATRIX

VERSION 5.00 MATRIX 5/15/70

Cc

c

10

20

30

40

C

C

C

50

60

70

C

C

C

80

MAT 10

MAT 20

MAT 30

L2=l ADD MATRICES A+B MADD A( f ) N , M, TO B(,) N,M AND S ORE IN C (MAT 40

L2=2 SUB MATRICES A-B MSUB A(,) N ,M FROM B(,)N,M AND STORE IN C (MAT 60

L2=3 TRANSPOSE MATRIX MTRANS A(,) N,M AND STORE IN C(,) MAT 80

TRANSPOSE ARRAY ATRANS A(,) N,M AND STORE IN C(,) MAT 90

L2=4

L2=5

L2=6

L2=7

L2=8

ARRAY ADD

ARRAY SUBTRACT

ARRAY MULTIPLY

ARRAY DIVIDE

ARRAY RAISE

AADD

ASUB

AMULT

ADIV

ARAISE

GENERAL FORMS FOR ARRAY OPERATIONS

MAT 100

MAT 110

MAT 120

MAT 130

MAT 140

MAT 150

) N,K STORE IN C(,) ARRAY BY ARRAY MAT 160

) STORE IN C(,) ARRAY BY ARRAY MAT 170

STORE IN C(,) ARRAY BY COLUMN MAT 180

STORE IN C(,j ARRAY BY CONSTANT MAT 200

MAT 220

MAT 230

COMMON /BLOCKD/ IARGS (100 ), KIND ( 100 ) ,ARGTAB ( 100 ), NRMAX ,NROW, NCOL ,NMAT 240

A(

A(

A(

A( )

N , M B(

N,M B(

N,M K

N ,M X

COMMON /BLOCRC/ NRC ,RC (12600)

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS (1) ,RC (12501)

)

COMMON /SCRAT/ NS , NS2 , A (13500

)

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG

CHECK TO SEE IF WE HAVE CORRECT NUMBER OF ARGUMENTS

NP=NARGS

IF (L2-3) 10,20,30

IF (NARGS .NE .8 . AND .NARGS .NE .10) GO TO 40

GO TO 50

IF (NARGS. NE. 6) GO TO 40

GO TO 50

IF(NARGS.LT.7.0R.NARGS.GT.10.0R.NARGS.EQ.9) GO TO 40

GO TO 50

CALL ERROR (10)

RETURN

CHECK TO SEE IF ALL ARGUMENTS ARE INTEGERS

IF (L2 .GT .3 .AND .NARGS .EQ .7 ) GO TO 70

J=NARGS

CALL CKIND (J)

IF (J.EQ.O) GO TO 80

CALL ERROR (3)

GO TO 80

I SAVE=KIND (NARGS

)

KIND (NARGS )=KIND (NARGS-2

)

KIND (NARGS-2 )=KIND (NARGS-1

)

KIND(NARGS-1)=ISAVE

NARGS=NARGS-1

GO TO 60

CHECK TO SEE IF DIMENSIONS ARE CORRECT IF THEY ARE GIVEN

IF (NP.NE.10) GO TO 90

IF (IARGS (3) .EQ. IARGS (7) .AND .IARGS (4) .EQ . IARGS (8) ) GO TO 90

CALL ERROR (3)

MAT 250

MAT 260

MAT 270

MAT 280

MAT 290

MAT 300

MAT 310

MAT 320

MAT 330

MAT 340

MAT 350

MAT 360

MAT 370

MAT 380

MAT 390

MAT 400

MAT 410

MAT 415

MAT 420

MAT 430

MAT 440

MAT 450

MAT 460

MAT 470

MAT 480

MAT 490

MAT 500

MAT 510

MAT 520

MAT 530

MAT 540

MAT 550

MAT 560

MAT 570

MAT 580

MAT 590

MAT 600

MAT 610

MAT 620

145
DCTIIDM Kt 1 UKN MA \ be 5 c HAT L

n

A MA 1 630

t pucri/ T(l CCC TC ADPII MET M T C ADC LntUN 1U ot.t lr AKuUMtlM 1 i AKt UU 1 Ur RANGE MA T L A n MA 1 640

U MAT L

L

A MA 1 660

A A IF( (L2.LT.3 .0R.L2 .GT.3) .AND .KIND (NP) • u ) C C\ Tft 1 A A bU ! U 1UO MAT L 7 A MA 1 6 7 0

MAT /OA MA I 680

UU 1 U 1 j u MAT L A A MA 1 690

1 A A J=3 MAT 7 A

A

MA 1 700

IARGS(12)=IAR6S(4) MA T 7 0 A MA i 1 i\J

ion 1^0 IARGS(11)=IARGS(3) MAT 7 C A Mm 1 / 3 0

IF (NP.EQ.10) GO TO 210 MAT 7 Z. A MA I 760

IARGS(10)=IARGS(NP) MAT 7 7 A MA 1 7 7 0

IARGS(9)=IARGS(NP-1) MAT 70A MA 1 7 80

1 30 IF (NP.EQ.8.0R. (NP . EQ . 7 .AND .KIND (NP) NP n ^ i bU IU 190 MA T 7 Q A MA 1 / 9 0

IF(NP E0 6) GO TO 160 MA T 0 1 A MA 1 o 1

0

IARGS (6)=IARGS (5) MAT O L A MA 1 860

IARGS (8 )=1 MAT OTA MA 1 870

IARGS(7)=IARGS(3) MAT O O A MA 1 880

IARGS (5)=1 MAT O A

A

MA 1 890

GO TO 210 MAT AAA MA 1 900

loU IARGS(8)=IARGS(3) MAT A 1 A MA 1 910

IARGS(7)=IARGS(4) MAT Q o A MA 1 920

GO TO 210 MAT A 1 A MA 1 930

i on 190 IF (NP.EQ.8) GO TO 200 MATT AT A MA 11010

IARGS(5)=IARGS(6) MA T 1 A O A MA 1 1 0 d 0

IARGS(6)=IARGS(7) MA T 1 A 7 A MA I 1030

O A A zoo IARGS(8)=IARGS(4) MA T 1 A A A MA 11040

IARGS(7)=IARGS(3) MA T 1 A C A MA 1 1030

7 T A

2 10 CALL MTXCHK (J) MA T T A L A MA 1 1060

IF (J-l) 240,220,230 MA T 1 A 7 A MA 110/0

*5 0 A £20 CALL ERROR (3) MA T 1 A O A MA 1 1080

RETURN MA T 1 A A A MA 11090

1 7 A 230 CALL ERROR (17) MA T 1 T A A MA 11100

RETURN MA T 1 1 1 A MA 11110

K> * mat MA 1 i ion J. i c 0

CHECK TO SEE IF THERE WERE PREVIOUS ERRORS MA T 1 T 7 A MA 11130

L

* MA T 1 1 A A MA 11140

J 4 0 IF (NERR0R.NE.0) RETURN MAT 1 1 C A MA 1 1130

C MA Tl 1 tft MA 1 lloO

r*L SUM ELEMENTS IN SCRATCH AREA MATT 1 Tft MA 111/0

L SUBTRACT ELEMENTS IN SCRATCH AREA MA Tl 1 Oft MA 1 1 180

C PRODUCTS AND QUOTIENTS FORMED USING DOUBLE r KtU 1 o 1 UN IN CPDATPLI ADMAT11AA bUKAlUH AKMA 11190

c TRANSPOSE IN SCRATCH AREA MATT 1 A A MA 1 1200

C MAT 1 7 1 A MA 1 1110

IR0W=IARGS(3) MA Tl 91ft MA 1 lii\i

IC0L=IARGS(4) MAT MA 1 7 7 ft

1 Li

NR0WPP=NR0W MATT 7 Ah MA 1 1140

IF (L2-3) 260,250,290 MAT 1 7 C ft MA 1 1Z30

250 1 1 B= I COL MA Tl lift MA I l£O0

JJB=IR0W MAMATlI 1 nnc 1 0

NR0WPP=0 MAT MA 1 7 0ft 1 l£OU

K=l MAT 1 7 0ft MA 1 1 £ 9 0

GO TO 280 MAT 1 7 ft ft MA 1 13U0

260 NR0WP=NR0W MA T 1 7 1 ft MA 11310

IBP=IARGS(5) MAT1 1"if\ MA 1 13tU

270 IIB=IR0W MATT MAI 17ft 133U

JJB=IC0L MAT 1 7 A A MA 11340

K=0 MAT MA 1 7 C ft

1 1330

280 IS=1 MAT1360

146
290

300

310

320

C

330

340

350

360

365

370

380

390

400

410

415

420

430

440

450

460

470

480

490

500

510

I AP=I ARGS (1

)

GO TO 320

IF (NP.GE.8) GO TO 260

IF (KIND (NP ) .EQ.l) GO TO 300

IBP=IARGS(5)

GO TO 310

IARGS(9)=IARGS(5)

NROWP=0

GO TO 270

DO 510 J=1,JJB

COMPUTE ADDRESSES

IA=IAP+(J-1)*K

IB=IBP

DO 500 1=1, 1 IB

GO TO (330,340,370,380,390,400,410,420), L2

A(IS)=RC(IA)+RC(IB)

GO TO 470

A(IS)=RC(IA)-RC(IB)

GO TO 470

A(IS)=RC(IA)*RC(IB)

GO TO 470

IF(RC(IB) .EQ.O .0) GO TO 365

A(IS)=RC(IA) /RC(IB)

GO TO 470

A(IS)=0.0

GO TO 470

A(IS)=RC(IA)

IA=IA+NROW

GO TO 490

IF (NP.GE.8. OR. (KIND(NP) . EQ . 0 . AND . NP . LT . 8 ) ) GO TO 330

A(IS)=RC(IA)+ARGS(NP-2)

GO TO 480

IF (NP.GE.8. OR. (KIND (NP) . EQ . 0 . AND . NP . LT . 8 ) ) GO TO 340

A(IS)=RC(IA)-ARGS(NP-2)

GO TO 480

IF (NP.GE.8. OR. (KIND (NP ) . EQ . 0 . AND . NP . LT . 8 ) ) GO TO 350

A(IS)=RC(IA)*ARGS(NP-2)

GO TO 470

IF (NP.GE.8. OR. (NP.LT.8.AND.KIND(NP) .EQ.O) ) GO TO 360

IF(ARGS(NP-2) .EQ.O.O) GO TO 415

A(IS)=RC(IA) /ARGS(NP-2)

GO TO 470

A(IS)=0.0

GO TO 470

IF (NP.GE.8. OR. (NP.LT.S.AND.KIND(NP) .EQ.O) ) GO TO 440

IF (RC(IA)) 430,460,430

A(IS)=FEXP2 (RC(IA) ,ARGS(NP-2)

)

GO TO 470

IF (RC(IA)) 450,460,450

A(IS)=FEXP2(RC(IA) ,RC(IB)

)

GO TO 470

A(IS)=0.0

IB=IB+1

IA=IA+1

IS=IS+1

CONTINUE

IAP=IAP+NROWPP

IBP=IBP+NROWP

CONTINUE

MAT1370

MAT1380

MAT1390

MAT1400

MAT1410

MAT1420

MAT1430

MAT1440

MAT1450

MAT1460

MAT1465

MAT1470

MAT1480

MAT1490

MAT1500

MAT1510

MAT1520

MAT1530

MAT1540

MAT1550

MAT1560

MAT1562

MAT1564

MAT1566

MAT1570

MAT1580

MAT1590

MAT160Q

MAT1610

MAT1620

MAT1630

MAT1640

MAT1650

MAT1660

MAT1670

MAT1680

MAT1690

MAT1700

MAT1710

MAT1712

MAT 17 14

MAT1716

MAT1720

MAT1730

MAT1740

MAT1750

MAT1760

MAT1770

MAT1780

MAT1790

MAT1800

MAT1810

MAT1820

MAT1830

MAT1840

MAT1850

MAT1860

MAT1870

MAT1880

147
C * MAT1890

C MOVE SUMS TO WORKSHEET MAT1900

C MOVE DIFFERENCES TO WORKSHEET MAT1910

C MOVE ARRAY PRODUCT TO WORKSHEET MAT1920

C MOVE ARRAY QUOTIENT TO SORKSHEET MAT1930

C MOVE TRANSPOSE TO WORKSHEET MAT1940

C MOVE RAISED MATRIX TO WORKSHEET MAT1950

C * MAT1960

IF (L2.NE.3) GO TO 520 MAT1970

ICP=IARGS(5) MAT1980

GO TO 530 MAT1990

520 ICP=IARGS(9) MAT2000

530 IS=1 MAT2010

DO 550 J=1,JJB MAT2020

IC=ICP MAT2030

DO 540 1=1 , 1 IB MAT2040

RC(IC)=A(IS) MAT2050

IC=IC+1 MAT2060

IS=IS+1 MAT2070

540 CONTINUE MAT2080

ICP=ICP+NROW MAT2090

550 CONTINUE MAT2100

RETURN MAT2110

END MAT2120

148
c

c

cc

c

cc

c

c

c

cc

c

c

SUBROUTINE MOAMAD

VERSION 5.00 MDAMAD 5/15/70

SUBROUTINE MDAMAD

* R VARNER 9/26/67

C

c

c

c

c

c

cc

c

c

10

20

30

40

50

C

C

C

60

SUBROUTINE TO PRE OR POST MULTIPLY A MATRIX BY A DIAGONAL STORED

AS A COLUMN

L2=l M(AD)

MATRIX A IS POSTMULTIPLIED BY THE DIAGONAL D STORED IN COL I GENERAL FORM OF COMMAND

M(AD) A(,) N,K, D IN COL I STORE IN C( ( ) L2=2 M(AD)

MATRIX A IS PREMULTIPLIED BY THE DIAGONAL D STORED IN COL I GENERAL FORM OF COMMAND

M(DA) , A( ( ) N,K K IN COL I STORE IN C(,)

*COMMON /SCRAT/ NS , NS2 , A ( 13500

)

COMMON /BLOCRC/ NRC ,RC (12600)

COMMON /BLOCKD/ I ARGS ( 100 ) ,KIND ( 100 ), ARGTAB ( 100 ) ,NRMAX , NROW, NCOL

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS (1 ) ,RC (12501 )

)

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG

CHECK FOR CORRECT NUMBER OF ARGUMENTS

IF (NARGS.NE.7) CALL ERROR (10)

*CHECK TO SEE THAT ALL ARGUMENTS ARE INTEGERS

MDA

MDA

MDA

MDA

MDA

MDA

MDA

MDA

MDA

10

20

30

40

50

60

70

80

90

J=NARGS

CALL CKIND (J)

IF (J.NE.O) CALL ERROR (3)

CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE

COMPUTE ADDRESSES OF COLUMNS

IARGS(12)=IARGS(4)

IARGS(11)=IARGS(3)

IARGS(10)=IARGS(7)

IARGS(9)=IARGS(6)

IARGS(8)=1

GO TO (10,20) , L2

IARGS(7)=IARGS(4)

GO TO 30

IARGS(7)=IARGS(3)

IARGS(6)=IARGS(5)

IARGS(5)=1

J=3

CALL MTXCHK (J)

IF (J-l) 60,40,50

CALL ERROR (3)

RETURN

CALL ERROR (17)

RETURN

CHECK FOR PREVIOUS, ERRORS

IF (NERROR.NE.O) RETURN

IP=IARGS(4)

MDA 100

MDA 110

MDA 120

MDA 130

MDA 140

MDA 150

MDA 160

MDA 170

,NMDA 180

MDA 190

MDA 200

MDA 210

MDA 220

MDA 230

MDA 240

MDA 250

MDA 260

MDA 270

MDA 280

MDA 290

MDA 300

MDA 310

MDA 320

MDA 330

MDA 340

MDA 350

MDA 360

MDA 370

MDA 380

MDA 390

MDA 400

MDA 410

MDA 420

MDA 430

MDA 440

MDA 450

MDA 460

MDA 470

MDA 480

MDA 490

MDA 500

MDA 510

MDA 520

MDA 530

MDA 540

MDA 550

MDA 560

MDA 570

MDA 580

MDA 590

149
ID T ADPC / 1 \ Jr=lAKbb (i ) MAMUAA L A A 6UU

bU 1 U (80,70), LI urv a MUA L 1 A 610

70 11 A

1 1 =0 Un A MUA ion 620

1 2 = 1 unMUAa L "X A P A Trt OA bb1

1 U 90 Mlt MUAA L A (\ 640

80 T 1 1 1 1 = 1 MUA L C A 650

TO A Mn A OOU

Q A T A T ARTC / 1 \ 1 A=

1

AKuj ( 1 ) MUM a 7 n o / U

t no T hoc c/ci 1 Ur= 1 AKuo (D

)

un a MUA OoU

TD T A DP C / O \ Id=1 AKbb (7

)

un a MUA &7U

nn liA T 1 TD UU 110 1=1 , Ir MA A MUA 7 A A 700

ID TDD un a MUA 7 1 A

/ 10 nnUu i1UUfin i— i i d J = i , J r MnMUAA 7 O A DP / T Q \ DP / TH \ *DP M A 1 Kb (ID) =Kb ( 1 U ) Kb ( 1 A

)

MnMUAA 7 % t\ 1 3\J

t n T t\ . T 0

1 U= 1 U + l

£

MnMUAA 7 A A

T A T A , 1 1 A=l A+l Mn A MUA 7 C A 7 b0

T D T D . H

1 D=lD+l un a MUA 7 60

1 A A 1UU P AWT T Ml IE bUN 1 1 NUt unMUAa 7 7 A / / U YD T D i UD Alii 1 D 1 D=l D+NKU W—J r unMUAa 7 D A / oU

T A T A i MDAUf 1 D 1 A=1A+NKUW—Jr unMUAa 7 Q A / VU

T no T AD . T

1

1 Ur=l Ur + 1

1

un a MUA O A A oUU

110 P A MT T hi 1 1

C

bUN 1 1 Nut un a MUA Q 1 A olU

RETURN MDA 820

END MDA 830

150
SUBROUTINE MEIGEN ME I 10

C VERSION 5.00 MEIGEN 5/15/70 ME I 20

C SUBROUTINE MEIGEN WRITTEN BY R VARNER 4/4/68 ME I 30

C * ME I 40

C SUBROUTINE TO COMPUTE EIGENVALUES AND EIGENVECTORS ME I 50

C GENERAL FORMS OF COMMANDS ME I 60

C MEIGEN A(,,++) R= (( C=, , STORE VALUES IN COL ++ ME I 70

C MEIGEN A(,,++) R=,, C=, , STORE VECTORS IN B(,,++) ME I 80

C MEIGEN A(,,++) R=,, C=, , STORE VALUES IN COL ++ ME I 90

C STORE VECTORS IN B(,,++) ME I 100

C BOTH R AND C MUST BE SPECIFIED ME I 110

C NARGS= 5 COMPUTE ONLY EIGENVALUES ME I 120

C NARGS='6 COMPUTE ONLY EIGENVECTORS ME I 130

C NARGS= 7 COMPUTE EIGENVALUES AND VECTORS ME I 140

C * ME I 150

COMMON /BLOCRC/ NRC , RC ( 12600 ) ME I 160

COMMON /BLOCKD / IARGS ( 100 ), KIND ( 100 ) .ARGTAB ( 100 ), NRMAX , NROW,NCOL ,NMEI 170

1ARGS ,VWXYZ (8 ) ,NERROR ME I 180

DIMENSION ARGS(IOO) ME I 190

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 ) ) ME I 200

COMMON /SCRAT/ NS ( NS2 , A (13500 ) ME I 210

DIMENSION ISWCH(2) ME I 220

C * ME I 230

C CHECK TO BE SURE THAT MATRIX IS NO BIGGER THAN 54X54 ME I 240

C * ME I 250

IF (IARGS(3) .NE.IARGS(4) ) CALL ERROR (230) ME I 260

IF (IARGS(3)**2.GT.NS2) CALL ERROR (23) ME I 270

C * ME I 280

C CHECK FOR CORRECT NUMBER OF ARGUMENTS ME I 290

C * ME I 300

IF (NARGS . LT . 5 .OR .NARGS .GT . 7 ) CALL ERROR (10) ME I 310

C * ME I 320

C CHECK TO SEE IF ARGUMENTS ARE ALL INTEGERS ME I 330

C ME I 340

J=NARGS ME I 350

CALL CKIND (J) ME I 360

IF (J.NE.O) CALL ERROR (3) ME I 370

C * ME I 380

C CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE ME I 390

C COMPUTE ADDRESSES ME I 400

C * ME I 410

ISWCH(2)=NARGS-4 ME I 420

ISWCH(1)=0 ME I 430

IF (NARGS. EQ. 6) GO TO 10 ME I 440

IADD=1 ME I 450

CALL ADRESS (5, J) ME I 460

IF (J.LE.O) CALL ERROR (11) ME I 470

C * ME I 480

C J CONTAINS ADDRESS OF COLUMN ME I 490

C * ME I 500

IF (NARGS. EQ. 5) GO TO 20 ME I 510

IARGS(5)=IARGS(6) ME I 520

IARGS(6)=IARGS(7) ME I 530

10 IADD=2 ME I 540

IARGS(7)=IARGS(3) ME I 550

IARGS(8)=IARGS(4) ME I 560

GO TO 30 ME I 570

20 ISWCH (1 )=1 ME I 580

30 CALL MTXCHK (IADD) ME I 590

151
IF (1AUU-1) 60,40,50 IIC T ME I

/ A A 600

40 CALL ERROR (3

)

IIC T ME I

/ 1 A 610

DTTIIDM Rt 1 URN IIC T Mb I /OA 620

C A 50 CALL ERROR (17)

iir t Mbl /OA 630

DtTIIDkl RE I URN Mbl / A A 640

C

tier t ME I 650

c purri/ cad ooti/ t ni ic eoDADC CHECK FOR PREVlUUb ERRURb IIC T Mbl / / A 660

Ac

* IIC T Mbl L "T A 670

60 T C /MCDDAD MC f\\ DCTIIDU 1 r (NERRUR . NE . 0 ) KE 1 URN IIC T Mbl 680

TAD TADTC / C\

1 br=l ARbb ( D

)

Mbl 690

IG=IARGS(1) IIC T Mbl 1 A A 700

CALL HDIAG (RC ( IG ), I ARGS (3 ), ISWCH , A , RC ( J ), RC ( IGP ), NROW, A (3000 )

)

ne t ME I T 1 A 710

c

* IIC T ME1 T 1 A 7Z0

C RC(IG) IS LOCATION OF MATRIX TO BE DIAGONALIZED IIC T ME1 ^ O A 730

c IARG(3) GIVES SIZE OF MATRIX IIC T ME1 740

c ISWCH (1)=1 IF ONLY EIGENVALUES ARE TO BE COMPUTED IIC T ME1 T C A 750

c ISWCH (1)=0 COMPUTE EIGENVALUES AND EIGENVECTORS ne t ME I

-T / A 760

c ISWCH (2) = NARGS-4 AND IS USED FOR STORING RESULTS ne t ME1 770

ft A IS LOCATION OF SCRATCH AREA ME 1 ton 780

C RC(J) TELLS WHERE TO STORE EIGENVALUES Me t ME 1 7QA 790

c RC(IGP) IS WHERE EIGENVECTORS ARE STORED lie t ME I AAA 800

c

lie t ME1 A 1 A 810

RETURN ME I 820

END ME I 830

152
SUBROUTINE MISC2 MIS 10

c VERSION 5.00 MISC2 5/15/70 MIS 20

COMMON /BLOCRC/ NRC , RC ( 12600

)

MIS 30

COMMON /BLOCKD / IARGS(IOO) ,KIN0(100) ,ARGTAB(100) , NRMAX ,NROW,NCOL , NMIS 40

1ARGS ( VWXYZ(8) ,NERROR MIS 50

DIMENSION ARGS(IOO) MIS 60

EQUIVALENCE (ARGS (1) ,RC (12501)

)

MIS 70

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG MIS 80

COMMON /SCRAT/ NS ,NS2 , A (13500

)

MIS 90

c SUBROUTINE BY CARLA MESSINA NSRDS - NBS JULY 1967 MIS 100

c MIS 110

c L2=4 IS EXPAND $$ TO ,, POWER IN INTERVALS OF START STORE +MIS 120

c THE POWERS MAY BE INTEGER OR NOT MIS 130

c L2=l IS CLOSE UP ROWS HAVING ** IN ++,++, ETC MIS 140

c L2=2 IS COUNT LENGTH OF COLUMN ++, STORE IN COLUMN ++ MIS 150

c L2=3 IS SHORTEN COL ++ FOR COL ++ == ** STORE IN COL ++ AND COLMIS 160

c L2=5 IS DUPLICATE , , TIMES THE ARRAY IN , , ++ R= (f C=, , START MIS 170

c STORING IN ,, ++ MIS 180

c MIS 190

IF (NARGS-2) 10,40,40 MIS 200

10 K=10 MIS 210

20 CALL ERROR (K) MIS 220

30 RETURN MIS 230

40 GO TO (50,80,50,340,540) , L2 MIS 240

50 IF (KIND (L2 ) ) 60,60,70 MIS 250

60 K=3 MIS 260

GO TO 20 MIS 270

70 KIND(L2)=0 MIS 280

ARG1=ARGS(L2) MIS 290

IARGS(L2)=IARGS(L2+1) MIS 300

80 CALL CHKCOL (J) MIS 310

IF (J) 60,90,60 MIS 320

90 DO 100 I=1,NARGS MIS 330

100 IARGS(I)=IARGS(I)-1 MIS 340

IF (L2-2) 120,120,110 MIS 350

110 IF (NARGS-5 ) 10,120,10 MIS 360

120 IF (NERROR.NE.O) GO TO 30 MIS 370

IF (NRMAX) 130,130,140 MIS 380

130 K=9 MIS 390

GO TO 20 MIS 400

140 IF (L2-2) 150,210,250 MIS 410

C CLOSE UP MIS 420

150 DO 200 J=2,NARGS MIS 430

K=IARGS(J) MIS 440

M=l MIS 450

DO 170 1=1, NRMAX MIS 460

J1=K+I MIS 470

IF (RC(Jl)-ARGl) 160,170,160 MIS 480

160 Kl=K+M MIS 490

RC(K1)=RC(J1) MIS 500

M=M+1 MIS 510

170 CONTINUE MIS 520

IF (M-NRMAX) 180,180,200 MIS 530

180 DO 190 I=M, NRMAX MIS 540

J1=K+I MIS 550

190 RC(J1)=0.0 MIS 560

200 CONTINUE MIS 570

GO TO 30 MIS 580

C COUNT MIS 590

153
210 1 i M

n l|

AV

J 1=NKMAX MIS 600 1 TAOPC/1\ . MD MA V

J=lAKbb(l)+NKMAX IIT

C / 1 A MIS 610

AA 13AT 1 KIDMAY UU Z3U 1=1,NKMAA

£JTC / a

a

Wllb 620

T

r / D

P / 1 \\ OAAOOA 0 VIA IF (KL(J)) Z4U,ZZU,Z4UAJTCZOA Mlb 630

OOA 220

J 1=J 1-1 11

TCZAA MIS 640

OOA 230 J=J -1 IIT

A / r r\ MIS 650

AA f\ 240 AKb 1=J 1AlTCLL t\ Mlb 660

TADPC/0\ lAKbb(Z)=lAKbb(Z)+l TADPC/0\ 1 A

JTC / 7 A Mlb 670

nil 1 WCPTAD / A DP 1 TADPC/*5\\ LALL VtLlUK ( AKbl , 1 AKbb (Z ) )

AITC /OA Mlb 680

bU IU 30 Al

TC / A

A Mlb 690

aCCUADTCM bHUK 1 tN AiTC 7 AA Mlb 700

OCA 250TC / II 0 11AV ft\ OA ftZA ftZA lr (NKMAX-Z) 30,260,260 AIT

C 7 1 A Mlb 710

O £.A ZoU AA ion

V "> MDMAV UU ZVU l\=Z , NKMAX A4

TC 7*)n Mlb 720

11TA DPC / O\ .V

J 1=1 AKbb (Z AIT

C 7 OA Mlb 730

TC / A DP 1 DP / 11 1\\ 1 7 AOAA lOA 1 F (AKbl-KL (J 1-1 ) ) 270,300,280 AfTC 7/in Mlb 740

ft 7 A 270

TC / ADA 1 DA/M

\

\ AAA OTA OTA 1 F (AKbl-KL (J 1 ) ) 290,310,310 I J

T

A 7 C

A Mlb 750 1 O A 280 T C / A Q A 1 QO / 1 1 \ \ OTA OTA AAA IF (ARG1-RC ( J 1 ) ) 310,310,290 MIS 760

zvo

PA AlTT Al 1 1 C

LUN 1 INUb Al

TC 7 7 A Mlb 770

K=Z 03 AIT

C 7 AA Mlb 780

PA 0 1 CDDAD / 1/\ LALL tKKUK (K) AITC 7 AA Mlb 790

AAXAOAA bu IU 320 11TC AAA MIS 800

300 AIDUAV

V 1 NKMAX=K-1 KITCO 1 A Mlb 810

PATA "2 1 A bU 1 U 3Z0 KITCOOA Mlb 820

310 AIDUAV

y NKMAX=K IITC ft

o

A Mlb 830

3ZU 1 7 A UU 33U 1=1,NKMAA MT

C QJIA Mlb 84U

VT ADPC / 1 \T K=l AKbb ( 1 ) +1 MTC oca Mlb 850 1 TADPC//IN T J=l AKbb (4 ) +1 MT C din Mlb 860

It

TA DPC / C\ iT M=l AKbb ( 5 ) +1 MTCO 7 A Mlb 8 / U

1/1 M=lTA DPC / O\ . T AKbb ( Z ) +1 mt

c son Mlb 880

DP / U\ DP / V 1 \

KL (M)=KL (M ) MTMl

QO Dan 07U

330 DP / 1 \ nA/ui RC (J )=RC (K) 14

TC AAA Mlb 900

AATA OA GO TO 30 IITC ft i ft Mlb 910

pL tXPANU

MTC ft

o

a Mlb 9Z0

340 Tr /AIADPC /I

\ 1A ttCA 1A IF (NAKbb-4) 10,350,10 MTCO 1 A Mlb V30 1 C A 350 PAI 1 AADCCC IA 1/1 \ LALL AUKtbb (4,M) MT C Q A n

Mlb 740

TC / 1/ 1 \ Z.A Z.A 1 LA IF (M ) 60,60,360 MT

C OCA Mlb 7O0

OA 360 TC /l/TAIA/1\\ Jl

AAO 7 A yiAA IF (KlNU(l)) 400,370,400 MT

caLA Mlb 760

3/0 PAII

AnDCCC / 1 TADPC/1\\ LALL AUKtbb ( 1 , 1 AKbb ( 1 ) ) MTCQ 7 A Ml b 7 / U TC /TADPC/1\\ Z A Z A 1 Q F\ IF (lAKbb(l)) 60,60,380 MT C Q o A Mlb V80

OAA 380 1/

TA DPC / *l\ 1 K=IARGS (1 )-l MTC AAA Mlb 990

f\AoAAT 1 AIDUAV DO 390 1=1 ,NKMAX 111

r 1 AAA Ml blOOO 1 1/ . T J=K + I MT C 1 A 1 A MlblUlU

390

4 / T\nA / D\

A ( I )=RC (J )

AdTC 1 A 1 A Ml blOZO

AATA4OA GO TO 420

MTC 1 ftld Mlb 1030

AAA 400 nn i i n

T 1 MDMAV UU 410 1 = 1 , N K MAA MT Q1 AAA. Ml JlUtU

410 A/T\

ADPC / 1 \

A ( 1 ) =AKbb ( 1 )

MTMlblUSU C 1 A C A

A

AA 420 TC /|/TUA/ft\\

AA f\A 1l\AAA IF (K1NU(Z)) 44U,430,44U MT AAA

A 1 A 430A flP / ftv TAOPC/ftl ARGS (2 )=IARGS (2 )

MTC 1 A 7 A MlblU/U

4AA 440 IP (KIND (3) ) 460,450,460 MT

C 1 AftA Ml JlUOU

450

ADAC / O\ TADrC / O\ ARGS (3 )=I ARGS (3 )

miMT oiuyu ci nan

460 TC /ADAC/0\#ADAC/0\\ il 7 A jl 7 A ilOA IF (ARGS (2 ) 'ARGS (3 ) ) 470,470,480 mtMl ci51 i nn 1 UU

470 K=20 MT

C 1 1 i n Ml blilU

AATA OA GO TO 20 mtMl ciJ 1 i

J. onC U 480 TC /AOC/ADAC"/0\\ ADC/ADAC/0\\\ A A A AAA il*7A IF (ABS (ARGS (3 ) )-ABS (ARGS (2 ) ) ) 490,490,470 MT C 1 1 1 A Ml j 1 1 3 U

490 1 r / urnnAn 11 r*

avaa ta oa IF (NERR0R . NE . 0 ) GO 10 30 MTM15114U C 1 1 A A TC / kl D hi A V \ I^A 1 in CAA I r (NKMAX ) 130,130,500 MT Ci 1 C A

ml j 11

DU 500 AA A A A A / o \ CC=ARGS(3) MT C 1 1 L A Mlbll6U

510 AA ron

T 1 IIA II 1 \J 00 520 1=1 , NRMAX MT

C 1 1 7 A Ml bl 1 1 U K=K1-1+I MIS1180

154
520 RC(K)=FEXP2(A(I) ,CC) MIS1190

IF (ABS(CC)+.5E-6-ABS(ARGS(2) ) ) 530,30,30 MIS1200

530 CC=CC+ARGS(3) MIS1210

IARGS(4)=IARGS(4)+1 MIS1220

CALL ADRESS (4,K1) MIS1230

IF (Kl) 60,60,510 MIS1240

C DUPLICATE MIS1250

540 IF (NARGS.NE.7) GO TO 10 MIS1260

IF (IARGS(l) .LE.O) GO TO 60 MIS1270

K1=MAX0(IARGS(1)*IARGS(4)+IARGS(6)-1,NRMAX) MIS1280

IF (Kl.GT.NROW) GO TO 590 MIS1290

J=7 MIS1300

CALL CKIND (J) MIS1310

IF (J.NE.O) GO TO 60 MIS1320

NARGS=6 MIS1330

NDUP=IARGS(1) MIS1340

IARGS(61)=IARGS(6) MIS1350

IARGS(62)=IARGS(7) MIS1360

IARGS(63)=IARGS(4) MIS1370

IARGS(64)=IARGS(5) MIS1380

IARGS(65)=IARGS(6) MIS1390

IARGS(66)=IARGS(7) MIS1400

DO 550 1=1,6 MIS1410

550 IARGS(I)=IARGS(I+1) MIS1420

CALL MOVE MIS1430

IF (NDUP.EQ.l) GO TO 580 MIS1440

DO 570 I=2,NDUP MIS1450

DO 560 J=l,6 MIS1460

560 IARGS(J)=IARGS(J+60) MIS1470

IARGS(5)=IARGS(65)+(I-1)*IARGS(63) MIS1480

570 CALL MOVE MIS1490

580 NRMAX=K1 MIS1500

GO TO 30 MIS1510

590 K=16 MIS1520

GO TO 20 MIS1530

END MIS1540

155
SUBROUTINE MIST (M, B , LCHK ,NLA , IND

)

MST 10

c VERSION 5.00 MIST 5/15/70 MST 20

DIMENSION B(l) , NBC(12) MST 30

COMMON /BLOCKD/ IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX ,NROW,NCOL , NMST 40

1AR6S ,VWXYZ (8 ) ,NERR0R MST 50

a a i/\ ti (iie- 4 in m i ii A o t n m / a a v t t i jTM y j> a * * i a ii tt t n n t i i t tin i at t n i i a a i COMMON /HEADER/ N0CARD (80 )

, ITLE (60 , 6 )

, LNCNT , IPRINT , NPAGE , IPUNCH MST 60

nil ii a MM=M-2 MST 70

NN=NRMAX-3 IIA T MST 80

NC=10 MST 90

M1=(M-1) /NC+1 MST 100

NLU=56 MST 110

tin i /\ NCA=0 MST 120 nn i a NRA=0 IIA T MST 130

i\ a i a a i/rii i mi DO 120 KEN=1 , Ml IIA T MST 140

ftlAH IIT kl A / 11 A 11 IIA 1 V NCP=MIN0 (NC , M-NCA) IIA T MST 150

NRP=M-LCHK*NCA IIA T MST 160

ii i r» t kin i ^ \ i&inn r- NLP=(l+IND/7)*NRP+5 IIA X MST 170

T r~ /LI in IT l|i IB Al 1 A \ A A T A i A IF (NLP .LT .NLU-NLA) GO TO 10 IIA X MST 180

a i i i n»rr / a \ CALL PAGE (4)

IIA X MST 190

in I r\ NLA=0 AAA T MST 200

10 r\ A a a TV/A 1 || An DO 20 IYA=1,NCP IIA X MST 210

T 1 MA A TV/A

I 1=NCA+I YA IIA X MST 220

20 AO OA / TV/A \ /TAAjAA/Ti -o \ i v iiinAltl . NBC ( I YA)= ( IARGS ( I 1+1 ) -1 ) /NR0W+1 IIA X MST 230

A A T A / *> A * A f a t t\ •» a a A A A » t im GO TO (30,40,50,60,70,80,90), IND IIA T MST 240

30 iiin ITT /TAATAIT 1 "» A \ WRITE (IPRINT, 130) IIA T MST 250

AA XA 1 A

A

GO TO 100 IIA TT MST 260

40 Ikin T X A /TAATAIT 1 4 A \ WRITE (IPRINT, 140) IIA T MST 270

A A X A 1 A A GO TO 100 IIA T MST 280

50 Ikin T T r /THAT JIT y f /\ \ |||| WRITE (IPRINT, 150) MM IIA T MST 290

A A T A l A A GO TO 100 AAA T MST 300

60 in a t x r~ / t nn t iit i / a \ WRITE (IPRINT, 160) IIA T MST 310

AA T A T AA GO TO 100 MST 320

70 inn t tt / t nn t iit i t a \ WRITE (IPRINT, 170) AAA T MST 330

A A X A i a a GO TO 100 AAA T MST 340

80 T . /TAAAA/AIAA *»v 1 \ 1 kl H A III 1 11= (IARGS (NRA+3)-l) /NR0W+1 AAA X MST 350

T A IIA A dell A I2=NCA*M+2 AAA X MST 360

mn t t i- . t r\ n t i t • h. * ^ nil n * v a * t ^ 1 1 n a / «i » WRITE (IPRINT, 180) NN ,B ( 1 2 ) , 1 1 ,NBC (1

)

IIA X MST 370

^\ *\ <AW ^\ A A A GO TO 100 IIA X MST 380

90 WRITE (IPRINT, 190)

IIA X MST 390

100

l|FN x T A / T f> n T 11 T a A A i /linA/Tt T 1 II A A \ WRITE (IPRINT, 200) (NBC (I )

, 1=1 ,NCP) AAA X MST 400

mn t t ^ * v n n t 1 1 a « a % WRITE (IPRINT, 210)

AAA X MST 410

A A a, TM A IQI A A a || K A\ DO 110 NAGA=1,NRP IIA X MST 420

1 1 a 1 1 *>* i hi a i NBR=NRA+NAGA IIA X MST 430

* ft A 1 4 1 A ft Il=NCA*M+NBR IIA X MST 440

v jk * a |i yA n. 1 1 1 a a a a j iJr , 11 A FN III A It* « i 4> |J I2=I1+(NCP-MAX0 (0 ,LCHK* (NCP-NAGA) )-l)*M IIA X MST 450

1 1 f»i £ • 1 A /** d || fAfc |A. 4 k h J 1 1 A A III * NBR=(IARGS (NBR+1)-1) /NR0W+1 IIA X MST 460

mn t v «~ . * n n t i n v a >b a v unn > n / t \ t t h t a il\ WRITE (IPRINT, 220) ,NBR , (B ( I )

, 1=1 1 , 12 , M)

AAA X MST 470

t r , * ii a ii it m . a a t a « *a a IF (IND.NE.7) GO TO 110 AAA X MST 480

I1=I1+2*M*M AAA X MST 490

V AA • ft A "A* A A *|* A A I2=I2+2*M*M AAA X MST 500

WRITE (IPRINT, 230) (B ( I )

, 1=1 1 , 12 ,M)

AAA X MST 510

WRITE (IPRINT, 210) MST 520

110 CONTINUE MST 530

im a im a kii n NLA=NLA+NLP 540

NRA=NRA+LCHK*NCP MST 550

120 NCA=NCA+NCP MST 560

RETURN MST 570

C MST con 3 0 U 130 FORMAT (/1H ,44X,31HSIMPLE CORRELATION COEFFICIENTS) MST 590

156
140 FORMAT (/1H , 22X , 75HSIGNIFICANCE LEVELS OF SIMPLE CORRELATION COEFMST 600

1FICIENTS (ASSUMING NORMALITY)) MST 610

150 FORMAT (/1H , 25X , 37HPARTI AL CORRELATION COEFFICIENTS WITH,I3,26H RMST 620

1EMAINING VARIABLES FIXED) MST 630

160 FORMAT (/1H , 22X , 76HSIGNIFICANCE LEVELS OF PARTIAL CORRELATION COEMST 640

1FFICIENTS (ASSUMING NORMALITY)) MST 650

170 FORMAT (/1H , 30X , 58HSPEARMAN RANK CORRELATION COEFFICIENTS (ADJUSTMST 660

1ED FOR TIES)) MST 670

180 FORMAT (/1H ,8X,79HSIGNIFICANCE LEVEL OF QUADRATIC FIT OVER LINEARMST 680

1 FIT BASED ON F RATIO WITH 1 AND,I5,19H DEGREES OF FREED0M/1H ,7X,MST 690

213H(F0R EXAMPLE, F7.4,60H IS THE SIGNIFICANCE LEVEL OF THE QUADRATIMST 700

3C TERM WHEN COLUMN , 13 , 20H IS FITTED TO COLUMN , 13 , 1H ) ) MST 710

190 FORMAT (/1H , 17X , 86HC0NFIDENCE INTERVALS FOR SIMPLE CORRELATION COMST 720

1EFFICIENTS (USING FISHER TRANSFORMATION) /30X ,68H95 PER CENT LIMITSMST 730

2 BELOW DIAGONAL, 99 PER CENT LIMITS ABOVE DIAGONAL) MST 740

200 FORMAT (/1H , 6HC0LUMN , 101 11 ) MST 750

210 FORMAT (1H ) MST 760

220 FORMAT (1H , 14 ,4X , 10F11 .4) MST 770

230 FORMAT (1H ,6X,10F11.4) MST 780

END MST 790

409-118 OL - 71 - 11

157
CIIDDnilTTMP Ml/ DHM Ml/ D 1 A 10

L WCDCIflN C (Id Ml/ 13 ft N c n c / in D / 13 / /

U

MV 0 Kir.K 0 A p

t

DDI IT T KIP U/DTTTPM FflD ftMMTTAR KUU 1 1 NL WK i 1 1 LIM r UK UIVIN J. 1 AD 11/ 3

j

0

/

RV C D T o r LA V T Ml^ 0 IVIISK % A

L

A A 4U

L KRONECKER PRODUCT OF TWO MATRICES A (N IVIM< C A 30

C

Ml/ D L ft 60

ftr<;t four argiimfnt^ nFFTNF MATRIX A STARTING POS ANU AMD C T 7C IVllvK 7 A / 0

NEXT FOUR ARGUMENTS DEFINE MATRIX B STARTING POS AND SIZE IVllsrv Q A

Li LAST TWO ARGUMENTS INDICATE WHERE RESULT IS TO BE STORED D MVP OA

COMMAND IS: WINK 1

i nnu u

r>L MKRON A(, , ++) ,R=, , C=, ,*B(, , ++),R=, , c= STORE D(, , ++) Ml/ D 1 1 A 110

c Ml/D |V1M\ 1 0 A i £ U

l» Nll\l\ 1 A 1 J U COMMON /BLOCRC/ NRC , RC ( 12600

)

MKR 114U4 A COMMON /BLOCKD / IARGS(IOO) ,KIND(100) ,AR6TAB(100) ,NRMAX ,NR0W,NC0L ,NMKR i tin 1ARGS,VWXYZ(8) ,NERR0R MKR 1 AA 10U

DIMENSION ARGS(IOO) MKR 1 7 A 1 / U EQUIVALENCE (ARGS ( 1 ), RC (12501 )

)

MKR i ftn COMMON /SCRAT/ NS ,NS2 , A (13500) MKR 11 OA7U

IF (NARGS NE 10) CALL ERROR (101 MKR

J=NARGS MKR 0 1 A £ IU

CALL CKIND (Jl MKR 0 0 A IF (J NE 0) CALL ERROR (3) MKR 9 1 A IF (NERROR NE 0 1 RETURN MKR

I ARGS ( 11 ^,-IARGS (3 1 * I ARGS (7) MKR LjU

I ARGS ( 12 1 -I ARGS (41 * I ARGS (8 ) MKR 9£00A A J-3 MKR 0 7 A c 1 U CALL MTXCHK (Jl MKR 4 OU

IF (J EQ 01 GO TO 10 MKR ion £7U

CALL UnLL ERROR Ll\l\ul\ (171 \ * ) MKR ^<in

RETURN MKR

1 A 10 NRA-TARGS (1 1 MKR 9 A J c u NCA— T ARG<\ (4 \ MKR

NRR— T ARG<s ( 7 \ MKR

NCR— T ARC^ 1 ft

MKR •a c n kinc i NUO=l MKR ^ AD

KA=1 AKuo ( 1

)

MKR ^ 7n

UU 40 1 l/A=l , NLA MKR

1 A— T ARC*; ( 5

1

Ln— XMIxU J \D J MKR J 7 u DO 30 ICB=1,NCB ltil\r\ Ann HUU

K=KA itii\i\ ai1 1 nu DO 20 IRA=1 ,NRA MKR 4?n

T=RC(K) MKR A^n

K=K+1 MKR AAn

L=LA MKR dsn

DO 20 IRB=1 , NRB MKR AAn

A(NDS)=T*RC(L) MKR A7n HIM

L=L+1 MKR *T O U 20 NDS=NDS+1 MKR 490

30 LA=LA+NR0W MKR 500

40 KA=KA+NR0W MKR 510

NCR=IARGS(11) MKR -> £ w NCC=IARGS(12) MKR j J u NDS=1 MKR

KA=IARGS(9) MKR R^n

DO 60 I=1,NCC MKR

K=KA MKR JIM

DO 50 J=1,NCR MKR 580

RC(K)=A(NDS) MKR 590

158
NDS=NDS+1

50 K=K+1

60 KA=KA+NR0W

RETURN

END

MKR 600

MKR 610

MKR 620

MKR 630

MKR b40

159
c

c

cc

cc

c

c

c

c10

c

c

c

c

c

c20

c

c

c

c70

80

100

110

120

c

c

c130

C

C

SUBROUTINE MMULT

VERSION 5.00

SUBROUTINE MMULT

*

MMULT

10/ 4/67

5/15/70

SUBROUTINE TO MULTIPLY MATRICES

GENERAL FORMS OF MMULT

MMULT A(,) N,K, BY B( ( ) K,M AND STORE IN C(,)

MMU

MMU

MMU

MMU

MMU

MMU

MMU

10

20

30

40

50

60

70

CHECK TO SEE IF WE HAVE CORRECT NUMBER OF ARGUMENTS

*IF(NARGS.NE.IO) CALL ERROR(IO)

*CHECK TO SEE

* IF ALL ARGUMENTS ARE INTEGERS

J=NARGS

CALL CKIND (J)

IF (J.EQ.O) GO TO

CALL ERROR (3)

20

CHECK TO SEE IF DIMENSIONS ARE CORRECT

* MMU 110

COMMON /SCRAT/ NS ,NS2 ,A (13500 ) MMU 120

COMMON /BLOCRC/ NRC , RC ( 12600 ) MMU 130

COMMON /BLOCKD / I ARGS ( 100 )

, KIND ( 100 )

, ARGTAB ( 100 ), NRMAX , NROW, NCOL , NMMU 140

1ARGS ,VWXYZ (8) ,NERROR MMU 150

DIMENSION ARGS(IOO) MMU 160

EQUIVALENCE (ARGS (1) ,RC (12501) ) MMU 170

DOUBLE PRECISION X,SUM MMU 180

DIMENSION X(l) MMU 190

EQUIVALENCE (X,A) MMU 200

* MMU 210

MMU 220

MMU 230

MMU 240

MMU 250

MMU 260

MMU 270

MMU 280

MMU 290

MMU 300

MMU 310

MMU 320

MMU 330

MMU 340

MMU 380

MMU 420

MMU 430

MMU 440

MMU 450

MMU 490

MMU 500

MMU 630

MMU 640

MMU 650

MMU 660

MMU 670

MMU 680

MMU 690

MMU 700

MMU 710

MMU 720

MMU 730

MMU 740

MMU 750

MMU 760

MMU 770

MMU 780

MMU 790

MMU 800

MMU 810

MMU 820

MMU 830

IF(IARGS(4) .NE.IARGS(7) ) CALL ERROR (26)

*CHECK TO SEE IF ARGUMENTS ARE OUT OF RANGE

FIND COLUMN ADDRESSES

*IARGS(12)=IARGS(NARGS-2)

IARGS(ll)=IARGS(3j

J=3

CALL MTXCHK (J)

IF (J-l) 130,110,120

CALL ERROR (3)

RETURN

CALL ERROR (17)

RETURN

CHECK FOR PREVIOUS ERRORS

*

IF (NERROR.NE.O) RETURN

IR0WA=IARGS(3)

IC0LA=IARGS(4)

IC0LB=IARGS(8)

BEGIN MULTIPLICATION

ISP=1

IBP=IARGS(5)

DO 160 ICB=1,IC0LB

IAP=IARGS(1)

DO 150 IRA=1,IR0WA

160
IS=NS2 MMU 840

I A=I AP Illll 1 rt r A MMU 850

I B=I BP lift 11 1 O L A MMU 860

DO 140 J=1,IC0LA ftlftll 1 n t A MMU 870

X(IS)=RC(IA)*RC(IB) ftlftll 1 AAA MMU 880

I S= I S-l IAA1I 1 AAA MMU 890

T A T A |i n A III I A=IA+NR0W ftlftll 1 AAA MMU 900

IB=IB+1 ftlftll 1 ATA MMU 910

140 t\ AlIT T III ir CONTINUE ftlftll 1 AAA MMU 920

C

* ftlftll 1 A 'i A MMU 930

Ac

p A 1 1 DAIITf UC TA frtDT A D A Rl 1 A T C A 11 A C 1 1 ftl CALL ROUTINE TO SORT PRODUCTS AND SUM ftlftll 1 AAA MMU 940

c

Illll 1 A F A MMU 950

A 1 1 CADTCftl / TArtl A Cllftlx CALL SORTSM (IC0LA,5UM) ftlftll 1 A L A MMU 960

A / t cn \ C 1 1 ftl A ( ISP)=SUM ftlftll 1 A "7 A MMU 970

I SP=I SP+l ftlftll 1 AAA MMU 980

150 tap* tin i I AP=I AP+1 All 11 1 AAA MMU 990

160 t nn t nn kin aiii IBP=IBP+NR0W ftlftll 11 AAA MMU 1000

ac

4= ftlftll 1 t A 1 A MMU 1010

c CTAOC 1 i A T D T V DDAIMI^T 51 URt MA I R IX PRODUL

1

ftlftll 1 1 A A A MMU 1 0 Z 0 c

* ftlftll 1 1 A O A MMU 1030

T C 1 1 5=1 lllll 1 T A A A MMU1040

T A T A A A C / A \ IC=IAR65 (9

)

ftlftll IT a r A MMU 1050

A A "1 O A 1 1 T A A 1 D uv 180 J=i , ILULb ftlftll 1 1 A L A MMU 1060

nn i ^ A T 1 T D Alii A DO 170 1=1 , IROWA ftlftll MMUn1070 mn

D A / T A \ A / T C \ RL (1L)=A (15)

Alftll 1 1 A A A MMU 1080

T C TC 1 15=15+1 ftlftll 1 1 A A A MMU1090

T A T A 1 IC=IC+1 ftlftll 1 1 1 A A MMU 1100

1 ^ A 170 A A ft.1 T T fcl II C CONTINUE ftiftii n t i a MMU 1110

180 T A T A im/\ III T n A III A IC=IC+NR0W-IR0WA A AA Al 1 4 n A A MMU 1120

RETURN MMU1130

END MMU 1140

161
SUBROUTINE MOP MOP

c VERSION 5.00 MOP 5/15/70 MOP

c SUBROUTINE TO DO MDEFINE , ADEFINE , MZERO , AZERO , MERASE , AERASE , MIDENT MOP

c S. PEAVY FOR OMNITAB 1108 4/2/68 MOP

c COMMANDS ARE AS FOLLOWS MOP

c MOP

c MDEFINE MATRIX IN R , C SIZE N X M TO EQUAL K MOP

c

i f\rr t nr a r% r% a w t&i ADEFINE ARRAY IN R , C SIZE N X M TO EQUAL K MOP

c MZERO MATRIX IN R , C SIZE N X M MOP

c AZERO ARRAY IN IT* R

r\ <"* T T rTM ft 1

, C SIZE N X M MOP

c MERASE MATRIX IN R , C SIZE N X M MOP

c AERASE ARRAY IN R , C SIZE N X M MOP

c MIDENT MATRIX IN R , C SIZE N X N MOP

c MDIAGO MATRIX IN R , C SIZE N X

a a r A 1 1 a l Tp* A IT" A ft 1 n T 1 A All I 1 M EQUAL TO E ON DIAGONAL MOP

c MOP

c L2=l MDEFINE .ADEFINE MOP

c L2=2 MZERO, AZERO, MERASE, AERASE MOP

c L2=3 MIDENT MOP

c L2=4 MDIAGONAL MOP

c MOP

10

20

30

40

50

10

20

30

40

50

60

70

80

90

COMMON /BLOCRC/ NRC , RC ( 12600

)

MOP 340

COMMON /BLOCKD/ IARGS (100) ,KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NM0P 350

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS (1) ,RC (12501)

)

COMMON /SCRAT/ NS ,NS2 , A (13500)

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , ISRFLG

DATA ONE/1.0/, ZERO/0.0/

GO TO (10,50,60,80) , L2

IF (NARGS . NE . 5 ) CALL ERROR (10)

IF (KIND(NARGS) .NE.l) CALL ERROR (3)

IF (NARGS. EQ. 4) IARGS (4 )=IARGS (3

)

CONST=ARGS (NARGS)

CONSTA=ARGS (NARGS)

J=NARGS-1

CALL CKIND (J)

IF (J.NE.O) CALL ERROR (3)

J=l

CALL MTXCHK (J)

IF (J.NE.O) CALL ERROR (17)

IF (NERROR.NE.O) RETURN

JB=IARGS(1)

N=IARGS(3)

K=IARGS(4)

JA=JB

IF (L2.EQ.4) GO TO 90

DO 40 KA=1,K

JC=JB

DO 30 NA=1,N

RC(JC)=CONST

JC=JC+1

IF (KA.GT.N) GO TO 40

RC(JA)=CONSTA

JA=JA+NR0W+1

JB=JB+NROW

RETURN

IF (NARGS .NE .4) CALL ERROR (10)

CONST=ZERO

CONSTA=ZERO

MOP 360

MOP 370

MOP 380

MOP 390

MOP 400

MOP 410

MOP 420

MOP 430

MOP 440

MOP 450

MOP 460

MOP 470

MOP 480

MOP 490

MOP 500

MOP 510

MOP 520

MOP 530

MOP 540

MOP 550

MOP 560

MOP 570

MOP 580

MOP 590

MOP 600

MOP 610

MOP 620

MOP 630

MOP 640

MOP 650

MOP 660

MOP 670

MOP 680

MOP 690

MOP 700

MOP 710

MOP 720

162
J=NARGS MOP 730

IF (NARGS.EQ.4) GO TO 20 MOP 740

IARGS(4)=IARGS(3) MOP 750

J=NARGS-1 MOP 760

GO TO 20 MOP 770

60 IF (NARGS .NE .4) CALL ERROR (10) MOP 780

CONST=ZERO MOP 790

CONSTA=ONE MOP 800

J=NARGS MOP 810

GO TO 20 MOP 820

80 J=NARGS-1 MOP 910

IF (NARGS. NE. 5) CALL ERROR(IO) MOP 920

GO TO 20 MOP 930

90 IF (KIND(NARGS) .EQ.O) GO TO 110 MOP 970

DO 100 NA=1,N MOP 980

RC (JB)=ARGS (NARGS) MOP 990

100 JB=JB+1+NR0W M0P1000

RETURN M0P1010

110 KIND(5)=0 M0P1020

CALL ADRESS (5,M) M0P1030

IF (M.GT.O) GO TO 120 M0P1040

CALL ERROR (11) M0P1050

RETURN M0P1060

120 DO 130 NA=1,N MOP1070

A(NA)=RC(M) M0P1080

130 M=M+1 M0P1090

DO 140 NA=1,N M0P1100

RC(JB)=A(NA) M0P1110

140 JB=JB+1+NR0W MOP1120

RETURN M0P1130

END M0P1140

163
SUBROUTINE MOVE MOV 10

C VERSION 5.00 MOVE 5/15/70 MOV 20

COMMON /BLOCRC/ NRC,RC(12600) MOV 30

COMMON /BLOCKD/ I ARGS ( 100 ) ,KIND ( 100 )

, ARGTAB ( 100 ) ,NRMAX ,NROW,NCOL , NMOV 40

1ARGS , VWXYZ (8 ) ,NERROR MOV 50

DIMENSION ARGS(IOO) MOV 60

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 ) ) MOV 70

C THIS ROUTINE IS ALSO CALLED BLOCKTRANSFER MOV 80

IF (NARGS.EQ.6) GO TO 50 MOV 90

K=10 MOV 100

10 CALL ERROR (K) MOV 110

20 RETURN MOV 120

30 K=20 MOV 130

GO TO 10 MOV 140

40 K=ll MOV 150

GO TO 10 MOV 160

50 IARGS(9)=IARGS(1)+IARGS(3)-1 MOV 170

IARGS(13)=IARGS(5)+IARGS(3)-1 MOV 180

IF (KIND(1)+KIND(3)+KIND(4)+KIND(5) .NE.O) GO TO 30 MOV 190

IF (IARGS(l) .GT.0.AND.IARGS(3) .GT .0 .AND . IARGS (5) .GT . 0 . AND . IARGS (9 ) MOV 200

1 .LE .NROW.AND . I ARGS (13) .LE .NROW) GO TO 60 MOV 210

K=16 MOV 220

GO TO 10 MOV 230

60 IARGS(10)=IARGS(2)+IARGS(4)-1 MOV 240

KIND(10)=0 MOV 250

IARGS(14)=IARGS(6)+IARGS(4)-1 MOV 260

KIND(14)=0 MOV 270

DO 70 1=2,14,4 MOV 280

CALL ADRESS (I, I ARGS (I)) MOV 290

IF (IARGS (I ) ) 30,40,70 MOV 300

70 IARGS(I)=IARGS(I)-1 MOV 310

C MOV 320

C IF MOVE IS UP, IR = -1, IF DOWN, IR = +1 MOV 330

C IF MOVE IS LEFT, IC = -1, IF RIGHT, IC = +1 MOV 340

C DIRECTION OF MOVE IS SUCH THAT THE TWO AREAS CAN BE OVERLAPPING MOV 350

C AND IT WILL BE DONE PROPERLY. MOV 360

C MOV 370

IR=ISIGN(1,IARGS(5)-IARGS(1)) MOV 380

IC=ISIGN(1,IARGS(6)-IARGS(2)) MOV 390

MM=IARGS(4*IR+5)+IARGS(4*IC+6) MOV 400

NN=IARGS(4*IR+9)+IARGS(4*IC+10) MOV 410

IC=IC*NROW MOV 420

MMM=IARGS (3 ) MOV 430

NNN=IARGS (4) MOV 440

DO 90 J=1,NNN MOV 450

M=MM MOV 460

N=NN MOV 470

DO 80 1=1, MMM MOV 480

RC(N)=RC(M) MOV 490

M=M-IR MOV 500

80 N=N-IR MOV 510

MM=MM-IC MOV 520

90 NN=NN-IC MOV 530

GO TO 20 MOV 540

END MOV 550

164
c

cc

c

c

c

cc

c

cc

cc

c

c

c

c

c

cc

c

c

cc

cc

c

c

c

c

SUBROUTINE MPROP MPR

VERSION 5.00 MPROP 5/15/70 MPR

WRITTEN FOR OMNITAB BY S PEAVY 5/ 7/68 MPR

COMMAND IS AS FOLLOWS, X=A OR M DEPENDING APROP OR MPROP IS REQUIRMPR

I XPROP OF MATRIX (,, ++) NO OF ROWS NO OF COL ++ MPR

INFORMATION PRINTED AND NO STORAGE MPR

MPR

II XPROP MATRIX (,, ++) SIZE , , BY ++ PROPERTIES STORED ++ MPR

PROPERTIES PRINTED AND STORED MPR

III XPROP MATRIX (,, ++) R= ( , C=,, PROP ++ COL NORMS (,, ++ ) SAME AS II PLUS STORAGE OF COLUMN NORMS

IV XPROP (,, ++) R=, ( C= /( PROP ++ COL NORMS (,, ++) ROW NORMS

SAME AS III PLUS STORAGE OF ROW NORMS, ALSO (R+1.++) OF NORM

AVERAGES WILL CONTAIN GRAND AVERAGE, IF X=A

.

V XPROP ( ,, ++) R=,, C=,, COL NORMS (,, ++)

SAME AS III EXCEPT PROPERTIES WILL NOT BE STORED

VI XPROP (,, ++) R=,, C=,, COL NORMS (,, ++) ROW NORMS (,, ++)

SAME AS IV EXCEPT PROPERTIES WILL NOT BE STORED

10

20

30

40

50

60

70

80

90

VII SXPROP

IF COMMANDS I-VI ARE PREFACED WITH AN S PRINTOUT

OF PROPERTIES WILL BE SUPPRESSED

L2 OPTIONS:

L2= 1 MPROP:

L2= 2 APROP:

L2=3 SMPROP

L2=4 SAPROP

10

COMMON /HEADER /NOCARD (80) , ITLE (60 ,6) , LNCNT , IPRINT ,NPAGE , I PUNCH

COMMON /SCRAT/ NS ,NS2 ( A (13500)

COMMON /BLOCRC/ NRC ,RC (12600)

COMMON /BLOCKD / IARGS(IOO) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL

,

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS (1 ), RC (12501 )

)

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG

DIMENSION IRSLT(6) , ERR (3 ) , IPR0P(5), IRSLTP(ll), IRSLTA(2,5)

DATA N0/3H NO/ , IYES/3HYES/ , IBLK/3H /,L0WRA/3H LO/ ,L0WRB/3HWER/

,

1PPRA/3H UP/,IPPRB/3HPER/,IANDA/3H AN/ , IANDB/3HD /, IRWA , IRWB/3H

2,3HR0W/,ICLMA,ICLMB/3HC0L,3HUMN/,IBTHH,IBTHHA/3H ,3H T/ , IBTHA

,

3BTHB/3HW0-,3HWAY/,N0A,N0AB/3H ,3H NO/

IF(L2.LE.2.0R.NARGS.NE.4) GO TO 5 CALL ERROR (233)

RETURN

IF (NARGS . LT .4 .OR .NARGS .GT .9) CALL ERROR (10)

L0C=IARGS(1)

J=NARGS

CALL CKIND (J)

IF (J.NE.O) CALL ERROR (3)

K=5

J=l

IF (NARGS-5) 60,30,10

IF (NARGS. EQ. 6. OR. NARGS. EQ . 8) GO TO 40

IS=IARGS(5)

J=2

K=9

MPR 100

MPR 110

MPR 120

MPR 130

(MPR 140

MPR 150

MPR 160

MPR 170

MPR 180

MPR 190

MPR 200

MPR 210

MPR 220

MPR 230

MPR 240

MPR 250

MPR 260

MPR 270

MPR 280

MPR 290

MPR 300

MPR 310

MPR 320

MPR 340

MPR 350

NMPR 360

MPR 370

MPR 380

MPR 390

MPR 400

MPR 410

IMPR 420

MPR 430

IMPR 440

MPR 450

MPR 455

MPR 460

MPR 465

MPR 467

MPR 470

MPR 480

MPR 490

MPR 500

MPR 510

MPR 520

MPR 530

MPR 540

MPR 550

MPR 560

MPR 570

165
30

40

IF (NARGS.EQ.7) GO TO 20 MPR 580

IARGS(11)=IARGS(3) MPR 590

I ARGS (12 )=1 MPR 600

IARGS(10)=IARGS(9) MPR 610

IARGS(9)=IARGS(8) MPR 620

K=13 MPR 630

J=3 MPR 640

IF (L2.GT.2) IARGS(11)=IARGS(11)+1 MPR 650

20 IARGS(5)=IARGS(6) MPR 660

IARGS(6)=IARGS(7) MPR 670

IARGS(7)=1 MPR 680

IARGS(8)=IARGS(4) MPR 690

IARGS(K)=IS MPR 700

CALL ADRESS (K,KPROP) MPR 710

IF (KPROP.LE.O) CALL ERROR (11) MPR 720

GO TO 60 MPR 730

J=2 MPR 740

IF (NARGS.EQ.6) GO TO 50 MPR 750

IARGS(9)=IARGS(7) MPR 760

IARGS(10)=IARGS(8) MPR 770

IARGS(11)=IARGS(3) MPR 780

IARGS(12)=1 MPR 790

J =3 MPR 800

IF (L2.GT.2) IARGS(11)=IARGS(11)+1 MPR 810

50 IARGS(7)=1 MPR 820

IARGS(8)=IARGS(4) MPR 830

60 CALL MTXCHK (J) MPR 840

KARGS=K MPR 850

IF (J.NE.O) CALL ERROR (17) MPR 860

IF (NERROR.NE.O) RETURN MPR 870

K=IARGS(1) MPR 880

IF (L2.EQ.2.0R.L2.EQ.4) GO TO 110 MPR 890

C COMMAND IS MPROP MPR 900

C IS MATRIX A SQUARE ONE MPR 910

IF (IARGS(3) .NE.IARGS(4)) GO TO 90 MPR 920

C YES MPR 930

CALL INVCHK (RC (K) , NROW, I ARGS (3 )

, A ( 100 ), I ARGS (3 ) +1 , A , 1 , ERR , IND ) MPR 940

KA=K MPR 950

M=100 MPR 960

L=IARGS(3) MPR 970

DO 80 1=1, L MPR 980

KB=KA MPR 990

DO 70 J=1,L MPR1000

A(M)=RC(KB) MPR1010

KB=KB+1 MPR1020

70 M=M+1 MPR1030

80 KA=KA+NROW MPR1040

CALL DETRNK (A (100 ), L , L , DET , RANK) MPR1050

CALL PVTRI (RC(K) ,NROW, IARGS (3 ) ,INDU,INDB) MPR1060

CALL PROCHK (RC (K) ,NROW, I ARGS (3 )

, I ARGS (4 )

, IPROP , A ( 1 )

, NS2 ) MPR1070

A(30)=0. MPR1080

IF (INDU.EQ.O) A(30)=A(30)+1.0 MPR1090

IF (INDB.EQ.O) A(30)=A(30)+2 .0 MPR1100

A(19)=DET MPR1110

A(20)=RANK MPR1120

A(21)=ERR(1) MPR1130

A(22)=ERR(2) MPR1140

A(23)=ERR(3) MPR1150

A(24)=0. MPR1160

166
IF ( IPROP (3 )

. EQ 0

)

A (24) =1 .0

IF (IPROP (3

)

. EQ 1) A(24) =2.0

A (25)=0

.

IF (IPR0P(2) .LT 2) A(25) =IPR0P(2)+1

A (26 )=0

.

IF (IPR0P(2) .GT 2) A(26) =IPR0P(2)-2

A (27 )=0

.

IF (IPROP(l) . EQ 0) A(27) =1

.

A(28)=0.0

IF (IPR0P(4) .LT 2) A(28) =IPR0P(4)+1

A(29)=0.

IF (IPR0P(5) .LT 2) A(29) =IPR0P(5)+1

GO TO 110

90 CALL ORTHRV (RC (K ) ,NROW, I ARGS (3 )

, I ARGS (4 ), I PROP (4 ), A ( 1 ) ,NS2 , A ( 1 )

)

DO 100 1=19,31

100 A(I)=0.0

110 CALL RCSUM (RC (K) ,NR0W, I ARGS (3 )

, I ARGS (4 )

, A ( 101 )

)

L=IARGS(3)

IF (L.GT.IARGS(4)) L=IARGS(4)

ITRACE=L

IP0S=0

IZER0=0

INEG=0

TRACE=0.0

AMX=RC(K)

AMN=AMX

LA=IARGS(3)+IARGS(4)

AVG=A(LA+102)/FL0AT(IARGS(3)*IARGS(4)

)

ABSMX=ABS (AMX)

ABSMN=ABS (AMN)

ABSMNZ=ABSMN

SSQ=0.0

SRSQ=0.0

SCSQ=0.0

IF (ABSMNZ.EQ.0.0) ABSMNZ=1.E35

KA=K

DO 120 1=1 ,L

TRACE=TRACE+RC(KA)

120 KA=KA+NROW+l

IN=IARGS(3)

JK=IARGS(4)

KA=K

FIN-IN

FJK=JK

DO 200 J=1,JK

KB=KA

DO 190 1=1 , IN

KC=IARGS(4)+I

SSQ=SSQ+(RC(KB)-AVG)**2

SCSQ=SCSQ+(RC(KB)-A(J+100)/FIN)**2

SRSQ=SRSQ+(RC(KB)-A(KC+100)/FJK)**2

IF (RC (KB) ) 130,140,150

130 I NEG=I NEG+1

GO TO 160

140 IZER0=IZER0+1

GO TO 160

150 IP0S=IP0S+1

160 IF (AMX .GT .RC (KB) ) GO TO 170

AMX=RC (KB)

MPR1170

MPR1180

MPR1190

MPR1200

MPR1210

MPR1220

MPR1230

MPR1240

MPR1250

MPR1260

MPR1270

MPR1280

MPR1290

MPR1300

MPR1310

MPR1320

MPR1330

MPR1340

MPR1350

MPR1360

MPR1370

MPR1380

MPR1390

MPR1400

MPR1410

MPR1420

MPR1430

MPR1440

MPR1450

MPR1460

MPR1470

MPR1480

MPR1490

MPR1500

MPR1510

MPR1520

MPR1530

MPR1540

MPR1550

MPR1560

MPR1570

MPR1580

MPR1590

MPR1600

MPR1610

MPR1620

MPR1630

MPR1640

MPR1650

MPR1660

MPR1670

MPR1680

MPR1690

MPR1700

MPR1710

MPR1720

MPR1730

MPR1740

MPR1750

167
170

180

185

190

200

210

220

230

240

250

260

r* n Tn ion bU IU ioU MDD 1 7/(1 Mr K 1 / oU

T c i A MM P T DP 1 U& \ \ A MM Dp / l/D \ 1 r (A WIN .u 1 . Kb \I\B ) j AMIN=Kb (l\B ) MD D 1 7 7 A Mr K 1 / / U dpad KbAB=ABo adc (Dr (i^nn ( Kb ( M3 ) ) MD D 1 7 O A Mr K 1 / ou

ic /ADC MY IT D P A D \ ADC MY OTAB lr (ABjMA.LI . KbAB ) ABoMA=KbAB MDD Mr 1 7 O A K 1 / 7U

ic /ADC MM P T DPAP.X ADCMM or AD lr (ABoMN.bl .KbAB) ABoMN=KbAB MDD Mr 1 0 A A K 1 OUU

if /ADC MM 7 rT D P A D \ IC / D P A D \ 1 On 1 Q A lr ( ABoMIMZ. . b 1 .KbAB) lr (KbAB) lVU , IVU , 1 Q C lob MDD 1 one MrKloUD

pn Tfi 1 on bU 1 U IVU MDD Mr 1 O 1 A K I 0 IU

AB3MN£=KbAB ADCMM 7 DP AD MDD 1 O 0 A Mr K 1 oi. U ^o=^o+J. MDD Wlr K

1 am

1

Y A — A 1 MPntU MDD 1 0 4(1 ic 11 7 en 7 no i 7 cn 4 no tadpc/i\ mc lr (L£.ty.£.UK.L£.ty.4.UK.iAKb.>(.?) .INC TADPC/A\\ Prt Tfl ltd ,lAKbo(4); bU IU Lo\) MDD 1 ocn Mr K lo DU

T CTnPD n 1 3 1 UbK=U MDD 1

Q

Mr k A K I00U

t1 ctpup_a 0 1 bnb=U MD Dl 07(1 Mr K 1 0 / U TPir /A(AWN. MM ITLI .U.U) ft A\ pfl oU TOIU 7AA ttU MDMr DlK J.00U QOn

nn 91 n i_i 1 v UU c. J. U J = 1 , J r\ MDD 1 flan Mr rv 1 0 7 U

1 c / ft / i , 1 a n \ c n i n\ m Tfl 11 n ir (i\ ( j+iuu ) . ty . 1 . u ) bu iu £iu MDD 1 O A

A

MrKl7UU

bU 1 U ccU MD D 1 O 1 A Mr K 1 7 1

U

rnMTTMiic MDD1 07

A

MrKl7£U

T CTPUP—7 MDD 1 Q 1

A

Mr K 1 7 i U nn 9 in t_i t

n

MDD 1 Q d A IVlr K 1 7 4 U M— T _l IK IV^l +Jr\ MDD MrK 1 ocn 17DU

ic / A / Ui 1 nn \ en i a \ pn jn 7 3 a ir (a v m+iuu ) . ty . 1 . u ) bu iu ^^u MrK MD D 1 O A A J.70U

P.P, bU tI nU 7dn ^'U MDD 1 07

A

MrKl7 / U rnMT t mi ic uuro 1 1 nut. MDMrKl7oU D 1 O Q A

T CTflPR—

1

1 j 1 UU r\=± MP D 1 Q Q A aa/hv1 )=i— tctpuPiT j 1 unu+ioCTnpp 1 uui\ MDMr D 7 A A A K £. U U U

A (i \ TD ATC A ( X } = 1 K Abt MDMr D 7 A 1 A K L U 1

U

T D 9 n a 1 K£=U . 1) MDMrKZUZU D 7 A 7 A

l\B=r\ MDMr DKiUJU 7 A X A

J M\=J r\ MDWlrKtUtU R 7 A A A TC / \Y PT TM\ IVY TM lr ( J r\ . b 1 .IN) JI\I\=1N MDD 7 AC

A

Mr KdUOV

UU ^ oU J=£ , Jl\l\ MDD7AAA Mr KdUOU

If A 1/ K A=r\ MDP7A7A Mr K c U / U

v p i/Q . MDniil 1 1

r\ B=l\ B +N K U H+

1

MDP7A0A

|/p_1/ , 1 i r\U=i\ +J —1 MPD7AQn wiri\cU7U

KU=K+ (J-l)NKUW MPP7 1 A

A

Mr rv & I U U

T T 11 1 1 =J -1 MPP7 Mr 1 1 A K 1 1 1

U

nn 'i l(\ t i tt UU ioU 1=1 , 1

1

MDD Mr 7 1 7 A rv L 1 L U TD1 K

7i=TD9 1 K£ +1 /OP (l/A \ *DP II^R\ DP / l/P \ *DP (1^11 M ( Kb ( l\A ) Kb (l\B ) —Kb v r\b ) Kb(r\U)) MrMPR7n4l;U 1 ^A

1/ A U A 1 MDnui • 1 ~ r\A=r\A+l\IKUII+l MP D 7 1 A A Mr l\t!4U

l\b=Kb+liKUW MPP7 Mr fVt 113UCA

KU=KU+1 MPMr DRiiOU 7 1 A A

A / *5 \ TOO A (2 )=l Ki MPMr DKtl/U 7 1 7 A

A / 1 \ A UV A (3 ) =AMX MDMr DKlIOU 7 1 fl A

A / A \ A MM A (4 ) =AWInl MPP7 Mr nil1 on7U

A / C \ ADC MY A

(

3

j

=AB DMA MPP77AA Mr rv i. L U U

A / t \ ADC MM A ( 0

) =ABbMN MPP77 1

n

Mr rv £ t i u

A / "7 \ ADC MAI 7 A (7 )=ABbMN£ MPR7 Mr rv 9 7 A C C c. U

a / 0 \ i one A (8 )=lrUb MDP7 7 1

A

Mr x\(.C3\S A / a \ T 7CDP A ( V ) = 1 Z.C.KU MDR77AA Mr rv 1 1 1 u A/in\ tmcp A ( 1 U ) = 1 INtb mr rv c c j \j I/lit A/l A.1A1V A ( 11 )=A (LA+1U1

)

MPR97AA

A (12 ) =AVb MPR997D Mr rv C C I U

A / 1 O \ A/l A . 1 A 1 \ A ( 13 )=A ( LA+103

)

MDR770A Mr rv L. C OU

a / 1 a \ ccn A ( 14 )=bbU MPR?7Qn mr ncL7U

Kiel cocn A ( Id )=bKbu. MPR2300 mr rv c ^ u v

A / 1 L \ CPC/1 A ( 16 )=bbbU MPR mr iVb^iv 7 310

A ( 17 ) =A ( LA+104

)

MPR2320

A(18)=A(17)/FL0AT(IARGS(3)*IAR6S(4)

)

MPR2330

168
IF (L2 .6E.3) GO TO 570 MPR2340

CALL PAGE (4) MPR2350

IF (L2.NE.1) GO TO 370 MPR2360

WRITE (IPRINT ( 640) I ARGS (3 )

, IARGS (4 ), LOC , IARGS (2

)

MPR2370

IF (MOD (NARGS ,2) .EQ .0) GO TO 270 MPR2380

WRITE (IPRINT,650) IARGS (KARGS) MPR2390

270 WRITE (IPRINT,660) ITRACE , (A(I) ,1=1,7) , IPOS , IZERO , INEG , (A(I) , 1=11 ,MPR2400

116) MPR2410

WRITE (IPRINT,670) A(17),A(18) MPR2420

WRITE (IPRINT,680) MPR2430

IF (IARGS(3) .NE.IARGS(4)) GO TO 390 MPR2440

IRANK=A(20)+.5E-5 MPR2450

WRITE (IPRINT,690) A ( 19 ) , IRANK , (A ( I ) , 1=21 , 23

)

MPR2460

DO 280 1=1,6 MPR2470

IRSLT (I )=IYES MPR2480

IRSLTP(I)=A(I+23) MPR2490

IF (A(I+23) .EQ.O.) IRSLT(I)=NO MPR2500

280 CONTINUE MPR2510

C SET IRSLT (I ) ,1=1,6 FOR YES OR NO. ALSO A ( I ), 1=24 ,29 MPR2520

DO 290 1=1,5 MPR2530

IRSLTA(1,I)=IBLK MPR2540

290 IRSLTA(2,I)=IBLK MPR2550

IRSLTA(1,3)=N0A MPR2560

IRSLTA(2,3)=N0AB MPR2570

IF (INDU.NE.O .AND.INDB.NE.O) GO TO 320 MPR2580

IF (INDU.NE.O) GO TO 310 MPR2590

IF (INDB.EQ.O) GO TO 300 MPR2600

IRSLTA(1,1)=IPPRA MPR2610

IRSLTA(2,1)=IPPRB MPR2620

GO TO 320 MPR2630

300 IRSLTA(1,1)=IPPRA MPR2640

IRSLTA(2,1)=IPPRB MPR2650

IRSLTA(1,2)=IANDA MPR2660

IRSLTA(2,2)=IANDB MPR2670

310 IRSLTA(1,3)=L0WRA MPR2680

IRSLTA(2,3)=L0WRB MPR2690

320 IRSLTA(1,5)=N0A MPR2700

IRSLTA(2,5)=N0AB MPR2710

IF ( ISTOCR+ISTCHC .EQ . 3 ) GO TO 340 MPR2720

IF (ISTOCR.EQ.O) GO TO 330 MPR2730

IRSLTA(1,5)=IRWA MPR2740

IRSLTA(2,5)=IRWB MPR2750

GO TO 350 MPR2760

330 IF (ISTCHC.EQ.O) GO TO 350 MPR2770

IRSLTA(1,5)=ICLMA MPR2780

IRSLTA(2,5)=ICLMB MPR2790

GO TO 350 MPR2800

340 IRSLTA(1,4)=IBTHH MPR2810

IRSLTA(2,4)=IBTHHA MPR2820

IRSLTA(1,5)=IBTHA MPR2830

IRSLTA(2,5)=IBTHB MPR2840

350 IRSLTP(7)=A(30) MPR2850

IRSLTP(8)=A(31) MPR2860

WRITE (IPRINT,700) ( IRSLT ( I )

, IRSLTP ( I ), 1=1 , 6

)

MPR2870

WRITE (IPRINT.710) ( ( IRSLTA ( I , J )

, 1=1 , 2 ) , J=l , 3 ), IRSLTP (7

)

( (IRSLTA(MPR2880

1I,J),I=1,2),J=4,5),IRSLTP(8) MPR2890

DO 360 1=1,2 MPR2900

360 WRITE (IPRINT,720) MPR2910

WRITE (IPRINT,730) MPR2920

169
n n Tn c 7

n

bU 1 U 3 / U UQ D 7 Q 7 A MPKZ930

MrAPDnP KUr rnlBI PRTMT UUmix

1

UDD 7 o /

n

Mr KZVHU

1 7 n 3 IV U/RTTF WK /TPRTNT 7Afl\ TARn^/11 TARn<WA\ 1 nr TART,? f 5 \ 1 1 t ( Irnl n 1 , / HU J 1 HnUJ \3 j f 1 MKU3 \ ^ 1 i LUl< , IHnUJ ( c ) UDD 7 0 c n TFi r fMfirwNARf^ 71 FCt (\\ CC\ TO ^ftn

( mu u^iMHr\uj,^).r_y.u) o u i u j o u UDD MrKZ70U 7 Q A n UIRTTF /TPRTNT A^ni T ARG ^ 1 K AR£Q 1 UDR707n Mr Kc 7 1 U

i q n U/RTTF WK MPPTNT A A n 1 TTRAPF 1 A 1 T 1 T — 1 7\ TPflC T7FR0 I MFP /A/Tl T

1 1 t ( 1 r l\ 1 HI 1 , OOU J1 1 Rn^C , \ A \ I ) , 1 =1 , / ) , 1 r Uj , 1 /.t KU , 1 Ntb , {A ( I ) , 1 =11, 1 1 UDD 7 O Q n Mr K A70U

1 1 A 1 1 1 0 ) UDD MKKZ77 Q 0 n 7U

U/RTTF WK 1 ! t /TPRTKIT ( lrl\lN 1 A7/1I A/171 A/101 , 0 / U ) n \ JL 1 )

, A ' 10 J UDD 1 n n n MrrOUUU

Tfl <>7n UDD 1 n l

n

U KIDROD WlrRUr DDTKIT rnllil OUT Uu 1 FDD rUrv MA KIDW KuN-jyUflRr. QHIIADF MATRTV MM 1 K 1

A

upMr d 1 n 7 n l\ U J7U ion nn Ann T — 1 9 imp Mr D 1 n 1 n K3U

T1K0L DCI TA / 1 T \ KlrtA

1 ft ( 1 , 1 ; =NUM UDD 7 n /

n

MrK 3U4U

Ann TB^I T4 n T\—KIDAP. UDD Mrr\ JUDU 1 n cn

TFlr /TPRnP/41 FO 5 1 r;n TO ccn l

t irrvuri4 4^.C.y.£; UU 1 U j DU MDRinAn Mr RJUDU

TFlr /TARC/TPRnP/All l,lMDjllrKUr^4; A 1 41 (1 /on ADn ) —4 ) 41U,40U,40U udd MrK 1 n 7 n JU /

U

a i n 4 1 U nnUU aH 7 n t — l 7 c.\) 1 = 1 , C. udd 7 n 0 n MrK JUoU

TPCITAM IKoLIMI,!,!T \_ TRUIA

J = X rv WM UDD MrK 7 non JU7U

Aon TRQITA/7 IK JL 1 H I \ _ TRUIR ( t , 1 )=1K TID udd MrK J7 inn 1UU

TF nPPHP m u Ain am AAn UDMr D 11 1 n K J 1 1U

a i n MA /(CO7 A 1)—C_7 UDD Mr 1 1 7 n K 3 1 C U nnbU Tn Ac.n 1 U H3U UDMr D 1 1 1 n K J 1 i U AAn MA / 7 A 1 — 1

I £ 0 ; =1 UDD Mr K

1 1 An J 1 H U Ai;n TFlr /TPRnP/Cll AAn AAn 47(1 ( IrRUr p ) ) 40U , HOU , 4 /

U

UDD Mr 1 1 c n K J 1 D U SOU a An A (Z / )=Z UDD MrK 1 1 A n J loU nn Tn ccn MDD Mr t\ 1 1 7 n j i / u a 7 n 4 / u

A / 7 7 \ — 1 A I*/ )=1 UDD MrK 1 ion 3 loU rnbU Tn ccn 1 U DJU udd iion Mr K J I7U

Ann nnUU Aon 47U T—1=1i 7

,

L MDDionn Mr K 3 C\t\J

TRQITA/1 111 jL 1 ft ( 1 Tl—TPIMA , 1 ) = l L> L MM UDD 1 7 1

n

Mr K 3 i. 1U

Aon 47U TRCITA/7 1 IV J L 1 M ( C , T1

1

) —= T1 PU

1L MRMD UDD 1 7 7 n TFlr / T PRnp 1 a \ \ cnn cnn cin [ 1 rl\Ur ^*» ) ) 3UU , DUU , 31U UDD 1 7 1

n

MrK 3 i. JU cnn 3UU A / 7 A 1 A ft

(

L 0 ) =1 UDD MrK JZhU 1 7 A n nn Tn con UU 1 U DCU MDD Mr r\ j17i. cnd u

c i in A i 7 A 1 _1 MDD Mr R J17t An0 u con JiU TF M PRnp i c \ \ c-ja c^n CAn MDR177n nnr r\ j c 1 u 33U A / 7 7 1 A UDD Mr K J

7 7 Qn e OU nnuu Tn1 U ccn 33U MrMD KD 1 7 Q n J C 7 u

c An ftU' A ( 7 7 1 3 )—-5 MPMr R j1 j1 n n u u ccn 35U T P^l TP 1

"\ 1KJL \ —A ( 7 A \

1 r (1 ) =M (, £ 0 ; mpriii Mr r\ j j 1 nu TRQI TPi71—A/771 UDD117n Pfir r\ 3 3 C \J UID UK TTF lit /TDDTKIT 7Cn\ //TDCITA/I Tl l_l 7\ IDCI TP ( T \ T_l 71 ( IrKIN 1 , /3U ) ( ( IKjL 1 A ( J , 1 J

, J = l , £ ) , 1K3L 1 r ( 1 ) , 1=1 ,t

)

MDD 1 1 1

n

MrK J J JU nnUU cAn SOU t_i 1=1 77

,

C

C

UPD itir i\ j1 j

1 An* u

c An U/DTTF UK MDRTKIT 77rtl 1 1 L ( 1 rKin 1 , 1 tu

)

UDD lien nnr rv 3 3 j u

UID WK lit TTF /TDDTKIT 7An\ 1 IrKIN 1 ,/0U; MPRiiAn Mr i\ j j 0 u C7n TF / Kl ADP C cn A\ DFTIIDKI lr ( IMAKuo . ty . H ) Kt 1 UKIM MPR117n nnr rv j 3 1 u ir /unn/MADrc 71 cn n\ nn Tn Ain udd Mri\ jimn jou

T D 11 1 r=3

1

MPRIIQn Mr rv j j 7 u tr MADrc / ca i Aor c / a \ \ cf\ Tn con lr ( lAKbb (3 ) . ty . lAKbb (4 )

) bU IU DVU MPMr DK 1 a n n J 4 u u

1 r=Z7 mdpiai Mr K n J 4 1 u nnUU 30U con t1=11 0 7c 7

,

c 3 MPR34?n. con Mllj a / T 1 _n=u n.

u

MPR3430

CO/1 tc /unn/i 7 7\ cf\ n\ td 1 q lr ( MUO

(

Li , I )

.

ty . U ) lr=lo MPR1 6»ir rv AArt 3 4 4 v TC / fclDAUJ IT TD\ TD UD/1UI lr (NKUW.LI.lr) 1H=NKUW MPRIAcn Mr K J 4 3 U nn a nn t t t d UU 0 U U 1=1 , 1

r

Itlr l\ 3 *t U Vi KU (KrKUr )=A ( 1

)

UPD1A7n Mr rv J 4 / U Ann oUU 1/DDnD 1/DDftD , 1 r\r KUr=l\r KUr + 1 MPR14R0

TF /KIADTC Fn CI DFTIIDKI lr ( NflKoj . ty . D ) l\t 1 UKIl MPR?4 Q f) a i n k A—T ADnC / C

\

r\M=l flKuo (D ) MPR3S00

ANRMX=IARGS (3) MPR3510

170
DO 620 1=1 , JK MPR3520

RC (KA)=A ( 1+100 ) /ANRMX MPR3530

620 KA=KA+NROW MPR3540

IF (NARGS.LT.8) RETURN MPR3550

KA=IARGS(9) MPR3560

ANRMX=I ARGS (4 ) MPR3570

KB=JK+101 MPR3580

DO 630 1=1, IN MPR3590

RC(KA)=A(KB) /ANRMX MPR3600

KA=KA+1 MPR3610

630 KB=KB+1 MPR3620

IF (L2.GT.2) RC(KA)=AVG MPR3630

RETURN MPR3640

C MPR3650

640 FORMAT (1H0 , 39X , 14HPR0PERTIES OF ,13, 3H X ,I3,27H MATRIX STARTING MPR3660

1L0CATI0N ( , 13 , 1H ,

, 13 ,1H) ) MPR3670

650 FORMAT (23X , 3HC0L , 1 7 ) MPR3680

660 FORMAT (3 OX , 7HGENERAL/23X , 1HR/23X , 9H1 TRACE (

, 13 , 13H VALUES USED )

, MPR3690

17X,1PE15 .6/23X,32H2 TRACE NO. 2 , E15 . 6 / /23X , 32H3MPR3700

2 MAXIMUM ELEMENT , E15 . 6 /23X , 20H4 MINUMUM ELEMENT ,MPR3710

3 12X ,E15.6/23X,32H5 MAXIMUM ELEMENT IN ABS VALUE ,E15 . 6 /23XMPR3720

4,32H6 MINUMUM ELEMENT IN ABS VALUE , E15 . 6 /23X , 32H7 MIN NON-ZERO EMPR3730

5LEM IN ABS VAL ,E15 . 6 / /23X , 32H8 NUMBER OF POSITIVE ELEMENTS ,10MPR3740

6X,I5/,23X,32H9 NUMBER OF ZERO ELEMENTS , 10X , 1 5 /22X , 33H10 NUMMPR3750

7BER OF NEGATIVE ELEMENTS , 10X , 15 / /22X , 33H11 SUM OF TERMS MPR3760

8 ,E15.6/22X,33H12 AVERAGE ,E15 .6/22MPR3770

9X,33H13 SUM OF SQUARES , E15 . 6 /22X , 33H14 SUM OF SQUAMPR3780

$RES ABOUT MEAN , E15 . 6 /22X , 33H15 WITHIN ROWS SUM OF SQUARES MPR3790

$,E15.6/22X,33H16 WITHIN COLS SUM OF SQUARES ,E15.6) MPR3800

670 FORMAT (22X,33H17 SUM OF ABSOLUTE VALUES , 1PE15 . 6 /22X , 33H18MPR3810

1 AVERAGE OF ABSOLUTE VALUES ,E15.6) MPR3820

680 FORMAT (1H0 , 29X , 8HSPECIFIC/ ) MPR3830

690 FORMAT (22X,33H19 DETERMINANT , 1PE15 . 6 /22X , 33H18MPR3840

1 RANK ,7X,I8/30X ( 5HN0RMS/22X,33H21 SQ R00MPR3850

2T OF SUM OF B(I ,J)**2 , E15 . 1 /22X , 33H22 N*MAX (B (I , J )

) MPR3860

3 ,E15.1/22X / 33H23 MAX VAL OF ROW SUM ,E15.1) MPR3870

700 FORMAT ( 1H0 , 21X , 32H24 NORMALITY , 13X , A3 , 2H* (

, i 1MPR3880

1,1H)/22X,33H25 SYMMETRY , 12X , A3 , 2H* (

, 1 1 , 1H) /2MPR3890

22X,33H26 SKEW SYMMETRY , 12X , A3 , 2H* (, 1 1 , 1H ) /22X , 33HMPR3900

327 DIAGONALITY , 12X , A3 , 2H* (, 1 1 , 1H ) /22X , 33H28 0RTMPR3910

4H0G0NALITY: A/A=I , 12X , A3 , 2H* (, I 1 , 1H ) /22X , 2H29 , 17X , 19HA / AMPR3920

5=DIAG0NAL MATRIX , 7X , A3 , 2H* (, 1 1 , 1H ) / / ) MPR3930

710 FORMAT (22X,13H30 TRIANGULAR , 2 OX ,3 A3 ,A1,2A3,3H**(,I1,1H)/22X,33H31 MPR3940

1ST0CHASTIC (R AND/OR C SUMS=1 ) ,3X ,4A3 ,4H*** (, 1 1 , 1H )

) MPR3950

720 FORMAT (1H ) MPR3960

730 FORMAT (9X,79H* IF ANSWER IS YES, (R,C)=1 OR 2. (1, IF EXACT; 2, MPR3970

1IF TOLERANCE IS SATISFIED .) /11X , 25HI F ANSWER IS NO, (R ,C)=0 . / /8X , 1MPR3980

20HTRIANGULAR/8X,69H** (R,C)=0,IF ANSWER IS NO; (R,C)=1, IF UPPER PMPR3990

3ART OF MATRIX IS ZERO ; /11X , 74H (R ,C )=2 , IF LOWER PART IS ZERO; (R,CMPR4000

4)=3, IF ALL OFF DIAGONAL ELEMENTS = 0 . / /7X , 10HSTOCHASTIC/7X , 75H***MPR4010

5 (R,C)=0, IF MATRIX IS NOT STOCHASTIC; (R,C)=1, IF SUM OF EACH ROWMPR4020

6 = 1; /11X,75H(R,C)=2, IF SUM OF EACH C0LUMN=1 ; (R,C)=3, IF SUM 0FMPR4030

7 EACH ROW AND C0LUMN=1 . ) MPR4040

740 FORMAT ( 1H0 , 39X , 14HPR0PERTIES OF ,I3,3H X ,I3,26H ARRAY STARTING LMPR4050

10CATI0N (,I3,1H,,I3,1H)) MPR4060

750 F0RMAT(22X,32H26 ORTHOGONALITY: A/A=I , 9X , 2A3 , 2H* (

, 1 1 , 1H ) /MPR4070

1 22X,2H27,17X,19HA/A=DIAG0NAL MATRIX , 3X2A3 , 2H* (, 1 1 , 1H) ) MPR4080

760 FORMAT (9X,86H* (R,C)=0, IF MATRIX IS NOT ORTHOGONAL; (R,C)=1 OR 2MPR4090

1 IF MATRIX IS ORTHOGONAL ROW WI SE ; /11X , 97H (R , C )=3 OR 4, IF MATRIX MPR4100

171
2IS ORTHOGONAL COLUMN WISE . ( (R,C)=I, IF 1=1 OR 3 ORTHOGONALITY ISMPR4110

3 EXACT; /11X,50HF0R 1=2 OR 4 RELATIVE WITHIN ERROR BOUND OF . IE . 6 )

) MPR4120

END MPR4130

172
SUBROUTINE MRAISE MR A 10

C VERSION 5.00 MRAISE 5/15/70 MR A 20

C * MR A 30

C SUBROUTINE TO RAISE A MATRIX TO A POWER 9/13/67 MR A 40

C GENERAL FORMS OF MRAISE MR A 50

C MRAISE A ( , ) N ,N TO M POWER AND STORE IN C(,) MR A 60

C M MAY BE INTEGER OR REAL MR A 80

C IF M=0 C=IDENTITY MATRIX MR A 90

C IF M=l C=A MR A 100

C * MR A 110

COMMON /BLOCRC/ NRC , RC ( 12600 ) MR A 120

COMMON /BLOCKO/ IARGS (100 ), KIND ( 100 ), ARGTAB ( 100 ) ,NRMAX , NROW, NCOL , NMRA 130

1ARGS ,VWXYZ (8 ) ,NERROR MRA140

DIMENSION ARGS(IOO) MR A 150

EQUIVALENCE (ARGS (1) ,RC (12501) ) MRA160

COMMON /SCRAT/ NS ,NS2 , A (13500 ) MR A 170

DOUBLE PRECISION X,SUM MR A 180

DIMENSION X(l) MRA 190

EQUIVALENCE (X,A) MRA 200

C * MRA 210

C CHECK NUMBER OF ARGUMENTS MRA 220

C * MRA 230

IF (NARGS .NE .7 ) CALL ERROR (10) MRA 240

C * MRA 250

C CHECK TO SEE IF ALL ARGUMENTS ARE INTEGER MRA 260

C * MRA 270

J=NARGS MRA 280

CALL CKIND (J) MRA 290

IF (J.EQ.O) GO TO 20 MRA 300

IF (KIND (NARGS-2 ) .NE.O) GO TO 10 MRA 310

CALL ERROR (3) MRA 320

GO TO 20 MRA 330

10 I ARGS (NARGS-2 )=ARGS (NARGS-2) MRA 340

C * MRA 350

C CHECK TO SEE IF M (POWER) IS NEGATIVE MRA 360

C * MRA 370

20 IF ( IARGS (NARGS-2 ) .LT.O) CALL ERROR (3) MRA 380

C * MRA 390

C CHECK TO SEE IF DIMENSIONS ARE CORRECT MRA 400

C * MRA 410

IF (IARGS(3) .NE.IARGS(4) ) CALL ERROR (3) MRA 430

C * MRA 440

C CHECK TO SEE IF ARGUMENTS ARE OUT OF RANGE MRA 450

C * MRA 460

30 NP0W=IARGS(NARGS-2)-l MRA 470

40 IARGS(5)=IARGS(NARGS-1) MRA 500

IARGS(6)=IARGS(NARGS) MRA 510

IARGS(7)=IARGS(3) MRA 520

IARGS(8)=IARGS(4) MRA 530

J=2 MRA 540

CALL MTXCHK (J) MRA 550

IF (J-l) 70,50,60 MRA 560

50 CALL ERROR (3) MRA 570

RETURN MRA 580

60 CALL ERROR (17) MRA 590

RETURN MRA 600

C * MRA 610

C CHECK TO SEE IF PREVIOUS ERRORS MRA 620

C * MRA 630

173

409-118 OL - 71 - 12
7 A 70 i r / MFDDOP MP

A\

DPT 1 IPM lr (NLKKUK . Nt . U ) KL 1 UKN MD

A i ylA MKA O'JU TCT7P I ADPC (5 ^ 1 b 1 it= 1 AKbb ( 3 )

AIDA / rA MKA ODO

b * MDMKAA

LLA 00U

b RPPTM D L b 1 N

Mill WIU LITTDI IrLlUHl TPATTnM 1UN MDMKAA i7A 0 / U

b MDMKAA iOli 00U b * MD A iOA MKA 0 7 U b Mn\/P MUVL (\D TP T MAI MATDTY TP CPDATPU ADPA /rni 1 1 MM UU T C P \ UKlbllMAL MA 1 K 1 A IU bbKA 1 UH AKtA ( bULUMN Wl b t )

IJD

A 7 AA MKA /UU

b * MDMKAA 7 1 A / IU

TP /MDnui\ qa an 1 1 n lr ^NrUn) oU,7U,llU MDA 7 OA MKA /ZU

qnTP YT— 1 1 LA 1 = 1MDMKAA 7 1 A / J U

pn tp i aa bU 1 U 1UU AIDA ~yAA MKA 7 4U

anTP YT 7 1 L A 1 =Z MD

A 7 CA MKA /DU 1 uu MD A 7 i A

MKA / oU

pn tp i oa oU 1 U 1 Z UAIDA 7 7 A MKA / / U i i n T F YT—% 1 L A 1 —J MPMKAA 7Qn / O U 1 O A 1ZU T D T ADP C t 1 \ 1 r = l AKbb ( 1 )

IJD

A 7 OA MKA /VU

TP 1 1 b=I MD

AOAA MKA oUU nnUU oon ZZU J=l,lblit i i TCT7P MDMKAA O 1 A OlU

nn i ont i tct 7p UU loU 1 = 1 , 1 Hit MD

AOOA MKA oZU

pnou TnIU inn ( 1 JU , iloUin 17m tpyt , 1/ U ) , 1 LA 1 MPMKMA oin ojVJ 1 7 A 1 J u tplr 11 pp i\ rn Tn i^n ii.ty.j; uu iu MDMKAA OlU 0 A A DP ( KAWl A A Kb I 1 bAV ) =U . U

MDAQCA MKA obU

pn Tn 1 t;n bU 1 U IDU mix MP

AA 9 A 0 0 0 U 11U Kb ( 1

jAV ; = 1 . U MDMKAA

Q 7 n O / U

TC AV—T CAUxl 1 jAV = l oAV + 1 MRA QOn MK A OoU

pnbU Tn i o.n 1 U lou MPlini\AA son 07U 1 An lOU DP/TCAW\ Kb D P / T D \ ( 1 bAV ) =Kb ( 1 r )

MDMK

AA

onn 7 U U TO T D . 1 1 r = 1 r+1 MD A Q 1 n

MKA V1U enbU Tn1 U iIjUtn MRIVlrvAA Q7iU7 0 1 7 A J. / U A / T P \ DP / T D \ A ( l b ) =Kb ( 1 r ;

MPMKAA oin

TPTP 1 1 b=l b+1 MPMKAAQ7tUA n

TDTD 1 1 r = 1 r+1 MPA ocn MK A 73U i on loU PnMT T Ml IP bUlM 1 1 IMUL MPMK AA 0 a n 7 0 U pn Tn /ion onn 11 ni tpyt bU IU ( 1VU , ZUU , Z1U ) , 1LAI MPMKAA Q 7 A 71U 1 OA ICAW TCAV/iMDnUJ TQT7P 1 bAV= l bAV+IXKUW— 1 J lit mrMK AA onn 7 0U p n Tn 0 0 a bU 1 U ZZU MPMK AA Q Q n 7 7 U O A A zuu TCAW ICAW .MDniU TCT7P 1 bAV=l bAV+NKUW— 1 b 1 it MPMK AA 1 n n n 1 U U U Z 1 U

TD TD.MDniAl TCT7P 1 r=l r+NKUW— 1 b 1 it mrMKAA 1 ntn 1 U 1 U

O 1 A zzu PnMT

T Ml 1 P

bUN 1 1 NUL MRMKA1.UZU A 1 n 7 n TP MCYT 1 P 0\ DPTIIDM lr (ItXI.Lt.Z) KtlUKN mrNIKAIUJU a i n 7 n TYD MC TCT7P*7 1 Xr=Nb-l b lit Z MR A i n a n nn oon v 1 mdpuu UU ZoU l\=l,IMrUw MR A i n c. n Tf MID TADPC/CX 1 bAvr=l AKbb ( 5 )

MKA1UOU MP A t n a n I Mr=Nbz mrMK Aa 1 n 7 n 1 U / U tp / if pt i \ pn Tn 9in ir ( l\ . b 1 . 1 } bU IU Z i u MR A 1 A Q A TDD T A DP C / 1 \ 1 Kr=l AKbb ( 1 )

MRA 1 nQn bU IU Z40 mrNIK A11UU a 1 inn

O 1 rt 230 TDD

T ADPC f C\ IKr=lAKbb (5 )

MRA1 MKA 111U Tin

240 T\t\

nnnT 1 T (*T 7T DO 280 I=1,ISIZl MDMKAA 1 1 7 A 1 1 Z U tp 11/ T C A I/O IbAV=I5AVP MRMK AA 1 1 1 n 1 1 3 U TP 1 I b =l MR A 1 1 & n ml\ H11HU

tnTnn I R=I RP MDMKAAlien J. 1 D U TV T V PI I X= I XP MDMKAA 1 1 A n J. 1 OU

C MDMKA1A 1 1 7 n 1 / U c

1— iiip r\ Alll AT 111 Tn

TV SAVE ROW OF MATRIX MDMKAA 1 1 0 n J. loU

pb * MP

A 1 1 0 n rem A X 1 7 u nn oca 1 i tct7c UU 250 J=l , lbiit MRA1 ?nn A ( I X )=RC ( IR )

MRmK

AA 1 7 1 n 1 Z 1 U

IX=IX-1 MRA1220

174
IR=IR+NR0W MRA1230

250 CONTINUE MRA1240

DO 270 J=l , ISIZE MRA1250

IX=IXP MRA1260

IM=IMP MRA1270

DO 260 JP=1 , ISIZE MRA1280

X(IM)=A(IX)*A(IC) MRA1290

IM=IM-1 MRA1300

IX=IX-1 MRA1310

IC=IC+1 MRA1320

260 CONTINUE MRA1330

CALL SORTSM (ISIZE , SUM) MRA1340

RC(ISAV)=SUM MRA1350

ISAV=ISAV+NROW MRA1360

270 CONTINUE MRA1370

ISAVP=ISAVP+1 MRA1380

IRP=IRP+1 MRA1390

280 CONTINUE MRA1400

RETURN MRA1410

END MRA1420

175
SUBROUTINE MSCROW MSC 10

C VERSION 5.00 MSCROW 5/15/70 MSC 20

COMMON /BLOCRC/ NRC ,RC (12600) MSC 30

COMMON /BLOCKD/ I ARGS (100 )

, KIND ( 100 ), ARGTAB ( 100 ), NRMAX , NROW, NCOL ,NMSC 40

1ARGS , VWXYZ (8 ) ,NERROR MSC 50

DIMENSION ARGS(IOO) MSC 60

EQUIVALENCE (ARGS (1) ,RC (12501) ) MSC 70

COMMON /BLOCKE/ NAME (4 ), LI , L2 , ISRFLG MSC 80

C SUBROUTINE BY CARLA MESSINA 221.04 JUNE 1967 MSC 90

C TYPE 1 IS PARSUM OF COL ++ , STORE IN COL ++ MSC 100

C TYPE 2 IS PARPRODUCT OF COL ++, STORE IN COL ++ MSC 110

C TYPE 3 IS ROOT MEAN SQUARE RMS OF COL ++, STORE IN COL MSC 120

C TYPE 4 IS AVERAGE OF COL ++, STORE IN COL ++ (DOWN TO NMSC 130

C TYPE 5 IS SUM COL ++, STORE IN COL ++ (DOWN TO NRMAX) MSC 140

C SUM COL ++ FROM ROW , , TO ROW , , STORE IN COL ++ MSC 150

C SUM COL ++ FROM ROWS NUMBERED ,

, ETC STORE MSC 160

C THE THREE TYPES OF SUM ARE IDENTIFIED BY THE NO. OF NARGS =2,3 ANDMSC 170

ELEM=0.0 MSC 180

IF (NARGS-2 ) 10,40,40 MSC 190

10 K=10 MSC 200

20 CALL ERROR (K) MSC 210

30 RETURN MSC 220

40 CALL ADRESS (1,J1) MSC 230

IF (Jl) 50,50,60 MSC 240

50 K=3 MSC 250

GO TO 20 MSC 260

60 CALL ADRESS (NARGS, J2) MSC 270

IF (J2) 50,50,70 MSC 280

70 IF (NARGS-3) 210,80,80 MSC 290

80 IF (L2-5) 10,90,10 MSC 300

90 NARG1=NARGS-1 MSC 310

DO 110 I=2,NARG1 MSC 320

IF (KIND (I ) .NE.O) GO TO 130 MSC 330

IF (IARGS(I)) 130,130,100 MSC 340

100 IF (IARGS(I)-NROW) 110,110,130 MSC 350

110 CONTINUE MSC 360

IF (NERROR.NE.O) GO TO 30 MSC 370

IF (NARGS-4 ) 120,120,180 MSC 380

C MSC 390

C SUM FROM ROW ,

, TO ROW , , MSC 400

C MSC 410

120 IF (IARGS(2)-IARGS(3) ) 140,140,130 MSC 420

130 I=IARGS(2) MSC 430

IARGS(2)=IARGS(3) MSC 440

IARGS(3)=I MSC 450

140 IF (NRMAX) 150,150,160 MSC 460

150 K=9 MSC 470

GO TO 20 MSC 480

160 J=J1+IARGS(2) MSC 490

ELEM=ELEM+RC ( J-l ) MSC 500

IARGS(2)=IARGS(2)+1 MSC 510

IF (IARGS(2)-IARGS(3)) 160,160,170 MSC 520

170 CALL VECTOR (ELEM, J2) MSC 530

GO TO 30 MSC 540

180 IF (NRMAX) 150,150,190 MSC 550

C MSC 560

C SUM DISCRETE ROWS MSC 570

C MSC 580

190 DO 200 I=2,NARG1 MSC 590

176
J=J 1 + IARGS ( I

)

MSC 600

200 ELEM=ELEM+RC ( J-l

)

MSC 610

GO TO 170 MSC 620

210 IF (NERROR.NE.O) GO TO 30 MSC 630

IF (NRMAX) 150,150,220 MSC 640

220 FNRMAX=NRMAX MSC 650

C MSC 660

C PARSUM, PARPROOUCT MSC 670

C MSC 680

IF (L2-3) 230,260,280 MSC 690

230 J=L2-1 MSC 700

RC(J2)=RC(J1) MSC 710

IF (NRMAX. EQ.l) GO TO 30 MSC 720

00 250 1=2 , NRMAX MSC 730

J1=J1+1 MSC 740

J2=J2+1 MSC 750

IF (J.EQ.O) GO TO 240 MSC 760

RC(J2)=RC(J2-1)*RC(J1) MSC 770

GO TO 250 MSC 780

240 RC(J2)=RC(J2-1)+RC(J1) MSC 790

250 CONTINUE MSC 800

GO TO 30 MSC 810

C MSC 820

C RMS MSC 830

C MSC 840

260 DO 270 1=1, NRMAX MSC 850

J=J1+I MSC 860

270 ELEM=ELEM+RC(J-1)**2 MSC 870

ELEM=FSQRT (ELEM/FNRMAX) MSC 880

GO TO 170 MSC 890

C MSC 900

C AVERAGE, SUM ENTIRE COLUMN MSC 910

C MSC 920

280 DO 290 1=1, NRMAX MSC 930

J=J1+I MSC 940

290 ELEM=ELEM+RC ( J-l

)

MSC 950

IF (L2-5) 300,170,170 MSC 960

300 ELEM=ELEM/FNRMAX MSC 970

GO TO 170 MSC 980

END MSC 990

177
SUBROUTINE MTRIAN MTR 10

VERSION 5.00 MTRIAN 5/15/70 MTR 20

MTRIAN SUBROUTINE FOR OMNITAB 11/27/67 BY S PEAVY MTR 30

MTR 40

TRI ANGULARIZATION OF NON-SINGULAR, REAL SYMMETRIC MATRIX MTR 50

A=TT i LOWER TRINGLE IS COMPUTED MTR 60

COMMAND IS: MTR 70

MTRIAN A(,, ++),R=,, C=, , STORE T IN (,, ++) MTR 80

OR MTR 90

MTRIAN A(, ( ++),R=,, C=, , STORE T IN(, ( ++) AND T INVERSE (,, ++)MTR 100

THE UPPER TRIANGLE IS SET = 0 . MTR 110

MTR 120

COMMON /SCRAT/ NS , NS2 , A ( 13500 ) MTR 130

COMMON /BLOCRC/ NRC , RC ( 12600 ) MTR 140

COMMON /BLOCKD/ IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NMTR 150

1ARGS ,VWXYZ (8) ,NERROR MTR 160

DIMENSION ARGS(IOO) MTR 170

EQUIVALENCE (ARGS ( 1 ), RC (12501 )

) MTR 180

DIMENSION X(2) MTR 190

DOUBLE PRECISION X,SUM MTR 200

EQUIVALENCE (X,A) MTR 210

KRR=7 MTR 220

KRRA=7 MTR 230

KRRB=7 MTR 240

KRRC=7 MTR 250

J=2 MTR 260

IF (NARGS . EQ . 6 .OR . NARGS . EQ . 8 ) GO TO 10 MTR 270

CALL ERROR (10) MTR 280

RETURN MTR 290

IF (IARGS(3) .EQ.IARGS(4)) GO TO 20 MTR 300

CALL ERROR (KRR) MTR 310

RETURN MTR 320

IF (NARGS. EQ. 6) GO TO 30 MTR 330

J=3 MTR 340

IARGS(9)=IARGS(7) MTR 350

IARGS(10)=IARGS(8) MTR 360

IARGS(11)=IARGS(3) MTR 370

IARGS(12)=IARGS(4) MTR 380

IARGS(7)=IARGS(3) MTR 390

IARGS(8)=IARGS(4) MTR 400

CALL MTXCHK (J) MTR 410

IF (J-l) 60,40,50 MTR 420

CALL ERROR (3) MTR 430

RETURN MTR 440

CALL ERROR (17) MTR 450

RETURN MTR 460

IF (NERROR.NE.O) RETURN MTR 470

IR=IARGS(3) MTR 480

IRM=IR-1 MTR 490

K=IARGS(1) MTR 500

DO 70 1=1, IR MTR 510

IF (RC(K) .GT.O.O) GO TO 70 MTR 520

*** ERRA -MATRIX CAN NOT BE TRIANLIZED SINCE ONE OF THE TERMS ON MTR 530

THE DIAG. IS ZERO OR LESS. MTR 540

CALL ERROR (KRRA) MTR 550

RETURN MTR 560

K=K+1+NR0W MTR 570

K=IARGS(1) MTR 580

CALL SYMV (RC(K) ,NROW,IR,M) MTR 590

178
80

90

100

110

120

130

140

IF (M.LE.l) GO TO 80 MTR 600

*** NON-SYMMETRIC MATRIX MTR 610

CALL ERROR (KRRC) MTR 620

RETURN MTR 630

M=2 MTR 640

A(1)=FSQRT(RC(K)

)

MTR 650

K=K+1 MTR 660

DO 90 1=2 ,IR MTR 670

A(M)=RC(K) /A(l) MTR 680

K=K+1 MTR 690

M=M+1 MTR 700

KA=IARGS(1) MTR 710

KB=KA+NR0W+1 MTR 720

MA=2 MTR 730

DO 140 1=2, IR MTR 740

MB=MA MTR 750

L=NS2-1 MTR 760

X(NS2)=RC(KB) MTR 770

M=(I-1)*IR+I MTR 780

11=1-1 MTR 790

DO 100 J=l , 1

1

MTR 800

X(L)=-(A(MB)**2) MTR 810

L=L-1 MTR 820

MB=MB-IR MTR 830

CALL SORTSM (I, SUM) MTR 840

IF (SUM. GT. 0.0) GO TO 110 MTR 850

*** ERRB-LEADING SUBMATRIX IS SINGULAR MTR 860

CALL ERROR (KRRB) MTR 870

RETURN MTR 880

S=SUM MTR 890

S=FSQRT(S) MTR 900

A(M)=S MTR 910

M=M+1 MTR 920

IF (I.EQ.IR) GO TO 140 MTR 930

IP=I+1 MTR 940

KC=KB+1 MTR 950

DO 130 J=IP,IR MTR 960

X(NS2)=RC(KC) MTR 970

KC=KC+1 MTR 980

L=NS2-1 MTR 990

MC=J MTR1000

MD=I MTR1010

DO 120 JJ=1,II MTR1020

X(L)=-A(MC)*A(MD) MTR1030

MC=MC+IR MTR1040

MD=MD+IR MTR1050

L=L-1 MTR1060

CALL SORTSM (I, SUM) MTR1070

A(M)=SUM/S MTR1080

M=M+1 MTR1090

MA=MA+IR+1 MTR1100

KB=KB+NR0W+1 MTR1110

K=IARGS(5)-1 MTR1120

KB=IARGS(5) MTR1130

DO 180 1=1 , IR MTR1140

KA=K+I MTR1150

M=(I-1)*IR+I MTR1160

KC=KB MTR1170

DO 150 J=I,IR MTR1180

179
RC(KA)=A(M)

KA=KA+1

150 M=M+1

IF (I.EQ.l) GO TO 170

11=1-1

DO 160 J=l , 1 1

RC(KC)=0.0

160 KC=KC+1

170 KB=KB+NROW

180 K=K+NROW

IF (NARGS.EQ.6) RETURN

KC=IARGS(5)

DO 210 1=1 , IR

M=(I-1)*IR+I

A(M)=1.0/RC(KC)

IF (I .EQ.IR) GO TO 210

M=M+1

IP=I+1

KB=KC+NR0W+1

JC=1

DO 200 J=IP,IR

KA=KC+J-I

MA=(I-1)*IR+I

L=NS2

DO 190 JA=1,JC

X(L)=RC(KA)*A(MA)

MA=MA+1

KA=KA+NROW

190 L=L-1

CALL SORTSM (JC,SUM)

S=SUM

A(M)=-S/RC(KB)

KB=KB+NR0W+1

M=M+1

200 JC=JC+1

210 KC=KC+NR0W+1

K=IARGS(9)-1

KB=IARGS(9)

DO 250 1=1 , IR

KA=K+I

W=(I-1)*IR+I

KC=KB

DO 220 J=I,XR

RC(KA)=A(M)

KA=KA+1

220 W=M+1

IF (I.EQ.l) GO TO 240

11=1-1

DO 230 J=1,II

RC(KC)=0.

230 KC=KC+1

240 KB=KB+NROW

250 K=K+NROW

RETURN

END

MTR1190

MTR1200

MTR1210

MTR1220

MTR1230

MTR1240

MTR1250

MTR1260

MTR1270

MTR1280

MTR1290

MTR1300

MTR1310

MTR1320

MTR1330

MTR1340

MTR1350

MTR1360

MTR1370

MTR1380

MTR1390

MTR1400

MTR1410

MTR1420

MTR1430

MTR1440

MTR1450

MTR1460

MTR1470

MTR1480

MTR1490

MTR1500

MTR1510

MTR1520

MTR1530

MTR1540

MTR1550

MTR1560

MTR1570

MTR1580

MTR1590

MTR1600

MTR1610

MTR1620

MTR1630

MTR1640

MTR1650

MTR1660

MTR1670

MTR1680

MTR1690

MTR1700

MTR1710

MTR1720

MTR1730

180
cc

cc

c

c

c

cc

c

c

cc

c

c

10

20

30

SUBROUTINE MTXCHK (J)

VERSION 5.00 MTXCHK 5/15/70

S PEAVY FOR OMNITAB 10/24/67

J AS INPUT = NO OF MATRICES TO BE CHECKED

IARGS(l) , IARGS(5) IARGS (4* (J-l ) +1

)

IARGS(2) , IARGS (6) , IARGS (4* (J-D+2)

LARGS (3), IARGS(7), IARGS (4* (J-l )+3 ) NO. OF ROWS

IARGS(4), IARGS(8) IARGS (4* (J-l ) +4 ) NO OF COLUMNS

STARTING ROW OF MAT

STARTING COLUMN OF MAT

MCK

MCK

MCK

MCK

MCK

MCK

MCK

MCK

MCK

10

20

30

40

50

60

70

80

90

UPON RETURN

J=0 IF ALL MATRICES ARE IN WORK SHEET

AND

IARGS(l) ,IARGS(5) , IARGS (4* (J-l )+l ) WILL CONTAIN STARTING

ADDRESS OF MATRIX

J GT ZERO IF MATRIX IS NOT IN WORK SHEET

J=l SOME IARGS ARE NEGATIVE, J=2 MATRIX TO BIG FOR WORK SHEET

COMMON /BLOCKD / IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX , NROW, NCOL

,

1ARGS,VWXYZ(8) ,NERROR

JA=J

JB=4*J

J=0

DO 10 1=1 , JB

IF (IARGS(I) .GT.O) GO TO 10

J=l

RETURN

CONTINUE

DO 20 1=1, JB,

4

IF (IARGS(I)+IARGS(I+2)-l.GT.NR0W) GO TO 30

IF (IARGS(I+l)+IARGS(I+3)-l.GT.NC0L) GO TO 30

IARGS ( I

) =1 ARGS ( I ) + (IARGS ( I +1 ) -1 ) *NROW

RETURN

J=2

RETURN

END

MCK 100

MCK 110

MCK 120

MCK 130

MCK

MCK

MCK

NMCK

140

150

160

180

MCK 190

MCK 220

MCK 230

MCK 240

MCK 250

MCK 260

MCK 270

MCK 280

MCK 290

MCK 300

MCK 310

MCK 320

MCK 330

MCK 340

MCK 350

MCK 360

MCK 370

181
SUBROUTINE MXTX

VERSION 5.00 MXTX 5/15/70

SUBROUTINE MXTX R.V. 5/7/68

SUBROUTINE TO MULTIPLY MATRIX A BY ITS TRANSPOSE

OR TRANSPOSE OF MATRIX A BY MATRIX A

L2=l MULTIPLY MATRIX BY ITS TRANSPOSE

GENERAL FORM OF COMMAND

M(XXT) A(.) N,K, STORE IN C( ( ) N,K DEFINE X

L2=2 MULTIPLY TRANSPOSE OF MATRIX BY ITSELF

GENERAL FORM OF COMMAD

M(XTX) A(,) N,K STORE IN C(,) N,K DEFINE X

*COMMON /SCRAT/ NS ,NS2 ,A (13500)

COMMON /BLOCRC/ NRC , RC ( 12600

)

COMMON /BLOCKD / I ARGS ( 100 ) ,KIND ( 100 )

, ARGTAB ( 100 )

, NRMAX , NROW.NCOL

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )

)

COMMON /BLOCKE / NAME (4) ,L1 ,L2 , ISRFLG

DOUBLE PRECISION AP(3000)

EQUIVALENCE (A,AP)

*CHECK FOR CORRECT NUMBER OF AGRUMENTS

*

*DECIDE WHETHER COMMAND IS M(XAX') OR M(X'AX)

L2=3 MEANS M(XAX') L2=2 NARGS.GT. 6 MEANS M(X'AX)

*

IF (L2-2) 30,10,20

IF (NARGS.LE.6) GO TO 30

L2=4-L2

CALL TRANSF

RETURN

IF (NARGS .NE .6) CALL ERROR (10)

*CHECK TO SEE IF ALL ARGUMENTS ARE INTEGERS

*J=NARGS

CALL CKIND (J)

IF (J.NE.O) CALL ERROR (3)

*CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE

COMPUTE ADDRESSES

*GO TO (50,60) , L2

IARGS(8)=IARGS(3)

IARGS(7)=IARGS(3)

GO TO 70

IARGS(8)=IARGS(4)

IARGS(7)=IARGS(4)

J=2

CALL MTXCHK (J)

IF (J-l) 100,80,90

CALL ERROR (3)

RETURN

CALL ERROR (17)

RETURN

MXT

MXT

MXT

MXT

MXT

MXT

MXT

MXT

MXT

10

20

30

40

50

60

70

80

90

MXT 110

MXT 120

MXT 130

MXT 150

MXT 160

MXT 170

, NMXT 180

MXT 190

MXT 200

MXT 210

MXT 220

MXT 230

MXT 240

MXT 250

MXT 260

MXT 270

MXT 280

MXT 290

MXT 300

MXT 310

MXT 320

MXT 330

MXT 340

MXT 350

MXT 360

MXT 370

MXT 380

MXT 390

MXT 400

MXT 410

MXT 420

MXT 430

MXT 440

MXT 450

MXT 460

MXT 470

MXT 520

MXT 530

MXT 540

MXT 550

MXT 560

MXT 570

MXT 580

MXT 590

MXT 600

MXT 610

MXT 620

MXT 630

MXT 640

MXT 650

182
C CHECK FOR PREVIOUS ERRORS MXT 660

C * MXT 670

100 IF (NERROR.NE.O) RETURN MXT 680

IG=IARGS(1) MXT 690

CALL MXTXP (RC(IG) ,NROW, IARGS (3 ) ,IARGS(4) ,A ,L2 ,NS2 , AP) MXT 700

GO TO (110,120) , L2 MXT 710

110 NR0WP=IARGS(3) MXT 720

GO TO 130 MXT 730

120 NR0WP=IARGS(4) MXT 740

130 NCOLP=NROWP MXT 750

IG=IARGS(5) MXT 760

CALL STORMT (RC(IG) ,NROW,NROWP ,NCOLP , A) MXT 770

C * MXT 780

C MOVE FROM SCRATCH AREA TO STORAGE MXT 790

C * MXT 800

RETURN MXT 810

END MXT 820

183
CIIDDAIITTKIC HVT VD /V Al HID 1/ A 1 O Al A C ? *7 P* VA\ SUBROUTINt MXTXP ( X , N , NP , K , A , L2 , NAS 1 ZE , XP

)

AAV D MXP 10

c l/COC T All C A A ft 1 V TVD c/ir*TA VERSION 5.00 MXTXP 5/15/70 ftIV D MXP O A 20

c fimnAiiTTiir aiv T v A a ti t ntirn , n </••-, SUBROUTINE MXTXP R VARNER 2/12/68 o i w A MXP 30

c

a, 1 w p. MXP 40

c

v/ t <~ in ti t \/ t a a r

-

i if r n X IS MATLIX TO BE USED AIV A MXP 50

c

ki t r* at ur nr t Aiirn p* t t r* ap a N IS DIMENSIONED SIZE OF A MXP 60

c

* i r\ t c bill un r

- r> at n a uip" y m a NP IS NUMBER OF ROWS IN A

i|y r\ MXP 70

c

1/ t P" (LI 1 1 tin r* n AT A A 1 II Alii C T Al A K IS NUMBER OF COLUMNS IN A MXP 80

c

1 O 1 All 1 1 Ttni U V T T uc c v td incnAccn L2=l MULTIPLY X TIMES X TRANSPOSED AIV D MXP A A 90

c

"i *» kai ii x t r> i \/ \/ miiif nAfrn tt Air* c v L2=2 MULTIPLY X TRANSPOSED TIMES X uv a MXP 100

c

Al A P" T T P* T C r T T T AP" A ATI/TATA AW *\ NASIZE IS SIZE OF A DIVIDED BY 2 MXP 110

c

A TP* P

1 A A A T A 1 1 A A P" A till irAP III Tfi 7 U TP* T A AP" P* T A A P" A A IS SCRATCH AREA WHERE MATRIX IS TO BE STORED MXP 120

ac

* ||w r\ MXP 130

AAiioi r DDCATCTAM VD CI III UUUbLt PKtLlblUN XP,bUM AIV D MXP 140

A T lirilC T All V / Al i \ & / i \ w r\ / t » DIMENSION X(N,1), A(l), XP(1) MXP 150

T A 1 I C=l MXP 160

A A T A / ^ A a s\ \ i a GO TO (10 ,40) , L2 t aw A MXP 170

c

AAA1AIITP* V T T lir f \J T A A IIT AATm COMPUTE X TIMES X TRANSPOSED ft IV/ A MXP 180

C

ft iw pj MXP 190

10 AA OA 1/1/ 1 AIA DO 30 KK=1,NP AIV D MXP O A A 200

AA OA T 1 Al A DO 30 I=1,NP |w p» MXP 210

TP" AIACTTP* IS=NASIZE AIV A MXP 220

UU 20 J=l ,K AIV D MXP 1 1 A 230

v/ft / T P \ V / T I \ * w / i/ i/ iv XP(IS)=X(I , J

) *X (KK , J

)

AIV A MXP 240

T C T C 1 AIV D MXP OCA 250

OJtl 1 CrtDTCII /I/ CI III

\

CALL SOKISM (K,SUM) AIV D MXP A / A 260

A / T A \ C 1 1 Al A ( IC )=SUM AIV D MXP 270

30 T A T A 1 IC=IC+1 AIV D MXP A A 280

RETURN AAV A MXP 290

C

AIV D MXP O A A 300

c

A A AAA 1 1 T P* w TAAAIP"AAP"P"A TT A IP" P* V/ COMPUTE X TRANSPOSED TIMES XAAV A MXP OTA 310

pvc MXP O O A 320

40 A A / r\ 1 1 W DO 60 L=1,K MXP O O A 330

A A / r\ i / DO 60 J=1,K IIV O MXP O il A 340

TC 1I1CT7C Ib=NASIZE MXr 350

riA cA T 1 11

D

DU 50 1=1 , NP MY D Mat 1 L f\ 360

V A / T P* \ v/ / T V i T 1 \ XP ( IS )=X ( I ,J)*X(I ,L) iiv n MXP OTA 370

50 TP" TP" T I S=I S-l IIV D MXr 380

AAI 1 CADTCH /AID C 1 1 il \ CALL SORTSM (NP,SUM) MV D MXr 390

A / T A \ P* 1 1 AA A ( IC )=SUM IIV D MXP AAA 400

60 T A T A 1 I C=I C+l MXP il 1 A 410

r*t i- tt i r\ ft i RETURN AIV A MXP 420

END MXP 430

184
SUBROUTINE NNAME (NAME) NNA 10

c VERSION 5.00 NNAME 5/15/70 NNA 20

COMMON /BLOCKA/ MODE , M, KARD (83 ) ,KARG , ARG , ARG2 , NEWCD (80 ), KRDEND NNA 30

DIMENSION NAME (2

)

, MISC(6) NNA 40

c NNA 50

c THIS SUBROUTINE ASSEMBLES A NAME UP TO THE FIRST NON-LETTER OR UP NNA 60

c SIX LETTER, WHICHEVER IS FIRST. THE INDEX, M, IS INITIALLY POINTINNNA 70

c THE FIRST LETTER, IT IS LEFT POINTING AT THE FIRST NON -LETTER

.

NNA 80

c NNA 90

c SPACE OUT SO THAT TABLE LIES ALL ON ONE PAGE NNA 100

c NNA 110

c NNA 120

c CONVERSION TABLE FOR ALPHABETIC TO NUMERIC AS USED BY OMNITAB. NNA 130

c NNA 140

c A 729 27 1 NNA 150

c B 1458 54 2 NNA 160

c C 2187 81 3 NNA 170

c D 2916 108 4 NNA 180

c E 3645 135 5 NNA 190

c F 4374 162 6 NNA 200

c G 5103 189 7 NNA 210

c H 5832 216 8 NNA 220

c I 6561 243 9 NNA 230

c J 7290 270 10 NNA 240

c K 8019 297 11 NNA 250

c L 8748 324 12 NNA 260

c M 9477 351 13 NNA 270

c N 10206 378 14 NNA 280

c 0 10935 405 15 NNA 290

c P 11664 432 16 NNA 300

c Q 12393 459 17 NNA 310

c R 13122 486 18 NNA 320

c S 13851 513 19 NNA 330

c T 14580 540 20 NNA 340

c U 15309 567 21 NNA 350

c V 16038 594 22 NNA 360

c w 16767 621 23 NNA 370

c X 17496 648 24 NNA 380

c Y 18225 675 25 NNA 390

c Z 18954 702 26 NNA 400

c NNA 410

c NNA 420

c THE FIRST THREE CHARACTERS GO INTO THE FIRST WORD OF NAME NNA 430

c THE SECOND THREE CHARACTERS GO INTO THE SECOND WORD OF NAME NNA 440

c NNA 450

c NNA 460

DO 10 1=1,6 NNA 470

10 MISC (I )=0

DO 20 1=1,6

L=KARD (M)-9

NNA

NNA

NNA

480

490

500

IF (L.LT.l.OR.L.GE .27) GO TO 40 NNA 510

MISC(I)=L NNA 520

20 M=M+1 NNA 530

30 IF (KARD (M) .LT.10.

M=M+1

GO TO 30

OR .KARD (M) .GE.36) GO TO 40 NNA

NNA

NNA

540

550

560

40 NAME(l)=MISC(3)+27

NAME(2)=MISC(6)+27

*(MISC(2)+27*MISC(1))

*(MISC(5)+27*MISC(4))

NNA

NNA

570

580

RETURN NNA 590

END

185

NNA 600
FUNCTION NONBLA (I) NON 10

C VERSION 5.00 NONBLA 5/15/70 NON 20

C NON 30

C SCAN KARO STARTING AT KARO(I) UNTIL A NON-BLANK CHARACTER IS NON 40

C FOUND. POINT M AT IT AND ALSO RETURN IT AS FUNCTION VALUE. NON 50

COMMON /BLOCKA/ MODE ,M,KARD (83 ) ,KARG , ARG , ARG2 ,NEWCD (80 ) ,KRDEND NON 60

M=I NON 70

10 IF (KARD(M) .NE.44) GO TO 20 NON 80

M=M+1 NON 90

GO TO 10 NON 100

20 NONBLA=KARD (M) NON 110

RETURN NON 120

END NON 130

SUBROUTINE NOTEPR(J) NOT 10

C VERSION 5.00 NOTEPR 5/15/70 NOT 20

C WRITTEN BY STP 4/21/70 NOT 30

C NOT 40

C IF J=0 BLANK OUT NOTE VARIABLE NOT 50

C IF J=l STORE IN NOTE(l) THRU N0TE(60) FROM NEWCD (M-2) 60 CHAR NOT 60

C IF J=2 STORE IN N0TE(61) THRU N0TE(120) FROM NEWCD (M-2) 60 CHAR NOT 70

C IF J=3 PRINT OUT NOTE(l) THRU N0TE(120) NOT 80

C NOT 90

COMMON /BLOCKA /MODE , M,KARD (83 ), KARG , ARG ,ARG2 , NEWCD (80 ) ,KRDEND NOT 100

COMMON/HEADER/NOCARD (80) ,ITLE(60,6) , LNCNT , IPRINT ( NPAGE , I PUNCH NOT 110

C0MM0N/N0TE/N0TE(120) NOT 120

DATA IBLANK/1H / NOT 130

IF (J.NE.O) GO TO 20 NOT 140

DO 10 1=1,120 NOT 150

10 NOTE ( I )=IBLANK NOT 160

RETURN NOT 170

20 IF(J.NE.3) GO TO 40 NOT 180

IF(NPAGE.EQ.O) CALL PAGE(O) NOT 190

WRITE (IPRINT, 30) (NOTE ( I )

, 1=2 , 120 ) NOT 200

RETURN NOT 210

30 F0RMAT(1X,119A1) NOT 220

40 MA=M+60 NOT 230

M=M+1 NOT 240

IF(MA.GT.82) MA=82 NOT 250

MB=(J-1)*60+1 NOT 260

MC=MB+59 NOT 270

IF (J .NE.l.AND.J .NE.2) RETURN NOT 280

DO 100 I=MB,MC NOT 290

100 NOTE ( I )=IBLANK NOT 300

I=MB NOT 310

DO 110 IC=M,MA NOT 320

N0TE(I)=NEWCD(IC-2) NOT 330

110 1=1+1 NOT 340

RETURN NOT 350

END NOT 360

186
SUBROUTINE OANOVA (YSUM, SU , ND9 , FM, M,N , ND7 , SSQ , IHC , NSU , B

)

0AN 10

c VERSION 5.00 OANOVA 5/15/70 0AN 20

c COMPUTE AND PRINT ANALYSIS OF VARIANCE 0AN 30

c WRITTEN BY DAVID HOGBEN , SEL, NBS . 10/09/69. 0AN 40

c ***** 0AN 50

COMMON /BLOCKD/ I ARGS ( 100) , KIND (100) ,ARGTAB (100) , NRMAX , NROW , NCOL

,

0AN 60

1NARGS,VWXYZ(8) ,NERROR 0AN 70

COMMON/BLOCKE/NAME (4 ) ,L1 ,L2 , ISRFLG 0AN 90

COMMON/HEADER /NOCARD (80) ,ITLF.(60,6) , LNCNT , I PR I NT ,NP AGE , I PUNCH 0AN 100

COMMON /SCR AT / NS ,NS2 , A (13500) 0AN 110

n t tir ii r t aii ft / > t i i a * * . DIMENSION B(l) , IHC ( 1

)

0AN 160

r\ A i 1 n i r— ft A. r~ /> T C T A •. 1 w r 1 1 11 DOUBLE PRECISION YSUM 0AN 170

c

**r *•T* *t* *T * 0AN 180

1850 r\ r~ c j ir \< r m n i n i RESMS = YSUM/SU OAN 190

NSUA = NSU 0AN 200

IT = 1 OAN 210

IF (L2.EQ.3) IT=3 OAN 220

III A T TP / T nn T llT i a / a i 1 IIA f T T t tiiA / it •% \ WRITE ( IPRINT , 1860 ) IHC (IT) , IHC (IT+1) OAN 230

1860 rAniii t / / / / / r ft u ft ft 1 1 i ii it i \i c 7 c a r~ vi a n t i n/>r / a 4 v/ tftii hrnrnnrnT FORMAT ( / / / /50X , 20HANALYSIS OF VARIANCE/24X , 73H-DEPENDENT ON 0RDER0AN 240

1 VARIABLES ARE ENTERED, UNLESS VECTORS ARE ORTHOGONAL-// OAN 250

A 1 \/ A -> « w a i | | f* A p\ r f\ r\ 1 I r T A A A IT" i- aim a i i ii iia 21X,2A3,4X, 21H SS=RED . DUE TO C0EF.,21H CUM. MS REDUCTI00AN 260

ifci /II r\ r~ a ^ 1 1 a i in nrr t mi a i nr / r\ r* t n n n r / A apt 3N ,6H D.F.,21H CUM. RESIDUAL MS ,6H D.F.,11H F(C0EF= ft \ >ii =0) ,6H ft A A li POAN 270

4(F), 11H F (C0EFS=0 )

, 6H P(F)/) OAN 280

IND9 = ND9+M a i II OAN 290

A C 1 1 1J A A AbUM =0.0 All! OAN 300

tin CM C 11 VR = SU-FM OAN 340

RESSS = VR*SSQ OAN 350

T lim || A *T | J IND7 = ND7+M OAN 400

A(IND7) = RESSS OAN 410

TP" / n T~ ft t \ A A T A ift// IF(M.EQ.l) GO TO 1866 A | || OAN 415

A A i A / C* T 1 A ftfl DO 1865 11=2,

M

OAN 420

IND7 = IND7-1 OAN 430

a / t iirt \ i / t im^ t \ a / tiiaa \ A(IND7) = A(IND7+1) + A(IND9) OAN 440

1865 i Hf\ a t iir\ a n IND9 = IND9-1 OAN 450

1866 \i i r ft r |i i a V1F2 = FM+1 .

0

OAN 460

B(l) = A(IND9-1) OAN 470

B(2) = A(IND9-2) OAN 480

1 i T II ft A n » \ / A 1 1 1 1 A(IND9-1) = YSUM OAN 482

1 t V II ft ^fc A * P*i frTM AAA A(IND9-2) = RESSS ClAW 484

A II 1 A A ft 1 l"P s 1 ' T Q 1 A A M, V 1 ft ft ft II lif 1 | 1 |7%, f .ft « * ft A , *1 » A , ^ . A A % CALL RF0RMT (A ( IND9-2 )

, M+2 , 8 , NW1 , NDECl , 18 , A (1 ), A ( 1 )

, 0 , 0

)

OAN 490

A(IND9-1) = B(l) OAN 492

A(IND9-2) = B(2) OAN 494

A M | £ A |— A ft | il / Til ft A l II ft II III A 1 1 ft A ft ft > ft | / n i 1 , « . — A \ CALL RF0RMT (A ( IND9) ,M, 8 ,NW2 ,NDEC2 , 18 , A (1 ) ,A(1) ,0,0) OAN 496

SSU=SU OAN 498

DO 1867 1=1,

M

OAN 500

A A | | A A | 1 — *\ SSU=SSU-1 .0 OAN 505

B(I)=A(IND7) /SSU OAN 510

1867 IND7=IND7+1 OAN 515

IND7=IND7-M OAN 520

CALL RF0RMT (B (1 )

, M, 8 ,NW3 ,NDEC3 , 18 , A (1) ,A(1) ,0,0) OAN 525

SSU = SU OAN 530

DO 1950 1=1,

M

OAN 540

NSUA = NSUA-1 OAN 550

ASUM = ASUM+A(IND9) OAN 560

SSU = SSU-1.0 OAN 570

CR = ASUM/FL0AT(I) OAN 580

IF (ABS(SSU) .GT.0.0) GO TO 1880 OAN 590

RESMS =0.0 OAN 600

1870 Fl = 0.0 OAN 610

187
F2 = 0.0 0AN 620

PF1 =1.0 0AN 630

PF2 =1.0 0AN 640

A T A T A A A GO TO 1890 A 1 II OAN /FA 650

1880 RESMS = A ( IND7 ) /SSU 0AN 660

V1F2 = V1F2-1 .

0

OAN 670

IF (ABS (RESMS) .LE .0 .0) GO TO 1870 OAN 680

A

C Mrijrn nAAl NEVtK POOL A A AI UAN Z A A 690

p- 1 / T llf\ A \ /AAA Fl = A ( IND9 ) /SSQ A A AI OAN 700

CALL PR0B (1 . , VR , Fl ,PF1

)

A A AI OAN 710

AC TEST HIGHER SUB-HYPOTHESES A 111 OAN T A/V 720

p* a / f i / t kii\7 \ t / t kin n \ nrp r f \ iwi \ / <* a a F2 = ( (A ( IND7 ) +A ( IND9 ) -RESSS ) /V1F2 ) /SSQ A A AI OAN 730

Aiii n n n n ft/i ro w a, p" a n r* a \ CALL PROB (V1F2 ,VR ,F2 ,PF2) A A AI OAN 740

1890 TT T A PI A / T 1 \ II = IABS(I-l) A 1 II OAN 750

a i i i n r A n iit s a / i v i a n un n i\ r A i a « / t ti f\ a \ n / i\ a i n tun n \ CALL RF0RMT (A (1 )

, 1 , 8 , NW1 ,NDEC1 , 0 , A ( IND9 )

, B ( 1),21-NW1,1) A A AI OAN 760

a i i i n i~ a n bat / a / t \ i a a i til iinrA a a a r* n / a a \ -» ai hi a ^ > CALL RFORMT ( A ( 1 )

, 1 , 8 , NW2 , NDEC2 , 0 , CR , B (22 ), 21-NW2 , 1

)

A A AI OAN 770

a a i i n r* A ri a at / a / i \ i r» ai mi *i n r\ r a o /% n r* <~ a *r a / /i *» \ ai ii mi a -s \ CALL RFORMT (A ( 1 )

, 1 , 8 , NW3 , NDEC3 , 0 , RESMS , B (43 ), 21-NW3 , 1

)

A A AI OAN 780

t (— / i a r* A i \ a f\ t A i n i n IF (L2.EQ.1) GO TO 1920 A A AI OAN T A A 790

WRITE (IPRINT , 1900) I ARGS ( 1+3 ) , (B ( 1 1 )

, 1 1=1 , 42 )

, I , (B ( 1 2 ),

1

2- AO e *t \ AAAI =43 ,63) ,0AN 800

i ai f* 1 1 a r~ i Pi i~ *i r"A r\ r" a 1NSUA , Fl ,PF1 ,F2 ,PF2 A A AI OAN 810

1900 FORMAT (1X,I4,6X,42A1 < I6,21A1,I6,2(0PF11.3,F6.3)) OAN 820

A T A 1 A /• A GO TO 1940 A A AI OAN 830

1920 WRITE ( IPRINT , 1900 ) 1 1 , (B ( 1 1 )

, 1 1=1 ,42 ), I , (B ( 12 ), 1 2=43 , 63

)

, OAN 840

i ai f 1 1 a t~ i a P" i r~ a r*p"A 1NSUA,F1,PF1,F2,PF2 A A II OAN 850

1940 IND7 = IND7+1 A A AI OAN 860

1950 T AI A A T kin A 1 IND9 = IND9+1 A A AI OAN 870

1951 r An in t /t i \j i Aimrr t nn i i i a ^ <\ n \j t / \ FORMAT (/ , IX , 10HRESIDUAL ,21A1 ,21X , 16)

A A AI OAN 880

1952 r~ A A I M A TT i V/ ^ /Nil T A t* AI j"s n A % /\ « \/ T S \ FORMAT (IX, 10HT0TAL ,21A1 ,21X, 16) OAN 890

r- ^ r» r* f a a Fl = RESSS A A AI OAN 900

Aii nrrtn a it / a / -a \ i a ai iqi i a i n f" a i a r*i D / i \ ai III ill i i\ CALL RFORMT (A ( 1 )

, 1 , 8 ,NW1 ,NDEC1 , 0 , Fl B ( 1 )

, 21-NW1 , 1

)

A A fcl OAN A 1 A 910

Ifll A T T r~ / THAT IIT i r\ r t \ / A / T \ T ^ <1 1 \ AlAIIA WRITE ( IPRINT , 1951 ) (B ( I )

, 1=1 , 21 )

, NSUA A A AI OAN 920

ir~ a v/ n 111 F2 = YSUM A A AI OAN A O A 930

A A | 1 A r* A n KIT / A y 1 v 1 A LI1U1 fclftTP 1 A E" A D/i\ AI AI IIM 1\ CALL RFORMT (A ( 1 )

, 1 , 8 , NW1 ,NDEC1 , 0 , F2 ,B ( 1 )

, 21-NW1 , 1

)

UAN A A A 940

III A T T A1 / T A A T IIT 1 r <*> \ / A / T \ T TI A1\ Riri I WRITE ( IPRINT , 1952 ) (B ( I )

, 1=1 , 21 )

, NSU A A AI OAN 950

RETURN A A II OAN 960

END OAN 970

188
SUBROUTINE OCOEFF (Ml , N , ND18 , ND17 , IND19S , IND18S , IHC , B , IND7S , NSU , SSOCO 10

1 ,SSOLD,YSUM) 0C0 20

c VERSION 5.00 OCOEFF 5/15/70 OCO 30

c WRITTEN BY DAVID HOGBEN , SEL, NBS . 10/14/69. 0C0 40

c

s|e $ * $ * OCO 50

C0MM0N/BL0CKD/IARGS(100) .KIND(IOO) ,ARGTAB(100) ,NRMAX ,NROW,NCOL

,

OCO 60

1NARGS,VWXYZ(8) ,NERROR OCO 70

COMMON /BLOCKE /NAME (4) , LI , L2 , I SRFLG AAA OCO 90

COMMON /HEADER /NOCARD (80 )

, ITLE (60 , 6 ), LNCNT , I PR INT , NPAGE , IPUNCH OCO 100

COMMON /SCRAT/NS,NS2 , A (13500) OCO 110

DIMENSION B(l) , IHC (1

)

OCO 160

DOUBLE PRECISION YSUM OCO 165

c

$ $ $ $ $ OCO 170

IT = 1 OCO 180

IF (L2.EQ.3) IT=3 OCO 190

M = Ml+1 OCO 200

WRITE (IPRINT , 1960) IHC ( IT )

, IHC ( IT+1 ), IHC ( IT ), IHC ( IT+1

)

OCO 210

1960 FORMAT (////20X,32HESTIMATES FROM LEAST SQUARES FIT , 38X , 18HFIT OMIOCO 220

1TTING LAST , 2A3 / /IX , 2 A3 , 5X , 11HC0EFFICIENT , 8X , 14HS . D . OF COEFF . ,4X ,0C0 230

25HRATT0 1?H*APP HTRTT^ QY 1 1 HPflFFF T P T FNT 7Y ldH^ n DF PflFFF L»ucr r npn 240

icy CUD AT T fi / \ nrn 250

TINDUS kin 1 Q = M.KlDIQil IM+NUlo+1 nnn 260

Turn 7 urn 7 , i J.IMU1/ = NU 1 / + i UL-U 270

UL-U 280

t un io iMm oc , i UL-U 290

t wr»7 t wri7C . i 1 IMU / = 1 NV 1 o + i npn ULU 300

t ALL KrUKMI ( A ( 1IMUJ.7 ) , Ml+1 , 0 , NW1 , NUtvl , 10 , A ( 1 ) , A ( 1 ) , U , 0 ) OCO 310

n A 1 1 DTAD UT / A / T M fl 1 \ 111.1 O Kl W 1 linrp*! to A/1\ A/1\ n n\ LALL KrUKMI (A(1NU1 )

, Ml + 1 , 8 , NWZ , NDLL2 , 18 , A ( 1 )

, A ( 1 )

, 0 , 0

)

OCO 320

TC /111 fA A \ A f\ T f\ A A A C

1 r (Ml . tQ . 0 ) bU 1 U 2005 OCO 330

oai I nrnn ijt /A / t m m o \ kit o 11 ui o iinroo i o a / 1 \ a / i \ a a \ LALL KhOKMI (A ( 1ND18 )

, Ml ,8,NW3,NDtL3,18,A(l) , A ( 1 ) ,0,0) OCO 340

a A I l nrnn ijt / a / Tlinn \ Hi o m m a mnrP/i i o A/i\ a / i \ a a \ CALL RFORMT (A(IND17),M1 , 8 , NW4 , NDEC4 , 18 , A ( 1 )

, A ( 1 ) , 0 , 0

)

OCO 350

UU 2000 J=l , Ml OCO 360

TC /A / TllfM \ \ T A O A 1 A O 1 t a a a lr (A(1NU1)) 1982,1981,1982 OCO 370

1981 r 1 = 0.0 OCO 380

GO TO 1983 OCO 390

1982 Fl = A ( IND19 ) /A ( IND1

)

OCO 400

1983 Tr / A / TMIM 7 \ \ 1 A O C 1 A O A 1 A O T lr (A(1NU17)) 1985,1984,1985 OCO 410

1984 F2 = 0.0 OCO 420

GO TO 1986 OCO 430

1985 F2 = A(IND18) /A(IND17) OCO 440

1986 CALL RFORMT (A ( 1 )

, 1 , 8 , NW1 , NDECl , 0 , A ( IND19 )

, B ( 1 )

, 20-NW1 , 1

)

OCO 450

CALL RFORMT (A (1 ) ,1,8 ,NW2 ,NDEC2 , 0 , A ( INDl ), B (21 ), 20-NW2 , 1

)

OCO 460

CALL RFORMT (A ( 1 ), 1 , 8 ,NW3 , NDEC3 , 0 , A ( IND18 ), B (41 ), 20-NW3 , 1

)

OCO 470

CALL RFORMT (A ( 1 ), 1 , 8 , NW4 , NDEC4 , 0 , A ( IND17 )

, B (61 ), 20-NW4 , 1

)

OCO 480

JJ = L2/3 OCO 490

JJ = IABS(J-1)*(1-JJ)+IARGS(J+3)*JJ OCO 500

WRITE (IPRINT, 1990) J J , (B ( 1 1 )

, 1 1=1 , 40 ), Fl , A ( IND7 ) , (B ( 12 )

, 12=41,80)0C0 510

1.F2 OCO 520

1990 FORMAT (1X,I4,2X, 40A1 , 0PF7 . 2 , 6X , F5 . 2 , 8X , 40A1 , F7 . 2

)

OCO 530

IND7 = IND7+1 OCO 540

IND19 = IND19+1 OCO 550

IND17 = IND17+1 OCO 560

INDl = IND1+1 OCO 570

2000 IND18 = IND18+1 OCO 580

2005 CALL RFORMT (A ( 1 ), 1 , 8 , NW1 , NDECl , 0 , A ( IND19 ), B ( 1 ), 20-NW1 , 1

)

OCO 590

CALL RFORMT (A ( 1 )

, 1 , 8 , NW2 ,NDEC2 , 0 , A ( INDl ), B (21 )

, 20-NW2 , 1

)

OCO 600

Fl = A(IND19) /A(IND1 ) OCO 610

NSUA = NSU-M OCO 620

NRM1= NSU-M1 OCO 630

189
II _ 1 9 / % npn AAfl

II — TAR^fM"l\*M 1 1 \ x T ARft^ f Ml j.4 ^ * 1 1 npn OjU /L C fl WRTTF fTPRTNT lQQfl) 11 / R r T \ T_i Afll Fl AfTNr)71 npn AAfl 0 0 U p ai i ucnuiuiT f Q^ni n i q nu/9 NfiFP9 i a a m i ami n n\ npn A7fl

D (K ) =JJ npn A 7 9 P AO MKT FOR Ml—

n

u aujuji run ivii=u npn A0/47 A

t

f

i mi mf ni nn t n ?noq, npn A7 A O / O

R/c?\ _ Y^IIM/FI flAT (Nl npn A7fl 0/0

d/co\ _ p cnRT f R

f

r 9 i

i

npn ton oou

ifino PAII RFDP MT ( R ( 1 9 \ 1 fl M IN A N n F P A 1 fl Afll Afll fl fl 1 npn Afl9 PAII RFflRMT 1 A f 1 1 1 fl NU/9 MHFP9 fl QQni H Rm 9(1 NU/9 m npn 0 7 U PAII R F H R MT f A f 1 1 1 fl N U/A N fl F P A fl D / c 9 \ R / 51 \ in M UM n \ npn 7flfl WRITE (IPRINT,2010) (B(I) ,1=1,40) , NSU , M, NSUA , NSU , Ml ,NRM1 OCO 7 1 (1 2010 FORMAT ( / IX , 30HRESI DUAL STANDARD DEVIATION = , 3X , 20A1 , 26X , 20A1 /4X , 0C0 7 9 fl 128HBASED ON DEGREES OF FREEDOM , 9X , 14 , 1H- , 1 2 , 3H = , 13 ,33X, 14 ,1H-, OCO 7^n

212, 3H = , 13 // 120H * THE NUMBER OF CORRECTLY COMPUTED DIGITS IN EAC0C0 7 Afl 3H COEFFICIENT USUALLY DIFFERS BY LESS THAN 1 FROM THE NUMBER GIVEN0C0 7 c n

4 HERE) OCO 7 Afl / OU

RETURN OCO 770

END OCO 780

190
SUBROUTINE OCOVAR (M, ND7 , MD1 , IHC , B , IHT ) OCV 10

C VERSION 5.00 OCOVAR 5/15/70 OCV 20

C PRINT VARI ANCE-COVARIANCE MATRIX OCV 30

C WRITTEN BY DAVID HOGBEN , SEL, NBS . 10/10/69. OCV 40

C ***** OCV 50

COMMON /BLOCKD/ I ARGS (100) , KIND (100) ,ARGTAB(100) ,NRMAX ,NROW,NCOL , OCV 60

1NARGS , VWXYZ (8 ) ,NERROR OCV 70

COMMON /BLOCKE /NAME (4) ,L1,L2,ISRFLG OCV 80

COMMON/HEADER/NOCARD (80) ,ITLE(60,6) , LNCNT , I PR I NT ,NPAGE , I PUNCH OCV 90

C0MM0N/SCRAT/NS,NS2 , A (13500 ) OCV 100

DIMENSION IHC(l) ,B(1) ,IHT(1) OCV 110

1750 IND7 = ND7+1 OCV 120

1791 FORMAT ( / / / /31X , 56HVAR I ANCE-COVARIANCE MATRIX OF THE ESTIMATED COEOCV 130

1FFICIENTS) OCV 140

1792 FORMAT ( /IX , 2A3 , IX , 7 (6X , 15 , 4X) ) OCV 150

1793 FORMAT (IX , 14 ,3X , 106A1 ) OCV 160

WRITE (IPRINT,1791) OCV 180

CALL RFORMT (A ( IND7 ), MD1 , 8 , NW1 , NDEC1 , 13 , A ( 1 ), A ( 1 )

, 0 , 0 ) OCV 190

IF (L2.EQ.1) I6=-l OCV 200

IF (L2.EQ.3) 16=3 OCV 210

C I1END = NUMBER OF BLOCKS OF PRINTING OCV 220

IlEND=(M+6) /7 OCV 230

DO 1820 1 1=1 , 1 1END OCV 240

I3BEG=7*(I1-1)+1 OCV 250

I2BEG=I3BEG+I6 OCV 260

I2END = MINO (M+I6,I2BEG+6) OCV 270

IF (L2-2) 1811,1811,1813 OCV 280

1811 I7END=I2END+1-I2BEG OCV 290

DO 1812 I7=1,I7END OCV 300

1812 IHT (17 )=I2BEG-1+I7 OCV 310

WRITE (IPRINT,1792) IHC (L2) , IHC (L2+1) , (IHT (17 )

, 17=1 , 17END) OCV 320

GO TO 1814 OCV 330

1813 WRITE (IPRINT,1792) IHC (L2 )

, IHC (L2+1 ) , ( I ARGS ( 1 2 ), 1 2=1 2BEG , 1 2END ) OCV 340

1814 WRITE (IPRINT.1793) OCV 350

LOCI = IND7+( I3BEG* (I3BEG+1) ) /2-1 OCV 360

C 13 IS FOR LOOP ON ROWS OCV 370

DO 1820 I3=I3BEG,M OCV 380

I4END=MIN0 (13 , I3BEG+6) + 1 - I3BEG OCV 390

C 14 IS FOR LOOP ON COLUMNS OCV 400

DO 1815 14-1, MEND OCV 410

CALL RFORMT (A ( 1 ), 1 , 8 , NW1 , NDEC1 , 0 , A (LOCI ), B ( 15* 14-14 ), 15-NW1 , 0 ) OCV 420

1815 L0C1=L0C1+1 OCV 430

I5END = 15*I4END OCV 440

IF (L2.EQ.1) 18 = 13-1 OCV 450

IF (L2.EQ.3) I8=IARGS (13+3 ) OCV 460

WRITE (IPRINT,1793) 18 , (B ( 15 ), 1 5=1 , 1 5END ) OCV 470

1820 LOCI = L0C1-I4END+I3 OCV 480

RETURN OCV 490

END OCV 500

191
SUBROUTINE OMCONV (NWCD , KRD , KRDEND ) OMC 10

C VERSION 5.00 OMCONV 5/15/70 OMC 20

COMMON /ABCDEF / L(48) OMC 30

C OMC 40

C ARRAY L CONTAINS THE ALPHABET FORMATTED 1H OMC 50

C OMC 60

C THIS ROUTINE CONVERTS INPUT CARD IMAGES TO A STANDARD CODE SO OMC 70

C THAT OMNITAB CAN DEAL WITH THE CHARACTERS AS INTEGERS. OMC 80

C OMC 90

C OMC 100

C THIS ROUTINE IS INCLUDED ONLY FOR COMPLETENESS. IT SHOULD BE OMC 110

C REWRITTEN IN ASSEMBLY LANGUAGE FOR EACH COMPUTER. ALSO, IT OMC 120

C CANNOT MEET ASA STANDARDS BECAUSE ASA DOES NOT REQUIRE THAT DATA OMC 130

C READ WITH FORMAT Al BE STORED THE SAME AS HOLLERITH DATA SETUP OMC 140

C WITH 1H ALTHOUGH THEY WILL BE THE SAME ON MOST COMPUTERS. OMC 150

C OMC 160

C ALSO, ASA DOES NOT RECOGNIZE THE CHARACTER ' APOSTROPHE OMC 170

C OMC 210

DIMENSION NWCD(l), KRD ( 1 ) OMC 220

DO 30 1=1, KRDEND OMC 230

K=NWCD(I) OMC 240

C SPECIAL CASE TO CHECK FOR BLANKS OMC 250

IF(K.NE.L(45) ) GO TO 10 OMC 260

J=45 OMC 270

GO TO 30 OMC 280

C OMC 290

C THE UPPER BOUND OR LIMIT ON J MUST BE CHANGED IF MORE CHARACTERS OMC 300

C ARE ADDED TO THE VECTOR L IN LABEL COMMON ABCDEF OMC 310

C OMC 320

10 DO 20 J=l,48 OMC 330

IF(K.EQ.L(J) ) GO TO 30 OMC 340

20 CONTINUE OMC 350

J=47 OMC 360

30 KRD(I)=J-1 OMC 370

RETURN OMC 380

END OMC 410

192
cc

SUBROUTINE OMNIT

VERSION 5.00 ***************

C

cc

c

c

cc

c

c

c

c

c

cc

c

c

c

c

c

10

c

cc

20

c

c

c

c

c

30

OMNIT 5/15/70

THIS IS THE MAIN OMNITAB ROUTINE

MODE ,M,KARD (83) , KARG ,ARG ,ARG2 ,NEWCD (80) , KRDEND

NSTMT,NSTMTX,NSTMTH,NC0M,LC0M,I0VFL,C0M(2000)

KIO , I NUN IT , I SCR AT ,KBDOUT ,KRDKNT , LLIST

NRC,RC(12600)

IARGS(IOO) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW ( NCOL

COMMON /BLOCKA/

COMMON /BLOCKB

/

COMMON /BLOCKC/

COMMON /BLOCRC/

COMMON /BLOCKD

/

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )

)

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG

COMMON /HEADER /NOCARD (80) , ITLE (60 ,6) , LNCNT , I PRINT ,NPAGE , I PUNCH

THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS

COMMON /TAPE/ NAME4 (2

)

( NTPCT , IPUNCP , I NUN IP , L1TP

DATA IBLANK/1H /,LETSG0/-1/

THIS IS THE MAIN OMNITAB PROGRAM

SUBROUTINES CALLED BY THIS PROGRAM..

SETUP , INPUT , ERROR , STMT , NNAME , AARGS , ASTER , SETQ , READQ , STORE , XECUTE

AERR ,XOMNIT ,XFORMT , LOOKUP

MOD = 1 INTERPRETIVE MODE = 2 DATA MODE (READ SET) = 3 STORAGE MODE (BETWEEN BEGIN AND FINISH)

=4 IMPLIED STORAGE MODE (STATEMENT NUMBER GIVEN

OMN

OMN

*OMN

OMN

OMN

OMN

OMN

NOMN

OMN

10

20

30

40

50

60

70

80

90

0 = 0, 1 = 1, ETC., 9 = 9, A = 10, B = 11, ETC, Z= 35, / = 36

. = 37, - = 38, + = 39, * = 40, ( = 41, ) = 42, , = 43

BLANK =44, = = 45 , $ AND OTHERS = 46

CALL SETUP

IF (MODE . EQ . 3 ) NSTMT=NSTMT+10

IF (M0DE.EQ.4) M0DE=1

NAME(1)=0

NAME(2)=0

NAME(3)=0

NAME(4)=0

NARGS=0

J=0

CHECK FOR ACCUMULATED ERRORS DURING LAST EXECUTED COMMAND

CALL AERR (0)

CALL INPUT

SCANNING BEGINS WITH THE THIRD CHARACTER. THE FIRST TWO ARE DUMMY

TO KEEP THE PROGRAM OUT OF TROUBLE. SCANNING TERMINATES WITH A $

A $ HAS BEEN PLANTED IN THE (KRDEND+1 ) -TH POSITION.

M=2

M=M+1

K-KARD (M)

IF (K.GE.36) IF (K-46) 45,40,30

OMN 100

OMN 110

OMN 120

OMN 130

OMN 150

OMN 160

*OMN 170

OMN 180

OMN 190

OMN 200

OMN 210

OMN 220

OMN 230

OMN 240

OMN 250

OMN 260

OMN 270

OMN 280

OMN 290

OMN 300

OMN 310

OMN 320

OMN 330

OMN 340

OMN 350

OMN 360

OMN 370

OMN 460

OMN 470

OMN 480

OMN 490

OMN 500

OMN 510

OMN 520

OMN 530

OMN 540

OMN 550

OMN 560

OMN 570

OMN 580

OMN 590

OMN 600

OMN 610

OMN 620

OMN 630

OMN 640

OMN 650

OMN 660

OMN 670

OMN 675

193
IF (K.GE.10) GO TO 60 OMN 680

C OMN 690

C A NUMBER IS THE FIRST ALPHANUMERIC CHARACTER ENCOUNTERED, ERROR IFOMN 700

C IN MODE 3 OMN 710

C OMN 720

CALL OUTPUT OMN 730

IF (M0DE.NE.3) GO TO 50 OMN 740

35 CALL ERROR (2) OMN 750

GO TO 20 OMN 760

40 IF (MODE . NE . 4 ) CALL OUTPUT OMN 770

GO TO 10 OMN 780

C CHECK FOR * OR ' OMN 790

45 IF (K-40) 30,190,30 OMN 800

50 CALL STMT (NSTMT) OMN 810

IF (KARG.NE.O) IF (MODE-2) 35,185,35 OMN 815

C OMN 820

C IF AN ILLEGAL STATEMENT NUMBER WAS FOUND, KARG = 1 (KARG = 0 IF OMN 830

C LEGAL) OMN 840

C OMN 850

M0DE=4 OMN 860

C OMN 870

C M IS POINTING AT THE FIRST LETTER ON THE CARD, ASSEMBLE NAME. OMN 880

C OMN 890

60 CALL NNAME (NAME (1) ) OMN 900

C OMN 910

C OMN 920

C CHECK THE FIRST NAME FOR SPECIAL NAMES... OMN 930

C OMNITAB, FORMAT, NOTE, FOOTNOTE, HEAD, TITLE OMN 940

C OMN 950

C OMNITAB OMN 960

C OMN 970

IF (NAME(l) .NE. 11300. OR. NAME(2) .NE .7102) IF (LETSGO) 65,67,67 OMN 975

C OMN 980

C IF NOT THE FIRST OMNITAB CARD, WRITE EOF RECORD. OMN 990

C 0MN1000

IF(LETSG0.NE. (-1) ) WRITE (ISCRAT,390) 0MN1010

LETSG0=LETSG0+1 0MN1020

65 CALL XOMNIT (LETSGO) 0MN1030

IF (LETSGO .NE . (-1) ) GO TO 10 0MN1040

LETSGO=0 0MN1050

C 0MN1060

C FINISH 0MN1070

C 0MN1080

67 IF (NAME(l) .NE. 4631. OR. NAME(2) .NE. 7082) GO TO 70 0MN1090

M0DE=1 OMN1100

GO TO 40 0MN1110

C 0MN1120

C FORMAT OMNI 130

C 0MN1140

70 IF (MODE .NE .4) CALL OUTPUT 0MN1150

IF (NAME(l) .NE. 4797. OR. NAME(2) .NE. 9524) GO TO 90 0MN1160

CALL XFORMT 0MN1170

80 IF (MODE .GE . 3 ) CALL ERROR (202) 0MN1180

IF (MODE .NE .3 ) M0DE=1 0MN1190

GO TO 10 0MN1200

C 0MN1210

C NOTE 0MN1220

C 0MN1230

90 IF (NAME ( 1 ) .NE. 10631. OR. NAME(2) .NE.3645) GO TO 100 0MN1240

194
K=KARD (M) 0MN1243

IF (K.EQ.l .0R.K.EQ.2) GO TO 95 OMN1245

IF (NPAGE.EQ.O) CALL PAGE (0) 0MN1247

WRITE (IPRINT,400) (NEWCD ( 1-2 )

, I=M, 82 ) 0MN1250

LNCNT=LNCNT+1 0MN1260

GO TO 80 0MN1270

95 CALL NOTEPR (K) 0MN1273

GO TO 80 0MN1275

C 0MN1280

C HEAD 0MN1290

C 0MN1300

100 IF (NAME(l) .NE .5968 .OR .NAME (2) .NE.2916) GOTO 110 0MN1310

CALL XHEAD 0MN1320

GO TO 80 0MN1330

C 0MN1340

C TITLES. TITLEX = TITLES , TITLEY = TITLE6 0MN1350

C 0MN1360

110 IF (NAME(l) .NE. 14843) GO TO 160 0MN1370

C CHECK NAME TITLE 0MN1380

IF (NAME(2) .EQ.8883) GO TO 120 0MN1390

C CHECK TITLEX, TITLEY 0MN1400

K=5 0MN1410

M=M+1 0MN1420

IF (NAME (2) .NE .8908) IF (NAME (2 ) -8907 ) 160,130,160 0MN1425

K=6 0MN1430

GO TO 130 0MN1440

120 K=KARD (M) 0MN1450

IF(K.GE.1.AND.K.LE.4) GO TO 130 0MN1460

CALL ERROR (209) 0MN1470

K=l 0MN1480

130 MM=MIN0(M+59,81) 0MN1490

DO 140 1=1,60 0MN1500

140 ITLE ( I ,K)=IBLANK 0MN1510

1=1 0MN1520

DO 150 MA=M , MM 0MN1530

ITLE (I ,K)=NEWCD (MA-1 ) 0MN1540

150 1=1+1 0MN1550

GO TO 80 0MN1560

C 0MN1570

C STOP 0MN1580

C 0MN1590

160 IF (NAME(l) .NE. 14406. OR. NAME(2) .NE. 11664) GOTO 170 0MN1600

WRITE (ISCRAT,390) 0MN1610

CALL XSTOP 0MN1620

STOP 0MN1630

C 0MN1640

C M IS POINTING AT THE FIRST NON-LETTER AFTER NAME. LOOK FOR 0MN1650

C POSSIBLE NAME QUALIFIER OR ARGUMENTS OR END OF CARD. 0MN1660

C 0MN1670

170 K=KARD(M) 0MN1680

IF (K.LT.36) IF (K-10) 190,175,175 0MN1685

IF (K.EQ.40) GO TO 190 0MN1690

IF (K.EQ.46) GO TO 320 0MN1700

M=M+1 0MN1710

GO TO 170 0MN1720

C 0MN1730

C A LETTER FOUND, ASSEMBLE SECOND NAME (COMMAND QUALIFIER). 0MN1740

C 0MN1750

175 CALL NNAME (NAME (3)) 0MN1760

195
CHECK SPECIAL CASE OF NAMES M(XAX'), M(X'AX), M(XX'), M(X'X)

SKIP ONE CHARACTER (') IF FIRST NAME =(M ) THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS

IS NAME (3) EQUAL TO TAP AND NAME (4 )=E

IF (NAME(3) .NE. 14623 .OR. NAME(4) .NE. 3645) GO TO 180

CALL TAPOP

GO TO 190

0MN1770

OMN1780

0MN1790

0MN1800

0MN1810

0MN1820

0MN1830

0MN1840

0MN1850

0MN1860

IF (NAME ( 1 ) .EQ.9477

GO TO 190

M=M+1 0MN1870

0MN1880

0MN1890

0MN1900

0MN1910

0MN1920

0MN1930

0MN1940

0MN1950

0MN1960

0MN1965

0MN1970

NUMBER FOUND, CONVERT ARGUMENT. IF KARG RETURNED = 0, NUMBER IS 0MN1980

INTEGER, IF KARG = 1, NUMBER IS FLOATING POINT, IF KARG = -1, ERR0R0MN1990

0MN2000

CALL AARGS

IF (KARG) 10,230,220

ARGTAB (J )=0

.

SCAN FOR ARGUMENTS AND END OF CARD

M=3

J=J+1

GO TO 210

M=M+1

K=KARD (M)

IF (K.GE.10) IF (K-40) 200,255,315

ADD A BIAS OF 8192 THEN CHECK THAT IT IS

0MN2010

0MN2020

OMN2030

0MN2040

OMN2050

0MN2060

OMN2070

0MN2080

0MN2090

0MN2100

0MN2110

0MN2120

0MN2130

0MN2140

0MN2150

0MN2160

0MN2170

0MN2180

0MN2190

IF BRACKETED BY SINGLE ASTERISKS, QUANTITY IS TO BE USED AS A 0MN2200

FLOATING POINT ARGUMENT. IF BRACKETED BY DOUBLE ASTERISKS, QUANTITY0MN2210

IS TO BE TRUNCATED AND USED AS AN INTEGER ARGUMENT. 0MN2220

0MN2230

KARG=1 0MN2240

M=M+1 0MN2250

IF (KARD(M) .NE.40) GO TO 260 0MN2260

KARG=0 0MN2270

M=M+1 0MN2280

MS=M 0MN2290

CALL ASTER 0MN2300

0MN2310

THE TERMINAL ASTERISK(S) HAVE BEEN CHECKED TO BE THE SAME AS THE 0MN2320

INTITAL SET (IF NO ERROR) AND M IS POINTING AT THE FIRST CHARACTER0MN2330

AFTER THE LAST ASTERISK. 0MN2340

J=J+1

GO TO 240

ARGUMENT IS AN INTEGER

.GT. 0

ARG=ARG+8192

.

IF (ARG.GT.O.) GO TO 240

CALL ERROR (18)

GO TO 10

ARGTAB (J )=ARG

NARGS=NARGS+1

GO TO 190

ASTERISK FOUND, CONVERT

196
c

c

cc

c

c

c

c

c

c

cc

c

c

cc

c

c

270

280

290

KARG RETURNED AS

300

310

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

c

c

c

c

1 = ERROR FOUND

2 = FLOATING POINT CONSTANT, Z.B.

3 = INTEGER NAMED VARIABLE, Z.B.

4 = FL. PT. NAMED VARIABLE, Z.B.

5 = INTEGER ROW-COLUMN, Z.B.

6 = FL . PT. ROW-COLUMN, Z.B.

7 = STRING OF ASTERISKS Z.B.

A STRING OF THREE OR MORE ASTERISKS IMPLIES -THRUEXAMPLE. .

* p j * **NRMAX**

*NRMAX*

* * 3 40 * *

* 1 2

*

* * *

ERASE

ERASE

2 3 4

*t» T* 12 13 14 15

12 *** 16,

16 20

20

PRINT 1 20 19 18 17 16 15 14

PRINT 1, 20 *** 14

IS EQUIVALENT TO

IS EQUIVALENT TO

GO TO (270,220,280,280,290,290,300), KARG

M=MS

GO TO 210

ARGTAB (J )=-2 . *ARG-FLOAT (KARG-3

)

GO TO 250

ARGTAB(J)=-(ARG+8208.

)

ARG2=ARG2+8192.

IF (KARG.EQ.6) ARG2=-ARG2

J=J+1

ARGTAB (J )=ARG2

GO TO 250

IF (J.GT.O) GO TO 310

CALL ERROR (211)

GO TO 210

ARGTAB (J )=-l

.

GO TO 190

ARGTAB SETUP

IF ENTRY

TO WHICH

0MN2350

0MN2360

0MN2370

0MN2380

0MN2390

0MN2400

0MN2410

0MN2420

0MN2430

0MN2440

0MN2450

0MN2460

0MN2470

OMN2480

0MN2490

0MN2500

0MN2510

0MN2520

0MN2530

0MN2540

0MN2550

0MN2560

0MN2570

0MN2580

0MN2590

0MN2600

0MN2610

0MN2620

0MN2630

0MN2640

OMN2650

OMN2660

0MN2670

0MN2680

0MN2690

0MN2700

0MN2710

0MN2720

0MN2730

0MN2740

IF ENTRY .EQ.O, THE NEXT ENTRY IS A FLOATING POINT CONSTANT.

IF ENTRY .LT. 0, ARGUMENT IS A VARIABLE. SET SIGN POSITIVE AND

IF ENTRY .LT. 16, IT IS A NAMED VARIABLE REFERENCE NUMBER

.GT. 0, IT IS AN INTEGER CONSTANT (Z.B. COLUMN NUMBER)

A BIAS OF 8192 HAS BEEN ADDED. THIS IS TO SAY THAT A

NEGATIVE INTEGER ARGUMENT MAY NOT BE EXPLICITLY GIVEN OR MODIFIED 0MN2750

TO BE LESS THAT -8191. 0MN2760

0MN2770

OMN2780

0MN2790

0MN2800

0MN2810

0MN2820

0MN2830

0MN2840

0MN2850

0MN2860

0MN2870

0MN2880

V,W,X,Y,Z, ARE FOR PROGRAMMING CONVENIENCE ONLY AND DO N0T0MN2890

AFFECT THE OPERATION OF OMNITAB 0MN2900

0MN2910

IF ENTRY IS EVEN, CURRENT VALUE TO BE TRUNCATED AND USED 0MN2920

AS AN INTEGER ARGUMENT. 0MN2930

IF

2,3

4,5

NRMAX

COLTOP

6,7

8,9

V

W

10,11

12,13

14,15

X

Y

Z

197
C IF ENTRY IS ODD. THE CURRENT VALUE IS TO BE USED AS A 0MN2940

C FLOATING POINT ARGUMENT. 0MN2950

C 0MN2960

C IF ENTRY .GT. 16, IT IS A WORKSHEET REFERENCE (ROW, COLUMN) TO 0MN2970

C WHICH A BIAS OF 8192. HAS BEEN ADDED. 0MN2980

C ENTRY - 8208 = ROW NUMBER 0MN2990

C ABS (NEXT ENTRY) = COLUMN NUMBER TO WHICH A BIAS OF 8192. 0MN3000

C HAS BEEN ADDED. 0MN3010

C 0MN3020

C IF NEXT ENTRY IS NEGATIVE, WORKSHEET CONTENTS ARE TO BE 0MN3030

C USED AS A FLOATING POINT CONSTANT. IF +, WORKSHEET VALUE OMN3040

C TO BE TRUNCATED AND USED AS AN INTEGER ARGUMENT. 0MN3050

C 0MN3060

C 0MN3070

315 IF (K.NE.46) GO TO 200 0MN3080

C 0MN3090

C THE TERMINATION OF CARD FOUND ( $ ENCOUNTERED) 0MN3100

C 0MN3110

320 IF (J.EQ.O) J=l 0MN3120

IF (MODE . NE . 2 .OR .NAME (1 ) .NE . 0 ) GO TO 350 0MN3130

C 0MN3140

C IN INPUT MODE AND NO POSSIBLE NAME, RETURN TO SET OR READ ROUTINE 0MN3150

C 0MN3160

330 CALL EXPAND (J , ARGTAB) 0MN3170

IF (ISRFLG.EQ.O) GO TO 340 0MN3180

CALL SETQ 0MN3190

GO TO 10 OMN3200

340 CALL READQ 0MN3210

GO TO 10 0MN3220

C OMN3230

C LOOK UP NAME (AND POSSIBLE QUALIFIER) IN DICTIONARY. RETURN 0MN3240

C COORDINATES OF ENTRY. IF LI = 0, NAME NOT FOUND 0MN3250

C 0MN3260

350 CALL LOOKUP 0MN3270

IF (Ll.NE.O) GO TO 360 0MN3280

IF (MODE .EQ . 2 ) GO TO 330 0MN3290

CALL ERROR (1) 0MN3300

GO TO 10 0MN3310

C 0MN3320

C NAME FOUND 0MN3330

C 0MN3340

C THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS 0MN3350

C STATEMENT WAS 220 IF (MODE .EQ . 2 ) M0DE=1 0MN3360

360 IF (MODE . EQ . 2 ) GO TO 370 0MN3370

Q **************************************************************** * *0MN3 3 80

IF (MODE .EQ . 1 ) GO TO 380 0MN3390

CALL STORE (J) 0MN3400

GO TO 10 0MN3410

C THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS 0MN3420

370 M0DE=1 0MN3430

INUNIT=INUNIP 0MN3440

Q **************************************************************

380 CALL EXPAND (J, ARGTAB) 0MN3460

CALL XECUTE 0MN3470

GO TO 10 0MN3480

C 0MN3490

390 FORMAT (1HZ,83X) 0MN3500

400 FORMAT (1X,80A1) 0MN3510

END 0MN3520

198
SUBROUTINE ONEWAY ONE 10

c VERSION 5.00 ONEWAY 5/15/70 ONE 20

c ONE 30

c *********************************************************** 40

c OMNITAB * ONEWAY STAT. ANALYSIS. ONE 50

c WRITTEN BY DAVID HOGBEN , SEL, NBS . 10/25/69. ONE 60

c ONEWAY ANALYSIS OF DATA IN ++ WITH TAG IN ++ STORE IN ++,++ ONE 70

c TAG NUMBERS DIFFERENTIATE BETWEEN GROUPS ONE 80

c WHEN TAG IS NON-POSITIVE ZERO WEIGHT IS GIVEN TO MEASUREMENTS ONE 90

c NUMBER OF GROUPS MUST BE GREATER THAN 1 AND MUST NOT EXCEED NLNTH20NE 100

c NRMAX MUST NOT EXCEED NLNTH1 ONE 110

c SLOPE IN ANOVA IS ONLY GIVEN IF FPROB FOR BETWEEN IS LESS THAN . 100NE 120

c **************************************************************** * *Qty£ 130

COMMON /BLOCKD / IARGS(IOO) , KIND (100) ,ARGTAB (100) , NRMAX ,NROW,NCOL , NONE 140

1ARGS,VWXYZ(8) ,NERROR ONE 150

COMMON /BLOCRC/ NRC , RC ( 12600

)

ONE 160

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG ONE 170

DIMENSION ARGS(IOO) ONE 180

EQUIVALENCE (ARGS ( 1 ), RC (12501 )

)

ONE 190

COMMON /HEADER/ NOCARD (80 )

, ITLE (60 , 6 )

, LNCNT , IPRINT , NPAGE , IPUNCH ONE 200

COMMON /SCRAT/ NS , NS2 , A ( 13500

)

ONE 210

COMMON /ABCDEF / L(48) ONE 220

EQUIVALENCE (BLANK , L (45 )) , (SL0,L(22)), (HIGH,L(18)) ONE 230

c NLNTH1 = LENGTH OF ARRAYS = 2700, MUST BE CHANGED IF NS CHANGED ONE 240

c 5*NLNTH1 MUST BE LE NS DIMENSION A3 (NLNTHl

)

ONE 250

DIMENSION A2(2700), A3(2700), A4(2700), A5(2700) ONE 260

EQUIVALENCE (A2 (1 ), A (2701 )

)

ONE 270

EQUIVALENCE (A3 (1 )

, A (5401 ) ) , (A4 ( 1 ), A (8101 ) ) , ( A5 ( 1 ), A ( 10801 )

)

ONE 280

c NLNTH2 = LENGTH OF ARRAYS = 540, MUST BE CHANGED IF NS CHANGED ONE 290

c 10*NLNTH2 LE NLNTHl DIMENSION Bl (NLNTH2

)

ONE 300

DIMENSION Bl(540), B2(540), B3(540), B4(540), B5(540), B6(540), B70NE 310

1(540), B8(540), B9(540), B10(540) ONE 320

EQUIVALENCE (Bl (1 )

, A (1 ) ) , (B2 (1 ), A (541 ) ) , (B3 (1 ) ,A (1081 ) ) , (B4(1),0NE 330

1A(1621)), (B5(l) ,A(2161)) , (B6 ( 1 )

, A (2701 ) ) , (B7 (1 )

, A (3241 ) ) , (B8(10NE 340

2),A(3781)), (B9(l) ,A(4321)) , (BIO ( 1 ), A (4861 )

)

ONE 350

c ONE 360

c EXECUTION TIME CAN BE CONSIDERABLY SHORTENED USING LESS ACCURATE ONE 370

c VERSION OF FPPT. ONE 380

c ONE 390

c

i|c sfc ^ + :£ # £ j|{ ^ ^ # # sfc s|e ^ 400

c ONE 410

NLNTHl=NS/5 ONE 420

NLNTH2=NLNTHl/5 ONE 430

c ERROR CHECKING ONE 440

IF (NRMAX. GT. NLNTHl) GO TO 50 ONE 450

IF (NRMAX. EQ.O) CALL ERROR (9) ONE 460

IF (NARGS.EQ.6) GO TO 40 ONE 470

IF (NARGS . EQ . 2 .AND . L2 .EQ . 13 ) GO TO 40 ONE 480

IF (NARGS .EQ . 2 . AND . L2 . EQ . 14 ) GO TO 10 ONE 490

IF (NARGS. EQ. 3) GO TO 20 ONE 500

CALL ERROR (10) ONE 510

RETURN ONE 520

10 CALL ERROR (236) ONE 530

RETURN ONE 540

20 DO 30 1=4,6 ONE 550

IARGS(I)=IARGS(3)+1 ONE 560

30 KIND(I)=0 ONE 570

NARGS=6 ONE 580

40 CALL CHKCOL (J) ONE 590

199
i r / i cn n i en tci in ir (J.ty.u) uu iu ou (\ ki c l a a UNt 600

50 LALL tKKUK til) nur tin UNt 610

60 ilrr (NtKKUK (MrDonD . Kir Nt . t\ \ rn Tn cm U ) UU IU 51U n ki c l o r\ UNt 620

L MOVE Y AND TAG TO SCRATCH AREA MOVING TO BOTTOM IF TAG UNt 630

AU NON-POSITIVE, CONVERT TAG TO INTEGER, COMPUTE NZW AND K, SET 1 1 D T f\MC L A ft Ur 1 UNt 640

Mlmil1 —— T1 HI\U ARG^J 111 1

^ J. ; — X ntir ten UNt 6d0

Ml ?-T ARG^ < ? ) 1 Alir L L ft UIMt 660

K-0 UNt 6/U

N7W-0 1 1 L. If —

U

n ki c l o ft UNt boU

DO 80 1=1 NRMAX HMt L ft ft UNt 07U

MO?—Ml 1 -i-T n ki c ~i r\ ft UNt /UU

Mn3—Ml ?-i-T nur il

n

UNt / 1U

TF (RP(M031 GF 1 ni GO Tfl 7f) nur 7 o ft UNt / £.[} NZW-NZW+1 nKir 7

1

(\ UNt 1 3\i

M01=NRMAX-NZW+1 iiiv Awimninn ilia ikt a flNF 7 A.(\ A3 ( M01 }-RC ( MO

2

) UNt nur 7 c n /DU

mA 4 (Mm \ —0 n *r ^ vn\j x ) —\j . u n KI C 7 Lft UNt / 6U

GO TO 80 nwc 7 7

n

UNt / /

U

7/ nu J=I-NZW flKJP 70A

A3 (J )=RC (M02 ) nwF 7on

A4 ( J i-AINT fRC (M03 ^+1 E-81 UNt oUU

o a BU K-MAX0 f K INT(A4fJl+l 0E-6n Alir O 1 A UNt 810

NZW-NRMAX-NZW UNt Oil)

IF (NZW LE IO GO TO 50 UNt oJU

IF (K.LT.2) GO TO 50 nwc QAn

IF (K.GT.NLNTH2) GO TO 50 n ki c oca UNt odO

M34=NZW+1 nwc o l n UNt B60

p1/ COMPUTE NI ,MEAN,S(R) , SETUP MIN + MAX, I BAR FOR T— 1 K nwc o 7 a UNt o/U

DO 90 I=1,NLNTH1 HKIC oon UNt ooU

on7 u A(I)=0.0 nwc UIVL 07U son CALL RANK0 (NZW , A3 ( 1 )

, A2 ( 1 ), A5 ( 1 ), A (49 )

)

nwc onn A(49)=12.0*A(49) nWC UNt OTA 7lU

A(133)=NZW nwc q o a UNt 7Z.U DO 100 1=1, NZW nwc Q 1

A

UNt 7JU

M40=A4(I) nwc od a B2(M40)=B2(M40)+1.0 DNC U N t QRA 7jU

B3(M40)=B3(M40)+A3(I) nwc UNt QAA 70U

B5 (M40)=B5 (M40 ) +A5 ( I

)

ONC UNt Q7A 7 /

U

B6(M40)=A3(I) nwc UNt QQA 70U

B7 (M40)=A3 (I

)

nwc U N C QQA 7 7 U A(21)=A(21)+A3 (I

)

("IMF 1 AAA

i nn A(101)=A(101)+A4(I) nwc 1 A 1 A UllLlVJ 1U

A(21)=A(21) /A(133) nwci at a UIvLIUlU

A(101)=A(101) /A(133) nUNfil C 1 A 1 A t 1

U

i u DO 110 1=1,

K

nWC 1 Ad

A

UN t X U*r U IF (B2(I) .GT.0.0) B3 (I )=B3 (I ) /B2 (I

)

nwc UNtlUDU 1 A K A B8(I)=B3(I) nwc UN 1

11 AAA U O U COMPUTE MIN , MAX ,SD>S,SS,DF,MS,F, FPR0B , S ( 1 / NI ) , S (N.I **3 ) , S (R * * 5 / WnWC 1 A7 A £ / NUNt 1U /

u

no B9(I)=B2(I) nwc

i

a o a UNtluoU

DO 120 1=1, NZW nwci U N t X AQA u 7 U M40=A4(I)+.0001 ONF linn

B6(M40)=AMIN1(B6(M40) ,A3 (I )

)

nNF UN t 1X1X1X AU B7(M40)=AMAX1(B7(M40) # A3 (I )

)

nwFi

i

UNC. X X onC U B4 ( M40 ) =B4 ( M40 ) + ( A3 ( I

) -B3 ( M40 )

)

* * 2 nNF UN 1 1 1 A 1 X j U A(1)=A(1)+(B3(M40)-A(21))**2 nNC UNt iX 1HU i in

A(4)=A(4)+(A3 (I)-B3 (M40) )**2 nwci i

c

a UilLll Ju

1 0 ft 12U A(5)=A(5)+(A3(I)-A(21))**2 nnic UN t

1X 1X aaO U A(17)=0.0 0NE1170

A(22)=B3 (1) 0NE1180

200
A(23)=B3(1)

A(24)=FSQRT(B4(1) ) A(25)=0

A(26)=B6(1)

A(27)=B7(1)

A(48)=0 .0

DO 150 1=1 ,K

BIO (I ) = (B2 {I ) * (B2 (I )-l .0) ) /B4 (I

)

A(126)=A(126)+B10(I)*B3(I)

A(127)=A(127)+B10(I)

IF (B2(I)-1.) 150,140,130

130 B4(I)=FSQRT(B4(I) / (B2(I)-1.0)

)

A(121)=A(121)+(B2(I)-1 .0)*FL0G(B4(I)*B4(I)

)

A(131)=A(131)+1

A(25)=AMAX1 (A(25) ,B4(I))

A(24)=AMIN1 (A(24) ,B4(I))

A(120)=A(120)+1.0/(B2(I)-1.0)

140 A (2 )=A (2 ) +B2 ( I

) * (FLOAT ( I

) -A ( 101 )

) * (B3 ( I

) -A (21 )

)

A(114)=A(114)+B2(I)* ( (FLOAT (I )-A (101) )**2)

A(22)=AMIN1(A(22) ,B3(I)

)

A(23)=AMAX1 (A(23) ,B3 ( I )

)

A(26)=AMIN1(A(26) ,B6(I))

A(27)=AMAX1 (A(27) ,B7 (I)

)

A(17)=A(17)+B5(I)**2/B2(I)

A(18)=A(18)+1 . /B2 (I

)

A(48)=A(48)+(B3(I)-A(21))**2

A(122)=A(122)+B4(I)**2

A(129)=A(129)+B2(I)**2

150 A(118)=A(118)+B2(I)**3

A(126)=A(126)/A(127)

A(2)=A(2)**2/A(114)

A(3)=A(1)-A(2)

C DEGREES OF FREEDOM FOR ANOVA

M1=K-1

A(136)=FL0AT(M1)

M2=l

M3=K-2

M4=NZW-K

A(134)=FL0AT(M4)

M5=NZW-1

C MEAN SQUARES

A(6)=A(1)/A(136)

A(7)=A(2) /FLOAT (M2)

A(8)=A(3) /FLOAT (M3)

A(9)=A(4) /FLOAT (M4)

A(10)=A(5) /FL0AT(M5)

A(11)=A(6)/A(9)

A(12)=A(7)/((A(3)+A(4))/(A(133)-2.))

A(13)=A(8)/A(9)

CALL PROB (A (136) , FLOAT (M4),A(11),A(14))

CALL PROB (FLOAT (M2) , FLOAT (M4) ,A(12) ,A(15))

CALL PROB (FL0AT (M3) , FLOAT (NZW-2 ) ,A(13) ,A(16)

)

C COMPUTE FOR KRUSKAL-WALLIS TEST

A(117)=NZW* (NZW+1)

A(17)=(12.*A(17) ) /A(117)-3.*FL0AT(NZW+1)

A(102)=1.0-A(49)/FL0AT(NZW**3-NZW)

A(17)=A(17) /A(102)

A(106)=(FL0AT(NZW**3)-A(118) )/A(117)

A(105)=FL0AT(2*Ml)-.4*FL0AT(3*K*M3+NZW*(2*K*(K-3)+l) ) /A (117)

0NE1190

0NE1200

0NE1210

0NE1220

0NE1230

0NE1240

0NE1250

0NE1260

0NE1270

0NE1280

0NE1290

0NE1300

0NE1310

0NE1320

0NE1330

0NE1340

0NE1350

0NE1360

0NF1370

0NE1380

0NE1390

0NE1400

0NE1410

0NE1420

0NE1430

0NE1440

0NE1450

0NE1460

0NE1470

0NE1480

0NE1490

0NE1500

0NE1510

0NE1520

0NE1530

0NE1540

0NE1550

0NE1560

0NE1570

0NE1580

0NE1590

ONE1600

0NE1610

ONE1620

0NE1630

0NE1640

0NE1650

0NE1660

0NE1670

0NE1680

0NE1690

0NE1700

0NE1710

0NE1720

0NE1730

0NE1740

ONE1750

0NE1760

-6.*A(0NE1770

201
118)/5. 0NE1780

A(103)=A(136)* (A (136)* ( A ( 106 ) -A ( 136 ) )-A(105) )/ ( .5*A(105)* A(106)) 0NE1790

A (104)= (A (106) -A (136) )*A(103) /A (136) 0NE1800

A(19)=A(17)* (A (106) -A (136) ) / ( A ( 136 ) * (A ( 106 ) -A ( 17 ) )

)

0NE1810

PAII DOOR ( A I WT ( A M A1 1 . C\ ITklT / A / I nA\ i U AL L rKUD (A1NI(A(1U.?) + .3),A1NI(A(.LU'1) +

C\ A / 1 ft \ A /oft \ \

. 5 ) ,A (19 ), A (20 ) ) 0NE1820

PAMPIITF LUrarU It TATAI 1 U 1 AL CTATTCT1PC j 1 A 1 1 j 1 1U) 0NE1830

AA 1 1"\ \—FCART / A 1 Q \ \(

i

1 ) =r JU.K 1 ^ A ( 7 ) ) a Air i n a f\ 0NE1840

A nil F QfiRT 1 h 1 AQ\ / A M 11. \ \ f\ ( 3 l ) =r \ ( A (lo ) 1 A ( 1 JO ) ) 0NE1850

A ( 3 3 ) =r oyK 1 (

A

( 1U ;

J

0NE1860

AA i 74\_a / 7i \ /FQnRT(AM77.ii ( 3 *t ) =M ( 3 1 ) 1 r O UK 1

' A ' 1 .? .? ; ) 0NE1870

A

A A(19 1 / F CAPT / Fl Pi AT / It \ \

( J3 ) =A ^ J £ ) / r JU.K 1 ^ r LU A 1 (N)

)

0NE1880

A / ? A \ —a \ /FCflRT/AM'i'iii 0NE1890

PAII O A L L TPPTPT 1 r U 1 r 1 1

^ Fr

1L OAT U A 1 f^ MAWit \

;

, A

A /17 (3 1 M) ) 0NE1900

PAII TPPTPT iA/IUI A no ; \ l/ALL Irlilrl (A ( X30 ) , A (3 0 1 ) 0NE1910

PAII TPPTPT ( Fl AAT ( MC \ A no i \ U H L L 1 rU 1 r 1 ^ r L U A 1 I WIO } , A [i7 ) ) a ii r i o i*\ 0NE1920

A ( H 1

) =A (c

X

) —

A

( 3H j H(3l) 0NE1930

A ( 4 £ J =A ( 2 1 ) —A 1 3 D ) A ( 3 0 ) ONE1940

AA ( a 3 i Ami A i * a / 50 i (4 J

) =A ( £ 1 ) —A (30) A (.5 7) 0NE1950

A Ctt ]=A (i 1)+A ( it ) A (.?/) ONE1960

A

A / Ai; 1 A ill i iA / ?i;\*A / Ifil

( H D ; =A ( i. X ) +A ( 3 D ) A (Jo) ONE1970

A 1 A A \ —A 1 9 1 1 xA nti *A no \ 0NE1980

^ORT JuR 1 YRAR ADMr\ FAR rUI\ Mill WlU LIT TIrLL PI F PAMPART^TAKK L- U Wlr rt r\ 1 jlUrij AFUr MFWIL AAKKNo 0NE199C

nnuu iiouao T—i — i mi i , mi a ii r A A A A ONE2000

M37—k T 0NE2010

nnUU iIOUao i—i mi 7 J —

1

# m3

1

A M IT O ft O A ONE2020

TlrF rRg/ lDO(,J;.Lt.DO(J+l); h IF RQ M • 1 \ \ pfl vjU Tfl I U unloll ONE2030

A M 1 5 \ O Q / | \ A ) =DO ( J ; A ii r o r\ >• a ONE2040

DO / 1 \ DO / 1 , 1 \ Do ( J ) =DO ( J+I J A ft! r~ A A C A ONE2050

do i |,i \ _A n l 1 \ DO \ J +1 ) =A (113 ) Aiir i a / a ONE2060

A/1U\ —RQ 1 1 1 A 11 r ATA ONE2070

DQ / 1 \ DQ / I

, 1

\

D7 { J ) =D7 I J+l

J

All T 1 A fl A ONE2080

R0D 7/

\ J

1 j.1 + X )1 —A—M inn ( X X j ) A 11 f* A AAA 0NE2090

CONTINUE Aiirn A/\ ONE2100

PAII l/HLL FPPT rrrl /A/iui (A ( 1JO ) ,rFinAT( LUA 1 \ MAWit 1

J , . ncU3 , Aamhu ^ 11D ) J AIICM t ft UNtZllO

AA / 1 1 A \ A (% 1 \ * FCfiPT 1 A / 1 % A \ * A / 1 1 C 1 1

^ i 1 0

; =A \ 3 X ) rjyKI (A(IJO) A ^ 1 13 J ; rtfcir a i Aft ONE2120

TFCTQ 1 l j 1 j FOR FUR UinMnPFWFTTV nU WlU ulNlI 1 1 OFUr UAPTAMPFC VAK1ANUC.O ftlirAi Oft UNt2130

A(Di) A / ci \ = /(A(£b) A I1C \ *AA(^:>) nc \ \

) j

/ S\(Xil) A / i m UNLZ 140

A(l23) = AINT (A(l33)/FL0AT(K)-0.5)

PAII uALL PPDR rKUD I A 1 1 0 1 1 A/lUltfAMll 1 1 \ (A (A ( 1/ J ) , A ( XC.3 ) (H (1.3 1 ) —1 . ) , (

A

AIIC 1 1 C ft UNL2150

(lil)-l . ) A ( b 1 ) / (

1

. -A (51 ) ) ,0NE2155

1 A(52)) UNLZloO

Aiir a i / c 0NE2165

IF (A(52) .GT.l . ) A(52) = l .0 UNtZ 170

A(57)=(A(25) /A(24) )**2

A(121)=A(134)*FL0G(A(9) )-A(121)

AIIPO 1 Aft UNLZloO

Alien oa UNLZ190

A(124)=(A(120)-1 .0/A(134) ) / (3 .*A(136)

)

A(125)=(A(131)+1 . ) / (A(124)*A(124)

)

Ak| C O O A A UNtZ Z 00

AllCOOl A UNcZZ 10

A(53)=(A(125)*A(121) ) / ( (A(131)-l .0)* (A (125) / ( 1 . 0-A ( 124 ) +2 a ik / i ic \ ftllCi'i Oft

. 0/ A ( 125 ) UNL2220

1)-A(121) )

)

UNt2Z30

CALL PR0B (A(131)-1.0,AINT(A(125)+.5),A(53),A(54)) UNt2240

A (130)= (A (133) -A (129) /A (133) ) /A (136) UNt2250

A(47)=(A(6)-A(9))/A(130) 0NE2260

COMPUTATIONS ARE NOW COMPLETE ************************************QNE2270

M0=L2-12 0NE228C

GO TO (170,480) , M0 0NE2290

AUTOMATIC PRINTING WHEN L2=13 0NE2300

FORMAT STATEMENTS 0NE2310

CALL PAGE (4) 0NE2320

PRINT AN0VA 0NE2330

WRITE ( IPRINT , 520

)

0NE2340

202
180

190

200

210

220

230

240

250

260

WRITE ( IPRINT , 530 ) Ml , A ( 1 )

, A (6 ), A ( 11 ), A ( 14 ) IF (K.LT.3) GO TO 180

IF (A(14) .GE . .10) GO TO 180

WRITE (IPRINT, 540) M2 , A (2 ), A (7 )

, A ( 12 )

, A ( 15

)

WRITE ( IPRINT ,550) M3 , A (3 ) , A (8 ) , A ( 13 ) , A ( 16

)

WRITE (IPRINT, 560) M4,A(4),A(9)

WRITE (IPRINT,570) M5,A(5)

PRINT KRUSKAL-WALLIS TEST

WRITE (IPRINT, 580) A(17),A(20)

PRINT ESTIMATES

WRITE (IPRINT.590)

DO 220 1=1,

K

A(107)=BLANK

A(108)=BLANK

IF (B2(I)-1.0) 220,190,190

IF (B3(I) .LE.A(22)) A(107)=SL0

IF (B3(I) .GE.A(23)) A(107)=HIGH

IF (B4(I) .LE.A(24)) A(108)=SL0

IF (B4(I) .GE.A(25)) A(108)=HIGH

0NE2350

0NE2360

0NE2370

ONE2380

0NE2390

0NE2400

0NE2410

0NE2420

0NE2430

0NE2440

0NE2450

0NE2460

0NE2470

0NE2480

0NE2490

0NE2500

0NE2510

0NE2520

0NE2530

0NE2540

0NE2550

0NE2560

0NE2570

0NE2580

0NE2590

ONE2600

0NE2610

270

280

(B3(I) .GE.A(23))

(B4(I) .LE.A(24))

(B4(I) .GE.A(25))

M8=B2(I)

IF (M8-1) 220,200,210

WRITE (IPRINT, 610) I , M8 , B3 ( I ), A ( 107 ), B6 ( I )

, B7 ( I ) ,B5 ( I

)

GO TO 220

A(109)=B4(I)/FSQRT(B2(I))

CALL TPCTPT (FLOAT (M8-1 ) ,A (112 )

)

A(110)=B3(I)-A(109)*A(112)

A(111)=B3(I)+A(109)*A(112)

WRITE (IPRINT, 600) I , M8 ,B3 ( I )

, A ( 107 )

, B4 ( I ), A ( 108 ), A ( 109 ), B6 ( I ) ,B7 (0NE2620

II) ,B5(I) ,A(110) ,A(111) 0NE2630

CONTINUE 0NE2640

WRITE (IPRINT, 620) NZW, A (21 )

, A (26 ), A (27 ), A (31 ), A (34 ), A (41 ), A (44 ) ,A0NE2650

1 (32) ,A(35) ,A(42) ,A(45) ,A(33) ,A(36) ,A(43) ,A(46) 0NE2660

COMPUTE AND PRINT FOR MULTIPLE COMPARISONS 0NE2670

IF (A(14)-0.10) 230,450,450 0NE2680

IF (M4.LT.4) GO TO 340 0NE2690

WRITE (IPRINT, 630) ONE2700

NEWMAN-KEULS-HARTLEY 0NE2710

WRITE (IPRINT, 640) 0NE2720

J=l 0NE2730

M28=0 0NE2740

I=K 0NE2750

IF (I-M28) 330,330,260 0NE2760

IF (I .EQ.J) GO TO 280 0NE2770

A(135)=ABS(B8(I)-B8(J) ) 0NE2780

MANDEL APPROXIMATION TO PERCENT POINT OF STUDENTIZED RANGE 0NE2790

A (137 )=I-J+1 0NE2800

RX=-. 283917+2 .63532* (A ( 134 )-l . 00123 ) ** (-.95862) ONE2810

Ul=-. 314115+2 .38301* (A ( 134 ) -1 . 03428 )**(-. 864005 ) ONE2820

U2=3.65961*Ul**2-1.00891*Ul-0. 166346 0NE2830

C=2 .3849867-2. 9051857* (A (137) -0.57583164)** (-.069648109) 0NE2840

Vl=l .30153-1 .95073* (A ( 137 )+. 394915 ) ** (-.139783) 0NE2850

V2=4.72863*Vl**2+0. 40427 l*Vl-0. 135104 0NE2860

A ( 119 )=6. 15075+4. 441409*RX+6.7514569*C+7 .467 1282*U1*V1-.157537*U2*0NE2870

1V2 0NE2880

A(119)=A(119)*FSQRT( .5* (1 .0/B9(I)+l .0/B9(J) ) )*A(31) 0NE2890

IF (A(135)-A(119) ) 280,280,270 0NE2900

1=1-1 0NE2910

GO TO 250 0NE2920

IF (J.EQ.l) GO TO 310 ONE2930

203
IF (J-M28) 290,290,300

290 WRITE (IPRINT ,670 ) GO TO 310

300 WRITE (IPRINT, 680)

310 WRITE (IPRINT, 660) (B8 (M29 ), M29=J , I

)

IF (I-K) 320,340,340

320 M28=I

330 J=J+1

GO TO 240

C SCHEFFE METHOD

340 WRITE (IPRINT, 650)

J=l

M28=0

350 I=K

360 IF (I-M28) 440,440,370

370 IF (I.EQ.J) GO TO 390

A(135)=ABS(B8(I)-B8(J)

)

A(119)=A(116)*FSQRT(1 .0/B9 (I )+l .0/B9(J)

)

IF (A(135)-A(119) ) 390,390,380

380 1=1-1

GO TO 360

390 IF (J.EQ.l) GO TO 420

IF (J-M28) 400,400,410

400 WRITE (IPRINT, 670)

GO TO 420

410 WRITE (IPRINT, 680)

420 WRITE (IPRINT, 660) (B8 (M29 )

, M29=J , I

)

IF (I-K) 430,450,450

430 M28=I

440 J=J+1

GO TO 350

450 IF (A(131) .LT.2.0) GO TO 480

WRITE (IPRINT, 690) A (51 )

, A (52 )

, A (53 )

, A (54 ), A ( 57

)

IF (A(52) .GT. .10.AND.A(54) .GT. .10) GO TO 470

DO 460 1=1,

K

A(55)=A(55)+B10(I)*(B3 ( I )-A (126 ) )**2

A(128)=A(128)+(1.-B10(I)/A(127))**2/(B2(I)-1 .

)

A(128)=(FL0AT(K**2)-1 . ) / (3 . *A (128)

)

A (55)= (A (55) /FLOAT (Ml) ) / (1 .+(2 . *FLOAT (M3 ) ) / (3 .*A(128)

)

CALL PROB (FLOAT (Ml) ,AINT(A(128)+.5) ,A(55) ,A(56))

WRITE (IPRINT,700) A(55),A(56)

WRITE (IPRINT, 710) A(47)

AUTOMATIC PRINTOUT IS FINISHED - NOW STORE RESULTS ***

IF (NARGS.EQ.2) GO TO 510

M13=IARGS(3)

M14=IARGS(4)

M15=IARGS(5)

M16=IARGS(6)

DO 500 1=1,

K

C DONT STORE IF N=0

IF (B2(I) .LE.O.O) GO TO 490

C TAG

RC(M13)=I

C NRC(M14)=B2(I)

C XBAR

RC(M15)=B3(I)

C STANDARD DEVIATION

460

470

C

C

480

ONE2940

ONE2950

0NE2960

ONE2970

0NE2980

0NE2990

0NE3000

0NE3010

ONE3020

ONE3030

0NE3040

0NE3050

0NE3060

0NE3070

0NE3080

0NE3090

0NE3100

0NE3110

0NE3120

0NE3130

0NE3140

0NE3150

0NE3160

0NE3170

ONE3180

0NE3190

0NE3200

0NE3210

0NE3220

0NE3230

0NE3240

0NE3250

0NE3260

0NE3270

0NE3280

0NE3290

0NE3300

0NE3310

) 0NE3320

0NE3330

ONE3340

0NE3350

0NE3370

0NE3380

0NE3390

0NE3400

0NE3410

0NE3420

0NE3430

0NE3440

0NE3450

0NE3460

0NE3470

0NE3480

0NE3490

0NE3S00

0NE3510

0NE3520

204
RC(M16)=B4(I) 0NE3530

490 M13=M13+1 0NE3540

M14=M14+1 0NE3550

M15=M15+1 0NE3560

500 M16=M16+1 0NE3570

510 RETURN 0NE3580

C 0NE3590

C 0NE3600

520 FORMAT (/ / ,48X , 20HANALYSI S OF VARIANCE/ / 17X , 6HS0URCE , 14X , 4HD . F ., 4X0NE3610

1 ( 14HSUM OF SQUARES, 5X,12HMEAN SQUARES , 9X , 7HF RATIO, 4X,7HF PROB./) 0NE3620

530 FORMAT (17X , 14HBETWEEN GROUPS , 5X , 14 , 1P2E18 . 6 , 4X , OPFll . 3 , F10 . 3 ) 0NE3630

540 FORMAT (20X , 5HSL0PE , 14X , 14 , 1P2E18 . 6 , 3X , OPFll . 3 , F10 . 3 ) 0NE3640

550 FORMAT (20X , 16HDEVS . ABOUT LINE , 3X , 14 , 1P2E18 . 6 , 3X , OPFll . 3 , F10 . 3 ) 0NE3650

560 FORMAT (17X , 13HWITHIN GROUPS , 6X , 14 , 1P2E18 . 6 ) 0NE3660

570 FORMAT (17X , 5HT0TAL , 14X , 14 , 1PE18 . 6 / /) 0NE3670

580 FORMAT (11X ,65HKRUSKAL-WALLIS RANK TEST FOR DIFFERENCE BETWEEN GR00NE3680

1UP MEANS * H =,0PF9.3,10H, F PROB =,F6.3,10H (APPROX.)/) 0NE3690

590 FORMAT (55X , 9HESTI MATES // IX , 5HGR0UP , 5X , 3HN0 . , 6X , 4HMEAN , 7X , 11HWITHI0NE3700

IN S.D. ,2X,12HS.D. OF MEAN , 5X , 7HMINIMUM, 7X , 7HMAXIMUM, 6X , 4HS (R ), 4X , 20NE37 10

23H95PCT CONF INT FOR MEAN/) 0NE3720

600 FORMAT ( IX , 14 , 18 , 1PE14 . 5 , Al , E13 . 5 , Al , E13 . 5 , 2E14 . 5 , 0PF9 . 1 , 1PE13 . 5 , 30NE3730

1H T0.E12.5) 0NE3740

610 FORMAT (IX , 14 , 18 , 1PE14 . 5 , Al , 3X , 24H ESTIMATE NOT AVAILABLE , 1P2E14 . 0NE3750

15 0PF9 1 3X 2 5H* ******** * jo **********\ 0NE3760

620 FORMAT ( / , IX , 5HT0TAL , 1 7 , 1PE14 . 5 , 28X , 2E14 . 5 /7X , 20HFIXED EFFECTS M0D0NE3770

1EL ,2E14.5,37X,E13.5,3H TO , E12 . 5 /7X , 20HRAND0M EFFECTS MODEL ,, 2E14 . 0NE3780

25,37X,E13 .5,3H TO , E12 . 5 /7X , 14HUNGR0UPED DATA , 6X , 2E14 . 5 , 37X , E13 . 5 , 30NE3790

3H T0,E12.5/) 0NE3800

630 FORMAT (IX , 120HPAIRWI SE MULTIPLE COMPARISON OF MEANS. THE MEANS A0NE3810

IRE PUT IN INCREASING ORDER IN GROUPS SEPARATED BY *****. A MEAN I0NE3820

2S /120H ADJUDGED NON-SIGNIFICANTLY DIFFERENT FROM ANY MEAN IN THE0NE3830

3 SAME GROUP AND SIGNIFICANTLY DIFFERENT AT THE .05 LEVEL FROM /1200NE3840

4H ANY MEAN IN ANOTHER GROUP. ***** ***** INDICATES ADJACENT GR0UP0NE3850

5S HAVE NO COMMON MEAN. ) 0NE3860

640 FORMAT ( /3X , 89HNEWMAN-KEULS TECHNIQUE, HARTLEY MODIFICATION. (APPR0NE3870

10XIMATE IF GROUP NUMBERS ARE UNEQUAL.)) ONE3880

650 FORMAT ( /3X , 18HSCHEFFE TECHNIQUE.) ONE3890

660 FORMAT (3X , 9 ( 1PE12 . 5 , 1H , )

) 0NE3900

670 FORMAT (6X,5H*****) 0NE3910

680 FORMAT (3X,11H***** *****) 0NE3920

690 FORMAT (/,36H TESTS FOR HOMOGENEITY OF VARIANCES . /7X , 13HC0CHRAN , S 0NE3930

1C =31H MAX. VARIANCE/SUM(VARIANCES) =,F6.4,5H, P =,F6.3,10H (APPR00NE3940

2X. ) /7X , 16HBARTLETT-B0X F =,F9.3,5H, P = , F6 . 3 /7X , 37HMAXIMUM VARIANC0NE3950

3E / MINIMUM VARIANCE =,F10.3) 0NE3960

700 FORMAT (7X , 70HAPPR0X BETWEEN MEANS F-TEST IN PRESENCE OF HETER0GEN0NE3970

1E0US VARIANCE. F =,F8.3,5H, P =,F6.3) 0NE3980

710 FORMAT ( / , IX , 35HM0DEL II - COMPONENTS OF VARIANCE. /7X , 29HESTIMATE0NE3990

1 OF BETWEEN COMPONENT , 1PE15 . 7 ) 0NE4000

END 0NE4010

409-118 OL - 71 - 14

205
SUBROUTINE OPONE (N , M, MX ,NX ,ND2 , ND3 , ND19 , B , SSQ , IX ) OPO 10

C VERSION 5.00 OPONE 5/15/70 OPO 20

C SUBROUTINE TO PRINT PAGE 1 OF POLYFIT AND FIT OPO 30

C ***** QPO 40

C WRITTEN BY DAVID HOGBEN , SEL, NBS . 10/14/69. OPO 50

C0MM0N/BL0CRC/NRC,RC(12600) OPO 60

COMMON /BLOCKE/ NAME (4) ,L1,L2,ISRFLG OPO 70

COMMON/HEADER /NOCARD (80) ,ITLE(60,6) , LNCNT , I PR I NT , NPAGE , I PUNCH OPO 80

C0MM0N/SCRAT/NS,NS2,A(13500) OPO 90

COMMON /KFMT/KFMT (100) OPO 100

C0MM0N/FMAT/IFMTX(6) ,I0SWT,IFMTS(6) ,LHEAD (96) OPO 110

COMMON/BLOCKD/IARGS(100) , KIND (100) ,ARGTAB (100

)

( NRMAX ,NROW,NCOL , OPO 120

1NARGS ,VWXYZ (8) ,NERROR OPO 130

DIMENSION ARGS(IOO) , I IRGS (100 ) OPO 140

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )),( I IRGS ( 1

)

( KFMT ( 1 )

) OPO 150

DIMENSION B(l) OPO 160

C ***** OPO 170

C ***** OPO 180

C ***** OPO 190

C ***** OPO 200

IF (L2.EQ.1) GO TO 1620 OPO 210

IF (MX.GT.l) GO TO 1640 OPO 220

1620 WRITE (IPRINT, 1625) (LHEAD ( 1 1 )

, 1 1=13 , 24 ) , (LHEAD ( 1 2 ), 1 2=1 , 12 )

, OPO 230

1 IARGS(IX) ,IARGS(1) OPO 240

1625 FORMAT ( / /5X , 2 (4X , 12A1 ,4X) , 6X , 9HPREDICTED , 8X , 12HSTD . DEV. 0F,25X, OPO 250

1 4HSTD . /2X , 3HR0W, 3X , 9HIN COLUMN , 1 5 , 6X , 9HIN COLUMN , 1 5 , 10X , 6HVALUE0P0 260

2S,10X,12HPRED. VALUES , 8X , 9HRESIDUALS , 8X , 4HRES ., 3X , 7HWEIGHTS/ ) OPO 270

GO TO 1660 OPO 280

1640 IF (MX.GT.2) GO TO 1650 OPO 290

WRITE (IPRINT, 1645) (LHEAD ( I )

, 1=1 , 12 ), I ARGS (NX+4 ), I ARGS (NX+5 ), OPO 300

1 IARGS(l) OPO 310

1645 FORMAT ( / /8X , 22HPREDICT0R VARIABLES IN , 6X , 12A1 , 8X , 9HPREDICTED , 6X , OPO 320

1 12HSTD. DEV. OF , 22X , 4HSTD . /2X , 3HR0W, 3X , 4HC0L . , 14 ,6X ,4HC0L . ,I4,8X,0P0 330

24HC0L. ,I4,11X,6HVALUES,8X,12HPRED. VALUES ,6X ,9HRESIDUALS ,7X ,4HRES .OPO 340

3,3X,7HWEIGHTS/) OPO 350

GO TO 1660 OPO 360

1650 WRITE (IPRINT, 1655) (LHEAD (I ), 1=1 , 12) , IARGS (NX+4) , IARGS (NX+5) , OPO 370

1 IARGS(NX+6) ,IARGS(1) OPO 380

1655 FORMAT ( / /12X , 22HPREDICT0R VARIABLES IN , 9X , 12A1 , 6X , 9HPREDICTED , 4X OPO 390

1,12HSTD. DEV. OF , 19X ,4HSTD . /2X , 3HR0W, 2X , 3 (4HC0L . , 14 , 4X) , 2X , 4HC0L . ,0P0 400

2I4,9X,6HVALUES,6X,12HPRED. VALUES , 4X , 9HRESI DUALS , 6X , 4HRES ., 3X , OPO 410

37HWEIGHTS /) OPO 420

1660 IX = IIRGS(IX) OPO 430

IY = IIRGS(l) OPO 440

IND3 = ND3+1 OPO 450

IND2 = ND2+1 OPO 460

IND4 = ND19+1 OPO 470

LL = 0 OPO 480

NSD = 8 OPO 490

NWM = 18 OPO 500

IF (L2.EQ.1 .OR. MX.EQ.l) GO TO 1666 OPO 510

1X2 = IIRGS(NX+5) OPO 520

NWM = 2*(2/MX) OPO 530

LL = 4-NWM OPO 540

NSD = 4+NWM OPO 550

NWM = NWM+10 OPO 560

CALL RFORMT (RC ( 1X2 ) ,N ,NSD ,NW2 ,^IDEC2 ,NWM, A (1 ) , A (1 ) ,0,0) OPO 570

IF (MX.EQ.2) GO TO 1666 OPO 580

1X3 = IIRGS(NX+6) OPO 590

206
1667

1670

1680

CALL RFORMT (RC ( 1X3 )

, N ,NSD ,NW3 ,NDEC3 ,NWM, A (1 )

, A (1 ) ,0,0) 0P0 600

1666 CALL RFORMT (RC(IX )

, N , NSO , NW1 , NDEC1 , NWM ,A(1) ,A(1) ,0,0) OPO 610

CALL RFORMT (RC(IY ),N, 8 ,NW4 , NDEC4 , 18-LL , A (1 )

, A ( 1 )

, 0 , 0 ) OPO 620

CALL RFORMT (A(IND3),N, 8 , NW5 , NDEC5 , 17-LL , A (1 )

, A ( 1 ), 0 , 0 ) OPO 630

CALL RFORMT (A(IND2),N, 8 , NW6 , NDEC6 , 17-LL , A ( 1 )

, A ( 1 )

, 0 , 0 ) OPO 640

CALL RFORMT (A(IND4),N, 8 , NW7 , NDEC7 , 17-LL , A ( 1 )

, A ( 1 ), 0 , 0 ) OPO 650

IF (KIND(2) .EQ.l) GO TO 1667 OPO 660

IW = I IRGS (2 ) OPO 670

CALL RFORMT (RC ( I W) , N , 4 , NW9 , NDEC9 , 9 , A ( 1 )

, A ( 1 ), 0 , 0 ) OPO 680

GO TO 1680 OPO 690

CALL RFORMT (ARGS (2 ) ,1,4 ,NW9 ,NDEC9 ,9,A(1) ,A(1) ,0,0) OPO 700

CALL RFORMT (A ( 1 ), 1 , 4 , NW9 , NDEC9 , 0 , ARGS (2 ), B (98 ), 11-NW9 , 1 ) OPO 710

WT=ARGS(2) OPO 715

FORMAT (1X,I4,97A1,0PF7.2,11A1) OPO 720

DO 1745 1=1, N OPO 730

CALL RFORMT (A (1 ), 1 , NSD ,NW1 , NDECl , 0 , RC ( IX ), B ( 1 )

, NWM+2-NW1 , 1 ) OPO 740

IF (L2.EQ.1 .OR. MX. EQ.l) GO TO 1685 OPO 750

CALL RFORMT (A ( 1 ), 1 ,NSD ,NW2 , NDEC2 , 0 , RC ( 1X2 ) , B (NWM+3 )

, NWM+2-NW2 , 1 ) OPO 760

1X2 = 1X2+1 OPO 770

IF (MX.EQ.2) GO TO 1685 OPO 780

CALL RFORMT (A (1 )

, 1 , NSD , NW3 , NDEC3 , 0 , RC ( 1X3 ), B (25 )

, 12-NW3 , 1 ) OPO 790

1X3 = 1X3+1 OPO 800

1685 CALL RFORMT (A (1 ) ,1,8 ,NW4 ,NDEC4 , 0 , RC ( IY ) ,B (4*LL+21 )

, 20-LL-NW4 , 1 ) OPO 810

CALL RFORMT (A (1 )

, 1 , 8 , NW5 ,NDEC5 , 0 , A ( IND3 ), B (3*LL+41 )

, 19-LL-NW5 , 1 ) OPO 820

CALL RFORMT (A ( 1 )

, 1 , 8 , NW6 ,NDEC6 , 0 , A ( IND2 )

, B (2*LL+60 ), 19-LL-NW6 , 1 ) OPO 830

CALL RFORMT (A ( 1 ), 1 , 8 , NW7 ,NDEC7 , 0 , A ( IND4 ), B (LL + 79 )

, 19-LL-NW7 , 1 ) OPO 840

IF (KIND(2) .EQ.l) GO TO 1730 OPO 850

CALL RFORMT (A ( 1 )

, 1 , 4 , NW9 , NDEC9 , 0 , RC ( I W) , B (98 )

, 11-NW9 , 1 ) OPO 860

WT=RC(IW) OPO 865

IW = IW+1 OPO 870

1730 IF(WT.GT.O.O) STDRES=A (IND4) /FSQRT (SSQ/ WT-A ( IND2 ) **2 ) OPO 875

IF(WT.LE.O.O) STDRES=0.0 OPO 880

WRITE (IPRINT,1670) I , (B ( 1 1 )

, 1 1=1 , 97 ), STDRES , (B ( 1 1 )

, 1 1=98 , 108 ) OPO 890

1740 IX = IX+1 OPO 900

IY = IY+1 OPO 910

IND3 = IND3+1 OPO 920

IND2 = IND2+1 OPO 930

1745 IND4 = IND4+1 OPO 940

RETURN OPO 950

END OPO 960

207
SUBROUTINE ORTHO ORT 10

C VERSION 5.00 ORTHO 5/15/70 ORT 20

DOUBLE PRECISION FDSQRT ,DK2 , SUM, Y SUM ORT 40

COMMON /ABCDEF/ L(48) ORT 50

COMMON /BLOCRC/ NRC , RC ( 12600 ) ORT 60

COMMON /BLOCKD/ I ARGS ( 100 ), KIND ( 100 )

, ARGTAB ( 100 ), NRMAX , NROW, NCOL , NORT 70

1ARGS ,VWXYZ(8) ,NERROR ORT 80

DIMENSION ARGS(IOO) ORT 90

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 ) ) ORT 100

COMMON /BLOCKE/ NAME (4 ), LI , L2 , I SRFLG ORT 110

COMMON /HEADER/ NOCARD (80 )

, ITLE (60 , 6 )

, LNCNT , IPRINT , NPAGE , IPUNCH ORT 120

COMMON /SCRAT/ NS , NS2 , A ( 13500 ) ORT 130

COMMON /KFMT / KFMT(IOO) ORT 140

COMMON /FMAT / IFMTX (6) , IOSWT , IFMTS (6) ,LHEAD (96) ORT 150

DIMENSION IIRGS(IOO) ORT 160

EQUIVALENCE ( I IRGS ( 1 )

, KFMT ( 1 ) ) , (B (1) , IB) ORT 170

DIMENSION IMTRXA(2,3) ORT 180

DIMENSION B(120), IHC(4), IHT(8) ORT 190

DATA IHC(l) ,IHC(2) , IHC (3) ,IHC(4)/3H TE ,3HRM ,3HC0L ,3HUMN/ ORT 200

q *** ******* ******* ORT 210

C ORTHONORMALIZATION PROGRAM BY PHILIP J. WALSH JULY 1, 1967 ORT 220

C REVISED BY S. PEAVY 5/28/68 ORT 230

C REVISED BY DAVID HOGBEN AND SALLY PEAVY, SEL, NBS . 9/23/69. ORT 240

C LEAST SQUARES PROGRAM USING GRAM SCHMIDT PROCESS ORT 250

C ORT 260

C POLYFIT Y IN COL ++ WITH WEIGHTS (ALL EQUAL TO **) ORT 270

C (IN COL ++) ORT 280

C USING POLYNOMIAL OF DEGREE ,

, TO X IN COL ++ ORT 290

C STORE: COEFFICIENTS IN COL ++ ORT 300

C DEVIATIONS IN COL ++ ORT 310

C STANDARD DEV OF PREDICTED VALUES IN COL ++ ORT 320

C FOURIER COEFFICIENTS IN COL ++ ORT 330

C VARIANCE COVARIANCE MATRIX STARTING IN ( , , ++) ORT 340

C ONLY FIRST 4 ARGUMENTS MUST BE SPECIFIED. ORT 350

C STORAGE WILL TAKE PLACE FOR ONLY THE STORAGE ARGUMENTS ORT 360

C PROVIDED ORT 370

C L2=l POLYFIT: L2=2 SPOLYFIT ORT 380

C ORT 390

C FIT Y IN COL ++ WITH WEIGHTS (ALL EQUAL TO **) AS A ORT 400

C (IN COL ++) ORT 410

C FUNCTION OF K=++ VARIABLES IN COLS ++,++,++ +++ ORT 420

C STORE: COEFFICIENTS IN COL ++ ORT 430

C DEVIATIONS IN COL ++ ORT 440

C STANDARD DEV OF PREDICTED VALUES IN COL ++ ORT 450

C FOURIER COEFFICIENTS, ETC. IN COL ++ ORT 460

C VARIANCE COVARIANCE MATRIX STARTING IN (++ ,,) ORT 470

C MINIMUM OF 4 ARGUMENTS IS NEEDED BEFORE COMMAND IS EXEC. ORT 480

C L2=3 FIT : L2=4 SFIT ORT 490

C ORT 500

C MORTHO X (,, ++) R= ( , C=, , WITH WEIGHTS ( ALL EQUAL TO **) ORT 510

C ( IN COL ++) ORT 520

C STORE IN M (,, ++) A MATRIX IN ( , , ++) ORT 530

C L2=5 MORTHO: ORT 540

C ORT 550

C ORT 560

IXl(I,J,IN)=IN+(I*(I-l))/2+J ORT 570

C PRECHECKING SECTION ORT 580

IF (L2.EQ.1.0R.L2.EQ.3) GO TO 8 ORT 582

IF (L2.EQ.2) IF (NARGS-4) 8,6,8 ORT 584

208
IF (NARGS.NE.IARGS(3)+3) GO TO 8 ORT 586

6 CALL ERROR (236) ORT 588

RETURN ORT 590

8 IREFIT=0 ORT 595

IF (NARGS.GT.O) GO TO 10 ORT 600

CALL ERROR (10) ORT 610

RETURN ORT 620

10 IF (NRMAX.NE.O) GO TO 20 ORT 630

CALL ERROR (9) ORT 640

RETURN ORT 650

20 NMUI=1 ORT 660

C IF L2 =5 THEN COMMAND IS MORTHO ORT. 670

IF (L2.EQ.5) GO TO 1850 ORT 680

IF (NARGS.LT.4) GO TO 1830 ORT 690

c COMMAND IS POLYFIT OR FIT ORT 700

CALL ADRESS (1 , I IRGS (1 )

)

ORT 710

IF ( I IRGS (1 ) .LE.O) CALL ERROR (11) ORT 720

IF (KIND(2) .EQ.l) GO TO 30 ORT 730

CALL ADRESS (2,1 IRGS (2 )

)

ORT 740

IF (I IRGS (2 ) .LE.O) CALL ERROR (11) ORT 750

GO TO 40 ORT 760

30 SU=NRMAX ORT 770

WSUM=SU ORT 780

IF (ARGS (2) .LE .0 .0) CALL ERROR (24) ORT 790

NMUI=2 ORT 800

40 NST=1 ORT 810

IF (KIND (3) .EQ.l) I ARGS (3 )=ARGS (3

)

ORT 815

NEND=NARGS ORT 820

J=NARGS-4 ORT 825

IF(L2.GT.2) J=J-IARGS(3)+1 ORT 830

IF (J .LE.4.AND.J .GE.O) GO TO 50 ORT 835

IF (J .NE.6) GO TO 1830 ORT 837

45 NEND=NARGS-2 ORT 840

NST=2 ORT 850

50 DO 60 I=4,NEND ORT 860

CALL ADRESS (I , I IRGS ( I )

)

ORT 870

IF ( I IRGS ( I ) .LE.O) CALL ERROR (11) ORT 880

60 CONTINUE ORT 890

M=IARGS(3) ORT 900

IF (L2.LE.2) M=M+1 ORT 910

N=NRMAX ORT 920

FN=N ORT 930

GO TO (100,70) , NST ORT 940

70 CALL ADRESS (NARGS , 1ST) ORT 950

IF (IST.GT.O) GO TO 80 ORT 960

CALL ERROR (11) ORT 970

RETURN ORT 980

80 MMTXR=M ORT 990

MMTXC=M ORT1000

IST=IST-1+IARGS (NARGS-1

)

0RT1010

IF (IARGS(NARGS)+M-1.GT.NC0L) MMTXC=NCOL-• IARGS(NARGS)+1 0RT1020

IF (IARGS(NARGS-1)+M-1.GT.NR0W) MMTXR=NROW-I ARGS (NARGS-1 )+l 0RT1030

IF (MMTXR.GT.O) GO TO 90 0RT1040

NARGS=NARGS-2 0RT1050

CALL ERROR (213) 0RT1060

GO TO 100 0RT1070

90 IF (MMTXR . NE . M.-OR . MMTXC . NE . M) CALL ERROR (213) 0RT1080

100 GO TO (110,140), NMUI 0RT1090

110 SU=0 .0 0RT1100

! 209
WSUM=0.0

L22=I IRGS (2

)

L22A=L22

DO 130 1=1 ,N

IF (RC(L22A)) 1840,130,120

SU=SU+1.0

WSUM=WSUM+RC(L22A)

L22A=L22A+1

FM=M

IF (SU-FM) 150,160,170

CALL F.RROR (24)

RETURN

DENOM=1.0

GO TO 180

DENOM=FSQRT (SU-FM)

NPM=N+M

M1=M-1

M2=M+1

N1=N-1

N2=N+1

MD1=(M* (M2)

)

/2

ND1=M2*NPM

X REQUIRES ND1 CELLS

GET A (ND1 +1) FOR START OF PK

ND2=M*NPM

MD3=N02+N

ND3=ND1

ADD NPM TO REACH XP

ND4=ND3+NPM

ADD NPM TO REACH QK

ND5=ND4+NPM

ADD (M+l) TO REACH CV

ND6=ND5+M2

ADD (M*(M+l))/2 + M TO REACH VCV

ND66=MD1+M

ND7=ND6+ND66

ADD THE SAME AMOUNT TO REACH Q

ND8=ND7+ND66

Q IS (M+l) CELLS LONG THEN COMES Q2

ND9=ND8+M2

Q2 E AND EP ARE EACH M CELLS LONG

ND10=ND9+M

ND11=ND10+M

ND12=ND11+M

THE A MATRIX IS NEXT

ND13=ND12+MD1

GRAM FACTOR STORAGE

ND14=ND13+M2

ENF

CV DIAGONALS

ND16=ND14+M

VCV DIAGONALS

ND17=ND16+M

ND18=ND17+M

ND19=ND18+NPM

ND20=ND19+N

IF (IREFIT.EQ.l) GO TO 190

ORT1110

0RT1120

ORT1130

0RT1140

0RT1150

ORT1160

0RT1170

0RT1180

0RT1190

0RT1200

0RT1210

0RT1220

0RT1230

0RT1240

0RT1250

0RT1260

0RT1270

0RT1280

0RT1290

0RT1300

0RT1310

0RT1320

0RT1330

0RT1340

0RT1350

0RT1360

0RT1370

0RT1380

0RT1390

ORT1400

0RT1410

0RT1420

0RT1430

0RT1440

0RT1450

0RT1460

ORT1470

0RT1480

0RT1490

0RT1500

0RT1510

0RT1520

0RT1530

ORT1540

0RT1550

0RT1560

0RT1570

0RT1580

0RT1590

ORT1600

0RT1610

0RT1620

0RT1630

0RT1640

0RT1650

0RT1660

0RT1670

0RT1680

0RT1690

210
x i— > ai

aaa ax nr\aa i i rnnAn / a *>\ IF (ND20.GT.NS) CALL ERROR (23) 0RT1700

IF (NERROR . NE . 0 ) RETURN 0RT1710

190 ti

nn An i NRBAR=1 Ai

A ^T" "IT f\ f\ 0RT1720

1=1 IRGS (1 )0RT1730

L22A=L22 0RT1732

Artllf 1 OA / I OA\ C0NS3=RC (L22) Ai

A T" 1 oo 0RT1733 I F (KIND (2 ) . EQ . 1 ) C0NS3=ARGS (2 )

0RT1735

AA AI t" 1 AA / T\ C0NS1=RC ( I )

0RT1736

AAlirn

AA / T\ C0NS2=RC ( I )

0RT1737

aa iac Ti i hintiAv DO 195 I1=1,NRMAX

AAT 1 *T

a 0RT1738

TT / 1/T lin / 1 \ t~A r\\AA AI

A *i

AA / l aaA\ IF (KIND (2 ) . EQ . 0 ) C0NS3=RC (L22A) 0RT1740

IF(C0NS3) 192,192,191 0RT1741

191

AA AI f*AA / T\ C0NS=RC ( I )

0RT1742

TT / Artiif ITAA AI

a i v Art tir i a Akir

IF (CONS .LT .C0NS1) C0NS1=C0NS 0RT1743 T r- / A AllA AX A A II f A \ AAIIA « A Allf

IF (CONS .61 .C0NS2) C0NS2=C0NS 0RT1745

192

TT 1 1 = 1+1 0RT1746

TAC 195 1 AAA 1 AAA 1 L22A=L22A+1 0RT1747

YC0NS= (C0NS2+C0NS1 ) /2 .0 0RT1748 A A X A / A A /"» AAA A i A A 1 fi n i A I 1 A GO TO (200,200,240,240,240), L2 0RT1750

L TUTC TC nAI uriT 1 H 1 S IS POLYF I ( A

AX 1 *^ / a 0RT1760

AAA 200 L33=I IRGS (4 )

0RT1770

ft aw

a

nA

A

r MXARGS=5 0RT1780 1 O O A lOO L33A=L33 0RT1790

K=NPM+1 0RT1800

f\A ATA

T i AI UU 210 1=1 , N

A

AX 1 A 1 A ORT1810

A / T\ 1 A

A ( I )=1 . 0 A

AX ^ AAA ORT1820

A / 1/\ r>A / I OOA\

A (K)=RC (L33A) 0RT1830

1/ 1/ 1 K=K+1 0RT1840

A 1 A 210 IOOA lOOA 1 L33A=L33A+1 0RT1850

TC / Ai

C

AA

\

AA TA AAA IF (M.EQ.2) GO TO 320 A\

A ^ A£A 0RT1860

f\A AOA L/

A 111 DO 230 K=2,M1 0RT1870

IOOA IOO L33A=L33 0RT1880

K2=K*NPM+1 0RT1890

1/1 1/A IIDtl K1=K2-NPM 0RT1900

UU 220 1=1 , N

AAX 1 A 1 A ORT1910

A / 1/A\A\ * AA • 1 OOA\ A(K2)=A(K1).RC(L33A) Ai f"^ ^ A

AA ORT1920

1/A 1/A 1 K2=K2+1 0RT1930

K1=K1+1 ORT1940

220 1 **

rl ft 1 "6 ft 1 L33A=L33A+1 0RT1950

A "5A 230 AAiiT

T All IC CONTINUE

A

A

T "1A#A 0RT1960

AAXA GO TO 320 0RT1970

240

TA 1=4

A fi^k * AAA 0RT1980

AC

r TllnA 1 | Tt r* All

V / T\ 1 A TC IfA FIND OUT IF ALL X(I) = 1.0, IF 50

C t~T AIV 1 tin AAV

RA i SET NX=1 AND MX=M-1 . A

AX 1 AAA 0RT1990 1 A A T T A A A / ^ \ L33=I IRGS (4) A A X* A A A A 0RT2000

ftl V/ i NX=1AAXAA 1 a 0RT2010

|-\A AAA AI 111/ 1 Al DO 250 NW6=1,N

AAXAAAA ORT2020

T ^ /AAC/HA/IOA\ 1 A\ If" 1 r* / \AA IF (ABS (RC (L33)-l .0) .LE . 1 .E-6) GO TO 250

A dOTAAAA 0RT2030

NX=0

AAAAaA 0RT2040

AA ASA GO TO 260 0RT2050

OCA 250 loo IOO 1 L33=L33-t-l

A

n

X OA/A ORT2060

"1 / A 260 KfV IJA

VA / 1 11 AIV\ MX=MAX0 ( 1 , M-NX )

ART

A AOA ORT2070

IF(NX.EQ.0.0R.L2.EQ.5) YC0NS=0.0 A\

AA

A 0RT2075

||w

A nAA ftl4 MXARGS=M+4 ORT2080 1 MM ft SW ft A A A t L44=MXARGS-1 A F\ A A A A ORT2090

J=l 0RT2100

ATA 270

AAA 1 AT 1 T 1 MM DO 310 11=1 ,L44

AOTA 1 rA 0RT2150

l/i 1 K1=JAAXA 1 / A 0RT2160

L33=I I RGS (11) 0RT2170

K2=K1 0RT2180

211
nn inn

T 9— l m

PDT 9 1 OA UK 1 Z 1 90

ZVO

A (If 9 \

—DC 1 1 1 1 \PDT 9 9 9 A UK 1 HIV

If 9—If 9 j.1 l\ £=l\ £ + 1 (IDT 9 9 1 A UK 1 L 1 3 U 300 111 | ,1 L3 3=L3 3 + 1

fl DT 9 9 A ft UK 1 Z Z40

T 1 If 1 M_9 fl

DT 9 9 CA UK 1 ZZD0 3 10 J =J +iMr wi P D T O O i A UK 1 ZZ60 p rFMERATF UtNtKA TnFMTTTV MATPTY A 1 ITMF MT A T T fiM 1 t lUC.ni 11 I MA 1 rv 1 A AUbMtli 1 A 1 1UIV fl D T 9 9 7 A UK 1 Z Z 7 0

ion j Z uIf 1 _

W 9 P DT 9 9 O

A UK 1 ZZoO

nnUU JtU iAn if— l\=l1 m, WI PDT UK 9 9 OA 1 Z 1 7U

If 9—If 1

l\ c=l\ J. (IDT UK 9 1 n

n 1 ZJUU

nnUU inni\St1 —= i1 m, nn PDT9 1 1 A UK 1 Li IU

AA 1 If 9 \ _n \ l\Z ) =u . P

DT 9 1 9 A UK 1 Z3ZU

If 9—If 9 i 1

l\£=l\£

+ l (IDT 9 1 1 A UK 1 Li iM

K 9—If. 1 j.k 1 IS t=l\ 1 +l\ — 1 nDT 9 1

UK

an 1 Z34U

V.l\ 1l=l\ —If 1 , WDM 1 +N r l\n ncT UK 9 1 c

n 1 Z J 3 U

AA ( if 9 \ 1 n ( l\Z ) =1 . U PDT 9 1 A

A UK 1 Z360

pu RFTTM DtoiN TUF inc.Cb.o.C DDflPFQC rKUutoj PDT 9 1 7 A UK 1 Li 1 0

MRF T— 1

Not 1 = 1 PDT 9 1 Q

A UK 1 Z3o0

MRU T— 1 n k n i = i pdt UK 1 9Z ion i 7 U t i ft— i ,uni i 1 1 0 = 1 +IM V Li nDT9 UK 1 f Ann HUU

MCA

T 9 IMbA 1=£ (lDTIvl 1 A UK 1 Z41U

MQOS JT1 TL—L—9 PDT9

A 9 A UK 1 Z4ZU

wnp NUE t_i 1=1 PDT 9 A 1 n

UK 1 Z*t3U MMI 1 T — 1 IMIMU 1 = 1 noT9jiAn UK 1 Z*»4U

171—1 Li. 1 = 1 nPT9Ai; UKn 1 f 1DU 1 79 — 1 PDT9 UK A An 1 Z40U

pU l\ UUN 1 KULj nnULL LUUr nDT 9 a 7 n UK 1 Lh 1 U

IfN=l1 PDT 9 A OA UK 1 floU

MTUT 1

im I n 1=1 PDT9 UK 1 Zt^U AQn MNALA 1 T1=11 pdt UK 9 c n n 1 L0\)\)

MOMT—1

PDT9

c i n

UK 1 i51U

M 1 wni i M i 1 IM J=IMU3+IM + 1 PDT UK 9 C 9 n 1 Z3ZU

nnUU ii7(i 1 U J=l i—im, nn nDT9 ^ i n

Ul\ 1 L j i U

A (M i\n

A ( IM

J ; =U . PDT9 UK

£ A(\ 1 t D4U

57ft

n j =m j +i nRT9 UK 1 L

<;D Rn0 U

p ROY DUAA0 . nRT9 UK 1 f SOU R An

3oU l\U If m1= IV( IS

— 11 \ * MDM ) NrM nRT9 UK 1 R7

n

£ j / U

T 1 Mm i 1 1 i=IMU3 + l PDT9 con UK 1 LDOV T 9 1/111,1 1 Z=ISU1 + 1 PPT9 c on UK 1 <£D7u 1 9 9 A 19 9 LZ Z A=LZ Z nRT9 UK 1 f Ann OUU

nna 9 n i i m UU 4ZU 1 = 1 , IM nPT9a i n

UK 1 L

O 1 U

rnuU Tn /ion Anni mmiit IU (37U,*tUUj , IMIVIUl nRT9A9n UK 1 COCK)

p Dlf 1 T 1 ris ( 1 )

nPT9 UK 1 COAinJ \J 390 A / T "1 \ A/T9\ :t: DPM99A\ A ( 1 1 ) =A (IZ)KL(LZZA) nRT9 UK 1 f.01U a An 1 9 9 A 1 9 9 A • 1 LZ Z A=LZ ^ A + l nRT9 UK 1 f OjU A^n

cnuU Tna i n 1 U 4 1 u

u r\ i l.uov

ifAA 400A / T "1\A / T 1 \ * ADTC / 1 \

A ( 1 1 )=A (IZ) AKbb(Z) nRT9 UK 1 toA7n/ U

ji i n 410

T 1 T 1 1 1 1=1 1+1 nRT9 UK Aftn 1 cOOU

>i 9 a 4Z0T 9 T 9 . 1 1 Z=l Z+l UK 1 t07U

PA Tfl / A 1 ftALA\ UdUT bU IU (430,460), NUM1 nRT97nn UK 1 f 1 UU

>i i n 430

TA 1 1 1 A 1 = 1 1 A2=NU5+1 npT9 UK 1 7 9 n L 1 c U

r\ (\

ar ftT 1 1/ DO 450 1=1, K

ppTo 7 i n

UK 1 L 1 3\i

T *\TA 1 1 2=1 Al nPT97An UK 1 L 1 t U C 1 1 11 A A bUM=0 . 0

nRT97i;n Un 1 f i 3U

19 Mill j 1 J Z=IMU3 + 1 flRT?7A0 nn a An i 1 udu UU 440 J = l , IMrM nRT?770 U I\ 1 CI 1 u C 1 1 M C 1 1 RJ . A / I9\*A/T9\ bUM=bUM+A ( J Z ) A ( 1 Z ) 12=12+1 0RT2790

212
440 J2=J2+1 ORT2800 C QK(I) ORT2810

A(IA2)=SUM 0RT2820

IA1=IA1+NPM 0RT2830

450 IA2=I A2+1 0RT2840

GO TO 490 ORT2850

460 DK2=0 .

0RT2860

I1=(K-1)*NPM+1 0RT2870

IND3=ND3+1 0RT2880

DO 470 1=1, NPM 0RT2890

DK2=DK2+A(IND3)*A(I1) 0RT2900

11=11+1 0RT2910

470 IND3=IND3+1 0RT2920

DK=FDSQRT (DK2 )

0RT2930

C GRAM FACTORS 0RT2940

A(I18)=DK 0RT2950

118=118+1 0RT2960

K1=(K-1)*NPM+1 0RT2970

DO 480 I=1,NPM 0RT2980 A (Kl )=A (Kl ) /DK 0RT2990

480 K1=K1+1 0RT3000

N0MI=1 0RT3010

GO TO 380 0RT3020

C B0X8 0RT3030

490 GO TO (500,560) , NDEI 0RT3040

500 LZ1=-LZ1 0RT3050

IF (LZ1) 550,510,510 0RT3060

C B0X8A 0RT3070

510 K1=K-1 0RT3080

IRUTH=ND5+1 0RT3090

DO 520 1=1, Kl 0RT3100

A(IRUTH)=-A(IRUTH) 0RT3110

520 IRUTH=IRUTH+1 0RT3120

IRUTH=K+ND5 0RT3130

A(IRUTH)=1.0 0RT3140

J2=ND4+1 0RT3150

DO 540 1=1, NPM 0RT3160

SUM=0.0 0RT3170

J1=I 0RT3180

J3=ND5+1 0RT3190

DO 530 J=1,K ORT3200

SUM=SUM+A(J1)*A(J3) 0RT3210

J1=J1+NPM 0RT3220

530 J3=J3+1 ORT3230 C XP(I) 0RT3240

A(J2)=SUM 0RT3250

540 J2=J2+1 0RT3260

GO TO 640 0RT3270

C B0X8B GET QK(I18) 0RT3280

550 ISAL=I18+M2 0RT3290

IRUTH=ND5+K 0RT3300

A(ISAL)=FSQRT(A(IRUTH) )

0RT3310

GO TO 510 0RT3320

C NDEI 0RT3330

560 LZ2=-LZ2 ORT3340

IF (LZ2) 570,510,510 0RT3350

C GET

E AMD OTHER VECTORS 0RT3360

570 DO 580 1=1 ,M 0RT3370

IND5=ND5+I 0RT3380

213
T Kin.0 MDQ i T 1 IMU7 =IMU7 + 1 UK 1 3390 1 IM U 0 =IMU 0 + 1 A D T 1 A A A UK 1 3400 a i t wnfl \— a / t writ; \ A D T 7 /I 7 A UK 1 341U

50U con

A / T Kirso\

—

AM hint:

\ * a f T Nn

£

\

A ^ 1 imu 7 J =M I 1 IM

U 3 J

M

\ 1 HU 3 ) dDT7yi OA UK 1 34ZU

A^1IMU0

+ 1) =M ^ 1 IMU j + 1 J UK 1 343U

A ( IMU 1 U

+ l ) =A ( 1 IMUO+ i ) —A ( IMU 7 + 1 ) UK 1 3440 i iyni n Kirn n 1 1 1 1 '« U 1 U =IM U 1 U + i (\DT2>I C A UK 1 3450 1 IMU 7=NU7 + 1 A D T 1 A L A UK 1 3460

nn con i— 9 m UU 5 7U J =£ , MADT 1 yi 7 A UK 134/0

1IMU1U=1IMU1U

+ 1 ADT 1 A

Q

A

UK 1 3'fOU i Kino— T WHO i 1 AD T 7 A O A UK 1 J4VU

con 59Ua nunini A/TKinin i i a / tmno\

A ( 1IMU1U ;=A (1IMU1U

— 1) —A ( 1IMU9 ) A

DT 1 CAA UK 13500

CI 7 A r 1=1 . U (1DT3

E 1 A UK 1 3ol0

TMmn Kimn 1 IMU 1 U=lMU 1 U

ADT 1 COA UK 1 3b<d U

ikiriii Mm l I IMU 1 1=IMU 1 1 A

DT 1 C 1 A UK 1 353U

UU 635 1=1 , M

UK 1 3540 1 IMU 1U=1 IMU 1U + 1 ADT 1 C C A UK 13550 t Mm i _t um 1 i 1 IMU 11=1 IMU 11 + 1 UK 13 560

TPlr (PM ci

\ z oa (in tun iriM— ri) o3U,o3U,6UU

ADT "aC 7 A UK 135/0 aaa TF rAMNmnM Ain A?n A9n nPTI Uf\ 1 jjoU H An

DiU

A IfMm 1 \ CCnDT / ARC / A / T M'ft 1 A\\ 1 1 EMPT\\

A ( l IMU 1 1 ) =—

r 0U.K 1 (Ado(A(1IMU1U) ) / ( r IM—r 1 ) ) A

DT 1 COA UK 1 3590

nnUU Tn1 U

O

J

J ADT 7 A

AA UK 1 36UU

A 9 (\ o a U

Aa Muni 1 1 ccnDTfA Munm\ / / cm ci 1 1 ( 1 IMU 11 )=r 5U.K 1 (A(IIMUIU) / (rlM-rl ) ) A

DT 1 L 7 A UK 13610

pa TO ise uU 1 U Ojj ADT 7 A

O

A UK 1 ibc\j

a i n

A ^ 1 IMU 1 U ) =— 1 . U ADT 1 A 7 A UK 1 JOJU

603

PT _P Tiln

r 1 =r 1 +1 . U UK 1 364U

oU 1 UD 1 u

ADT 1 LC

A

UK 1 365U

U DUA7 ADT "3

AAA UK 1 366U

a An nnoU TnIU ncn (in gnni mtut ( 0 5U , 6 1 U , oU U ) , IM 1 H 1 ADT UK 7 A 7 A 1 3 6 / U

ODD

K 1 /V 1 \ * WDM , 1

M=(l\

— 1; IMrWI+1 nDT UK

%AQA 1 JOoU

Tun/i Kin/1 1 1 1 IMU4=IMU4 + 1 UK 1 3690

nnUUaOOUa n t_l =tl,IMrlYI mpm adT'? UK i J 7/ nnUU

AIM) h It/ f \ =AA f T Mr\A

\ ( 1 IMU 4 ) nDT 1 7 1 A UK 1 i 1

1U

7. 7. 1 1 ADT UK 1 7 9 A 1 3 1

£U

AOOUAftT1IMUH=1IMUH MriA— T MDA^T+ 1 nDT UK 7 ^ n 1 J / J u m Tn 7 a n UU 1 U / OU ADT UK 7 7 A A 1 .5 / HU 0 / u 1IMU1o=IMU1o + 1 ADT 1 7 c; A UK 1 i 1

DU

t kina kin >t . 7 1 IMU4=IMU4 + 1 ADT 7 7 A

A UK 1 3 / 6U nnUU aOOUq n t — i m 1 =1 , IM nDT UK 1 1 7 7 0 3 I I U A ( lIMUlo ) =A ( 1NU4 j nDT UK 1 J/OU 17 on T Kin 7 O T KID 1 O 1 7 1 IMU 1 0=1 IMU 1 o + l ADTl70n UK 1 J / 7U

680

T ft! PiA TMA.J1.7 1NU4=1NU4+1 ADT 1 0 AA UK 1 3oUU

HITM . 7

IM 1=N+1 ADT UK 1 Q 1 A 1 JO 1U

UU 690 1—1 , M

nDT 1 q 0 n UK 1 JoaU

KKl=lMUlo+N 1 nDTi UK 1 JojU q in 1 IMUH=IMU'l+IM 1 nRT^ftAf) U l\ 1 JOHU A / W 1/ 7 \ K 1 T kl I\ A \ A (KM )=-A ( 1 IMU 4 ) nDT UK 1 J03U 1 o en

LAA 690 111 ftl

T . 7 ADT 1 Q

AA UK 1 JODU

Tiini ki

aA I N04=N04 ADT 1 Q 7 A UK 1 30 / U 1NU19=NU19 nDTIOflft UK 1 JOOU

nn 7 a

a

t i m UU / UU 1 =1 , IM Tlini T ftl A A . 7 1 IMU4=1 NU4+1 nDTionn UK 1 J7UU t Kin 7 0 t Ain 1 0 7 1IMU17=1IMU17+1 noTi q l n

Ui\ 1 J71U 7 A A 700 A / TUnini A / T kl n A \ A ( 1NU19}=A ( 1NU4; nDT^Q9n UK 1 j 7 L U it 11 0 en c no tdcctt cn 1 \ nr\ Tn 7sn 1 r ( Li . ty . j . UK . 1 Ktr l I . ty . l ) uU iu /3U

TC /MA DTC MY

A orC\ 7Cn 71(1 71n lr (IMAKuj—MAAKbi ) /3U,/JU,/1U Vl> 1 J77U

710 L66=I IRG5 (MXARG5+1 ) -1 ADT 10 cn UK 1 J73U

L66A=L66 ADTIQAn UK 1 J70U

IND4=ND4 0RT3970

214
DO 720 1=1,

N

ORT3980

L66A=L66A+1 0RT3990

IND4=IND4+1 ORT4000

720 RC(L66A)=A(IND4) 0RT4010

730 L55=IIRGS(MXARGS) 0RT4020

L55A=L55 0RT4030

NUN+ND4+1 0RT4040

RC(L55A)=-A(NI)+YC0NS 0RT4050

IF (M.EQ.l) GO TO 750 0RT4060

DO 740 I=2,M 0RT4070

NI=NI+1 0RT4080

L55A=L55A+1 0RT4090

740 RC(L55A)=-A(NI) 0RT4100

750 NTHI=3 0RT4110

GO TO 650 0RT4120

C B0X10 0RT4130

760 GO TO (770,780) , NALI 0RT4140

770 N0MI=2 0RT4150

NALI=2 0RT4160

GO TO 380 0RT4170

780 IF (K-M) 790,830,830 0RT4180

790 K=K+1 0RT4190

GO TO 350 0RT4200

800 GO TO (810,820) , NNUI 0RT4210

810 NNUI=2 0RT4220

GO TO 920 0RT4230

820 SS=DK/DENOM 0RT4240

SSQ=SS*SS ORT4250

GO TO 920 0RT4260

830 GO TO (840,800) , NBEI 0RT4270

C ***** ***** ****** ***** ****** ***** 0RT4280

C GET THE A MATRIX 0RT4290

840 Kl=l 0RT4300

DO 860 1=1,

M

0RT4310

I1=I*N+(I-1)*M 0RT4320

DO 850 J=1,I 0RT4330

I2=J+I1 0RT4340

K2=K1+ND12 0RT4350

A(K2)=A(I2) ORT4360

850 K1=K1+1 0RT4370

860 CONTINUE 0RT4380

C 0RT4390

NDEI=2 0RT4400

NBEI=2 0RT4410

NTHI=2 0RT4420

K=K+1 0RT4430

GO TO (800,870) , NGAI 0RT4440

C GET CV MATRIC 0RT4450

870 CONTINUE 0RT4460

DO 890 IL=1,M 0RT4470

L0C=IX1(IL,0,ND6)+1 0RT4480

DO 890 J=1,IL 0RT4490

SUM=0. 0RT4500

DO 880 KK=IL,M 0RT4510

L0C1=IX1(KK,IL,ND12) 0RT4520

L0C2=IX1(KK,J ,ND12) 0RT4530

880 SUM=SUM+A(L0C1)*A(L0C2) 0RT4540

A(LOC)=SUM 0RT4550

890 L0C=L0C+1 ORT4560

215
1 1 I lMD A

J 1=J+NU0 AUKD T1 4

A 3cm/

U

J =IM U 10+A UK 1 43oU

Ai,iiuio + i;=rjyi\i ^h^iiuo + ij ; UK 1 137U

tp iu Fn i\ f:n Tn qi n ir vi»i.c.y.i) uu iu 7iu rtDTvl A A n UK 1 toUU

UU 7UU 1 = A , l»l ADTvl A 1 A UK 1 401U

rU THF Inc. Hr\uUmC.lVI ARGIIMFNT TIM in THF Inc. Ffll rULLUWlliu 1 nWTNC CnRT jU.i\I nrr aq

t

UUUAJlUliALLT nw ai i v TC WFT AT T \/nRT4 A 9 n 1 j NluA 1 1 VUK 1 HO aU

Al,J;=r.jU.iAl ( Jl ) ) f\DT UK A A ^ n 1 40JU

J =J + 1 fiPT/i UK a 4 n 1 10»IU onn 7 u u 11— 1 1 . T j-1 J 1 —J 1 + 1 +1 UKC\Q T A A C n 1 46311

7 1 U MCA T—

1

aptaa UK 1 HOOUAn rnbu TO1 U onn oUU A D T ^ A 7 n UK 1 40 /

U

q 9 n cn TO /a jn q

q

n \ udut UU IU (7JU ,77U) , NKrll ADT ^ A 0 n UK 1 4ooU

o n 7 JU TFIt fi\iRRAP\ l,lli\DAr\J QAn 7 4 Ui mn QAn , 1 U .3 U , 7 4 U APT/I A Q A UK 1 'OVU

QAn 7tU IMRR iiiadhh AR——MRRAR 1 nir\Drtr\ —

x

a dt a 7 n

n

UK 1 4 / UU

NTH T—

9

ii i n i —l UK It/ IU

MRU T—

9

n r\ n i =a ART4 7 9 n UK 1 H 1

L

U

1L 11 11 —= T T RGC / 1 1 1

1

IKuj ^ 1 )

1 npT UK a 7 7 n 1 H 1

3

U

1 1 1 A—1 1 1 i_l L 1 1M=L 1 1+1 npT UK a 7 a n 1 4 / fU

T 1 M n 9 j_ 1 i i=iiua+i UK 1 H / 0\J nnUU Q7n 7/U T— i im 1 — X # 11 nPT47 UK 1 H / AnOU

TF1" M(Lt9 .Btnf . c \ ftn TO QAn 3 | OU IU 7DU UK 1 1/ /

U

Gfl UU TOIU /QAfl (70U acni MMIIT , 73U ) , ll IVIU 1 apta 7 a

n

UK 1 1/ OU

A 1 T 1 1 —ARCQ 1 0

\

npT UK a 7 q n 1 4 / 7

U

UUcn Tn1 U Q7n 7/U nRTAonn UK 1 tOUU

q a n n \ I 1 ) — ^Ll 1H J - 1 UUli 3 nRT/ia Ui\ 1 i n 4 O 1 U

1Lil1 1 A—1 1 1 A_l1 A=l_ 1 1 A + l aptj! UK q 9 n 1 4oaU

7/U T11=11+1 1 — T 1 j_1 nRTA q i

n

UK 1 IojU

1 i=IYIU .3 + 1 nRTAfl UK 1 H04UAn nnuu oan 7ou T—i=i,i mnn nRTAfl UK 1 40DUcn

A \ 1

1

) =U

.

nPTAo Urv 1 HOOUAn

70U T 1 — T 1 j-1 1 1=1 1+1 nPTAB 7

n

UK 1 40/

U

nnOU Tn1 U J^Anou nRTAQQn UK 1 400U

77U rUUa taIU /o3n (7PU , innn\ 1UUU mqtt ) , Njll UK 1 407U

eft ul 1 \ir\i VUV ANU Awn npu ULV AliU Awn rnFF UUtr npTAonn UK 1 47UU

i1UUU nnn t Nn7—Nn7 j.1 l nu l —li u / +1 nRT4Q i

n

Ur\ 1 *t 7 1 U

1 NU0=NU0+1 nPTAQ9n UK 1 4 7 A U UUnn i1U1U ni (i t — i Mn i 1 = 1, IYIU

1

nRTAQ Ui\ 1 47 JU^n

A/TMn7\ CCn*A / TMriA \ A ( 1 NU /

; =o ->U. A(1NU0) nRTAQAn UK 1 474U

T Wn7-T Mn7 l1 1 NU / =1 NU / +1 Uia npi1 aoH73Uc n 1U1U T mn A T KinA i 1 1 NUo=l NUo + 1 nRTAQAn Ul\ 1 H70U

T1NU10=NU10+1 MD1 A W n 1 Ail nRTA07n U i\ 1 H 7 / U Tuni 7 Mni 7 1

1

I Nu 1 / =NU1 / +1 npTAQon Uia 1 H7oU

nn i nin T 1 M UU I U A U 1 = 1 ,

M

nRTAoon Uia 1 H 7 7 U

i >iuni71 CC*A/TI\iniA\ a ( invxi )=3j a (

i

m u i o

)

nRTcnnn UK 1 3UUU

TMniA TKiniAil 1 11 U 1 0=1 NU 10 + 1 nRTcn i

n

Ul\ 1 3U1U

1U All runi 7 Tuni 7 , i i NU 1 / =! NU1 / +1 nRTi?n9n Ui\ 1 3UtU

bU IU 7^1) nRT t;n ^ n Ui\ 1 3UJU

/>U tuf IHt pai LALLULA nn ATTnwQ 1 lUnj ARC. apf rnMPi lUBIrLtFTFn ILU. wniu NUlt nilTPMT UUIrUI THF RF^III T<; nPT<;nAn Ui\ 1 3UtU

a / wno ! \ a / una ! \ .vrnwc + FcnRTi' met nu \ A ( NUo+1 ) =A ( NUo +1 ; +T UUNo royKI (W3UWI) nRT^ncn Ul\ 1 3U3U

i (linn . i \ A/WnQ^I \ **9 A ( NU 7+1 ; =A ( NUo+l ; c nRTsn \J l\ 1 3UDUAn

t Nn i P—Mn i ii.iiiii 1 ll U 1 o=ll U 1 0+11 +

1

0RTS070

a / Tuniox a i \ mm a \ , vrnwc A ( INUlo ) =A (INUloJ+TUUNo Uia 1 3U0U

tf mdfftt Fn i \ rn Tn i aao 1 r ( IKtrll.ty.i) oU IU 10*»U ARTsnon UIA 1 3U7U

tc it 9 Fn c\ m to l oifi lr (LZ.tu..5) bU IU IVoU nRTc UIA 1 31UU i nn

TC / IVI A D r C IT UVADrC\ TA 11QA lr (NAKbo.LI . MXAKbo ) bU IU JLIVU nRTc i i

n

UR 1 J 1 1

U

1 C C A 1 C C . k& L55A=L55+M nRTm Uia 1 31f.U 9n

TCC 1 1 Jr =l 0RTS1 3

0

VIA 1 J 2. J \J

1L33RCRD=L3 —1 CCA ,M 1 3 A +lfl—

1

0RT5140

IF (L55B.LE.NR0W+L55-1) GO TO 1040 0RT5150

216
T I- /II

A

r Hi

AA 11/\AA TA 7 7 AA IF (M.bt.NKUW) bU IU 1190 ftATr l / A ORT5160

rf

r i I br=2

ADXC 7 TA UK 1 5170

L5 5b=L5 5+INKUW-l

ADTC 1 OA UK 1 5180

1040 IND17=NU17+1

ADXC 7 AA UK 1 5 190

nn i ncnt i cca iccd UU 1050 1=L55A , L5 5bODTCOAA UK 1 5200

D

A / T

\A / Tkim 7 \ RL ( 1 )=A ( 1ND17 ) A

DTC ft 7 A UKT 52 10

*lAC ft 1050

TM l*. 7 7 THIhl 7 i 1 1 NU 1 7=1 NU 1 7+1

ADTC ft ft ft UK 1 5220

AAXA I 7 AL ft 7 7 AA\ TCL" bU 1U (1060,1190), lbrADXC ftOA UK 1 5230 1 ft L A 1060 t mc w d oiu O * u UK 1 5^:40 i r / T MC PT t. \ T UQ A lr ( 1 Mb . b 1 . 6 ) lMb=6 n. D T C O C A UK 1 be 50 P O TO Jl 1 fln 1 1 7 A 1 1 £ A 1 1 C A llylA 1 A 7 A \ T IIC bU IU (1180,1170,1160,1150,1140,1070), 1Mb A D T C ft L ft UK 1 5260 7 A X ft 1070 i i n a TTDPC/1\ L11A=1 lKbb ( 1 ) A A T C ft ^1 ft UKT5270 1 O O A IOO LZZA=LZZ A D T C 1 o a UK 1 5280

VDADAA

Y bAK=0 . 0 A

DTC AAA UK 1 5290

nn i innT l hi UU 1 IUU 1 = 1 , IN UK 1 5300

PO Tft / 1 AOn 1AQA\ hi Mi IT uU IU (1UoU,1U9U), IN MUX UK 1 53 10 1 n O A 1080 VDAD VDAD .DP / I OOA\*DP/l 1 1 A \ YbAK=YDAK+Kb (LZZA)Kb(LllA) A D T C O ft ft UK 1 5320 1 O O A 1 O O A . 1 LZZA=LZZA+1 A D T r O O A UK 1 5330

PH TO i inn bU 1 U 1 IUU C\DTC 1 AA UK 1 5340 i An ft 1090 VDAD VDAD. DP/I 1 1 A \ YbAK=YbAK+Kb (L11A) A D T C O C A UK 1 5350 11 1 nn 1 U U 1 1 1 A 1 1 1 A i 1 L 1 1 A=L1 J. A + l UK 1 53 60

VQAD YdAK=YBAK VDAD /UICIIM / WbUM

ADTC ? "7A UK 1 5370 1 1 1 A T T DP C / 1 \ L11A=1 lKbb ( 1 ) A A X C O A A 0RT5380 1 O O A IOO LZZA=LZZ A D X C O A A UK 1 5390

VVRADA I I bAK=U . ODT

CAAA UK 1 5400

nn 1 1 7nt i hi UU 1 J. i\i 1 =1 , IN

ADXCA 7 A UK 1 5410

PO TOm in iioa\ hi mi i t bU IU (1110,1120), INMU1ODTCA OA UK 1 5420 1 1 1 a VVDAD DP/I00A\#/DP/I11A\ VDAD\**0. VVDAD Y Y bAK=Kb (LZZA)(Kb(LllA)-YbAK)Z+YYbAK A D X C Jl O A UK 1 5430 1 O O A 1 O O A . 1 LZZA=LZZA+1 A A X C Jl Jl A URT5440

pft Tn i i in uU 1 U 113U ODT

CACA UK 1 5450

11ZU VVDAD ADPC /O

\ * /DP /I 1 1 A\ VDAD\**0. VVDAD

Y YbAK=AKbb (Z) (Kb (LllA)-YbAK) Z+YYbAK

ADXCAL ft UK 1 5460 1 1 i U 1 1 1 A 1 1 1 A i 1 L 1 1 A=L 1 1 A+l O D T C V! 7 A UK 1 54 / U

DO 1 CCPi* /CM CUl /VVDAD KZ=1 . -bbU. (bU-rM) /YYbAK

ODTCA on UK 1 5480 1 r /DO IT A \ DO A A lr (KZ.LI.U.) KZ=0.0 A D X C A ft ft UK 1 5490 T C /Do pi I n\ DO 1 A lr ( KZ . b 1 . 1 . U ) KZ=1 . U

ODTCCAA UK 1 DDUU

DP / I ccD ,i\ DO Kb (LDDD+6 )=KZ ODTCC 1 A UK 1 5510 1 1 A A 1140 np / | CCD.CX ceo Kb (L55b+5 )=bbU. ODT C C O A UK 1 5520 1 15U DP / I CCD , A \ CC Kb (L55b+4 )=bb nDTccin UK 1 5530 1 1 / A 1160 DP / I CCD , : \ CM C II Kb(L55b+3)=bU-rM ADTcc^n UK 1 5540

117 0 DP / 1 c CD . O ^ CM Kb (L55D+Z )=rM

ODTCCCA UK 1 5550 1 1 O A 1180 DP/I CCD . 1 \ Cll Kb (L55b+1 )=bU A D X C C Z A UK 1 5560 ob POIIOMTC DDrHTPTCn WAI IICC C A AC DDCATPTTA bUMHU 1 t HKLUlbltU VALUtb b.U. Ur HKtUlbltU A D X C C X A UK 1 5570 1 1 ft ft 1190 I NU2=NU2+1 A D X C C O A UK 1 5580

Tiini ki

n i . i 1 NU3=NU3+1ADXCCAA UK 1 5590

T hiAA iini ft , l 1NU4=NU19+1ADXCL ftA UK 1 5600

TDTP 1 1 r I b=l f\DTCL 1 A UK 1 5610

TVT TDPC /l\ I Y=I lKbb (1 ) A

DXCL ft ft ORT5620

VC 1 1 11AA YbUM=0 . 0

UK 1 5630 1 ft ft A 1 A O L22A=L22 ART r / A A ORT5640

ftft 1 O

OAT 1 M UU 1Z30 1=1 , NADXCLCA UK 1 5650

TDTDTP 1 r= 1 rib ADT

CL

L

A UK 1 5660

cnAA 5P=0 . 0 AAXC / ^ A ORT5670

AO i inn TT i u UU 1200 11=1, MAQXCLOA UK 1 5680

CO CD.A/TD\*#0 br=br+A (IP) "Z

AAXCZAA 0RT5690 1 L UU T D IDiklDU 1 r= 1 r+NrNI ODT C 7 A A UK 15 7 00 A ( 1 INU2 ) =r bU.K 1 (br) bb O D T C 7 1 A UK 15 710

TDTP TDTP.1 lr Ib=lr lb+1ODTC 7 OA UK I 5720

T -in 0 t lino i 1 1 INUZ=1 NUZ+1 ODT

C 7 1 A

UK 1 D / 3 U A(IND3)=RC(IY)-A(IND4) 0RT5740

217
1 NU 3=1 NU3 + 1

ft R T r 1 c ft ORT5750

T M fl A TKin^.1 1 NU4=1 NU4 + 1 ORT5760

PP Tfl / 1 O 1 A 1 01(11 hi Ml IT bu 1 U (1a10,1aaU), NMU1 UK 1 5770

1 11 ft 1210 V C 1 IM_VC 1 IM i DP 1 T V \ * * 0 * DP l\ 11A 1 T bUM=Y bUM+KL ( 1 Y ) A ( L a A A

)

f\ D T C T O A UK 1 5780

L22A=LaZA+1 ORT5790

PA T(l 1 ion bU 1 U 1230 r\ n t c aaa ORT5800

1 L i U V C 1 IM—VCI iy . DP 1 TV \ **0*ADPC C) 1 Y bUM=Y bUM+KL ( 1 Y ) A AKbb(A) n D T C O 1 A UK I 5810

1 O 1 A 1230 TV T V 1 1 Y= 1 Y + l A D T C O O A ORT5820

cL PUCPlf Tfl CCC TC DCCtlt TC ADC TP DC LntLIS IU jtt 1 r Kt JUL 1 j AKt lu Db DMT rU 1 T M U/P D U C U C C T IN WUKK bntbl UK 15830

TC (MADPC IC MY A D P C i 1 \ P P TP \ A LC\ lr (IMAKbb . Lt . MAAKbb+1 ) uU IU 1460 n D T C O A A UK 1 5840

TC /MADPC / MV A D P C . 1 \ \ 1 A A A l ion 1 1 y| A lr ( IMAKbb- ( MXAKbb+3 ) ) 1440,1390,1240 A D T C O C A ORT5850

pL CTPDC blUKb WADTAklPC VAKlAIMbb PPX/ADTAMPC MATDTV LU V AK 1 AIMLb MA 1 K 1 AT M1

N

UIA D V C U C C T WUKK bribe. 1 ADTC O L A UK 1 5860

1 A40 1LbnC'i/T1 n =0 UK 1 5870

1 IMU /=IMU / +1 ADTcoon UK 1 5880

J.OU T1 CTP T CT b 1 K= 1 b 1 n D T C OAA UK 1 5870

T CTP T CT A O T C A A A UK 1 5900

MCTPD UTMO /UUTVP MMTVD\ Mb 1 Ur=MllM0 (MMI XL , MMI XK

)

A D T C A 1 A ORT5910

nfl UU 11a/0 17(1 Tl=l,MblUr 1 MCTPD ADTCOOA UK 1 59Z0

T CTDD T CTP 1 b 1 KK=1 b 1

K

ADTCOl

A

UK 1 5930

T1 CTPP— b 1 l/L= T

1 CTP b 1 \j ADTCQ/1 A UK 1 5V40

HP 1 9 A A 1 1 T UU 1a60 J = 1 , 1 A D T C A C A UK 1 5950

DP/TCTDDl KL(lblKK) =AA(TWT\7\ ( 1 IM U / ) UK 1 5960

DP/TCTPPl Kb A/TMP.7\ ( 1 b 1 LL ) =A ( 1 IMU /

)

UK I 5970

T MP.7 T MP.7 i 1 1 IMU7 =1 IMU 1 +1 ADTCAOA UK 1 5980

TCTDD TCTDP. MDPUf 1 b 1 KK=1 b 1 KK+lMKUn UK 1 3990

TCTPP 1 b 1 TCTPPiT LL=1 b 1 LL + 1 ADT i A A A UK 1 6000

T CTD T CTD

T

1 b 1 K= 1 b 1 K + l ADT L A 1 A UK 1 6010

1 A 1 u

T CTP TCTPiWDPU/ ADT A 1 A UK 1 6020

TlrC /(MMI MMTVPXL . CPbU. . MMT MMI VD\ XK ) PPbU TPIU mn1330 A DT L A 1 A UK 1 6030

p WADTAklPC V AK 1 AIMLt PPX/ADTAMPC MATDTV TC CTPDCn LU V AK 1 AIMLb MAIK1X lb blUKbU AC A Ab A DCPTAMPIII KbLIANbULAKAD MATDTV MA 1 K 1 A

A DT L A A A UK 16040

MCTD Mb 1 r=MAXU MAYA 1 MMT YP MMT YD 1 MCTPD ( MM 1 XL , MM 1 XK ) —Mb 1 Ur UK 1 60b0

T C / MMTV P MMT VD\ llflft 1 9 Q A l IQft lr (MMI XL-MMI XK) 1280 , 1Z80 , 1290 UK 1 6060

1280 T PPM A MDPU1 1 LUIMA=IMKU W

A D T L. A 7 A UK 1 6070

TPPKID 1 1 LUIMt)=l PDT L A Q A UK 1 608U

T

1 CTADT—T b 1 AK 1 = J. CTD b 1 K PRTA AO A, UK 1 6U7U

PP TP 11 A

A

bU 1 U 1300 PDT£ 1 A

A

UK 1 6100

1 1 A A 1290 1LUIMA=1 PDT L 1 1 A UK 16110

1LUNd=NKUW PDT L 1 OA UK 1 61Z0

TCTADT T C TP 1 b 1 AK 1 =1 b 1

L

flDTil 1 A UK 1 6130

1 1 A A 1300 HP l 11(1 T 1 MCTD UU 1320 1 = 1 , Mb 1

r

ADT UK A 1 At\ 1 0 ±4U

TCTDP TCTADT 1 b 1 KL=1 b 1 AK

1

PDTA 1 CP UK 1 OJLDU n A lllft 1 l liC TAD UU 1310 J=l,MblUr PDTA 1 L l\ UK 1 616U

DP/TCTDP\ A / Tkini 1 KL(iblKL)=A(lNU7) PDTA 1 7 A UK 1 6 1 /

U

1NU7=1NU/+1 PDT A T Q

A

UK 16180

1 1 1 A 1310 TCTDP TCTDP. TPPMA 1 b 1 KL=1 b 1 KL+1LUNA UKPDTA TOP 1 0l7U

Tfclm T M fl 7 . T 1iMU7=1NU7 + 1 PDT A O A A UK 1 bl 00

1320 TCTADT TCTADT. T P AMD

I b I AK 1 =lb 1 AK 1 +1LUNB ADT A O 1 A UK 1 OA 10

C CTADC PDAM CAPTADC WCPTPD MPDMC AMR bTUKb bKAM rALIUKb, VtLlUK NUKMb AIMU PDAM bKAM T1CTCDMTMAMTC Ub 1 bKMl IMAN 1 b PDT A 0 0 A UK 1 OA AO

1330 IIC TAD MDA1AI 1 TADPC / MADPC 1\ M MbTUr=NKUW-l-lAKbb (IMAKbb-1 )-M PDTAO in UK 1 6 A30

IP / lie TAD IT / 1\\ PA TA 1 IDA 1 r (Mb lUr.LI.(-l)) bU 1 U 13BU ADTA04P UK 1 0A4U

Tuni i iini i . i 1NU13=NU13+1 ADTA9 cn UK 1 OA3U

I ND 14=ND 14+1 ADT A O A A UK 16260

GMD 1 =1 .

0

ADT A O 7 A UK 1 6 A /

0

TCTD TCT II IbTK=I5T+M ADT A O O A UK 1

6

aBO

nft llTft T 1 IIIITVP DO 1370 1=1,MMIaL PDT

A

1 on UK 1 6 A7U

TC /MCTADl l lift 11CA 1 1A(I lr (MblUr) 1360, 1330, 134U UK 1 0 JUU

1340 THAT P IIA T * / A / T II H 1 1 \ / A / TAIIll X 1 1 4*1 bMD I =bMU I ( A ( l NU13 ) / A ( 1NU14 )

) L UK 1 OJ1U

DP/TCTPlOI Kl» _PMnT ( 1 b 1 ?\+L ) =oMU 1 UU 1 w J A w 1350 RC(ISTR)=A(IND13) 0RT6330

218
IN013=IND13+1 0RT6340

1360 RC(ISTR+1)=A(IND14) 0RT6350

IND14=IND14+1 0RT6360

1370 ISTR=ISTR+NR0W 0RT6370

C STORE FOURIER COEFFICIENTS 0RT6380

1380 IF (LSWT.EQ.l) RETURN 0RT6390

1390 LST=IIRGS(MXARGS+3) 0RT6400

IN09=ND9 0RT6410

DO 1400 1=1,

M

0RT6420

IND9=IND9+1 0RT6430

RC (LST)=A(IND9) 0RT6440

1400 LST=LST+1 0RT6450

IF (NR0W-(M+1)) 1440,1420,1410 0RT6460

1410 RC (LST+1)=YSUM 0RT6470

1420 RC (LST) = (SU-FM)*SSQ 0RT6480

LST=LST+2 0RT6490

IF (M+2 .GE .NROW) GO TO 1440 ORT6500

A T' a ft f~ -y m LSTA=LST+M-1 0RT6510

IF (2*M+2 .GT .NROW) LSTA=I IRGS (MXARGS+3 ) +NR0W-1 0RT6520

IND8=ND8 0RT6530

DO 1430 I=LST,LSTA 0RT6540

IND8=IND8+1 0RT6550

1430 RC(I)=A(IND8) 0RT6560

C STORE S.D. OF PREDICTED VALUES 0RT6570

1440 A t An t t n a a , a M\e a n A A , LST0R=IIRGS (MXARGS+2) 0RT6580

IPIC=1 0RT6590

IND2=ND2+1 0RT6600

DO 1450 1=1,

N

0RT6610

RC(LST0R)=A(IND2) ORT6620

IND2=IND2+1 0RT6630

1450 LST0R=LST0R+1 0RT6640

C START PRINTING 0RT6650

1460 GO TO (1480,1470,1480,1470,1470), L2 0RT6660

1470 n i i a 1

1

RETURN ORT6670

1480 ITITLE=1 0RT6680

IF (L2.EQ.3) ITITLE=2 0RT6690

IPG=1 0RT6700

NSU=SU+.5E-5 0RT6710

CALL PREPAK (5 ,NW1 , NW1 , I ARGS ( 1 ), LHEAD

)

0RT6720

IF (NW1.EQ.0) GO TO 1500 0RT6730

DO 1490 1=1,4 0RT6740

LHEAD(I)=L(45) 0RT6750

1490 LHEAD(I+8)=L(45) 0RT6760

LHEAD(5)=L(14) ORT6770

LHEAD(6)=L(11) 0RT6780

LHEAD(7)=L(30) ORT6790

LHEAD(8)=L(11) ORT6800

1500 CALL PREPAK (5 ,NW1 ,NW1 , I ARGS (4) , LHEAD (13)

)

0RT6810

IF (NW1.EQ.0) GO TO 1510 0RT6820

LHEAD(13)=L(45) 0RT6830

LHEAD(14)=L(32) A A T / ft i a 0RT6840

LHEAD(15)=L(11) 0RT6850

LHEAD (16)=L (28) 0RT6860

LHEAD(17)=L(19) 0RT6870

LHEAD(18)=L(11) 0RT6880

LHEAD (19)=L (12

)

A A T* y AAA 0RT6890

LHEAD(20)=L(22) 0RT6900

LHEAD (21)=L (15) 0RT6910

LHEAD(22)=L(45) 0RT6920

219
LHEAD (23 )=L (34

)

LHEA0(24)=L(45)

1510 CALL PAGE (4)

WRITE (IPRINT,1990) (LHEAD ( I ), 1=1 , 12 ), IARGS ( 1

)

GO TO (1520 ,1820) , ITITLE

C PRINT POLYFIT TITLE

1520 WRITE (IPRINT,2000) IARGS (3 ), (LHEAD ( I ), 1=13 ,24) , IARGS (4)

1530 GO TO (1540,1550) , NMUI

1540 NZW=NRMAX-NSU

WRITE (IPRINT,2010) NSU ,NZW, IARGS (2

)

GO TO 1560

1550 CALL RFORMT (ARGS (2 ) ,1,8 ,NW1 ,NDEC1,10,A(1) ,A(1) ,0,0)

CALL RFORMT (A(l) , 1 , 8 ,NW1 , NDECl , 0 , ARGS (2) ,B(1) ,0,0)

WRITE (IPRINT,2020) NSU , (B ( I )

, 1=1 , 10

)

1560 GO TO (1570,1580,1610,1650), IPG

1570 IXA=4

IF (L2.EQ.3) IXA=IXA+(M-MX)

IX=IXA

CALL OPONE (N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX)

IPG=2

1580 IF (NSU.GE.3) GO TO 1590

WRITE (IPRINT,2030)

GO TO 1600

1590 CALL ORTPLT (ND19 , ND2 , N , SSQ , ND3 , IB , I IRGS ( IXA) , I IRGS (2 )

)

1600 IPG=3

GO TO 1510

1610 CALL OCOVAR (M, ND7 , MDl , IHC , B , IHT

)

C PRINT ANALYSIS OF VARIANCE

CALL OANOVA ( YSUM, SU , ND9 , FM, M, N , ND7 , SSQ , IHC , NSU , B)

GO TO 1660

C REFIT FOR M=M-1

1620 IREFIT=1

M=M-1

FM=M

M1=M-1

M2=M+1

SSOLD=SS

IND17=ND17+1

IND18S=ND18+N

IND19=ND19+1

IND19S=ND19

DO 1630 J=1,M2

A(IND19)=A(IND17)

IND19=IND19+1

1630 IND17=IND17+1

IF(M.EQ.O) GO TO 1640

GO TO 170

C BEGIN REFIT TO PREDICTED VALUES

1640 M1=M

C REFIT FOR M=M-1 COMPLETE-OUTPUT PAGE 3

IPG=4

M = M + 1 GO TO 1510

1650 CALL OCOEFF (Ml ,N ,ND18 ,ND17 , IND19S , IND18S , IHC ,B , IND7S ,NSU ,SS

1,YSUM)

RETURN

1660 IW=I IRGS (2

)

IND2=ND2+1

IND3=ND3+1

0RT6930

0RT6940

0RT6950

0RT6960

0RT6970

0RT6980

0RT6990

0RT7000

ORT7010

0RT7020

0RT7030

0RT7040

ORT7050

0RT7060

0RT7070

0RT7080

0RT7090

0RT7100

0RT7110

0RT7120

0RT7130

0RT7140

0RT7150

0RT7160

0RT7170

0RT7180

0RT7190

0RT7200

0RT7210

0RT7220

0RT7240

0RT7250

ORT7260

0RT7280

0RT7290

0RT7300

0RT7310

0RT7320

0RT7330

0RT7340

0RT7350

0RT7360

0RT7370

0RT7380

0RT7390

0RT7395

0RT7400

0RT7410

0RT7430

0RT7440

0RT7450

0RT7455

0RT7460

,SS0LD0RT7470

0RT7480

0RT7490

0RT7500

0RT7510

0RT7520

220
IDPG=2*M+13 0RT7530

IFI=1 0RT7540

DO 1700 1=1,

N

0RT7550

GO TO (1670,1680) , NMUI 0RT7560

1670 A(IND2)=A(IND3)*RC(IW) 0RT7570

I W=IW+1 0RT7580

GO TO 1690 0RT7590

1680 A(IND2)=A(IND3)*ARGS(2) 0RT7600

1690 IND3=IND3+1 0RT7610

1700 IND2=IND2+1 0RT7620

IND5=ND5+1 0RT7630

DO 1720 J=1,M 0RT7640

IF=IFI 0RT7650

ASUM=0 .0 0RT7660

IND2=ND2+1 0RT7670

DO 1710 1=1,

N

ORT7680

ASUM=A(IF)*A(IND2)+ASUM 0RT7690

IND2=IND2+1 0RT7700

1710 IF=IF+1 0RT7710

A(IND5)=ASUM 0RT7720

IFI=IFI+NPM 0RT7730

1720 IND5=IND5+1 0RT7740

ADEV=0.0 0RT7750

IW=I IRGS (2

)

0RT7760

I F 1=1 0RT7770

IND2=ND3+1 0RT7780

DO 1770 I=1,N 0RT7790

IND5=ND5+1 0RT7800

IF=IFI 0RT7810

ASUM=0.0 0RT7820

DO 1730 J=1,M 0RT7830

ASUM=ASUM+A(IF)*A(IND5) 0RT7840

IF=IF+NPM 0RT7850

1730 IND5=IND5+1 ORT7860

DEV=A(IND2)-ASUM 0RT7870

GO TO (1740,1750) , NMUI 0RT7880

1740 DEV=DEV**2*RC(IW) ORT7890

IW=IW+1 0RT7900

GO TO 1760 0RT7910

1750 DEV=DEV**2*ARGS(2) 0RT7920

1760 ADEV=ADEV+DEV 0RT7930

IND2=IND2+1 0RT7940

1770 IFI=IFI+1 ORT7950

IND18=ND18+1+N 0RT7960

IM=ND12 ORT7970

IND7S=ND18+N-M 0RT7980

IND7=IND7S+1 0RT7990

DO 1810 I=1,M 0RT8000

IM=IM+I 0RT8010

COEF=0.0 ORT8020

IS=IM 0RT8030

IND5=ND5+I 0RT8040

DO 1780 J=I,M 0RT8050

C0EF=C0EF+A(IS)*A(IND5) 0RT8060

IS=IS+J 0RT8070

1780 IND5=IND5+1 0RT8080

DIF=A(IND18)-C0EF 0RT8090

IF (ABS(DIF) .GT.O.O) GO TO 1790 0RT8100

C 8.0 EQUAL NUMBER OF DIGITS IN COMPUTER 0RT8110

221
DIG=8 . 0 0RT8120

GO TO 1800 ORT8130

1790 DIG=-FL0G10(ABS(DIF))+FL0G10(ABS(C0EF)) 0RT8140

DIG=AMIN1(8.0,DIG) 0RT8150

DIG=AMAX1 (-8 . 0 ,DIG) 0RT8160

1800 A(IND7)=DIG ORT8170

IND7=IND7+1 0RT8180

1810 IND18=IND18+1 0RT8190

C DELETE GRAM FACTORS, VECTOR NORMS, GRAM DETERMINANT ORT8200

GO TO 1620 0RT8210

C TITLE FOR PRINT 0RT8220

1820 I I=IARGS (3 ) +3 ORT8230

IBA=II 0RT8233

IBC=L(44) 0RT8235

I F ( 1 1 .GT. 11)11=11 0RT8237

IF(M.GT.l) GO TO 1823 ORT8240

WRITE (IPRINT ,2050) M,IARGS(4) 0RT8241

GO TO 1530 0RT8242

1823 IF (IBA.EQ. II ) IBC=L(45) 0RT8243

WRITE (IPRINT, 2050) M, I ARGS (4 ) , (L (44 )

, I ARGS ( I )

, 1=5 , 1 1 ), IBC 0RT8244

DO 1827 J=l,4 0RT8245

IF(M.LE.24*(J-l)+8) GO TO 1530 0RT8246

1 1=24* J+ll 0RT8247

III = 11-23 0RT8248

I I=MINO (II, IARGS (3 ) +3 ) 0RT8249

IF(II.NE.III) GO TO 1825 0RT8250

WRITE (IPRINT, 2060) IARGS (II) 0RT8252

GO TO 1530 0RT8254

1825 111=111+1 0RT8256

IF(II.EQ.IBA) IBC=L(45) 0RT8257

1827 WRITE (IPRINT, 2060) IARGS ( 1 1 1-1 ) , (L (44 )

, IARGS ( I )

, 1 = 1 1 1 , 1 1 ), IBC 0RT8258

GO TO 1530 0RT8260

1830 CALL ERROR (10) 0RT8270

RETURN 0RT8280

1840 CALL ERROR (25) 0RT8290

RETURN ORT8300

C MORTHO CHECK 0RT8310

1850 IF (NARGS .EQ . 7 .OR .NARGS . EQ . 9 ) GO TO 1860 0RT8320

CALL ERROR (10) 0RT8330

RETURN 0RT8340

1860 IF (IARGS(3) . GE . I ARGS (4 ) ) GO TO 1870 0RT8350

CALL ERROR (26) 0RT8360

RETURN 0RT8370

1870 CALL ADRESS (2,IXM) 0RT8380

IF (IXM.LE.O) CALL ERROR (11) 0RT8390

IF (IARGS(1)+IARGS(3)-1 .GT.NROW) CALL ERROR (17) 0RT8400

IF (IARGS(2)+IARGS(4)-1.GT.NC0L) CALL ERROR (17) 0RT8410

IXM=IXM-1+IARGS(1) 0RT8420

IF (NERROR.GT.O) RETURN 0RT8430

J=7 0RT8440

JJ=1 0RT8450

1880 CALL ADRESS (J , IMTRXA ( J J , 1 )

) 0RT8460

IF (IMTRXA(JJ ,1) .GT.O) GO TO 1900 ORT8470

1890 CALL ERROR (11) 0RT8480

RETURN 0RT8490

1900 IMTRXA(JJ,2)=IARGS(3) 0RT8500

IF (JJ.EQ.2) IMTRXA(JJ,2)=IARGS(4) ORT8510

IMTRXA(JJ,3)=IARGS(4) 0RT8520

IF (IARGS(J-l) .GT.NROW) GO TO 1890 0RT8530

222
TMTRXAMI \\ — TMTRXAMI 1 ^ 1-i.TARGSM ~\ \ \J r\ 1 O J " w IF1 r (IARGS(J)+IARGS(4)-1 y X n IN V. J \ v yXXniNVJJ V ~ } ~ X . GTVJ 1 . NCOL) iluUL ^ IMTRXAfJJ X 1*1 1 IV A n \ \J *J

t 3*t )) —=NC0L-I 11 L X ARGS niwj J (J\ u y

1 +1x x V IN 1 O J J \J IF11 n^ 1 ARGS ni\u J (

y J-l w x )} +1i i ARGS n i\ u J (y 3.j )

} -1~ x . GTVj l . NROW) ii i\ v n / IMTRXAUJ x in i i\ ah \ w w / 2*- )=NR0W-I y —1« i \ v u iniwij ARGS (J- y \j 1)+1 X^xX ORTft'iftO \J i\ 1 U JU u IFXI (JJ ^ "J O . E0l_ Vj( . 24- . Ul\ OR . NARGS IIHI\\J J . EO!_ . 7}1

f GOUv TOIV 1910 X 7 X V 0RT8570 V IV 1 V J 1 \J

U1-9 — 7 v rv i o j o \J

1 I — ? ORTft U iv 1 Oj/U ^9n

GO TO 1880 V l\ 1 uuuu

1910 IF (NERR0R NE 0) RETURN 0RT86 V IV 1 UU A10V IF (IMTRXAd 2) NE I ARGS ( 3 ^ OR IMTRXAd 3) NE IARGS(4H CALL ERR0R0RT8620

1 ( 213

)

0RT8630 W l\ 1 U U V IF (NARGS EO 7) GO TO 1920 V l\ 1 O V " V IF (IMTRXA(2 2\ NE IARGS(4) OR IMTRXA(2 3) NE IARGS(4M CALL ERR0R0RT8650 U. IV IV V IV V IV 1 o U J \j

1 f 2 13 ^ 0RT8ftf>0 V IV 1 U U U V 1920 IF (KIND(5) EO 1) GO TO 1930 0RT8670 v iv i \J \J i \j CALL ADRESS (5 IIRGS(2H 0RT8680 V IV 1 V V V \J

IX IRGS 1 1* U J (\ 1X }-I f — X IRGS 1 l\ VJ J (2) \ L / v rv i o u 7 v IFXI (IIRGS(2) ^11 l\VJ J \ k / . GTU 1 0)v / GOUV TOIV 1940 X 7 ~ v 0RT8700 V IV 1 O / V v CALL V ** L_ l_ ERROR LIIIWM (11) y X X / 0RT8710 VIV 1 V* Xv

RETURN 0RT8720

1930 SU=IARGS (3

)

j v ~"TM x nil vi-«j \ y 0RT8730

IF f ARGS f 5 1 LE 0 0) CALL ERROR (25) 0RT8740

NMUI=2 0RT8750 VI* 1 V* J \J KIND i\ i nu (2V )=i / — 0RT8760 Vl\ 1 V / vv ARGS (2)=ARGS (5) 0RT8770 Vr 1 \ 1 w # f w 1940 M=I ARGS (4) 0RT8780

DO 1950 1=1 M 0RT8790 VIXIU / / V 1950 I IRGS ( 1+3 )-IXM+( 1-1 ) X 1 li\J J y XT^ ^ — X f\ HIT I X X / *NR0W lll\ V 11 0RT8800

N-IARGS ii — i nii\3 J (3) ^ j j 0RT8810 V IX 1 V V X V FN=N 0RT8820 V IN 1 V V X> V GOVJ \J TOIV 100 X V V 0RT8830 VIV 1 SJ \J *S \J c START J 1 Hn 1 STORING J 1 Vl\ 1 llu RESULTS l\L JUL 1 FOR 1 VIA M0RTH0 HIV l\ 1 1 1

V

0RT8840 V IV 1 U U i u 1960 IST-IMTRXAfl x j I — x ill i i\An \ i f 1)x j 0RT8850 V IX 1 UU J u K=l 0RT8860 VIV 1 V V V V MMTXC=IMTRXA III 1 / A \J XIVII 1 \ / \ r» (\ 1X. f 3)^ f 0RT8870 VIX 1 VVf V MMTXR=IMTRXA(1 1 Villi 1 / \ 1 \ X III 1 1 \ f\ \ A m 2)1^ } 0RT8880 wl\ 1 VVVw

DOV V 1980 X 7 V V 1=1 X ~~ X f MMTXC lillVI 1 r\ V 0RT8890 V IN 1 V V 7 V KK-K l\ IX —1\ 0RT8900 V IN 1 V 7 V w ISTRR-IST X J 1 l\l\^X -J 6 0RT8910 VIV 1 V 7 X V DOV V 1970 / 1 v J=l w X y MMTXR llllll 1 /\ l\ ORT8920 VIN 1 V / a- VJ RCi\v (\ Ix <jSTRR i i\i\ )=A i'KK )

f ^~n y »\i\ y 0RT8930 VIN 1 V / «/ V/ KK=KK+1 0RT8940 VIN 1 V 7~W

1970 X 7 / V ISTRR-ISTRR+l X J 1 1 \ 1 \ — X J 1 l\ 1 \ T X 0RT8950 V IN 1 V 7 J V K-K+NPM l\ —1\ THI III 0RT8960 VIN 1 V 7 V V 1980 IST=IST+NROW X J 1 TM~ X J 1 Tlll'U " 0RT8970 VINIV7>V

IF (NARGS E0 7) RETURN 0RT8980 VIN 1 V / v W LSWT=1 J n i —x 0RT8990 VIN 1 V 7 7 V IND7-ND12+1 1 lit/ / -- li v X b x x 0RT9000 V IN 1 7 V w V IST-IMTRXA(2 x j I — x iti I i\ An yx. , 1)x f 0RT9010 V IN 1 7 v X V

llllll MMTXR-IMTRXA 1 A l\— X III 1 i\ An (^ 42 t 2)f 0RT9020 V IN 1 7 V tm V MMTXC=IMTRXA llllll 1 A V"TM X III 1 i\ A ri (2\ t~ j 3)J f 0RT9030 V1XI / V ^ V GO TO 1250 0RT9040

rV 0RT9050

X1990 7 7 w FORMAT (/35X,22HLEAST SQUARES FIT FOR ,12A1,11H IN COLUMN ,14) 0RT9060

fc. v U U FORMAT (25X,26HAS A POLYNOMIAL OF DEGREE ,I2,4H IN ,12A1,11H IN C00RT9070

1LUMN ,14) 0RT9080

2010 FORMAT (20X,6HUSING ,I4,22H N0N-ZER0 WEIGHTS AND ,I4,24H ZERO WEIG0RT9090

1HTS IN COLUMN ,14) 0RT9100

2020 FORMAT (35X,6HUSING ,I4,19H N0N-ZER0 WEIGHTS =,10A1) 0RT9110

2030 FORMAT (60H0 PLOTS ARE NOT PRINTED BECAUSE NO. OF POINTS IS LESS T0RT9120

223
1HAN 3) 0RT9130

2050 FORMAT (23X,24HAS A LINEAR FUNCTION OF ,I2,31H PREDICTOR VARI ABLES0RT9150

1 IN COLUMNS, I4,8(A1,I4) ) 0RT9160

2060 FORMAT ( 14 , 24 (Al , 14 ) ) 0RT9165

END 0RT9170

224
SUBROUTINE ORTHRV (A ,NROW,N ,NCOL , IND ,X ,NASIZE ,XP) ORV 10

c VERSION 5.00 ORTHRV 5/15/70 ORV 20

c SUBROUTINE ORTHRV ( A , NROW, N , NCOL , IND , X , NAS IZE , XP

)

ORV 30

c SUBROUTINE TO CHECK TO SEE IF MATRIX IS ORTHOGONAL ORV 40

DIMENSION A(NR0W,1), X(l), IND (1

)

ORV 50

DOUBLE PRECISION XP(1) ORV 60

c IF NUMBER OR ROWS IS GREATER THAN NUMBER OF COLUMNS COMPUTE A'

A

ORV 70

c OTHERWISE AA' ORV 80

IF (N .GT .NCOL) GO TO 10 ORV 90

L2P=1 ORV 100

MP=N ORV 110

GO TO 20 ORV 120

10 L2P=2 ORV 130

MP=NCOL ORV 140

20 CALL MXTXP (A,NR0W,N,NC0L,X ( L2P,NASIZE,XP) ORV 150

IC=1 ORV 160

IND(1)=0 ORV 170

IND (2 )=0 ORV 180

DO 80 1=1, MP ORV 190

DO 80 J=1,MP ORV 200

IF (I.EQ.J) GO TO 40 ORV 210

IF (X(IC)) 30,80,30 ORV 220

30 IF (ABS(X(IC) )-l.E-7) 60,60,90 ORV 230

40 IF (X(IC)-l.O) 50,80,50 ORV 240

50 IF (ABS(X(IC)-1.0)-l.E-7) 60,60,70 ORV 250

60 IND (2)=1 ORV 260

GO TO 80 ORV 270

70 IND(1)=2 ORV 280

80 IC=IC+1 ORV 290

GO TO 100 ORV 300

90 IND (1)=2 ORV 310

IND(2)=2 ORV 320

GO TO 150 ORV 330

100 IF (IND(l) .EQ.0.AND.IND(2) .EQ.l) IND(1)=1 ORV 340

IF (N.EQ.NCOL) GO TO 150 ORV 350

C SET UP INDICATORS FOR RECTANGULAR MATRICES ORV 360

GO TO (110,130) , L2P ORV 370

110 IF (IND(l) .EQ.l) GO TO 120 ORV 380

IND(1)=3 ORV 390

IND (2)=3 ORV 400

GO TO 150 ORV 410

120 INi?(l)=-3 ORV 420

IND(2)=-3 ORV 430

GO TO 150 ORV 440

130 IF ( IND (1 ) .EQ.l) GO TO 140 ORV 450

IND { 1 )=4 ORV 460

IND(2)=4 ORV 470

GO TO 150 ORV 480

C

* ORV 490

C IND(1)=0 EXACT ORTHOGONAL ORV 500

c IND (1)=1 RELATIVE (l.E-7) ORTHOGONAL ORV 510

c IND (1)=2 NON-ORTHOGONAL ORV 520

c INDICATORS FOR RECTANGULAR MATRICES ORV 530

c IND (l)=-3 RELATIVE ORTHOGONAL ROWWISE ORV 540

c IND (1)=3 EXACT ORTHOGONAL ROWWISE ORV 550

c IND ( 1 )=-4 RELATIVE ORTHOGONAL COLUMNWISE ORV 560

c IND (1 )=4 EXACT ORTHOGONAL COLUMNWISE ORV 570

c IND (2)=-l DIAGONAL TERMS ARE 1.0 SE ORV 580

c IND (2 )=0 EXACT ORTHOGONAL NORMALIZED ORV 590

225
C IND(2)=1 RELATIVE ORTHOGONAL NORMALIZED ORV 600

C IND(2)=2 NON-ORTHOGONAL ORV 610

C IND (2 )=-3 RELATIVE ROWWISE (NORMALIZED) ORV 620

C IND (2)=3 EXACT ROWWISE (NORMALIZED) ORV 630

C IND(2)=-4 RELATIVE COLUMNWISE (NORMALIZED) ORV 640

C IND(2)=4 EXACT COLUMNWISE (NORMALIZED) ORV 650

C * ORV 660

C * ORV 670

140 IND(l)=-4 ORV 680

IND(2)=-4 ORV 690

150 RETURN ORV 700

END ORV 710

226
SUBROUTINE ORTPLT ( ND19 , ND2 , N , SSQ , ND3 , IB , I XA , I WS ) ORP 10

C VERSION 5.00 ORTPLT 5/15/70 ORP 20

C THIS PROGRAM IS USED BY ORTHO TO GENERATE PLOTS ORP 30

C WRITTEN BY S PEAVY 10/11/69 ORP 40

DIMENSION IU(1) , IB (1 ) ORP 50

EQUIVALENCE (IU,A) ORP 60

C ***** ORP 70

C0MM0N/BL0CKD/IARGS(100) ,KIND(100) ,ARGTAB(100) ,NRMAX ,NROW,NCOL , ORP 80

1NARGS , VWXYZ (8 ) ,NERROR ORP 90

C0MM0N/BL0CRC/NRC,RC(12600) ORP 100

COMMON/ HEADER /NOCARD (80 ) ,ITLE(60,6) , LNCNT , I PR I NT ,NPAGE , I PUNCH ORP 110

C0MM0N/SCRAT/NS,NS2,A(13500) ORP 120

COMMON /FMAT/ I FMTX (6) , IOSWT , IFMTS (6 ), LHEAD (96 ) ORP 130

DIMENSION ARGS(IOO) ORP 140

EQUIVALENCE (ARGS (1 ), RC (12501 )

) ORP 150

COMMON /ABCDEF/L (48) ORP 160

COMMON/CONSTS/PI ,E,HALFPI , DEG , RAD , XALOG ORP 170

C ***** ORP 180

IW=IWS ORP 182

IWST=1 ORP 184

IF(KIND(2) .EQ.O) GO TO 18310 ORP 186

IWST=2 ORP 187

WT=ARGS(2) ORP 188

18310 IND4 = ND19+1 ORP 190

IND2=ND2+1 ORP 200

NZW=N ORP 205

DO 18320 1=1, N ORP 210

GO TO (18312,18314) ,IWST ORP 211

18312 WT=RC(IW) ORP 212

IW=IW+1 ORP 213

18314 IF(WT.NE.O.O) GO TO 18316 ORP 214

IU (IND4)=27 ORP 215

NZW=NZW-1 ORP 216

GO TO 18318 ORP 218

18316 Z=A(IND4) /FSQRT (SSQ/WT-A ( IND2 ) **2 ) ORP 220

IZ=Z / .3 ORP 230

IF (Z.GT.O.O.AND.AMOD(Z, .3) . NE . 0 . 0 ) IZ=IZ+1 ORP 240

IU(IND4)=IZ+13 ORP 250

IF(IU(IND4) .LE.O) IU(IND4)=1 ORP 260

IF (IU (IND4) .GT.26) IU(IND4)=26 ORP 270

18318 IND2=IND2+1 ORP 280

18320 IND4=IND4+1 ORP 290

IND3=ND3+1 ORP 300

YMAX=A ( IND3 ) ORP 310

YMIN=A(IND3) ORP 320

DO 18340 1=2, N ORP 330

IND3=IND3+1 ORP 340

IF(YMIN.LE.A(IND3) ) GO TO 18330 ORP 350

YMIN=A ( IND3 ) ORP 360

GO TO 18340 ORP 370

18330 IF (YMAX . LT . A ( IND3 )

) YMAX=A ( IND3 ) ORP 380

18340 CONTINUE ORP 390

YMM=ABS (YMAX-YMIN)/50. ORP 400

YMX=FL0AT(N-l)/50. ORP 410

CALL PAGE(O) ORP 420

IPL0T=1 ORP 430

WRITE(IPRINT, 18350) ORP 440

18350 FORMAT (15X , 36HSTANDARDIZED RESIDUALS VS ROW NUMBER, 22X, ORP 450

1 42HSTANDARDIZED RESIDUALS VS PREDICTED VALUES) ORP 460

227
18420

18430

19000

18355 WRITE ( IPRINT , 18360 ) (L (39) , 1=1 ,88)

18360 FORMAT (7X, 2 (1H+.9A1) , 1H+ , 4A1 , 1HX , 4A1 , 2 ( 1H+9A1 )

, 1H+ , 10X , 2 ( 1H+ , 9A1

)

1 ,1H+,4A1,1HX,4A1,2(1H+,9A1) ,1H+)

YYPR=3 .75

LINE=26

18390 DO 20050 1=1,5

DO 18400 IJ 1=1 , 102

18400 IB (IJI )=L (45)

GO TO (18410,19000) ,IPLOT

18410 IND3=ND3+1

IND4=ND19+1

DO 18430 I J 1=1 ,

N

IF (IU (IND4) .NE.LINE) GO TO 18420

IZ=FLOAT (IJI-1) /YMX +.5

IZ=IZ+1

IF(IZ.LE.O) IZ=1

IF(IZ.GT.51) IZ=51

IB(IZ)=L(41)

IZ=(A(IND3)-YMIN) /YMM

IZ=IZ+1

IF(IZ.LE.O) IZ=1

IF(IZ.GT.51) IZ=51

IB(IZ+51)=L(41)

IND4=IND4+1

IND3=IND3+1

GO TO 20000

IND4=ND19+1

IX=IXA

DO 19010 IJ 1 = 1 ,

N

IF(IU(IND4) .NE.LINE) GO TO 19005

IZ=(RC (IX)-XMIN) /XMM

IZ=IZ+1

IF(IZ.LE.O) IZ=1

IF (IZ.GT.51) IZ=51

IB ( IZ)=L (41

)

RAT 1 0= ( AN-GAMMA ) /FDEN

YMM=4.91* (RATIO** .14- (1 .-RATIO)** .14)

AN=AN-1.0

IF (AN.LT.2. .AND. NZW.LE.10) GAMMA = 1./3.

IZ=YMM/ .1

IZ=IZ+26

IF (IZ.LE.O) IZ=1

IF(IZ.GT.51) IZ=51

IB(IZ+51)=L(41)

19005 IX=IX+1

19010 IND4=IND4+1

20000 IF(I-l) 20010,20010,20030

20010 WRITE (IPRINT, 20020 )YYPR, ( IB ( I J I )

, IJ 1=1 , 51 )

, YYPR , (IB (IJI) , I J 1=52

,

1 102)

20020 F0RMAT(1X,F5.2,1H+,51A1 ,1H+,3X,F5 .2,1H+,51A1 ,1H+)

GO TO 20045

20030 WRITE(IPRINT,20040) ( IB ( I J I ), I J 1=1 , 102

)

20040 FORMAT (6X,1H-, 5 1A1 , 1H- , 8X , 1H- , 51A1 , 1H-)

20045 LINE=LINE-1

IF(LINE.EQ.O) GO TO 20060

20050 CONTINUE

YYPR=YYPR-1.5

GO TO 18390

20060 WRITE ( IPRINT , 18360

)

(L (39) , 1=1 ,88)

ORP 470

ORP 480

ORP 490

ORP 500

ORP 510

ORP 520

ORP 530

ORP 540

ORP 550

ORP 560

ORP 570

ORP 580

ORP 590

ORP 600

ORP 610

ORP 620

ORP 630

ORP 640

ORP 650

ORP 660

ORP 670

ORP 680

ORP 690

ORP 700

ORP 710

ORP 720

ORP 730

ORP 740

ORP 750

ORP 760

ORP 770

ORP 780

ORP 790

ORP 800

ORP 810

ORP 820

ORP 830

ORP 840

ORP 850

ORP 860

ORP 870

ORP 880

ORP 890

ORP 900

ORP 910

ORP 920

ORP 930

ORP 940

ORP 950

ORP 960

ORP 970

ORP 980

ORP 990

0RP1000

0RP1010

0RP1020

0RP1030

0RP1040

0RP1050

228
GO TO (20070,21100 ) ,IPLOT

20070 YMM=YMX*25.0 +1.0

YMMY= (YMAX-YMIN) /2 .+YMIN

WRITE ( I PR INT , 20080 ) YMM,N , YMIN , YMMY , YMAX

FORMAT (6X,3H1.0,18X,F9.4,16X, 15, 2H.0 , 1PE15 . 4 , E26 . 4 , 10X , E10 . 4

)

WRITE (IPRINT, 20090)

20080

20090 FORMAT (1H ) IPLOT=2

IX=IXA

XMAX=RC(IX)

XMIN=RC(IX)

DO 21000 1=2,

N

IX=IX+1

IF (RC (IX) .GT.XMAX) XMAX=RC(IX)

IF(XMIN.GT.RC(IX) ) XMIN=RC(IX)

21000 CONTINUE

XMM = ABS (XMAX-XMIN) /50.

GAMMA=P 1/8.0

AN=NZW

FDEN=AN-2 . *GAMMA+1 .

0

WRITE (IPRINT, 21010) (LHEAD(I) ,1=13,24)

21010 FORMAT (14X , 26HSTANDARDIZED RESIDUALS VS ,12A1, 21X,

1 42HPR0BABILITY PLOT OF STANDARDIZED RESIDUALS)

GO TO 18355

21100 YMMY=( XMAX-XMIN) /2.+XMIN

WRITE (IPRINT, 21110) XMIN ,YMMY ,XMAX

21110 F0RMAT(1PE13 .4,14X, E12.4, 8X, E12 . 4 , 7X , 4H-2 . 5 , 22X , 3H0 . 0 , 22X

,

1 3H2.5)

RETURN

END

0RP1060

0RP1070

0RP1080

0RP1090

0RP1100

0RP1110

0RP1120

0RP1130

0RP1140

0RP1150

0RP1160

0RP1170

0RP1180

0RP1190

0RP1200

0RP1210

0RP1230

0RP1240

0RP1245

0RP1250

0RP1270

0RP1280

0RP1290

0RP1300

0RP1310

0RP1320

0RP1330

0RP1340

0RP1350

0RP1360

229
CIIDDAIITTMC ftllTDItT bUBKUUIlNt UU 1 rll 1 Al IT UU 1 10

c UCDC TAM C A A ft 1 1 T D 1 1 T C / 1 C / "7 A VtKMUN 5.00 UU 1 rU 1 5/15/70 Al IT UU 1 20

A A MMAM /Dl nri/ A / MA n C U V A D n / O 1 \ 1/ADP ADT ADTI MC \A/A A / O A \ t/DACKIA LUMMUN /bLULKA/ MUUt , M , K.AKU ( 8 3 ) , KAKb , AKb , AKbZ , ML WLU ( 80 )

, KKUtlMO Al IT UU ! 30

A A MMAhi /Dl AAi/H / MCTMT MCTMTV MCTMTU MA AM IOAM TA\/CI PflUnnniH LUMMUN /DLULMJ/ NoIMI , IMo 1 M 1 A , No 1 m 1 n , IMUUM , LuUM , 1 U V r L , UUM ( L U 0 U ) Al IT UU 1 A A H\J

COMMON /BL0CRC/ NRC ,RC (12600) OUT C A 50

COMMON /BL0CKD/ IARGS(IOO) , KIND (100) , ARGTAB (100 ), NRMAX ,NR0W,NC0L ,N0UT L A 60

i arg<^ \iwxv7tR\ nfrror UU 1 1 A

7 0 U 1 IVIL.I1 J lUli nlxUJ \ 1UU J UU 1 0 A HO

Ffill T VAI FNPF fARft^fM RPd^dlU 0U 1UIT1 Q A

7 0

rnMiwnN /ri nr«r / Kin tniintt t^trat krhdiit krdknt i i t<;t 01U UIT1 1 A A A UU 1 1 1 A 110

A IURTTF RFPflRD f>N ^TRATTH IINTT ntUUit1 1 0 A A niU Uit1 1 1 A

131/

TF fNFRRfiR FO fl AND 1 1 T^T FO r\\ Gfl Tfi in OUT UU 1 1 A A TF fMfiflF FO % \ Gfl Tfl ?n OUT UU 1 1 C A 15U

WRTTF Wl\ 1IC M^PRAT ( 1 JLivH 1 3 0.\ NFIA/Pn , j U ) it L WU U niUUit1 1 L A 160

i a 10 Al IT 1 7 A 1/0

o a I=NSTMT/10 OUT 1 0 A

loll

WRITE (ISCRAT,40) I,NEWC0 OUT IVU

GO TO 10 OUT

pL OUT OTA civ

^ a 30 FORMAT (4X.80A1) OUT O O A zzu 40 FORMAT (1H+,I3,80A1) OUT 230

END OUT 240

230
SUBROUTINE PACK (NWORD , MWORO , NO , I P ) PAC 10

C VERSION 5.00 PACK 5/15/70 PAC 20

C WRITTEN BY S PEAVY 9/17/69 PAC 30

C NWORD CONTAINS CHARACTERS TO BE PACKED OR UNPACKED PAC 40

C MWORD THE PACKED CHARACTERS IN CODED FORM (SEE BELOW) OR THE PAC 50

C UNPACKED CHARACTERS PAC 60

C NO NO OF CHARACTERS TO BE PACKED OR UNPACKED PAC 70

C IP IP=0 PACK PAC 80

C IP IP=1 UNPACK PAC 90

C PAC 100

C THE CHARACTERS ARE PACKED IN A CODED FORM. EACH CHARACTER HAS BEENPAC 110

C ASSIGNED A VALUE IN OMCONV . THIS VALUE IS 1 LESS THAN THE PAC 120

C SUBSCRIPT OF L (IN LABELED COMMON ABCDEF) FOR THAT PARTICULAR PAC 130

C CHARACTER. THESE VALUES ARE STORED IN KARD. THE VALUES OF THE PAC 140

C CHARAC1 ERS ARE PACKED AS FOLLOWS PAC 150

C MW0RD(I)=(KARD(K)+l)*2**16+(KARD(K-l)+l)*2**8+KARD(K-2)+lPAC 160

C PAC 170

COMMON /ABCDEF/ L(48) PAC 180

DIMENSION NWORD(l), MWORD(l) PAC 190

KB=1 PAC 200

KA=1 PAC 210

IF (IP.EQ.l) GO TO 30 PAC 220

C PACK PAC 230

10 MWORD (KA)=0 PAC 240

DO 20 1=1,3 PAC 250

MW0RD(KA)=MW0RD(KA)*256+NW0RD(KB)+1 PAC 260

KB=KB+1 PAC 270

IF (KB .GT .NO) GO TO 22 PAC 280

20 CONTINUE PAC 290

KA=KA+1 PAC 300

GO TO 10 PAC 310

22 ICE=M0D(N0,3) PAC 311

IF(ICE.EQ.O) RETURN PAC 312

ICE=3-ICE PAC 313

24 MWORD (KA)=MWORD (KA) *256+45 PAC 314

ICE=ICE-1 PAC 315

IF (ICE.EQ.O) RETURN PAC 316

GO TO 24 PAC 317

C UNPACK PAC 320

30 ICA=NWORD(KB) PAC 330

ICD=65536 PAC 340

DO 40 1=1,3 PAC 350

ICB=ICA/ICD PAC 360

IF (ICB.EQ.O) GO TO 40 PAC 370

MWORD (KA)=L(ICB) PAC 380

KA=KA+1 PAC 390

IF (KA.GT.NO) RETURN PAC 400

ICA=ICA-ICB*ICD PAC 410

40 ICD=ICD/256 PAC 420

KB=KB+1 PAC 430

GO TO 30 PAC 440

END PAC 450

231
SUBROUTINE PAGE (J) PAG 10

C VERSION 5.00 PAGE 5/15/70 PAG 20

C PAG 30

C BRING UP A NEW PAGE AND PRINT OMNITAB CARD AND PAGE NUMBER PAG 40

C THEN, IF J = 0, DONE PAG 50

C J = 1 , PRINT TITLE1 PAG 60

C J = 2, PRINT TITLEl , 2 PAG 70

C ETC. FOR J = 3, 4 PAG 80

C THIS ROUTINE ASSUMES THAT THE EXECUTIVE SYSTEM LEAVES PAG 90

C THE PRINTER FORM AT THE TOP OF THE FIRST BLANK PAGE. PAG 100

COMMON/HEADER/NOCARD (80) ,ITLE(60,6) , LNCNT , I PR I NT ,NPAGE , I PUNCH PAG 110

NPAGE=NPAGE+1 PAG 150

WRITE (IPRINT,20) NOCARD ,NPAGE PAG 160

IF (J .LE.O.OR.J .GT.4) GO TO 10 PAG 180

WRITE (IPRINT,30) (

( ITLE ( 1 , 1 1 ), 1=1 , 60 ), 1 1=1 , J ) PAG 190

10 RETURN PAG 200

C PAG 210

20 FORMAT (1H1 , 19X , 80A1 , 10X , 4HPAGE , 14 ) PAG 220

30 FORMAT ( IX , 120A1 / IX , 120A1 ) PAG 230

END PAG 240

232
SUBROUTINE PDMOTE PDM 1 A 10

c VERSION 5.00 PDMOTE 5/15/70 nr\n PDM A A 20

COMMON /BL0CRC/ NRC , RC ( 12600

)

PDM "> A 30

COMMON /BLOCKD / IARGS(IOO) , KIND (100) , ARGTAB (100 )

, NRMAX ,NR0W,NC0L ,NPDM A A 40

IARGS, VWXYZ(8) ,NERR0R n nil PDM 50

DIMENSION ARGS(IOO) d n ii PUM 60

EQUIVALENCE (ARGS (1 ), RC ( 12501 )

)

d n ii PDM 70

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG r UNI 80

L2=L2-10 d n ii 90

Ac r UM 1 A A 100

C L2 : 0 FOR PROMOTE, 1 FOR DEMOTE ( L2 ADTPTMAIIV in 11 \ UK 1 b 1 NALL Y 10, 11 ) nnu PUM 110

A

c r UM 120

IF (MOD (NARGS , 2 ) .NE.O) GO TO Dnil PUM 130

1=10 nnii

r UM 1 i n 140

10 CALL ERROR (I) DrtM PUM 150

A A 20 RETURN rum T / A 160

a 30 IF (KIND (1 ) .EQ.l) GO TO 35 DrtM PUM 163

NR = IARGS (1) PUM 1 T A 170

IARGS(1)=1 nnu PUM T A A 180

CALL CHKCOL (I) ddm rUM 1 A A 190

IF (I.EQ.O) GO TO 40 DDM r UM 200

35 I = 20 DrtM r UM 210

GO TO 10 DrtM rUM 220

L

DrtM r UM AAA 230

L IF NUMBER OF ROWS TO BE MOVED IS NEGATIVE, CrLir I TD T MCTDI IPT T ftWC i No 1 KUL. 1 1 UNi . r UM A A A 240

L T F PRflMOTF A T <; THF SAME AS DEMOTE 6 DIM! PUM A C A 250

A A 40 TF fNR GF n\ en to nnu PUM 260

1 ?_1 1 0 L- L — X —1_ C nnu PUM 270

NR- NR DrtM PUM 280

r A 50 NARft^— Nftr\uj=NARG^ niMnvaj — 11 pnu r Um 290

C

DrtM rum 300

c CWVCV. nTQTAMTF OF Mfl\/F DDM r UM OTA 310

c

DrtM r Um AAA 320

IF (L2.EQ.0) GO TO 70 DrtM r UM 330

IF (NR+NRMAX.LE.NROW) GO TO 100 DrtM rum 340

CALL ERROR (231) DrtM r UM 345

NRMAX=NROW-NR DrtM PUM A C A 350

IF (NRMAX) 20,20,100 DrtM PUM A r T 351

70 NDIFF = NRMAX-NR DrtM rUM A C C 355

IF (NDIFF) 81,82,82 DrtM r UM A Z A 360

A "I 81 CALL ERROR (230) DrtM r UM a / e 365

NDIFF = 0 DrtM PUM 370

NR = NRMAX DrtM rUM A "T C 375

A A 82 IF (NARGS. GT.O) GO TO 100 nnu PUM AAA 380

J = IARGS (1)-1 DrtM PUM IOC 385

DO 95 11 = 1,NC0L run AAA 390

Kl = J+l DrtM PUM O A C 395

IF (NDIFF. EQ.O) GO TO 86 DrtM rUM 400

K2 = Kl + NR DrtM PUM A T A 410

DO 85 12 = 1, NDIFF DrtM r UM A 1 A RC(K1) = RC(K2) DrtM r UM #1 1 c 425

Kl = Kl+1 n n II PUM 430

A r 85 K2 = K2+1 nnu PUM 4 A C 435

A L 86 DO 90 13 = 1,NR nnu PDM VI it A 440

RC(K1) = 0.0 PDM j ja r 445

A A 90 Kl = Kl +1 PDM J PA 450

A C 95 J = J + NROW PDM A / A 460

GO TO 20 PDM 470

100 LIMIT=NARGS PDM 480

233
IC /I TMTT Cn Al 1 TMIT O + MPPI lr (L.1M1I . ty . 0 ) L 1 Ivu 1 =Z NILUL DnM r UM 4 V 0

Ilrr /MPDDnD MP A\ Pf\ Tfl OA

( NC.KKUK . nt . U ) bU IU ZO rUNI DnM C A A 500

tp imdmay MP ai pn Tn 1 1 n lr ( NKMAA . IMt . U ) bU IU 110 DnM r UM CIA 310

p n Tfi in bU IU 10 DnM r UM C *) A bZO

pb DnM r UM 3JU

pt CTADT DDfl MO T T M P flD DC MP TTklf 0 1 AK 1 rKUMUIlrvb UK UtMUllNb onM r UM C A A pb DnM r UM CCA DD0

J. 1

U

nnUU 1100cn T_l 1 TMTT 9 1 = 1 , LI ml 1 , Z DnM c a n 300

TP fNARG^ NP ni GO. Tfl 1 ?n r v vn c.7n

If 1 T ADf C f 1 \ pnu con SOU

If 9 —If 1 r\ £ =r\ 1 PDM con

IIAKuj ADfC M \ T A DP C / 1 1 . M DniU (1 )=lAKu J (1 J +NKU

n

DnM rUm AAA QUO

fin th iin PDM a i n 0 1 u

IfM=lnRUJ 1 — T ARG^ / lil \

^ 1+1 J rum

Ifl\Z=lAKbj 7 T ADP Q f 1 ,51

I 1 + Z ) pnM r Um a % n

1 jU tp /io pn a\ pn xn i c a lr (LZ.ty.U) bU IU lt>0 DnM r UM A A A 0^0

pb DnM r UM A C A 0 3 0 Pb

nUtMU p un tp pni at if i Tn pni at if 9 1 t bUL Al M IU bUL Al l\Z pnu A A n 000

b DnM r UM A0/07 A

If 1 —If 1 iNPUAY pnM r UIVI Ann DOU

If 7 If 0 i MDMA V i KID N Z =N Z +N K MA A +N K DnM r UM A 0 A 070

fin 1 Aft 1 1 MDMA V UU 110 J=1,NKMAA DnM r UM 7 A A / 00

If 1 If 1 1 f\ l=rv 1 — 1 DnM r UM 7 1 A / 1 0

If?—

1

PDM r u vn 7?n

11U i An OCKb 1 If 7 1 —DP 1 If 1 \

J =Kb [M J pnM r U Ifi 7^n

pbUn Tn ion 1 U loU DnM r UM 7 A A / tu

pb DnM r UM 7 C A /DO

pb DcnufiTr rKUMU pni at ifi Tn pni at v? 1 t bUL Al M IU bUL Al l\Z pnM r UM 7 AA

pb pnM r UM 7 7 n / / U

1 D U

1 1 MDMAV MD J J=NKMAA—NK pnM r uim 7/ OUq n tplr /

( J

i Ji

. pnty . aiu ) pnbU Tniu ucio? pnM r uwi 7 fi C / 03

If 1 V 1 MD pnM rUM 7on

noUU i10UAn i—T i i J — 1 , J <J rum PDM OwU

or iv o \ dp f if 1

1

Kb {l\Z ;=Kb (M ; PDM r UIVI q i n 0 1 u

if i —if i 1

1

M=M+ 1 pnM r UIVI a?n 0 A U

1 £ A 160 If 7 7 . 1 l\Z=KZ+l pnM r UM Q 1

A

0 J\)

p pnM r UM otu 0 A A pb TP D D n un TP ADDAV PTII DPCT fIC Pnill MM lAITTkl 7PD0PQ lr rKUMU 1 1 AKKAY , rlLL Kt.il Ur bULUMN Wlln ZtKUto . pnM r u wi OjU sen

pb

Pf)M r v vn RAH 0 0 U tpir /madpc mp n\ nn Tn inn l NAKuj . Nt . U J bU IU 10U PDM rum O 1 u lOD II 11,1 J J=J J+l pnM r Um RRn oOU

nnUU 1/0 1 7(1 J=J 1— i J1 MDMAV , PmiYlMA pnM rum O 7 v DP / V 0 \ A Kb ( KZ ) =0

.

rum pnM onn

1 "7 A 170 If 9 If 9 . 1 KZ=KZ+1 pnM r UWI o71Ui n

1 0 A loO PPMT bUN T Ml IP

1 1 nut. pnM rum 7tU

TP l\ 7 MP A \ MDMAV MDMAV, MD lr (LZ.Nt.U) NKMAa=NKMAA+IMK pnM r uwi o73Un GO TO 20 pnM r UM OAA 7^0

END PDM 950

234
SUBROUTINE j u i_> i\ \j u i i ii l PHYCON r ii i v vi» (NAME1 \ iv n if il. / PHY 10

c VERSION 5.00 PHYCON 5/15/70 PHY 20

COMMON /BLOCKA/ MODE , M, KARD (83 )

, KARG , ARG , ARG2 , NEWCD (80 ), KRDEND PHY 30

COMMON /PCONST /JPC P(40) N(40) PHY 40

c REMOVE PHY 50

c PHY 60

p PHYSICAL CONSTANT LIST PHY 70

r PHY 80

r ENTRIES ARE IN PAIRS, FIRST MKS VALUE, THEN CGS (ELECTROMAGNETIC) PHY 90

c PHY 100

r PHY 110

c PI PI PHY 120

c E BASE OF NATURAL LOGS PHY 130

c C SPEED OF LIGHT IN VACUUM PHY 140

c Q ELEMENTARY CHARGE PHY 150

c N AVOGADRO CONSTANT PHY 160

c ME ELECTRON REST MASS PHY 170

c MP PROTON REST MASS PHY 180

c F FARADAY CONSTANT PHY 190

c H PLANCK CONSTANT PHY 200

c ALPHA FINE STRUCTURE CONSTANT PHY 210

c QME CHARGE TO MASS RATIO FOR ELECTRON PHY 220

c RINF RYDBERG CONSTANT PHY 230

c GAMMA GYROMAGNETIC RATIO OF PROTON (CORRECTED FOR H20) PHY 240

c MUB BOHR MAGNETON PHY 250

c R GAS CONSTANT PHY 260

c K BOLTZMANN CONSTANT PHY 270

c CONE FIRST RADIATION CONSTANT PHY 280

c CTWO SECOND RADIATION CONSTANT PHY 290

c SIGMA STEPHAN-BOLTZMANN CONSTANT PHY 300

c G GRAVITATIONAL CONSTANT PHY 310

c PHY 320

c PHY 330

c IF NAME .LE. 0, NAME = INDEX FROM MKS, CGS 0 = CGS, -1 = MKS PHY 340

c PHY 350

J=JPC PHY 355

IF (NAME.GT.O) GO TO 10 PHY 360

JPC=NAME PHY 370

RETURN PHY 380

10 DO 20 1=1,20 PHY 390

IF (NAME.EQ.N(I) ) GO TO 30 PHY 400

20 CONTINUE PHY 410

ARG=0

.

PHY 420

RETURN PHY 430

30 I=I+I+J PHY 440

ARG=P(I) PHY 450

RETURN PHY 460

END PHY 470

235
c

c

c

c

c

c

c

BLOCK DATA PHYSIC

VERSION 5.00 PHYSIC 5/15/70

BLOCK DATA PHYSICAL CONSTANTS

(THEIR VALUES AND NUMBER REPRESENTATION)

BLOCK DATA

C0MM0N/PC0NST/JPC,P(40) ,N(40)

PCONST DEFINES PHYSICAL CONSTANT VALUES

SI UNITS C6S UNITS

SEE BELOW FOR FURTHER COMMENTS

cV PI Pi l \—

1

p c —J . X*tX.J7£0.?.?-J r\j F P( 3)=2 .718281828459 Pr 1 4 |_9 71 R 9 R 1 R 7 Rd e;Q r r\f P( 5)=2 .997925E8 pr O —L .77'

c n P( 7)=1 .60210E-19 Pr < Ro i—i Afi?inF ? n c N P( 9)=6 .02252E23 Pr 1 1 0 c MEML. P(ll)=9 1091E-31 Pr ( X L. i _g i n<J 1 F ?

R

— 7 . X V 7 1 L

CO

r MP P(13)=l 67252E-27 P 1 1 4

r F1 P(15)=9 64870E4 DI -QMO 7n

c 1H1 P(17)=6 6256E-34 P f 1 R —O . U L. J O C — CI c ALPHA P(19)=7 29720E-3 P i_7 ?Q7?(iF 3 c QME P(21)=l 758796E11 P (22 =17587960

c RINF P(23)=10973731. P (24 (=109737 .31

c GAMMA P(25)=2 67519E8 P (26 =26751 .9 c MUB P(27)=9 2732E-24 P (28 =9 .2732E-21

c R P(29)=8 3143 P (30 =8.3143E7

c K P(31)=l 38054E-23 P (32 =1.38054E-16

c CONE P(33)=3 7415E-16 P (34 =3 .7415E-5

c CTWO P(35)=l 43879E-2 P (36 =1 .43879

c SIGMA P(37)=5 6697E-8 P (38 =5.6697E-5

c G P(39)=6 670E-11 P [40 =6.670E-8

DATA P(l) ,P(2) ,P(3) ,P(4) ,P(5) ,P(6) ,P(7) ,P(8 ,P(9) ,P(10)/

12*3 .1415926535,2*2.718281828459,2 .997925E8 ,2 .997925E10,

2 1 .60210E-19.1 .60210E-20,2*6.02252E23/

DATA P(ll) ,P(12) ,P(13) ,P(14) ,P(15) ,P(16) ,P(17) ,P(18) ,P(19) ,P(20)/

1 9.1091E-31,9 .1091E-28,1 .67252E-27 ,1 . 67252E-24 , 9 . 64870E4 , 9648 . 70

,

2 6.6256E-34,6 . 6256E-27 , 2*7 .29720E-3/

DATA P(21) ,P(22) ,P(23) ,P(24) ,P(25) ,P(26) ,P(27) ,P(28) ,P(29) ,P(30)

/

1 1.758796E1 1,17587960. ,10973731. , 109737 . 31 , 2 . 67519E8 , 26751 . 9

,

2 9.2732E-24,9 . 2732E-21 , 8 . 3143 , 8 .3143E7/

DATA P(31) ,P(32) ,P(33) ,P(34) ,P(35) ,P(36) ,P(37) ,P(38) ,P(39) ,P(40)/

1 1 .38054E-23 ,1 .38054E-16,3 .7415E-16,3 .7415E-5 ,1 .43879E-2,1 .43879

,

2 5.6697E-8. 5 .6697E-5.6 .670E-11.6 .670E-8/

DATA N(l) ,N(2) ,N(3) ,N(4) ,N(5) ,N(6) ,N(7) ,N(8) ,N(9) ,N(10)/

1 11907,3645,2187,12393,10206,9612,9909,4374,5832,1069/

DATA N(ll) ,N(12) ,N(13) ,N(14) ,N(15) ,N(16) ,N(17) ,N(18) ,N(19) ,N(20)/

1 12749,13379,5143,10046,13122,8019,2606,2750,14101,5103/

PHYSICAL CONSTANTS INTEGER REPRESENTATION

c N (1) = 11907= PI (PI)

c N (2) = 3645= E (BASE OF NATURAL LOGS)

c N (3) = 2187= C (SPEED OF LIGHT IN VACUUM)

c N (4) = 12393= Q (ELEMENTARY CHARGE)

c N (5) = 10206= N (AV0GADR0 CONSTANT)

c N (6) = 9612= ME (ELECTRON REST MASS)

C N (7) = 9909= MP (PROTON REST MASS)

c N (8) = 4374= F (FARADAY CONSTANT)

c N (9) = 5832= H (PLANCK CONSTANT)

C N(10)= 1069= ALPHA (FINE STRUCTURE CONSTANT)

C N(ll)= 12749= QME (CHARGE TO MASS RATIO FOR ELECTRON)

c N(12)= 13379= R J W F (RYDBERG CONSTANT)

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

PHC

10

20

30

40

50

60

70

80

90

100

110

120

130

140

150

160

170

180

190

200

210

220

230

240

250

260

270

280

290

300

310

320

330

340

350

360

370

380

390

400

410

420

430

440

450

460

470

480

490

500

510

520

530

540

550

560

570

580

590

236
c N(13)= 5143= GAMMA (GYROMAGMETIC RATIO OF PROTON-CORRECTED FOR H20) PHC 600

c N (14) = 10046= MUB (BOHR MAGNETON) PHC 610

c N (15) = 13122= R (GAS CONSTANT) PHC 620

c N (16) = 8019= K (BOLTZMANN CONSTANT) PHC 630

c N ( 17 ) = 2606= CONE (FIRST RADIATION CONSTANT) PHC 640

c N (18) = 2750= CTWO (SECOND RADIATION CONSTANT) PHC 650

c N (19) = 14101= SIGMA (STEPHAN-BOLTZMANN CONSTANT PHC 660

c N (20) = 5103= G (GRAVITATIONAL CONSTANT) PHC 670

END PHC 680

409-118 OL - 71 - 16

237
SUBROUTINE PLOT PLO 10

C VERSION 5.00 PLOT 5/15/70 PLO 20

C S PEAVY 1/18/68 PLO 30

C THIS ROUTINE PLOTS MAX. OF 5 CURVES. IF MORE THEN ONE POINT FALLS PLO 40

C ON THE SAME POSITION A TALLY IS KEPT AND THE NUMBER IS PRINTED. PLO 50

C THE USER MAY PROVIDE THE BOUNDS ON THE X,Y COORDINATES. PLO 60

C IF BOUNDS ARE PROVIDED , THEY MUST APPEAR IN PAIRS AS READ NOS . IF APLO 70

C PAIR OF REAL NOS ARE EQUAL THE PROGRAM ASSUMES THERE ARE NO BOUNDSPLO 80

C COMMANDS FOR USING THIS PLOT ARE AS FOLLOWS PLO 90

C FOR THE AXIS THAT PAIR REPRESENTS AND THE BOUNDS WILL BE CALCULAT-PLO 100

C ED. PLO 110

C COMMANDS FOR USING PLOT ARE AS FOLLOWS PLO 120

C I PLOT Y +++,+++,

C II PLOT Y +++,+++,

C III PLOT Y +++,+++,

C IV PLOT Y +++,+++,

C V PLOT Y +++,+++,

X +++ PLO 130

. , (YMIN ,YMAX ) X +++ (XMIN,XMAX) PLO 140

. , (YMIN , YMAX ) X ++1 PLO 150

. v +++ (XMIN,XMAX) PLO 160

. X (XMIN,XMAX) (YMIN , YMAX ) PLO 170

C PLO 180

C ERRORS PLO 190

C I WHEN TYPE II COMMAND IS USED THERE MUST BE TWO PAIRS OF REAL PLO 200

C NOS. OTHERWISE THE FOLLOWING MESSAGE IS PRINTED PLO 210

C ' Y BOUNDS ARE NOT SET UP CORRECTLY' PLO 220

C I IF BOUNDS ARE PROVIDED, THEN THERE MUST BE FOUR REAL NOS. PLO 230

C II IF A SINGLE REAL NO. APPEARS AHEAD OF COLUMN NOS., THE FOLLOW-PLO 240

C ING MESSAGE WILL BE PRINTED AND NO PLOTTING WILL TAKE PLACE PLO 250

C ' Y BOUNDS ARE NOT SET UP CORRECTLY' PLO 260

C III IF A PLOT COMMAND ENDS WITH ONE REAL NO, THE FOLLOWING MESSAGEPLO 270

C WILL BE PRINTED AND PLOTTING WILL BE TERMINATED PLO 280

C ' X BOUNDS ARE NOT SET UP CORRECTLY' PLO 290

C IV IF MORE THEN 5 PLOTS ARE REQUESTED PER GRAPH, NO GRAPH WILL BEPLO 300

C PRODUCED AND FOLLOWING MESSAGE WILL BE PRINTED. PLO 310

C ' MORE THEN 5 PLOTS WERE REQUISTED PER GRAPH' PLO 320

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG PLO 330

COMMON /BLOCRC/ NRC , RC ( 12600 ) PLO 340

COMMON /BLOCKD / I ARGS ( 100 ), KIND ( 100 )

, ARGTAB ( 100 ), NRMAX , NROW, NCOL , NPLO 350

1ARGS ,VWXYZ (8 ) ,NERROR PLO 360

DIMENSION ARGS(IOO) PLO 370

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )) PLO 380

COMMON /SCRAT/ NS , NS2 , A ( 13500 ) PLO 390

COMMON /HEADER/ NOCARD (80 ), ITLE (60 , 6) , LNCT , I PR I NT ,NPAGE , I PUNCH PLO 400

COMMON /FMAT / IFMTX (6 ), IOSWT , IFMTS (6) , LHEAD (96) PLO 410

DIMENSION TIT(60), TITX(60) PLO 420

EQUIVALENCE (TIT , ITLE ( 1 , 6 ) ) , (TITX , ITLE ( 1 , 5 )

) PLO 430

DIMENSION X(l), KCCL(6), PRINT(lOl), XP(6), B00L(5), IDGT(9) PLO 440

EQUIVALENCE (RC ( 1 ), X (1 ) ) , (PRINT, A) PLO 450

INTEGER PRINT ,BLANK PLO 460

EQUIVALENCE (XO.XMIN), (X1,XMAX), (YO , YMIN) , (Yl , YMAX) PLO 470

DIMENSION IH(12,8), IPR(lOl) PLO 480

EQUIVALENCE (LHEAD, IH), (IPR,A(200)) PLO 490

INTEGER BOOL PLO 500

DATA BOOL(l) , BOOL (2) , BOOL (3) , BOOL (4) , BOOL (5 ) /1H . , 1H* , 1H+, 1H , , 1H-/ , PLO 510

1BLANK/1H / PLO 520

DATA IDGT(l) ,IDGT(2) ,IDGT(3) ,IDGT(4) ,IDGT(5) ,IDGT(6) , IDGT (7 )

, IDGT (PLO 530

18) ,IDGT(9)/1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HX/ PLO 540

C INITIAL SWITCHES PLO 550

DATA IXPR/1HX/ PLO 560

IF (NRMAX. GT.O) GO TO 10 PLO 570

CALL ERROR (9) PLO 580

RETURN PLO 590

238
10 I SWT=1 PLO 600

I SWT1=0 PLO 610

XUP=1 .E+35 ni A / a A PLO 620

X00WN=-1 . E+35 PLO 630

YUP=1 . E+35 n s A / a a PLO 640

YD0WN=-1 .E+35 PLO 650

NCN=0 PLO 660

IPT=100 PLO 670

IPTX=101 r> 1 A / a A PLO 680

i- /ii fcl r~ / \ A A T A A A IF (L2 . NE . 6 ) GO TO 20 n i a / a a PLO 690

IPT=60 A 1 A -7 A A PLO 700

IPTX=61 PLO 710

20 IF (NARGS.EQ.2) GO TO 50 A 1 A T A A PLO 720

IF (KIND (NARGS ) . EQ . 0 ) GO TO 40 A 1 A "7 1 A PLO 730

ir ^rvinu (nAnuj )-mhu ^hhuo— i ; MP n \ A f\ GO TO 680 A 1 A "/ A A PLO 740

c

yA npUrV v1 Rnnwn^ DUUnilj MrvC arp ppnuTnpn rKUV 1ULU PLO 750

IF (KIND (NARGS-2 ) .EQ.0) GOTO 30 PLO 760

IF (KIND (NARGS-3 ) .EQ.0) GO TO 680 PLO 770

ISWT=5 A 1 A » A A PLO 780

YUP=ARGS (NARGS) A 1 A T A A PLO 790

YD0WN=ARGS (NARGS-1

)

A 1 A AAA PLO 800

XUP=ARGS (NARGS-2) At A *~i t ft, PLO 810

XD0WN=ARGS (NARGS-3) A 1 A AAA PLO 820

NARGS=NARGS-4 A 1 A A *i A PLO 830

GO TO 50 A 1 A O A A PLO 840

Ac X BOUNDS ARE PROVIDED A 1 A a r A PLO 850

30 ISWT=3 A 1 A A / A PLO 860

XUP=ARGS (NARGS) A 1 A A A PLO 870

XD0WN=ARGS (NARGS-1) A 1 A AAA PLO 880

NARGS=NARGS-2 A 1 A AAA PLO 890

IF (NARGS.EQ.2) GO TO 50 A 1 A AAA PLO 900

c CHECK TO SEE IF THERE ARE Y BOUNDS A 1 A a t PLO 910

40 IF (KIND (NARGS-1 ) -KIND (NARGS-2) .NE. 0)

a A t A / T A GO TO 670 A 1 A AAA PLO 920

IF (KIND(NARGS-l) .EQ.0) GO TO 50 A 1 A A •> A PLO 930

c Y LIMITS ARE PROVIDED ni A A A A FLU 940

ISWT=ISWT+1 A 1 A A C A PLO 950

YUP=ARGS (NARGS-1) A 1 A A / A PLO 960

YDOWN=ARGS (NARGS-2) A 1 A A ^ A PLO 970

IARGS (NARGS-2 )=IARGS (NARGS) A 1 A AAA PLO 980

KIND(NARGS-2)=0 A II A AAA PLO 990

NARGS=NARGS-2 A 1 A 1 A A A PLO1000

50 DO 60 1=1, NARGS A 1 A 1 A 1 A PLO1010

60 KCCL(I)=IARGS(I) A 1 A 1 A A A PLO1020

M=NARGS-1 AH A "1 A O A PLO1030

IF (NARGS. GT. 6) GO TO 710 At A T A A A PL01040

CALL CHKCOL (J)

A 1 A 1 A (~ A PLO1050

IF (J.GT.O) GO TO 690 A 1 A T A / A PLO1060

c NO ERROR FOUND IN COLUMN NOS

.

A 1 A T A T A PLO1070

IF (NERROR.GE.l) RETURN A 1 A 1 A A A PLO1080

Ac SEARCH FOR MAX AND MIN ON AXIS, IF BOUNDS ARE hat nnAw t nrn NOT PROVIDED, r> 1 A 1 A A A PLO1090

Ac OTHERWISE TALLY NO OF POINTS THAT FALL OUTSIDE AC DAIIkinC Or BUUNUb D 1 A 1 1 A A r LU 1 1 OO

IF (XUP.GE.XDOWN) GO TO 70 A 1 A 1 1 1 A PLO1110

XAP=XD0WN A 1 A 1 1 A A PL01120

XAN=XUP A 1 A T 1 A PL01130

GO TO 80

A 1 A 1 1 A A PL01140

70 XAP=XUP A I At i c a PLUl 150

XAN=XD0WN A 1 A 1 1 / A PL01160

80 IF (YUP.GE.YDOWN) GO TO 90 PL01170

YAP=YD0WN PL01180

239
YAN=YUr

n 1 A i inn PL01190

PATA 1 AA bU IU 100 ni

A 1 AAA PLO1200

nA 90 win \y

MD YAr=YUr HI A)

T

A 1 A PL01210

vam vnnuiu YAIN=YUUriN 1 A 1 A

AA HLU1Z20

100 1/1 TADPC/AIADPCx Kl=lAKbb (NAKbb) ni i a i a

aa PL01230

I/O 1/1 1 . KID MAV K2=K1-1+NKMAX HI

A 1 A

AA PL01240

TC / TC U/T 0\ 11A 7 OA 1CA lr (loWI-Z) 110,710,150

n 1 A 1 ACA PLU1250 1 1 A 110 VI V / 1/ 1 \ A 1 =A (M ) n 1 A 1 A Z A PLU1260 V A VI X0=X 1 n 1 A 1 A T A PLU1270

nn i int i/i tfo

n i Anon HLU1280 ilrr /vi (XI . ccbt . vX / t \ \ rn to nn ( 1 ) ) bU IU 1Z0 n 1 A 1 A A A PLU1290

VIV / T\ X1 =X ( 1 )

ni

A 1 "5

AA PLU1300

pa Tft iia bU 1 U 13U

A 1 A 1 A 1 A PLU1310 1 0 A 1ZU T c (Vn 1 c Y / T \ \ PA Tf! 1 1 A lr ( AO . Lt . A ( 1 ) ) bU IU 130 d i ni iia HLU1320 V A V / T \ X0=X ( 1 ) O 1 A 1 1 1 A PLU1330 1 1 A 130 A A M T T Al 1 1 C

LUN 1 1 Nut

A 1 ATA ilA PL01340

140

VAD VI XAr=Xl

A 1 A 1 Ar

A PL01350

VAAN=AU A M V A

D 1 A 1 OL C\ f ft TH Mlrt O 7 A 1 £ A 1 7 A "> 7 A \ bU IU ( 17U ,

if 0 , 160 , 2/0 , Z70 ) , T

C UIT 1 on 1 A 1 A 1 A 7 A PLU1370 1 L A ioU l\t Y=Z A 1 A 1 1 Q A pn TA 1 O A bU IU 180 A 1 A 1 A A A PLU1390

170 1/

CV 1 Nh Y = l A 1 A 1 A

AA PL01400 1 Q A n a o£.n i i u UU £OU J = i , M • A 1 A 1 A 1 A r LU141U

M=lAKbO ( INAKbo ) A 1 A 1 A

AA

1/1T ADPC / I \ N3=l AKbo (J ) D 1 A 1 /l 3 A UK4=K3-1+NKMAX A 1/1 1 . MDMA V D 1 A A A A ic /i pt i\ pa Trt i on 1 r ( J . b 1 . 1 ) bU 1 U 190 A 1 A 1 A C A rLU1450

VIV / V 1 \

Y 1=X (K3 ) D 1 A

TALA

VA VI

Y U=Y 1 rLU1470

IS 1=1 Dl

A 1 VIOA 1 O A 190 PA TA / 1 A A O O A \ l/rv bU IU (200,220), KtY A 1 A 1 >l A A PLU1490 O A A nn 11 n t i/ i i/» UU ZJ.0 1=N3 , l\4 D 1 A 1 C A A r LU1500

TC /VI IT V/T\\ VI V/T\ lr (Yl.LI.X(l)) Y1=X(1)D 1 A 1 C 1 A KLU1510

TC /VA PT V/T\\ VA V/T\ lr (YO.bl.X(l)) Y0=X(1)D 1 fll C1A rLUlDZO

<: 1 0 r amt

t aji ic di ni ciA rLUi.D3U

p/l ta i/n bU IU 260D i ni c/n r LU1540

liv DO 250 I=K3,K4

D I (11 CCA rLUlbDO

IF (X(K1) .GE.XAN.AND.X(Kl) .LE.XAP) GO TO (230,240), KY

D 1 A 1 CLA KLU1560

GO TO 250

D 1 A 1 C 7 A rLUlb 7 0

230 Y1=X(I) di

a 1 CQ

A

Y0=X(I)

D 1 ftl cflrt rLU1590

KY=2

D 1 A 1 LAA HLU1600

GO TO 250 DI (IKlfl r LU1 0 IU 1 il A 240 IF (Yl.LT.X(I)) Y1=X(I) di m iin

IF (YO.GT.X(I)) Y0=X(I) DIrLU103U di tin

250 K1=K1+1

D 1 A 1 LAA

r LU1640

260 CONTINUE

D 1 (11 / CA HLU1650

YAP=Y1

D 1 (11 ii

A PLUlobO

YAN=Y0

D 1 n 1 L 7 A

IF (ISWT.EQ.l) GO TO 800 di ai ton

GO TO 280 Dim AO

n

r LU107U

270 Y1=YUP

D 1 A 1 7 AA rLUl/00

Y0=YD0WN

D 1 A 1 7 1 A KLU1710

ISWT1=1

D 1 A 1 7 OA rLUl 7 i\i

IF (ISWT.EQ.2) GO TO 770

D 1 A 1 7 1 A HLU1730

280 X1=XUP

D 1 A 1 7 AA KLU1740

X0=XD0WN

D 1 A 1 7 CA HLU1750

GO TO 770

D 1 A 1 7 LA KLU1760

C DETERMINE

X ANDY INCREMENTS FOR PLOT PL01770

240
290 YDELTA= (YMAX-YMIN ) /50

.

PL01780

K1=IARGS (NARGS) PL01790

XDELTA=(XMAX-XMIN) /FLOAT (IPT) PL01800

YL=YMAX-YDELTA/2

.

PL01810

YT=YMAX PL01820

IF (ISWT.LE.l) GO TO 820 PL01830

IF (L2.EQ.6) GO TO 300 PL01840

WRITE (IPRINT,1050) NTOT ,NCN PL01850

GO TO 820 PL01860

300 WRITE (IPRINT,940) NTOT ,NCN PL01870

GO TO 820 PL01880

310 KYTL=1 PL01890

IF (YMAX.LT.YMIN) KYTL=2 PL01900

KXTL=1 PL01910

IF (XMAX.LT.XMIN) KXTL=2 PL01920

ITB=1 PL01930

C THE I LOOP CONTROLS THE 5 DIVISIONS OF THE Y ORDINATE PL01940

DO 620 1=1,6 PL01950

L=l PL01960

C THE J LOOP IS FOR EACH LINE OF PRINT WITHIN THE DIVISIONS PL01970

DO 620 J=l,10 PL01980

C BLANK OUT PRINT BUFFER LINE. PL01990

DO 320 K=1,IPTX PL02000

320 PRINT (K)=BLANK PL02010

C THE KK INDEX IS FOR EACH CURVE. KK LESS THAN 6. PL02020

DO 500 KK=1,M PL02030

K3=IARGS (KK) PL02040

K4=K3-1+NRMAX PL02050

K5=K1 PL02060

C THIS DETERMINES IF Y(K) VALUE IS ON THE PRESENT PRINT LINE PL02070

DO 490 K=K3,K4 PL02080

GO TO (330,350) , KYTL PL02090

330 IF (X(K)-YT) 340,340,490 PL02100

340 IF (X(K)-YL) 490,490,370 PL02110

350 IF (X(K)-YL) 360,360,490 PL02120

360 IF (X(K)-YT) 490,490,370 PL02130

C YES. Y(K) BELONGS ON THIS PRINT LINE PL02140

C THEREFORE DETERMIND WHERE ALL THE X(K5) FALL ON THE X-AXIS PL02150

370 XL=XMIN PL02160

XT=XMIN+XDELTA/2. PL02170

DO 480 KA=1,IPTX PL02180

GO TO (400,380) , KXTL PL02190

380 IF (X(K5)-XT) 470,470,390 PL02200

390 IF (X(K5)-XL) 420,420,470 PL02210

400 IF (X(K5)-XL) 470,410,410 PL02220

410 IF (X(K5)-XT) 420,470,470 PL02230

420 IF (PRINT (KA) -BLANK) 440,430,440 PL02240

430 PRINT (KA)=BOOL (KK) PL02250

GO TO 490 PL02260

C IF MORE THEN ONE POINT FALLS ON THE PRINT POSITION, TALLY THE NO. PL02270

C OF POINTS. PL02280

440 DO 450 KKK=1,9 PL02290

IF (PRINT (KA)-IDGT (KKK) ) 450,460,450 PL02300

450 CONTINUE PL02310

PRINT(KA)=IDGT(1) PL02320

GO TO 490 PL02330

460 IF (PRINT(KA) .NE.IDGT(9)) PRINT (KA) = IDGT (KKK+1) PL02340

GO TO 490 PL02350

470 XL=XT PL02360

241
/! 0 ft VT_YT . vnCI TA A 1 =A 1 +AUCL 1 A

D 1 ft O 1 7 A

Y\-XiL5 1 0

^QA K3=K3+i di no 7

0

a rLU^ JoO

3UU rnMT T Ml IP D 1 n 0 "2 Q A r LUt J7O

VD—VT*VI p 1 n 0 a ft ft r LUZ'JUO

VT—VI 1 1 =1 Lpi n 0 a i ft r LUZh 1

0

VI —VI VRPI TA pi n 0 a 0 ft rLU^HZO

fin to /ei n ccn\ 1 di no ^ 7 ft r LUZ4 i 0

ci n D1U tp / t c \ con con A^n PI no A A ft

J c u 1 —

?

PI n?4c.ft

V^— I J=lVTj.YnPI 1+TUtLIH/i TA 10

.

pi n 0 A A ft r LUtf OU

u TUTC. Inlo PATH rHIn TC1 j FYFPIITFn, CALOUItU nWTF UHLt TWIN FV/FPV tvtKY nTVTCTnM U1V1 31UN OFUr TUP 1 tit VY—MAI AYTCJ . FUFDV tVtKT D 1 ft 0 /! 7 ft r LUZ4 /

0

u TFNTH 1 t Ii 1 n 1L TNF l vt C , C.TARTTNfi j 1 Ai\ 1 INu WITH nl In 7FR0, L t !\ U 1L TNF 1 1 x C DIrLUtHOU nOAflft

TFir M 0 pn A\ fin TO C7ft ( l i . cy .

0

) uu 1 u j /

u

pi no/ion

TF (YP\ l^ft C^n 14(1 pir LUnoL3UU enn

c. n UIRTTF ni\ 1 1 t MPRTNT (lrKlNI,70UJ QAft\ TIT/TTRl VC PRTNT 111(1101,13 ,rnin 1 di no c i n r LU 4 D 1

U

fin TO A9ft pi no c 0

n

r LUt 3 1

U

UIRTTF ni\ 1 1 1 MPRTWT (lrKini ,73U) Q eft \ TTT/ITRl iii^iDj VC PRTWT ( io ( ri\irii di n 0 c 1 ft

rift TO AOft di no c/in

J jU TF1 r

li

( L 0L . Ffi t w, . A\0

fin TH con J UU IU J ;U dirLUt33U no ccn

TFlr /VP\ CAft CAft Alft ( I r ) 30U , DOU , 01U DI no c. Aft r LUtDOU

r

w PRr K 1

T NT*; N 1 3 1LlliC TNF pi no E.7

n

r LU L 3 /

U

1; Aft UIRTTF hk i 1 1 MPRTNT irKiNi,7/uj Q7ft\ TTT/TTR\ 111 (iiDj ,rninii PRTWT pi n 0 c

0

a

fin uu TO1 u A0ft 0 i. u rLUi37U pi no con 570 TFiYP ir^ir.uifiT .u.uj fi COuu TOiu jou ^Rft pi n?Ann

WRTTF MPRTNT QQft \ TIT/TTR\ V< /PRTNT/IO K — T T PTY

\

nl\l 1 L (irnini , "BU) 1 1 1 \ 1 1 D ) , I 3 , \ r n 1 l» 1 l\ ) , r\=l , IrlAJ pi no A T ft

Cfl uu TO1 u A?fl 0 *.

u

pi n? a? n

CRft UIRTTF Kilt (TPRTWT OQft\ TTTMTBl VC /DR1WT \ TPTY\ ( 1 rl\lN 1 , 77U J I1I(1ID),!3, (rl\iw 1 , l\=i , lr 1 A] pi no a 7 ft

fit) UU Tft A5ft 1 U 0 £ u

pi no A/in r LUtOHU

K,>3),n TP/VP ir^ir.ui.u.uj fiT n n\ fin uu toiu ouu Ann pir lun?Acn cOju

UIRTTF nrvllll iTPRTNT lnnni TTTiTTR\ !PRTNT^K^ k — T T PTY ^

( lrRlll 1 , 1UUU ) lll^llDJ^rnini^j, l\= 1 , lr 1 A] pi n 0 a Aft

fin UU TnIU A?n 0 L U pi|LU£Q n?A7n1 U

Aftft ouu UIRTTF WR1 1 t /TPRTWT (IrnlNI 1 ftl ft \ TITMTRi /PRTWT/I^\ Y — 1 TPTY\ ,1U1UJ 111 >llDj , ^rl\lWI V">- / / i^ =-L , lr 1 A) pi noASft

cnUU Tn1 U Aon OC\J PIr lunoAQft c 0 7 u

A 1 ft UIRTTF i\i 1 1 MPRTNT iirr\iroi,iU£U/ lftoftx TTTMTR\ iii(iiu),ri\iiii PRTNT PInutn97ftft / uu

T1 TR— 1 D— TTRj.1 1 1 Dtl pi n?7T n tflr n(Li.Ly.o; 0 pn a\ r;n UU TnIU am7lU pir LUi/ no7on£ U TFlr tVP\ (Ir AAft AAft A^ft ] OHU , 01U , 03U pi fi?7 , rLUt / j\J ?n

UIPTTF nr\ lit MPRTWT (IrKlNI ,70U) QAft\ Tll'l\31/ T T / C 1 \ VMTW PRTWT f TMlH ( rKlNI pi no 7/ift r LUi 1 HU

fin UU Tfl AAft 1 U OOU pir LU£n57cn t 3U

UIRTTF nl\ 1IC /TPRTWT ocn\ TTTici \ VMTW PRTWT ( 1 rl\ 1 n 1 , 73U ) 1 1 1 \ 3

1

) , T IH1N , rn in 1 PIr luln?7Aft / ou

U 1 A^T 1 TNF nF PRTNT fit IT PI IK Y V/AI IIF<; Al nNfi Y. AY! 5 LAj ;

1 Llriu Ur rffxlli! UUI rLUj A VHLUtJ MLUI»U A-nAi J . pirLUti 00770/

U

AOOUAft UIRTTF Wr\ 1IC /TPRTNT ( 1 r Kill 1 IftAftl TPR , 1UCU j IrK pirLUtn?7Rn / OU

UIRTTF BK 1IL /TPRTWT ( IrK in i lftim YP , l\i JV ) Ar pir lun?79n c

1

7 u UfDTTP /TPDTMT 1ft7ft\ TTTY WK lit ( 1 rKin 1 , IU / U ) 1 1 1 A

PIr LUYOUU OORftft

DPTIIRW Kt 1 UKIM pi nop. i

n

rLUtoiu

L> Till C PRTWTC nilT TUAT 'V RftllWnC ARF WflT CFT IIP mRRFfTI V' Inlo rKllMlo UUI 1 HA 1 T DUUNUj AKt NU 1 3t 1 Ur uUKKtuILT pi n?ft?ft

0 / U PftWT T Ml IP uUN 1 1 Nut pir LUin?R^n 0 J U pO TUTC DOTMTC nilT TUAT ' Y RHIIWRC ARF Wf\T CFT IIP mPRFfTI V' IHli rKlSMIo UUI 1 HA 1 a DUUIMUj AKt NU 1 Dtl Ur UUKKtu 1 L T pi n?fldn

/OA 00U rt\ WT T Ml IP tUN 1 1 NUt pir LUinoRcn 0 3 u TUTQ PRTNT Tfll WnQ APPPAR A^ ARfillMFNT^

1 nl j rKin 1 uul. NU3 . ArrtMK mo mkuu wst n i j pi n?RAn

Aon rOALL A 1 1 PRPftR tKKUK / 0 ft \ pi n?R7n

7 A ft / 00 MPPPftD NtKKUK=NMPOOftD tKKUK— 1

1

pir LUin? RRO 0 ou

DCTI IDM Kt 1 UKN pir LUin?Ron 0 7 U L TUTC DOTMTC TUAT 'UftDF TUPM C PI ftTC IMF DP DFftllTCTPn PFR COADU ' Inib rKlNIb 1 HA 1 MUKt 1 HtN 3 rLUlo WtKt KtyUlo 1 tu rtK uKArH pir LUinoonn 7UU

7 1 A 710 LALL tKKUK (10) pi nooi

n

r LUi 7 xu

Aft Tft 7 A ft bU 1 U / 00 PIr lun?Q7f) c 7

c

u

7 0ft /iO Kt 1=1 PI n?Q3ft

DO 760 IK=1 ( M PL02940

IKK=IARGS(IK) PL02950

242
730

740

750

760

770

780

790

C

800

810

820

830

840

850

860

870

880

890

DO 750 I=K1,K2

IF (X(IKK) .GE.YAN.AND.X(IKK) .LE.YAP) GO TO (730,740), KEY

GO TO 750

X1=X(I)

X0=X1

KEY=2

GO TO 750

IF (Xl.LT.X(I)) X1=X(I)

IF (XO.GT.X(I)) XO=X(I)

IKK=IKK+1

CONTINUE

IF (KEY.EQ.2) GO TO 140

XO=XDOWN

X1=XUP

GO TO 140

DO 790 J=1,M

K1=IARGS (NARGS

)

K3=IARGS(J)

K4=K3-1+NRMAX

DO 790 I=K3,K4

IF (X(I) .GT.YAP.OR.X(I) .LT.YAN) GO TO 780

IF (X(K1) .LE.XAP.AND.X(Kl) .GE.XAN) GO TO 790

NCN=NCN+1

K1=K1+1

NTOT=M*NRMAX-NCN

DETERMINE TYPE OF HEADINGS TO BE PRINTED

CALL HEADS (KCCL , NARGS , 0 , 1

)

K=4

IF (L2.EQ.6) K=l

CALL PAGE (K)

IF (L2.EQ.6) GO TO 810

WRITE (IPRINT.1040) ( IH ( I , NARGS )

, 1=1 , 12 ) , (( IH ( I , J ), 1=1 , 12

L,J=1,M)

GO TO 290

WRITE (IPRINT,1080) ( IH ( I , NARGS )

, 1=1 , 12 ) , (( IH ( I , J ), 1=1 , 12

;

L,J=1,M)

GO TO 290

XP(1)=XMIN

XP(6)=XMAX

XR=20.*XDELTA

DO 830 1=2,5

XP(I)=XP(I-1)+XR

DO 840 J=l,100

IPR(J)=B00L(5)

DO 850 1=1,101,10

IPR(I)=B00L(3)

IF (XMIN*XMAX.GE.0.0) GO TO 900

J=0

DO 860 1=2,5

IF (XP(I-1)*XP(I)) 870,890,860

CONTINUE

N=IPTX

GO TO 890

XXP=XP(I-1)+XDELTA

DO 880 J=l,20

IF (XP(I-1)*XXP.LE.0.0) GO TO 890

XXP=XXP+XDELTA

J=20

N=(I-2)*20+J

PL02960

PL02970

PL02980

PL02990

PL03000

PL03010

PL03020

PL03030

PL03040

PL03050

PL03060

PL03070

PL03080

PL03090

PL03100

PL03110

PL03120

PL03130

PL03140

PL03150

PL03160

PL03170

PL03180

PL03190

PL03200

PL03210

PL03220

PL03230

PL03240

PL03250

PL03260

,B00L(J)PL03270

PL03280

PL03290

,B00L(J)PL03300

PL03310

PL03320

PL03330

PL03340

PL03350

PL03360

PL03370

PL03380

PL03390

PL03400

PL03410

PL03420

PL03430

PL03440

PL03450

PL03460

PL03470

PL03480

PL03490

PL03500

PL03510

PL03520

PL03530

PL03540

243
T DP ^ M \ — T YDD D 1 n i c c a AAA 900 UfDTTP ( IDD I MT 1A£A\ i10DlV\ V 1 T DTY \ WKJ.lt ( IrKIN 1 , lUOU ) ( 1 rK (K ) , N=l , lr 1 A) d

i

Aac/n PLU3560

r n Tft ji n d i nacirt rLUiD/O

7lU iriir.ul ,U,U) bU 1 U 7 <: U D i nicon

UID WKiiL TTC / IDDIkIT O Q A \ TIT (CI \ VMTKI / DD T KIT f IM (lrl\lNI,9ol)) lll(3l),YMlN,(rKlNI(K) V 1 T DTY

\

r LU3590

rnbU Tn q in 1 U 7 i U D 1 n i l a a r LUioOO

UIPTTF WKl It MPD1MT (IrKlQ 1 QQO\ TIT/R1 \ VMTM /DDIWT(k\ ( 77U J

1 1 1 ,YIVIlPf, \ tf — l T DTY

\

, 1^=1 , 1 r 1 A ) d i niiin rLKJi oil)

U/RTTF (IDDTMT 10AO\ lfDQ(W\ V 1 T DTY \ d i n i l o a, U/DTTF nt\ / IOPTMT i nin\ tYD lit \ V 1 AN 1 I t ^ 1 r K i IM I , 1 U.5 U ) ^ Ar ^ Fk ; , 1^=1 , 1

)

d i n "x l i a U/DTTF nrv 1 I C

<^ IDRIMT i r K 1 N I 10QO\ TTTY , 1U7U ) I1IA r LU.J 041)

DFTIIDM Kt 1 UKIM r HJ3650

d i c\ 1 L L A rLUiooO

Q AO. FORMAT (21H NO. OF PTS . PLOTTED ,15 ,33H NO. NOT PLOTTED IUUI Ur DUrLUJO/U

1UNDS) ,15) d i ni£.Qn ncn 7jU FORMAT (1X,A1,1PE11.4,1H+,101A1,1H+) D 1 (\ 1 L Q A rLU^07U

O L A 701) FORMAT (1X,A1,1PE11.4,1HX,101A1,1HX) D l n "2 7 A A rLL)3 7 00

7 / U FORMAT (1X,A1,11X,1HX,101A1,1HX) d i n 7 7 1 a ngn 70U FORMAT (IX, Al, 1PE11 .4, 1HX.61A1 ,1HX) D 1 n "3 7 ^ A nnn 77U FORMAT (1X,A1,1PE11 .4,1H+,61A1 ,1H+) D 1 H 1 7 1 A

i u u u FORMAT (1X,A1,11X,1HX,61A1,1HX) D 1 n *3 7 ^ A

YV.\)i / 41)

i ni n 1 U 1 u FORMAT (1X,A1,11X,1H-,61A1,1H-) rL\)i I Dl)

1 111 "1 ft i U si u FORMAT (1X,A1,11X,1H-,101A1,1H-) d i n *a 7 z. a rLU3 / 60

i n?n FORMAT (6(7X,1PE13.4) ) D I n 7 7 7 A rLU^ / /

U

1 OAfi J.U'HI FORMAT (6H ABS- , 12A1 , 6H , ORD- ,5(12A1,2H (,A1,3H), )) d i ni7on rLU^ / oU

i1UDU nco FORMAT (29H TOTAL NO. OF PTS. PLOTTED IS, I5,60H AND NO. WDT nu Di nTTFDl ni7on I rLU 1 ICrLUi/7U

ID BECAUSE THEY FALL OUTSIDE OF BOUNDS IS, 15) D 1 n 7 Q A A

i nin FORMAT (14X,101A1) D 1 n 1 0 i a r LU Jo J.U

1 0,70, FORMAT (34X,60A1) r Lu J 0 c

U

'tf Iff p fii FORMAT (6H ABS- ,12A1/6H ORD- ,5(12A1,2H (,A1,3H), )) d 1 n 1 0 1 a

1 A A A 1090 FORMAT (14X,60A1) PLU3840

END PL03850

244
c

cc

cc

cc

cc

c

c

c

c

c

c

cc

c

c

c

cc

SUBROUTINE PREPAK (N , IND , IA , LOC , LH)

VERSION 5.00 PREPAK 5/15/70

C

cc

cc

c

c

c

c

c

c

c

c

c

c

c

c

c

c

c

c

c

c

c

c

c

s THIS

N=l

N=2

N=3

N=4

N=5

IND

PEAVY 8/ 5/69

SUBROUTINE DOES THE FOLLOWING

PACK FORMAT IN IFMT

PACK HEAD IN IHEAD. IF MORE THAN 50 HEADINGS ARE STORED,

STACK OF HEADINGS IS PUSHED DOWN AND BOTTOM ONES

DISCARDED

CLEAR VARIABLES IFMT AND IHEAD

PICK UP PROPER FORMAT NO. IN IA AND STORE IN LH

UNPACKS THE HEADING OF LOC. INTO LH IA Al LEFT JUSTIFIED

INDICATOR. IF IND =0 CALL TO PREPAK WAS O.K.

IF IND =1 A FLAG THAT RESULTS WERE NOT OBTAINED

PRE

PRE

PRE

PRE

PRE

PRE

PRE

PRE

PRE

10

20

30

40

50

60

70

80

90

IA COL NUMBER FOR THE HEADING TO BE PACKED OR FORMAT DESIRED

LOC LOC CONTAINS THE COLUMN NUMBER WHOSE HEADING THE SUBROUTINE

IS TRYING TO FIND.

LH IS WHERE THE HEADING WILL BE STORED AS Al LEFT JUSTIFIED

AFTER IT IS UNPACKED, IF THE TITLE IS FOUND.

OR

WHERE FORMAT WILL BE STORED IF N=4

COMMON /ABCDEF/ L(48)

COMMON /BLOCKA/ MODE , M, KARD (83 )

, KARG , ARG , ARG2 , NEWCD (80 )

, KRDEND

COMMON /PKSWT/ IHCNT,IHTP

COMMON /BLOCKC/ KIO , INUNIT , ISCRAT , KBDOUT , KRDKNT , LLI ST

COMMON /SCRAT/ NS ,NS2 , A (13500

)

DIMENSION IAA(80)

EQUIVALENCE (A , I AA)

DIMENSION LH(1)

PRE 100

PRE 110

PRE 120

PRE 130

PRE 140

PRE 150

PRE 160

PRE 170

PRE 180

PRE 190

PRE 200

PRE 210

PRE 220

PRE 230

PRE 240

PRE 250

PRE 260

PRE 270

PRE 280

PRE 290

PRE 300

PRE 310

PRE 330

THE VARIABLE IFMT CONTAINS THE INFORMATION FOR 6 FORMATS PRE 340

(I E. FORMAT A THUR F) . THE MAXIMUM LENGTH FOR EACH FORMAT IS PRE 350

72 CHARACTERS INCLUDING LEFT AND RIGHT PARENTASIS . IF FORMATS ARE PRE 360

PACKED DIFFERENTLY THEN STATED BELOW , THE DIMENSION SIZE OF PRE 370

THE FIRST (12) CONSTANT MUST BE CHANGED TO BE EQUAL OR GREATER PRE 380

THAN 72/ (NO. OF CHARACTERS PER WORD)+M. SEE NOTE BELOW FOR M VALUEPRE 390

CAUTION : FORMATS MUST BE PACKED IF NH CONVERSION IS PERMITTED PRE 400

PRE 410

PRE 420

PRE 430

PRE 440

PRE 450

PRE 460

I FMT ( 1 1 , 6 ), I HEAD ( 5 , LA ARE REDIMENSIONED SO THAT PRE 470

THE VARIABLE IHEAD (5, LA) CONTAINS THE HEADINGS FOR LA COLUMNS

MAXIMUN NO. OF CHARACTERS PER HEADING IS 12.

DIMENSION IFMT(12,6), IHEAD(5,50)

IF THE VARIABLES

II DOES NOT = 12

AND LA DOES NOT = 50

THEN THE FOLLOWING DATA STATEMENT MUST BE CHANGED

DATA 11/12/, LA/50/

PRE 480

PRE 490

PRE 500

PRE 510

PRE 520

PRE 530

FORMAT 90 MUST BE CHANGED IF MORE OR FEWER CHARACTERS CAN BE PRE 540

PACKED INTO A WORD. 90 FORMAT (IIAK) WHERE II IS DEFINED ABOVE ANDPRE 550

K =12/ (CHARACTERS PER WORD)+M. PRE 560

WHERE M=0 IF 12/ (NO. OF CHAR/WORD) HAS NO REMAINDER PRE 570

AND M=l IF 12/ (NO. OF CHAR/WORD) HAD A REMAINDER PRE 580 ************************************************************* £<JQ

245
STORES FORMAT

IF (N.GT.5) GO TO 60

INO=0

GO TO (10,70,150,180,200) , N C THIS PART OF PROGRAM PACKS AND

10 K=KARD (M)

15 M=M+1

IF (KARD(M) .NE.41) IF (KARD (M) -46 ) 15,60,15

KK=1

KA=0

MA=M+1

KR=KRDEND+3

DO 20 I=MA ,KR

IF (KARD (I) .EQ.41) KK=KK+1

IF (KARD ( I ) .NE.42) GO TO 20

KA=KA+1

IF (KA.EQ.KK) GO TO 30

20 CONTINUE

GO TO 60

30 MB=M-2

IM=I-M+1

DO 40 JA=1,80

40 IAA(JA)=L(45)

DO 50 JA=1,IM

IAA(JA)=NEWCD(MB)

50 MB=MB+1

WRITE (ISCRAT,240)

BACKSPACE ISCRAT

READ (ISCRAT, 230)

BACKSPACE ISCRAT

RETURN

60 IND=IND+1

RETURN

C THIS PACKS HEADS

70 IF (IHCNT.GE.IHTP) GO TO 140

IF (IHCNT.EQ.O) GO TO 110

C IHEAD(1,I)=C0L NUMBER FOR THAT HEADING

DO 80 I=1,IHCNT

IF (IA.EQ.IHEAD(1,I) ) GO TO 130

80 CONTINUE

KB=IHCNT

90 DO 100 I=1,KB

KA=KB-I+2

DO 100 K=l,5

100 I HEAD (K,KA) = IHEAD (K ,KA-1

)

110 IHCNT=IHCNT+1

120 IHEAD(1,1)=IA

ICHAR=12

DO 122 1=2,5

C THE FOLLOWING CONSTANT IS (45*256+45 ) *256+45

122 IHEAD (I ,1)=2960685

IF(M+12 .GT.KRDEND+3) ICHAR=KRDEND+2-M

CALL PACK (KARD (M+l )

, IHEAD (2 , 1 )

, I CHAR ,0

)

RETURN

130 IF (I.EQ.l) GO TO 120

KB=I-1

(IAA(JA) ,JA=1,80)

(IFMT(JA,K-9) ,JA=1,II)

140

GO TO 90

KB=IHTP-1

CALL ERROR

GO TO 90

(229)

PRE 600

PRE 610

PRE 620

PRE 630

PRE 640

PRE 650

PRE 655

PRE 660

PRE 670

PRE 680

PRE 690

PRE 700

PRE 710

PRE 720

PRE 730

PRE 740

PRE 750

PRE 760

PRE 770

PRE 780

PRE 790

PRE 800

PRE 810

PRE 820

PRE 830

PRE 840

PRE 850

PRE 860

PRE 870

PRE 880

PRE 890

PRE 900

PRE 910

PRE 920

PRE 930

PRE 940

PRE 950

PRE 960

PRE 970

PRE 980

PRE 990

PRE1000

PRE1010

PRE1020

PRE1030

PRE1040

PRE1042

PRE1044

PRE1046

PRE1050

PRE1052

PRE1054

PRE1060

PRE1070

PRE1080

PRE1090

PRE1100

PRE1105

PRE1110

246
c N=3 CLEAR IFMT , IHEAO PRE1120

150 DO 160 1=1,6 PRE1130

DO 160 I A=l , 1

1

PRE1140

160 IFMT(IA,I)=0 PRE1150

DO 170 1=1, LA PRE1160

DO 170 IA=1,5 PRE1170

170 IHEAO (IA , I )=0 PRE1180

RETURN PRE1190

C FIND PROPER FORMAT PRE1200

180 IF (IA.LT.2.0R.IA.GT.7) GO TO 60 PRE1210

IF (IFMT(1,IA-1) .EQ.O) GO TO 60 PRE1220

DO 190 1=1,11 PRE1230

190 LH(I)=IFMT(I ,IA-1) PRE1240

RETURN PRE1250

C SEARCH FOR HEADING AND UNPACK PRE1260

C IF HEADING IS FOUND IND=0, OTHERWISE 1. PRE1270

200 DO 210 I=1,IHCNT PRE1280

IF (L0C.EQ.IHEAD(1,I) ) GO TO 220 PRE1290

210 CONTINUE PRE1300

C NO HEADING FOUND PRE1310

GO TO 60 PRE1320

220 CALL PACK (IHEAD(2,I) ,LH,12,1) PRE1330

RETURN PRE1340

C PRE1350

230 FORMAT (12A6) PRE1360

240 FORMAT (80A1) PRE1370

END PRE1380

247
c

c

c

c

c

c

c

c

c

10

20

30

40

45

50

60

70

80

90

100

110

120

130

SUBROUTINE PRINTX PRI 10

VERSION 5.00 PRINTX 5/15/70 PRI 20

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG PRI 30

COMMON /BLOCRC/ NRC , RC ( 12600 ) PRI 40

COMMON /BLOCKD / IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NPRI 50

1ARGS ,VWXYZ (8 ) ,NERROR PRI 60

DIMENSION ARGS(IOO) PRI 70

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 )

) PRI 80

COMMON /HEADER/ NOCARD (80) , ITLE (60 , 6 )

, LNCNT , I PR I NT ,NPAGE , I PUNCH PRI 90

COMMON /FMAT / IFMTX (6) , IOSWT , IFMTS (6) ,LHEAD (96)

COMMON /KFMT / KFMT(IOO)

THIS SUBROUTINE IS CALLED TO EXECUTE THE FOLLOWING

PRINT // COLS ++,++, ++,++ ( ETC (PRINT WITH FORMAT//)

PRINT COLS ++,++,++,++ USE RPRINT IF ALL ARGS ARE

UNLESS IOSWT IS ON

PRINT (USING ARGS AS IN RPRINT) ALWAYS USE RPRINT

Ll=2 PRINT

Ll=8 NPRINT

IF (NARGS.NE.O) GO TO 45

CALL ERR0R(205)

RETURN

CALL ERROR (222)

IF (NPAGE.EQ.O . AND . LI . EQ . 8 ) CALL PAGE(O)

CALL RPRINT

RETURN

IF (L2.EQ.1) IF (IOSWT) 40,40,230

CALL PREPAK (4 , IND ,L2 , IND ,KFMT)

IF (IND.NE.O) GO TO 30

IP=1

CALL CHKCOL (I)

IF (I.NE.O) GO TO 10

IF (NERROR . NE . 0 ) RETURN

IB=0

IA=1

ICP=0

GO TO (60,70) , IP

IB=NARGS

GO TO 100

IBB=NARGS

IF (IBB.GT.8) GO TO 90

IB=IBB+IB

IC=IBB

IBB=0

GO TO 100

IBB=IBB-8

IB=8+IB

IC=8

LL=NRMAX

IF (LL.GT.51) GO TO 120

J=LL

LL=0

GO TO 130

LL=LL-50

J=50

IF (L1.EQ.8) IF (NPAGE) 155,260,155

CALL PAGE (4)

GO TO (150,140) , IP

INTEGER

PRI 100

PRI 110

PRI 120

PRI 130

PRI 140

PRI 150

PRI 160

PRI 170

PRI 180

PRI 183

PRI 187

PRI 190

PRI 200

PRI 210

PRI 220

PRI 225

PRI 230

PRI 240

PRI 249

PRI 250

PRI 260

PRI 270

PRI 280

PRI 290

PRI 300

PRI 305

PRI 310

PRI 320

PRI 330

PRI 340

PRI 350

PRI 360

PRI 370

PRI 380

PRI 390

PRI 400

PRI 410

PRI 420

PRI 430

PRI 440

PRI 450

PRI 460

PRI 470

PRI 480

PRI 490

PRI 500

PRI 510

PRI 520

PRI 530

PRI 540

248
140 CALL HEADS (KFMT (IA) , IC , ICP ,0) PRI 550

150 WRITE (IPRINT ,250) PRI 560

155 DO 200 M=1,J PRI 570

DO 160 1=1 A , IB PRI 580

K=IARGS(I) PRI 590

IARGS ( I )=IARGS ( I ) +1 PRI 600

160 ARGS(I)=RC(K) PRI 610

GO TO (170,180) , IP PRI 620

170 WRITE (IPRINT, KFMT) ( ARGS ( I )

, 1=1 , NARGS ) PRI 630

GO TO 200 PRI 640

180 WRITE (IPRINT, IFMTX) (ARGS ( I )

, 1=1 A , IB ) PRI 650

190 IF (M0D(M,10) .EQ.O) WRITE (IPRINT, 250) PRI 660

200 CONTINUE PRI 670

ICP=1 PRI 680

IF (LL) 210,210,110 PRI 690

210 GO TO (20 ,220) , IP PRI 700

220 IF (IBB. EQ.O) GO TO 20 PRI 710

IF (L1.EQ.8) WRITE(IPRINT,250) PRI 713

IA=IB+1 PRI 715

ICP=0 PRI 720

GO TO 80 PRI 730

C USE STANDARD OR SPECIFIED FORMAT PRI 820

230 IP=2 PRI 830

DO 240 1=1, NARGS PRI 840

240 KFMT(I)=IARGS(I) PRI 850

GO TO 50 PRI 860

C PRI 870

250 FORMAT (IX) PRI 880

260 CALL PAGE (0) PRI 890

GO TO 155 PRI 900

END PRI 910

249
CIIDDAIITTMF bUBKUUIINt rKUB DDflR 1 \l M 1 1 1 \/ M 1 1 9 F A. \

( VNU 1 , ViMUZ , r , U ) DDD r KB i A IU

c V/CDCTAM C ftft nnAD C / 1 C / 7 A VtKilUN 5.00 rKUB 5/15/70 DDD r Kb O ft 20

nnimi c DDCPICinw rric Ikl rripnc rncvD rni AA UUUDLt rKtUlolUN r UM N , TMUUj , r Ut Ar , r ULUla DDD r KB i ft 3U

DOUBLE PRECISION C , A ,X , W,0NE ,B ,TA ,TB ,G PRB

DATA C/.6366197723675814D0/,EP/1 .E-5/ , 0NE/1 .DO/ ,TW0/2 .0/ ,0NEP/1 . /

, PRB C ft 50

IDC/ K / 1H5/ .5/ DDR L ft 60

Mill \/Mlll i CD INU i.=V INU 1+Lr DDR r KB i ft 7 0

llin w KM 1 O .CD l\IU£=VINU£+tr DDD r KB O ft o U

\l 1 Mill DDR r KB o ft V9—MI 19 PRR r i\d i nn

tr 1 ADC /All \/Mlll \ AT CD\ TO T A 9 ft ft lr ( ABb ( V 1-VNU 1 ) . la 1 .tr) laU IU tUU DDR r KB i l n 1 1

U

tc r adc ru? \/miio\ n f D \ r n to. inn lr v AD j ( V L—V NU £ ) . la 1 .tr) laU IU £\JU DDR r KB 1 9 ft tc i c \ c a in 1 r ( r ) 5 , o , I

U

DDR r KB i i ft 130

5 f n n r =U . U DDR r KD 14ft A PRRDR LKrXUK , <^FT P—fl ^TNPF F 1 FC^ THFN fi, / jl 1 r=U jlnOC r LLjj 1 null U/ PRR r rvD i cn

rCALL a i i fddmP tKKUK / o n (. ^ (^UO

)

DDR r KD 1 L ft 160

0 n i n U— i . u PRR r r\ d

1 L 9 RETURN PRB r l\U 1

i n TF f Mill 1 T ft OR Nil? IT ft i fifl Tfl 19ft PRB 1 7 n

9 n mm 1 1 1 _Mnn / Mm o \ WIPlUl=nnUU ^llUl , £ J PRR r r\ ui fin 1 o u

Willi MNII 9—MM) / Ml 19 91 U L=MUU ( NU £ , C ) PRR r r\D ion 1 9U

TFlr / MM ! 1 9 MF n\ fift Tft 7 fl

^ mix! Uc.nn.u) Va U IU IV PRR r t\D 9 nn

T 1 _Ml 17 / 9 1 PRR r r\D 9 T fl YA=Vi/ — //UiiUl*Cl vv^+vi r) PRR r i\D 9?fl

V H= V 1 / 1 ItU PRR r t\D 9 1 n £ J u

T A MM

1

1 H —liu 1 PRR r i\u 9 >1 ft

% ft A=UNt DDR r KD 9 k n

lrtf /Ti Fn fti fin Tn cn v 1 1 . Cy . V ) laU IU 3U PRR r r\u 9 ft

lit A PRR r i\D 9 7ft nn An t—i t

i

UU 4U 1=1 , 1

1

PRR r r\D 9 Q ft T—

T

1 = 1 PRR r rv D 9on £ 7 U

III- / /U4iT nMFD \ /T \ * Y*UI PRR r I\D 1 ft ft 3UU

A ft A_A , III PRR r i\D „»1 1I nu

C ft 5U 0—A*FrtFyp [V4*Frii or /onf y\ \ PRB 1 1 \ U % 9 n J t u TFlr 114 \ I H . FOLV( . NUT I1U1 i tt—HNFP 0 / U. —vll Lr —V< PRB

£ ft oU t F /n it n \ n—

n

i r ( y

.

l i . u . ; y=u PRB r r\D i An

tc i <\ n (Imcd \ a dmcd lr (y.bl .UNtr) y=UIMtr DDR r KB J5U

DFTI IDM Kt 1 UKN PRR r KD An

7 ft T C / MM 111 MC ft\ Pfl Tn Oft lr (MNUl.Nt.U) laU IU oU PRR r l\D a 7 a

T 1 Ml 1 1 / O 1 1 1=NU1

/

i-i PRR r r\D ^ no

VA=UNtr nMFD—U9//U0iUl*F\

v

c I

(

v z+v i r) PRR r i\d a q a

VI A ill J T VMA V4=VZ / 1 WU DPR r KD Ann

T /I Ml 19 PRR r rv D 11U a i n pa xrt -aft bU IU 30 PRR r r\D A9n

O ft 80 tc /hi no fcic i\ /*A TA laft IF (NU2.NE.1) GO IU 130 DPR r KD A^n

tc /Mm mf i \ rn Tn on lr (NUl.Nt.l) laU IU VU PRR A4(T

A A * AT AM / nMFD / FCnRT / F \ \ y=u a i api (urotr/royKi ^r)) PRB r i\d A<;n A A T A L ft (a0 IU 60 PRR r l\D t O U 90 X=ATAN (FSQRT ( V2 / (Vl'F) )

)

DDD rKD

1 1= (NU1-3 ) /2 DDR rKD Afln

1 5=1 DDR rKD 490 » 7 w

i ft ft 100 TB=FDSIN (X) DDD rKB

A=r a cnrnc ULU / y \ j ( A

)

PRB cm

IF (I1.EQ.0) GO TO 120 PRB C 9 ft 52U

TA=A**2 PRB CIA 5 JU

W=A PRB t; An

DO 110 1=1,11 PRB CCA 3 3 U V3=I PRB 560

W=V3/(V3+P5)*TA*W PRB 570

250
1 1 A 110 A A . IV A=A + W rKD DDR can DOU

120 A=L ( X+ 1 b A

)

DDR 07U

A A Q=A DDR Ann o U U rn to. /An i a n \ tq PPR r rvD ii n

O 1 u 130 A=A IAIN(r;>yKI^Vl r / V c ) ) DDR r kd a o n O £. U

T 1 /MM")

1 1= (NUZ-3 ) /

2

DDD r KB L 1 A 630

T C O

1 b=A DDR r Kb L A A 640

f (i t a inn bU 1 u 1UU DDR a c n

1 A ft 140 i c /win wc i \ rn m i en Ir ( NU 1 . Nt . 1 ) oU IU 13U DDR rKD AAA ooU

n. flMC A U.=UIML—

A

DDR rKD A 7 A

O / U rnbvj Tfi 1 An U 0 U DDR rKD ton ooU

i c ft 150 Tl /Mill 7 \ / 1

I 1= (NU1-3 ) / A DDR rKD L O A 690

R ftMC b=UINt DDR rKD 7 A A ic1 r /ti ( 1 i . ency . n\ rn Tfi 1 7n U ) bU IU 1 / U DDR rKD 7 1 A / 1 U

IUW=DR DDR rKD 7 0 n / A U

A A 1 Z ft T 1 Tl Uu 160 1=1 , 1

1

HKD 7 O A 730

V3=I DPR rKD / tu

W=(V2+TW0*V3-0NEP) / (TW0*V3+0NEP ) *TB**2*W DDR rKD 7 C A

/ dU

lou B=B+W DDR rKD 7 A A / oU

1 70, G=C DPR rKD 7 7 n I1=(NU2-1) /2 DDD rKD 7 O A 7 BO

DO 180 1=1,11 DDD rKD 7 O A 790

V3=I DPR rKD q nn

1 on 1 o U G=(TW0*V3) / (TW0*V3-0NEP)*G D D R 0 i n olU

W=l .000 DPR rKD O A U X=FDC0S(X) DPR r n a

0 7 n o3U

IF (M0D(NU2,2) .GT.O) W=DSIGN(W,X) DPR rKD

Q=0NE-A+G*TB*W*FDEXP (FLOAT (NU2)*FDL0G (DABS (X) ) )*B DDD rKD OCA ob0

GO TO 60 DDD rKD O £ A 860

L PRINT ' EITHER NU1 OR NU2 IS LESS THEN 1

' DDR rKD O 7 A 8 / U

l on 17U CALL ERROR (207) DDD rKD O O A OOU

RETURN DDD r Kb O O A 890

r

Ki PRINT ' EITHER NU1 OR NU2 IS NOT A INTEGER PROGRAM USES LARGEST DDR rKD 0 a n 9U0

r INTEGER CONTAINED ' DDR rKD 0 1 ft 7 IU

inn A U U CALL ERROR (208) DDR rKD o 0 n 7 aU

GO TO 20 nnn rKD A O A 930

END PRB 940

251
SUBROUTINE PROCHK (A ,NROW,N ,NCOL , IVEC ,X ,NSIZE) PRK 10

C VERSION 5.00 PROCHK 5/15/70 PRK 20

C SUBROUTINE PROCHK R VARNER 5/ 7/68 PRK 30

C R VARNER SUBROUTINE TO CHECK FOR DIAGONAL .NORMAL , SYMMETRIC , PRK 40

C SKEW-SYMMETRIC AND ORTHOGONAL MATRIX PRK 50

DIMENSION A(NR0W,1) , IVEC(l) PRK 60

C SET ALL INDICATORS TO NO CONDITION PRK 70

DO 10 1=1,5 PRK 80

10 IVEC ( I )=2 PRK 90

C TEST TO SEE IF WE HAVE A DIAGONAL MATRIX PRK 100

C IF YES IVEC(1)=0 IF NO IVEC(1)=2 PRK 110

DO 30 I=1,N PRK 120

DO 30 J=1,N PRK 130

IF (I-J) 20,30,20 PRK 140

20 IF (A(I,J)) 40,30,40 PRK 150

30 CONTINUE PRK 160

IVEC(1)=0 PRK 170

IVEC(2)=0 PRK 180

IVEC(3)=0 PRK 190

GO TO 50 PRK 200

40 IVEC(1)=2 PRK 210

C CHECK FOR SUMMETRY PRK 220

CALL SYMV (A,NR0W,N,IVEC(2) ) PRK 230

C CHECK FOR SKEW SYMMETRY PRK 240

CALL SKSYMV (A ,NROW,N , IRV) PRK 250

IF (IRV.GE.3) IVEC(2)=IRV PRK 260

IF (IVEC(2) .EQ.2) GO TO 50 PRK 270

IVEC(3)=0 PRK 280

C CHECK FOR ORTHOGONAL MATRIX PRK 290

C IF A IS ORTHOGONAL IVEC(4)=0 OTHERWISE IVEC(4)=2 PRK 300

50 CALL ORTHRV (A ,NROW,N ,NCOL , IVEC (4) ,X ,NSIZE ,X) PRK 310

RETURN PRK 320

END PRK 330

252
SUBROUTINE PROROW PRO 10

c VERSION 5.00 PROROW 5/15/70 PRO 20

c PROGRAMMED BY CARLA MESSINA MAY ,1967 PRO 30

c L2 = 1, ROWSUM L2 = 2, PRODUCT PRO 40

COMMON /BLOCRC/ NRC , RC ( 12600

)

PRO 50

COMMON /BLOCKD / IARGS(IOO) ,KIND(100) ,ARGTAB (100) , NRMAX ,NROW,NCOL ,NPRO 60

1ARGS,VWXYZ(8) , NERROR PRO 70

DIMENSION ARGS(IOO) PRO 80

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 )

)

PRO 90

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG PRO 100

COMMON /SCRAT/ NS , NS2 , A ( 13500

)

PRO 110

IF (NARGS-3 ) 10,40,40 PRO 120

10 IF (NARGS . EQ . 1 . AND .KIND (1 ) . EQ . 0 ) GO TO 230 PRO 130

K=10 PRO 140

20 CALL ERROR (K) PRO 150

30 RETURN PRO 160

40 CALL CHKCOL (J) PRO 170

IF (J) 50,60,50 PRO 180

50 K=3 PRO 190

GO TO 20 PRO 200

60 IF (NRMAX) 70,70,80 PRO 210

70 K=9 PRO 220

GO TO 20 PRO 230

80 IF (NERROR. NE.O) RETURN PRO 240

DO 100 1=1, NRMAX PRO 250

A(I )=0 .0 PRO 260

GO TO (100 ,90) , L2 PRO 270

90 A(I )=1 .0 PRO 280

100 CONTINUE PRO 290

IF (NARGS-4 ) 110,190,190 PRO 300

110 IF (IARGS(1)-IARGS(2) ) 120,120,50 PRO 310

120 K=IARGS(1) PRO 320

DO 150 1=1, NRMAX PRO 330

J=K+I-1 PRO 340

GO TO (130,140) , L2 PRO 350

130 A ( I )=A ( I ) +RC (J

)

PRO 360

GO TO 150 PRO 370

140 A(I)=A(I)*RC(J) PRO 380

150 CONTINUE PRO 390

IF (IARGS(1)+NR0W-IARGS(2)) 160,160,170 PRO 400

160 IARGS(1)=IARGS(1)+NR0W PRO 410

GO TO 120 PRO 420

170 K=IARGS (NARGS) PRO 430

DO 180 1=1, NRMAX PRO 440

J=K+I-1 PRO 450

180 RC(J)=A(I) PRO 460

GO TO 30 PRO 470

190 IUNARGS-1 PRO 480

DO 220 L=1,II PRO 490

K=IARGS (L) PRO 500

DO 220 1=1, NRMAX PRO 510

J=K+I-1 PRO 520

GO TO (200,210) , L2 PRO 530

200 A(I)=A(I)+RC(J) PRO 540

GO TO 220 PRO 550

210 A(I)=A(I)*RC(J) PRO 560

220 CONTINUE PRO 570

GO TO 170 PRO 580

230 CALL ADRESS (1,J) PRO 590

253
IF (J.LE.O) CALL ERROR (3) PRO 600

DO 250 I=1,NRMAX a a a PRO 610

TO T

I R= I PRO 620

r i Hi a SUM=0

.

rj n A PRO 630

DO 240 K=l , NCOL n o A PRO / A A 640

SUM=SUM+RC ( IR

)

AAA PRO 650

IR=IR+NR0W n o A PRO 660

RC (J )=SUM PRO 670

J=J+1 PRO /OA 680

RETURN AAA PRO 690

END PRO 700

254
SUBROUTINE PUNCH PUN 10

C VERSION 5.00 PUNCH 5/15/70 PUN 20

C PUN 30

C THE COMMAND PUNCH MAY BE USED IN THE FOLLOWING WAYS PUN 40

C PUNCH COL ++,++,++,++ (4 COLUMN LIMIT) PUN 50

C PUNCH // COL ++f++l++#++> ECT (ACCORDIND TO FORMAT //) PUN 60

C THIS SUBROUTINE IS USED TO EXECUTE WRITE TAPE PUN 70

C WRITE TAPE T FROM COL ++,++,++,++ (4 COLUMN LIMIT) PUN 80

C WRITE TAPE T // FROM COL ++,++, ETC (USE FOLMAT//) PUN 90

C PUN 100

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG PUN 110

COMMON /BLOCKD/ I ARGS ( 100 ), KIND ( 100 ), ARGTAB ( 100 ), NRMAX , NROW, NCOL , NPUN 120

1ARGS , VWXYZ (8 ) ,NERROR PUN 130

COMMON /BLOCRC/ NRC , RC ( 12600 ) PUN 140

DIMENSION ARGS(IOO) PUN 150

EQUIVALENCE (ARGS ( 1 ) ,RC ( 12501 )) PUN 160

COMMON /KFMT / KFMT(IOO) PUN 170

COMMON /FMAT/ IFMTX (6) , IOSWT , IFMTS (6 )

, LHEAD (96 ) PUN 180

COMMON /TAPE/ NAME4 (2 ) ,NTPCT , IPUNCP , INUNIP ,LITP PUN 190

COMMON /HEADER/ NOCARD (80 )

, ITLE (60.6) , LNCNT , I PR I NT ,NP AGE , I PUNCH PUN 200

C PUN 210

C Ll=3 PUNCH Ll=47 WRITE TAPE PUN 220

C PUN 230

IX=1 PUN 240

IF (L1.EQ.47) IX=2 PUN 250

IF (NARGS.NE.O) GO TO 20 PUN 260

10 CALL ERROR (205) PUN 270

RETURN PUN 280

C PUN 290

C IF L2=l ONLY 4 COLUMNS CAN BE PRINTED PUN 300

C PUN 310

20 IF(L2.NE.l) GO TO 25 PUN 320

NARGS=MINO (NARGS ,4) PUN 330

GO TO 30 PUN 340

25 CALL PREPAK (4 , IND ,L2 , IND , KFMT) PUN 345

IF (IND.NE.O) GO TO 90 PUN 350

30 CALL CHKCOL (I) PUN 360

IF (I.NE.O) GO TO 10 PUN 370

IF (NERROR.NE.O) GO TO (110,100), IX PUN 380

DO 60 1=1, NRMAX PUN 390

DO 40 J=l, NARGS PUN 400

K=IARGS(J) PUN 410

IARGS(J)=K+1 PUN 420

40 ARGS(J)=RC(K) PUN 430

IF (L2.NE.1) GO TO 50 PUN 440

WRITE (IPUNCH, IFMTX) (ARGS (K) ,K=1 , NARGS) PUN 450

GO TO 60 PUN 460

50 WRITE (IPUNCH, KFMT) (ARGS (K) ,K=1 , NARGS) PUN 470

60 CONTINUE PUN 480

IF (L1.NE.47) RETURN PUN 490

DO 70 J=l , NARGS PUN 500

70 ARGS(J)=0.0 PUN 510

IF (L2.NE.1) GO TO 80 PUN 520

WRITE (IPUNCH, IFMTX) (ARGS (K) ,K=1 , NARGS) PUN 530

GO TO 100 PUN 540

80 WRITE (IPUNCH, KFMT) (ARGS (K) ,K=1 , NARGS) PUN 550

GO TO 100 PUN 560

90 CALL ERROR (222) PUN 570

L2=l PUN 580

255
bU 1 U 3 0 n 1 1 ki PUN 590

1 A A 100 T DIIMPU T Dl IWPD 1 r UIMbrl=l rUnUr n 1 1 hi rUN z ft ft 600

110 RETURN PUN 610

END PUN 620

CIIDDnilTINr D W T D T 1 h kIDnill hi T hi ft 1 1 T hi n O \ bUDKUUIllMt rvlKl ( A , IMKU W , IM , 1NUU, INOb) DV/T rv 1 1 ft

c WCDCTAM C A A DWTDT C/1C/TA VtKblUN 5.00 PVIK1 5/15/70 DV/T rv 1 20

c

D\/T rv 1 1 a

c rn nCTCDUTMC I C A TC AW IIDDCD AD 1 AIVCD IU Ut 1 tKMl IMt lr A lb AIM UrrtK UK LUWtK TDTAKinil AD 1 K 1 AIMbULAK MA TD T V MA 1 K 1 X

DV/T rv 1 A A 40

c

C DCAWV CAD MhlTWAP 1 1 A 0 O / T Ufl b rtAVY rUK UIMlVAb 110b 2/ 7/68 rv 1 C A 50

c

DV/T HV 1 L A 60

c

A UATDTV TA DC PUCP1/CA A MAIK1X IU Bt bntbKtU DV/T rv 1 t A 70

C

hi D A \A1 AT KIC MCTAM C T 7 C AC A NKUW- UlMtlMblUlM b I Z,t Ur ADl/T Kv 1 O A 80

L

Kl DDCCCKIT CI7C ftc A IM- rKtbtIM 1 blZ.t Ur A DWT rv 1 Q A 90

L

TKIftll TMnTPHTrtD TKinil A IIDDPD TDIAWn C 1 IMUU 1 WD 1 OA 1 UK 1 IMUU = U , UrrtK 1 K 1 AIMbLt = A T U ftl I 1 U , 1 IMUU=1 , UPPER TRIANGLE hi n D W T IMUr V 1 1 A A 100

b

TlinD A DftTTAU TDTAI 1NUd=0,dUI 1 UM IK1AL = A T Kl A D 1 0 , 1 NUb=l , BOTTOM NOT irnuT Ltr V 1 1 1 A 110

b rv 1 1 O A 120

ftTMCKICTAhl A / hlDAUU hIDAUM UlMtlMblUlM A ( IMKU W , IMKU W)DX/T rv 1 1 1 A 130

T Kl A 1 1 1 1 IMUU=1 DMT rv 1 1 VI A 140

T hi A D 1 1 IMUb=l D\/T rv 1 1 C A 150

hi Kl Kl 1 NIM=IM-1 KV 1 1 L A 160

A A C A T 1 Kl Kl UU 50 1 = 1 , IMIM DV/T r V 1 1 7 A 170

T T Til 1 1=1+1 D\/T rv 1 1 O A 180 nn c a i T T Ki uu do J = 1 1

,

im D\/T rv 1 1 OA 17U rn TA MA in I TKIAII uU IU (1U,2U), 1 IMUU D\/T rv 1 O A A 2UU

1 A 10 TC /A/T l\ Kl C A \ TKIAII *> lr ( A ( 1 , J ) . IMt . 0 . ) 1IMUU=2 D\/T rv 1 1 1 A 210

o a rA TA 1 1 (\ VI A \ TKIAD bU IU (30,40), lIMUb D\/T rv 1 *5 O A 220

a a JO TC / A / 1 T\ KIC A \ TKIAD O lr (A ( J , 1 ) . 1Mb . 0 . ) llMUb=2 DUT rv 1 O 7 A 230

40 TC /TKIAII CA O AKIA TKIAD CA 0\ m TA L A lr ( 1 IMUU . tU. . i . AIMU . 1 NUB . tU, . L ) bU IU 60 DWT rv 1 O A A 240

c a DO P A KIT T Ml IC bUlM 1 1 IMUt D\/T rv 1 OCA 2DU

L A 60 T Kl A 1 1 T Kl A 1 1 1 1 IMUU=1 IMUU-1 D\/T rv 1 O L A 260

TKIAD TKIAD 1 1 IMUb=l IMUb-1 D\/T rv 1 O 7 A

2 70

npTt inn RETURN PV 1 i fi n 280

END PVT 290

256
NBS 4/9/69

R, CARRY ALONG I IN H TO OBTAIN HIERARCHY IN H

'PUSH-DOWN' METHOD . SEE ORGANICK, PAGE 84.

THEN I* = I-(K-l) /2

.

SUBROUTINE RANKO (N,X,H,R,T)

C VERSION 45.0 RANKO 3/ 6/70

DIMENSION X(l) , H(l) , R (1)

Q *****

C PUTS RANK OF N X'S IN VECTOR R. VECTOR H IS USED FOR STORAGE

C X,H AND R MUST BE DIMENSIONED N OR GREATER.

C STORES CORRECTION FOR TIES IN T = (1/12) *SUM(T-1) *T* (T+l )

.

C T=0 MEANS NO TIES.

C WRITTEN BY DAVID HOGBEN , SEL,

C MOVE X TO R AND PUT I IN H

10 DO 20 I=1,N

H (I )=I

20 R ( I )=X ( I

)

C SORT X IN

C SORT USES

K1=N-1

DO 30 1=1, Kl

K2=N-I

DO 30 J=1,K2

IF (R(J) .LE.R(J+1) ) GO TO 30

W=R(J)

R(J)=R(J+1)

R(J+1)=W

W=H(J)

H(J)=H(J+1)

H(J+1)=W

30 CONTINUE

C REPLACE R(I) BY I*.

C LET K BE SUCH THAT R ( I )=R ( I-J+l ) , J=l ,K

K=l

T=0

DO 70 1=2,

N

IF (R(I)-R(I-l)) 50,40,50

40 K=K+1

GO TO 70

50 DO 60 J=l ,K

IJ=I-J

60 R(IJ)=FL0AT(I-l)-FL0AT(K-l)/2

.

IF (K.GT.l) T=T+(FLOAT(K-1)*FLOAT(K)*FLOAT(K+1))/12.0

K=l

70 CONTINUE

T = T + (FL0AT(K-1)*FL0AT(K)*FL0AT(K+1))/12.0

DO 80 1=1,

K

K2=N+1-I

80 R(K2)=FL0AT(N)-FL0AT(K-l)/2 .0

C SORT H CARRY ALONG R TO OBTAIN RANKS IN R DO 90 1=1, Kl

K2=N-I

DO 90 J=1,K2

IF (H(J) .LE.H(J+1)) GO TO 90

W=H(J)

H(J)=H(J+1)

H(J+1)=W

W=R(J)

R(J)=R(J+1)

R(J+1)=W

90 CONTINUE

RETURN

END

RKO

RKO

RKO

RKO

RKO

RKO

RKO

RKO

RKO

10

20

30

40

50

60

70

80

90

RKO 120

RKO 130

RKO 140

RKO 150

RKO 160

RKO 170

RKO 180

RKO 190

RKO 200

RKO 210

RKO 220

RKO 230

RKO 240

RKO 250

RKO 260

RKO 270

RKO 280

RKO 290

RKO 300

RKO 310

RKO 320

RKO 330

RKO 340

RKO 350

RKO 360

RKO 370

RKO 380

RKO 390

RKO 400

RKO 410

RKO 420

RKO 430

RKO 440

RKO 450

RKO 460

RKO 470

RKO 480

RKO 490

RKO 500

RKO 510

RKO 520

RKO 530

RKO 540

RKO 550

RKO 560

RKO 570

RKO 580

RKO 590

RKO 600

RKO 610

257
SUBROUTINE RANKS RAS 10

C VERSION 5.00 RANKS 5/15/70 RAS 20

C ***** RAS 30

C VERSION 3.05 COMMON RAS 40

COMMON /BLOCRC/ NRC , RC ( 12600 ) RAS 50

COMMON /BLOCKD/ IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NRAS 60

1ARGS ,VWXYZ (8) ,NERROR RAS 70

DIMENSION ARGS(IOO) RAS 80

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )) RAS 90

COMMON /SCRAT/ NS , NS2 , A ( 13500 ) RAS 100

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG RAS 110

C ***** RAS 120

C RANKS OF VALUES IN COLUMN ++ PUT IN COLUMN ++. TIES ARE ALLOWED. RAS 130

C ADJUSTMENT T= ( 1 /12 ) *SUM(T-1 ) *T* (T+l ) FOR FURTHER CALCULATIONS IS RAS 140

C PUT IN ROW (NRMAX+1) IF NRMAX LT NROW. RAS 150

C ***** RAS 160

10 IF (NARGS.EQ.2) GO TO 20 RAS 170

CALL ERROR (10) RAS 180

RETURN RAS 190

20 CALL ADRESS (1,J1) RAS 200

CALL ADRESS (2,J2) RAS 210

IF (J1.GT.0.AND.J2.GT.0) GO TO 30 RAS 220

CALL ERROR (3) RAS 230

RETURN RAS 240

30 IF (NRMAX. GT.O) GO TO 40 RAS 250

CALL ERROR (9) RAS 260

RETURN RAS 270

40 IF (NERROR.NE.O) RETURN RAS 280

CALL RANKX (NRMAX , RC ( J 1 ), A (2 )

, RC ( J2 ), A ( 1 )) RAS 290

IF (NRMAX. GE. NROW) RETURN RAS 300

JANR=J2+NRMAX RAS 305

RC(JANR)=A(1) RAS 310

RETURN RAS 320

END RAS 330

258
cc

cc

c

c

cc

c10

20

cc

30

C

C

40

50

60

70

80

C

90

SUBROUTINE RANKX (N,X,H,R,T)

VERSION 5.00 RANKX 5/15/70

DIMENSION X(l) , H(l) , R(l) ***** PUTS RANK OF N X'S IN VECTOR R. VECTOR H IS USED FOR STORAGE

X,H AND R MUST BE DIMENSIONED N OR GREATER.

STORES CORRECTION FOR TIES IN T = (1/12) *SUM(T-1) *T* (T+l )

.

T=0 MEANS NO TIES.

WRITTEN BY DAVID HOGBEN, SEL, NBS . 4/9/69.

COMPUTATION OF T CORRECTED 8/26/69

***** MOVE X TO R AND PUT I IN H DO 20 1=1,

N

H(I)=I

R(D=X(I)

SORT X IN R, CARRY ALONG I IN H TO OBTAIN HIERARCHY IN H.

SORT USES 'PUSH-DOWN' METHOD. SEE ORGANICK, PAGE 84.

K1=N-1

DO 30 1=1 ,K1

K2=N-I

DO 30 J=1,K2

IF (R(J) .LE.R(J+1) ) GO TO 30

W=R(J)

R(J)=R(J+1)

R(J+1)=W

W=H(J)

H(J)=H(J+1)

H(J+1)=W

CONTINUE

REPLACE R(I) BY I*.

LET K BE SUCH THAT R ( I )=R ( I-J+l ) , J=l ,K

K=l

T=0

DO 70 1=2,

N

IF (R(I)-R(I-l) ) 50,40,50

K=K+1

GO TO 70

DO 60 J=1,K

IJ=I-J

R(IJ)=FL0AT(I-l)-FL0AT(K-l)/2.

IF (K.GT.l) T=T+(FL0AT(K-1)*FL0AT(K)*FL0AT(K+1))/12.0

K=l

CONTINUE

T = T + (FL0AT(K-1)*FL0AT(K)*FL0AT(K+1))/12.0

DO 80 1=1,

K

K2=N+1-I

R (K2 )=FL0AT (N ) -FLOAT (K-l ) /2 .

0

SORT H CARRY ALONG R TO OBTAIN RANKS IN R DO 90 1=1, Kl

K2=N-I

DO 90 J=1,K2

IF (H(J).LE.H(J+1)) GO TO 90

W=H(J)

H(J)=H(J+1)

H(J+1)=W

W=R(J)

R(J)=R(J+1)

R(J+1)=W

CONTINUE

RETURN

END

259

THEN I* = I-(K-l)/2

RAX

RAX

RAX

RAX

RAX

RAX

RAX

RAX

RAX

RAX

10

20

30

40

50

60

70

80

90

95

RAX 100

RAX 110

RAX 120

RAX 130

RAX 140

RAX 150

RAX 160

RAX 170

RAX 180

RAX 190

RAX 200

RAX 210

RAX 220

RAX 230

RAX 240

RAX 250

RAX 260

RAX 270

RAX 280

RAX 290

RAX 300

RAX 310

RAX 320

RAX 330

RAX 340

RAX 350

RAX 360

RAX 370

RAX 375

RAX 380

RAX 390

RAX 400

RAX 410

RAX 415

RAX 420

RAX 430

RAX 440

RAX 450

RAX 460

RAX 470

RAX 480

RAX 490

RAX 500

RAX 510

RAX 520

RAX 530

RAX 540

RAX 550

RAX 560

RAX 570

RAX 580
r i i n n a i i t t hi- n a r i i ft a / * ki n /\ in ai i/ n \ SUBROUTINE RCSUM (A ,NROW,N ,K ,R) RCS 10

c

w r ri f ? A in r* a ft r 1 III r~ i ~\ r i ~/ r\ VERSION 5.00 RCSUM 5/15/70 p> ft p RCS 20

c WRITTEN BY S PEAVY 11/22/67 RCS 30

c RCS 40

c WHERE

:

RCS 50

c

a TP i AAc T T ft ft 1 ft P* 111 T Pi T vy T A ft P P 1 1 ft II IP p. pi ft in A IS LOCATION OF MATRIX TO BE SUMMED ROW AND COLUMN WISE RCS 60

c

ft r"\ a in r y ^ p rv p * t ik i rv t b ip ft i p t A ft i p t ft t r ir ft i t NR0W SIZE OF A IN DIMENSION STATEMENT A(NR0W,NR0W) RCS 70

c

fti a i pi a r ft /*v in r t ft i ft N NO OF ROWS IN A RCS 80

c

IS ft 1 ft ftP A A I P f ft I ft K NO OF COLS IN A

ft p< p RCS 90

c

p\ nrrin t" p R RESULTS. ft ft p RCS 100

c

rt/^v Pk/i/\ p» p\ i r I I nr

R ( 1 ) . . R (K) COL SUMS ft ft r RCS 110

c R(K+1).. R(K+N) ROW SUMS pi ft p RCS 120

ftcp\ / 1/ ft i -1 , rn inn run R(K+N+2) GRAND SUM RCS 130

ftcpk / i / t , p> & / t iv An aii t a R(K+N + 1) S A ( I , J ) FOR ALL I,J. RCS T ill A 140

c

ft / 1/ ft 1 i\ C A / T J \ A A A p p\ p» All T 1 R(K+N+3) S A(I,J)**2 FOR ALL I ,J

.

ft ft r RCS 150

c

p* < / ft i • , p i ft « ftp * p\ p ft i ii *p p ii i i i i t— p ftp R(K+N+4) SUM OF ABSOLUTE VALUES OF ALL A 1 1 AM I ^ A ( 1 , J ) RCS 160

ftc

n ft r RCS 170

ft T ft ftP ft 1 P T ft ft ft * ft 1 ft ft lit ft 1 ft ft lit % ft s ft. 1 v DIMENSION A (NR0W,NR0W) , R(N) RCS 180

L=l p» ft p RCS 190

ASUM=0

.

pv ft r RCS 200

ft ft ft ft i ^ 1/ DO 20 J=l ,

K

ft ft p RCS 210

SUM=0

.

ft ft p RCS 220

r» /> i ft t i hi DO 10 1=1,

N

D r* C RLb 230

run & p i

i •, a k n c / k / t i \ \ ASUM=ASUM+ABS (A ( I , J )

)

RLb 1 A A 240

10 run r i in a / t iv SUM=SUM+A(I ,J) RCS ft p A 250

p» . i . ^ i hi R (L )=SUM p> ft r RCS 260

20 L=L+1 RCS 270

S=0 .0

p» ft p RCS 280

SS=0 .0

r> ft r RCS 290

ft ft aft T ft! DO 40 1=1,

N

ft p» r* RCS 300

SUM=0 .0

p» ft p" RCS 310

r\ft i p. i ! i/ DO 30 J=1,K O 1 A 320

run r i tn a / 7 i \ SUM=SUM+A ( I , J

)

RC5 O O A 330

30

PP PP ft , T 1 v *t *S SS=SS+A(I ,J)**2 O c RCS O A A 340

r p rim S=S+SUM DOC OCA 350

ft>> pit** R (L)=SUM ft ft r RCS 360

40 L=L+1 D C RCS OTA 370

R (L)=S Rtb O O A 380

R (L+2 )=SS npr RLb O A A 390

ft / | ^ V P R (L+1)=S DP C RLb 400

ft i a At ft P 1 1 ft ft R (L+3 )=ASUM RCS A T A 410

RETURN

ft ft r RCS 420

END RCS 430

260
SUBROUTINE READQ REQ 10

c VERSION 5.00 READQ 5/15/70 REQ 20

COMMON /BLOCRC/ NRC , RC ( 12600

)

REQ 30

COMMON /BLOCKD / IARGS(IOO) , KIND (100) , ARGTAB (100 )

, NRMAX , NROW , NCOL , NREQ 40

1ARGS,VWXYZ(8) ,NERROR REQ 50

DIMENSION ARGS(IOO) REQ 60

EQUIVALENCE (ARGS (1) ,RC (12501)

)

REQ 70

COMMON /QRS / NDROW, I FLAG, J ,NNARG REQ 80

COMMON /BLOCKA/ MODE , M, KARD (83 ) ,KARG , ARG , ARG2 ,NEWCD (80 )

, KRDEND REQ 90

COMMON /BLOCKC/ KIO , INUNIT , ISCRAT , KBDOUT , KRDKNT , LLI ST REQ 100

COMMON /TAPE/ NAME4 (2 ), NTPCT , IPUNCP , INUNI P , L1TP REQ 110

COMMON/KFMT/KFMT (100

)

REQ 115

IF (IFLAG.NE.O) GO TO 80 REQ 120

IF (J.LT.NROW) GO TO 10 REQ 130

IFLAG=1 REQ 140

CALL ERROR (201) REQ 150

GO TO 40 REQ 160

c NNARG CONTAINS NARGS OF READ COMMAND REQ 170

c KFMT (l)THRU KFMT (NNAGR ) CONTAINS ADDRESSES OF COLUMN TOPS REQ 180

c THESE CORRECTIONS ARE NEEDED FOR TAPE OPERATIONS REQ 190

10 IF (L1TP.NE.45) GO TO 50 REQ 200

DO 30 1=1 , NNARG REQ 210

K=KFMT(I)+J REQ 220

IF (KIND (I ) .EQ.O) GO TO 20 REQ 230

IF (ARGS(I) .NE.O. ) GO TO 50 REQ 240

GO TO 30 REQ 250

20 IF (IARGS(I) .NE.O) GO TO 50 REQ 260

30 CONTINUE REQ 270

40 INUNIT=INUNIP REQ 280

M0DE=1 REQ 290

GO TO 80 REQ 300

50 IF (NARGS. GE. NNARG) GO TO 55 REQ 305

NNS=NARGS+1 REQ 307

DO 52 I=NNS , NNARG REQ 310

KIND(I)=0 REQ 315

52 IARGS(I)=0 REQ 320

55 DO 70 1=1 ,NNARG REQ 325

C **************************************************************** REQ 330

K=KFMT(I)+J REQ 340

IF (KIND ( I ) .EQ.O) GO TO 60 REQ 350

RC(K)=ARGS(I) REQ 360

GO TO 70 REQ 370

60 RC(K)=IARGS(I) REQ 380

70 CONTINUE REQ 390

C J IS CARD COUNT. IT COUNTS FROM ZERO. REQ 400

J=J+1 REQ 410

NRMAX=MAXO (NRMAX , J

)

REQ 420

C THESE CORRECTIONS ARE NEEDED FOR TAPE OPERATIONS REQ 430

IF (L1TP.NE.46) GO TO 80 REQ 440

NTPCT=NTPCT-1 REQ 450

IF (NTPCT. EQ.O) GO TO 40 REQ 460

C *****************************************************************!| REQ 470

80 RETURN REQ 480

END REQ 490

261
SUBROUTINE READX REX 10

C VERSION 5.00 READX 5/15/70 REX 20

COMMON /BLOCKA / MODE , M,KARD (83 ) ,KARG , ARG , ARG2 ,NEWCD (80

)

( KRDEND REX 30

COMMON /BLOCRC/ NRC ,RC (12600) REX 40

COMMON /BLOCKD / I ARGS ( 100 ), KIND ( 100 ), ARGTAB ( 100 )

, NRMAX , NROW, NCOL , NREX 50

1ARGS ,VWXYZ (8 ) ,NERROR REX 60

DIMENSION ARGS(IOO) REX 70

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 ) ) REX 80

COMMON /BLOCKE/ NAME (4 ), LI , L2 , ISRFLG REX 90

COMMON /QRS / NDROW, I FLAG , J ,NNARG REX 100

COMMON /BLOCKC/ KIO , I NUN IT , ISCRAT , KBDOUT , KRDKNT , LLIST REX 110

C THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS REX 120

COMMON /TAPE/ NAME4 (2 ) ,NTPCT , IPUNCP , I NUN IP , L1TP REX 130

q *************************************************************** 140

COMMON /KFMT /KFMT (100) REX 150

IF (L2.NE.1) GO TO 90 REX 170

ISRFLG=0 REX 180

IF (NARGS.GT.O) GO TO 20 REX 190

10 CALL ERROR (10) REX 200

GO TO 70 REX 210

20 M0DE=2 REX 220

CALL CHKCOL (I) REX 230

IF(I.EQ.O) GO TO 40 REX 240

30 CALL ERROR (3) REX 250

GO TO 70 REX 260

40 IF (NERROR.NE.O) GO TO 70 REX 270

DO 50 1=1, NARGS REX 280

KFMT(I)=IARGS(I) REX 290

IARGS(I)=0 REX 300

50 ARGS(I)=0. REX 310

I FLAG=0 REX 320

J=0 * REX 330

NNARG=NARGS REX 340

GO TO 80 REX 350

60 M0DE=2 REX 360

70 IFLAG=1 REX 370

C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS REX 380

IF (LITP.EQ.46.0R.LITP.EQ.45) GO TO 200 REX 390

Q ******************************************************************p£X 4 QQ

80 RETURN REX 410

C REX 430

C FORMATTED READ REX 435

C READ X N C C C C REX 440

C REX 450

C N = NUMBER OF CARDS TO READ. IF N = 0, READ UNTIL A REX 460

C BLANK CARD IS FOUND REX 470

C X IS THE FORMAT IDENTIFIER, A,B ( C,D,E,F REX 480

C REX 490

90 IF (NARGS . LE . 1 ) GO TO 10 REX 500

C SETUP FORMAT REX 510

CALL PREPAK(4, IND,L2,I , KFMT) REX 520

IF (IND.NE.O) CALL ERROR (27) REX 525

IF (NERROR.NE.O) GO TO 60 REX 530

C CHECK AND CONVERT ARGUMENTS REX 540

DO 100 1=2, NARGS REX 550

CALL ADRESS ( I , IARGS ( I ) ) REX 560

IF ( IARGS ( I ) . LE . 0 ) GO TO 185 REX 565

100 CONTINUE REX 567

IF(IARGSd)) 30,110,120 REX 570

262
110

120

130

140

C

C

150

160

170

180

C

C

C

185

C

C

190

200

C

C

210

N=NRC

GO TO 130

N=IARGS(1)

00 170 1=1,

N

READ (INUNIT ,KFMT) (ARGS (J ) , J=2 ,NARGS)

CHECK IF LOOKING FOR BLANK CARD

IF (IARGS(l) .NE.O) GO TO 150

DO 140 J=2,NARGS

IF (ARGS(J) .NE.O. ) GO TO 150

CONTINUE

BLANK CARD FOUND, TERMINATE READ.

GO TO 180

IF THERE IS TOO MUCH DATA, DO NOT ENTER EXCESS

IF (I.GT.NROW) GO TO 170

DO 16Q J=2,NARGS

K=IARGS(J)

IARGS(J)=K+1

RC(K)=ARGS(J)

CONTINUE

I=N+1

1 = 1-1

NRMAX=MAX0 (NRMAX , MI NO (I ,NROW)

)

WRITE (ISCRAT,210) I IF (I.GT.NROW) CALL ERROR (201)

THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS

THE CARD WAS GO TO 80

GO TO 190 *************************************************************

CALL ERROR (11)

THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS

THE CARD WAS GO TO 80

IF(L1TP.NE.45 .AND .L1TP .NE .46) RETURN

INUNIT=INUNIP

M0DE=1

RETURN ***********************************************************

FORMAT (5X,I4,33H DATA CARD(S) READ BUT NOT LISTED, 42X)

END

REX 580

REX 590

REX 600

REX 610

REX 620

REX 630

REX 640

REX 650

REX 655

REX 657

REX 660

REX 670

REX 680

REX 690

REX 700

REX 710

REX 720

REX 730

REX 740

REX 750

REX 760

REX 770

REX 780

REX 790

REX 800

REX 810

REX 820

*****REX 830

REX 840

REX 850

REX 860

REX 870

REX 880

REX 890

REX 900

*****REX 910

REX 920

REX 930

REX 940

263
SUBROUTINE REPINC (IJSWT) REP 10

C VERSION 5.00 REPINC 5/15/70 REP 20

C WRITTEN BY R VARNER 4/ 9/68 REP 30

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG REP 40

COMMON /BLOCKB/ NSTMT ,NSTMTX , NSTMTH ,NCOM,LCOM, IOVFL , COM (2000) REP 50

COMMON /BLOCKX/ INDEX (6,8) , LEVEL REP 60

COMMON /BLOCRC/ NRC , RC ( 12600 ) REP 70

COMMON /BLOCKD / I ARGS ( 100 )

, KIND ( 100 ), ARGTAB ( 100 )

, NRMAX , NROW, NCOL , NREP 80

1ARGS ,VWXYZ (8) ,NERROR REP 90

DIMENSION ARGS(IOO) REP 100

EQUIVALENCE (ARGS (1 ) ,RC (12501) ) REP 110

C REP 120

C IJSWT=1 COMMAND IS REPEAT INITIALIZE THINGS REP 130

C IJSWT=2 IN REPEAT MODE REP 140

C IJSWT=3 COMMAND IS INCREMENT OR RESTORE REP 150

C REP 160

C L2=6 INCREMENT REP 170

C L2=8 RESTORE REP 180

C REP 190

GO TO (350,490,10), IJSWT REP 200

10 IF (L2.EQ.6) GO TO 20 REP 210

T=0.0 REP 220

GO TO 30 REP 230

20 T=1.0 REP 240

30 IF (NARGS.GE.2) GO TO 50 REP 250

40 K=10 REP 260

GO TO 320 REP 270

C REP 280

C GET STATEMENT NUMBER. CAN BE FLOATING OR INTEGER. REP 290

C REP 300

50 IF (KIND(l) .EQ.O) GO TO 60 REP 310

J=10 .*ARGS(l)+.5 REP 320

GO TO 70 REP 330

60 J=10*IARGS(1) REP 340

70 IF (J .GT.NSTMTH) GO TO 80 REP 350

J=LOCATE(J) REP 360

C REP 370

C J HAS LOCATION OF COMMAND TO BE MODIFIED REP 380

C REP 390

IF (J.GT.O) GO TO 90 REP 400

80 K=13 REP 410

GO TO 320 REP 420

C REP 430

C JJ IS FIRST LOCATION OF THE NEXT STORED COMMAND. REP 440

C REP 450

90 JJ=J+IFIX(C0M(J+1) ) REP 460

C REP 470

C CHECK THAT COMMAND HAS THE PROPER NUMBER OF ARGUMENTS REP 480

C REP 490

IF (NARGS-l.NE.M0D(IFIX(C0M(J+2)) ,64)) GO TO 40 REP 500

J=J+3 REP 510

C REP 520

C SKIP OVER HEADER REP 530

C REP 540

C REP 550

C CHECK IF THIS COMMAND IS STORED. IF SO, PULL OUT INTO ARGTAB. REP 560

C (ALL BUT FIRST ARG WHICH IS STATEMENT NUMBER) REP 570

C REP 580

IF (LEVEL. EQ.O) GO TO 110 REP 590

264
K=2*NARGS REP 600

DO 100 1=2, K REP 610

ARGTAB(I)=C0M(I2+4) REP 620

100 12=12+1 REP 630

C REP 640

C 12 IS LOCATION OF THIS COMMAND REP 650

C REP 660

110 I=2+KIND(1) REP 670

C REP 680

C PERFORM INCREMENT OR RESTORE. PICK UP ARGUMENT FROM REP 690

C COMMAND TO BE MODIFIED AND EXAMINE IT. REP 700

C REP 710

120 IF (COM(J)) 250,130,200 REP 720

C REP 730

C FLOATING POINT CONST. REP 740

C REP 750

130 IF (ARGTAB ( I ) ) 140,160,310 REP 760

C REP 770

C INCR. FL. PT. CONST. BY 'STATEMENT' REP 780

140 IF (ARGTAB ( I ) . EQ . (-1 . )

) GO TO 310 REP 790

CALL XPND (ARGTAB(I) ,K,Y,KND) REP 800

IF (K.LT.O) GO TO 220 REP 810

IF (KND.EQ.O) GO TO 310 REP 820

C0M(J+1)=T*C0M(J+1)+Y REP 830

J=J+2 REP 840

150 I=I+K+1 REP 850

GO TO 190 REP 860

160 C0M(J+1)=T*C0M(J+1)+ARGTAB(I+1) REP 870

170 J=J+2 REP 880

180 1=1+2 REP 890

190 IF (J-JJ) 120,330,330 REP 900

C REP 910

C COLUMN NUMBER REP 920

C REP 930

200 IF (ARGTAB ( I ) ) 210,310,230 REP 940

C REP 950

C INTEGER CONST MODIFIED BY STATEMENT: REP 960

C REP 970

210 IF(ARGTAB(I) .EQ. (-1. )

) GO TO 310 REP 980

CALL XPND (ARGTAB (I ) ,K , Y ,KND) REP 990

IF (K.GE.O) IF (KND) 310,225,310 REP 995

220 K=-K REP1000

GO TO 320 REP1010

225 COM(J)=T*COM(J)+Y REP1020

J=J+1 REP1030

GO TO 150 REP1040

230 C0M(J)=T*(C0M(J)-8192.)+ARGTAB(I) REP1050

IF (COM(J)) 300,300,240 REP1060

240 J=J+1 REP1070

1=1+1 REP1080

GO TO 190 REP1090

C REP1100

C VARIABLE *REFERENCE* REP1110

C NRMAX,V ( W,X,Y,Z CAN ONLY BE INCREMENTED, BY 0 OR 0 . REP1120

C WHETHER 0 OR 0. INCREMENTS :X: OR 'X' IS IMMATERIAL. REP1130

C REP1140

250 IF(COM(J) .LT. (-16. ) ) GO TO 260 REP1150

IF(COM(J) .EQ. (-1.)) GO TO 340 REP1160

J=J+1 REP1170

265
c

cc260

270

280

290

300

310

320

330

C

C

C

C

340

C

C

C

C

C

C

C

C

C

C

C

C

C

350

360

C

C

C

370

C

C

C

380

390

400

410

GO TO 180

*ROW,COL* REFERENCE.

IF (ARGTAB(I)+16.0) 270,310,310

COM(J)=T* (COM (J ) +8208 . ) +ARGTAB ( I

)

IF(COM(J) .GT. (-16.)) GO TO 310

IF (C0M(J+1)*ARGTAB(I+1) ) 310,310,280

Y=T* (ABS(C0M(J+1) )-8192 . ) +ABS (ARGTAB ( 1+1 )

)

IF (Y) 310,310,290

C0M(J+1)=SIGN(Y,C0M(J+1))

GO TO 170

K=18

GO TO 320

K=20

CALL ERROR (K)

RETURN

*** (=THRU) IGNORE. INCREM.

HAVE CORRESPONDING *** OR RESTORE MAY OR MAY NOT

IF(ARGTAB(I).EQ.(-1.))

J=J+1

GO TO 190

1 = 1+1

NESTED PERFORMS UP TO EIGHT LEVELS ARE ALLOWED

CURRENT LEVEL IS STORED IN LEVEL

INDEX(1, LEVEL)

INDEX(2, LEVEL)

INDEX(3, LEVEL)

INDEX(4, LEVEL)

INDEX(5, LEVEL)

INDEX(6, LEVEL)

CONTAINS LOCATION OF COMMAND AT ARGl (FIRST)

CONTAINS RUNNING INDEX FROM ARGl TO ARG2

CONTAINS LOCATION OF COMMAND AT ARG2 (LAST)

CONTAINS THIRD ARG (REPEAT COUNT)

CONTAINS CURRENT LEVEL COUNTER (1 TO ARG3)

CONTAINS STATEMENT NUMBER OF STATEMENT CURRENTLY

BEING EXECUTED.

IF (NARGS-3) 360,400,390

IF (NARGS-1 ) 390,370,380

SECOND ARG MISSING, MAKE SAME AS FIRST ARG

IARGS(2)=IARGS(1)

KIND(2)=KIND(1)

THIRD ARG MISSING, SET TO INTEGER 1

IARGS(3)=1

KIND(3)=0

GO TO 410

CALL ERROR (10)

GO TO 500

IF (KIND(3) .EQ.0.AND.IARGS(3) .GT.O) GO TO 410

CALL ERROR (3)

GO TO 500

DO 450 1=1,2

IF (KIND (I ) .EQ.O) GO TO 420

IARGS(I)=10.*ARGS(I)+.5

GO TO 430

REP1180

REP1190

REP1200

REP1210

REP1220

REP1230

REP1240

REP1250

REP1260

REP1270

REP1280

REP1290

REP1300

REP1310

REP1320

REP1330

REP1340

REP1350

REP1360

REP1370

REP1380

REP1390

REP1400

REP1410

REP1420

REP1430

REP1440

REP1450

REP1460

REP1470

REP1480

REP1490

REP1500

REP1510

REP1520

REP1530

REP1540

REP1550

REP1560

REP1570

REP1580

REP1590

REP1600

REP1610

REP1620

REP1630

REP1640

REP165*

REP1660

REP1670

REP1680

REP1690

REP1700

REP1710

REP1720

REP1730

REP1740

REP1750

REP1760

266
420

430

440

450

460

C

C

C

470

C

C

C

480

490

500

IARGS ( I )=10*IARGS (I

)

IF (IARGS(I) .GT.NSTMTH) GO TO 440

IARGS(I)=LOCATE(IARGS(I)

)

IF (IARGS(I) .GT.O) GO TO 450

CALL ERROR (13)

GO TO 500

CONTINUE

IF (LEVEL. LT. 8) GO TO 460

CALL ERROR (19)

GO TO 500

IF (IARGS (2) .LT.IARGS(l) ) CALL ERROR (3)

IF (NERROR.NE.O) GO TO 500

LEVEL=LEVEL+1

INDEX(1,LEVEL)=IARGS(1)

INDEX(3,LEVEL)=IARGS(2)

INDEX(4,LEVEL)=IARGS(3)

INDEX(5,LEVEL)=0

OUTER LOOP

INDEX (5, LEVEL )=INDEX (5, LEVEL) +1

IF (INDEX (5 , LEVEL) . LE . INDEX (4 , LEVEL) ) GO TO 480

FINISHED OUTER LOOP, REDUCE LEVEL BY 1

LEVEL=LEVEL-1

IF (LEVEL. GT.O) GO TO 490

RETURN

INDEX (2 , LEVEL )=INDEX (1 , LEVEL)

I2=INDEX(2,LEVEL)

IF (12. GT.INDEX(3, LEVEL)) GO TO 470

INDEX(6,LEVEL)=C0M(I2)

K=C0M(I2+1)

INDEX(2,LEVEL)=INDEX(2,LEVEL)+K

L2=C0M(I2+2)

Ll=L2/64

NARGS=L2-64*L1

L2=Ll/64

L1=L1-64*L2

CALL EXPAND (K-2 ,C0M(I2+3)

)

RETURN

IJSWT=-IJSWT

RETURN

END

REP1770

REP1780

REP1790

REP1800

REP1810

REP1820

REP1830

REP1840

REP1850

REP1860

REP1870

REP1880

REP1890

REP1900

REP1910

REP1920

REP1930

REP1940

REP1950

REP1960

REP1970

REP1980

REP1990

REP2000

REP2010

REP2020

REP2030

REP2040

REP2050

REP2060

REP2070

REP2080

REP2090

REP2100

REP2110

REP2120

REP2130

REP2140

REP2150

REP2160

REP2170

REP2180

REP2190

REP2200

267
^IIRROHTTMF RFSFT Klj i n J. u p VFRSTON 5 00 RFSFT 5/15/70 ? n COMMON /BLOCRC/ NRC , RC ( 12600

)

RES

COMMON /BLOCKD / IARGS(100) , KIND (100) ,ARGTAB (100) , NRMAX ,NR0W,NC0L ,NRES An

1ARGS X HJ\ w J / VWXYZ(ft^ V If A I im \ O ) f IINERROR t- IVi\ vn RFS l\LJ ^ n nTMFNSTON ARGSHOO} RFS I\LJ An

FnilTVAIFNPF f ARG^M ^ Rf/IKflin RFS 7n

TOMMON V«i V llllfIV/ 11 //BLOfKE/ UUU w!\U / NAME 11 H IfIL. (4^ \ " ^ r LILX ( L2L4 ( ISRFLG 1 JIM L. V3 RFS l\ L. J o u IFfNARGS EO 1} T F f L2—2 ^ 25 20 40 RES 1\ L- «J

ft ^ K=10 RES Qn

i n 1 u PALI FRROR (K\ RFS l\LJ iJ.UU nn

o n L u RETURN l\ L. l U l\ 11 RFS 1 1 n 1 1 u p RESET NRMAX RFS l\LJ l 7 n TFIT (KTNfWn ^rXJLIlls^xJ .I1L..U/ NF ft * TIHI\gj ARGS f

\ "M1 ) ——MARGS rv VI J f^ *MX / RFS ii. JinV IF f I ARGS f 1 ^ GE 0 AND IARGSm LE NROUh GO TO 30 RES r\ l. j 1 4n

K=3 RES i ^ n GO TO 10 RES i An

in NRMAX-I ARGS ( 1

RES f\ L. <J> i 7n

cc\ to ?ft RFS i ft n r RESET V,W,X,Y,Z RES X1907 VI 40"T VI IF (KIND(l) .EQ.0) ARGS(1)=IARGS(1) RES ?nn

VWXYZ(L2-2)=ARGS(1) RES 5 1 n GO TO 20 RES o o n END RES 230

268
c

cc

c

cc

c

c

cc

c

c

c

c

c

c

c

c

c

c

10

c

c

c

cc

c

c

c

c

c

cc20

30

SUBROUTINE RFORMT (X , N , NS ,NW , ND , NX , XVAL , ARRAY , NB , NC

)

VERSION 5.00 RFORMT 5/15/70

WRITTEN BY DAVID HOGBEN , SEL, NBS . 4/18/69.

REWRITE AND COMBINING OF FXFARG (2 / 1 /69 ) AND FXF0RM(2 /7 /69 )

.

FLOATING FORMAT 1PE NW.NS-1 IS GIVEN IF N LT 0 AND NX LT 0

.

FIXED FORMAT F NW.ND IS GIVEN IF N GE 0 AND NX LT 0 . SET NS=8.

PERIOD NOT PRINTED IF NDECS=0

FXFARG SET *** XVAL=X (OR ANY REAL VARIABLE)

ARRAY=A (OR ANY DIMENSIONED VECTOR)

NBLANK=0 (OR ANY OTHER INTEGER)

INPUT *** X, N, NSIGDS, NWMAX.

OUTPUT *** NWIDTH , NDECS . FXFORM SET *** X=X(OR ANY REAL VARIABLE)

N=l (OR ANY INTEGER)

NWMAX=0

INPUT *** XVAL, NSIGDS, NWIDTH, NDECS, NBLANK.

OUTPUT *** ARRAY

$ $ $ $ $

NUMBER IS CENTERED IF NC=1 AND NOT CENTERED IF NC=0 (RIGHT JUST'D

THIS REVISION WRITTEN 10/09/69

COMMON /ABCDEF / L(48)

DIMENSION X(l), ARRAY (1) , C(10)

EQUIVALENCE (C(1),L(1)), (BLANK , L (45 )) , (PERIOD ,L (38) ) , (CPLUS,L(

10)), (CMINUS,L(39)) , (CASTER , L (41 )

)

DOUBLE PRECISION Z

NSIGDS=MIN0(8,NS)

NSIGDS=MAX0(1, NSIGDS)

IF (NX) 50,60,20

***** FXFARG SUBROUTINE

INPUT FOR THE SUBROUTINE FXFORM. NWMAX IS THE MAXIMUM ALLOWABLE

VALUE OF NWIDTH. X MUST BE DIMENSIONED AND N IS ITS LENGTH.

NWMAX MUST BE GREATER THAN NSIGDS PLUS FOUR

NWIDTH = MIN (MMAX-MMIN+NSIGDS+2 , NWMAX)

NDECS=NSIGDS-MMIN-1, NDECS=MIN0 (MAXO (NDECS ,NSIGDS+2 ) ,NWMAX-3 ), IF

NWIDTH EXCEEDS NWMAX.

IF NSIGDS GT 8, IT IS SET = TO 8, IF LT 1 SET = TO 1.

REFERENCE *** SEL NOTE N-68-3, SEPTEMBER, 1968.

WRITTEN BY DAVID HOGBEN, SEL, NBS. 2/ 1/69.

* * * * * NWMAX=MAXO (NSIGDS+5 ,NX)

Y=ABS(X(1))

IF (Y.LE.O.) Y=1.0

Y1=Y

Y2=Y

IF (N.LT.l) N=l

DO 30 1=1,

N

Y=ABS(X(I))

IF (Y.LE.O.) Y=1.0

IF (Y.LT.Y1) Y1=Y

IF (Y.GT.Y2) Y2=Y

CONTINUE

MMIN=FL0G10(Y1)

IF (Yl.LT.l.) MMIN=MMIN-1

MMAX=FL0G10(Y2)

IF (Y2.LT.1.) MMAX=MMAX-1

Z=Y1

LL=Z*10.D0**(NSIGDS-MMIN)+5.0D0

RFO

RFO

RFO

RFO

RFO

RFO

RFO

RFO

RFO

10

20

30

40

50

60

70

80

90

RFO 100

RFO 110

RFO 120

RFO 130

RFO 140

RFO 150

RFO 160

RFO 170

RFO 180

RFO 190

RFO 195

RFO 197

RFO 200

RFO 210

4RF0 220

RFO 230

RFO 240

RFO 250

RFO 260

RFO 270

RFO 280

RFO 290

RFO 300

RFO 310

RFO 320

RFO 330

RFO 340

RFO 350

RFO 360

RFO 370

RFO 380

RFO 390

RFO 400

RFO 410

RFO 420

RFO 430

RFO 440

RFO 445

RFO 450

RFO 460

RFO 470

RFO 480

RFO 490

RFO 495

RFO 500

RFO 510

RFO 520

RFO 530

RFO 540

RFO 550

269
IF (LL.GE.10** (NSIGDS+1) ) MMIN=MMIN+1 RFO 560

IF (LL.LT.10**NSIGDS) MMIN=MMIN-1 RFO 570

Z=Y2 RFO 580

LL=Z*10.D0**(NSIGDS-MMAX)+5.0D0 RFO 590

IF (LL.GE.10**(NSIGDS+1)) MMAX=MMAX+1 RFO 600

IF (LL.LT.10**NSIGDS) MMAX=MMAX-1 RFO 610

NDECS=NSIGDS-MMIN-1 RFO 620

NDECS=MAXO(0,NDECS) RFO 630

NWIDTH=MMAX+3+NDECS RFO 640

IF (MMAX.LT.O) NWIDTH=NDECS+2 RFO 650

IF (NWIDTH.LE.NWMAX) GO TO 40 RFO 660

N0ECS=MAX0(NDECS,NSIGDS+2) RFO 670

NDECS=MINO (NDECS, NWMAX-3) RFO 680

NWIDTH=NWMAX RFO 690

IF (NDECS.LT.O) NDECS=0 RFO 700

ND=NDECS RFO 710

NW=NWIDTH RFO 720

RETURN RFO 730 ***** RFO 740

FXFORM SUBROUTINE RFO 750

SUBROUTINE FXFORM ALLOWS PRINTING OF REAL NUMBERS X IN FIXED RFO 760

FORMAT WITH DECIMAL POINT IN CONSTANT POSITION. NWIDTH = WIDTH OFRFO 770

FIELD, NDECS = NUMBER OF PLACES TO RIGHT OF DECIMAL POINT, X IS RFO 780

THE NUMBER, ARRAY IS THE VECTOR WHERE X IS RETURNED TO BE PRINTED RFO 790

ACCORDING TO A FORMAT, NSIGDS = NUMBER OF DIGITS GIVEN WITH BLANKSRFO 800

ON THE RIGHT, NBLANK IS THE NUMBER OF BLANKS TO BE PUT ON THE RFO 810

LEFT OF THE FIELD. IF X IS TOO LARGE OR TOO SMALL IT IS RETURNED RFO 820

AS A FLOATING POINT NUMBER. ARRAY MUST BE DIMENSIONED. RFO 830

A PERIOD IS NOT GIVEN IF X IS GREATER THAN OR EQUAL TO 10**NSIGDS RFO 840

ZERO IS WRITTEN 0. RFO 850

IF NDECS=NWIDTH , BLANKS ARE RETURNED RFO 860

SUBROUTINE MAY BE USED IN CONJUCTION WITH SUBROUTINE FXFARGS . RFO 870

IF NSIGDS GT 8, IT IS SET = TO 8, IF LT 1 SET = TO 1. RFO 880

NWIDTH IS ADJUSTED IF NECESSARY SO THAT IT IS GE NDECS+2 , RFO 890

GE NSIGDS+2 IF FIXED AND GE NSIGDS+5 IF FLOATING RFO 900

REFERENCE *** SEL NOTE N-68-3 , SEPTEMBER, 1968. RFO 910

WRITTEN BY DAVID HOGBEN , SEL, NBS . 2/ 7/69. RFO 920 ***** RFO 930

NWIDTH=NW RFO 940

GO TO 70 RFO 950

NWIDTH=MAXO(NW, NSIGDS+2) RFO 960

NDECS=MAX0(0,ND) RFO 970

IF (NWIDTH. LT. NDECS) NWIDTH=NDECS+2 RFO 980

NB=MAXO(0,NB) RFO 985

IF(NC.NE.O) NC=1 RFO 990

NBLANK=NB-(NB/2 ) *NC RFO 995

MF=0 RF01000

Y=ABS(XVAL) RF01010

NDIFF=NWIDTH-NDECS RF01020

NWMAX=NWIDTH+NBLANK RF01030

NPONE=NDIFF+NBLANK RF01040

IEND=NWIDTH+NB RF01045

DO 90 1=1 , IEND RF01050

ARRAY ( I )=BLANK RF01060

IF (NDECS. EQ. NWIDTH) RETURN RF01070

IF (Y.GT.O.) GO TO 110 RF01080

XVAL=0. IS SPECIAL CASE UNLESS FIXED OR FLOATING RF01090

IF (NX.GE.O) GO TO 100 RF01100

FIXED RF01110

270
W=0 RF01120

GO TO 130 RF01130

100 IF (NDECS.NE.O) ARRAY (NPONE)=PERIOD RF01140

ARRAY(NP0NE-1)=C(1) RF01150

RETURN RF01160

110 M=FLOG10(Y) RF01170

IF (Y.LT.l.) M=M-1 RF01180

Z=Y RF01190

Z = Z*10.D0** (NSIGDS-M) RF01193

XI = Z RF01196

LL1 = XI RF01200

X2 = Z - DBLE(Xl) RF01205

LL2 = X2 RF01210

LL = LL1 + LL2 + 5 RF01215

IF (LL.LT.10**(NSIGDS+1)) GO TO 120 RF01220

M=M+1 RF01230

LL=LL/10 RF01240

GO TO 130 RF01250

120 IF (LL.GE.10**NSIGDS) GO TO 130 RF01260

Rft=M-l RF01270

LL=10*LL RF01280

130 IF (NX.EQ.O) GO TO 170 RF01290

IF (N.LT.O) GO TO 180 RF01300

C FIXED RF01310

IF (M.LT. NDIFF-2) GO TO 150 RF01320

IF (M.EQ .NDIFF-2 .AND .XVAL .GE . 0 . ) GO TO 150 RF01330

NSIGDS=MAX0(0,NWIDTH-5) RF01340

IF (NSIGDS.GT.O) GO TO 180 RF01350

C PUT IN ASTERISKS RF01360

DO 140 I=1,NWIDTH RF01370

IRVSP=I+NBLANK RF01375

140 ARRAY (IRVSP)=CASTER RF01380

RETURN RF01390

150 NSIGDS=MINO (8 ,NDECS+M+1

)

RF01400

NSIGDS=MAXO(0,NSIGDS) RF01410

LL=(LL-5)/(10**(8-NSIGDS))+5 RF01420

IF (NSIGDS.GT.O) GO TO 170 RF01430

IF (XVAL. LT. 0.0) ARRAY (NPONE-1 )=CMINUS RF01440

DO 160 I=NPONE,NWMAX RF01450

160 ARRAY(I)=C(1) RF01460

ARRAY (NPONE)=PERIOD RF01470

IF(NDECS+1.EQ. (-M) . AND . LL .GT . 10 ) ARRAY (NWMAX

)

=C(2) RF01480

RETURN RF01490

170 MREAL=0 RF01500

IF (M.GE .NSIGDS-1-NDECS .AND .M.LT . NDIFF--2) GO TO 190 RF01510

IF (M. EQ. NDIFF-2. AND. XVAL. GT. 0. ) GO TO 190 RF01520

C FLOATING RF01530

180 MREAL=M RF01540

M=0 RF01550

MF=1 RF01560

Y=Y*10.**(-MREAL) RF01570

190 IF (M.LT.NSIGDS. AND. NDECS.NE.O) ARRAY (NPONE )= PERIOD RF01580

NINT=NP0NE-1-M RF01590

IF (M.LT.O) NINT=NINT+1 RF01600

NEND=NINT+NSIGDS-1 RF01610

IF (M.GE.O.AND.M.LT.NSIGDS-1) NEND=NEND+1 RF01620

DO 200 J=NINT , NEND RF01630

I=NEND+NINT-J RF01640

IF (I. EQ. NPONE) GO TO 200 RF01650

271
II II J 1 A LL=LL / 10 A A A. *l y y A RF01660

AO HI ||Af\ /II TAX NN=MOD (LL , 10)

A P A ^ y ^* f\ RF01670

t rt n i \y / t \ a / hi hi i\ ARRAY ( I )=C (NN+1

)

RF01680

200

a AlIT T hi i i r* CONTINUE RF01690

T i*- , hi A A f\ f\ \ A A X A AAA

IF (MF.EQ.O) GO TO 220 RF01700

c m it Til runAnrmT r~ a a r* i a ax t hi a a a t ti x hi i i tin r* a PUT IN EXPONENT FOR FLOATING POINT NUMBER RF01710

t r— / kllllT l\TII A A hi A T A A. A AA T A ATA

IF (NWIDTH .GE .NSIGDS+5 ) GO TO 210 RF01720

hi 111 T ff\ X 1 1 hi A T A A A f NWIDTH=NSIGDS+5 RF01730

PA T A a a GO TO 80 A 1TM A 1 "T A RF01740

O 1 A 210 T f~ / hlA C A 1 IT A \ AODAV /klTKin 1 \ A fed T fcl 1 1 c lr (MKLAL . L 1 . 0 ) AKKAY(NLND+l)=LMINUb A r A t ? p n RF01750

T r / Itn PAI AC A\ AHDAU /klTkin 1 \ A A 1 1 1 A IF (MREAL.GE.0) ARRAY (NEND+1 )=CPLUS A A A 1 ^ / A RF01760

11D r A 1 A T A D C / hJD C A 1 \ MKhALA=l Abb (MKLAL

)

RF01770

11 1 h in r Al A / 1 A M1=MKLALA / 10 A l~ A 1 T A A RF01780

a a a hlA H / IAD C Al A 1 A \ M2=M0D (MREALA , 10

)

A r

- A 1 T A A RF01790

AKKAY (NbNU+2 )=L (Ml+1

)

D C A 1 AAA RF01800

ARRAY (NEND+3 )=C (M2+1

)

A ITM A 1 AT A RF01810

AAA 220 ? ir / uii i i it a a hi n hi rr a \ inniu /iitiit i\ a hi t hi i i a IF (XVAL . LT . 0 . . AND . M . GE . 0 ) ARRAY (NINT-1 )=CMINUS A iTM A 1 AAA RF01820

t f~ / vi / 1 i ix a i tm hi ix a \ inni\/ / tinnur i\ a hi t hi 1 1 c IF (XVAL . LT . 0 .. AND . M. LT . 0 ) ARRAY (NP0NE-1 )=CMINUS A A A T A A RF01830

t r / II Al~ / t \ \ AA XA AiCA IF (M.GE . (-1 )

) GO TO 240 A A A 1 A A A RF01840

T 1 hi A A hi r* 1 I 1=NP0NE+1 n i A IT A RF01850

T A hi T hi x ^ I 2=NINT-1 A I- /"\ n y^ y ^\ RF01860

T\f\ A *> A T TT TA DO 230 1=11,12 A r~ A 1 ATA RF01870

230 AAAA\//T\ A / 1 \ ARRAY(I)=C(1) A A A ^ AAA RF01880

A r* X 1 1 A hi RETURN A A A 1 AAA RF01890

A

C

ni IT T hi hi A hi CTAhlTi~TAAhlX TrnftT PUT IN NON-SIGNIFICANT ZEROS nrrti aaa RF01900

240 T A /hi IX 11 f T AAA An hlf"* Hi"-

f\ \ htti inn

IF (M. LT . NSIGDS .OR . MF . NE . 0 ) RETURN ft A A ^ a n A RF01910

T T hi T hi X II (* T A A A

I 1=NINT+NSIGDS n A A 1 A A A RF01920

T *\ a I pi An r" n I 2=NP0NE-1 ft ^ A t a a RF01930

A A f" A T T T T A DO 250 1=11,12 A 1" A 1 A A A RF01940

250 AAAA\//T\ A / •» \ ARRAY(I)=C(1) A r" A 1 A IT A RF01950

RETURN RF01960

END RF01970

272
c

c

c

c

10

20

30

40

C

50

60

70

SUBROUTINE RNDOWN

VERSION 5.00 RNDOWN 5/15/70

COMMON /BLOCKC/ KIO , I NUN IT , I SCR AT ,KBDOUT ,KRDKNT ,LLIST

COMMON /BLOCKX/ INDEX (6 , 8 ), LEVEL

IF AN ERROR

OUT EXACTLY

IS MADE IN A STORED STATEMENT,

WHEN AND WHERE IT OCCURRED.

/10.

THIS ROUTINE PRINTS

A=FLOAT ( INDEX (6 , LEVEL)

WRITE (ISCRAT,50) A

N=LEVEL-1

IF (N) 40,30,20

A=FLOAT (INDEX (6 ,N) ) /10.

WRITE (ISCRAT,60) INDEX (5 ,N+1 )

, INDEX (4 ,N+1 ) ,A

N=N-1

GO TO 10

WRITE (ISCRAT,70) INDEX (5 , 1 ), INDEX (4 , 1

)

RETURN

FORMAT

FORMAT

1.23X)

FORMAT

IT. ,32X)

END

(31H IN COMMAND AT STATEMENT NUMBER , F6 . 1 ,47X)

(10H CYCLE N0.,I4,3H 0F,I4,24H OF PERFORM AT STATEMENT

(10H CYCLE N0.,I4,3H 0F.I4.31H OF EXTERNAL PERFORM

RND 10

RND 20

RND 30

RND 40

RND 50

RND 60

RND 70

RND 80

RND 90

RND 100

RND 110

RND 120

RND 130

RND 140

RND 150

RND 160

RND 170

RND 180

RND 190

RND 200

1RND 210

RND 220

STATEMENRND 230

RND 240

RND 250

F6

SUBROUTINE RNJBK (RNO ,N START .NFINSH) RNJ 10

c VERSION 5.00 RNJBK 5/15/70 RNJ 20

DATA M,FLM/8192,8192./ RNJ 30

c 8192=2**13 RNJ 40

c JB KRUSKAL (1969) ACM, 12, 93-94. RNJ 50

c RNJ 60

c RETURNS RANDOM NUMBER (0,1) IN RNJBK. RNJ 70

c SET NSTART=1 TO START AT BEGINNING, OTHERWISE PREVIOUS NFINSH. RNJ 80

c RETURNS NFINSH FOR LAST NUMBER GENERATED. RNJ 90

c WRITTEN BY DAVID HOGBEN , SEL, NBS . 3/24/69. RNJ 100

c

jf: # $ af: % RNJ 110

K=NSTART RNJ 120

DO 10 1=1,3 RNJ 130

10 K=M0D(5*K,M) RNJ 140

RNO=FLOAT(K) /FLM RNJ 150

NFINSH=K RNJ 160

RETURN RNJ 170

END RNJ 180

273
bUdKUUIlNt KHK1NI RPR 10

c VERSION 5.00 RPRINT 5/15/70 RPR 20

p ********************* ********************=*=**** s(=*************=(=****=*:^pj^ 30

pC RPRINT COLS ++, ++, ... ++ (MAXIMUM OF 50 COLS) (NO OF SD IS 8) RPR A A 40

p RPRINT COLS ++, ++, ... ++ WITH ** SIGNIFICANT DIGITS (49 COL MAX) RPR C A 50

pC DDD KrK T KIT mi C >i 1UTTU ** Cn 1 MUIMAY — 1 1 NUITrtTUIiMBI AMtf 1 It 1 l>ULj ++ .. ++ Wl In jll , ... \r% WIVIA A=l 3 , n W 1 U 1 n+NDLAIMN= 1 C \ DDD Id ) Kr K 60

pc DDD KrK T A 70

p ddrtwt ** rni q rni u/ttu cn ^nu/may—?? mri amk -> Kr \ K 1 N 1 lULj , Wl 1 n D U ... yn WIVIA K=L c , NDLANft.=.? ) DDD KrK A A 80

pC PPRTMT ** mi C , . WITH Cn AKin MUUMAY _ ^WRI AN If— 1 \ K r K 1 N 1 1/ULj , ++ Wl 1 n ,, jU AN U v% nMA A — , , , ... \ HDLMWI\=j ) DDD KrK 90

p DDD Krl\lli I wt1 ** rni L>UL Cj

i i_ uittu cn MUIMA Y mri auk , ++ Wl in , , Z)V N YtlrlAA ,, NDLAINIV ,, ... DDD KrK 1 A A 100

p RPR 1 T A 110

p FLOATING 1PEW.D IS OBTAINED IN LAST TWO OPTIONS IF NWMAX=0

.

RPR 1 A A 120

p W=NSIGDS+5 AND D=NSIGDS-1 RPR T 1 A 130

p FIXED FW.D IS OBTAINED IN LAST TWO OPTIONS IF NWMAX LT 0. RPR 1 it A 140

p W=-NWMAX AND D=NSIGDS RPR 1 C A 150

C IW IS OBTAINED IN LAST TWO OPTIONS IF NSIGDS=0 AND NWMAX=-W. RPR 160

p 1 T A 170

p REPLACES TRAILING ZEROS BY BLANKS IF COUNT LT NRMAX RPR 1 O A 180

p IF COLUMN CONTAINS ALL ZEROS AND FIRST ARGUMENT IS A COLUMN NUMBERRPR 1 O A 190

p NO COLUMN HEADING IS GIVEN RPR o a a 200

p IF FIRST ARGUMENT IS NOT A COLUMN NUMBER (1) NO HEADING IF WIDTH RPR A 1 A 210

LESS THAN 6, (2) COL NO IF 6 LE WIDTH LT 12, (0) COLUMN XXX. IFRPR AAA Z20

p WIDTH GREATER THAN OR RQUAL TO 12. RPR A O A 230

p IF NUMBER IS FLOATED ASTERISK IS PUT TO RIGHT OF FIELD. RPR 1 A A 240

p NUMBERS ARE PRINTED IN BLOCKS OF 5 IF NRMAX IS LESS THAN 49. RPR OCA 250

C WRITTEN BY DAVID HOGBEN , 5EL, NBS . 4/17/69. RPR 260

PVj # £ $ Z- $ * * $ $ # $ $ $ + % * # * * * * :Je jfc rfc # ^ ^ ^ * ^ ^ ^ # ^ ^ ^ ^ + ^ ^ ^ ^ * ^ * * * * * * ^: * ^ i|( * * 4; * * * + * * po 7 n COMMON /ABCDEF / L(48) RPR 2oU

COMMON /BLOCRC/ NRC ,RC (12600) RPR 9 0ft i. 7 U COMMON /BLOCKD / IARGS(IOO) , KIND (100) ,ARGTAB (100) , NRMAX ,NR0W,NC0L ,NRPR JUU

1ARGS,VWXYZ(8) ,NERR0R RPR J 10

DIMENSION ARGS(IOO) RPR 1 9 n > c U EQUIVALENCE (ARGS ( 1 ). RC ( 12501 )

)

RPR

COMMON /BLOCKE/ NAME (4) ,L1 ,L2 , ISRFLG RPR i a a.3 4U

COMMON /SCRAT/ NS ,NS2 ,A (13500) RPR

COMMON /HEADER/ NOCARD (80 ), ITLE (60 , 6 ), LNCNT , I PR INT , NPAGE , IPUNCH RPR 1 L A 360

COMMON /FMAT / IFMTX (6 ), IOSWT , IFMTS (6 ), LHEAD (96

)

RPR 370

p ******************************************************************ppp Oflft j dU

DIMENSION NWIDTH(IOO) , NDECS(IOO), NBLANK ( 100 ) , IRGS(IOO), NCOUNT(RPR lQft

1100), NWMAX(IOO), NSIGDS(IOO) , AL(48), NF(IOO), NWM(IOO) RPR Ann

EQUIVALENCE (NWIDTH ( 1 ), A ( 1001 ) ) , (NDECS ( 1 )

, A ( 1101 ) ) , (NBLANK (1) , A (RPR J l ft 11201)), (IRGS(l) ,A(1301) ) , (NCOUNT(l) ,A(1401) ) , (NWMAX (1 ), A (1601 )) RPR Aon

2, (NSIGDS(l) ,A(1701) ) , (AL ( 1 )

, L ( 1 ) ) , (NF ( 1 )

, A ( 1801 ) ) , (NWM(1 ), A ( 19RPR Aid

301)) RPR A A A 440

p

C

$ * * RPR 4d0

p

c IRGS(I) NEEDED FOR HEADS BECAUSE CHKCOL IS USED RPR A L A 460

p

c LINES 20 TO 70 DO ERROR CHECKING RPR A 7 A

IF (L1.NE.6) GO TO 20 RPR A Q A NARGS=NARGS-1 RPR

IF (KIND(l) .EQ.l) GO TO 50 RPR enn DUU

IF (IARGS(l) .LE .0 .OR . IARGS (1) .GT.NROW) GO TO 60 RPR cin

NRJ=IARGS(1)-1 RPR con 3 C U IF (NARGS.LT.l) GO TO 30 RPR C 7 ft DO 10 I=1,NARGS RPR

KIND (I )=KIND ( 1+1) RPR K^n

IARGS (I )=IARGS ( 1+1

)

RPR

10 ARGS(I)=ARGS(I+1) RPR C7 ft

0 A 20 IF (NARGS.GT.O) GO TO 40 RPR RAO. 30 CALL ERROR (10) RPR 590

274
GO TO 400 RPR 600

40 IF (NRMAX.GT.O) GO TO 70 RPR 610

CALL ERROR (9) RPR 620

GO TO 400 RPR 630

50 CALL ERROR (3) RPR 640

GO TO 400 RPR 650

60 CALL ERROR (11) RPR 660

GO TO 400 RPR 670

C ALL ARGUMENTS ARE INTEGERS. RPR 680

70 NPAR=1 RPR 690

IF (KIND (1 ) . EQ . 1 .OR .KIND (NARGS) .EQ . 1 ) GO TO 90 RPR 700

DO 80 1=1, NARGS RPR 710

NSIGDS ( I )=8 RPR 720

NF (I )=1 RPR 730

NWM(I)=0 RPR 740

NWMAX(I)=13 RPR 750

80 IRGS (I )=IARGS (I

)

RPR 760

CALL CHKCOL (J) RPR 770

IF (J.NE.O) GO TO 50 RPR 780

NA=NARGS RPR 790

GO TO 160 RPR 800

C LAST ARGUMENT IS NOT AN INTEGER, NSIGDS IS GIVEN RPR 810

90 IF (KIND(l) .EQ.l) GO TO 130 RPR 820

LL=0 RPR 830

DO 100 1=1, NARGS RPR 840

IF (KIND (I ) .EQ.O) GO TO 100 RPR 850

LL=LL+1 RPR 860

ARGS (LL)=ARGS ( I

)

RPR 870

100 CONTINUE RPR 880

NL=0 RPR 890

DO 120 1=1, NARGS RPR 900

IF (KIND ( I

) .EQ.O) GO TO 110 RPR 910

NL=NL+1 RPR 920

GO TO 120 RPR 930

110 I2=I-NL RPR 940

IARGS(I2)=IARGS(I) RPR 950

N5IGDS(I2)=ARGS(NL+1) RPR 960

NWMAX(I2)=13 RPR 970

NF(I2)=1 RPR 980

NWM(I2)=0 RPR 990

IRGS (I2)=IARGS (12) RPR1000

120 KIND ( 12 )=0 RPR1010

NA=NARGS-NL RPR1020

NARGS=NA RPR1030

CALL CHKCOL (J) RPR1040

IF (J.NE.O) GO TO 50 RPR1050

GO TO 160 RPR1060

C FIRST ARGUMENT IS NOT AN INTEGER, PARAMETERS ARE GIVEN. RPR1070

130 IF (ARGS(l) .LE.O.) GO TO 50 RPR1080

IRVSP=ARGS(1) RPR1085

NPAR=(NARGS-1) /IRVSP RPR1090

IF (NPAR . NE . 2 .AND .NPAR .NE .3 . AND . NPAR .NE .4) GO TO 30 RPR1100

A ( 1

) =ABS ( FLOAT (NPAR ) * ARGS ( 1 ) +1 . -FLOAT (NARGS )

)

RPR1110

IF (A(l) .GT.O.O) GO TO 30 RPR1120

NA=ARGS (1

)

RPR1130

DO 150 1=1, NA RPR1140

ISUB=2+NPAR*(I-1) RPR1150

IRGS (I )=IARGS ( ISUB) RPR1160

IARGS (I )=IARGS (ISUB) RPR1170

275
pii 1 ihnrf C /TCMD TADPC/T\\ CALL AUKtbb ( lbUd , lARbb ( 1 )

)

RPR1180

ir /TADPC/T\ 1 C A \ PP. TP C A lr ( 1 AKbb ( 1 ) . Lt . 0 ) bU IU 50 n n n n i a a RPR1190

1Mb 1 bUb (1 ) =1 AKbb ( 1 bUB + 1 ) D D D 1 1 A A KrK 1 ZOO

Kl UJM A V / T \ T A DP C / T C 1 1 D • O \ # / M D A D / 1 \ • O O * / 1 MDAD / 1 \ NWMAX (l) = lAKbb(lbUb+<:) (NrAK/3)+Z2 ( 1-IMr AK / 3 ) d n D 1 A 1 A KHK1210

Nr ( 1 )=1 R D D 1 AAA KHK1220

hi UfM / T \ a N WM ( 1

) =0 nnni a o a RPR1230

IP / Al UlAJ A V / T \ rT A \ PP. TP 1 c A

It- (NWMAX ( I ) . b 1 . 0 ) bU IU 150 n nn i a a a RPR1240

T IT I Al MfklA V/T\ IT A \ PfV TP l » A lr (NWMAX ( 1 ). L 1 . 0 ) bU IU 140 n n n i a r a RPR1250

p CI P A T T Al P

r LUA 1 1 1Mb D D D 1 A / A KrKlZoO

IMW1 U 1 n ( 1 ) =IMb 1 bUb ( 1 ) +5 DDDl 07rt Kr K1Z /

0

Al fl C P C / T \ MCTPHC / T \ . O NUtbb ( 1 )=Nb IbUb ( 1 )+Z d n D 1 AAA RHR1280

Al C / T \ 1 Nr ( 1 )=-l nnoi AAA KHK1290

Al Uiftd / T \ 1 NWM( 1 )=-l nnoi O A A KHK1300

TP 1 C A bU IU 150 o n D 1 1 1 A RHK1310

p r 1 AtU DDDl 1 O A KrKl it. 0

IM W 1 U 1 n ( 1 ) =—IM WMA X ( 1 ) DDDl lin KKK1330

NUtLb ( 1

) =Nb 1 bUb (1

)

DDDl 1 A A KPK1340

Nb 1 bUb ( 1

) =8 o n D 1 OCA

AJUfM / T \ 1

[M WNI ( i ) =—1 KrK JOOO

I 5U MDI AMV f I \ T A DP C / T CI ID 1 \ * 1 UD A D / A \ • a * A 1 M D A D / >1 \ IMDLAIMi\ ( 1 )=lAKbb(lbUD+3) (NrAK/4)+3 ( 1—IMr AK / 4 ) DDDl 1 7 A KrK 1.5 / 0

T C / Al D A D m A A Al A Al D 1 A Al 1/ / 1 \ IT "l \ hi D 1 A Al 1/ / 1 \ 1 1 r (NPAK . LQ . 4 . AND . NBLANK ( 1 ) . LT . 1 ) NBLANK ( 1

) =1 n r\ n i o t c RPR1375

p 1 T Al C C l / A TP 1 jl n TAITTTAI T 7 C A Al A PAI 1 CVCADP LINtb 160 IU 240 1N1 1 lALlZt AND LALL rXrAKb KHK1380

lot) TC / Al C D D P D Al C A \ PP TP yl A A lr ( NtKKUK . Nh . 0 ) bU IU 400 DDDl 1 Ct A KHK1390

TC /II AIC £ \ PP TP O 1 A lr (Ll.Nt.6) bU IU 210 onoi A A A KrK1400

T 1 1 1 1 = 1 KrK 140D

TO A

1 2=0 KPK1410

lOD LL=1 DDDl A 1 C KHK1415

TO Al T Al A / A Al A \ TO I2=MIN0 (8 , NA ) +1

2

in n n i a a a RPK1420

Al A AD A a nnn i a a c RPR1425

fl P OAA T T 1 TO UU 200 1=1 1,12 DDDl A 1(\ KrK1430

V T A DP C / T \ . M D 1 K=l AKbb ( 1 ) +NKJ DDDl A A A KKK1440

IF (NWMAX(I) .LE.0) GO TO 170 RPR1450

CALL RF0RMT (RC(K) , 1 , NSIGDS ( I ) ,NWIDTH ( I ) ,NDECS(I) , NWMAX (I) ,A(1) ,A(RPR1460

11) ,0,0) RPR1470

1 in

1 / u IF (NPAR.EQ.l) NBLANK(I)=15-NWIDTH(I) RPR1480

CALL RF0RMT (A,NF(I) , NS IGDS ( I )

, NWI 0TH ( I ), NDECS (I ) ,NWM(I ) ,RC (K) ,A(LRPR1490

1L) , NBLANK (I) ,0) RPR1500

LL=LL+NWIDTH ( I ) +NBLANK ( I

)

RPR1510

IF (NWIDTH(I) .LT.NWMAX(I) .OR.NWMAX(I) .LE.0) GO TO 200 RPR1520

IF (NBLANK ( I

) .EQ.0) GO TO 200 RPR1530

I5=LL-NDECS(I)+NSIGDS(I)-1 RPR1540

IF (A(I5)-AL(39) ) 180,190,180 RPR1550

180 IF (A(I5)-AL(40)) 200,190,200 RPR1560

T A A K=LL-NWIDTH ( I )-l RPR1570

A(K)=AL(41) RPR1580

1 A A 200 CONTINUE RPR1590

NL=MIN0(LL-1,120) RPR1600

WRITE (IPRINT,410) (A ( I ), 1=2 , NL

)

RPR1610

IF(NA.LE.O) GO TO 400 RPR1615

11=12+1 RPR1620

GO TO 165 RPR1625

210 11=1 RPR1630

DO 240 1=1, NA RPR1640

K=IARGS(I) RPR1650

C DETERMINE COUNT OF COL I RPR1660

NC0UNT(I)=NRMAX RPR1670

DO 220 J=1,NRMAX RPR1680

K1=K+NRMAX-J RPR1690

IF (ABS(RC(KD).GT.O.) GO TO 230 RPR1700

276
220 NCOUNT ( I )=NCOUNT ( I )-l RPR1710

230 IF (NCOUNT(I) .GT.NRMAX-3) NCOUNT ( I )=NRMAX RPR1720

IF (NCOUNT(I) .EQ.O) NWIDTH ( I )=NWMAX (I

)

RPR1730

IF (NCOUNT(I) .EQ.O) GO TO 240 RPR1740

IF (NWMAX(I) .LE.O) GO TO 240 RPR1750

CALL RFORMT (RC(K) , NCOUNT (I) , NSIGDS (I )

, NWIDTH (I) ,NDECS(I) , NWMAX ( I

) RPR1760

1 ,A(1) ,A(1) ,0 ,0) RPR1770

240 IF (NPAR.EQ.l) NBLANK(I)=15-NWIDTH(I) RPR1780

c LINES 250 TO 390 CALL FXFORM AND PRINT IN READABLE FORMAT RPR1790

250 IF (L1.NE.8) CALL PAGE (4) RPR1800

14=0 RPR1810

DO 260 1=1 1 , NA RPR1820

I4=I4+NWIDTH(I)+NBLANK(I) RPR1830

IF(I4.LE.120) GO TO 260 RPR1840

14=1-11 RPR1850

GO TO 270 RPR1860

260 IF (I.EQ.NA) I4=NA-I 1+1 RPR1870

270 12=14+11-1 RPR1880

NARGS=I2-I1+1 RPR1890

c FROM HERE TO 290 PUTS IN COL HEADING IF FIRST ARG NOT A COL NO. RPR1900

IF (NPAR.EQ.l) GO TO 290 RPR1910

CALL RFORMT (A , 1 , 1 , 119 , 119 , 0 , 1 . 0 , A ( 1 )

, 0 , 0

)

RPR1920

LL=1 RPR1930

DO 280 1=11,12 RPR1940

LL=LL+NWIDTH ( I ) +NBLANK ( I

)

RPR1950

IF (NWIDTH(I) . LT . 6 .OR . NCOUNT ( I

) .EQ.O) GO TO 280 RPR1960

A(200)=IRGS(I) RPR1970

I5=FL0G10(A(200) )+1.0 RPR1980

CALL RFORMT (A , 1 , 1 5 , 6 , 0 , 0 , A (200 ), A (LL-6 )

, 0 , 0

)

RPR1990

A(LL-1)=AL(45) RPR2000

IF (NWIDTH(I) .LT.12) GO TO 280 RPR2010

A(LL-12)=AL(13) RPR2020

A(LL-11)=AL(25) RPR2030

A(LL-10)=AL(22) RPR2040

A(LL-9)=AL(31) RPR2050

A(LL-8)=AL(23) RPR2060

A(LL-7)=AL(24) RPR2070

280 CONTINUE RPR2080

WRITE (IPRINT.410) (A ( I ), 1=2 , LL

)

RPR2090

GO TO 320 RPR2100

290 IF (L1.EQ.8) GO TO 325 RPR2110

CALL HEADS ( IRGS (11) ,14,0,1) RPR2120

DO 310 1=11,12 RPR2130

IF (NCOUNT(I) .GT.O) GO TO 310 RPR2140

15=12* (I-I1)+1 RPR2150

DO 300 16=1,12 RPR2160

LHEAD(I5)=L(45) RPR2170

300 15=15+1 RPR2180

310 CONTINUE RPR2190

15=12*14 RPR2200

WRITE (IPRINT,420) (LHEAD ( 16 )

, 16=1 , 15

)

RPR2210

320 WRITE (IPRINT,410) RPR2220

325 DO 390 J=1,NRMAX RPR2230

LL=1 RPR2240

DO 350 1=11,12 RPR2250

K=IARGS(I)+J-1 RPR2260

C PRINT BLANKS IF NCOUNT(I) LT NRMAX RPR2270

IF (J.GT.NCOUNT(I)) NDECS ( I )=NWIDTH ( I

)

RPR2280

CALL RFORMT (A , NF ( I )

, NSIGDS ( I ), NWIDTH (I) , NDECS (I) , NWM( I )

, RC (K) ,A(LRPR2290

277
1 1 \ Al D 1 A Al 1/ / T \ A \ 1L ) , NdLANK. ( 1 ) , 0

)

D D D 1 1 A A KHKZ300

LL=LL+Nnl Uln(l)+NDLANK(1) D D D O 1 1 A ir /AIUITr\TU/T\ IT MUfMA Y / I 1 AD M UIMA V / ! 1 1 C As f>n TO 3 C ft 1 r (NWlUln(l).LI. IMWMAA ( 1 ) . UK . N WMAa (l).Lt.U) bU IU 3bU KKKZ3 IQ

T C /AIDIAAII//T\ Cn A \ ftfl TA -1 c A IF (NbLANK ( 1 ) . bQ . 0 ) bU IU 350 n n d i o o a KKK2330

L

DIIT Ikl ACTCDTCtf TC DEAHADI f D C T 1 1 D M C CI flATtUr rU 1 IN AbltKiotv lr KtAUABLt KtlUKNb rLUAIlNb D D D O 1 A ft KrK23'JU

tc ii Mr\CAC/T\.wcTAnc/T\ i 15=LL-NUtbb (1 ) +Nb 1 bub (1 )-l DDD11CA KHK2350

TC / A / T C \ Al nfl l \ lln 1 A f\ lift lr (A ( 1 5

) -AL (3 9 ) ) 330,340,330 KKK2360

1 1 A 330 TC / A / T C \ Al / VI A \ \ 1 C A 1 A ft "3 C A lr (A ( 1 5

) —AL (40 ) ) 3b0,340,3b0 KHK23 /

0

1 A A 340 It7

1 1 MIAIT (ITU ( I \ 1 D DD O 1 a

n

KrK2 JoU

A / 1/ \ Al / VI 1 \ A (K)=AL (41

)

D D D 1 O A A KKK2390

1 C A 350 LUN 1 INUt o n o i >i a a KPK2400

L

T O A A AAD CMCATCC CAD IV 1=2 LUMPtNbA 1 tb r UK IX D O D O il 1 A KKKZ410

N L=LL—

1

D D D 0 A OA KrK242U

U1DTTC / T D D T M T VI 1 A \ / A / T \ T O tvli \ WKlIt ( 1 rK 1 IM 1 , 410 )

( A ( 1 ) , 1=2 , NL ) D D D O VI "3 ft KHKZ430

ab DDTKIT III Q | AAI/C AC CTWC rKlIMI IN bLULKb Ur rlvt D D D O A A ft Kr K244U

tc/ i cn mdmavx rn to ice 1 r ( J . ty . NKMAX ) bU IU JDD D DD O VI VI C Kr K2443

TC /UAH/ 1 C\ CA ft Akin AIDAAAV 1 C A Q \ UIDTTC / 1 DD T MT VI 1 A \ lr ( MUU ( J , b ) . ty . 0 . ANU . NKMAX . Lt . 48 ) WKlIt (lrK!NI,410) D D D O VI C A KrKZ4b0

TC /AAA ft/ 1 1A\ CA ft A AIR AIDAAAV PT A O \ UIDTTC /T DDT AIT VI 1 A \ lr (MUU ( J , 10 ) . ty . 0 . ANU . NKMAX . b 1 . 48 ) WKlIt ( 1 rK 1 N 1 , 4 10 ) D D D O VI L ft KKK2460

aL

ALALL A 1 1 MCUJ D A A C TC MD UA V AT c ft NtW r Abt lr NKMAX bl bU D D D O VI 7 A Kr K24 / 0

ICC i 3 3

i c / aja. n/i cn\ mc n \ a a ta iqa 1 r ( MUU (J,bO).Nt.O) bU IU 390 D D D 0 VI O A KrK2'+0U

TC / I CA AID AAA V\ A A TA 1 ft ft lr ( J . ty . NKMAX ) bU IU 390 D D D O VI O C KrK2485

TC /II AIC Q\ AAII DAAC 1 A \ lr (Ll.Nt.8) LALL r Abt (4) D D D O A Q A KKK2490

TC/ll CA 0\ AA TA ion lr(Ll.ty.8) bU IU 390 D DD O C A A KrK2b00

T c 1 O * T A

1 3=12 1

4

D DD O C 1 A KrK23iU

TC / AID AD AT 1 \ AA Tfl JAfl ir INrHK.ul .1) IjU IU JDU RDRo co a IUDTTC / T D D T Al T xont /IL1CAIY/Tl.\ T L 7 TC\ WKlIt (1KK1NI,420) ( LnbAU ( 1 6 ) , 1 6=1 , 1 5

)

D DD O C 1 ft KKK2530

A A T A 1 O A bU IU 380 D DD O C VI A KrK2b4U

L CDAAA UCDC TA IQft DIITC TAI AAI LICArtTAIA TC CTDCT ADA MAT A AAI MA rKUM HtKt IU 380 rU 1 b IN LUL HbAUlNb lr rlKbl AKb NU 1 A LUL NU . D DD O C C ft KrK2bbU

3 6 0 AAI 1 O C A D AIT Ik 1 7 7 7 A 7 7 O A 7 A A / 7 \ A A \ LALL KrUKMl (A , 1 , 1 , 119 , 119 , 0 , 1 . 0 , A ( 1 )

, 0 , 0

)

D DD O C L ft KKK2560

i i i LL=1 DDD O C 7 A KKK2D /

U

nn i7ii t t i to UU i

1

U 1=1 1,12 D DD 0 C Q ft

II II .MUfTftTU/T\.MQIAMI///T\ LL=LL+NW1 UIH(l)+NbLANK(l) DDD 0 C Q A TC fMUIinTU / I 1 IT L AD MAAI IMT / T \ CA ft\ A A. TA 170. lr (NWlUlrl(l).LI.6.UK.NLUUNI(l).ty.U) bU IU J/U DDDO A ft ft A(£UU) a /7aa\ = lore lKuo(l/ I \

) DDD Kr 0 A T ft R t O L U TC15=rLUblU(A(tUU) CI flfll n / A / 0 ft ft \ \ 1 ft ) +1 .

U

DKrPR 9 A o ft i\ c o <c u AAI 1 D C A D AiT Ik 1 TC L ft ft K 1 Oft ft \ A/ll L \ ft ft\ LALL KrUKMI ( A , 1 , 1 D , 6 , U , U , A ( 2UU )

, A ( LL—0 ), U , U

)

DDDO Al ft A/ll 1\ Al t A C \ A (LL-1 )=AL (4b

)

DDDO Avl ft TC /AlUITftTU/Tx IT ni AA TA "XT ft 1 r (nil I L)IM(l) .LI .12) bU 1 U 3 / U DDDO ACft

A/ID 1*5\ Al /11\ A (LL-1 2 )=AL (

1

i

)

RDRO AAft i\r nzoou

A/ll 1 1 \ Al /OC\ A (LL-ll )=AL \c.O ) RPR?A7ft

A/ll t ft \ Al ZOO\ A (LL-1U )=AL (22

)

DDDO ABft

A/ll ft \ Al /II \ A (LL-9 )=AL (31

)

DDDO AQft

A

A/ll ( LL-8OV)=ALAD OH( 23

)

RDR07 AA

A/ll T \ Al I *% A \ A (LL-7 )=AL (24

)

D DD O 7 1 ft KrK2 / IU

3 1 0 A AMT T All IC LUN 1 1 NUt RPR?7?ft l\r Ia/I / £U

UIDTTC MDDIMT /I1A\ /A/T\ T O II \ WKlIt ( 1 rK 1 N 1 ( 410 )

( A ( 1 ) , 1=2 , LL

)

DDD? 7 o A

O O A 380 1MDITC / T DD T WT A 1 A \ WK1 1 1 ( IrKIN 1 ,410

)

DDD 0 7 vl ft

*> A A 390 A A AIT T All IC CONTINUE DDDO 7 C ft Krr<2 / DU

C

A r\ 1 1 1 C T CAD AAA DC TUAAI O AAI II AAAI

C

ADJUbT r UK MUKt i HAN 8 LULUMNb DKrK2 DD O 7 Aft

/ OU

TC /TO CA AIA\ AA TA A ft ft Ir (I2.bQ.NA) bU IU 400 DDD077ft

TC/I 1 MC 0\ AA TA 1 A C Ir(Ll.Nt.o) bU IU 14D DDD0770

WRITE ( IPRINT , 410) DDD O 7 7 Q Kr K2 110

145 11=12+1 DDD O 7 O ft KrK2 / oU

GO TO 250 DDDO 7 OA KPKZ790

400 n rxi mil RETURN D DD O O 1 A KrKZBlO

a

L DPROOOft

410 rUKMA 1 (IX , 1 19A1

)

DDDonift rvr 1% c. 0 j U 420 FORMAT (8(3X,12A1)) D DD O O VI ft Kr KZ840

END RPR2850

278
c

cc

c

c

cc

c

c

cc

cc

ccc

10

20

30

40

50

60

65

70

80

90

100

110

120

130

140

150

160

170

180

190

200

210

SUBROUTINE SELECT SEL

VERSION 5.00 SELECT 5/15/70 SEL

COMMON /BLOCRC/ NRC , RC ( 12600 ) SEL

COMMON /BLOCKO/ IARGS(IOO) , KIND (100) ,ARGTAB (100) , NRMAX , NROW, NCOL , NSEL

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 )

)

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG

COMMON /SCRAT/ NS , NS2 , A ( 13500

)

ITYPE=1

ITYPE=1

ITYPE=1

ITYPE=2

ITYPE=3

ITPE=5

WRITTEN

COL ++

++

SELECT IN COL ++ VALUES APPROX

STORE IN COL ++ SELECT IN COL ++ VALUES APPROX COL

STORE IN COL ++ TO COL ++ SELECT IN COL ++ VALUES APPROX COL ++ TO WITHIN

STORE ++ TO ++, STORE NUMBER FALLING WITHIN TOL

TO WITHIN **

TO WITHIN

IN

SEL

SEL

SEL

SEL

SEL

SEL

SEL

SEL

SEL

SEL

SEL

COSEL

SEARCH

FROM

IN ++

COL

INTO

++++

FOR NUMBERS

++ INTO ++,

SEL

IN ++, TRANSFER CORRESP VSEL

ETC SEL

SEL

CENSOR COL ++ FOR $$, REPLACING BY $$, STORE IN COL ++SEL

SEL 220

(C)SEL 225

10

20

30

40

50

60

70

80

90

100

110

120

130

140

150

160

170

180

190

200

210

MATCH COLUMN (C) WITH (E) , EXTRACT (E) , PUT IN COLUMN

BY DAVID HOGBEN SEL, NBS . 2/28/70. (CENSOR REVISED)

GO TO (10,100,130,40,130), L2

IF (KIND(3)) 50,20,50

K=3

CALL ERROR (K)

RETURN

IARGS(3)=IARGS(2)

KIND(3)=0

IF (NARGS-4 ) 60,70,80

K=10

GO TO 30

K=ll

GO TO 30

IARGS(5)=IARGS(4)

NARGS=NARGS+1

KIND(5)=KIND(4)

IF (NARGS-6 ) 90,90,60

IF (IARGS(4)-IARGS(5) ) 230,230,20

IF (NARGS-4) 60,110,110

IF (2*(NARGS/2)-NARGS) 60,120,60

CALL CHKCOL (J)

IF (J) 20,200,20

IF (NARGS-4) 60,140,60

CALL ADRESS (1,11)

IF (II) 20,65,150

CALL ADRESS (2,12)

IF (12) 160,65,170

12 = -12

CALL ADRESS (3,13)

IF (13) 180,65,190

13 = -13

CALL ADRESS (4,14)

IF (14) 20,65,200

IF (NRMAX) 210,210,220

K = 9

SEL 230

SEL 235

SEL 240

SEL 250

SEL 260

SEL 270

SEL 280

SEL 290

SEL 300

SEL 310

SEL 320

SEL 330

SEL 335

SEL 337

SEL 340

SEL 350

SEL 360

SEL 370

SEL 380

SEL 390

SEL 400

SEL 410

SEL 420

SEL 430

SEL 440

SEL 450

SEL 460

SEL 470

SEL 480

SEL 490

SEL 500

SEL 510

SEL 520

SEL 530

SEL 540

SEL 550

279
bU 1 U 3 0 C

C 1 ccc btL 555

OOA 220 TC /MTDDAD

MC A\ fft TfiAA lr ( NtKKUK . Nt . 0 ) bU IU 40cc i e l a btL 560

pfi Tfi /ocn den con an tin ^ i o bU IU \ e. 3U , 43U , 3 aU , 4U , 3 a U ) , La CCI cic

230

tc /uprc is i I iPfi? (4 > md ma v,i i ion ion o/in lr ( I AKb J (3 ) — 1 AKb J (1 ) —IMK MA A + l ) I i. U , 1 i. U , L <i U ccic 7 n jlL 3 / U

oAa 240 TADTC/C\

TADPC / /l\ iMDMAY 1 lAKbb ( 3 )=lAKbb (4 ) +IMKMAX — 1 cc i con 3tL 580

pn to i i a bU IU 120cc i con btL 590

C btLtb 1 c

c i /nn btL 600

OCA Zbu nnU ion

T 1 MDMAV

U loU 1 = 1, IMK MA

A cci JtL tin OlU 1 T A DP c / i \ i T 1 L=l AKb J (, 1 ) +1 — 1

cci

aon

r\=l AKbJ^A)+i— 1 cci

an 1 T A DP C / >l \ . T 1 J=l AKbb (4 ) +1-1 cci l a n btL 640 M ki o MA Y T Wt=lM K MA A + 1

CCI / en btL 650

CCIAan 1 fill DP/1 \ A (M)=Kb (L )

ccia 7 n btL 6/0

oaoUa n DC i i \nn CCI jtLAqn OOU

TC" / I T 1 ADPC / C\ illO 7 A OOA OOA lr ( J -1 -1 AKbb ( 5 ) +1 ) 2/0,280,280 cci i on btL 690

o 7 a 2/0 1 Mdnw . 1 J=NKU W+J CCI 7 AA btL 700

bU I U 2 60 CCI btL nn710 0 Q n / oU pniUT T Ml IC i/Un i i nut CCI btL 7 o n / c U ADp5 ABQ ( ADTC /5l \

AKb3=ADb (AKuj ( 3 ) ) cci btL 7 1 n /3U

nnAAAT l MDMAV UU 440 l=i,NKMAA CCI 7 AA btL /40

V KlDMAV . 1 K=NKMAX+1 CCI 7 CA btL 750 1 0 * MDMA Y

L=2 IMK MA

A cci 7 a

n btL / 6U

M 1 * MD MA

V

M=3 IMK MAA

CCI 7 7 A btL / / 0

M_A*MDMAY CCI JtL 7an / ou 1 1= 1 AKb J

(H )

+1—1 cci otL 7an / 7U

11T ADPC f £ 1 , T 1 Jl=lAKbb (6)+l-l CCI OAA btL 800

nnUU inn 1 V 1 3 U U J=r\ , L cci JtL ill

n

O 1 u

AT IDC / AMlkt\\\

A 1 =Abb (A ( 1 ) -A ( J ) )

CCI OOA btL 820

TC / ADP1 AT 1 lAfl OOA OQA lr (AKb3-AI) 300,270,2^0 cci

o i n btL 83U

oon a VU M_M=M+1 M . 1 cciqan btL 84U

A / M\ AT

A ( M ) =A 1

cciocn btL 850

MIM=IMMil+ 1 CCI JtL OAn OOU A / M \ A / 1 \ A (N)=A(J )

CCI btL 07fl O / U inn 3UU PflMT T Ml IC bUlM 1 1 IMUL cci JtL aan OOU

TC 1 M 1 * MD MAY 1 \ 51

n Jin lcp lr (M—3 IMKMAA-1 ) 31U,33U,33U cci JtL non 07U

310 TC IMADPC C\

AAAAAA 1 OA lr (IMAKbb-3) 440,44U,3aU cci JtL onn 7UU

OOA 320 dp / n\aa Kb ( J 1 )=0 . 0

cci btLo i n V1U

pn TPi

AAA bU 1 U 44U cci J C L Qon 7 C U 1 1 o 330 DP/Tll A/M\ Kb ( 1 1 ) =A ( IM ) cci JtL Q^n 7 J U TC /MADPC C\ A A A A A A 1 A (\ lr (IMAKbb-3) 44U,44U,34U CCI JtL QAC\ 74U O >9 A 340 Dp / 1 1 1 1 A RC ( J 1 ) = 1 . 0

cci jtL ocn 73U

r*AT f\AAA bU IU 440 cci JtL

q70Ua n OCA 350 111 ? ^IIDIIAV O Ml=3 NKMAX+2 CCI JtL 07(1 7 / U O Z A 360 I/O A K2=0 cci JtL oon 70U

nn ooa i miM UU 380 J=M1 , M

cci JtL oon 7 7 U TC /A/l\ A/I 1\\ 5 7A OOA OOA lr (A ( J ) -A ( J-l ) ) 3/0,380,380 cci JtLlUUU i nnn

OTA 370 AT

A / 1 \

A 1 =A ( J ) cci i m

n

A / 1 \A / 1 1 \

A (J )=A (J-l) cci J t L i1 non U A u A / 1 *l \ AT A (J-l ) =A I

cci l n i n

JtLIU JU

M 1 . MDMAV N=J +NKMAA CCI 1 0A()

ATA /Ul

A 1 =A (N )

JLL1U cci i ncnJU

A (N )=A (N-l )

cci jtLlUOU i nAn

A / Al 1 \ AT* A (N-l )=AT cci JtL l n7n I u / u

K2=K2+1 cci JtLlUOU i nnn 1 O A 380 PnAITTAIIIC bUN 1 1 NUt OLL1U7U c pi i nan T r" / 1/ O \ OAA OAA OZA IF (K2) 390,390,360 cci JtL 11 11UUnn 3VU M A IMDMAY • 1

IM

=

4 IMKMAA

+ l ccilllO

400 RC(I1)=A(N) SEL1120

280
1 1=1 1+NR0W SEL1130

N=N+1 SEL1140

IF (N-M-NRMAX) 410,410,420 SEL1150

410 IF (I1-I-IARGS(5)+1) 400,400,420 SEL1160

420 IF (NARGS-5 ) 440,440,430 SEL1170

430 RC(J1)=M-3*NRMAX SEL1180

440 CONTINUE SEL1190

GO TO 40 SEL1200

C SEARCH SEL1210

450 I1=NARGS-1 SEL1220

DO 470 I=1,NRMAX SEL1230

K=IARGS(1)+I-1 SEL1240

L=IARGS(2)+I-1 SEL1250

M=NRMAX+I SEL1260

A(I)=RC(L) SEL1270

A(M)=RC(K) SEL1280

J 1=2 SEL1290

DO 460 N=3,I1,2 SEL1300

L=J1*NRMAX+I SEL1310

M=IARGS(N)+I-1 SEL1320

A(L)=RC(M) SEL1330

460 J1=J1+1 SEL1340

DO 470 N=4,NARGS,2 SEL1350

M=IARGS(N)+I-1 SEL1360

470 RC(M)=0.0 SEL1370

K=NRMAX+1 SEL1380

L=2*NRMAX SEL1390

DO 510 I=1,NRMAX SEL1400

AT=ABS(A(I)/1.E8) SEL1410

DO 500 J=K,L SEL1420

IF (ABS(A(I)-A(J) )-AT) 480,480,500 SEL1430

480 Jl=l SEL1440

DO 490 N=4,NARGS,2 SEL1450

M=IARGS(N)+I-1 SEL1460

I1=J1*NRMAX+J SEL1470

RC(M)=A(I1) SEL1480

490 J1=J1+1 SEL1490

GO TO 510 SEL1500

500 CONTINUE SEL1510

510 CONTINUE SEL1520

GO TO 40 SEL1530

C CENSOR OR MATCH SEL1540

520 DO 580 1=1 , NRMAX SEL1550

IF (RC(Il)-RC (12) ) 540,530,560 SEL1560

530 RC(I4) = RC(I3) SEL1570

GO TO 570 SEL1580

540 IF (L2-4) 530,40,570 SEL1590

560 IF (L2.EQ.5) GO TO 570 SEL1600

RC(I4) = RC (11) SEL1610

570 11 = 11+1 SEL1620

IF (KIND(2) .EQ.O) 12=12+1 SEL1630

IF (KIND(3) .EQ.O) 13=13+1 SEL1640

580 14 = 14+1 SEL1650

GO TO 40 SEL1660

END SEL1670

281
SUBROUTINE SET SET 10

C VERSION 5.00 SET 5/15/70 SET 20

COMMON /BLOCKA/ MODE , M, KARD (83 ) ,KARG , ARG , ARG2 ,NEWCD (80 ) ,KRDEND SET 30

COMMON /BLOCRC/ NRC ,RC (12600) SET 40

COMMON /BLOCKD/ I ARGS ( 100 )

, KIND ( 100 )

, ARGTAB ( 100 ), NRMAX , NROW, NCOL , NSET 50

1ARGS ,VWXYZ (8) ,NERROR SET 60

DIMENSION ARGS(IOO) SET 70

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 ) ) SET 80

COMMON /BLOCKE/ NAME (4 ), LI , L2 , ISRFLG SET 90

COMMON /QRS/ NDROW, IFLAG , J ,NNARG SET 100

C THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS SET 110

COMMON /TAPE/ NAME4 (2 ), NTPCT , IPUNCP , INUNIP , L1TP SET 120

COMMON /BLOCKC/ KIO.INUNIT, ISCRAT ,KBDOUT ,KRDKNT , LL I ST SET 130

ISRFLG=1 SET 150

IF (NARGS . EQ . 1 .OR .NARGS .EQ . 2 ) GO TO 10 SET 160

CALL ERROR (10) SET 170

GO TO 70 SET 180

10 M0DE=2 SET 190

CALL ADRESS (NARGS, J) SET 200

IF (J) 20,30,40 SET 210

20 CALL ERROR (3) SET 220

GO TO 70 SET 230

30 CALL ERROR (11) SET 240

GO TO 70 SET 250

40 NDR0W=J+NR0W-1 SET 260

IF (NARGS. EQ.l) GO TO 60 SET 270

IF (KIND(l) .NE.O) GO TO 20 SET 280

IF (IARGS(l) .LE. NROW. AND. IARGS(l) .GT.O) GO TO 50 SET 290

CALL ERROR (16) SET 300

GO TO 70 SET 310

50 J=J+IARGS(1)-1 SET 320

60 IFLAG=0 SET 330

M0DE=2 SET 340

GO TO 80 SET 350

70 IFLAG=1 SET 360

C THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS SET 370

IF (L1TP .NE .48 .AND .L1TP .NE .49) RETURN SET 380

M0DE=1 SET 390

INUNIT=INUNIP SET 400

80 RETURN SET 420

END SET 430

282
SUBROUTINE SETQ STQ 10

C VERSION 5.00 SETQ 5/15/70 STQ 20

COMMON /BLOCRC/ NRC , RC ( 12600 ) STQ 30

COMMON /BLOCKD / IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NSTQ 40

IARGS ,VWXYZ (8) ,NERROR STQ 50

DIMENSION ARGS(IOO) STQ 60

EQUIVALENCE ( ARGS (1 ), RC ( 12501 ) ) STQ 70

COMMON /QRS/ NDROW, IFLAG , J ,NNARG STQ 80

COMMON /BLOCKA/ MODE , M, KARD (83 )

, KARG , ARG , ARG2 , NEWCD (80 ) ,KRDEND STQ 90

COMMON /BLOCKC/ KIO , INUNIT , I SCRAT , KBDOUT , KRDKNT , LLIST STQ 100

COMMON /TAPE/ NAME4 (2 ) ,NTPCT , IPUNCP , I NUN IP , L1TP STQ 110

C CHECK IF END OF ROW HAS BEEN EXCEEDED PREVIOUSLY IN THIS SET. STQ 120

IF (IFLAG. NE.O. OR. NARGS.EQ.O) GO TO 80 STQ 130

C J IS WHERE NEXT DATA ITEM IS TO GO IN COLUMN STQ 140

C JJ IS WHERE LAST DATA ITEM OF THIS SET IS TO GO STQ 150

C NDROW IS ADDRESS OF LAST ELEMENT OF ROW. STQ 160

JJ=J+NARGS-1 STQ 170

IF (JJ .LE. NDROW) GO TO 10 STQ 180

CALL ERROR (201) STQ 190

IFLAG=1 STQ 200

IF (J. GT. NDROW) GO TO 80 STQ 210

JJ=NDROW STQ 220

C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS STQ 230

10 IF (L1TP.NE.48) GO TO 50 STQ 240

K=l STQ 250

DO 30 I=J,JJ STQ 260

IF (KIND(K) .EQ.O) GO TO 20 STQ 270

IF (ARGS(K) .NE.O. ) GO TO 50 STQ 280

GO TO 30 STQ 290

20 IF (IARGS(K) .NE.O) GO TO 50 STQ 300

30 CONTINUE STQ 310

40 INUNIT=INUNIP STQ 320

M0DE=1 STQ 330

RETURN STQ 340

C THIS STATEMENT WAS 10 K=l STQ 350

50 K=l STQ 360

DO 70 I=J , JJ STQ 380

IF (KIND(K) .EQ.O) GO TO 60 STQ 390

RC(I)=ARGS(K) STQ 400

GO TO 70 STQ 410

60 RC(I)=IARGS(K) STQ 420

70 K=K+1 STQ 430

J=JJ+1 STQ 440

NRMAX=MAXO(NRMAX,JJ-NDROW+NROW) STQ 450

C THE FOLLOWING CARDS ARE NEEDED ONLY FOR CSET TAPE STQ 460

IF (L1TP.NE.49) RETURN STQ 470

NTPCT=NTPCT-1 STQ 480

IF (NTPCT.EQ.O) GO TO 40 STQ 490

q s**************************^ * *STQ 500

80 RETURN STQ 510

END STQ 520

283
CIIRRnilTTMF CFTIID CTD o 1 r 10

L VCKjIUIM D.UU jt 1 Ur 3/X3//U CTD 0 1 r

0 ft rnMMDN /ri nrKA / winnF m i^ADn ja^ i karg art, art,9 NFwrn

c

rd i KRnFiun j 1 r 3 u po-mmon /RinPkr/ kin tniiimtt tcprat KRnniiT krdkimt iit^t CTD 4 U COMMON /BLOCRC/ NRC , RC ( 12600 ) STP 0 u COMMON /BLOCKD / IARGS(IOO) ,KIND(100) ,ARGTAB(100) , NRMAX ,NR0W,NC0L ,NSTP L ft 1ARGS VWXYZffU NFRRDR STP 7 n DIMENSION u i. ifiL.ll J l uil ARGSflOO^ n i\ \j J y A. \J \J j STP ou EQUIVALENCE (ARGSd^ RC(1250in STP •j i r q n 7 u COMMON /HEADER /NOCARD ( 80 ) ITLEf&O h) LNCNT IPRINT NPAGE IPUNCH STP i1UUn n COMMON K' \J Ifllf lw 11 //PKSWT r l\ J 11 1 // IHCNT 1 1 1 11 1 , IHTP 1 1 1 1 r STP 1 1 u COMMON /SPRAT / NS NS? A ( T 3 5(10 ^ STP 1 i. U COMMON /ICODE/ NIR ,NID ,NIRD ,LIR , LID , LIRD STP LjU

COMMON /BLOCKX/ INDEX (6 , 8 ), LEVEL STP

C0MM0N/PC0NST/JPC,P(40) ,N(40) STP 1 en 1 3 U COMMON /CONSTS/ PI ,E ,HALFPI ,DEG ,RAD ,XAL0G STP 1 o U THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS STP 1 / u COMMON /ICODTP/ NITP,LITP STP 1 0 u COMMON /TAPE/ NAME4 (2 )

, NTPCT , IPUNCP , I NUN IP , L1TP STP T ft A 190

r ********************************************************

P(1)=PI STP 9 1 n

P (2)=PI STP 99(1 L L U P(3)=E STP 9

P (4)=E STP 9dn

KRDEND=80 STP 9t J<;nu NERR0R=0 STP 9L An0 U LEVEL=0 STP

M0DE=1 STP 9 sn IPRINT=6 STP 9on

IPUNCH=3 STP

INUNIT=5 STP J i u ISCRAT=45 STP

NS=13500 STP n KI0=0 STP •a AO

CALL AERR (-1) STP

NRC=12500 STP

NS2=NS/2 STP 37n

r THESE VARIABLES MUST BE REDEFINED IF A NEW COMMAND IS ADDED STP % Rn

NIR=246 STP

NIRD=29 STP *T W U NID=8 STP din

LIR=300 STP

LID=9 STP H ^ U LIRD=30 STP dan

L THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS STP

NITP=9 STP tuu

LITP=10 STP *t / u INUNIP=INUNIT STP ARO

IPUNCP=IPUNCH STP A ft ft 490

L ******************************************************************5jp

p1/ STP 510

L ** THESE SWITCHES MUST BE SET BEFORE COMPILING. NEEDED INFORMATIONSTP D £. U C FOR PACKING HEADS AND FORMATS. STP c *a f|

L STP JtU

U IHTP- NO. OF HEADINGS PERMITTED. STP j j y THIS IS SET = 50 , HOWEVER IN ORDER TO SAVE SPACE ONE MAY DESIRE STP

TO PERMIT FEWER HEADINGS. IF SO DIMENSION STATEMENT IN PREPAK STP 570

o FOR VARIABLE IHEAD MUST BE CHANGED. SECOND VALUE OF IHEAD INDI- STP J580o w C CATES TOTAL NO. OF HEADINGS STP 590

284
C STP 600

IHTP=50 STP 610

C STP 620

RETURN STP 630

END STP 640

SUBROUTINE SKSYMV (A,NROW,N,K) SKS 10

C VERSION 5.00 SKSYMV 5/15/70 SKS 20

C FOR OMNITAB MATRIX S PEAVY 1/ 3/68 SKS 30

C SKS 40

C A MATRIX TO BE TESTED FOR SKEW SYMMETRY SKS 50

C NROW DIMENSION OF A SKS 60

C N PRESENT SIZE OF MATRIX SKS 70

C K STATUS SKS 80

C K=2 NO SYMMETRY SKS 90

C K=3 EXACT SKEW SYMMETRY SKS 100

C K=4 RELATIVE (l.E-7) SKEW SYMMETRY SKS 110

C SKS 120

DIMENSION A(NROW,NROW) SKS 130

K=3 SKS 140

NN=N-1 SKS 150

DO 40 J=1,NN SKS 160

IF (A(J , J) .EQ.O.O) GO TO 10 SKS 170

K=2 SKS 180

RETURN SKS 190

10 I=J+1 SKS 200

DO 40 L=I,N SKS 210

IF (A(L.J).NE.O.) GO TO 20 SKS 220

T=ABS(A(J ,L) ) SKS 230

GO TO 30 SKS 240

20 T=ABS(1.0+A(L,J)/A(J ,L) ) SKS 250

30 IF (T. EQ.O.O) GO TO 40 SKS 260

K=4 SKS 270

IF (T.LE. l.E-7) GO TO 40 SKS 280

K=2 SKS 290

RETURN SKS 300

40 CONTINUE SKS 310

IF (A(N,N) .NE.O.O) K=2 SKS 320

RETURN SKS 330

END SKS 340

285
SUBROUTINE SORDER SOD

VERSION 5.00 SORDER 5/15/70 SOD

COMMON /BLOCRC/ NRC ,RC (12600) SOD

COMMON /BLOCKD / IARGS(IOO) , KIND (100) ,ARGTAB (100 )

, NRMAX , NROW,NCOL , NSOD

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

C

10

20

30

40

50

60

70

80

90

100

110

120

130

140

150

160

170

180

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )

)

COMMON /BLOCKE/ NAME (4 ), LI , L2 , I SRFLG

COMMON /SCRAT/ NS ,NS2 , A (13500

)

SUBROUTINE BY CARLA MESSINA 221.04

L2=8 FOR SORT, L2=9 FOR ORDER, L2=14 FOR

JUNE 1967

HEIRARCHY

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

TYPE 1 IS HEIRARCHY OF COL ++, STORE IN COL ++ SOD

HEIRARCHY GIVES THE ROW LOCATION OF THE SMALLEST NO. OF THE SOD

THE FIRST COLUMN IN THE FIRST ROW OF THE SECOND COLUMN SOD

THE ROW NO. OF THE SECOND LOWEST NO. OF THE FIRST COLUMN IS STOREDSOD

IN THE SECOND ROW OF THE SECOND COLUMN THE ROW NO. OF THE SOD

LARGEST NO. OF THE FIRST COL IS STORED IN THE NRMAX ROW OF THE 2NDS0D

COLUMN. THE FIRST COLUMN IS UNCHANGED BY THIS COMMAND.

TYPE 2 IS ORDER COLUMNS ++,++,++, ETC

ORDER PLACES EACH ONE OF THE GIVEN COLUMNS IN NUMERICALLY

INCREASING ORDER.

TYPE 3 IS SORT COL ++ CARRY ALONG COLUMNS ++,++, ETC

SORT PLACES THE FIRST COLUMN IN NUMERICALLY INCREASING ORDER

WHILE PRESERVING THE ROW RELATIONSHIPS AMONG THE GIVEN COLUMNS

THESE INSTRUCTIONS CAN BE DONE FASTER IF A MACHINE LANGUAGE

PROGRAM IS SUBSTITUTED FOR THIS ONE.

IF (NARGS) 10,10,40

K=10

CALL ERROR (K)

RETURN

CALL CHKCOL (J)

IF (J) 50,60,50

K=3

GO TO 20

IF (L2-9) 80,80,70

IF (NARGS-2) 10,80,10

IF (NERROR) 30,90,30

IF (NRMAX-1) 100,110,120

K=9

GO TO 20

IF (L2-9) 30,30,210

K3=l

K=IARGS(1)-1

DO 140 1=1, NRMAX

J=K+I

L=NRMAX+I

A(I)=RC(J)

A(L)=I

K1=NRMAX

K1=K1-1

K2=0

IF (Kl-1) 160,160,170

Kl=2

DO 190 1=1, Kl

IF (A(I)-A(I+1)) 190,190,180

CC=A(I)

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

SOD

10

20

30

40

50

60

70

80

90

100

110

120

130

140

150

160

170

180

190

200

210

220

230

240

250

260

270

280

290

300

310

320

330

340

350

360

370

380

390

400

410

420

430

440

450

460

470

480

490

500

510

520

530

540

550

560

570

580

590

286
A ( I )=A ( 1+1 )

SOD 600

A ( I +1 )=CC SOD 610

L=NRMAX+I CAP* SOD 620

CC=A (L) f Aft SOD 630

A(L)=A(L+1)

ca r\ SOD 640

A (L+l )=CC SOD 650

K2=l SOD 660

190 CONTINUE

cA r* SOD 670

IF (K2) 150,200,150 f A r\ SOD 680

200 IF (L2-9) 240,240,220

cAn SOD / A

A 690

210

A (NRMAX+1 )=1 . 0

r*a r\ SOD 700

220 K=IARGS (2)-l SOD 710

DO 230 I=1,NRMAX SOD 720

J=K+I f A r\ SOD 730 i limit v/ t L=NRMAX+I c a r» SOD 740

230 RC ( J )=A (L) SOD 750

GO TO 30 SOD 760

240 DO 250 1=1, NRMAX SOD 770

J=K+I

ca r* SOD 780

250 RC ( J )=A ( I ) C

A f\ SOD ~1

AA 790

IF (NARGS-2) 30,260,260 f*

A r\ SOD 800

260 IF (L2-9) 290,270,270 f a r\ SOD 810

270 IF (NARGS-K3) 30,30,280 f a r\ SOD 820 A ft A 280 1/1 I/O T K3=K3+1 SOD A O A 830

i/ taa/^c/i/ix i K=I ARGS (K3 ) -1CA T\ SOD 840

GO TO 130 SOD 850

290 DO 310 I=2,NARGS f*

AA SOD 860

K=IARGS (I )-l SOD 870

DO 300 J=l , NRMAX SOD 880

L=NRMAX+J CAR SOD ft

AA 890

11 A/I\ r* 1 AA T" i W\ J1=A (L)+FL0AT (K)f*AA SOD 900

300 A(J)=RC(J1) SOD 910

DO 310 J=l, NRMAX SOD 920 1 1 1/ 1 J 1=K+J SOD A *> A 930

310

nA / 1 1 v A/It RC (J1)=A(J )

f*AA SOD 940

GO TO 30 SOD 950

END SOD 960

287
C 1 IDDOI IT T WP CnBTQM ( hi CIIU\ bUM ID

WCDCIflM c nn C n D T C U e lie j7h cnu oUNI c U L

* CAM i\j

COMMON /SCRAT/ NS ,NS2 ,A (13500) A ft

L snRT rni iimn nF products for MATRIX IflH 1 T\ 1 A Mill 1VIU LlTTPI Ir L TPATIflN 1UM 1 1UI1 cnu a ft b0

AFTFR SORTING START SUMMING RFGIN IN MlIiniF OF S0.RTFD mi IIMN L ft 60

L

* cnu 7 ft 1 0

DIMENSION XII] cnu O ft 00

DOIIRI F PRFPTSTON X SAVF SUM SUM Q ft 7U

FOIITVALFNfF fX A^ COM i1UUnn

Ti rF (N^ 11 . NF11 t_ . Ui Pifl TO 1(1 ) uu i u x\j cnu 1 1 ft 1X0

JUIT^A ^ll Jl ) CAM ion i i. yj R FT URN cnM l 7 n

i n 1

U

cnu JUKI

t

1 c_nc? O —ll -J L cnu 1 DU nn in T— 2 n cnu i An

cnu i 7 n

9 n SAVE-X ( T S-lcnu ion

cnu 17U i on

X ( I S ^-SAVE cnu onn iUU

K-l cnu £ 1U

3 U I S-I S-l cnu 9 9 n IFIT <K^ l\ . NEI1L . 0}U / GOVJ V TO1 v 10X w cnu 9 ^n

NP-N ii r —ii 12f c COM jUWI ") An

IF (MODfN 2^ EO 0^ GO TO 40 cnM 9 <;n NP A —KK? jVID I llrH—11 Jt —11 r — J. cnu jUWI 9 An

NPR—NPAx? cnu 9CIV7 n NPC-NS2 ll r v—ll Jt —NPll r cnu jUWI

SIIM=X fNPP ) cnu ion t7U

GO TO 50 cnM inn

a n 4U StJM=0 J U III— \J . DOU\J cnu 1 1 n NPA-NS2-NP iir n—iu t ~iir COM jUWI 9 n NPB-NPA-tl ll r u—llrnti cnM jUWI 3nnJ U

3 u nn An t— 1 np SOM

j

CIU

! uWf= CjUIwi+A I |M_lY ( NPA ^ j_y ( NPR \ \ Ii r M J +A ^ Iir D ; SHM Jmn3 U NPA=NPA-1 SOM JUKI 3 OU

NPB=NPB+1 COM 1 7 n 3 1 V

Z. ft 60 CONTINUE jUWI cnM J OU

RETURN cnu jUWI ion

END S0M 400

288
CIIPDmiTTWC CDAPF jrA CD A i n

L jrn CPA ^ n COMMON /BLOCRC/ NRC , RC ( 12600

)

SPA p u COMMON /BLOCKD / IARGS(IOO) , KIND (100) ,ARGTAB(100) , NRMAX ,NR0W,NC0L ,NSPA a n 4 u

1 ARGC \/WYV7fft\ NFRRflR spa c n rtTMPN^TOKi ARf.CMnn\ CPA a n o u

Fflll T V/AI FNPF fARG^MI Pfunnin spa 7 n rOMMON /HFADER /NOfARD / 80 ^ ITLEf60 ft) LNCNT IPRINT NPAGE IPUNCH SPA Jin n n tf1 r rhiAR£C ^NMrvOJ — iI)^ An4U %o in , ,1U CPA l1 nnu u 1U T—1 — iX nu SPA O r H

I 1 (1 I I u

0 f\ PAN FRRDR f T \ CPA 1 O A 12U

i u RETURN CPA i » n 1 J u J L SPA J r n SPA i An J.4U

Gf) TP. ?f) SPA 1 D U

T _ 7

1 —

J

CPA jrn 1 L f\ loU no to ?n SPA i 7 n 1 / u An T ARGC f 1 \ 1 Hl\U J 1 \ X ) — J- j r H

1 on 10U

<^PA j r H ion 1 7 u IF (NERROR NE 0^ GO TO 30 SPA o n n z u u nnuu «;n T— l i 3 U 1 = 1,

J

CPA or M

o i n <i 1 u

c n WRITE (IPRINT, 60) SPA o o n ZZU

GO TO 30 SPA 0 7 A r

L> SPA 5t4UAn

6(J FORMAT (IX) SPA 250

END SPA 260

289
SUBROUTINE SPINV (A ,M,KK , I S I G ) SPI 10

C VERSION 5.00 SPINV 5/15/70 SPI 20

C 7058MI MATRIX INVERSION WITH MINIMUM ROUNDOFF ERROR ACCUMULATION . SPI 30

DATA ONE/J.O/, ZERO/0. 0/,ER/l. £-8/ SPI 40

DIMENSION A(l) SPI 50

ISIG=0 SPI 60

N=M SPI 70

NN=KK SPI 80

N2=N+N SPI 90

DO 30 J=1,N SPI 100

NJC0L=(N+J-1)*NN SPI 110

DO 30 1=1, N SPI 120

KINJ=NJCOL+I SPI 130

IF (I-J) 10,20,10 SPI 140

10 A(KINJ)=ZERO SPI 150

GO TO 30 SPI 160

20 A(KINJ)=ONE SPI 170

30 CONTINUE SPI 180

C DETERMINE MAXIMUM ABS OF VARIABLE BEING ELIMINATED. THIS BECOMES SPI 190

L=0 SPI 200

40 L=L+1 SPI 210

LCOL=NN*L-NN SPI 220

KLL=LCOL+L SPI 230

IF (L-N) 50,100,200 SPI 240

C FIND THE LARGEST ELEMENT IN THE LTH COLUMN. SPI 250

50 J1=L SPI 260

C=ABS (A(KLL) ) SPI 270

L1=L+1 SPI 280

DO 70 I=L1,N SPI 290

KIL=LCOL+I SPI 300

X=ABS(A(KIL) ) SPI 310

IF (C-X) 60,70,70 SPI 320

C RECORD THE NUMBER OF THE ROW HAVING THE GREATER ELEMENT. SPI 330

60 J 1=1 SPI 340

C C BECOMES THE GREATER. SPI 350

C=X SPI 360

70 CONTINUE SPI 370

C INTERCHANGE ROW Jl WITH ROW L. Jl IS THE ROW WITH THE LARGEST ELEMSPI 380

C TEST TO SEE IF INTERCHANGING IS NECESSARY. SPI 390

IF (Jl-L) 80,100,80 SPI 400

80 DO 90 J=L,N2 SPI 410

JCOL=NN*J-NN SPI 420

KJIJ=JC0L+J1 SPI 430

HOLD=A(KJIJ) SPI 440

KLJ=JCOL+L SPI 450

A(KJIJ)=A(KLJ) SPI 460

A (KLJ )=HOLD SPI 470

90 CONTINUE SPI 480

C IF THE LARGEST ABSOLUTE ELEMENT IN A COLUMN IS ZERO WE HAVE A SINSPI 490

100 IF (ABS(A(KLL) )-ER) 110,110,120 SPI 500

110 I S I 6=4 SPI 510

GO TO 200 SPI 520

C ZERO ALL THE ELEMENTS IN THE LTH COLUMN BUT THE PIVOTAL ELEMENT . SPI 530

120 Ll=l SPI 540

L2=L-1 SPI 550

IF (L2) 130,130,150 SPI 560

130 IF (L-N) 140,170,140 SPI 570

140 L1=L+1 SPI 580

L2=N SPI 590

290
150 DO 160 I=L1,L2 SPI 600

KIL=LCOL+I SPI 610

Z=-A(KIL) /A(KLL) SPI 620

DO 160 J=L,N2 SPI 630

JCOL=NN*J-NN SPI 640

KIJ=JCOL+I SPI 650

KLJ=JCOL+L SPI 660

160 A(KIJ)=A(KIJ)+Z*A(KLJ) SPI 670

IF (N-L2) 40,40,130 SPI 680

C DIVIDE BY DIAGONAL ELEMENTS. SPI 690

170 DO 180 1=1 ,

N

SPI 700

KKK=NN* I-NN+I SPI 710

ZZ=A(KKK) SPI 720

DO 180 J=1,N2 SPI 730

KKI=NN*J-NN+I SPI 740

180 A(KKI)=A(KKI) 111 SPI 750

C RETURN AFTER PUTTING A INVERSE INTO B SPI 760

DO 190 J=1,N SPI 770

JCOL=NN*J-NN SPI 780

NJCOL=NN*N+JCOL SPI 790

DO 190 1=1,

N

SPI 800

KIJ=JCOL+I SPI 810

KINJ=NJCOL+I SPI 820

190 A(KIJ)=A(KINJ) SPI 830

200 RETURN SPI 840

END SPI 850

291
SUBROUTINE STATIS STA 10

C VERSION 5.00 STATIS 5/15/70 STA 20

C S PEAVY STA 30

C OMNITAB COMMAN IS AS FOLLOWS STA 40

C I WITH WEIGHTS STA 50

C A. STATIS COL +++ WEIGHTS +++ START STORING RESULTS +++ STA 60

C (RESULTS WILL BE STORED IN THE NEXT 4 COL) STA 70

C B. STATIS COL +++ WHTS +++ RESULTS +++,+++,+++,+++ STA 80

C II WITHOUT WHTS STA 90

C A. SAME AS I. A. EXCEPT WHTS COL OMITTED STA 100

C B. SAME AS I. B. EXCEPT WHTS COL OMITTED STA 110

COMMON /BLOCRC/ NRC , RC ( 12600 ) STA 120

COMMON /BLOCKD / I ARGS ( 100 ), KIND ( 100 )

, ARGTAB ( 100 ), NRMAX , NROW , NCOL , NSTA 130

1ARGS , VWXYZ (8 ) ,NERROR STA 140

DIMENSION ARGS(IOO) STA 150

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 )

) STA 160

COMMON /SCRAT/ NS , NS2 , A ( 13500 ) STA 170

COMMON /HEADER /NOCARD (80) ,ITLE(60,6) , LNCNT , I PR I NT ,NPAGE , I PUNCH STA 180

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG STA 200

DIMENSION SA(3125,3), ISA (3125 ) STA 210

DIMENSION IB ( 10 ) STA 220

EQUIVALENCE ( A ( 101 )

, I SA) , (A(3226),SA) STA 230

DIMENSION BC0N(4), BKC0N(4), AKC0N(4), AT5(6), CK1(6), DK2(6) ( XKlSTA 240

1(7) , YK2(7) STA 250

DATA BCON(l) ,BC0N(2) ,BC0N(3) , BCON (4 ) /3 . 6948 , -1 . 6561 , .406 ,2 .7764/ ,BSTA 260

1KC0N(1) ,BKC0N(2) ,BKC0N(3) , BKCON (4 ) /7 . 45894 ,-. 89082 , . 61522 , 2 . 56706 /STA 270

2,AKC0N(1) ,AKC0N(2) ,AKC0N(3) , AKCON (4 )/-. 5 1732 ,-. 61863 ,-. 04122 , .5589STA 280

37/ ,AT5 (1) ,AT5 (2) ,AT5 (3) ,AT5 (4) ,AT5 (5) ,AT5 (6) /l .9599640 ,2 .3722712 ,2STA 290

4.8224986,2.55 58497,1.5895341, . 7328982 /, CK1 ( 1 ) ,CK1 (2 ) ,CK1 (3) ,CK1 (4) STA 300

5 ,CK1 (5) , CK1 (6 )/-. 70285 ,-.02006, -.01687 ,-.01447 ,-.01263 , . 67839 /, DK2STA 310

6 (1) ,DK2 (2) ,DK2 (3) ,DK2 (4) ,DK2 (5) ,DK2 (6) /-l .49016, .13384, .09764, .074STA 320

776, .05931, 1 .68641/ ,XK1 (1) , XK1 (2) ,XK1 (3) ,XK1 (4) ,XK1 (5) ,XK1 (6) ,XK1 (7 STA 330

8) /-40. 34387 5, 14. 1365, -2. 743342, .84143957, . 001066 , -6 . 3701507E-6 , 1 . 7STA 340

949484E-8/ ,YK2 (1) , YK2 (2 ), YK2 (3 ), YK2 (4 ), YK2 (5 ) ,YK2 (6 ), YK2 (7 ) /50 . 2982STA 350

$33,-11.395210,6.0537922,1.1542370,-9 .8051279E-4, 5 . 5609437E-6 , 1 . 458STA 360

$4433E-8/ , CONK/1 .959964/ STA 370

DATA ZERO/0 .0/ , ONE/1 .0/ , TWO/2 .0/ STA 380

IF (L2.EQ.1.0R.NARGS.NE.1) GO TO 5 STA 385

CALL ERROR (236) STA 387

RETURN STA 390

5 DO 10 1=1,60 STA 395

10 A(I)=0.0 STA 400

NXC0L=IARGS(1) STA 410

NXWT=IARGS(2) STA 420

IST0RE=1 STA 430

NAR=NARGS STA 440

IWT=1 STA 450

IF (NARGS.EQ.l) GO TO 30 STA 460

IF (NARGS .EQ . 3 . AND . I ARGS (NARGS) . LT . 0 ) GOTO 20 STA 470

GO TO 40 STA 480

20 NARGS=NARGS-1 STA 490

IWT=2 STA 500

30 IST0RE=2 STA 510

GO TO 50 STA 520

40 IF (NARGS .NE .2 .AND .NARGS .NE .3 .AND .NARGS .NE .5 . AND. NARGS .NE. 6) CALL STA 530

1ERR0R (10) STA 540

50 J=NARGS STA 550

CALL CKIND (J) STA 560

IF (J.NE.O) CALL ERROR (3) STA 570

292
60

70

80

90

100

110

AA 1 1 PUI/Prtl / 1 \ CALL LHKLUL (J ) f T

Araa STA 580

TP / | kir

a\AA 1 1 rnnflD / 1 1 \ I r (J.Nt.O) LALL tKKUK (11) f T

A f*AA STA 590 1 r / M D II A V * A 1 C M C \ A A TA L. A lr (NKMAX 4 . Lt . Nb ) bU IU 60 fTA / A A b 1 A 600 A A 1 1 rDDAD / O "1 A \ LALL tKKUK (Z14) fTA / T A STA 610 D CT1 1 D M Kt 1 UKN C T A /OA b 1 A 620 T C / M C D D A D M C A \ DCTI IDM lr (NtKKUK . Nt . 0 ) RtTUKN f T A /OA STA 630 T V M MDUAV f X A / A A STA 640

An

\ MDMA

Y

A ( 1 ) =INKMAa

CTALca

b 1 A 650

1/TADAC / 1 \ K=l AKbb ( 1 ) CTA / / a

b 1 A 660 m= 1 C T A Z7A b 1 A 670

TC /MADCA 1 AD MADCAL\AA TA OA lr (NAK . ty . 3 . UK . NAK . tU. . 6 ) bU IU 80

r

TA /OA STA 680

M 7 VAJ MDAIAV

NZ, W=NKMAA

CTA / nA STA 690

C 1 III

AA bUM=U . 0 C

TA "7AA

b 1 A 700

COA bZ=0 . CTA 7 1 A

b

T

A 710

U/TAACTA 7 OA

b 1 A 720

ACM AJIA/TA AbUMW 1 =0 .

fTA "T 1 A STA 730

nA 7 aT i Tvti

U\J 1 U 1 = 1 , 1 AIM

CTA *7AA

b 1 A 740

CA/TO\ DA / V\ bA ( 1 , Z )=KL (K ) CTA 7 CA

b 1 A 750

CA/T 1\ 1 ACTA 7 £A

b 1 A 760

TCA 1 J

M 1 M

A ( I ) =m

CTA 7 7 A

b 1 A / / U CA/T 1\ DA/l/\ bA ( 1 , 1 )=KL (K ) c T A 7 nn STA 780

\=l\+l fTA -r

A

A STA 790

M=IVI+1 fTA AAA STA 800 n 1 =n 1 +JL . C T A OTA b 1 A 810

CI IU— CI IM CA/T 7 \ OUlVI=oUIVI+oA ( 1 , i. ) C

TAOO fi

b 1 A 8^0

AoUMW ACM MUIT

AC 1 1 MU/T , ADC / CA/TO\\ 1 =AbUMn 1 +Abb ( bA ( 1 , Z ) ) C

TA

ao

a

b 1 A 830

CO Co. CA/TO\ * * o b£=b<d+bA (1 ,2) 2 fTA AAA bTA 840

CIIMUIT CUM bUMn 1 =bUM fTA OCA b 1 A 850 A A TA 1 1 A bU 1 U 111) fTA O L A b 1 A 860 C 1 1 M A bUM=U . fTA OTA b 1 A 870

U/TA fTA

OOA STA 880

CIIMU/TAn oUmll 1 =U . U

CTA AAA

S 1 A 87O

MAMA=1TADAC AKbb ni( Z )

fTA AAA b 1 A 900

COAA bZ=U . 0

fTA ATA b 1 A 910

T U/TO 1 W 1 =2

CTAAOA

b 1 A 9Z0

Air

p u/TA Neb W 1 =0 fTA

AOA

b 1 A 930

AC 1 1 AIU/TA AbUMW 1 =0 .

fTA AAA S 1 A 940

nn 1 AAT 1 TVM UU 100 1 = 1 , 1 ANCTAACA

S 1 A 950

TC /DA/UA\ CAA\ rn TA OA lr ( Kb ( MA ) . tlj . 0 . ) bU IU 90CTAQLA

b 1 A 960

tc i or i ma\ itn n\ wcr u/T wcr u/t i i 1 r ( KL ( MA ) . L 1 . U . U ) Ntonl =Ntbn 1 +1

CTAQ 7 A

b 1 A 9 / U CA/M 0\ DC 1 V \

iA (M,

Z )=KL (K ) C

TAQQA

b 1 A 9oU

CA/U 1 \ DA/ MA

\

bA (M, 3 )=KL (MA ) C

TA AAA

b 1 A 990

TCA / M\M 1 bA ( M) =M

CTA 1 AAA

b 1 A1U00

CA/M "l\ DA IV\ bA (M, 1 )=KL (K ) CTA 1 ATA

b I A1U1U

CO CO. CA/M 0\**0*DA/MA\ bZ=bZ+bA (M,Z)ZKL (MA ) C

TA 1 AOA

C 1 1 M CI 1 M , DC IV\ bUM=bUIVI+KL ( r\ ) C

TA 1 A "JA

b 1 AlO^U

U/T U/T . DA / MA\

W 1 =W 1 +KL ( MA ) C

TA 1 AAA

b I A 1 040

C 1 1 MUIT CA/M 0 \ * DP / MA\ .CM MUIT bUMn 1 =bA ( M , Z ) KL ( MA ) + bUM»? 1 C

TA 1 ACA

b 1 AJ.05U

ACM IIIA/T ACM IJU/T ADC ( CA /IIO\\#DA / IIA\ AbUMWT=AbUMWT+ABb (bA(M,2) ) Kb (MA) f T

ATALA

b 1 A1060

ii ii i M=M+1CTA 1 A 7 A

b 1 A1070

K=K+1

CTA 1 AQA

b 1 AlUoU

IIA IIA 1 MA=MA+1CTA 1 AAA

b 1 A1090

L|7Uf

M -1 NZW=M-1CTA 1 1 AA

b 1 A11U0

TP / II

CA IA/T AT A\ AAII CDDAD / OO 5 \ lr (NtbWT.bi.0) CALL tKKUK (ZZ3)CTA 1 1 1 A

b 1 A1110

TC / II 7 tAI AT A\ AA TA 1 1 A IF (NZW.GT.0) GO TO 110CTA 1 1 OA

b 1 A11Z0

AAI 1 CDDAD / 1 1 A\ LALL tKKUK (ZZ4)CTA 1 1 1 A

b 1 Al 130

DCTMD II Kt 1 UKNCTA 1 1 AA

b 1 Al 14U

A / 0 \ —N7W

O 1 nil JU

A(3)=SUM/A(2) STA1160

293
A 1 A

\—CI IMWT / HUT STA1170 b 1 Al 180

M 1^3 | =r 10 . A(Z)-Z7.)/7U.)

b 1 Al 190 i not Co A ( J 7 )=bZ STA1200 A / 45 \ _ACI IMU/T b 1 A1Z10 A (1j ] =AbUIVIW 1 / V» 1 f T A 1 AAA STA1220 T YM—M7U/ 1 AN=N£W f T A 1 A 1 A STA1230

TYMM1—TYM 1 1ANI»I1 = AAN — 1

CTA 1 AAA

b 1 A1240

T CT—

n

fTI 1 A

CA

b 1 A1250

nn i ^n T—ot ym

CTA 1 1£(1

b 1 A1Z60

TP1 r /cam i i i ic cam i\\ pn Tn Tin \ 1—1 , 1 ) . Lt . OA ( 1 , 1 ) ) bU 1U lJU

CXA 1 ATA bTA1270

h'—T CAM 1 \

CTAT AAA

b 1 A1280

IjH^l—1 )=1 DM ( 1 ) C

TA i inn

b 1 A1Z90 i jfl \ a ) =r^ C T A 1 1 A A b 1 A1300

T—CAM 1 1 \

CTA 1 i 1 n

b 1 A1310

CAM 1 1 \—C AM 1 l jA I 1 —1 , 1 )=3A ( I , 1 ) C

TA 1 1 on

b 1 A13Z0

CAM bA 1 \T ( 1 , 1 )=l

CTA 1 *5OA STA1330

T1 CT_1 o 1 =1 f Til

A4

A

b I A1340

rnwT Lunt mi ip i l

nul

CTA 1 OCA

b 1 A1350

TPlr mct MPm Gn Tn ion ( 1 J 1 .WL . U ) uU 1 U 1 £ U

CTA 1 1 Ln MAI DMA 1 C * A i "> NALr HA= \ . £ D A(Z; f TA 1 O "7 A b 1 A1370

TYA I AA=NALr MAI DUAM HA+1

CXA 1 OAA 5TA1380

TYMA 1 ANA=1TYMAN—MAI NALrDUAHA

CTA 1 OAA

b 1 A1390

TCIIM_ft 1 oUI»l=U . b 1 A1400

TIMCIIM—

n

C

TA 1 A 1 A

b 1 A141U 1 W 1 =u C T A 1 it A A b 1 A14Z0

nfl UU 114UAnTA=1AA,1ANA TYA TYMA

CTA 1 A 1 n

b 1 A1430

M—IW=tI amJA \ I ) C

TA 1 Aan

b 1 A1440

TUiC 1 IM—TWCI IM CAM 1\*CA/M 51 1 noUIV^ 1 nDUNH-1A (1 ,l) bA(NI,j)

CTA 1 /lcn

b 1 A1450

TVUT—TVUT^C

A l M It 1 ni=l nl +jh (m , j ) C

TA 1 A l.n

b 1 A146U

TCIIM—TCIIMiCAM l t 1 jUW= 1 jUIVI+jA ( I , 1 ) CT

A 1 A7n

b 1 A14 / U

A / 7 \—T C||l»; / A i ) \ 9 *PinAT/MAIDUA\\

cTA i aon

b 1 A148U

AA I(o)ft \

—=

Tl U/C njUIYl/ 1 1 M / T1 WTIf 1 CT

A 1 AQ ft.

b 1 A147U

M 9— / M7UIM\ / 0 n £.= ( NZ.W+1 ) i

C. CT

A i cnn

b 1 A13UU

A / C\—CA 1 tiO 1 1 CTA l ci

n

tpir / Mnn / m 7 uuo\ Pn c\\

a ict f a / c\ i ca /mom i\\/t vun ^ muu i nz. w , £ j . ny . u ; A ( 3 ) = (, A ( 3 J +3A ^ N&+1 , 1 J J / 1 nil CT

A i con

b 1 A i D i.U

A 1 L\ /CAM 1\,CAMYM 1\\/T Wf\

A (0 ] = ( iA ( 1 , 1 ) +bA ( 1 AN , 1 j ) / 1 HU

CbT1 Alb A i cmJO * / I 1 i CAMYM 1 1 CAM 1 \ A ( 1 1 )=>A ( 1 An , J. J —3A ( i , i ) CTA i cv! n b 1 A1D4U A I 1 A \ CA/1 1\ A (^4 )=bA (1,1) C T A i c c n b 1 AlDDU A / 1 <; 1 —C A / TYM 1 \ A \ 3 3 ; =3A ^ 1 AN , i ) CTA l cifl

ncivan i \ fin

V LL A=A ( 1 1 ) / 1 U .

CTA 1 C 7 n

b 1 AID / U

VD CAM 1\ AD=bA (1,1)CTA i con

b 1 A1580

VT VD . nciV

A 1 =Xb+UtL

A

cTA i con

b 1 AlDTU

L=l

CTA i £nn

b 1 A1600

UU 170 1=1 , 10

CTA 1 L\n

b 1 A1610

TPn 1 L=0 CT

A 1 Lon

b 1 A16ZU

rr /CA/I 1\ PC VT\ pn TH 1 L

n lr ( bA ( L , 1 ) . bt .XI) bU IU 160CTA 1 tin

b 1 A1630

TPTP . 1 1 b=I b+1CTA 1 AAA

b 1 A164U 1 1.1 L=L+1 C T A 1 L C ft b 1 AlODU

tp i\ mp tym\ pn Tn i cn Ir (L.Nc.lAN) bU IU 13U CTA 1 A Art A(l+DU)=lly CTA 1 t7fl

vt vt . nciY

A 1 =A 1 +UtLX CT

A 1 L

Q

ft

b 1 AlOOU

TC /I /^TT Vkl\ 1* f\ Tf\ inn IF (L.bl.IXNj bU lu 1V0 CTA 1 ton

b 1 A16V0

np iont i t VM UU 180 1=L , 1 XN CTA 17 00 b 1 Al / UU

tc /ca/t i\rc vt nn v\a / l n\a / l n\ . i lr (bA ( 1 , 1 ) . bt . X 1 -UtLX ) A (60 )=A (60 )+l .

CTA 17 1ft b 1 Al / IU

P rtUTT Al 1 1 C

UUN 1 INUt CTA 1 70(1 b 1 Al / C<J nn inn t i tvaiui UU ZOO 1=1 , I XNM1 CTA1 71(1 j 1 Al f JU

SA ( I , 3 )=SA ( 1+1 , 1 ) -SA ( I ,1)

CTA 1 7 A ft

b 1 Al 740

LA=1 STA1750

294
210

220

230

240

250

260

270

280

DO 210 1=1, IXN

K=ISA(I)

SA(K,1)=LA

LA=LA+1

K=0

RNS=0 .

RNSS=ONE

LR=0

DO 250 1=1 , IXNM1

IF (SA (I ,3 ) .NE.O.O.AND.K.EQ.O) GO TO 240

IF (SA ( I ,3) .NE.O.O) GO TO 220

RNS=RNS+RNSS

K=K+1

GO TO 250

K=K+1

RNS=RNS+RNSS

RNS=RNS/FLOAT (K)

DO 230 L=1,K

LR=LR+1

LRR=ISA(LR)

SA(LRR,1)=RNS

LR=LR-1

RNS=0.

K=0

LR=LR+1

RNSS=RNSS+ONE

ICI=0

IPLUS=0

IMINUS=0

IDRUNS=0

IC=0

ADEV=0.0

DEV3=0.0

DEV2=0 .0

DEV=0.0

DEVI=0.0

DEVWT=0.

DEV4=0.0

AK=1.

KWT=IARGS(2)

NRXX=KWT+NRMAX-1

TA=1.0

DO 320 1=1 , IXN

T=SA(I ,2)-A(4)

SA(I,3)=T

DEV=T+DEV

ADEV=ADEV+ABS(T)

DEV2=DEV2+T**2

DEV3=DEV3+T**3

DEV4=DEV4+T**4

DEVI=AK*T+DEVI

AK=AK+1.0

IF (IWT.EQ.l) GO TO 280

IF (RC(KWT) .NE.O.) GO TO 270

IF (KWT.GE.NRXX) GO TO 290

KWT=KWT+1

GO TO 260

TA=RC (KWT)

DEVWT=DEVWT+TA*T**2

STA1760

STA1770

STA1780

STA1790

STA1800

STA1810

STA1820

STA1830

STA1840

STA1850

STA1860

STA1870

STA1880

STA1890

STA1900

STA1910

STA1920

STA1930

STA1940

STA1950

STA1960

STA1970

STA1980

STA1990

STA2000

STA2010

STA2020

STA2030

STA2040

STA2050

STA2060

STA2070

STA2080

STA2090

STA2100

STA2110

STA2120

STA2130

STA2140

STA2150

STA2160

STA2170

STA2180

STA2190

STA2200

STA2210

STA2220

STA2230

STA2240

STA2250

STA2260

STA2270

STA2280

STA2290

STA2300

STA2310

STA2320

STA2330

STA2340

295
290

300

310

320

325

326

330

340

t f I T IT A A \ A A T f\ *\ f\ f\ IF (T . LT . 0 . 0 ) GO TO 300 STA2350

T ni II C T f"i 1 II f i IPLUS=IPLUb+l STA2360

T A T 1 ICI=+1 STA2370

GO TO 310 STA2380

T hi T HI 1 1 C T fcJ T HI 1 I C 1 IMINUb=IMINUS+l STA2390

TAT -i I C I =—1 STA2400

A / T A r f\ T A T \ A A T A •» A A IF (IC.EQ.ICI) GO TO 320 STA2410

I C= I C

I

STA2420

IDRUNS=IDRUNS+1 STA2430

1/ IA/T 1/ UJT . 1 KWI=KWI +1 STA2440

A / 1 1 \ nrW HIT / /A/Ox 1 v A ( 13 )=DEVWT / (A (2 ) -1 .

)

STA2450

A / A \ CCADT / A / 1 1 \ \ A (V )=rbQK 1 (A ( 13 ) ) STA2460

A / 1 A \ A / A \ /TCADT / UJT \ A ( 10 )=A (9 ) /rbQKI (Wl

)

STA2470

A / 1 A \ 1 A A * A / O \ / A / A \ A (14) =100 .A (9) /A(4) ATA a. AAA STA2480

A / A A \ T ni nc A (28 )=IPLUb STA2490

A(29)=IMINUS A T A A ^ A A STA2500

A / 1 1 \ 1 . / 1 #A/'1>0\+A/*lA\/A/0\\ A ( 3 1 )=1 .+(2 .A(Zo)A(29) /A(2)

)

A / O A \ CCADT//A #A/AO\stcA/AA\:fe/A A(32)=r5QRT((2.A(28)*A(29)*(2

C T A A C" 1 A STA2510

A A / A A \ 3k A / A A \ A / A A \ .A(28)*A(29)-A(28)- A / *\ A \ \ v / / / A / <"» r\ \ A T A at A a A (29) ) ) / ( (A (28) +STA2520

1A(29) )**Z* (A(2)-l . ) )

)

C T A A C 1 A STA2530

A(36)=(DEV3/A(2) )**2/ ( (A(2)-l

.

) /A(2)*A(13) )**3 b I A2540

A(37)=(DEV4/A(2) ) / ( (A (2 )-l . ) /A (2 ) *A (13) ) **2 STA2550

A ( j o

)

=bUMn

1

STA2560

nA 1(1UA(\ \— nFVU/T ) =UC. V W 1 STA2570

A(30)=IDRUNS CTAicon

A / 111 / A / 1ft \ A (11 M / A / 1 9 \ A(.*.?) = (A(.JU)-A(.J1))/A(JZ) C T A O C O A A ( IV )=1Z . Utv 1 / (A (Z ) (A(Z)Z—1 • ) ) C T A A Z A A 5TA2600

A (20)=FSQRT ((l./(A(2)-2.))*(12 . *DEV2 / (A (2 ) * (A (2 ) ** 2-1 . ) )-A(19)**2)STA2610

1)

A T A A / A A b 1 A2620

A(21)=A(19) /A(20) C T A A / OA bTA2630

A A 1 1 A A A A / Alir a / <-t \ Aiir n , n i ,4; CALL PR0B (0NE,A(2)-0NE ,A(21)* A(21) ,A(22)

)

STA2640

ATI- /s D I F=0 STA2650

IRUN=1 STA2660

DO 325 1=2, IXN C T A A L L C 5TA2665

T A A A / T a i A * / T n *\ \ TA=SA(I ,2)-SA(I-l ,2)

C T A A t T A 5TA2670

IF(TA) 326,325,326 C T A A L T C STA2675

CONTINUE A T A A y A A STA2680

A A *» O A T A TX/AI DO 330 1=2, IXN f T A A / AC STA2685

T=SA(I ,2)-SA(I-l,2) A T A A / A A 5TA2690

DIF=DIF+T**2 ATA A T A A STA2700

IF (TA*T.GE.0.0) GO TO 330 C T A A T 1 A STA2710

TA=T C T A A A" A A bTAZ720

IRUN=IRUN+1 A T A A T O A bTA2730

CONTINUE b 1 AZ740

A(23)=IRUN CTA07CA b 1 AZ / bU

A(26)=DIF/(A(2)-1.) CT A 9 7 Afl b 1 At / OU

A(27)=A(26) /A(13)

A(41)=A(4)*FSQRT(WT) /A(9)

CT A 0 7 7 n b 1 At / /

U

CT A 0 7 Q f» b 1 AZ / OU

A(12)=ADEV/A(2) STA2790

NU=NZW-1 ATA A A A A STA2800

VNU=NU f* T A A A 1 A STA2810

T=ZER0 CTAIQ^A b 1 AZ8Z0

TK1=ZER0 CTA161A b 1 AZ830

TK2=ZER0 b 1 AZ840

IF (NU.GE.5) GO TO 350

C T A A A C A STA2850

DO 340 1=1,4 CT A 0 Q A ft b 1 AZooU

V=I/NU CT A9 fl7 ft O 1 Ato /

U

T=T+BC0N(I)*V CT A 0 Q Oft b 1 AtOOU

TK2=BKC0N(I)*V+TK2 CTAOQQft O 1 H4O7U

TK1=TK1+AKC0N(I)*V STA2900

296
GO TO 400 STA2910

350 T=( ( ( (AT5 (6) /VNU+AT5 (5) ) /VNU+AT5 (4) ) /VNU+AT5 (3) ) /VNU+AT5 (2) ) /VNU+ASTA2920

115(1) C T A 9 Q 1 n O 1 A A 7 J U tc /mm n i n \ r n th 1 r (NU.bl.10) bU IU 3/0 C T A 9 O A A

b 1 AA74U

ri a i l f\ t i

' UU 360 1=1 ,

0

C T A 9 O C A

b 1 AA7DU

V/ , T A \ /Mil V= ( 1 +4 ) /NU C T A 9 A L A b 1 A2960

1 M= 1 M+LM (1 ) V

C T A 9 A 7 A

b 1 AA7 /

U

360 Tl/ 9 TI^O . TWO / T \ #*Vl1 KZ= 1 Ka+UKa ( 1 ) V

C T A 9 O O A

b 1 AA700

bU 1 U 4U0 C T A 9 O A Ab 1 AA77U

i t rt 370 tc /mii n inni rn m ion lr (INU.bl .1UU) bU IU J7U c t a i n n n b l A JUUU

n n i q a t i 7 UU 3 80 1 = 1 ,

/

C T A "2 A 1 A b 1 A3010

W \/ M 1 1 * * / T A \ V=VNU ( 1 -4

)

C T A 1 A 9 A b 1 A30Z0

1 In 1=1 M+AM ( I ) V b 1 A }\)}\J

ion 380 TI//9 TI//9.VI//9/T\*W ll\A=lr\A + Tr\A (1 J V b 1 A JU4U

art UU to1 u Ann HUU QT A n c. n

i o a 390 \/9 Vi=rCCnDT / TU/n* WMI 1 1 j(JK 1 (1 wu vnu ) C T A 1 A A A

b 1 A3060

\/9M1 CCnDT / TU/n * WMI 1 DIUP t v ^ ivii=r du.k i ( i wu vnu—uiMt) C T A 7 A 7 A b 1 A .5 U / U Tkl —V9 1 (^nillk iUOMl 1

1 M=V A / ^UUNN+ VAIVIl ) b 1 A JUbU

Ttf9_V9 / / rnWI^ •V/9MT \

1 l\ A=V A / ( —bUNr\ + v AMI ) CT A 'J AO A b 1 A^UVU

Ann tuu A

A / 1 R 1 A / A 1 T * A / 1 n 1 ( 1 3 ) =A ( 1 ) — 1 A(1U) ct a jinn b 1 A^ 1UU

A / 1 L \ A / A \ . T # A / 1 A 1 A ( 1 6

) =A ( 4 ) + 1 A ( 1 0

)

CTA11 1 A

b 1 A3 110

AA 1 1 7 \ Ttf 1 * A / O \ (1/ )=l M A ( 7 ) 9 A b 1 AJ

1

aU

c t a i i in

pl> CTADT O 1 AK 1 DBTMT rl\ 1 N 1 OUT UU 1 CT A 7 1 Art b 1 A i 14U

tplr i\(LZ.ty.A) o cn ? i rnoU TnIU c^n DoU CT A 7 i cn b 1 Aj 1DU

bALL rAbt (4; C T A "2 1 Z. A b 1 A3 160

tc / t u/T cn :i rn Tn at n ir (lnl.ty.ii) bU IU 41U C T A 1 1 7 A b 1 A j 1 / U U/DTTC /TDDTMT A A (\ \ MVPni M7UI WK 1 1 t (lrKlNI,64U) NAbUL , NA.W C T A 2 1 OA b 1 A3 loO rn Tn a a n bU 1 U 44U C T A 1 1 OA b 1 A3 1V0

a i n 41U TCir /M7U/ MC MDMAYl rn Tn aio ( NL W . Nt . IMKMAA ) bU IU 4AU C T A 1 9 A A b 1 A j a U U U/DTTC /TDDTMT ten \ MYmi MYUJT M7U/ Wr\ lit \ I r K 1 IN 1 ,o5U) NAUUL,INAWI , ni.it CT A 7 9 1

n

b 1 A i a IU

r n ta >i i a bU IU 430 C T A "3 9 9 A

b 1 A3 a AO

a o n 4 aU U/DTTC BR lit /TDDTMT llrr\llll,OOUJ A A fl \ MYPni W AUUL MY U/T M7Uf MDMAY , HAW 1 , HA II , NKIVIM A CTA7 J 1 A 3

9A 3\i in

430 U/DTTC nKiit /TDDTMT (irnini A7rtl , o /

u

) CTA79An

AAn nnUU a13Ur n t1=1— l

, inIU CTO 1 AA 3

% 9A DURn

4DU a r n TD/T\ A / T i R n 1 ID ( 1 )=A ( 1+DU J CT A 1 9 A n b 1 AJ/.DU

U/DTTC /TDDTMT AOA\ / T B / 1 \ T 1 in\ WK 1 It ( IrKIN 1 , ooU ) ( 1 D ( 1 )

, 1=1 , IU

)

C T A 7 9 7 A b 1 A J A / U U/DTTC WKlIt /TDDTMT (lrKllMI,07U) AOn\ CT A 7 9 on

U/DTTC WK lit /TDDTMT 7nn\ /AM ,11 A M .01 T_i A\ (lrKllMI,/UU) I A ( i+i ) , A \ I +0 ) ,1 = 1,0) CTo 1 AJ/.7U A 1 9 on

U/DTTC /TDDTMT 71 (11 /A/T\ T-l ? 1 Ol WK lit (lrKlNI,/lU) (A(1;,1=1D,18) CTA 'inn

UID TTC /TDDTMT 71(11 /A/Tl A (T .HI T — TO 991 WK lit (lrKllNI,/AU) (A(l),A(l+lD) ( i = l7,AA), /(AA /( T 1 T _ 1 ) , 1 = 3 a Ail JO ,41

J

CT A mn J 1 Aj 3 IU

f D / 1 i A / 1 1 1 lb(l)=A(Z3) CT A

1

X 9 n b 1 AJ J AU

ID )=A [co

)

CT A ill

n

TO / I \ A/OQX lb (3 )=A (29

)

CTAl iAn O 1 Aj

Id (4 )=A (30

)

CT A I i c n 0 1 A 3 3 D U

UID TTC /TDDTMT 7in\ TO / 1 \ h ( AO \ K / O A \ h / A 1 \ WK1 It (IrKlNI ,730) lD(l) , A (4^ ) ,A(^4) , A (43

)

/ A / T \ T

, (A ( 1 ) , 1 =29C 971 / TD / T 1 5,27) , (1B(1) TCTAllAn , 1 b

1

n330V

1 O A \ /A/T\ T 11 11 \ 1=2 ,4 ) , (A ( 1 )

, 1=31 ,33

)

CT A 11 7 n b 1 A 3 3 1 U WK 1 1 1 ( IrKIN 1 , 740

)

C T A 1 1 O A

b 1 A33U0

l/D TCA/lx KB=1 bA ( 1

)

CT A no n b 1 l\3 37\}

T_C A / k" R 9 1

1 =jA ( r\D , A ) CTAidnn J 1 HJHUU

1 T 11 C D A A L 1 Ntr=40 CT A IA 1

n

b 1 AJ*HU

I Tijr n LINt=0 CTAiAIA b 1 A J4 aU

i ill t * n/^r / n \ Lw=IARGS (2

)

C T A 1 A 1 A b 1 A3430

A A CIA T 1 TV DO 520 1=1 , 1 XNM1 b 1 A.J44U

tc /i tmcd i t a a \ nn Tn A7n lr (LlNtr.LI .40) bU IU 4/U CTAlARn

1 TMCD—

n

L i wtr=u J 1 n3 t O w CALL PAGE (4) STA3470

WRITE (IPRINT,750) STA3480

IF (IWT.EQ.l) GO TO 460 STA3490

297
460

470

480

490

500

510

520

530

540

550

560

570

580

590

WRITE (IPRINT ,760)

GO TO 470

WRITE (IPRINT, 770)

K=ISA(I+1)

TA=SA(K,2)-T

GO TO (500,480) , IWT

IF (RC(LW) .NE.O.O) GO TO 490

LW=LW+1

GO TO 480

WRITE (IPRINT, 790)

LW=LW+1

GO TO 510

WRITE (IPRINT, 780)

T=SA(K,2)

LINE=LINE+1

IF (LINE. NE. 10) GO TO 520

LINE=0

LINEP=LINEP+10

WRITE (6,800)

CONTINUE

(IWT.EQ.l) GO TO 550

I ,SA(I ,2) ,SA(I ,1) ,SA(I ,3) ,RC(LW) , ISA ( I ) ,T ,TA

I,SA(I,2) ( SA(I,1),SA(I,3),ISA(I),T,TA

STA3500

STA3510

STA3520

STA3530

STA3540

STA3550

STA3560

STA3570

STA3580

STA3590

STA3600

STA3610

STA3620

STA3630

STA3640

STA3650

STA3660

STA3670

STA3680

STA3690

STA3700

STA3710

STA3720

STA3730

) ,RC(LW) ,ISA(NZSTA3740

STA3750

600

610

IF

IF (RC(LW) .NE.O.O) GO TO 540

LW=LW+1

GO TO 530

WRITE (IPRINT, 790) NZW , SA (NZW, 2 )

, SA (NZW, 1 ), SA (NZW,

3

1W),T

GO TO 560 STA3760

WRITE (IPRINT, 780) NZW, SA (NZW, 2 )

, SA (NZW, 1 ) , SA (NZW, 3 )

, ISA (NZW) ,T STA3770

IF (IST0RE.EQ.2) RETURN STA3780

IF (NARGS.EQ.2 .OR.NARGS .EQ.3) GO TO 570 STA3790

L=IARGS (NARGS-3 ) STA3800

M=IARGS (NARGS-2 ) STA3810

K=IARGS (NARGS-1 ) STA3820

J=IARGS (NARGS ) STA3830

GO TO 580 STA3840

L=IARGS (NARGS) STA3850

M=L+NROW STA3860

K=M+NROW STA3870

J=K+NROW STA3880

DO 590 1=1, NZW STA3890

MB=ISA(I) STA3900

RC(K)=SA(MB,2) STA3910

RC(M)=SA(I ,1) STA3920

RC(J)=SA(I,3) STA3930

M=M+1 STA3940

K=K+1 STA3950

J=J+1 STA3960

IF (NZW.EQ.NRMAX) GO TO 610 STA3970

NZW1=NZW+1 STA3980

DO 600 I=NZW1,NRMAX STA3990

RC(M)=0. STA4000

RC(K)=0. STA4010

RC(J)=0. STA4020

M=M+1 STA4030

K=K+1 STA4040

J=J+1 STA4050

NT0P=60 STA4060

IF (NROW.LT.NTOP) NTOP=NROW STA4070

DO 620 I=1,NT0P STA4080

298
620

630

C

640

650

660

670

680

690

700

710

720

730

740

750

760

770

780

790

800

RC(L)=A(I)

L=L + 1 IF (NRMAX.LT.60) RETURN

DO 630 I=61,NRMAX

RC(L)=0.

L=L+1

RETURN

STA4090

STA4100

STA4110

STA4120

STA4130

STA4140

STA4150

STA4160

I4,33X,4HN = ,14) STA4170

I4,8X,15HWEIGHTS INSTA4180

STA4190

I4,8X,15HWEIGHTS INSTA4200

1 COL ,I4,6X,4HN = ,I4,33H(N0 OF NON-ZERO WTS) COL LENGTH =,14) STA4210

FORMAT (1H0,24X,64HALL COMPUTATIONS ARE BASED ON OBSERVATIONS WITHSTA4220

FORMAT

FORMAT

(1H0 ( 4X,28HSTATISTICAL

(1H0,4X,28HSTATISTICAL

1 COL ,I4,6X,4HN = ,14)

FORMAT (1H0 , 4X , 28HSTATI STICAL

ANALYSIS

ANALYSIS

OF

OF

COL

COL

ANALYSIS OF COL

(1-6) ,7X, 1016)

2) ,34X,28HMEASURES

1 NON-ZERO WEIGHTS)

FORMAT (1H0/15X,28HFREQUENCY DISTRIBUTION

FORMAT (1H0/5X,26HMEASURES OF LOCATION (2-

1SPERSI0N (2-6))

FORMAT (1H0,

1 9X,26HUNWEIGHTED MEAN =, 1PE15

2 26HSTANDARD DEVIATION =, E15

310X,26HWEIGHTED MEAN =, E15

4 26HS.D. OF MEAN =, E15

510X,26HMEDIAN =, E15.7

6 26HRANGE =, E15.7

710X,26HMID-RANGE =, E15.7

8 26HMEAN DEVIATION =, E15.7

910X,26H25 PCT UNWTD TRIMMED MEAN= , E15.7

A 26HVARIANCE =, E15.7

B10X,26H25 PCT WTD TRIMMED MEAN =, E15.7,20X,

C 26HC0EFFICIENT OF VARIATION =, E15.7 ) FORMAT (1H0//20X,50HA TWO-SIDED 95 PCT CONFIDENCE INTERVAL

IN IS1PE11.4 ( 3H TO, Ell. 4, 6H (2-2 ) /20X , 50HA TWO-SIDED 95 PCT

2NCE INTERVAL FOR S.D. IS, Ell. 4, 3H T0,E11.4,6H (2-7))

20X

20X

20X

20X

20X

STA4230

STA4240

OF DISTA4250

STA4260

STA4265

STA4270

STA4275

STA4280

STA4290

STA4295

STA4300

STA4305

STA4310

STA4315

STA4320

STA4325

STA4330

FOR MEASTA4350

C0NFIDESTA4360

STA4370

FORMAT (1H0//5X,30HLINEAR TREND STATISTICS (5-1) , 30X , 16H0THER STASTA4380

1TISTICS//10X,5HSL0PE,20X,1H=,1PE15.7,20X,7HMINIMUM,18X,1H=,E15.7/1STA4390

20X,13HS.D. OF SLOPE , 12X , 1H=, E15 . 7 , 20X , 7HMAXIMUM, 18X , 1H= , E15 . 7 /10X , STA4400

326HSL0PE/S.D. OF SLOPE = T = , E15 . 7 , 20X , 8HBETA ONE , 17X , 1H=,E15 .7 /1STA4410

40X,35HPR0B EXCEEDING ABS VALUE OF OBS T = , 0PF6 . 3 , 20X , 8HBETA TWO , 17STA4420

5X,1H=,1PE15 .7/71X.17HWTD SUM OF VALUES , 8X , 1H= , E15 . 7 /71X , 18HWTD SUMSTA4430

6 OF SQUARES, 7X , 1H=, E15 . 7 /5X , 24HTESTS FOR NON-RANDOMNESS , 42X , 26HWTDSTA4440

7 SUM OF DEVS SQUARED =,E15.7/71X, 11HSTUDENT/S T , 14X , 1H= , E15 .7) STA4450

FORMAT (10X,26HN0 OF RUNS UP AND DOWN = , 1 5 , 30X , 26HWTD SUM ABS0LUSTA4460

1TE VALUES =,1PE15.7/10X,26HEXPECTED NO OF RUNS = , 0PF7 . 1 , 28X , STA4470

226HWTD AVE ABSOLUTE VALUES = , 1PE15 . 7 /10X , 26HS . D . OF NO OF RUNS STA4480

3 =,0PF8.2/10X,26HMEAN SQ SUCCESSIVE DIFF =, 1PE16 . 7 / 10X , 26HMEANSTA4490

4 SQ SUCC DIFF/VAR = .0PF9 .3// /10X , 24HDEVIATI0NS FROM WTD MEAN/ /1STA4500

55X,21HN0 OF + SIGNS =, I5/15X ,21HN0 OF - SIGNS =I5/15X ,STA4510

610HN0 OF RUNS,10X,1H=,I5/15X,21HEXPECTED NO OF RUNS = , F7 . 1

/ 15X , 12HSTA4520

7S.D. OF RUNS, 8X,1H=,F8.2/15X,21HDIFF. /S.D. OF RUNS =F9.3) STA4530

FORMAT (/////68H NOTE - ITEMS IN PARENTHESES REFER TO PAGE NUMBER STA4540

UN NBS HANDBOOK 91) STA4550

FORMAT (//27X,12H0BSERVATI0NS,47X,20H0RDERED OBSERVATIONS) STA4560

FORMAT (1H0,8X,1HI ,9X,4HX(I) , 9X , 4HRANK , 7X , 9HX ( I

) -MEAN , 7X , 4HW( I ) ,16STA4570

1X,3HN0. ,8X,4HX(J) , 10X , 11HX ( J+l )-X (J ) ) STA4580

FORMAT (1H0,8X,1HI,9X,4HX(I) , 9X ,4HRANK , 7X , 9HX ( I

) -MEAN , 27X , 3HN0 . ,8XSTA4590

1,4HX(J) ,10X,11HX(J+1)-X(J)

)

FORMAT (I10,1PE17.7,0PF9.1,1PE17

FORMAT (I10,1PE17.7,0PF9.1,1PE17

FORMAT (1H ) END

7,22X,I6,1P2E17.7)

7,1PE12.3,10X,I6,1P2E17.7)

299

STA4600

STA4610

STA4620

STA4630

STA4640
SUBROUTINE STMT (NSTMT) STM 10

C VERSION 5.00 STMT 5/15/70 STM 20

COMMON /BLOCKA/ MODE , M,KARD (83 ) ,KARG ,ARG ,ARG2 , NEWCD (80) , KRDEND STM 30

C STM 40

C THIS SUBROUTINE ASSEMBLES AND CHECKS A STATEMENT NUMBER. STM 50

C STM 60

C CALLED BY. . .MAIN. STM 70

MISC=10*KARD(M) STM 80

10 M=M+1 STM 90

K=KARD (M) STM 100

IF (K.GE.10) GO TO 30 STM 110

MISC=10* (MISC+K) STM 120

IF (MISC. LT. 10000) GO TO 10 STM 130

C STM 140

C ILLEGAL STATEMENT NUMBER EXIT STM 150

C STM 160

20 KARG=1 STM 170

RETURN STM 180

C STM 190

C NON-NUMERIC FOUND, IS IT A . STM 200

C STM 210

30 IF (K.EQ.37) GO TO 50 STM 220

C STM 230

C IS IT A / STM 240

C STM 250

40 IF (K.EQ.36) GO TO 70 STM 260

C STM 270

C IS IT A SPACE STM 280

C STM 290

IF (K-44) 20,60,20 STM 300

C STM 310

C . FOUND, MUST BE FOLLOWED BY ONE AND ONLY ONE NUMERAL STM 320

C STM 330

50 M=M+1 STM 340

K=KARD (M) STM 350

IF (K.GE.10) GO TO 20 STM 360

MISC=MISC+K STM 370

60 M=M+1 STM 380

K=KARD (M) STM 390

GO TO 40 STM 400

70 M=M+1 STM 410

K=KARD (M) STM 420

C STM 430

C / FOUND, MUST BE FOLLOWED BY BLANKS THEN/OR A LETTER STM 440

C STM 450

IF (K.EQ.44) GO TO 70 STM 460

IF (K.GE.36.0R.K.LT.10) GO TO 20 STM 470

C STM 480

C LEGAL STATEMENT NUMBER FOUND STM 490

C STM 500

NSTMT=MISC STM 510

KARG=0 STM 520

RETURN STM 530

END STM 540

300
SUBROUTINE STORE (J) STO 10

C VERSION 5.00 STORE 5/15/70 STO 20

COMMON /BLOCKA/ MODE , M, KARD (83 )

, KARG , ARG , ARG2 , NEWCD (80 ), KRDEND STO 30

COMMON /BLOCKB / NSTMT , NSTMTX , NSTMTH , NCOM, LCOM, IOVFL , COM( 2000 ) STO 40

COMMON /BLOCRC/ NRC ,RC (12600 ) STO 50

COMMON /BLOCKD/ I ARGS ( 100 )

, KIND ( 100 ), ARGTAB ( 100 ), NRMAX , NROW, NCOL , NSTO 60

1ARGS , VWXYZ (8 ) ,NERROR STO 70

DIMENSION ARGS(IOO) STO 80

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )

) STO 90

COMMON /BLOCKE/ NAME (4 ), LI , L2 , I SRFLG STO 100

C STORAGE LAYOUT.. STATEMENT NUMBER STO 110

C NUMBER OF WORDS IN ENTRY STO 120

C NARGS+64*(L1+64*L2) STO 130

C ALL ITEMS ARE STORED IN ( ENTRY 1 ) STO 140

C FLOATING POINT TO ALLOW ( 2 ) STO 150

C CONVERSION TO DOUBLE- STO 160

C PRECISION. ( LAST WORD ) STO 170

C STO 180

IF (IOVFL. NE.O) RETURN STO 190

IZE=J+2 STO 200

IF (NSTMT. GT. NSTMTH) GO TO 90 STO 210

C STO 220

C STATEMENT IS AN INSERTION OR A REPLACEMENT STO 230

C STO 240

L=LOCATE (NSTMT) STO 250

IF (L.GT.O) GO TO 30 STO 260

C STO 270

L=-L STO 280

IDIF=IZE STO 290

10 LL=NCOM STO 300

C STATEMENT IS AN INSERTION, OPEN GAP STO 310

II=LL+IDIF STO 320

IF (II. GE. LCOM) GO TO 100 STO 330

DO 20 I=L,NCOM STO 340

COM(II)=COM(LL) STO 350

11=11-1 STO 360

20 LL=LL-1 STO 370

GO TO 60 STO 380

C STO 390

C STATEMENT IS REPLACEMENT STO 400

C STO 410

30 IDIF=IZE-IFIX(C0M(L+1) ) STO 420

IF (IDIF) 40,60,10 STO 430

C STO 440

C NEW STATEMENT SMALLER THAN OLD, CLOSE UP GAP. STO 450

C STO 460

40 I=L-IDIF STO 470

II=L STO 480

DO 50 IA=I,NCOM STO 490

COM(II)=COM(IA) STO 500

50 11=11+1 STO 510

C STO 520

C INSERT STATEMENT STO 530

C STO 540

60 COM(L)=NSTMT STO 550

C0M(L+1)=IZE STO 560

C0M(L+2)=NARGS+64*(L1+64*L2) STO 570

NCOM=NCOM+IDIF STO 580

IF (IZE.EQ.3) GO TO 80 STO 590

301

409-118 OL - 71 - 20
DO 70 1=4 , IZE STO 600

C0M(L+3)=ARGTAB(I-3) STO 610

70 L=L+1 STO 620

80 CONTINUE STO 630

RETURN STO 640

C STO 650

C PUT STATEMENT ON END STO 660

C STO 670

90 L=NCOM STO 680

IDIF=IZE STO 690

NSTMTX=NSTMTH STO 700

NSTMTH=NSTMT STO 710

IF (NCOM+IDIF.LT.LCOM) GO TO 60 STO 720

C STO 730

C COM STORAGE OVERFLOW STO 740

C STO 750

100 I0VFL=1 STO 760

CALL ERROR (12) STO 770

RETURN STO 780

END STO 790

SUBROUTINE STORMT (C , N , NP , K , A ) STT 10

C VERSION 5.00 STORMT 5/15/70 STT 20

C * STT 40

C SUBROUTINE STORES MATRIX C(NP,K ) FROM SCRATCH AREA A STT 50

C * STT 60

DIMENSION A(l) , C(N,1) STT 70

IS=1 STT 80

DO 10 J=1,K STT 90

DO 10 1=1, NP STT 100

C(I,J)=A(IS) STT 110

10 IS=IS+1 STT 120

RETURN STT 130

END STT 140

302
10

20

30

40

SUBROUTINE STRUVE (Z,A,B,C) STR 10

VERSION 5.00 STRUVE 5/15/70 STR 20

DIMENSION C(l) STR 30

DOUBLE PRECISION Z,A,B,C,X,P,Q,R,S, DBEJ STR 40

X=DABS(Z) STR 50

IF (X.GT. .ODO) GO TO 10 STR 60

A=.0D0 STR 70

B=.0D0 STR 80

GO TO 40 STR 90

IF (X.GT. 70. DO) GO TO 30 STR 100

CALL BEJN (0,C,X) STR 110

P=.ODO STR 120

Q=.ODO STR 130

DO 20 N=l,49 STR 140

J=2*N STR 150

K=J+1 STR 160

R=J-1 STR 170

S=4*N**2-1 STR 180

P=P+C(J)/R STR 190

Q=Q+C(K)/S STR 200

A=P/ .78539816339D0 STR 210

B=(2 .D0*Q+1 .DO-C(l) ) /l .5707963268D0 STR 220

GO TO 40 STR 230

S=l .D0/X**2 STR 240

P=l .DO-S* (1 . DO-9 .DO*S* (1 .00-25 .D0*S* (1 .00-49 DO*S) )

)

STR 250

A=DBEJ (X,0,5)+P/ (X*l .5707963268D0) STR 260

Q=1.D0+S* (1.D0-3 .DO*S* (1 .DO-15 .D0*S* (1.D0-35 DO*S) ) ) STR 270

B=DBEJ (X,l,5)+Q/ (1 .5707963268D0) STR 280

RETURN STR 290

END STR 300

SUBROUTINE SYMV (A,NROW,N,K) SYM 10

C VERSION 5.00 SYMV 5/15/70 SYM 20

C FOR OMNITAB WRITTEN BY S PEAVY 11/29/67 SYM 30

C A-FIRST ELEMENT OF MATRIX A SYM 40

C NROW -NO. OF ROWS IN A AS DEFINED IN A DIMENSION ST SYM 50

C N -PRESENT SIZE OF A SYM 60

C K -STATUS FOR SYMMETRY SYM 70

C K=0 EXACT SYMMETRY A A ( I , J ) / A ( J , I ) )=1 SYM 80

C K=l SYMM TO A RELATIVE RROR ABS (

1

-A(I,J)/A(J,I)) = OR LESS l.E-7 SYM 90

C K=2 NO SYMMETRY SYM 100

C SYM 110

DIMENSION A(NROW,NROW) SYM 120

K=0 SYM 130

NN=N-1 SYM 140

DO 40 J=1,NN SYM 150

I=J+1 SYM 160

DO 40 L=I ,N SYM 170

IF (A(J,L)) 20,10,20 SYM 180

10 T=ABS(A(L,J)

)

SYM 190

GO TO 30 SYM 200

20 T=ABS(1.0-A(L,J)/A(J,L)) SYM 210

30 IF (T.EQ.O.) GO TO 40 SYM 220

K=l SYM 230

IF (T.LE.l.E-7) GO TO 40 SYM 240

K=2 SYM 250

RETURN SYM 260

40 CONTINUE SYM 270

RETURN SYM 280

END SYM 290

303
SUBROUTINE TAPOP TAP 10

C VERSION 5.00 TAPOP 5/15/70 TAP 20

C RV SUBROUTINE USED WITH TAPE COMMANDS TAP 30

COMMON /TAPE/ NAME4 (2 ) ,NTPCT , IPUNCP , INUNIP , L1TP TAP 40

COMMON /CODE/ I ALPH (6 ), NALPH (5 )

, I D (9 , 3 ) , I R (300 , 4 ) , I RD (30 , 6 ) TAP 50

C0MM0N/ABCDEF/L(48) TAP 55

COMMON /BLOCKA/ MODE , M, KARD (83 )

, KARG , ARG , ARG2 , NEWCD (80 ), KRDEND TAP 60

COMMON /BLOCKE/ NAME (4 ), LI , L2 , I SRFLG TAP 70

COMMON /CODETP/ ITP(10,4) TAP 80

NAME4(1)=0 TAP 90

NAME4(2)=0 TAP 100

NTPCT=0 TAP 110

10 K=KARD(M) TAP 120

C THE TAPE ID MAY BE A NUMBER OR A LETTER TAP 130

IF (K.LT.36) IF(K-IO) 20,30,30 TAP 135

M=M+1 TAP 140

GO TO 10 TAP 150

20 ITAPE=KARD (M) +6 TAP 160

MP=M-1 TAP 170

GO TO 50 TAP 180

30 MP=M-1 TAP 190

CALL NNAME (NAME4 (1 )) TAP 200

ITAPE=0 TAP 210

DO 40 1=1,6 TAP 220

IF (NAME4 (1 ) .NE . I ALPH ( I )

) GO TO 40 TAP 230

ITAPE=I+6 TAP 240

GO TO 50 TAP 250

40 CONTINUE TAP 260

50 IF(ITAPE.GT.9) GO TO 60 TAP 270

KARD(MP)=L(45) TAP 280

KARD(MP+1)=ITAPE TAP 290

GO TO 80 TAP 300

60 KARD(MP)=1 TAP 310

KARD(MP+1)=ITAPE-10 TAP 320

C CREAD READ WRITE TAP 340

80 IF (NAME ( 1 ) .NE . ITP (2 , 1 ) .AND .NAME (1) .NE. I TP (1,1) .AND .NAME (1) .NE . ITPTAP 350

1(3,1)) GO TO 110 TAP 360

NAME4(1)=0 TAP 370

NAME4(2)=0 TAP 380

M=M+1 TAP 390

90 K=KARD (M) TAP 400

IF (K.LT.36) IF (K-10) 110,100,100 TAP 410

M=M+1 TAP 420

GO TO 90 TAP 430

100 CALL NNAME (NAME4 (1) ) TAP 440

110 M=MP TAP 450

RETURN TAP 460

END TAP 470

304
SUBROUTINE TAPOP2 TP2 10

C VERSION 5.00 TAP0P2 5/15/70 TP2 20

C THIS SUBROUTINE IS NEDOED ONLY FOR TAPE OPERATIONS TP2 30

C Ll= 45 L2=l,7 TP2 40

C READ TAPE A-F A-F (FORMAT) INTO COLUMNS ++,++,++,++, ETC. TP2 50

C READ UNTIL A RECORD OF A ZEROS ARE ENCOUNTERED TP2 60

C IF NO FORMAT IS GIVEN, CARDS ARE READ AS IN READ COMMAND TP2 70

C Ll= 46 L2=l,7 TP2 80

C CREAD TAPE A-F A-F (FORMAT) CARDS INTO COLUMNS ++,++,++, ETP2 90

C CREAD TAPE A-F , , CARDS INTO COLUMNS ++,++,++, ETC . TP2 100

C READ USING A COUNTER TP2 110

C Ll= 47 L2=l,7 TP2 120

C WRITE TAPE A-F A-F (FORMAT) FROM COLUMNS ++,++,++,++, ETC . TP2 130

C A RECORD OF ZEROS IS WRITTEN AFTER NRMAX VALUES TP2 140

C Ll= 48 L2=l TP2 150

C SET TAPE A-F INTO COLUMNS ++ TP2 160

C SET TAPE A-F INTO ROW OF COLUMN ++ TP2 170

C READ UNTIL A RECORD OF ZEROS IS ENCOUNTERED TP2 180

C Ll= 49 L2=l TP2 190

C CSET TAPE A-F ,, VALUES INTO COLUMN ++ TP2 200

C CSET TAPE A-F ,, VALUES INTO ROW ,, OF COLUMN ++ TP2 210

C READ USING A COUNTER TP2 220

C Ll= 50 L2=l TP2 230

C ENDFILE TAPE A-F TP2 240

C Ll=50 L2=2 TP2 250

C REWIND TAPE A-F TP2 260

C Ll= 50 L2=3 TP2 270

C SKIP TAPE A-F FORWARD RECORDS TP2 280

C Ll= 50 L2=4 TP2 290

C BACKSPACE TAPE A-F ,, RECORDS TP2 300

COMMON /BLOCKC/ KIO , I NUN IT , ISCRAT , KBDOUT , KRDKNT , LLIST TP2 310

COMMON /BLOCKD / I ARGS ( 100 ), KIND ( 100 ) ,ARGTAB ( 100 ), NRMAX , NROW, NCOL , NTP2 320

1ARGS,VWXYZ(8) ,NERROR TP2 330

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , ISRFLG TP2 340

COMMON/ HEADER /NOCARD (80 ) ,ITLE(60,6) , LNCNT , I PR I NT ,NPAGE , I PUNCH TP2 350

COMMON /SCRAT/ NS ,NS2 ,A (13500 ) TP2 370

COMMON /TAPE/ NAME4 (2 ) ,NTPCT , IPUNCP , I NUN IP , L1TP TP2 380

C CHECK FOR CORRECT NUMBER OF ARGUMENTS TP2 390

IF(L1.LT.50) IF(NARGS-2) 5,30,30 TP2 395

GO TO (10,10,20,20), L2 TP2 400

5 CALL ERROR (10) TP2 410

GO TO 30 TP2 420

10 IF (NARGS.NE.l) CALL ERROR (10) TP2 430

GO TO 40 TP2 440

20 IF (NARGS.NE.2) CALL ERROR (10) TP2 450

C ALL ARGUMENTS SHOULD BE INTEGERS TP2 460

30 J=NARGS TP2 470

CALL CKIND (J) TP2 480

IF (J.NE.O) CALL ERROR (3) TP2 490

C IS TAPE NUMBER CORRECT TP2 500

40 IF (IARGS(l) .LT.7.0R.IARGS(1) .GT.12) CALL ERROR (28) TP2 510

IF (NERROR . NE . 0 ) RETURN TP2 520

LlP=Ll-44 TP2 530

GO TO (50,70,90,60,80,170), LIP TP2 540

50 IF (L2.EQ.1) GO TO 60 TP2 550

INUNIT=IARGS(1) TP2 560

IARGS(1)=0 TP2 570

GO TO 130 TP2 580

60 IA=2 TP2 590

305
A

ATA i ftA GO TO 100 TP2 600

70

TC / tA MC 1 \AATALA IP (L2 . Nt . 1 ) bU 1 U 60

TAA / TA TP2 610

80 Al

TAATTADAC / A\ NTPCT=I ARGb (2 ) T

AA / AA TP2 620

TA 1 I A=3TAA /OA TP2 630

ArtTATAA GO TO 100 TP2 640

90

TAA I A=2 TP2 650 Y A 1 1 Al A U T A A A C / i \ IPUNCH=IARGS ( 1 )

TP2 660

AATA 1 1 A bU 1 U 110

TAA / "?A IPZ 670 1 A A 100 T Al M Al T T T A D A C / 1 \ INUNl l=lAKbo (1 ) T A A /OA IP2 680 1 1 A 110 1=1 T A A / A A TP2 690

i\A i a

A TT TA AlADAC DO 120 1 1 = 1 A ,NAKb:>

TAATAA TP2 700

TAAAC/T\T AOTC / TT\ IARGS(I)=IARG5(II)

TAAT 1 A TP2 710 1 A A 120 IT TT 1 1 = 1+1 T A A "7 A A TP2 720

AlADAC AlADAC TA 1 NARG5=NARGS-I A+l

TAA ^ 1 A TP2 730 1 O A 130 LI 1 P=L1 T A A TilA Ir2 740 A A TA / 1 i A ti ,i fi TCA 1 / A T / A \ 1 -j r\ GO TO (140,140,150,160,160), LIP T A A T C A TP2 750 T A A 140 nil i nr a a v CALL READX T Pi A ~J / f\ TP2 760

RL 1 URN

TAA "7 ~IA TP2 770

TCA 150AA 1 1 A 1 1 AlA LI CALL PUNCHTnATAA TP2 780

DTTtlDM Rt 1 URN

TAATAA Ir2 790 1 / A 160 A A 1 1 f* C T CALL SET T r\ A AAA TP2 800

DCTIIDII Rt 1 URN

TAAA 1 A TP2 810 1 T A 170 TTDD TADAC/"l\ ITPP=IARG5 ( 1 ) T A A AAA TP2 820

AA TA / TAA *1AA AAAAAA\ IA GO TO (180 , 190 , 200 , 220 ) , L2TAAO *>A TP2 830

ion 180 CklHCTtC TTDD

TAA

O Jt

A IrZ 840

DFTItDII RETURN

TAA OCA TP2 850 1 A A 190 DCUiTAIA TTfin RcWIND ITPP T A A Ci I A TP2 860

RETURN

TAAO "TA Ir2 870

AAA 200

TDCATAAAC / A\ IREC=IARG5 (2)

TAA AAA TP2 880

AA ATAT 1 TDCA DO 210 I=1,IREC

TDA AAA IP2 890

READ (ITPP, 240) A(l)

TAA AAA IP2 900

AA AITT All It CONTINUE

TAA ATA IPZ 910

nni I A Al RETURN IP2 920

AAA 220 TDCA TADAC/A\ IRtC=IARGS (2 )

IrZ 930

AA

A

oa

T 1 TDCA DU 230 1=1 , IRtt TDO QAA DAAI/CAAAC TTAA BACK5PACE ITPP TDO Q C A IrZ V50

230 AftuT

t til ir CONTINUETAAA / A TP2 960

nr Ti i nil RETURN

TDA ATA IrZ 970

C

T

AA

AO

A IrZ 980

240 FORMAT (80A1)

TAA AAA TP2 990

END TP21000

306
SUBROUTINE THERMO THE 10

C VERSION 5.00 THERMO 5/15/70 THE 20

C IT NOW CONTAINS THE COMMANDS CTOF , FTOC , ATOMIC, MOLWT , EINSTEIN, THE 30

C PFTRANSLATIONAL, PFATOMIC, AND PARTFUNCTION THE 40

C THERMODYNAMIC PACKAGE WRITTEN BY R. MCCLENON , NSRDS-NBS , NOV. 69 THE 50

C THE 60

C THE VALUES FOR L2 ARE — THE 70

C 1 -CTOF (CENTIGRADE TO FAHRENHEIT) THE 80

C 2 - FTOC (FAHRENHEIT TO CENTIGRADE) THE 90

C 3 - ATOMIC MASS TABLE THE 100

C 4 - MOLWT (MOLECULAR WEIGHT) THE 110

C 5 - EINSTEIN FUNCTION THE 120

C 6 - PFTRANS ( PARTITION FUNCTION TRANSLATIONAL ) THE 130

C 7 - PFATOM ( P.F. ATOMIC) THE 140

C 8 - PARTFUNCTION THE 150

C 9 - BOLDISTRIBUTION (BOLZMAN DISTRIBUTION) THE 160

C THE 170

C WRITTEN BY R. MCCLENON, NSRDS-NBS, DEC. 1969 THE 180

C THE 190

C COMMAND FORMATS ARE AS FOLLOWS — THE 200

C CTOF OF $$ STORE IN COL ++ THE 210

C FTOC OF $$ STORE IN COL ++ THE 220

C ATOMIC MASSES STORE IN COL ++ THE 230

C MOLWT Z=,, AMOUNT=, , Z=, , AMOUNT= STORE SUM IN COL ++ THE 240

C EINSTEIN TEMP IN $$ VIB FREQ IN WAVE NO IN $$ START STORING IN ++THE 250

C OR EINSTEIN TEMP IN $$ FREQ IN $$ GAS CONST R=, , START IN ++ THE 260

C PFTRANS TEMP IN $$ MOL WT M IN $$ START STORING IN $$ THE 270

C PFATOM TEMP IN $$ MOL WT M IN $$ WAVE NO IN ++ DEGEN G IN ++ THE 280

C START STORING IN COL ++ THE 290

C PARTFUNC TEMP IN $$ WAVE NO IN ++ G IN ++ START STORING IN ++ THE 300

C VIBDIST TEMP IN $$ WAVE NO IN ++ G IN ++ START STORING IN ++ THE 310

C THE 320

C SEE HANDBOOK 101 FOR DETAILS ON STORAGE BY ALL COMMANDS EXCEPT THE 330

C VIBDIST (WHICH IS NEW) THE 340

C VIBDIST STORES THE PERCENTAGE OF MOLECULES IN EACH OF THE THE 350

C VIBRATIONAL ENERGY LEVELS. IF THERE ARE N ENERGY LEVELS VIBDIST THE 360

C WILL USE N COLUMNS FOR STORAGE THE 370

C THE 380

COMMON /BLOCKD/ I ARGS ( 100 ), KIND ( 100 )

, ARGTAB ( 100 ) ,NRMAX ,NROW,NCOL , NTHE 390

1ARGS , VWXYZ (8 ) ,NERROR THE 400

EQUIVALENCE (ARGS (1) ,RC (12501) ) THE 410

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , ISRFLG THE 420

DIMENSION ARGS(IOO) THE 430

COMMON /BLOCRC/ NRC , RC ( 12600 ) THE 440

DOUBLE PRECISION X , EXX , EXDI F , FDEXP , FDLOG , QO ,Q1 ,Q2 ,G ,QQ THE 450

COMMON /SCRAT/ NS ,NS2 , A (13500) THE 460

C DIMENSION QQ(NS2) THE 470

DIMENSION QQ(6750) THE 480

EQUIVALENCE (A(1),QQ(1)) THE 490

DIMENSION ATWT(103) THE 500

DATA ATWT(l) ,ATWT(2) ,ATWT (3 )

, ATWT (4) ,ATWT(5) , ATWT (6) /l .00800 ,4 . 002THE 510

160,6.94100,9.01218,10.81000,12.01100/ THE 520

DATA ATWT(7) , ATWT (8 )

, ATWT (9 )

, ATWT (10) ,ATWT(11) , ATWT (12 ) /14 . 00670 , 1THE 530

15.99940,18.99840,20.17900,22.98980,24.30500/ THE 540

DATA ATWT (13) ,ATWT(14) ,ATWT(15) ,ATWT(16) , ATWT (17 ), ATWT (18) /26 . 9815THE 550

10,28.08600,30.97380,32.06000,35.45300,39.48000/ THE 560

DATA ATWT (19) ,ATWT(20) ,ATWT(21) ,ATWT(22) ,ATWT(23) , ATWT (24) /39 . 1020THE 570

10,40.08000,44.95590,47.90000,50.94140,51.99600/ THE 580

DATA ATWT(25) ,ATWT(26) , ATWT (27 ), ATWT (28 ), ATWT (29 )

, ATWT (30 ) /54 . 9380THE 590

307
10,55 .84700 ,58 .93320 ,58 .71000,63 .54600,65 .37000/

DATA ATWT(31

10 ,72 .59000,74 .92160 ,78 .96000,79 .90400,83 .80000/

DATA ATWT(37

10,87 .62000,88.90590,91.22000,92.90640,95.94000/

DATA ATWT(43

10 ,101 .07000,102 .90550 ,106.40000 ,107 .86800,112 .40000/

DATA ATWT(49

100,118.69000

DATA ATWT(55

150 ,137 .34000

DATA ATWT(61

100,150.40000

DATA ATWT(67

130,167.26000

DATA ATWT(73

190,183.85000

DATA ATWT(79

150,200.59000

DATA ATWT(85

100,222.00000

DATA ATWT(91

190,238.02900

DATA ATWT(97

,ATWT(32) ,ATWT(33) ,ATWT(34) ,ATWT(35) ,ATWT(36)

,ATWT(38) ,ATWT(39) ,ATWT(40) ,ATWT(41) ,ATWT(42)

,ATWT(44) ,ATWT(45) ,ATWT(46) ,ATWT(47) ,ATWT(48)

,ATWT(50) ,ATWT(51) ,ATWT(52) ,ATWT(53) ,ATWT(54)

121 .75000 ,127 .60000,126.90450,131 .30000/

,ATWT(56) ,ATWT(57) ,ATWT(58) ,ATWT(59) ,ATWT(60)

138 .90550 ,140 . 12000 , 140 . 90770 , 144 . 24000

/

,ATWT(62) ,ATWT(63) ,ATWT(64) ,ATWT(65) ,ATWT(66)

151 .96000 ,157 .20000,158.92540,162.50000/

,ATWT(68) ,ATWT(69) ,ATWT(70) ,ATWT(71) ,ATWT(72)

168.93420,173 .04000 ,174.97000 ,178.49000/

,ATWT(74) ,ATWT(75) ,ATWT(76) ,ATWT(77) ,ATWT(78)

186 .20000 ,190 .20000 ,192 .22000 ,195 .09000/

,ATWT(80) ,ATWT(81) ,ATWT(82) ,ATWT(83) ,ATWT(84)

204.37000,207 .20000,208.98060,210.00000/

,ATWT(86) ,ATWT(87) ,ATWT(88) ,ATWT(89) ,ATWT(90)

223.00000,226.02540,227 .02000,232 .03810/

,ATWT(92) ,ATWT(93) ,ATWT(94) ,ATWT(95) ,ATWT(96)

237 .04820,239.00000,243 .00000,247 .00000/

THE 600

/69.7200THE 610

THE 620

/85.4678THE 630

THE 640

/98.9062THE 650

THE 660

/114.820THE 670

THE 680

/132.905THE 690

THE 700

/147.000THE 710

THE 720

/164.930THE 730

THE 740

/180.947THE 750

THE 760

/196.966THE 770

THE 780

/210.000THE 790

THE 800

/231.035THE 810

THE 820

,ATWT(98) ,ATWT(99) ,ATWT(100) , ATWT (101) , ATWT ( 102 ) /247 .THE 830

100000,249 .00000,254 .00000,253 .00000 ,255 .00000 ,257 .00000/

DATA ATWT(103)/255.0/

GOTO (10,250,260,380,490,590,640,710,760), L2

C THIS IS CTOF

10 M=l

20 IF (NARGS-2 ) 1210,30,1210

30 CALL ADRESS (2,12)

IF (12) 1220,1230,40

40 CALL ADRESS (1,11)

IF (II) 50,1230,50

50 IF (NRMAX) 1240,1240,60

60 IF (NERROR) 1180,70,1180

70 IF (II) 160,1230,80

80 IE=0

DO 150 J=l , NRMAX

II1=I1+J-1

II2=I2+J-1

IF (M-l) 1180,100,90

90 RC(II2)=(RC(IIl)-32.0)/1.8

IF (RC (112) +273 .15) 110,150,150

100 IF (RC ( 1 1 1 )+273 . 15 ) 110,140,140

110 IF (IE) 130,120,130

120 CALL ERROR (230)

IE=1

130 IF (M-l) 1180,140,150

140 RC ( 1 12 ) = (1 . 8*RC (III) )+32 .0

150 CONTINUE

GO TO 1180

160 IF (M-l) 1180,180,170

170 T=(ARGS(l)-32.)/1.8

IF (T+273.15) 190,230,230

180 IF (ARGS(l)+273 .15) 190,220,220

190 IF (IE) 210,200,210

200 CALL ERROR (230)

IE=1

THE 840

THE 850

THE 860

THE 870

THE 880

THE 890

THE 900

THE 910

THE 920

THE 930

THE 940

THE 950

THE 960

THE 970

THE 980

THE 990

THE1000

THE1010

THE1020

THE1030

THE1040

THE1050

THE1060

THE1070

THE1080

THE1090

THE1100

THE1110

THE1120

THE1130

THE1140

THE1150

THE1160

THE1170

THE1180

308
210 IF (M-l) 1180,220,230 THE1190

220 T=(l .8*ARGS (1) )+32 .0 THE1200

230 DO 240 J=l, NRMAX THE1210

1 1 2=1 2+J-l THE1220

240 RC(II2)=T THE1230

GO TO 1180 THE1240

C THIS IS FTOC THE1250

250 M=2 THE1260

GO TO 20 THE1270

C THIS IS ATOMIC WEIGHT THE1280

260 IF (NARGS-1) 1210,280,270 THE1290

270 CALL ERROR (221) THE1300

280 CALL ADRESS (1,11) THE1310

IF (11) 1220,1230,290 THE1320

290 IF (NROW-92) 300,310,310 THE1330

300 CALL ERROR (226) THE1340

310 IF (NERROR) 1180,320,1180 THE1350

320 IF (NROW-103) 330,340,340 THE1360

330 L=NROW THE1370

GO TO 350 THE1380

340 L=103 THE1390

350 00 360 J=1,L THE1400

1 1 1=1 1+J-l THE1410

360 RC(II1)=ATWT(J) THE1420

IF (NRMAX-L) 370,1180,1180 THE1430

370 NRMAX=L THE1440

GO TO 1180 THE1450

C THIS IS MOLWT THE1460

380 I=NARGS THE1470

CALL CKIND (I) THE1480

IF (1-1) 390,1220,1220 THE1490

390 N=NARGS/2 THE1500

IF (NARGS-2*N ) 400,1210,400 THE1510

400 IF (NRMAX) 1240,1240,410 THE1520

410 CALL ADRESS (NARGS , I

)

THE1530

IF (I) 1220,1230,420 THE1540

420 WT=0 .

0

THE1550

IF (N-l) 1210,430,430 THE1560

430 IF (NERROR) 1180,440,1180 THE1570

440 DO 470 J=2,NARGS,2 THE1580

K=IARGS(J-1) THE1590

IF (K-103) 450,450,1250 THE1600

450 IF (K) 1250,1250,460 THE1610

460 WT=WT+ATWT(K)*FLOAT(IARGS(J)

)

THE1620

470 CONTINUE THE1630

DO 480 J=l, NRMAX THE1640

II=I+J-1 THE1650

480 RC(II)=WT THE1660

GO TO 1180 THE1670

C SPACE RESERVED FOR EINSTEIN, PFTRANS, PFATOMIC, AND PARTFUNCTION THE1680

C THIS IS EINSTEIN THE1690

490 IF (NARGS-5 ) 500,1210,1210 THE1700

500 IF (NARGS-3) 1210,510,530 THE1710

510 CALL ADRESS (3,1) THE1720

IF (I) 1220,1230,520 THE1730

520 R=l .0 THE1740

II=IARGS(3) THE1750

GO TO 560 THE1760

530 CALL ADRESS (4,1) THE1770

309
V I- / T

\ TtAAA i a «i

AP 1 A IF (I) 1220,1230,540 THE1780

540 r— / 1/

T IIA / 1 v i\ *iAAA r* • AtAAA IF (KIND(3)-l) 1220,550,1220 THE1790

550 R=ARGS (3 ) 1 1 TTM

T AAA THE1800 1 1=1 ARGS (4) T i i r i a i a THE1810

IF (R) 1250,1250,560 i i rTM~ ^ aaa THE1820

560 CALL ADRESS (2,IFQ) THE1830 T fTM / T 1"* A v ^ T A "i A A A r* A A IF (IFQ) 570,1230,580 T 1 rTM Ti A A A THE1840

570 F=ARGS (2 ) t i i r • a ^ a THE1850 t r~ / F" \ i a r/ A i a r* a r* A A IF (F) 1250,1250,580 tut i a / a THE1860

580 TP" TT ^ \

TAAA AAA AAA IF (NCOL-II-7) 1230,800,800 Tiir~Ti a^a THE1870

590 TP" « i| I r\ f A . Tl

A TlAyAA

x

AA IF (NARGS-3) 1210,600,1210 ~fT 1 1 tTM Ti

AAA THE1880

600 CALL ADRESS (3,1) THE1890 T fTM / T \ T A A A ^ A A A / T A IF (I) 1220,1230,610 TUT 1 AAA THE1900

610 1 1 = 1 ARGS (3 )

ti ir i a » a THE1910

a « | g i nnr

rr /at hit\ CALL ADRESS (2 , IWT)

T 1 1 l~ Ti AAA THE1920

T J" i T IIIT

\y

AA 1 AAA / AA IF (IWT) 620,1230,630

T 1 1 r" Ti AAA THE1930

620 HIT

AA f / a\ WT=ARGS (2)

TI If* 1 AAA THE1940

t rTM / isnr

\ ^ a ^ a tia f»ayaa IF (WT) 1250,1250,630 ti in

a f a THE1950

630

T f / M

AA | TT / v Ti

AAA AAA AAA IF (NCOL-II-6) 1230,800,800 ti in Aya THE1960

640

T f- /llin^P r- » "1ATA /PA 1 A 1 A IF (NARGS-5) 1210,650,1210 ti in ATA THE1970

650

a

a i 4 nnrrr is- T\ CALL ADRESS (5,1) THE1980 T i T \ T* A A A Ti A A A y y A IF (I) 1220,1230,660 T 1 IT 1 AAA THE1990

660 TT T'.PiAP'/r'v I I=IARGS (5 ) T 1 1 f~

AAAA THE2000

a»ii i ftnrpr /a

t hit\ CALL ADRESS (2, IWT)T 1 1 f AA 1 A THE2010

TC / T HIT\ ZTATA 1 A / an IF (IWT) 670,1230,680 THL2020

670 hit i n/>

r / a\ WT=ARGS (2 ) T 1 1 P"

AAAA THE2030

T 1TM / HITV 1 A If"A 1 arA / AA IF (WT) 1250,1250,680T 1 1 f"AAAA THE2040

680

aa i »i\r»r"f*f /a

t p*a\ CALL ADRESS (3, IFQ)

T 1 1 f"*AA r~A THE2050

IT / ? ^ A

\

AAA TiAAA / AA IF (IFQ) 1220,1230,690T 1 1 rTMAayA THE2060

690

A

A 1 1 *. f\ Pi P*

CC / /J

TA « CALL ADRESS (4,IG) TI IT rt ft 1 rt THE2070

TP" / TA\ -|AAA » AAA ^ AA IF (IG) 1220,1230,700T 1 1 rTM

A

AAA THE2080

700 TP* /HA

A 1 TV

y

v tiAAA AAA AAA IF (NCOL-II-6) 1230,800,800T 1 1 rAAAA THE2090

710

T ITTM / ftlA PiACA\tA TlA "TlAA 1 A TlA IF (MARGS-4) 1210,720,1210 Tiir- AT AA THE2100

720

AA 1 J 1 hnrrftaT\ CALL ADRESS (4,1)

Tliro 1 1 A THE2110

T t~ /T\TAAA *1A *5

A

T

A

A IF (I) 1220,1230,730

TUC 1 1 O 1 HLZIZO

730 TT

TA P»AP / A\ 1 1 = 1 ARGS (4 )Tlir"Al AA IHE2130

aa (i i a r\ Pi P* P" P" /A

t r~a » CALL ADRESS (2, IFQ) T| | rA 1 A

A THE2140

T , T ^TM

A

\ TiAAAAAA ^ AA IF (IFQ) 1220,1230,740

T 1 1 f a i rA THE2150

740

AA 1 1 A

A (A IT" P"

P /A TAv CALL ADRESS (3,IG)

T 1 1 f"A 1 / A THE2160

T ^ / TA\ Tl AAASAAAT ^ A IF (IG) 1220,1230,750 Tliri 1 TA THE2170

750 I WT=0

T 1 1 1- A 1 AA THE2180

T *~ , A A. I TT Al TiAAAAAAAAA IF (NCOL-II-3) 1230,800,800 Tlir^l AA THE2190

760

T *~~ i A 0 A IAA f~A\ TiAHA "i? ~JAA TlA IF (NARGS-4) 1210,770,1210 TllfTAAAA THE2200

770

A AllA f\n *TMA yTM , o

V

% CALL ADRESS (4,1) THE2210

IF (I) 1220,1230,780

T 1 1 r"AAAA THE2220

780

T HITA I WT=0 I HtZ230

TTTA ftAA / A\ 1 1 = 1 ARGS (4)

T LICA

a

aa THt2240

A AllA A.n / A f AT ^ jAV CALL ADRESS (2, IFQ)

T|ir"AAf»A THE2250

T - VA « VAAA TiAAAAA IF (IFQ) 1220,1230,790

X LICAA / A

790

AA 1 A

A

n f AA /A TA\ CALL ADRESS (3,IG) I HL2270 y i- , T A » 1 A A A "i A A A AAA

IF (IG) 1220,1230,800 Tur OOOft I HL2 2oU

800

AA I A 0\AA , w

T A\

\ CALL ADRESS (1,ITP)

T LICAAAA Tnt2290

T ^ , tT a~v i A^A ^AAA AAA

IF (ITP) 810,1230,820 I HL2300

810 T=ARGS(1) TUT* 1 1 A THE2310

IF (T) 1250,1250,820

T LICA *1AA THE2320

820 IE=0 V W~ , 1 1 Ak AAA V/

\ ^ AAA 1 AAA AAA

IF (NRMAX) 1240,1240,830 1 HtZ340

830

t r* / 11rnn An\td

aa

aaat i aa IF (NERR0R) 1180,840,1180 TUEottn

840 IF (L2-8) 890,850,850 THE2360

310
850 DO 880 J=NR0W,1,-1 THE2370

IIG=IG+J-1 THE2380

IF (RC(IIG)) 1260,880,860 THE2390

860 KK=J THE2400

IF (KK-NS2) 890,890,870 THE2410

870 IF (L2-8) 890,890,1190 THE2420

880 CONTINUE THE2430

GO TO 1270 THE2440

890 DO 1170 J=1,NRMAX THE2450

IF (ITP-1) 910,900,900 THE2460

900 IIT=ITP+J-1 THE2470

T=RC(IIT) THE2480

IF (T) 1150,910,910 THE2490

910 IF (IWT) 940,920,930 THE2500

920 WT=1.0 THE2510

GO TO 940 THE2520

930 IIW=IWT+J-1 THE2530

WT=RC(IIW) THE2540

IF (WT) 1150,940,940 THE2550

940 IF (L2-8) 1000,950,950 THE2560

950 Q0=0 . THE2570

Q1=0

.

THE2580

Q2=0. THE2590

DO 990 JJ=1,KK THE2600

IIF=IFQ+JJ-1 THE2610

IIG=IG+JJ-1 THE2620

E=RC(IIF) THE2630

G=RC(IIG) THE2640

IF (G) 1260,960,960 THE2650

960 IF (E) 1130,970,970 THE2660

970 X=1.43879D0*DBLE(E)/DBLE(T) THE2670

EXX=FDEXP(-X) THE2680

Q0=Q0+G*EXX THE2690

Q1=Q1+G*X*EXX THE2700

Q2=Q2+G*X*X*EXX THE2710

IF (L2-8) 990,990,980 THE2720

980 QQ(JJ)=G*EXX THE2730

990 CONTINUE THE2740

GO TO 1010 THE2750

1000 Q0=1.0 THE2760

Q1=0. THE2770

Q2=0. THE2780

IF (L2-6) 1020,1010,1010 THE2790

1010 FE=2.5*FL0G(T)+1.5*FL0G(WT)-3 . 66495+SNGL (FDLOG (QO )

)

THE2800

HE=2.5D0+Q1/Q0 THE2810

S=FE+HE THE2820

CP=2.5D0+Q2/Q0-(Q1/Q0)*(Q1/Q0)

HBYT=HE*T

THE2830

THE2840

GO TO 1050 THE2850

1020 IF (IFQ-1) 1040,1030,1030 THE2860

1030 IIF=IFQ+J-1 THE2870

E=RC(IIF) THE2880

IF (E) 1130,1040,1040 THE2890

1040 X=1.43379D0*DBLE(E) /DBLE(T) THE2900

EXX=FDEXP(-X) THE2910

EXDIF=1.0D0-EXX THE2920

FE=-FDLOG (EXDIF) *R THE2930

HE=(X*EXX/EXDIF)*R

CP=R*X*X*EXX/ (EXDIF*EXDIF)

THE2940

THE2950

311
b=r t+tlt 1 Ht2960

URVT tlut 1 =nUC*T l 1 T

UC 1 ft 7 ft 1 Ht2970 1 A C ft lObO itK.= Till 1 +J —1 1 Ht29o0 t c ii i o\ i n a n inon linn lr (L2—o) iu o u , i u 7 u , 1 1 u u 1 Ht2990 1 ft L ft 1U60 tlrc /i(Li.— i l\ l Ain inon inon 0) 1 U / U , 1 UoU , 1 U o 0 T U C 1 A ft ft 1 Ht3000 1 ft 7 ft 10/0 or iv \ c KLIN) =t T U C O A 1 A 1 Ht30 10

l\=f\ KUn

TUC 1 A 1 A 1 Ht3020 1 ft Q ft 1 U o U KU ( l\ ) = 1 T U C 7 ft 1 ft 1 Mt30i0

l\=rv s\

U If TUC 1 ft / ft 1 ntjOHO

t\U ^ l\

J =r

t TUC 7 ft

C ft 1 rlt J0b0

i/ i/ , Mpnuu i\=^+roi\Un TUC 3Airt 1 Ht3060

or / 1/\ up K\j \ h. ) =nt TUC 7 ft 7 ft 1 nt30 / 0

l\=i\+HI i\U ( j tuc 7 n

qn l tit .JUoU

KU ^ IS. ) =o TUC 7 ft

Q ft 1 nt3090

tuc l ntj7 1 nn 10U

PPKb I V\ CD ( l\ ) =ur TUC 71 1 A 1 Hti 110

Pv=!\ +IM KUW TUC 7 1 1 A 1 Ht3 120

DP (V 1 URVT tuc 7 1 7 n 1 Mt3 130

CO

TA 117ft TUC 1 tit 7 1 Ad 3 ItU 1 U 7 u dp / v \ _nn TUC I ntj7 1 cn ibO

TUC 7 1 L.n 1 rlt3 160

op

n i

TUC 7 1 7ft 1 Ht31/0

TUC7 1 QA 1 ntj lOU

Pf / it

\ ni TUC 7 1 Qft 1 lit 3 170 cnbU xn1 U ii7n J. X 1 u tuc 1 ntj7 0i. nnUU 1 100 t c /MPfti tt \f\i\ iinn liift iiift 1 r ( NbUL— 1 1 —M\ ) 12U0 , 1110 , 1110 tuc 7 1 1 n 1 Ht3210 X1 1X x1 nu nnUU 1X 1X 9CMn i i— i k k J J — 1 , IVI\ TUC 7 0 0 n op ii/ \ nn i i i \ / nn TUC 7 0 7 ft 1 Mt3230 i i o n TUC 7 O /I ft 1 Mt3 240

pn xn 1 1 7(i oil 1 U 1 1 / u TUC 7 OC ft 1 fit J C b 0 1 I JU n n i ft yu=i . o

TUC 7 0 A ft 1 Mt3 2 60

n i _n TUC 7 9 7 ft 1 nt 3 c. 1 0 no n y z=u . T UC 7 9 0 n I C / I C \ 1 ni n 1 1 yl ft 1 ft 1 ft lr (it; 1 U 1 0 , 1 140 , 1 0 1 U

TUC 7 9 Qn 1 nt 3 2 7 0 i i An pai LALLi cpphp tl\ltUI\ oioi \ct\7) THC77ftn

IC 1 1 t=l TUC 7 7 1 n 1 nt.33 10

pn Tn i (ii

n bU ID 1010 TUC 7 7 O ft 1 Mt3320

1150

r t=U . TUC 7 7 7 ft 1 Mt3330

rlt=0 . TUC 7 7 A ft 1 Mt33'*0 P D ft Lr=0 . TUC 1 nt.?7 7 en 3 bU c ft b=0 . TUC 7 7 An

URVT ft Hb Y 1 =0 .TUC 7 7 7 n 1 nt j 3 1 u

T

r / i r i lftcn l l id IAEA lr (It) lObO , 1 160 , lObO TUC 7 7 Q ft 1 nt 3 30\J 1 1 L A 1160 A A 1 1 CDDAD / 1 *i O \ LALL tKKUK (229) TUC 7 7 on 1 Mt3390 T C 1 1 t = l TUC 7dnn

pn Tn iftcn bU 1 U lObO TUC 7 A 1 n 1 nt 3 t x u 117 0 PAMT T Ml IC LUIM I 1 Nut TUC 7 A 7 n 1 1 o 0 DCTI IDKI Kt 1 UKN TMC7A70 1 nt 3Hj\) 1 1 A A 1190 pit 1 rnnftn / 1 Q \ LALL tKKUK ( 23 ) TUC "XAA(\ \ nt jttu

pn Tn iioft bU IU lloO TUC74i;n 1 nt 3 n J u 1 O ft ft 1200 pUALL A i i rppnp tKKUK m 7 i ( 1 / ) 1 ntJHDU

nn Tn iioft bU IU 1 loO TUC7A7rt 1 nt / u

liiA 1210 psi i rnnftn /1ft\ LALL tKKUK (10) tuc 1 nt jtou 7 Aon A A TA llOA bU IU 1180 TUC 7AOft 1 nt j*>7U

1220 ftfli l CDDAD / *5

A\ LALL tKKUK (20) TUC 7 Qrtft 1 nt; duu

PA TA 1 1 QA bU 1 U 1 180 tuc 7 c 1 n 1 ntj jlU 1 1 O A 1230 A A 1 1 CDDAD /11\ LALL tKKUK (11) TUC 7 K 9(1 1 nt 3 d t u

P.

A TA 1 ] 0(1 bU 1 U i i 0 U THE3530

1240 CALL ERROR (9) THE3540

312
GO TO 1180 THE3550

1250 CALL ERROR (3) THE3560

GO TO 1180 THE3570

1260 CALL ERROR (25) THE3580

GO TO 1180 THE3590

1270 CALL ERROR (224) THE3600

GO TO 1180 THE3610

END THE3620

SUBROUTINE TPCTPT (V,T) TPC 10

C VERSION 5.00 TPCTPT 5/15/70 TPC 20

IF (V.LE.O.) GO TO 30 TPC 30

IF (V-AINT(V)) 30,10,30 TPC 40

10 IF (V.GT.4.) GO TO 20 TPC 50

T=3 .6948*AINT(1 . /V)-l .6561*AINT (2 . /V ) + . 406*AINT (3 . /V ) +2 . 7764*AINT (TPC 60

14. /V) TPC 70

RETURN TPC 80

20 T=l .959964+2 .37227 12/ V+2 .8224986 /V**2+2 .5558497 /V**3+l .5895341 /V**TPC 90

14+.73289821/V**5 TPC 100

C 25 FORMAT (1X/10X,,* INFORMATIVE DIAGNOSTIC * V IMPROPER/) TPC 110

C 30 WRITE ( IPRINT ,25 ) TPC 120

30 RETURN TPC 130

END TPC 140

313
SUBROUTINE TRANSF

VERSION 5.00 TRANSF 5/15/70

SUBROUTINE TRANSF R.V. 5/2/68

SUBROUTINE TO PROVIDE TRANSFORMATIONS B=UAU(T) AND C=U(I)AU

L2=l TRANSFORMATION B=UAU(T)

GENERAL FORMS OF TRANSFORM

M(XAXT) A(,) K,K U(,) N ,K

L2-2 BACK TRANSFORMATION C=U(T)ALL

GENERAL FORMS OF BACKTRANS

M(XTAX) A(,) N,N U(,) N,K

STORE IN C(,

STORE IN C(

TRA

TRA

TRA

TRA

TRA

TRA

TRA

) TRA

10

20

30

40

50

60

70

80

COMMON /SCRAT/ NS , NS2 , A ( 13500

)

COMMON /BLOCRC/ NRC , RC ( 12600

)

COMMON /BLOCKD / IARGS(IOO) , KIND (100) ,ARGTAB(100) ,NRMAX ,NROW,NCOL

1ARGS,VWXYZ(8) , NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 )

)

COMMON /BLOCKE/ NAME (4 )

, LI , L2 , I SRFLG

DIMENSION X(3000)

DOUBLE PRECISION X ( SUM

EQUIVALENCE (X,A)

*CHECK TO SEE IF WE HAVE CORRECT NUMBER OF ARGUMENTS

*IF(NARGS.NE.IO) CALL ERROR (10)

CHECK TO SEE IF ALL ARGUMENTS ARE INTEGERS

*J=NARGS

CALL CKIND (J)

IF (J.NE.O) CALL ERROR (3)

*CHECK TO SEE IF DIMENSIONS ARE CORRECT

*GO TO (30,40) ,L2

IF (I ARGS (3) .NE. I ARGS (4) .OR. I ARGS (3) .NE. I ARGS (8;

GO TO 50

IF (IARGS(3) .NE.IARGS(4) .OR. I ARGS (3) .NE. I ARGS (7;

*CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE

COMPUTE ADDRESSES

CALL ERROR (3)

CALL ERROR (3)

IF (NARGS.EQ.10) GO TO

IARGS(12)=IARGS(L2+5)

IARGS(ll)=IARGS(L2+5)

GO TO 70

IARGS(12)=IARGS(L2+6)

IARGS(ll)=IARGS(L2+6)

GO TO 80

IARGS(10)=IARGS(NARGS)

IARGS(9)=IARGS(NARGS-1)

IARGS(8)=IARGS(NARGS-2)

IARGS(7)=IARGS(NARGS-3)

IARGS(6)=IARGS(5)

IARGS(5)=IARGS(4)

IARGS(4)=IARGS(3)

J =3

CALL MTXCHK (J)

60

TRA 100

TRA 110

, )TRA 120

TRA 140

TRA 150

TRA 160

, NTRA 170

TRA 180

TRA 190

TRA 200

TRA 210

TRA 220

TRA 230

TRA 240

TRA 250

TRA 260

TRA 270

TRA 280

TRA 290

TRA 300

TRA 310

TRA 320

TRA 330

TRA 340

TRA 350

TRA 360

TRA 370

TRA 380

TRA 440

TRA 450

TRA 460

TRA 470

TRA 480

TRA 490

TRA 500

TRA 510

TRA 520

TRA 530

TRA 540

TRA 550

TRA 560

TRA 570

TRA 580

TRA 590

TRA 600

TRA 610

TRA 620

TRA 630

TRA 640

TRA 650

TRA 660

314
IF (J-l) 110,90,100 TRA 670

90 CALL ERROR (3) TRA 680

RETURN TRA 690

100 CALL ERROR (17) TRA 700

RETURN TRA 710

C TRA 720 C CHECK FOR PREVIOUS ERRORS TRA 730 C * TRA 740

110 IF (NERROR.NE.O) RETURN TRA 750

IR0WA=IARGS(3) TRA 760

ISP=1 TRA 770

IR0WU=IARGS(11) TRA 780

GO TO (120,130) , L2 TRA 790

120 IADD1=1 TRA 800

IADD2=NR0W TRA 810

GO TO 140 TRA 820

130 IADD1=NR0W TRA 830

IA0D2=1 TRA 840

140 DO 180 J=1,IR0WU TRA 850

DO 170 I=1,IR0WU TRA 860

IUP=IARGS(5)+(I-1)*IADD1 TRA 870

IA=IARGS(1) TRA 880

IUT=IARGS(5)+(J-1)*IADD1 TRA 890

ISX=NS2 TRA 900

DO 160 L=l, IROWA TRA 910

IU=IUP TRA 920

DO 150 K=1,IR0WA TRA 930

X(ISX)=RC(IU)*RC(IA)*RC(IUT) TRA 940

ISX=ISX-1 TRA 950

IU=IU+IADD2 TRA 960

IA=IA+1 TRA 970

150 CONTINUE TRA 980

IA=IA+NROW-IROWA TRA 990

IUT=IUT+IADD2 TRA1000

160 CONTINUE TRA1010

CALL SORTSM ( IROWA* IROWA , SUM) TRA1020

A(ISP)=SUM TRA1030

ISP=ISP+1 TRA1040

170 CONTINUE TRA1050

180 CONTINUE TRA1060 C * TRA1070 C STORE RESULTS IN WORKSHEET TRA1080 C * TRA1090

IS=1 TRA1100

IC=IARGS(9) TRA1110

DO 200 J=1,IR0WU TRA1120

DO 190 I=1,IR0WU TRA1130

RC(IC)=A(IS) TRA1140

IS=IS+1 TRA1150

IC=IC+1 TRA1160

190 CONTINUE TRA1170

IC=IC+NROW-IROWU TRA1180

200 CONTINUE TRA1190

RETURN TRA1200

END TRA1210

315
SUBROUTINE TWOWAY (LL) TWO 10

C VERSION 5.0 TWOWAY 5/15/70 TWO 20

COMMON /BLOCRC/ NRC , RC ( 12600 ) TWO 30

COMMON /BLOCKD / I ARGS ( 100 ), KIND ( 100 ), ARGTAB ( 100 )

, NRMAX , NROW, NCOL , NTWO 40

1ARGS , VWXYZ (8 ) ,NERROR TWO 50

DIMENSION ARGS(IOO) TWO 60

EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 ) ) TWO 70

COMMON /HEADER / NOCARD (80) , ITLE (60 , 6 )

, LNCNT , IPRINT ,NPAGE , I PUNCH TWO 80

COMMON /KFMT/ KFMT(IOO) TWO 90

COMMON /SCRAT/ NS ,NS2 , A (13500 ) TWO 100

COMMON /ABCDEF/ L(48) TWO 110

DIMENSION IIRGS(IOO) TWO 120

EQUIVALENCE (KFMT , I IRGS ) TWO 130

DOUBLE PRECISION FDSQRT , DK2 , SUM TWO 140

DIMENSION AST0(120) TWO 150

EQUIVALENCE (ND1 ,KIND (100) ) , (ND2 ,KIND (99) ) , (ND3 ,KIND (98) ) , (ND4,TW0 160

1KIND(97)), (ND5,KIND(96) ) , (ND6 ,KIND (95 ) ) , (ND7 ,KIND (94 ) ) , (ND8,KITW0 170

2ND(93)), (ND9,KIND(92) ) , (ND10 ,KIND (91) ) , (ND11 ,KIND (90 ) ) , (ND12,KTW0 180

3IND(89)), (ND13,KIND(88)) , (ND14 ,KIND (87 ) ) , (ND16 ,KIND (86) ) , (ND17TW0 190

4,KIND(85)), (ND18,KIND(84) ) , (ND19 ,KIND (83 )

) TWO 200

Q ************************************************************** yyQ 210

C OMNITAB TWOWAY ANALYSIS OF VARIANCE SUBROUTINE TWO 220

C WRITTEN BY DAVID HOGBEN , SEL, NBS . 4/17/69 VERSION. TWO 230

C TWO 240

C TWOWAY ANALYSIS FOR R = C = DATA IN ++ VECTORS START IN ++ TWO 250

C (WEIGHTS IN COL ++) TWO 260

C MEASUREMENTS ARE STORED IN THE COLUMN ROW BY ROW TWO 270

C LAST ARGUMENT USED ONLY IF WEIGHTS ARE UNEQUAL (E.G. IF ZERO WTS TWO 280

C FOR MISSING OBSERVATIONS OR REJECTED OUTLIERS) TWO 290

C COEFFICIENTS ARE STORED IN COL (X+R+C-l) TWO 300

C RESIDUALS ARE STORED IN COL (X+R+C) TWO 310

C STANDARD DEVIATIONS OF PREDICTED VALUES ARE IN COL (X+R+C+l) TWO 320

C SUMS OF SQUARES ARE STORED IN COLUMN (X+R+C+2) TWO 330

C R*C MUST = NRMAX WHICH MUST BE LESS THAN OR EQUAL TO NO. OF ROWS TWO 340

C (X+R+C+2) MUST BE LESS THAN OR EQUAL TO THE NUMBER OF COLUMNS TWO 350

C R+C+6 MUST BE LESS THAN OR EQUAL TO NCOL TWO 360

C TUKEY/S TEST FOR NON-ADDITIVITY IS NOT DONE IF WTS ARE SPECIFIED TWO 370

C IF ZERO WTS ARE USED FOR M.O. THE ESTIMATES GIVEN ARE THE SAME AS TWO 380

C THOSE OBTAINED FROM DATA AUGMENTED USING THE M.O. FORMULA TWO 390

C SIZE OF TABLED CONSTRAINED BY NS AND ORTHO TWO 400

C MID-RANGE SUBTRACTED BEFORE DOING FIT TWO 410

C AUTOMATIC OUTPUT USING READABLE FORMAT TWO 420

C TABLE OF STANDARDIZED RESIDUALS IS GIVEN ON PAGE TWO. TWO 430

C FORMAT STATEMENT NUMBERS ARE * TWO 440

C TWO 450

Q ******************************************************************"[ yyQ

C LINES 10 TO 20 GIVE CONSTANTS TWO 470

IXl(I,J,IN)=IN+(I*(I-l))/2+J TWO 480

M1=IARGS(1) TWO 490

M2=IARGS(2) TWO 500

M3=IARGS(3) TWO 510

M4=M1*M2 TWO 520

M5=M1+M2-1 TWO 530

M6=M1-1 TWO 540

M7=M1+1 TWO 550

M8=M2-1 TWO 560

M9=M6*M8 TWO 570

M10=M4-1 TWO 580

M11=IARGS(4) TWO 590

316
TP i M A R ri C FO C \ Ml 1 — I ARCQ I c. \ t1 wonu Ann O u u

WIX J =llrtl\V3 J t1 wnnU AO 1X 0U Ml 4 — 1 TWO A?n

Ml 5—M9 1 (VI 1 J —flfl7— X TWO 1 nu aO Jinu Ml A — MA_i_Mft TWO i nu AAn o *t u MlMl 7—MA / 5 / =IVIH / L t wo a «; n M9 0—MQ T WO AAn

TF1 r /Ml IT 0 OR M? IT ">\ GO TO 9tt ^ mx . I_ 1 . L . U 1 \ . n\C .LI . t J UU 1 u 7U Ti WOnu Ao 7/ nu M? 1 —? * / Ml 4.M? \ j.1 TWO Afin r LINES 30 TO 90 GIVE ERROR CHECKS TWO AQn

tf /Mil 4i in 9n in tI wnnu 7/ nuun

X1 nu C Al 1 ERROR 11(11 TWO i nu 71( iun RETURN TWO i nu 7?n 1 cm

?oL U TE i T ARGS i 1 \ T ARGS IA.W fiO Q0 Qn TWO i nu 7in / j u 10 teir iL minix .?i — r i An An in 3y *rU,*tU,Xv TWO i nu 7Art i hu

AO TF ( IABC^ fni wrni i An An sn Ti wnnu 7/ j1; nu V/nLL P Al 1 ERROR r_lM\UB\ /111 IXXJ ti wnnu 7/ Ano u RFTURN Twn i nu 77n i i u

Art Ti WOnu 7f oufi n 70 TF MARG^f^ T ARGS f4n AO Qfl QO TWO i nu 79n / 7 u

fin no 1 1 0 T— 1 Ml % ti wnnu ouy ann

TF ( K T NO ( 7 \ \ QO 100 QO ti wnnu «oiui n

7 U

r Ai | FRROR ( % \ ti wnnu ftocu7 n RETURN ti wnnu ftoj\j i n 100 TF (lARfi^flM 50 50 110 Twn i nu ftAO ohu

110 CONTINUE t1 wnnu ftODUs n IF (NRMAX-IARGS(1)*IARGS(2)) 120,130,120 TWn i nu RAO oou

1 20 CALL ERROR (16) Twn i nu B7n of

u

RETURN T WO H ft (1

i nu oou

iX Jin\J IF (M5+M11+2 LT NC0L AND M21+6 LT NROWi GO TO 140 ti wnnu ftO/Uq n CALL ERROR (17) t wn q n n RETURN ti wnnu q7iui n 140 NARGS=M5 t1 wnnu o7£U7 n IF (M5+7.GT.NC0L) GO TO 10 Twn i nu 9in

DO 150 1=1, M5 TWO 940

KIND ( I )=0 TWO I nu 9^n y DU

ISO IARGS(I)=M11+I-1 Twn i nu Q7 Ano v CALL CHKC0L (J) ti wnnu 97 7/ nu IF (J.NE.O) GO TO 90 TWO i nu 9fl0 7DU

IF (NERR0R.NE.0) RETURN Twn 1 nu 99n 77U

p LINES 100 TO 150 CONSTRUCT DESIGN MATRIX ti nonu iuuu li n ifi n K=IARGS(1)-1 twoi oi

n

i nu iuiu

DO 160 U1,M4 twoi i nu iu£u n?n

M19=K+I Twni nin

xou 1 AO RC(M19)=1.0 T WO 1 ft f ft 1 nu x u * u DO 180 1=2, Ml Twm 1 nu iuju nsn K1=IARGS(I) T1 H0nuxuou 1 ft k 0

DO 170 K=1,M6 Twm 1 nu iu/u n7n

DO 170 J=1,M2 T HO 1 ft ft ft 1 nuxuou

K2=K1+M2*(K-1)+J-1 TWOI 1 nu x 090 u 7 u RC(K2)=0. T1 15)01 11 v x X100w v

1if70u IF (K.EQ.I-1) RC(K2)=1.0 TWOI 1 nu x 110 x x u DO 180 J=1,M2 TWOI 1 nu 114U 1 70

K2=K1+M2*(M1-1)+J-1 TWOI 1 nu x 1x jinu

1 R0 RC(K2)=-1.0 TWO1 1 nu x 1x AOhu

DO 200 I=M7,M5 TW01 1 nv 11150Jv

DO 200 K=1,M1 TWHl 1 AO

DO 190 J=1,M8 TW01170 1 WW X 1 r v K2=IARGS(I)+M2*(K-1)+J-1 TW01180

317

409-118 OL - 71 - 21
D P / 1/ 0 \ ft ft KL (IV 2 )=U .

u

T Uift 1 1 O A 1V0 tr i

1 c p. T Ml \ DP / \ _1 ft lr \ J . Ly . 1—Ml J KL(I\£} = 1.0 T lun 1 O A A

1 WU12 00

if 0 TADPC/T \ i MO * 1 l\2 = 1 AKtob ( 1 ) +MZ N —

1

t u/n 1 O 1 A

1 WU 1 2 1

0

o a a 200 D P / 1/ o \ 1 ft KL (K2 )=-! .

0

t urn 1 O O A

1 WU1220

L

1 TMPC 7ftft Tfl 505 PAI 1 MCU/ nDTUin LllMtO JOU IU i co LALL NLW UK 1 HU Tu/n ioift 1 WU 1 2 3 0

Kl A DP C Ml . MO . A INAKljb=Ml+M2+0 T ii/n 1 O A A

1 WU1240

I AOTC ( 1 1 M7 1 AKbb ( 1

)

=mi T U/n 1 O C A

1 WU1250

T AOr C 1 0 \ Mil 1 AKuj ( L

)

=M1

1

t u/n i Tin 1 WU 1 2 o 0

UU tlU i=4,NAKuo T U/n 10 7ft1 WU 1 2 / 0

o i n £ 1 UIIAKoj ART C ( I \ Ml 1 , T A \ I } =IVI1 1 + 1 —4 t u/n i o o ft

1 WU12U0

PLALL A 1 1 AUK AnDFCC 11 Y \ t o 0 ( 1 , IV ) t u/n i o a ft

1 WU12V0

rr / mi 7 rrt a \ pn Tn ooft lr (Ml.J.ty.4) UU IU 220 t u/n i a a a

1 WU

1

5 0 0

IAKuj i adtc n \ mi o

( c ) =IVI1 i. T U/n 17 1ft

1 WU 1 i 1

0

PLALL A 1 1 AUKtii A nD F C Q / o 1 N (2, J) t u/n 170ft 1 WU 1.320

1 1 1 J =J —1 T U/n 17 7ft

1 WU1J30

o o n 220 PfiMC 1 DP /V

i

LUNbl=KL (IV ) t u/n 1 7 A A

1 WU

1

5 4 0

LUIMb2=KL (IS ) T U/n 1 7 C A 1 WU 1 i o 0 nn o^ft T 1 MA UU 240 1=1, M4 T u/n 1 7 A ft

1 WU1 ibv

tc

1 r /Mil cn rn to 07n ( Ml 3 . ty • 1 } oU IU C3\) T u/n 17 7ft1 WU

1

3 1 U J=J +1 t u/n 1 7 D ft

1 WUIjoU

TC / DP / 1 \ \ 04ft 0 A ft 07ft lr ( KL ( J ) ) 240 , 240 , 2 .JO t u/n 1 7 Q A 1 WU13 7U

TC (DP /V \ IT PfiMClN pnwci or IV

\

lr (KL(IV) .LI .LUNbl) LUIMbl=KL (IV ) T U/n 1 A ft ft1 WU1400

TC /DP/i/\ PT PPWCON PPiMCO Dp lr (KL(N) .ol .LUNb2) LUNb2=KL(K) T U/n l yl l ft

1 WU1410

0240A ft Y Y i 1 l\=l\ + l t u/n i a o ft

1 WU1420

l\=l\—PAH R0= /PPiMCl Pf\WCO\ /O ft (LUIMbl+LUNb2 ) / 2 . 0 T U/n l yl jl ft

1 WU144U

nn o c n t i ma UU dO\J 1 = 1 , M4 t u/n i a c n 1 WU145U

Ml 0 Y l .1 Ml7=l\— 1 + 1 TU/m A/Lft

1 WU140 0

ltd DP 1 Ml Q \ DP 1 Ml Q \ Q KL (Ml 7 )=KL (Ml V

) —

D

T U/n 1 A 7 ft

1 WU 14 / 0 nnUU OAft 2 o

T 1 MADPC 0 1 = 1 , INAKbb T U/n 1 A Q ft

1 WU140U

0 £ ft 26U Y T Un 1 T \ ft r\ 1 NU ( 1

) =0 t u/n 1 A 0 ft

1 WU147 0

1 0 A L2=4 TU/m en ft

1 WU13U0

TADPCf7\ Ml .MO 1

1 AKbb

(

i )=M1+M2-1 t u/n i c i ft

1 WU 1510

P Pi TH £ Q ft bU IU oVO Tu/m 1 WU con 1 D L U

0 7ft 2/0 TC /MCDDHD MC ft \ DC Tl 1 DM lr ( IMLKKUK . Nt . 0 ) KLIUKN T U/n 1 C 7 ft

1 WU 13 JU

p 1 TMCC lift TPi 7Aft PPiMDIITC PPiC C C T P T C MTC AMD, TUCTD CTfl HFUTATTOMC L 1 Ntb 33\J IU JoU LUMr U 1 t LULr r 1 L 1 LN 1 o ANU 1 ML 1 K OIU. ULV1AI1UN3 t1 u/n i cAn HU1D4U

PAI 1 AftDCCC /MADPC 1 Y\ LALL AUKLbb (NAKbb-3,K) TUim KKft 1 WUiDDO

ACTP./Ml.11\ A Ab 1 U (Ml+11 )=0

.

TUim 1 WU1300 cin

ft A O O ft T 1 ML l)U 2B0 1 = 1 , Mo TU/m K7ft 1 WU1D /

u

MIO T . Y Ml 7=1 +1^ t mini «; ft ft

i nu

i

j o u ACTA / I . 11 \ DP/MIOX Ao 1 U ( 1 +1 1 )=KL ( Ml 7

)

t1 u/n HU1icon 3YU

A C TO / Ml , 1 1 \ ACTA / Mi ,11 \ DP 1 Ml Q \ Ab 1 U ( Ml+1 1

) =Ab 1 U ( Ml+1 1

) -KL (Ml V

)

T u/n 1 A ft. ft VI 1 O . Ml . MO . T I^J = 12+M1+M2 + 1 Tj/nuin i nu loiu

Y A Y . Ml . MO . T K4=K+Ml+Mo+l T U/n 1 A 0 ft

1 WUlOtU

O O ft 280 ACTn/l/lx DP ( V A \ Ab 1 U (l\3 )=KL (K4 ) t u/n i /.in

V 1 Ml . Ml . MO . 1 1 I\3=M1+M1+M2+1

1

T U/n 1 AAft

acta / vi . i \ ACTn/i/7\ Ab 1 U (K3+1 )=Ab 1 U (K3

)

T u/n i a c n i nu i o j u V A Y . ML . MO K4=K+M6+MZ T U/n 1 A A ft.

1 HU 100

U

ACTA / lie 10\ DP/I/>I\ Ab 1 U (M5+13 )=KL (K4

)

t u/n 1 A 7 ft

i nu i o / u

jCTrt / lie . 1 O \ A Ab 1 U (M5+12 )=0

.

t u/n i a ft ft, i nu i o o u nn ooft t i mq UU 2VU 1=1 , Mo twoi Aon

V A 11. Ml . T K4=l 1+M1+1 ti uim nu i/uu 7 n n

L/C 1/ 11/ . T K5=K+M6+I ti u/n nu 1i 7/ iu1 n ASTO (K4 )=RC (K5

)

T U/n 17 9ft i nu \.i cm

1/ A 1/ c kflo til K4=K5+M8+M1 \ nu i

/

j u YC Y 1 . T . 1 Ko=lv.J + l +1 TW01740

h CTf\ t V L \ D P i Y A \ Ab 1 U (Ko )=KL (K4

)

twoi 1 If M li7^n

o o ft 270 ACTn ( MR .1 0 \ ACTrt / MC . 1 0 \ OC lY c, \ Ab 1 U ( Mt) + 1 C ) =A j 1 U ( mO + li ) —KL(I\3; TW01760

AST0(M21+11)=AST0(M21+10) TW01770

318
c

c

c

cc

300

310

320

330

K5=K+M21+7

00 285 1=1,6

K5=K5-1

285 RC(K5)=RC(K5-4)

LINES 400 TO 430 COMPUTE TERMS FOR ANOVA

IF (LL.EQ.7) GO TO 350

IF (M13.EQ.5) GO TO 430

CALL ADRESS (NARGS ,K)

A(1)=0.

A(2)=0.

DO 310 1=1, M6

M19=K+I

A(1)=A(1)+RC (M19)

DO 320 1=1, M8

K4=M6+I+K

A(2)=A(2)+RC(K4)

K4=K+M5

A(3)=RC(K4)

A(4)=RC(K4+1)-RC(K)

A(5)=A(1)/FL0AT(M6)

A(6)=A(2)/FL0AT(M8)

A(7)=A(3) /FLOAT (M9)

A(8)=A(5)/A(7)

A(9)=A(6)/A(7)

CALL PROB (FLOAT (M6) , FLOAT (M9) ,A(8),A(10))

CALL PROB ( FLOAT (M8) , FLOAT (M9) ,A(9),A(11))

CALL RFORMT (A ( 1 ) ,4 , 8 , NW1 , NDEC1 , 20 , A ( 1 )

, A ( 1 )

, 0 , 0

)

CALL RFORMT (A (5) ,3 ,8 ,NW2 ,NDEC2 ,20,A(1) ,A(1) ,0,0)

CALL PAGE (4)

WRITE (IPRINT,1680) M1,M2

IF (M13.EQ.5) GO TO 510

CALL RFORMT (A (1 )

, 1 , 8 ,NW1 ,NDEC1 , 0 , A (1 ), A ( 101 )

, 25-NW1 , 0

)

CALL RFORMT (A (1 )

, 1 , 8 ,NW2 , NDEC2 , 0 , A (5 ), A ( 126 ), 25-NW2 , 0

)

LINES 500 TO 550 PRINT ANOVA WHEN ALL WEIGHTS EQUAL ONE

WRITE (IPRINT,1690) M6 , (A ( I )

, 1=101 , 150 )

, A (8 ), A ( 10

)

CALL RFORMT (A ( 1 ), 1 , 8 , NW1 ,NDEC1 , 0 , A (2 ), A ( 101 ), 25-NW1 , 0

)

CALL RFORMT (A (1 ), 1 , 8 ,NW2 ,NDEC2 , 0 , A (6 ), A ( 126 )

, 25-NW2 , 0

)

WRITE (IPRINT,1700) M8 , (A ( I )

, 1=101 , 150 ), A (9 ), A ( 11

)

CALL RFORMT (A ( 1 )

, 1 , 8 , NW1 , NDEC1 , 0 , A (3 ), A (201 )

, 25-NWl ,0

)

CALL RFORMT (A (1 ), 1 , 8 , NW2 ,NDEC2 , 0 , A (7 ), A (226 ), 25-NW2 , 0

)

WRITE (IPRINT,1710) M9 , (A ( I ), 1=201 , 250

)

CALL RFORMT (A (1 )

, 1 , 8 ,NW1 , NDECl , 0 , A (4 )

, A ( 101 ), 25-NWl , 0

)

WRITE (IPRINT,1720) M10 , (A ( I )

, 1=101 , 125

)

LINES 600 TO 645 COMPUTE AND PRINT FOR TUKEY'S TEST

CALL ADRESS (1,J)

A(12)=0.

DO 330 11=1, Ml

DO 330 12=1, M2

J1=J+M2*(I1-1)+I2-1

M19=M1+11+I2

A(12)=A(12)+AST0(I1+11)*AST0(M19)*RC(J1)

A(12)=(A(12)*A(12))/((A(1) /FLOAT (Ml )

) * (A (2 ) /FLOAT (M2) )

)

A(13)=A(3)-A(12)

A(6)=A(13)/FL0AT(M9-1)

A(16)=A(12)/A(6)

CALL PROB (1. ,FL0AT(M9)-1. ,A(16) ,A(17))

A(5)=A(12)

A(14)=A(3)

CALL RFORMT (A (12 ) ,3 , 8 ,NW1 , NDECl , 20 , A ( 1 )

, A (1 ) , 0 ,0

)

TW01780

TW01790

TW01800

TW01810

TW01820

TW01830

TW01840

TW01850

TW01860

TW01870

TW01880

TW01890

TW01900

TW01910

TW01920

TW01930

TW01940

TW01950

TW01960

TW01970

TW01980

TW01990

TW02000

TW02010

TW02020

TW02030

TW02040

TW02050

TW02060

TW02070

TW02080

TW02090

TW02100

TW02110

TW02120

TW02130

TW02140

TW02150

TW02160

TW02170

TW02180

TW02190

TW02200

TW02210

TW02220

TW02230

TW02240

TW02250

TW02260

TW02270

TW02280

TW02290

TW02300

TW02310

TW02320

TW02330

TW02340

TW02350

TW02360

319
340

C

350

360

370

380

390

400

CALL RFORMT (A (5) ,3 ,8 ,NW2 ,NDEC2 ,20 ,A(1) ,A(1) ,0,0)

CALL RFORMT (A (1 )

, 1 , 8 , NW1 ,NDEC1 , 0 , A (12 )

, A (101 ), 25-NW1 ,0

)

CALL RFORMT (A (1) , 1 ,8 ,NW2 ,NDEC2 ,0 , A (5) , A (126) , 25-NW2 ,0

)

WRITE (IPRINT,1740) M14 , (A ( I ), 1=101 , 150 ), A ( 16 ), A (17

)

CALL RFORMT (A (1 )

, 1 , 8 ,NW1 ,NDEC1 , 0 , A ( 13 )

, A ( 101 ), 25-NWl , 0

)

CALL RFORMT (A (1) ,1,8 ,NW2 ,NDEC2 ,0,A(6) ,A(126) , 25-NW2 ,0

)

WRITE (IPRINT,1750) M15 , (A ( I ), 1=101 , 150

)

CALL RFORMT (A ( 1 ), 1 , 8 , NW1 , NDECl , 0 , A ( 14 ), A ( 101 )

, 25-NWl , 0

)

CALL RFORMT (A (1 ), 1 , 8 , NW2 ,NDEC2 , 0 , A (7 ), A ( 126 ), 25-NW2 , 0

)

WRITE (IPRINT,1710) M9 , (A ( I )

, 1=101 , 150

)

WRITE (IPRINT,1760)

DO 340 1=1,4

ASTO(I)=A(I)

LINES 650 TO 690 PRINT COEFFICIENTS AND THEIR STD . DEVIATIONS

CALL ADRESS (1,K)

DO 360 1=1 ,M4

K5=K-1+I

RC(K5)=RC(K5)+B

J=K

CALL ADRESS (NARGS-3 ,K)

K5=K+M21+7

DO 370 1=1,6

K5=K5-1

RC(K5)=RC(K5-4)

DO 380 1=1, M21

K5=K+I

RC(K5)=AST0(I+11)

RC(K)=RC(K)+B

K5=K+M21+1

A(1000)=RC(K5)

RC(K5)=RC(K5+3)

CALL ADRESS (2,J1)

CALL ADRESS (NARGSJ2)

A(1002)=0.0

SUM=O.ODO

DO 390 1=1, M4

A(1002)=A(1002)+RC(J1)

SUM=SUM+RC(J1)*RC(J)**2

J=J+1

J1=J1+1

J1=J2+M1+M2

RC(J1)=SUM

RC(J1+1)=RC(J1+1)+B*FSQRT(A(1002)

)

RC(J2)=RC(J1+1)**2

IF (LL.EQ.6) GO TO 400

RC(K5)=A(1000)

RETURN

K5=K+M5+2

CALL RFORMT

CALL RFORMT

CALL RFORMT

CALL RFORMT

WRITE (IPRINT,1770)

K5=K+M21+1

RC(K5)=A(1000)

DO 410 1=1, Ml

K5=K+I

K6=K5+M5+2

CALL RFORMT (A (1 ) , 1 , 8 , NW3 ,NDEC3 , 0 , RC (K5 )

, A (101 ) , 25-NW3 , 0

)

(RC(K) ,M5+2,8,NW3,NDEC3,20,A(1) ,A(1) ,0,0)

(RC(K5) ,M5+3,8,NW4,NDEC4,20,A(1) ,A(1) ,0,0)

(A(l) ,1,8,NW3,NDEC3,0,RC(K) ,A(101) ,25-NW3,0)

(A(l) ,1,8,NW4,NDEC4,0,RC(K5) ,A(126) ,25-NW4,0)

(A(J),J=101,150)

TW02370

TW02380

TW02390

TW02400

TW02410

TW02420

TW02430

TW02440

TW02450

TW02460

TW02470

TW02480

TW02490

TW02500

TW02510

TW02520

TW02530

TW02540

TW02550

TW02560

TW02570

TW02580

TW02590

TW02600

TW02610

TW02620

TW02630

TW02640

TW02650

TW02660

TW02670

TW02680

TW02690

TW02700

TW02710

TW02720

TW02730

TW02740

TW02750

TW02760

TW02770

TW02780

TW02790

TW02800

TW02810

TW02820

TW02830

TW02840

TW02850

TW02860

TW02870

TW02880

TW02890

TW02900

TW02910

TW02920

TW02930

TW02940

TW02950

320
CALL RFORMT (A (1 ) ,1,8 ,NW4 , NDEC4 , 0 ,RC (K6 )

, A (126) , 25-NW4 , 0

)

410 WRITE ( IPRINT , 1780) I , (A ( J ) , J=101 , 150

)

WRITE (IPRINT, 1760)

DO 420 1-1,112

K5=K+M1+I

K6=K5+M5+2

CALL RFORMT (A (1 ) ,1,8 ,NW3 ,NDEC3 , 0 ,RC (K5 ), A (101 ), 25-NW3 ,0

)

CALL RFORMT (A(l) ,1,8,NW4 ,NDEC4 ,0 ,RC (K6) , A (126) , 25-NW4 ,0

)

420 WRITE (IPRINT, 1790) I , ( A ( J ) , J=101 , 150

)

K6=K+M2H4

CALL RFORMT (A (1) ,1,8 ,NW4 ,NDEC4 ,0 ,RC (K6) , A ( 101 )

, 50-NW4 ,0

)

WRITE (IPRINT, 1760)

WRITE (IPRINT, 1800) (A ( J ) , J=101 , 150

)

ASTO ( 1

) =ASTO ( 1 ) +ASTO ( 2 ) +ASTO (3

)

AST0(2)=ABS(AST0(4)-AST0(1) ) /ASTO (4)

IF (AST0(2) .GT.5.E-7) CALL ERROR (228)

GO TO 630

C LINES 700 TO 780 GIVE ANOVA WHEN WEIGHTS ARE SPECIFIED

430 CALL ADRESS (2, J)

C CHECK ON WEIGHTS

K5=J-1

DO 470 11=1, Ml

M31=0

DO 460 12=1, M2

K5=K5+1

IF (RC(K5)) 440,450,460

440 CALL ERROR (223)

RETURN

450 M31=M31+1

M9=M9-1

460 CONTINUE

IF (M31.NE.M2) GO TO 470

CALL ERROR (224)

RETURN

470 CONTINUE

K5=J-1

DO 500 11=1, M2

M31=0

DO 490 12=1, Ml

K5=K5+1

IF (RC(K5)) 480,480,490

480 M31=M31+1

490 CONTINUE

IF (M3.NE.M1) GO TO 500

CALL ERROR (224)

RETURN

500 CONTINUE

M10=M6+M8+M9

GO TO 300

510 J=5

DO 520 1=1, M8

IARGS(J)=M11+M6+I

520 J=J+1

DO 530 1=1, M6

IARGS(J)=M11+I

530 J=J+1

DO 540 1=1,11

540 ASTO(I)=A(I)

CALL ADRESS (1,J)

TW02960

TW02970

TW02980

TW02990

TW03000

TW03010

TW03020

TW03030

TW03040

TW03050

TW03060

TW03070

TW03080

TW03090

TW03100

TW03110

TW03120

TW03130

TW03140

TW03150

TW03160

TW03170

TW03180

TW03190

TW03200

TW03210

TW03220

TW03230

TW03240

TW03250

TW03260

TW03270

TW03280

TW03290

TW03300

TW03310

TW03320

TW03330

TW03340

TW03350

TW03360

TW03370

TW03380

TW03390

TW03400

TW03410

TW03420

TW03430

TW03440

TW03450

TW03460

TW03470

TW03480

TW03490

TW03500

TW03510

TW03520

TW03530

TW03540

321
(1,J)

(2,K)

(NARGS-2,K1)

(NARGS-1.K2)

CALL ADRESS (2,K)

DO 550 1=1, M17

K5=J-1+I

K6=J+M4-I

A(20)=RC(K5)

RC(K5)=RC(K6)

RC(K6)=A(20)

K5=K-1+I

K6=K+M4-I

A(20)=RC(K5)

RC(K5)=RC(K6)

550 RC(K6)=A(20)

GO TO 690

560 CALL ADRESS

CALL ADRESS

CALL ADRESS

CALL ADRESS

DO 570 1=1, M17

K5=J-1+I

K6=J+M4-I

A(20)=RC(K5)

RC(K5)=RC(K6)

RC(K6)=A(20)

K5=K2-1+I

K6=K2+M4-1

A(20)=RC(K5)

RC(K5)=RC(K6)

RC(K6)=A(20)

K5=K1-1+I

K6=K1+M4-I

A(20)=RC(K5)

RC(K5)=RC(K6)

RC(K6)=A(20)

K5=K-1+I

K6=K+M4-I

A(20)=RC(K5)

RC(K5)=RC(K6)

570 RC(K6)=A(20)

A(18)=0.

CALL ADRESS (NARGS ,K)

DO 580 1=1, M8

K5=I+K

580 A(18)=A(18)+RC(K5)

A(17)=0.

DO 590 1=1 ,M6

K5=M2+I+K-1

590 A(17)=A(17)+RC(K5)

Jl=M21-2

K5=201

K6=K+1

DO 600 1=1, Jl

A(K5)=RC(K6)

K5=K5+1

600 K6=K6+1

K5=K+1

K6=201+M8

Jl=K+M16+4

J2=204+M16+M8

DO 610 1=1, M6

TW03550

TW03560

TW03570

TW03580

TW03590

TW03600

TW03610

TW03620

TW03630

TW03640

TW03650

TW03660

TW03670

TW03680

TW03690

TW03700

TW03710

TW03720

TW03730

TW03740

TW03750

TW03760

TW03770

TW03780

TW03790

TW03800

TW03810

TW03820

TW03830

TW03840

TW03850

TW03860

TW03870

TW03880

TW03890

TW03900

TW03910

TW03920

TW03930

TW03940

TW03950

TW03960

TW03970

TW03980

TW03990

TW04000

TW04010

TW04020

TW04030

TW04040

TW04050

TW04060

TW04070

TW04080

TW04090

TW04100

TW04110

TW04120

TW04130

322
610

620

630

640

RC(K5)=A(K6) TW04140

RC(J1)=A(J2) TW04150

K5=K5+1 TW04160

K6=K6+1 TW04170

J1=J1+1 TW04180

J2=J2+1 TW04190

Jl=K+Ml6+M8+3 TW04200

J2=204+M16 TW04210

DO 620 1=1 ( M8 TW04220

RC(K5)=A(I+200) TW04230

RC(J1)=A(J2) TW04240

K5=K5+1 TW04250

J1=J1+1 TW04260

J2=J2+1 TW04270

A(19)=A(17) /FLOAT (M6) TW04280

A(20)=A(18) /FL0AT(M8) TW04290

A(21)=A(19) /AST0(7) TW04300

CALL PROB (FLOAT (M6) , FLOAT (M9) ,A(21) ,A(22)) TW04310

CALL RFORMT (A ( 1 )

, 1 , 8 , NW1 , NDECl , 0 , A ( 17 )

, A ( 101 ), 25-NW1 , 0

)

TW04320

CALL RFORMT ( A ( 1 )

, 1 , 8 ,NW2 , NDEC2 , 0 , A ( 19 )

, A ( 126 ), 25-NW2 , 0

)

TW04330

WRITE (IPRINT . 1690) M6 , (A ( I )

, 1=101 , 150 )

, A ( 21 ), A (22

)

TW04340

CALL RFORMT ( A ( 1 )

, 1 , 8 , NW1 , NDECl , 0 , A ( 18 )

, A ( 101 ), 25-NW1 , 0

)

TW04350

CALL RFORMT ( A ( 1 )

, 1 , 8 , NW2 , NDEC2 , 0 , A (20 )

, A (126 ), 25-NW2 , 0

)

TW04360

WRITE (IPRINT, 1700) M8 , (A ( I )

, 1=101 , 150

)

TW04370

CALL RFORMT (A (1 )

, 1 , 8 , NW1 , NDECl , 0 , ASTO (3 )

, A ( 101 ), 25 -NW1,0) TW04380

CALL RFORMT (A ( 1 )

, 1 , 8 , NW2 ,NDEC2 , 0 , ASTO (7 )

, A ( 126 )

, 25 -NW2,0) TW04390

WRITE (IPRINT, 1710) M9 , (A ( I )

, 1=101 , 150

)

TW04400

CALL RFORMT (A ( 1 )

, 1 , 8 , NW1 ( NDEC1 , 0 , ASTO (4 )

, A ( 101 )

, 25 -NW1,0) TW04410

WRITE (IPRINT, 1720) M10 , (A ( I )

, 1=101 , 125

)

TW04420

CALL RFORMT (A ( 1 ), 1 , 8 , NW1 , NDECl , 0 , ASTO ( 1 )

, A ( 101 )

, 25 -NW1 ,0) TW04430

CALL RFORMT (A ( 1 ), 1 , 8 , NW2 ,NDEC2 , 0 , ASTO (5 )

, A ( 126 )

, 25 -NW2,0) TW04440

WRITE (IPRINT,1690) M6 , (A ( I )

, 1=101 , 150

)

TW04450

CALL RFORMT (A ( 1 )

, 1 , 8 , NW1 , NDECl , 0 , ASTO (2 )

, A ( 101 ), 25 -NW1,0) TW04460

CALL RFORMT (A (1 ), 1 , 8 ,NW2 ,NDEC2 , 0 , ASTO (6 )

, A ( 126 ), 25 -NW2,0) TW04470

WRITE (IPRINT, 1700) M8 , (A ( I ), 1=101 , 150 )

, ASTO (9 ), ASTO ( 11

)

TW04480

CALL RFORMT (A ( 1 ), 1 , 8 , NW1 , NDECl , 0 , ASTO (3 )

, A ( 101 )

, 25 -NW1 ,0) TW04490

CALL RFORMT (A ( 1 ), 1 , 8 , NW2 , NDEC2 , 0 , ASTO (7 )

, A ( 126 ), 25 -NW2,0) TW04500

WRITE (IPRINT, 1710) M9 , (A ( I ), 1=101 , 150

)

TW04510

CALL RFORMT (A ( 1 ), 1 , 8 , NW1 , NDECl , 0 , ASTO (4 )

, A ( 101 ), 25 -NW1,0) TW04520

WRITE (IPRINT, 1720) M10 , (A ( I )

, 1=101 , 125

)

TW04530

M31=M5+M9 TW04540

M32=M4-M31 TW04550

WRITE (IPRINT, 1730) M31,M32,M12 TW04560

CALL ADRESS (NARGS-3 ,K) TW04570

K5=K+M6+M2+M2 TW04580

K6=K+M1+M2 TW04590

K3=M1+M1+M2+12 TW04600

AST0(K3)=RC(K5) TW04610

AST0(M21+11)=RC(K6) TW04620

GO TO 350 TW04630

CALL PAGE (4) TW04640

WRITE (IPRINT, 1810) M1,M2 TW04650

M31=MIN0(15,M2) TW04660

DO 640 I=1,M31 TW04670

KIND (I )=I TW04680

WRITE (IPRINT, 1820) (KIND ( I ), 1=1 , M31

)

TW04690

WRITE (IPRINT, 1830) TW04700

CALL ADRESS (NARGS-2,J) TW04710

CALL ADRESS (NARGS-1,K3) TW04720

323
TP /Mil FO s \ KTMn/^—ft tc /Mil Pn c \ PA| 1 AftDPCC

( L , W) L ) T U/fl A 7 Aft

1 VlU'J / 4U nnU U

A7ft 0 < U T—1 = 11, MAKIH Tl|lfti7 eft

1 BUt / DU

TP1 r /Mil ( ml j . FnCy . «;

_> ^

) onuu to. 1 U Asn OjU TU/0A7 Aft 1 HUH / 0 U ami DO | | \ / CCnOT / DP / K A \ * * A \ i ) =Ku i J ) I r I ( ku ( no ) ? or t v i \ * * ?

\

TUI0A7 7 ft

I nut / /

U

rnuu Trt AAft i u oou T U/O A 7 Q ft

1 WUH / OU

a k n 0 DU tf ioriu, 1 r x')\ ct ft n\ a/t\_ \ Ku ( mj L) .ul . U . U ) A 1 1 ; =Or 1 l \ /FCnDT^/DP/I^A\**9 \ IDC t WiO \ —orKL> / k ~i \ * * 9TU/OA7 on IIS J ) £lnUH/7U

i \ «

)

TUIOAfiftft 1 nUHOUU

T F IOC I Ml 5 1 IF ft ft\ A / T \ — Ir I K w Nlj c ) . L C . U . U J A v 1 J = ft ft u . u TWOAQ 1 ft

i nuHoiu

MlWlj 5—C—mjC+l Ml 5x1 TUJOAQon oou J=J +1 t \un a q i f\

1 WU'to

a 7 ft 0 / u kIV J=IV.} 7.—U 1^1+ 1 T U/n A Q A ft nOUU ARft OOU T— 1 Ml 1 = 1 , Nil t u/n A Q C ft

1 WU40DU

WRTTF nftllC /TPRTNT llrl\lNI,l/OU/ 17A(11 T U/n A O A ft

1 WUtoOU

Mlmj 1i ——M9* mc 11 "\ \ ^ i — ± j T u/n A O 7 ft

i nuto /

u

It A —Ml 1 ] MO t u/n jtoon

KB=M31+1 t u/n yioon 1 WU407U

Ann oou WRITE (IPRINT,1840) I , (A (K) ,K=KB , KA) T U/n A O ft ft

1 WU47UU

RETURN T U/n A O 1 ft r\j THIS IS NEW ORTHO - SFIT PORTION T U/n A Q 9 ft AQft 0 7ll NMUI=1 T U/n A Q 1 ft

1 nUt7 JU

CALL ADRESS (1,1 IRGS ( 1 )

)

t u/n A O A ft CALL ADRESS (2,1 IRGS (2 )

)

t u/n A O C ft NST=1 T U/n A Q A ft

1 BU470U

NEND=NARGS TU/nA07ft 1 HUH 7 /

U

DOK# W 700WW 1=4 A ~^ ~ f NEND 1 • 1_ 1 w T U/n A Q B ft CALL ADRESS (I I IRGS (In t u/n A O O ft

i n n CONTINUE t u/n q ft n n M=IARGS (3

)

t u/n c n i n i nusuiu

N=NRMAX T u/n ft 7 n FN-N t u/n c; ft •» n i nu 3 u j u CM ft ft JU—w .

U

T U/n CftAft 1 WuDUtU

1 22— I IRGS (2

)

TU/nQftRft 1 WU3U3U

L22A-L22 T WO <\ ft A ft

1 WUDUOU

DO 730 T— 1 N TW0<;n7n 1 iTUDU / U TFir /RPM??A\\ ^i\V/ 71ft 71ft 79ft \ L£lh j ) / iu , I j u , / lu T WO <v ft fl ft

1 WUDUOU

7i n / iu r Al 1 frror r o c \ T WO C ft Q ft

1 WUDU7U

RPTIIRKI T WO 5 1 ft ft

1 BUj 1UU

7 0 0 / C\J c 1 1 ci l , n n JU—jutl .

U

T1 woBUDciin 1 1U

7 in L££n 1 ??A——1U ?9Aj.1 ^ t n + 1 T WO 5 1 7 ft I BUj 1 C U FM=M t wo <; i n IF (SU-FM) 740,750,760 T WO C 1 Aft 1 BUj 1HU

7 A ft CALL ERROR (24) T1 woBU313U ci cn RETURN T WO C 1 Aft i nu jiou

/ jU DEN0M=1.0 T1 WOBU jl/U 5 1 7 n GO TO 770 TWOS l ftft 1 If W JIOU

7 a n / OU DENOM=FSQRT (SU-FM) T WO S 1 Q ft

1 BUJlTV

1 IV NPM=N+M T WO 5 9 ft ft

1 BUjtUU

M31=M-1 T wo coin i nu Di iu

M32=M+1 TWOS 9 9 ft

i nu dc cm N1=N-1 1 TIU Jt JU

N2=N+1 T WO c. 9 A ft

1 nUPtHU

MDl=(M*(M32))/2 T1 WOBUjljU c; o c n ND1=M32*NPM T WO C. 9 A ft

1 BUjlDU

ND2=M*NPM T WO S 9 7 ft

1 BUj C

1

U MD3=ND2+N TWO 5.90.(1 1 BUjlOU

ND3-ND1 i nu jt7u

ND4=ND3+NPM Ti WOnu jjuuft n ND5=ND4+NPM TW05310

324
780

790

800

810

820

830

840

850

ND6=ND5+M32 TW05320

ND66=MD1+M TW05330

N07=N06+ND66 TW05340

ND8=ND7+ND66 TW05350

ND9=ND8+M32 TW05360

N010=ND9+M TW05370

ND11=ND10+M TW05380

ND12=N011+M TW05390

ND13=ND12+MD1 TW05400

ND14=ND13+M32 TW05410

ND16=ND14+M TW05420

ND17=ND16+M TW05430

ND18=ND17+M TW05440

ND19=ND18+NPM TW05450

ND20=ND19+N TW05460

IF (ND20.GT.NS) CALL ERROR (23) TW05470

IF (NERROR.NE.O) RETURN TW05480

NRBAR=1 TW05490

1=4 TW05500

MXARGS=M+4 TW05510

L44=MXARGS-1 TW05520

J=l TW05530

DO 790 11=1, L44 TW05540

K1=J TW05550

L33=IIRGS(I1) TW05560

K2=K1 TW05570

DO 780 12=1,

N

TW05580

A(K2)=RC(L33) TW05590

K2=K2+1 TW05600

L33=L33+1 TW05610

J=J+NPM TW05620

K1=N2 TW05630

DO 810 K=1,M TW05640

K2=K1 TW05650

DO 800 1=1,

M

TW05660

A(K2)=0. TW05670

K2=K2+1 TW05680

K2=K1+K-1 TW05690

K1=K1+NPM TW05700

A(K2)=1.0 TW05710

NBEI=1 TW05720

NRHI=1 TW05730

I18=1+ND13 TW05740

NGAI=2 TW05750

NS 1 1=2 TW05760

NDEI=1 TW05770

NNUI=1 TW05780

LZ1=1 TW05790

LZ2=1 TW05800

K=l TW05810

NTHI=1 TW05820

NALI=1 TW05830

N0MI=1 TW05840

NJ=ND3+N+1 TW05850

DO 840 J=1,M TW05860

A(NJ)=0. TW05870

NJ=NJ+1 TW05880

KD1=(K-1)*NPM TW05890

I1=ND3+1 TW05900

325
T 9 Km ,1 1 £=I\U 1 +1 1 WU 5 9 1 0 1 9 9 A 10 0 L A A A=LZ A T 111 A C A O A 1 WU 5 9 2 0 nn Din t i ki uu sou 1=1 , n 1 WU 5 9 3 0 A / T 1 \ A / T o \ #PP / 1 ooft\ A (, 1 1 ) =A I, 1 A J l\U(,L££AJ T \un C O A A 1 WUb94U 1 9 0 A_l 994.1 L A 1 A=L A £ A + i T u/n coca 1 WUd9dO T 1 Till 1 1=1 1+1 T UJA C A L A 1 WU5960

BbU To

T 0 i 1 1 £=1 Z+l

T UJA. coin 1 WUS9 70 rnuu toIU /o7n 10/U,7UU), onn\ unMT NUWI1 T UJA coon 1 WUb9oO

o 7 nTA 1 — 1 1 A 1 = 1 T UJA

COOA 1 W0S99U

TA 0—KinK i 1 1 A£=liiUD + l T U/A

LAAA 1 WU 6 0 0 0 nnUU oan t i k o 7 U 1 = 1 , l\ T UJA L A 1 A 1 WU6010 T 9_ T A 1 1 4=1 Al T UJA znin 1 WU6020

jUI«=U . U

T UJALA 0 A 1 WU6030

19 until j c=nv j+i

T UJA£A /IA 1 WU6040

nnuu flan sou

Ji—= l1 mpu , ii r ivi

T uin i ncn 1 WUoUdO

OUIVt=oUIVl+A C 1 III CI |U , A / I9\*AM9\ ( J A ) A (_ 1 £. ) T UJA

LALA 1 WU6060

T 9 T 9 i 1 1 £=1 £+1

T UJA

Z

A 7 A 1 WU6070

sou 1 9— 19,1 J £ =J A + l T UJA

LAOA 1 WU60B0

A (, 1 A£

J =oUIVI

T UJA£AOA 1 WU6090 1 A 1 = 1 Al+Nr nfl t u/n ti nn 1 WU610U

ft 0)A 0 7 0 TA 0 I A 9 i 1 1 Aa= 1 AA+1

T UJAL 1 1 A 1 WU6 1 10

C

a Tn

qt

n

bU 1 U 7jU

T UJAL 1 9 A 1 WU 6 1 2 0 7 U U nK9 n UI\£ = U . t mn a i t a 1 WU6130 T 1 — f K 1 \ * UDM 1 1 1= ( f^ — 1 J NrlVI+1 t uin l i a n 1 nUo 140 t wn t_unt , i t u/n ti cn 1 WUO 1 3U nnUU qi7 1 nU tl = l,NrlVI i mdm t uin c i t. n l WUoloO

DK9 nK0iAMUnt\*AMl\ UI\£ =UI\£+A ( 1 NU.? ) A ( 1 1 ) t1 uin BlUoinn1 / 0 I i Tlil 1 1=1 1+1 T UJA L 1 O A 1 WU61U0 7 I U t unt t unt i i i nu j=i p» u j + 1 T U/n ii on 1 WU019U

nK_rncnPT ^ nK 9 \

T UJA

L

OAA

A / T A 1 Q

\ DK ( 1 1 0 ) =UI\

t u/n£ 9 1 n 1 WUoZ 10

T 1 OT 1 Q i 1 1 lo=l lo + l T UJALOOA 1 nUo/VO

KIM= / 1/ 1 \ * UDM . 1 1 ) IMr M+lt uin£ 0 1 A 1 WUoZ JU

UUnn 09n 7/U

t1=1,i udu NrMT u/n& 9 A

n

AA (Kit |M —A /KI

\ / nK

J =A (MJ / U l\ 1 nU 0 c j U

Q*)ft KiM=M+1 Kl.l

T U/nA 9 £A NUM1=1 t u/n a 9 7 n c a t a oca bU 1 U ojU T Uin L 9 Q A 1 WUoZoO

Qlrt

57 i 0 c

AtA / aa f\ i nun ^ unrT bU IU (940,1000), NUti

T U/n£ 9 Q

n 1 WU0Z7U

Ail

A 94 0 171 171 LZ.1=—La.1

T u/natnn

T

r 1171V AAA OCA OCA lr (La.1) 990 ,9b0 , 9b0

t uinA 1 1 A 1 WU 0 i 1 u OCA ? b 0

1/ T. 1/ 1 K1=K-1t uinAt 9 A 1 WUOJ a0

IKU 1

H=NUd+1

t u/n Attn

DO 960 1=1 , Kl

t1 u/n At An wuo j4U

A / T Dl ITU\n ( 1 DIITU\

A ( 1 KU 1 H ) =—

A ( I KU 1 n ) T u/n

at c.n 1 nu oiDU

AZA 960 TDIITU TDIITU.l IKU 1 H=l KU 1 n+1 TU/nAt Art IKU1 H=K+Nl)5 t uin a 1 7 n 1 WU 0 3 1 U A / T Dl ITU \ 1 A A ( 1 KU 1 n ) = 1 . 0 T u/n a t q n 1 WUOjoU J 2=ND4+1 t u/n a 1 0 n A AAA T 1 linii DO 980 1=1 , NPM t u/n a a n n 1 WU04UU C 1 1 fti A A t wn a 4 1 n 1 nuot 1 u n i t j i=i t uin a a 9 n 1 WU04 A u

J3=ND5+1

t u/naatn 1 WU04JU

IftiAAA II 1 1/ DO 970 J=l , K

t u/naaan 1 WU044U

CIIIJ CIIIJ.A / M\ * A / D -5\ SUM=5UM+A ( J 1 ) *A ( J3 )

TwnAARn

In I i . aio II

J 1=J 1+NrM

t1 u/n WU040U aa ah

ATA 970 to to ll J3=J3+1

t u/naa 7 n 1 WU04 / U

A 1 1 1 \C 1 1 ft!

A ( J2 )=5UM

t u/naaan 980 J2=J2+1 TW06490

326
60 TO 1090 TW06500

990 ISAL=I 18+M32 TW06510

IRUTH=ND5+K TW06520

A (ISAL)=FSQRT (A(IRUTH)

)

TW06530

GO TO 950 TW06540

1000 LZ2=-LZ2 TW06550

IF (LZ2 ) 1010,950,950 TW06560

1010 DO 1020 1=1,

M

TW06570

IND5=ND5+I TW06580

IND9=ND9+I TW06590

IND8=ND8+I TW06600

A(IND8)=A(IND5) TW06610

1020 A(IND9)=A(IND5)*A(IND5) TW06620

A(IND8+1)=A(IND5+1) TW06630

A(ND10+1)=A(IND8+1)-A(ND9+1) TW06640

IND10=ND10+1 TW06650

IND9=ND9+1 TW06660

DO 1030 J=1,M TW06670

IND10=IND10+1 TW06680

IND9=IND9+1 TW06690

1030 A(IND10)=A(IND10-1)-A(IND9) TW06700

FI=1.0 TW06710

IND10=ND10 TW06720

IND11=ND11 TW06730

DO 1080 1=1,

M

TW06740

IND10=IND10+1 TW06750

IND11=IND11+1 TW06760

IF (FN-FI) 1070,1070,1040 TW06770

1040 IF (A(INDIO)) 1050,1060,1060 TW06780

1050 A(IND11)=-FSQRT(ABS(A(IND10))/(FN-FI)) TW06790

GO TO 1080 TW06800

1060 A(IND11)=FSQRT(A(IND10) /(FN-FI)

)

TW06810

GO TO 1080 TW06820

1070 A(IND10)=-1 .0 TW06830

1080 FI=FI+1.0 TW06840

GO TO 950 TW06850

1090 GO TO (1100,1120,1250), NTHI TW06860

1100 K1=(K-1)*NPM+1 TW06870

IND4=ND4+1 TW06880

DO 1110 1=1, NPM TW06890

A(K1)=A(IND4) TW06900

K1=K1+1 TW06910

1110 IND4=IND4+1 TW06920

GO TO 1210 TW06930

1120 IND18=ND18+1 TW06940

IND4=ND4+1 TW06950

DO 1130 1=1,

N

TW06960

A(IND18)=A (IND4) TW06970

I ND18=I ND18+1 TW06980

1130 IND4=IND4+1 TW06990

NI=N+1 TW07000

DO 1140 1=1,

M

TW07010

KK1=ND18+NI TW07020

IND4=ND4+NI TW07030

A(KK1)=-A(IND4) TW07040

1140 NI=NI+1 TW07050

IND4=ND4 TW07060

IND19=ND19 TW07070

DO 1150 1=1,

N

TW07080

327
1 NU4=i INU4

+ 1 T ia/A 7 n

nn 1 WU7 090

niftin

TM ft 1 O • 1 1 INUl7=llNUl7+lT u/A 7 1 nn 1 WU7 100 1 1 C A 1150 A Mkini n\ A / T M H /l \ A ( INUIV )=A ( 1INU4 ) T U/A 7 1 i n 1 WU 7 1 1 0

ic /MADPC MY ADfC> l infl 1 1 ft ft 1 1 A

n 1 r ( IN A Kb o—MA A Kb 0 ) 1 Z U U , 1 1 oU , 1 1 DUT U/A. 7 11ft 1 WU / 1 Z 0 i i / a 1160 1 L L T T D P C / MY A D P C i 1 \ 1 Lb o= 1 1 Kb j (HIAAKbj + 1 ) —1 T IDA 7 11ft 1 WU / 1 3 0 1 L L A 1/1/1 LooA=Loo T IAIA 7 1 a n 1 WU 7 1 4 0 1 NU4=INU4 T \A/A 7 1 c n 1 WU 7 1 5 0

UU 1 1 / U 1 = 1 , IN

T IDA 71 in 1 WU / loU

Loo A=LooA+l

T U/A 7 17ft 1 WU / 1 / 0

llNU'r=llNU'r

+ i t1 mn 71 on WU / 1 0 u 11/0 DP/1 £. A A \ A / T Kin/1 \ Klf (Lot) A )=A \ 1INU4 ) T IAIA Tlftft 1 WU 7 1 7 0

lion 1 1H0 1 C

CTTDPC / MYADPC

\

L 0 D

= 1 1 Kb

o ( HIAAKb j ) T U1A 7 1 n

n 1 WU/ ZOU 1 tcA ICC 1 LDDA=L3D-1 T U/A 711ft 1 WU / Z 1 U

it

m , Kirt/i

IN 1=IN+INLI4

T U/A 7 11ft 1 WU / ZZU

nn i i on t_i

m UU 1 17U 1 = 1 , IWI

t u/n 7 0 1 ft 1 WU / Z

jU

Ul Ml

T . 1 IN 1=IN 1+1

T U/A 7 1 /I ft 1 WU 7 Z 4 0 1L55A=L55A+1 c C A 1 CCA 1 1 T U/A 7 1 c n 1 WU 7 Z 5 0 1 1 Oft 1 1VU DP/1 Kb (L55A CCAi)=—AA/MTV (INI ) T U/A 7 1 L ft 1 WU / Z O u 1 inn 1 Z U U MTU IN 1 H T_l i —j T U/A. 717ft 1 WU / z / u pnbU Tfl 1 1 on 1 U 1 1UU TUIA7 1 0 n 1 WU / Z 0 u 1 Z I u P n Tfi noon 117/11 mm t bU IU ( 1ZZU , 1Z 3U ) , INAL1 T IVA 7 1 Q ft 1 WU / Z 7 u i o o n 1ZZU NUH11=Z T UIA 7 1 ft n 1 WU / 3 0 0

MAI INAL T_9 1 =Z TUIH7 1 WU / itin1 u bU 1 U ODU t urn 7 1 9 n 1 WU / J z u 1Z jU re /i/ u \ 1 i<n iign lion lr (r\—HI) 1 Z 'tU , 1 Z 0 U , 1 i. 0 U Tu/n7 1 1 n i i /i ft 1Z40 N=l\ + 1 T u/n 71/in 1 WU / 34U

pn th 0 1 n

bu IU oZO

t u/n 7 1 cn 1 WU / 3 50 1 ICft IZDU pn Tn /I otn liifti MMiiT bU IU (lZoU,12/0), ININU 1 t u/n 7 1 /1 n 1 WU / 360

lZOl) MKII 1 T 1 ININU 1 =Z

T U/n 7 17ft 1 WU / 3 / 0

GO TO 1370

t u/n 7 1 Q ft 1 WU / 3 0 0 i o 7 ft L Z / U c c iw ; newnu

ccn cc*cc

T U/n 7 10ft 1 WU / J7U t1 u/n WU 7Ann / 4 U U

pn Tn 1170 bU 1 u 1 3 1 ut u/n 7/11n 1 WU / H 1 u i ion lZoO pn th /lion iicn\ kidct bU IU (127U,1Z5U) , INDtl t u/n 7 a 7 n 1 wu / 1 z u 1 inn 1ZV0 VM=l1 1 Tu/n7/iin 1 wu / 1 3 u nn 1 iin t 1 u UU 1310 1=1 , M t u/n 7 a a n 1 WU / 44U

TlT * Kl , 1 T 1 1 * M 1 1=1 IN+ ( 1 -1 ) HIt u/n 7/.cn 1 WU / 4DU

nn linn 1 i T UU 1300 J=l , 1 t u/n 7 /1

an l wu / tou

TO 1 T 1 1 Z=J+1 1 t1 u/n WU 7/ 47n 1 / u

1/1 1/1 .uni 1 r\Z=M+INUlZ

t u/n 7 a ftn 1 WU itOU

A (NZ )=A ( 1 Z ) t u/n 7 A

on 1300 V 1 1/ 1 . 1 K1=K1+1 t u/n 7 c n n 1 WU / D U U IOTA 1310 O AUT T U 1 1 C

LUN 1 INUt

t u/n 7 c i n 1 WU / 3 1 U

fcincT 1 nut 1=2

t u/n 7 c 0 n 1 wu / D z u

klDCT 1 NBEI=2

t u/n 7 c 1 n 1 WU / 5 3 U MTU T 1 N 1 Hl=z Tuin7 cAn 1 wu / D 1 u

1/ 1/ . 1 K=K+1

T u/n 7ecn 1 WU / DDU

PA TA /iicn 1 11A1 sjrAT bU IU (1250,1320), NbA 1 t u/n 7 c

&n 1 WU / 0 O u 1320 A A U T T M 1 1 C

LUN 1 INUt

t u/n 7 c 7 n 1 WU / D / U nn 1 0 / n Tfl 1 |l UU 1340 1 L=l , HI T u/n 7 can 1 WU / 30U 1 nn TVi/Tl n b\in £ \ . 1 LUL=1 XI ( 1 L , 0 , NUo ) +1 t u/n 7 c 0 n 1 WU / 37U

00 1340 J=1,IL Tiun7 1 wu / Ann 0 u u C 1 1 If A t u/n 7 a 1 n 1 wu/ 01U

t\f\ IOOA 1/1/ Tl tl DO 1330 KK=IL,H1

t u/n 7 a 9 n 1 wu / 0 z u 1 nni TVi/l/ky Tl uni 1 t LUb 1=1X1 (KK , 1 L , NU12 ) 1 tiu / O JU 1 API TV1 /l/A/ 1 l\lftl1\ LUbZ=lAl (KK,J , NU1Z )

Ttt(n7A4n 1 WU / OHU 1 ^ O A 1330 CM II CIIII.A / I API \ # A It A P 1 \ 5Uhv=5Uh1+A (LOCI ) A (LOO 2 ) t wn 7 a c n 1 WU /

OjU

A / 1 AP\C 1 1 11

A (L0C)=5UM

T U/n 7 AA ft 1 WU / O O U 1340 L0C=L0C+1 TW07670

328
J1=3+ND6 TW07680

J=NDl6+2 TW07690

A(ND16+1)=FSQRT(A(ND6+1)

)

TW07700

00 1350 1=2,

M

TW07710

IF (M.EQ.l) GO TO 1360 TW07720

A(J)=FSQRT(A(J1)

)

TW07730

J=J+1 TW07740

1350 J1=J1+I+1 TW07750

1360 NGAI=1 TW07760

GO TO 1250 TW07770

1370 GO TO (1380,1420) , NRHI TW07780

1380 IF (NRBAR) 1390,1460,1390 TW07790

1390 NRBAR=NRBAR-1 TW07800

NTHI=2 TW07810

NRHI=2 TW07820

L11=IIRGS(1)-1 TW07830

L11A=L11+1 TW07840

I1=ND2+1 TW07850

DO 1400 1=1,

N

TW07860

A(I1)=RC(L11A) TW07870

L11A=L11A+1 TW07880

1400 11=11+1 TW07890

I1=MD3+1 TW07900

DO 1410 1=1,

M

TW07910

A(I1)=0. TW07920

1410 11=11+1 TW07930

GO TO 830 TW07940

1420 GO TO (1380,1430) , NSII TW07950

1430 IND7=ND7+1 TW07960

IND6=ND6+1 TW07970

DO 1440 1=1, MD1 TW07980

A(IND7)=SSQ*A(IND6) TW07990

IND7=IND7+1 TW08000

1440 IND6=IND6+1 TW08010

IND16=ND16+1 TW08020

IND17=ND17+1 TW08030

DO 1450 1=1,

M

TW08040

A(IND17)=SS*A(IND16) TW08050

IND16=IND16+1 TW08060

1450 IND17=IND17+1 TW08070

GO TO 1380 TW08080

1460 L55A=L55+M TW08090

ISF=1 TW08100

L55B=L55A+M-1 TW08110

IF (L55B.LE.NR0W+L55-1) GO TO 1470 TW08120

IF (M.GE.NROW) GO TO 1580 TW08130

ISF=2 TW08140

L55B=L55+NR0W-1 TW08150

1470 IND17=ND17+1 TW08160

DO 1480 I=L55A,L55B TW08170

RC(I)=A(IND17) TW08180

1480 IND17=IND17+1 TW08190

GO TO (1490,1580) , ISF TW08200

1490 IMS=NR0W-2*M TW08210

IF (IMS.GT.6) IMS=6 TW08220

GOTO (1570,1560,1550,1540,1530,1500), IMS TW08230

1500 L11A=IIRGS(1) TW08240

L22A=L22 TW08250

YBAR=0.0 TW08260

329
IIIA 1 1 11

AA WSUM=0 . 0 T IIIAAA "TA TW08270

A.A 1 C 1 AT 1 &,l DO 1510 1=1, NT IIIAAAAA TW08280

IAIC 1 1 11 MIC II 11 D.O / 1 A

A

A\ WSUM=WSUM+RC (L22A)

T IAIA

AAAA TW08290

v/nAD V/DAnAO / 1 AAA\*DO/l 1 1 A\ YBAR=YBAR+RC (L22A)*RC(L11A)

T IAIA

A 1 AA TW08300

IAAA IAAA 1 L22A=L22A+1

T IAIA

A

Q 1 A

T WO 8 3 1 0

1510 II

TTA 1 ^ 1 A 1 L11A=L11A+1T \IIAAAAA TW08320

wn

aO un an / ulC 1 1 11 YBAR=YBAR / WbUM

T UlAAOOA TWO8330 1 1 1 A TTDOC/l\ L11A=I IR6S (1) T IIIA A O A A TW08340 1 A A A 1 A A L22A=L22 T IAIA A O c A TW08350

YYBAR=0 . T IAIA

A

o / A TW08360

AA 1 CAAT 1 Al DO 1520 1=1 , NT IAIAAOTA TW08370

wwn AD DO / 1 AAA\#/DO/l 11

A\ Y/DAD\#*A UUO AD

Y YBAR=RL (L22A)*(RL(L11A) -YdAR ) "2+YYBAR

T IAIAA

o

oA TW08380

IAAA IAAA 1 L22A=L22A+1T IIIAA 1 AA TW08390 1 C A A 1520 1 1 1 A 1 1 1 A 1 L11A=L11A+1 T IAIA Q A A A 1 W08400

DA 1 CCA* / Cll Cfcl\ /V/UDAD R2=l .-bbQ (bU-rM) /YYdART UlAOA 1 A 1 WU8410

TC /OA ITTA\ DAAA IF (R2 . LT . 0 . ) R2=0 . 0 T IAIAA /IAA TW08420

t r~ / r*l

A ATT l A\ OA i A IF (R2 . GT . 1 . 0 ) R2=l . 0 T IIIAAAOA TW08430

DO / 1 CCDZ\ DA RL (L55B+6 )=R2

T IAIAO

AAA 1 WU8440 1 C O A 1530 no / i ccD.c\ CCA RC (L55B+5 )=S5Q TI UJA OKA WU8450 1 C A A 1540 DO/I C C D A \ CC RL (L55b+4 )=bb T UJA O >l L A 1 WU8460 1 C C A 1550 D O / 1 C C D *1\ Cll r"ii RC (L55B+3 )=SU-FM T IAIA A A ~t A T W08470 1 C Z A 1560 DO/I CCD A\ Cll RC (L55B+2 )=FM T 111 A A A A A TW08480 T C T A 1570 DO/I CCD 1 \ Cll RC (L55B+1 )=SU T 111 A A A A A T W08490 1 C O A 1580 T Al r\ A At A A 1 1ND2=ND2+1 T U/A O C A A 1 W08500 T aj n o iim , i 1NU3=NU3+1 T U/A O C 1 A 1 WU8S1U I ND4=ND19+1 T \AlA A C A A TW08520 T D T O 1 IPIC=1 T UJA A c o A TW08530

TV/ TTDAC/l\ I Y= I IRGS (1)T IAIAA F"AA TW08540

wr nil

aA Y5UM=0 . 0 T UJA

OCCA TW08550 1 A A A 1 A A L22A=L22 T UJA O C L A TW08560 A A 1 / A A T 1 Al DO 1600 I=1,N T UlA ACTA TW08570 T D T D T O IP=IPIC T IAIA A C A A TW08580

SP=0 . 0 X 111

AACAA 1 W08590

AA TCAA TT 1 11 DO 1590 11=1, M

T UlAOLAA 1 WU8600

bP=br+A ( IP) *Z

T tl/n qjli

n 1 WUooiU

1590

TATA AlA 11 IP=IP+NPM 1 WU8620 A ( IND2 )=FSQRT (SP) *SS T UlA A / o A TW08630

TATA TATA 1 IPIC=IPIC+1T UJAOLAA 1 WU8640

T II f\

AT liftA "J IND2=IND2+1

T U/AO i CA 1 W08650

a/taii\*>v no / tu\a / t hin » \

A (IND3 )=RC (IY)-A ( IND4 ) T U/A 0 I L

A

t kina Til AO 1 I ND3=I ND3+1

T U/A fl/lfl 1 WU8670

t ii in i t im < i IND4=IND4+1

T U/AO / OA 1 W08680

wAiiiiwa 1 1 11 no / tu\ i;A

a ino / i aaa\ YSUM=YSUM+RC (IY)**2*RC(L22A)

T U/AO i AA 1 W08690

L22A=L22A+1

T UlAO 1 AA 1 WU87 00

1600 TV/ TV/

H I Y=I Y+l

T U/A 071/1 1 WU o 7 1 0 1 AO* T T A A A / IV/ » nr P ** \ LST=I IRGS (MXARGS+3 ) T U/A O T O A TW08720

IND9=ND9

T UlA

A

T

o

A TW08730

DO 1610 I=1,M

T U/A Q7JIA TW08740

t || r\ay |ina -n IND9=IND9+1

T U/A 07C

A i WU8750

DA / I CT\A / T AlAA\ RC (L5T)=A ( IND9 ) T U/A 0 7 XL

A 1 WU 0 / 6 0 1 Z 1 A 1610 1 C T 1 CT.l Lb 1 =Lb 1 +1 t wn o 7 7 n T C / Al n A III /ll 1 \ \ *a / C A 1 Z O A 1 Z A A IF (NR0W-(M+1)) 1650,1630,1620 T u/A sign 1 WU o / o 0

1620

AA / 1 AT i \A / II l>A\ RC (LST+1 )=A (ND9)

T U/AO 7 QA 1 WU8790

1630

AA / 1 CT\ /All r* ||

\ * A f a RC (LST)=(SU-FM)*SSQ

T U/AOOAA 1 WU8800 1 A T 1 A T A LST=LST+2 T U/A O O 1 A 1 WU8810 T C /ll A AC || n A III \ AA TA 1ZCA IF (M+2 . GE . NR0W) GO TO 1650 T U/A o o t n 1 WUooiU 1 ATA 1 AT ll ^ LSTA=LST+M-1 T UlA Q03A 1 WU8830 w |— , a ^ ll a av tin A ifli \ i /TA TTAAA / 11V/ A AAA O \ AIDA Ul 1 IF (2*M+2 .GT .NR0W) LSTA=I IRGS (MXARGS+3 )+NR0W-l T UlA AAiin TW08840

IND8=ND8 TW08850

330
DO 1640 I=LST,LSTA

IND8=IND8+1

1640 RC(I)=A(IND8)

1650 LST0R=IIRGS(MXARGS+2)

IPIC=1

IND2=ND2+1

DO 1660 1=1,

N

RC(LST0R)=A(IND2)

IND2=IND2+1

1660 LST0R=LST0R+1

IF (IARGS(5)-IARGS(4)-1) 1670,270,560

1670 RETURN

C

C

1680 FORMAT (//,31X,34H ANALYSIS OF VARIANCE FOR TWO-WAY ,I2,3H

1H TABLE, //,4X,7H SOURCE , 13X , 5H D . F . , 10X , 14HSUM OF SQUARES,

1

2EAN SQUARES, 10X,17HF RATIO F PROB./)

1690 FORMAT (4X,20H BETWEEN ROWS , 14 , 50A1 , 6X , 0PF11 . 3 , F9 . 3

)

1700 FORMAT (4X,20H BETWEEN COLS , 14 , 50A1 , 6X , 0PF11 . 3 , F9 . 3

)

1710 FORMAT (4X,20H RESIDUALS ,I4,50A1)

1720 FORMAT (4X,20H TOTAL ,I4,25A1//)

1730 FORMAT (9X,40HA WEIGHTED LEAST SQUARES ANALYSIS USING ,14,2

1ZER0 WEIGHTS AND ,I4,24H ZERO WEIGHTS IN COLUMN ,14/)

1740 FORMAT (39X ,31HTUKEY' S TEST FOR NON-ADDITIVITY / / ,4X , 20H NON

1VITY ,I4,50A1,6X,0PF11.3,F9.3)

1750 FORMAT (4X,20H BALANCE ,I4,50A1)

1760 FORMAT (IX)

1770 FORMAT ( / /5X , 11HC0EFFICIENT , 14X ,8HESTIMATE , 17X ,9HSTD . DEV./

1GRAND MEAN , 50A1 /

)

1780 FORMAT (5X,7HR0W ,I3,50A1)

1790 FORMAT (5X,7HC0LUMN ,I3,50A1)

1800 FORMAT (5X , 10HRESIDUAL ,50A1)

1810 FORMAT (//10X,I2,3H X ,I2,86H TABLE OF RESIDUALS, STANDARDI

1DIVIDING EACH RESIDUAL BY ITS STANDARD DEVIATION.)

1820 FORMAT (/,8H COLUMN , 15 (3X , 14 , IX)

)

1830 FORMAT (8H ROW ) 1840 FORMAT (2X , 14 , 2X , 15 (2X , F6 . 2 )

)

END

TW08860

TW08870

TW08880

TW08890

TW08900

TW08910

TW08920

TW08930

TW08940

TW08950

TW08960

TW08970

TW08980

TW08990

X ,I2,6TW09000

3X,12HMTW09010

TW09020

TW09030

TW09040

TW09050

TW09060

2H N0N-TW09070

TW09080

-ADDITITW09090

TW09100

TW09110

TW09120

/5X,10HTW09130

TW09140

TW09150

TW09160

TW09170

ZED BY TW09180

TW09190

TW09200

TW09210

TW09220

TW09230

331
SUBROUTINE VARCON (NAME) VAR 10

C VERSION 5.00 VARCON 5/15/70 VAR 20

COMMON /BLOCKA/ MODE , M.KARD (83 ) ,KARG , ARG , ARG2 , NEWCD (80 )

, KRDEND VAR 30

DIMENSION NAME(2) , N(14) VAR 40

DATA N(l) ,N(2) ,N(3) ,N(4) ,N(5) ,N(6) ,N(7) ,N(8) ,N(9) ,N (10) ,N (11) ,N (12VAR 50

1) ,N (13 ) ,N (14) / 10705, 2604, 16038 ,16767 ,17496, 18225, 18954 ,1377 ,15001, VAR 60

25*0/ VAR 70

C VAR 80

C LOOKUP NAME IN VARIABLE-NAME TABLE VAR 90

C VAR 100

C NAMES IN TABLE VAR 110

C VAR 120

C NRMAX,COLTOP,V,W,X,Y,Z VAR 130

C VAR 140

DO 10 1=1,7 VAR 150

IF (NAME (1 ) .EQ .N ( I ) .AND .NAME (2 ) . EQ .N ( 1+7 ) ) GO TO 20 VAR 160

10 CONTINUE VAR 170

1=0 VAR 180

20 ARG=I VAR 190

RETURN VAR 200

END VAR 210

SUBROUTINE VECTOR (A, J) VEC 10

C VERSION 5.00 VECTOR 5/15/70 VEC 20

COMMON /BLOCRC/ NRC ,RC ( 12600 ) VEC 30

COMMON /BLOCKD / IARGS (100) , KIND (100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL ,NVEC 40

1ARGS , VWXYZ (8 ) ,NERROR VEC 50

DIMENSION ARGS(IOO) VEC 60

EQUIVALENCE (ARGS ( 1 ), RC (12501 ) ) VEC 70

C VEC 80

C VECTORIZE A IN TO COLUMN STARTING AT J VEC 90

C VEC 100

IF (NRMAX.EQ.O) GO TO 20 VEC 110

K=J+NRMAX-1 VEC 120

DO 10 I=J,K VEC 130

10 RC(I)=A VEC 140

20 RETURN VEC 150

END VEC 160

332
SUBROUTINE XECUTE XEC 10

C VERSION 5.00 XECUTE 5/15/70 XEC 20

COMMON /BLOCKE/ NAME (4) , LI ,L2 , ISRFLG XEC 30

COMMON /BLOCKX/ INDEX (6,8) , LEVEL XEC 40

C ***** XEC 50

C Ll=l-10 FOR COMMANDS CONSISTING OF ONE OR TWO VERIABLES XEC 60

C EXAMPLES RESET XEC 70

C RESET X XEC 80

C PRINT A XEC 90

C Ll=ll-50 FOR COMMANDS CONSISTING OF ONE VARIABLE XEC 100

C EXAMPLES ADD XEC 110

C MPROP XEC 120

C Ll=51-63 FOR COMMANDS CONSISTING OF TWO VARIABLES XEC 130

C EXAMPLES CLOSE UP XEC 140

C M(X'X) XEC 150

90 GO TO (100,200,300,400,500,600,700,800,900,1000, XEC 160

11100,1200,1300,1400,1500,1600,1700,1800,1900,2000, XEC 170

22100,2200,2300,2400,2500,2600,2700,2800,2900,3000, XEC 180

33100,3200,3300,3400,3500,3600,3700,3800,3900,4000, XEC 190

44100,4200,4300,4400,4500,4600,4700,4800,4900,5000, XEC 200

55100,5200,5300,5400,5500,5600,5700,5800,5900,6000 XEC 210

66100,6200,6300) , LI XEC 220

C RESET XEC 230

100 CALL RESET XEC 240

GO TO 9999 XEC 250

C PRINT PRINT A-F XEC 260

200 CALL PRINTX XEC 270

GO TO 9999 XEC 280

C PUNCH XEC 290

300 CALL PUNCH XEC 300

GO TO 9999 XEC 310

C APRINT APRINT A-F XEC 320

400 CALL APRINT XEC 330

GO TO 9999 XEC 340

C READ READ A-F XEC 350

500 CALL READX XEC 360

GO TO 9999 XEC 370

C ABRIDGE XEC 380

600 CALL ABRIDG XEC 390

GO TO 9999 XEC 400

C MPRINT MPRINT A-F XEC 410

700 CALL APRINT XEC 420

C NPRINT NPRINT A-F XEC 430

GO TO 9999 XEC 440

800 CALL PRINTX XEC 450

GO TO 9999 XEC 460

C Ll=9 AVAILABLE XEC 470

900 RETURN XEC 480

C Ll=10 AVAILABLE XEC 490

1000 RETURN XEC 500

C ADD, SUB, MULT,DIV, RAISE, SUBTRACT, DIVIDE, MULTIPLY XEC 510

1100 CALL ARITH XEC 520

GO TO 9999 XEC 530

C SIN,ASIN,SIND,ASIND,SINH,ASINH XEC 540

C COS, ACOS,COSD,ACOSD, COSH, ACOSH XEC 550

C TAN , ATAN ,TAND , ATAND ,TANH ,ATANH ,NEGEXP XEC 560

C COT,ACOT,COTD,ACOTD,COTH,ACOTH XEC 570

C ABS , ABSOLUTE , EXP .EXPONENT , LOG ,LOGE , LOGTEN , ANTILOG , SQRT , RAISE XEC 580

C INTEGER , FRACTION, SQUARE XEC 590

333

409-118 OL - 71 - 22
1200 CALL FUNCT XEC 600

GO TO 9999 XEC 610

C Ll=13 XEC 620

1300 GO TO (1301,1302,1303,1304,1305,1306,1307,1308,1309,1310, XEC 630

11311,1312,1313,1314) ,L2 XEC 640

C GENERATE XEC 650

1301 CALL GENER XEC 660

GO TO 9999 XEC 670

C SET XEC 680

1302 CALL SET XEC 690

GO TO 9999 XEC 700

C FIXED XEC 710

1303 CALL FIXFLO XEC 720

GO TO 9999 XEC 730

C FLOATING XEC 740

1304 GO TO 1303 XEC 750

C PLOT XEC 760

1305 CALL PLOT XEC 770

GO TO 9999 XEC 780

C PAGE PLOT XEC 790

1306 CALL PLOT XEC 800

GO TO 9999 XEC 810

C Ll=13 L2=7 AVAILABLE XEC 820

1307 RETURN XEC 830

C NEW PAGE XEC 840

1308 CALL PAGE(4) XEC 850

GO TO 9999 XEC 860

C SPACE XEC 870

1309 CALL SPACE XEC 880

GO TO 9999 XEC 890

C CGS XEC 900

1310 CALL PHYCON(O) XEC 910

GO TO 9999 XEC 920

C SI XEC 930

1311 CALL PHYCON(-l) XEC 940

GO TO 9999 XEC 950

C FLEXIBLE XEC 960

1312 GO TO 1303 XEC 970

C PRINT NOTE XEC 980

1313 CALL N0TEPR(3) XEC 990

GO TO 9999 XEC1000

C ROUND XEC1010

1314 CALL FNEIC XEC1020

GO TO 9999 XEC1030

C Ll=14 XEC1040

1400 GO TO (1401, 1402 ,1403, 1404, 1405, 1406 ,1407, 1408, 1409, 1410 ,1411, 1412, XEC1050

1 1413,1414,1415) ,L2 XEC1060

C BEGIN XEC1070

1401 CALL BEGIN XEC1080

GO TO 9999 XEC1090

C SCAN XEC1100

1402 GO TO 1401 XEC1110

C REPEAT EXECUTE PERFORM XEC1120

1403 J=l XEC1130

CALL REPINC(J) XEC1140

IF(J)9999,9999,90 XEC1150

C Ll=14 L2= 4 AVAILABLE XEC1160

1404 RETURN XEC1170

C Ll=14 L2=5 AVAILABLE XEC1180

334
1405 RETURN XEC1190

C INCREMENT XEC1200

1406 J=3 XEC1210

CALL REPINC(J) XEC1220

GO TO 9999 XEC1230

C Ll=14 L2=7 AVAILABLE XEC1240

1407 RETURN XEC1250

C RESTORE XEC1260

1408 J=3 XEC1270

CALL REPINC(J) XEC1280

GO TO 9999 XEC1290

C IFLT XEC1300

1409 CALL IFS XEC1310

GO TO 9999 XEC1320

C IFEQ XEC1330

1410 GO TO 1409 XEC1340

C IFGT XEC1350

1411 GO TO 1409 XEC1360

C IFGE XEC1370

1412 GO TO 1409 XEC1380

C IFNE XEC1390

1413 GO TO 1409 XEC1400

C IFLE XEC1410

1414 GO TO 1409 XEC1420

c COMPARE XEC1430

1415 GO TO 1409 XEC1440

C MDEFINE MZERO MERASE MIDENT MDIAGONAL XEC1450

C ADEFINE AZERO AERASE XEC1460

1500 CALL MOP XEC1470

GO TO 9999 XEC1480

C MINVERT INVERT SOLVE XEC1490

1600 CALL INVERT XEC1500

GO TO 9999 XEC1510

C Ll=17 NO L2 VALUES ARE NEEDED IN SUBROUTINES XEC1520

1700 GO TO (1701,1702,1703,1704,1705] ,L2 XEC1530

C MMULT MMULTIPLY XEC1540

1701 CALL MMULT XEC1550

GO TO 9999 XEC1560

C MRAISE XEC1570

1702 CALL MRAISE XEC1580

GO TO 9999 XEC1590

C MKRONECKER XEC1600

1703 CALL MKRON XEC1610

GO TO 9999 XEC1620

C MTRAIN XEC1630

1704 CALL MTRIAN XEC1640

GO TO 9999 XEC1650

C ME I GEN XEC1660

1705 CALL MEIGEN XEC1670

GO TO 9999 XEC1680

1800 IF (L2.GT.8) GO TO 1809 XEC1690

C MADD MSUB MTRANS SCALAR AMULT MSUBTRACT XEC1700

C AADD ASUB ATRANS ARAISE AD I V I DE ASUBTRACT A MULTIPLY XEC1710

CALL MATRIX XEC1720

GO TO 9999 XEC1730

C ACOALES AAVERA XEC1740

1809 CALL COALES XEC1750

GO TO 9999 XEC1760

C NORMLAGUERE LAGUERE HERMITE LEGENDRE TCHEBYSHEV UCHEBYSHEV XEC1770

335
i17UU onn PAl 1 Al 1 < 1 1

R

LHLL HLLjUD vepi 7 on ALL 1 / 0 U PPOU TP1 U QQQQ 7 7 7 7 Y c n 7 Qfl A CL> 1 / 7

U

pL PARSIIM PARPRODUCT RMS AVFRARF SUM YCp

i

ann ALL10UU

9nnn 4VUU PAl l MSPROW YFP 1 ft 1

0

ALL101U

(If) 13U TO1 U QQQQ 7 7 7 7 YFP1 R20

rl 1 1 —9 1 L. X — L X yfp ALL i1 ft0 JinU

9 1 nn ftn to f?ini 9109 9 1 o^ 9104 9 1 05 9 1 o a 9 1 07 9 i oft 9 i oq 9 i i o 9111 YFP AlL 1lOHU RAO. 19119 X£XX£,£.XXJ,£XX 9113 9114at 9115 911A 9117 911fl 911Q^ 19 f £XXj / £XXO,£XXI ( lHO ( Lll 7 | , L» £ yfpi R^n

p ROWSUM ROW SUM YFPI ftAfl 21 (11 PALL PR0R0W YFPl R70

UU TO1 U QQQQ 7 7 7 7 YFPl ACL ftftfl 1 0 OU

Pw YFPl ALL ftQfl 1 0 7 U

9t. iX 09w t. HO TO 9101 YFP ALL11 Qdfl 7UU

p OFFTNF ULl 1 IX £_ YFP 1 Q 1 fl

£. X \J J PALL vnLL DEFINE 1/L.r 1 IX l_ XFP1 Q90

f,n OU TO1 U QQQQ 7 7 7 7 ALL17JU YFPl Q in

1L. 1—91 X —t- X 1l_ 9—4 £ —t HVnlLnDLL AVATI ARI F YFPl ALL 1 QAn 7HU

9 1 04 RFTIIRN fx L. 1 U r\ IX yfpi ALL 1 Q>;n 7 D U r MAX MAXIMUM YFPl ALL l/OU QAn

9 1 05 PALL vnLL EXTREM L.A 1 l\ L. Ifl YFPl A L v X Q70 7 1 yJ UU TH1 U QQQQ 7 7 7 7 YFPl ALL Qftrt 1 7 0 U r MTN III 111 MINIMUM If! 1 IX A III U I'l YFP ALL 11 QQP 7 7 U nn Tn 9io , UU > 0 U tlU

J

YFP?nnn ALL L U u v r 1L. 1-91 X —C X 1L. 9-7 J- — / HVnl AVATILnDLL ARI F VFP?ni

n

ALL lUIU

2107 RETURN l\ L- 1 \J l\ IX XFP9090 ALvbULV

pL SORT yFP90^0

2 1 nft PAl 1 SORDFR XFT9040

UV 1 U 7 7 7 7 yFP90^0

pL PRDFR XFP90A0

2£ Xi pqw 7 PPLIU TO1 u 2in« XFP9070

Pl FRASF YFP90ftO

9 i i n PAl 1 FRASF VFP90Q0 ALU tU 7U

PPQU TPIV/ QQQQ 7 7 7 7 XFP9 1 00

pL EXCHANGE XFP91 1

0

ALw CllV

2111 bill CALL EXfHNG XEC2120 ALU L X £• V ppUU TO1 U QQQQ 7 7 7 7 YFP2 ALL41JU 1 in

pL FI1P r L 1 r YFP2 A LL C 11HUAn

C9119 1 1 c PAl OHLL1 Flr LlrIP yfp ALL 2£ iLJ\J sn PPLlU TP1 U QQQQ 7 7 7 7 YFP21 ALL L. iouArt pL PHANPF LnHliLiL XEP217n ALU iL 1 I v

9£ 11111 3 PAl LHLL1 PHANPF LnHllLlL XFP2 ALL tlOU i sn M TP QQQQ LlU 1 U 7 7 7 7 XFP2 ALubl1 Q07 U

Li Un

T

i CDLi\Hi\un ARPHYt XFP9900

9 1 1 A L 1 11 LlU 1 U C 1UO XFP991

0

ALvl C X u p LI1 1 STJ 1 XEC2220

L UfRTTF nrv 1IC SIIP.RPIITTNF jUDRUU I1MC rFORUR 1LI1STJ 1 XFP2230

PAl 1 1 TQT in \

Li ALL LI J 1 ( V ) YFP224n

rnLlU Tfl 1 U QQQQ 777 7 XFP22'»n ALL £ £ J

w

Li MP 1 T CT llU LI jl XFf A L. V 22b d AOW V PL> WRITE SIIRRPIIT I NF XEC2270 AL L f V

9 1 1 A PAl LHLL1 |LIICT/1 J 1

1 ( 1 ) XEC2280

rnUU Tn1 U QQQQ 7777 XEC2290 A La W fa Ci 7 w PL> Mill NULL1 XEC2300

9117 £.111 rn Tn qoqo UU IU 7777 ALV bJ'lU

Li tKKUK XFP9^9fl ALuC J C\J

9£110 1 1 Q PAl LtHLL1 PMFT rWtL XEC2330

rnLlU Tn1 QQQQ U 7777 YFP2140

Li rroc XEC2350

2119 GO TO 2118 XEC2360

336
c POLYFIT FIT MORTHO XEC2370

c SPOLYFIT SFIT XEC2380

2200 CALL ORTHO XEC2390

GO TO 9999 XEC2400

C Ll=23 XEC2410

2300 GO TO (2301,2302,2303,2304,2305,2306,2307,2308,2309,2310,2311, XEC2420

12312) ,L2 XEC2430

C CLOSE UP XEC2440

2301 CALL MISC2 XEC2450

GO TO 9999 XEC2460

C COUNT XEC2470

2302 GO TO 2301 XEC2480

C SHORTEN XEC2490

2303 GO TO 2301 XEC2500

C EXPAND XEC2510

2304 GO TO 2301 XEC2520

C DUPLICATE XEC2530

2305 GO TO 2301 XEC2540

C MOVE AMOVE MMOVE XEC2550

2306 CALL MOVE XEC2560

GO TO 9999 XEC2570

C Ll=23 L2=7 AVAILABLE XEC2580

2307 RETURN XEC2590

C Ll=23 L2=8 AVAILABLE XEC2600

2308 RETURN XEC2610

C Ll=23 L2=9 AVAILABLE XEC2620

2309 RETURN XEC2630

C PROMOTE XEC2640

2310 CALL PDMOTE XEC2650

GO TO 9999 XEC2660

C DEMOTE XEC2670

2311 GO TO 2310 XEC2680

C DIMENSION DIM XEC2690

2312 CALL DIMENS XEC2700

GO TO 9999 XEC2710

C Ll=24 XEC2720

2400 GO TO (2401,2402,2403,2404,2405,2406,2407,2408,2409,2410, XEC2730

1 2411,2412,2413,2414,2415) ,L2 XEC2740

C STATIS XEC2750

2401 CALL STATIS XEC2760

GO TO 9999 XEC2770

C SSTATIS XEC2780

2402 GO TO 2401 XEC2790

C RANKS XEC2800

2403 CALL RANKS XEC2810

GO TO 9999 XEC2820

C GAUSS QUADRATURE XEC2830

2404 CALL GQUAD XEC2840

GO TO 9999 XEC2850

C F PROBABILITY XEC2860

2405 CALL FPROB XEC2870

GO TO 9999 XEC2880

C TWO WAY XEC2890

2406 CALL TW0WAY(L2) XEC2900

GO TO 9999 XEC2910

C STWOWAY XEC2920

2407 CALL TW0WAY(L2) XEC2930

GO TO 9999 XEC2940

C HISTOG XEC2950

337
2408 ft

a I 1 UTCTMJ LALL HlbibM

V C"A 1 A / A XEC2960

AA Trt AAAA GU IU 9999VCAAATA XEC2970

C MUT

C TP Nrl 1 b 1 U

VCA I AOA XtL2980

A ilA ft 2409 PAI 1 LJTCTPM LALL n 1 b 1 bM

VCAAAAA XtL2990

rp tp ooqq bU 1 U 777 7 VCP 5 AAA XLL3000

C I- KtU.Ut

VCAOA 1 A XtL3010

AA 1 A 2410 PAI | rnniCT LALL rKUlblVCA "5AAA XEC3020

PP TP QQQQ bU IU 9999

VCAOAOA XtL3030

pL PPDDCI LUKKtL

VCP 0 A VIA XtL3040

2411

PA 1 1 PPDDC 1

LALL LUKKtL

VCP 0 ACA XLL3050

PA TA

a nnn bU IU 9999

VCA 1 ALA XEC3060

pLC PPD DC bLUKKt

VCAOATA XEC3070

2412

PA 1 1 PPDDC 1

LALL LUKKtL

VCAOAOA PP TP OOQQ bU IU 9999 V C A 1 A A A XLL3090

pL UIMt WAY VCP11

AA AtL3 1UU

o vl 1 1 2413 PAI 1 P hiC 14/AV LALL UNtWAYVCAO 1 1 A XEC3110

PP TP QQQQ bU IU 9999

VCAO 1 AA XEL3120

pL

c PAIr UIAV

b UIMt WAY VCP

O 1 0 A XtL3130

2414 PP TP

O VI 1 7 bU IU 2413 VCP 1 1 VIA XtL3 140

pLIlklTCPDM DAKIDPM UIMlrUKM KAIMUUM

V CP 5 1 CA XtL3 150

2415 PAI 1 c

MVP LALL HMK.LV CP 1 1 / A XtL3160

PP TP nOQfl bU IU 9999 VCP 0 1 7 A XtL3170

pLCCI CPT CCADPU PCMCPD MATPLi otLtLI btAKLH LtNbUK MAILH

VCP 1 1 OA XtL3 180

OCAA 250UT

r / 1 o CP vi

\ PP TP ocavi lr (L2.HJ.4) bU IU 2504 XtL3 190 p A 1 1 C CI CPT LALL btLtL 1

XtL32UU

PP TP QQQQ bU IU 9999 XEL3210

ca vi 2504 PAI 1 TMTCDD LALL INItKPVCP 0 1 OA XtL3220

PP TP AAAA bU IU 9999V CP 7 *5OA XtL3230

pL

lil/CPATAP IIWCPIJAT IlklATWCP UU

CP ViTAPP KlA 1 MVLLUlAb MVtLMAI MMAIvtL MVtLU 1 AbUIMALVCPO 1 VIA XtL3240

O / Aft 2600 PAI 1 CVDPPM LALL tXPLUN

VCP 0 1 CA XtL3250

PP TP QQQQ bU IU 9999 XtL3260

pL MDDPDCDTTCC ADDPDCDTTCC CAJDDPD CADDPD MrKUPtKlltb APKUPtKlltb bMPKUP bAPKUP

VCP 3 1 7 A XtL3270 1 "7 A A 2700 PAI 1 I1DDPD LALL MPKUP XEL3280

PP TP AQAQ bU IU 9999 XEL3290

p TTCDATC TCCTIID TCPI ATC lltKAIt lbtlUr lbULAIt

Y CP 3 a

AA AtL33UU 1 O A A 2800 PAI 1 TTCDAT LALL 1 1 tKA 1

XtL33 10

PP TP AAAA bU IU 9999VCP 7 1 OA XtL3320

p CCDADATC TAICCDT AJAVUTM CVTDCIIA btPAKAIt lIMbtKI MAXM1N tX 1 KtMA XtL333U 1 A A A 2900 P A 1 1 P KJC E* n A CALL CMbtPA XtL3340

PP TP QQQQ bU IU 9999V CP 1 1 CA

At

L 3 3 5 U

AC DCCCCI CIIDDPIITTAICC BtbbtL bUbKUUIlNtb XtL336U

3000 PAI 1 nf CCD CALL BESSEL

V CP 1 1 7 A XtL3370

AA TA AAAA GO TO 9999 XtL338U

c

TUCO 11

A

THERMO

VCP 1 1 QA XtL3390 1 1 A A 3100 P 1 1 i Turn up CALL IntKMU V CP 3 Vl A A XtL34UU

AA TA AAAA GU IU 9999 VCP 1 vl 1 A XtL341U

Ac COMPLEX ARIIHMtllL

VCP 1 A 1 A XtL3420

3200

aa i i AA ain i v CALL C0MPLX

VCP ^ VI 1 A XtL3430

AATA ft ft ft ft GO TO 9999

VCAO il vAA XtL3440

aC Ll=33

V CP 1 VlCA XtL3450

ac

11OA

L 1=34

vAtL34oU CP 1 vl A A

c Ll=35 VCP 1 VI 7 A XtL3470

ftc Ll=36

VCP 3 VI OA XtL3480

c Ll=37

VCP 1 AQA XtL3490

c Ll=38

VCP 0 CAA XEL3500

ftc Ll=39 YCpj CIA AtL351U

ftc Ll=40

VCP 1 COA XtL3520

c Ll=41 YCP 7 C 7 n XtL353U c Ll=42 XEC3540

338
c Ll=43 XEC3550

c Ll=44 XEC3560

3300 RETURN XEC3570

3400 RETURN XEC3580

3500 RETURN XEC3590

3600 RETURN XEC3600

3700 RETURN XEC3610

3800 RETURN XEC3620

3900 RETURN XEC3630

4000 RETURN XEC3640

4100 RETURN XEC3650

4200 RETURN XEC3660

4300 RETURN XEC3670

4400 RETURN XEC3680

C***** THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS XEC3690

C THE STATEMENTS 4500 -5000 WERE RETURN STATEMENTS XEC3700

C READ TAPE XEC3710

4500 CALL TAP0P2 XEC3720

GO TO 9999 XEC3730

C CREAD TAPE XEC3740

4600 GO TO 4500 XEC3750

C WRITE TAPE XEC3760

4700 GO TO 4500 XEC3770

C SET TAPE XEC3780

4800 GO TO 4500 XEC3790

C CSET TAPE XEC3800

4900 GO TO 4500 XEC3810

C ENDFILE TAPE .REWIND TAPE SKIP TAPE, BACKSPACE TAPE XEC3820

5000 GO TO 4500 XEC3830

c M(XX') M(X'X) M(XAX') M(X'AX) XEC3850

5100 CALL MXTX XEC3860

GO TO 9999 XEC3870

C M(AD) ,M(DA) XEC3880

5200 CALL MDAMAD XEC3890

GO TO 9999 XEC3900

C M(V'A) M(AV) XEC3910

5300 CALL ARYVEC XEC3920

GO TO 9999 XEC3930

C Ll=54 XEC3940

5400 GO TO (5401,5402,5403,5404,5405,5406,5407) ( L2 XEC3950

C L2=l XEC3960

5401 RETURN XEC3970

C DUMMY A XEC3990

5402 CALL DUMMY

A

XEC4000

GO TO 9999 XEC4010

C DUMMY B XEC4020

5403 CALL DUMMYB XEC4030

GO TO 9999 XEC4040

C DUMMY C XEC4050

5404 CALL DUMMYC XEC4060

GO TO 9999 XEC4070

C DUMMY D XEC4080

5405 CALL DUMMYD XEC4090

GO TO 9999 XEC4100

C DUMMY E XEC4110

5406 CALL DUMMYE XEC4120

GO TO 9999 XEC4130

C DUMMY F XEC4140

339
C A f\ 7 PM 1 DIIMMVF Atl>Hl3U

pn. UU Tfi 1 U oooo 7 7 7 7 YPPA 1 An AtU'tloU

pL> L 1 =3 3 yppa i 7 n A t U 1 1 / U p L 1 =30 vcPAi AtUllOUon

pL> L 1 =3 / yppa ion

p\j L 1 =3 0 At04£UU

pL> L 1 =37 AtU**£ 1U

pL>

1 I _/L n L 1 =0 U Y CP A 0 o n pLi

1 1 —A 1 L 1 =0 1 yppao in

PLi

1 1 —A 0 L 1 =0 L YPPA9 An

pLi1 1 _A 1 L 1 =0 J AtU4£3U

33UU DFTIIDM Kt 1 UKIM yppa AtUHoU "> An

30UU PPTIIRM KL 1 UKN YPPA97n

3 / UU PPTIIRM YPPA^Qn

conn 30UU PPTIIRM t\C 1 URN YPPAOQfl

37UU conn PPTIIRM KL 1 UKN YPPAinn

OUUU DPTIIRM l\L 1 UKIM Atllj 1U

ik i n n O I u 0 PPTIIRM KC. 1 urn YPPAI^n AtU4 J £.\J a o n n Q CUV PPTIIRM KC. 1 UKN YPPAlin

k % n n 0 J u u PPTIIRM

oi a a o ¥ t y i r ai i appp / n \ yfp

a

ALL.** i cn J3U

1Ttr

(1 PUPI IP f\\ DPTIIRM ( Lt VLL . Lt . U ) Kt 1 UKIM YPP A 1 An AtU't JOU

J=t YFPA17ft

PAN RPP T MP / 1 \ yppaijm

if1 r n run if rv\ pptiipn ( LtVCL . LL . U ) nil 1 Unl« YPPAIQn

PP. Tfl on bll IU 90 v P P ji ji n n END XEC4410

340
SUBROUTINE XFORMT XFO 10

C VERSION 5.00 XFORMT 5/15/70 XFO 20

COMMON /BLOCKA/ MODE , M, KARD (83

)

( KARG , ARG , ARG2 , NEWCD (80 ) ,KRDEND XFO 30

C XFO 40

C LOOK FOR LETTER A-F FOLLOWED BY NON-ALPHANUMERIC CHARACTER XFO 50

C A $ = 46 STOPS THE SCAN XFO 60

10 M=M+1 XFO 70

IF (KARD(M) .LT.IO.OR.KARD(M) .GT.15) IF (KARD (M)-46) 10,20,10 XFO 75

IF (KARD (M+l ) .LE .35) GO TO 20 XFO 80

C CALL PREPAK TO STORE FORMAT XFO 90

C IF IND=0 FORMAT IS O.K. AND STORED XFO 100

C IF IND=1 NUMBER OF ( DOES NOT EQUAL THE NUMBER OF ) XFO 110

C XFO 120

CALL PREPAK (1 , IND , IR , IR , IR) XFO 130

IF (IND.EQ.O) RETURN XFO 140

20 CALL ERROR (205) XFO 150

RETURN XFO 160

END XFO 170

SUBROUTINE XHEAD XHE 10

C VERSION 5.00 XHEAD 5/15/70 XHE 20

COMMON /BLOCKA/ MODE, M,KARD(83) ,KARG, ARG, ARG2 , NEWCD (80) .KRDEND XHE 30

COMMON /BLOCKD / I ARGS ( 100 )

, KIND ( 100 ), ARGTAB ( 100 ), NRMAX , NROW, NCOL , NXHE 40

1ARGS ,VWXYZ (8 ) ,NERROR XHE 50

COMMON /ABCDEF/ L(48) XHE 60

GO TO 20 XHE 70

10 M=M+1 XHE 80

20 IF (KARD (M) .GE . 10 ) IF (KARD(M)-46) 10,30,10 XHE 85

CALL AARGS XHE 90

I=ARG XHE 100

IF (KARG.EQ.O.AND.I .GT.O.AND.I .LE.NCOL) GO TO 60 XHE 110

30 CALL ERROR (204) XHE 120

RETURN XHE 130

50 M=M+1 XHE 140

60 IF (KARD (M) .NE .36) IF (KARD(M)-46) 50,30,50 XHE 145

C XHE 150

C SLASH FOUND. PICK UP NEXT 12 CHARACTERS IN FORMAT Al AND PACK XHE 160

C XHE 170

80 CALL PREPAK (2 , IND , I , IR , IR) XHE 230

RETURN XHE 240

END XHE 250

341
CIIQDAIITTMF Yd MM T T / 1 P \ bUDKUUIllMC. aUMIMII (Lu ) AUM i n I u p

c VC.KMUIM D.UU AUMIMII D/1D//U YAM AUM 9 n p Ann A cu/TTPU TA nFTPBMI MP 1MUFTUFR DPTMTY OB PDRTMT UU T 1 1 RP IKPn AUU A DWllUn IU UL 1 CKM1 IMC Hint 1 ntR r l\ 1 N 1 A UK KrKllMI WILL DC UjlU AUM YDM i. 1 pU TWTTTAI T7P CU/TTPU TA 7FPA PI PYTRI P POD MAT IBDB!NT\ UU T 1 1 RP IKP n 1IM1I1AL1Z.L jnl 1 In IU £ C K U rLCAlDLt r U K KIM 1 (KrKlHI ) WILL DC. UjlU AUM YAM C i. p

U CUJTTPU U/T 1 1 DP CCT TO. 1 IP CTYCn AR PI AATTMP T C C MP Al IMT C P F n

b W 1 1 Un WILL DC. DC. 1 IU 1 lr r 1 AC U UK r LUA 1 1 1Mb 1 j C.IMUUUIMICKLU YAM AUM L J p

U

ir DDTMT PAMMAKin UAd nFP ARPC PI PYTRI P FAPMAT UU T 1 1 RP IKPn lr rKllMI UU MMAIMU HAD U t U . AKuj FLCA1DLC r UK MA 1 WILL DC UjlU YAM AUM OA

p CUITTPU DWl 1 Un UIT1 WILL1 MAT IMU 1 RPDC PUAMPFH UnAIMULU YAM AUM O C L 0 pU

CIrLtAlBLt PYTRI C PAMMAMR UU T 1 1 PUAMPF CU/TTPU TA n UU MMAIMU WILL UnAIMUL jnl 1 Un IU U YAM AUM i. 0

p TP DDTMT U/TTU Al 1 TMTFPFP ARPQ AWn CU/TTPU—n IKP CI PYTRI P PflPMAT lr r K I IM 1 Wlln ALL 1 IM 1 LUCK MKU D AIMU D W 1 1 U n=U UjL r LlAIDLl r UK MM 1 YAM AUM O 7 p TPlr DDTMT rKIIMI U/TTU Wlln ALL Al 1 TMTFPFP 1IMICUCK HnQj ARPQ MIM AMnU CUJTTPU— jnl 1 U n=l1 IICF CPPPTFTPH FARMAT , U DC DrCUlrlCU r UK MM 1 YOM AUM Oft pU /CTYFn PiD CI A AT T MP ^ 1 ALU UK r LUA 1 1 IMU J YAM AUM O Q P AMMAM /RIAP^A/ kiPinp U V ARO. (Qi\ HARP ARP. A RP 9 MP U/P D f 8(1 1 IcPnPMn UUMMUIM / DLUUIV.A / MUUC , M , NAKU \ 0 J } , l\ AKU , AKu , AKU c , IM C WU V ( 0 U ; ,r\KLlC.IML> YAM AUM 3 U PAMMAM UUMMUIM /DLUUrVD/ /Rl APtfR / MQTMT IMDIMI ,IMDIMIA,IMDIMIn,IMUUM,LUUM,lUVrL,UUI»ll£UUUJ MQTMTY MCTMTU MPAM 1 POM TAV/FI PAM/9nnni YPiM Aunn Aft PPiMMPiM UUMMUIM /Rl APKP / KTA TMIINTT TCPRAT kRfinilT KRnKMT 1 1 T CT / DLUUInU / l\ 1 U , 1 IMUIM 1 1 , 1 jUKM 1 ( KDUUU 1 , l\ K U MM 1 , LL 1 J 1 AUlfl YAM SO. COMMON /BLOCRC/ NRC ,RC (12600) XOM ADD U COMMON /BLOCKD / IARGS(IOO) , KIND (100) ,ARGTAB (100) , NRMAX ,NR0W,NC0L ,NX0M / u 1ARGS X *» 1 * \& rj * VWXYZ(8) V ww f\ 1 £o y W J j NERR0R 1 » IW lilt W X XOM o u DIMENSION ARGS(100) XOM 7 U EQUIVALENCE ( ARGS ( 1 ), RC ( 12501 )

)

XOM inn 1 u u COMMON /HEADER/ N0CARD (80) , ITLE (60 , 6 )

, LNCNT , IPRINT ,NPAGE , I PUNCH XOM iin 1 X \l COMMON /PKSWT / IHCNT IHTP XOM XIISID

COMMON /FMAT / 1 FMTX (6 ) I0SWT IFMTS (6 ) 1 HEAD (96) XOM i ? n COMMON /BL0CKX / INDEX (6 ,8 )

, LEVEL XOM ±1 7CJ5 COMMON /SPRV / NERC0N ,NERR , ISWERR XOM 1 3n

COMMON /ABCDEF /L (48) XOM 1 4n

COMMON /PC0NST / JPC P(40) N(40) XOM i sn

pU XOM 1 / u rU IF LG IS NEG FIRST CARD WAS NOT '0MNITAB' CARD IF LG= 0 FIRST XOM i1 ano u U CARD = /0MNITAB/ ELSE SUBSEQUENT '0MNITAB' CARD FOUND XOM ion

U XOM ?nn

XOM o l n p

U XOM ??n C CM

U Cfl THROUGH ' CTflP ' ^FOIIFNTF AND RETURN XOM ? ^ n

i A c k\ I y<;tpiP XOM £ t u

L U nn t— i ro XOM ? SO

30 IMUwMIMf MOPARn n \—NFuirn i t \

V 1 ) —IXC.nUL' \ I J XOM 9 An

pC XOM f\ \J ifl 97n

p

c TWTTTAI 1H1I1AL1Z.L T7C QVQTFU jijILm XOM A \J 1*1 9 an

p

u XOM A \J 111 uu du 1 = 1 , o

u

XOM A \J l"» J> \J V n A c a 1 l £ >^lJ. nu

C A

D U tT| r (T l\ 1 / AK V i 1 Lt ( 1 , J

) =L (45

;

XOM A \J 1*1 DO 60 1=1,6 XOM J J u

L A 60 IFMTX(I)=IFMTS(I) XOM

I0SWT=0 XOM 350

IHCNT=0 XOM

CALL PREPAK(3,IND,IND,IND,IND) XOM

M0DE=1 XOM 400

NRMAX=0 XOM 410

NR0W=201 XOM 420 "T b w NC0L=62 XOM 430

KRDEND=80 XOM 440

LLIST=3 XOM 4^0

NERR0R=0 XOM 4A0

NSTMT=0 XOM 470

NSTMTH=0 XOM 480

NC0M=1 XOM 4Q0

LC0M=2000 XOM 500 P w V LEVEL=0 XOM 505

342
IOVFL=0 XOM 510

NPAGE=0 XOM 520

NRCC=NRC+100 XOM 530

00 90 I=1,NRCC XOM 540

RC(I)=0. XOM 550

NERR=0 XOM 560

NERC0N=100 XOM 570

ISWERR=0 XOM 580

DO 100 1=1,8 XOM 584

VWXYZ(I)=0.0 XOM 586

JPC=-1 XOM 588

CALL NOTEPR (0) XOM 600

RETURN XOM 605

END XOM 610

343
c

cc

c

cc

cc

c

c

c

10

20

30

C

cc40

50

SUBROUTINE XPND (T ,K ,Y ,KND)

VERSION 5.00 XPND 5/15/70

COMMON /BLOCRC/ NRC ,RC (12600)

COMMON /BLOCKD / IARGS(IOO) ,KIND(100) ,ARGTAB (100) ,NRMAX ,NROW,NCOL

1ARGS,VWXYZ(8) ,NERROR

DIMENSION ARGS(IOO)

EQUIVALENCE (ARGS ( 1 ), RC ( 12501 )

)

DIMENSION T(2)

THIS SUBROUTINE TAKES A "STATEMENT" REFERENCE AS STORED

AND EXPANDS IT INTO THE PROPER ARGUMENT WITH CHECKING.

K IS RETURNED 0 IF ARG IN STATEMENT IS ONE WORD LONG

K IS RETURNED 1 IF ARG IN STATEMENT IS TWO WORDS LONG.

K IS RETURNED -( ERROR NUMBER ) IF ERROR OCCURS.

IT—T(l)

IF (IT.LT 16) GO TO 40

"ROW, COL" ENTRY

IT=IT-8208

IF (IT.GT.O.AND.IT.LE.NROW) GO TO 10

K=-16

GO TO 20

IARGS(100)=ABS(T(2) )-8192.

KIND(100)=0

CALL ADRESS (100, J)

IF (J.NE.O) GO TO 30

K=-ll

RETURN

J=J+IT

KND=0

IF (T(2).LT

Y=RC(J-1)

K=l

GO TO 20

0.) KND=1

NRMAX, V, W, X, Y, Z, REFERENCE

IU=IT/2

KND=IT-2*IU

K=0

IF (IU.LE.l) GO TO 50

Y=VWXYZ(IU-2)

GO TO 20

Y=NRMAX

GO TO 20

END

XPN

XPN

XPN

NXPN

XPN

XPN

XPN

XPN

XPN

10

20

30

40

50

60

70

80

90

XPN 100

XPN 110

XPN 120

XPN 130

XPN 140

XPN 150

XPN 160

XPN 170

XPN 180

XPN 190

XPN 200

XPN 210

XPN 220

XPN 230

XPN 240

XPN 250

XPN 260

XPN 270

XPN 280

XPN 290

XPN 300

XPN 310

XPN 320

XPN 330

XPN 340

XPN 350

XPN 360

XPN 370

XPN 380

XPN 390

XPN 400

XPN 410

XPN 420

XPN 430

XPN 440

XPN 450

XPN 460

XPN 470

XPN 480

XPN 490

344
SUBROUTINE XSTOP XST 10

c VERSION 5.00 XSTOP 5/15/70 XST 20

COMMON /BLOCKC/ KIO , I NUN IT , ISCRAT ,KBDOUT ,KRDKNT ,LLIST XST 30

COMMON /BLOCRC/ NRC , RC ( 12600

)

XST 40

COMMON /BLOCKD / IARGS(IOO) , KIND (100) , ARGTAB ( 100 ) ,NRMAX ,NROW, NCOL , NXST 50

1ARGS,VWXYZ(8) ,NERROR XST 60

DIMENSION ARGS(IOO) XST 70

EQUIVALENCE (ARGS (1) ,RC (12501)

)

XST 80

COMMON/HEADER /NOCARD (80 ), ITLE (60,6) ,LNCNT , IPRINT ,NPAGE , IPUNCH XST 90

COMMON /SCRAT/ NS ,NS2 , A (13500

)

XST 110

DIMENSION ITEMP(84) XST 120

EQUIVALENCE ( ITEMP ( 1 ) ,A (1 )

)

XST 130

DATA IZ,IP,N0,K0MMA/1HZ,1H+,1H0,1H,

/

XST 140

c XST 150

c THIS ROUTINE REWINDS THE SCRATCH UNIT AND PRINTS IT. XST 160

c XST 170

REWIND ISCRAT XST 180

LLIST=0 XST 190

IF (NERROR.EQ.O) LLIST=3 XST 200

10 CALL PAGE (0) XST 210

WRITE (IPRINT, 90) XST 220

DO 40 J=l,50 XST 230

READ (ISCRAT, 100) ITEMP XST 240

IF (ITEMP(l) .EQ.IZ) GO TO 50 XST 250

IF (ITEMP(l) .EQ.IP) GO TO 30 XST 260

IF (ITEMP (1) .EQ.KOMMA) GO TO 20 XST 270

WRITE (IPRINT, 110) ITEMP XST 280

GO TO 40 XST 290

20 LLIST=3 XST 300

IF (ITEMP (2) .EQ .NO .AND . NERROR . EQ

.

0) LLIST=0 XST 310

GO TO 40 XST 320

30 WRITE (IPRINT, 120) ( ITEMP ( I ), 1=2

,

84) XST 330

40 CONTINUE XST 340

GO TO 10 XST 350

50 REWIND ISCRAT XST 360

IF (NERROR-1 ) 80,60,70 XST 370

60 WRITE (IPRINT,130) XST 380

GO TO 80 XST 390

70 WRITE (IPRINT, 140) NERROR XST 400

80 LLIST=3 XST 410

WRITE (IPRINT, 150) XST 420

WRITE (IPRINT, 160) XST 430

RETURN XST 440

C XST 450

90 FORMAT (//19X,39H LIST OF COMMANDS, DATA AND DIAGNOSTICS//) XST 460

100 FORMAT (84A1) XST 470

110 FORMAT (20X.84A1) XST 480

120 FORMAT (18X,3A1,3X,80A1) XST 490

130 FORMAT (///40X,20H0NLY ONE FATAL ERROR) XST 500

140 FORMAT (///40X,I4,7H ERRORS) XST 510

150 F0RMAT(1H0/33X,95H NATIONAL BUREAU OF STANDARDS, WASHINGTON, D. C.XST 520

1 20234, OMNI TAB II VERSION 5.00 MAY 15, 1970 ) XST 530

160 FORMAT (1H1

)

XST 690

END XST 700

345
8. Appendix — OMNIT Flow Chart

Flow Chart Notes

(1) The flow chart of the OMNIT subprogram was

generated by the FLOGEN program on the UNIVAC

1108 and drawn by the CAL-COMP plotter; see CAL-COMP [1968].

(2) When the flow of the diagram is broken, an arrow points to a box with two symbols. The top

number refers to the page and the bottom symbol

is the entry point. At each entry arrow, the number

inside the box indicates the page from which the

flow comes and the symbol outside is the entry

position.

(3) The INPUT subprogram reads an OMNITAB

instruction and stores the information in the array

KARD. Each character is stored in one location

starting with the character of the first column in

KARD(3). See page 2 of the flow chart.

(4) The subprogram NNAME takes the first six or less characters of the first nonnumeric word and

converts them into two numbers by combining the

values assigned to each letter. (See NNAME for

the values assigned to each letter.) The numbers are

stored in NAME(l) and NAME(2). See page 5

of the flow chart.

(5) Pages 5 through 11 of the flow chart check to see if the OMNITAB command is one of the fol- lowing: OMNITAB, FINISH, FORMAT, NOTE,

HEAD, TITLE or STOP.

(6) The subprogram EXPAND converts the values

in ARGTAB, described on page 18 of the flow chart,

to floating-point numbers and stores them in either

the array IARGS or the array ARGS, depending

upon whether an argument is an integer or a floatingpoint number. Also, EXPAND sets KIND(I) = 0, if an argument is an integer, and sets KIND(I)=1, if an argument is a floating-point number; see pages

19 and 22 of the flow chart.

(7) A table look-up is done by the subprogram

LOOKUP using NAME(l), NAME(2) and sometimes NAME(3) and NAME(4). Also, a set of unique

numbers are assigned to the variables Ll and L2.

If Ll=0, no command was found; see page 20 of

the flow chart.

(8) If a command is found, the subprogram

XECUTE is called to execute the instruction; see page 22 of the flow chart.

346
SUBROUTINE 0MNIT

C VERSION 5-00 OMNIT 5/15/70

C * * * * * * * * * * * * * * * THIS IS THE MAIN OMNITAB ROUTINE ****************x

COMMON /BLOCKA/ MODE . M , KflRD ( 83 ) . KRRG , HRG , ARG2 , NEWCD ( 80 ) , KRDEND

COMMON /BLOCKS/ NSTMT , NSTMTX , NSTMTH , NCOM . LC0M . I OVFL , COM ( 2000 ) COMMON /BLOCKC/ K I 0 . I NUN I T . I SCRAT . KBDOUT , KRDKNT . LL I ST

COMMON /BLGCRC/ NRC.RCC 12600)

COMMON /BLOCKD/ IARGS(1OO).KIND(1OO).ARGTAB(1OO),NRMAX.NROW.NC0L,N

RRGS , VWXYZ( 8 ) , NERROR

DIMENSION ARGS( 100

)

EQUIVALENCE ( ARGS ( 1 ) ,RC( 12501 J ) COMMON /BLOCKE/ NAME ( 4 ) . L 1 . L2 . I SRFLG

CQMM0N/HEADER/N0CARD(8O),ITLE(6O.6),LNCNT,IPRINT , NPflGE . I PUNCH

THE FOLLOWING CARDS ARE NEDDED ONLY FOR THPE OPERATIONS

COMMON /TAPE/ NAME4 ( 2 ) , NTPCT , I PUNCP , I NUN I P , L 1 TP

1

DATA I BLANK/ 1 H / , LETSGO/- 1

/

C THIS IS THE MAIN 0MNITAB PROGRAM

C SUBROUTINES COLLED BY THIS PROGRAM .

.

C SETUP. INPUT. ERROR. STMT, NNAME. A ARGS. ASTER. SETQ.READQ. STORE. XECUTE

C flERR.XOMNIT.XFORMT, LOOKUP

C MOD = 1 INTERPRETIVE MODE

C =2 DATA MODE ( READ SET)

C =3 STORAGE MODE (BETWEEN BEGIN AND FINISH)

C =4 IMPLIED STORAGE MODE (STATEMENT NUMBER GIVEN)

3

C 0=0.1=1. ETC . . 9 = 9 . A = 1 0 . C . = 37 , - = 38 , + = 39 . * = 40. ( = 41

C BLANK = 44. = = 45. $ AND OTHERS = 46

= 11, ETC , Z= 35 . / = 36

= 42 . . = 43

4 7 15 T20J]2\1 no

L6.J LlsJ l_20j 21 L22.J

CONT . ON PG

PG 1 OF 22

347
"FT Rl

-t>i

NSTMTrNSTMT+l 0~~]

1 r n2

MODE^l

<i

NRME( 1 )-0

NRME C 2 1:0

NflMEt 3)=0

NRME( 4 1=0

NRRGS^O

J:0 i_

CHECK FOR RCCUMULHTEO ERRORS DURING LAST EXECUTED EOMMRND

3

CRLL rerr" Toi"

20

A3

±1.

SL

fCRLL INPUT

SCANNING BEGINS WITH THE THIRD CHARACTER . THE FIRST TWO ARE DUMMY

TO KEEP THE PROGRAM OUT OF TROUBLE . SCANNING TERMINATES WITH A $ A $ HAS BEEN PLANTED IN THE ( KRDEND+ 1 ) -TH POSITION.

V\-2

~~T~__

|R4

30

Tm-m+ i

|_K z K A R D ( M ) V

V

CONT. ON PG

PG 2 OF 22

345
[~GQ TO" 60

C fl NUMBER IS THE FIRST ALPHANUMERIC CHARACTER ENCOUNTERED . ERROR IF

C IN MODE 3

CALL OUTPUT"

n5

_35 £

[£ALL ER

_ ROR (2)^|

HZ21

f

V

CONT. ON PG 4 PG 3 OF 22

409-118 OL - 71 - 23 349
GO TO 20 ">H> 2_

A3

350
ru IF11 ANn in iIIi_ 1i_ FGAI l_ ri i STATFMFNT «j i n i i i i l. i « i NllMRFR i vu I i lj i_ I \ WAS n n u FOUND i u u in u » KARG i \ n i \ u -— 1i (KARG i i\ni\u -— ("1 u IFi i C LEGAL)

4

i i> R9

MODE = 4 3:

M IS POINTING AT THE FIRST LETTER QN THE CARD. ASSEMBLE NAME

BO

i

•

SO <7 CALL NNAME ( N AME ( 1 )

)

"EL~

c CHECK THE FIRST NAME FOR SPECIAL NAMES • . . c OMNITAB. FORMAT NOTE. FOOTNOTE. HEAD . T I TLE

c OMN I TAB

IF NOT THE FIRST OMNITAB CARD. NRITE EOF RECORD

WRITE [ ISCRAT .390 "]'

CONT . ON PG 6

PG 5 OF 22

351
xz_ MODE;

^7

r GO TO 4Q^>-4>-

R6

FORMRT

v

v

CONT. ON PG

PG 6 OF 22

352
GQ TO 10 AO

CONT . ON PG 8

PG 7 OF 22

353
GO TO 100 ~>H>-§B8

fC RLL PRGE (0

tz

f3-

_2

[~vTR T TE~" C I PR I NT ,400 ) ( N E W CD ( 1-2 ) , I~=M ,82 )"

j A.

LNCNT-LNCNT + l"

.

A ^

I GO TO 80 J>\ B5

CONT. ON PG 9

354
B7

95

CALL NOTEPR ( K I T

£

GO TO 80 B5

[ GO TO 3 0

TITLES TITLEX = TITLE5, TITLEY = TITLE6

C CHECK NAME TITLE

0

PG 9 OF 22

355
9

GO TO 120~^>

K = 6

GO TO 130~~^>£>- 1 1 CI

|0-

1 20 <7 K = KfiRD( M )

GO TO 130~^>t>-

V. fCRLL" ERROR (209)

±1

CONT . ON PG 11

PG 10 OF 22

356
10 10

10

K=l

-O

CI

130 <7 MM=MIN0( M + 59 .81

< DO 140 1=1 ,60 >

140 ±

I TLE ( I . K IrlBLHNK

1 = 1

DO 150 MRr.ri.MM

I TLE C I . K JrNEWCDt MR-1 )

150 _£

= IM]

5

GO TO 80 7_

B5

C STOP

9

1 10 C2

IF ( NAME ( 1 ) .NE.14406.0R.NAME(2) .NE . 11664

GO TO 1 7 0 ^^>- 1 2 C3

i<3-

7

I WRITE ( ISCRAT ,390 ) £__

CALL XSTOP

stop"]

CONT . ON PG 12

PG 1 1 OF 22

357
C M IS POINTING fl T THE FIRST NQN-LETTER AFTER NCI ME • LOOK FOR

C POSSIBLE NAME QUALIFIER OR ARGUMENTS OR END OF CARD.

GO_ TO 1 90 ^ H>-

. 2 .

GO TO 170 J>-

CONT. ON PG 13

PG 12 OF

358
C fl LETTER FOUND. ASSEMBLE SECOND NRME (COMMANCF QUALIFIER).

12 l >

C4

175 V

CALL NNRHF INRMEO

3

C CHECK SPECIAL CASE OF NAMES M1\HX'), M(Y'flX). M C X X ), M(X'X

C SKIP ONE CHARACTER ( ) IF FIRST NAME =(M ) C THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS

C IS NAME ( 3 ) EQUAL TO TAP AND NAME ( 4 ) =E

GO TO 180~^>-

r }

CALL TAPOP

1 3

GO TO 190 1 4 C6

CONT. ON PG 14

PG 13 OF 22

359
SCRN FOR ARGUMENTS AND END 0F CARD

C5

-o

185 , i

M = 3

1 3 1 2

1 3 C6

-oo- C6 15

190 i

J = J+ 1

00 10 2TTJ

f3- C7 19 V

200 £

M=n +

1

o- C8 17

18

210 K7

C NUMBER FOUND . CONVERT ARGUMENT. IF KARG RETURNED = 0. NUMBER IS

C INTEGER. IF KARG = 1. NUMBER IS FLOATING POINT. IF KARG = -1, ERROR

CALL AARGS

HI

f

3

V

CONT. ON PG 15

PG 14 OF 22

360
0

C9

220 <7 HRGTHHf J )=0 •

J = J+ 1

, GO

ir

TO 240

^

C ARGUMENT IS AN INTEGER. ADO A BIAS OF 8192 THEN CHECK THAT IT IS

C .GT. 0

-O

230 <7 A RG= ARG+8 1 92

T

2

GO TO 240

f3-

2

CALL ERROR ( 1 8

1 i

21

GO TO 10~^>4>-

AO

240 ft ARGT AB ( J

) -ARG

250 S

^ rn

UU | 7

7 NARGS=NARGS+

1

GO TO 190~~^>4>

CQNT . ON PG 16

PG 15 OF

361
C RSTERISK FOUND. CONVERT

C IF BRACKETED BY SINGLE ASTERISKS . QUANTITY IS T 0 BE USED AS A

C FLOATING POINT ARGUMENT . I F BRACKETED BY DOUBLE ASTERISKS. QUANTITY

C IS TO BE TRUNCATED AND USED AS AN INTEGER ARGUMENT

.

GO TO 260~^>-

iO-

| KARG-O

M = M+ 1

O260, ±

MS = M

CALL ASTER

c

c

cc

cc

cc

THE TERMINAL ASTERISK(S) HAVE BEEN CHECKED TO BE THE SAME AS THE

INT I TAL SET (IF NO ERROR

AFTER THE LAST ASTERISK.

AND M IS POINTING AT THE FIRST CHARACTER

KARG RETURNED AS 1 = ERROR FOUND

2 = FLOATING POINT CONSTANT, Z-B- *PI*

3 = INTEGER NAMED VARIABLE. Z-B. **NRMAX**

4 = FL. PT. NAMED VARIABLE. Z-B. *NRMAX * 5 = INTEGER ROW-COLUMN . Z-B- **3.40**

C

Ccc

c

c

c

c

A STRING

EXAMPLE . ERASE 1 ERASE 1 PRINT 1 PRINT 1

OF

2 3 4 * * * 4 20 19

20 *>

6 = FL • PT . ROW-COLUMN

.

7 = STRING OF ASTERISKS

THREE OR MORE ASTERISKS IMPL

Z -B

Z .B ES -THRU-

* 1 , 2*

1 2

12 * 18 17

* 1 4

3 14 15

6 . 15

16

20

1 4

20 IS EQUIVALENT TO

IS EQUIVALENT TO

CONT . 0N PG 17

PG 16 OF 22

362
-<C GG TQ (270,220.280.280.290,290.300). KRRG~

15

C9

V K? V K7

18

D2

270. ft M = MS

GO TB 2 1 C5 ^>H> 1 4 C8

280 <7 RRGTRB ( J ) = -2 .*RRG-FL0RT( KflRG-3

GO TO 250 15

DO

290 <7 RRGTRB ( J )=-( RRG+8208 . )""

HRG2=-RRG2

—2—

1

J = J+ 1

RRGTRB ( J 1-RRG2

5

GO TO 250~^>T>[^|n

CONT. ON PG 18

PG 17 OF 22

363
CALL ERROR (211

T

GO TQ 210 j>H> 1 4 C8

310 ^

ARGT A8 (

J

GO TO 1 90 ^>H> C6

C RRGTflB SETUP

C IF ENTRY .GT. 0. IT IS AN INTEGER CONSTANT (Z-B. COLUMN NUNBER ) C TO WHICH A BIAS OF 8192 HAS BEEN ADDED . THIS IS TO SAY THAT A

C NEGATIVE INTEGER ARGUMENT MAY NOT BE EXPLICITLY GIVEN OR MODIFIED

C TO BE LESS THAT -8191 . C IF ENTRY -EQ.O. THE NEXT ENTRY IS A FLOATING POINT CONSTANT . C IF ENTRY .LT. 0. ARGUMENT IS A VARIABLE • SET SIGN POSITIVE AND..

C IF ENTRY .LT. 16. IT IS A NAMED VARIABLE REFERENCE NUMBER

2,3 NRMflX 6.7 V 10.11 X 8.9 W 12.13 Y 14.15 Z V.W.X.Y.Z. ARE FOR PROGRAMMING CONVENIENCE ONLY AND DO NO f AFFECT THE OPERATION OF OMNITAB

IF ENTRY IS EVEN. CURRENT VALUE TQ BE TRUNCATED AND USED

AS AN INTEGER ARGUMENT.

IF ENTRY IS ODD. THE CURRENT VALUE IS TO BE USED AS'A

5

FLOATING POINT ARGUMENT

.

IF ENTRY -GT. 16, IT IS A WORKSHEET REFERENCE (ROW. COLUMN) TO

WHICH A BIAS OF 8192. HAS BEEN ADDED . ENTRY - 8208 = ROW NUMBER

ABS ( NEXT ENTRY) = COLUMN NUMBER TO WHICH A BIAS OF 8192.

HAS BEEN ADDED.

IF NEXT ENTRY IS NEGATIVE. WORKSHEET CONTENTS ARE TO BE

USED AS A FLOATING POINT CONSTANT. IF + , WORKSHEET VALUE

TQ BE TRUNCATED AND USED AS AN INTEGER ARGUMENT

V

CQNT . ON PG 19

PG 18 OF 22

364
GO TO 200"""^>H>

C THE TERMINATION OF CARD FOUND ( $ ENCOUNTERED )

C IN INPUT MODE AND NO POSSIBLE NAME. RETURN TO SET OR READ ROUTINE

330 a

1 CALL EXPAND t J . A R GTAB

)

] :

CQNT. ON PG 20

PG 19 OF 22

365
1 9 D6

-t>i

GQ TO 340

19 D7

-Oi

CALL SETQ

T

£

GO TO 10~^>H>

AO

340 <7 CALL READQ

1£

3

GO TO 10 >n> 1AO

LOOK UP NAME (AND POSSIBLE QUALIFIER) IN DICTIONARY. RETURN

COORDINATES OF ENTRY. IF LI = 0. NAME NOT FOUND

GO TO 330~^>D>1

CONT. ON PG 21

PG 20 OF 22

366
20 D9

CALL ERROR ( 1 )

1 £

21

GO TO 10^>>-O

no

c NRliE FOUND

c THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS

c STATEMENT WAS 220 IF MODE EQ.2) M0DE=1

f3-

2

CALL ST 0 R E ( J ) £

±i

GO TO 10 AO

C THE FOLL OWING CAR PS ARE NEDD E_D__ ONLY _ FOR T AP E^ OPER A T TONS j

O37 0 <7 MODE::

1

£

INUNITrlNUNIP

£

CONT. ON PG 22

PG 21 OF 22

367
21

i 0

El

380 K7 CALL EXPAND (J.flRGTAB)

CALL XECUTE

GO TO 10 ">-i>

390

FORMAT ( 1HZ .83X )

400 \7 FORMAT ( IX . 80R 1 )

END

P G 22 FINA L

368
Latest developments in the subject area of this publication, as well as

in other areas where the National Bureau of Standards is active, are

reported in the NBS Technical News Bulletin. See following page.
HOW TO KEEP ABREAST OF NBS ACTIVITIES

Your purchase of this publication indicates an interest in the research,

development, technology, or service activities of the National Bureau of

Standards.

The best source of current awareness in your specific area, as well as in

other NBS programs of possible interest, is the TECHNICAL NEWS BULLETIN,

a monthly magazine designed for engineers, chemists, physicists, research

and product development managers, librarians, and company executives.

If you do not now receive the TECHNICAL NEWS BULLETIN and would like to

subscribe, and/or to review some recent issues, please fill out and return the

form below.

Mail to: Office of Technical Information and Publications

National Bureau of Standards

Washington, D. C. 20234

Name

Affiliation

Address

City State Zip

| | Please send complimentary past issues of the Technical News Bulletin.

|

| Please enter my 1— yr subscription. Enclosed is my check or money

order for $3.00 (additional $1.00 for foreign mailing).

Check is made payable to: SUPERINTENDENT OF DOCUMENTS.

SP 339
NBS TECHNICAL PUBLICATIONS

PERIODICALS NONPERIODICALS

JOURNAL OF RESEARCH reports National

Bureau of Standards research and development in

physics, mathematics, chemistry, and engineering.

Comprehensive scientific papers give complete details

of the work, including laboratory data, experimental

procedures, and theoretical and mathematical analyses. Illustrated with photographs, drawings, and

charts.

Published in three sections, available separately:

• Physics and Chemistry

Papers of interest primarily to scientists working in

these fields. This section covers a broad range of

physical and chemical research, with major emphasis on standards of physical measurement, fundamental

constants, and properties of matter. Issued six times a year. Annual subscription: Domestic, $9.50; foreign, $11.75*.

• Mathematical Sciences

Studies and compilations designed mainly for the

mathematician and theoretical physicist. Topics in

mathematical statistics, theory of experiment design,

numerical analysis, theoretical physics and chemistry, logical design and programming of computers

and computer systems. Short numerical tables.

Issued quarterly. Annual subscription: Domestic,

$5.00; foreign, $6.25*.

• Engineering and Instrumentation

Reporting results of interest chiefly to the engineer

and the applied scientist. This section includes many

of the new developments in instrumentation resulting

from the Bureau's work in physical measurement,

data processing, and development of test methods.

It will also cover some of the work in acoustics,

applied mechanics, building research, and cryogenic

engineering. Issued quarterly. Annual subscription:

Domestic, $5.00; foreign, $6.25*.

TECHNICAL NEWS BULLETIN

The best single source of information concerning the

Bureau's research, developmental, cooperative and

publication activities, this monthly publication is designed for the industry-oriented individual whose

daily work involves intimate contact with science and

technology

for engineers, chemists, physicists, re- search managers, product-development managers, and

company executives. Annual subscription: Domestic,

$3.00; foreign, $4.00*.

• Difference in price is due to extra cost of foreign mailing.

Applied Mathematics Series. Mathematical tables,

manuals, and studies.

Building Science Series. Research results, test methods, and performance criteria of building materials, components, systems, and structures. Handbooks. Recommended codes of engineering

and industrial practice (including safety codes) developed in cooperation with interested industries,

professional organizations, and regulatory bodies.

Special Publications. Proceedings of NBS conferences, bibliographies, annual reports, wall charts,

pamphlets, etc. Monographs. Major contributions to the technical

literature on various subjects related to the Bureau's

scientific and technical activities.

National Standard Reference Data Series.

NSRDS provides quantitative data on the physical

and chemical properties of materials, compiled from

the world's literature and critically evaluated.

Product Standards. Provide requirements for sizes,

types, quality and methods for testing various industrial products. These standards are developed cooperatively with interested Government and industry groups

and provide the basis for common understanding of

product characteristics for both buyers and sellers. Their use is voluntary.

Technical Notes. This series consists of communications and reports (covering both other agency and

NBS-sponsored work) of limited or transitory interest.

Federal Information Processing Standards Publications. This series is the official publication within

the Federal Government for information on standards

adopted and promulgated under the Public Law

89-306, and Bureau of the Budget Circular A-86

entitled, Standardization of Data Elements and Codes

in Data Systems.

Order NBS publications from: Superintendent of Documents

Government Printing Office

Washington, D.C. 20402

U.S. GOVERNMENT PRINTING OFFICE : 1971 0L—409-1 18