BYTE Listings Jul Oct 1986

Byte

This book was produced in EPUB format by the Internet Archive.

The book pages were scanned and converted to EPUB format automatically. This process relies on optical character recognition, and is somewhat susceptible to errors. The book may not offer the correct reading sequence, and there may be weird characters, non-words, and incorrect guesses at structure. Some page numbers and headers or footers may remain from the scanned page. The process which identifies images might have found stray marks on the page which are not actually images from the book. The hidden page numbering which may be available to your ereader corresponds to the numbered pages in the print edition, but is not an exact match; page numbers will increment at the same rate as the corresponding print edition, but we may have started numbering before the print book's visible page numbers. The Internet Archive is working to improve the scanning process and resulting books, but in the meantime, we hope that this book will be useful to you.

The Internet Archive was founded in 1996 to build an Internet library and to promote universal access to all knowledge. The Archive's purposes include offering permanent access for researchers, historians, scholars, people with disabilities, and the general public to historical collections that exist in digital format. The Internet Archive includes texts, audio, moving images, and software as well as archived web pages, and provides specialized services for information access for the blind and other persons with disabilities.

Created with abbyy2epub (v.1.7.2)

INDEX

July

ANAGRAM

PAS. .

. . .5

FORMULA

MOD.

..168

ASCSTR

ASM. .

.216

INTSGN

ASM.

...85

BROCHURE

DOC..

..60

LENSTR

ASM.

...87

CALC

MOD..

.127

LISPTEST

DOC.

...99

CELL

DEF..

.181

LISTING1

#

. .201

CELL1

MOD..

.182

LISTING2

#

. .202

CELL2

MOD..

.173

LOCSTR

ASM.

...93

CELLLIST

DEF. .

.169

LOGPSL

ASM.

...83

CELLLIST

MOD..

.179

LUG

INP.

. . .48

CHARSTUF

DEF..

.157

LWCSTR

ASM.

. . .88

CHARSTUF

MOD. .

.159

MEMAVA

ASM.

...58

CHKDUP

ASM. .

..10

MISC

DEF.

..185

CHOPWR

ASM..

..59

MISC

MOD.

. .185

COMMANDP

DEF..

.179

MODSTR

ASM.

. . .89

COMMANDP

MOD. .

.170

MOVSTR

ASM.

. . .56

CONFRM

ASM. .

..82

MSP

PAS.

..103

CONSTR

ASM..

. .86

MYSTOR1

DEF.

..164

CRITIBM

BAS..

.211

MYSTOR1

MOD.

. .165

CRITICAL

BAS. .

.197

MYSTOR2

DEF.

..166

DATE

ASM. .

..12

MYSTOR2

MOD.

. .166

DEFDRV

ASM. .

..96

MYTERMIN

DEF.

..146

DELFIL

ASM. .

..92

NUMTOSTR

DEF.

. .163

DISKIO

DEF..

.167

NUMTOSTR

MOD.

..164

DISKIO

MOD..

.130

PACER

ASM.

...83

DISPLAYH

DEF..

.140

PAKSTR

ASM.

.. .81

DISPLAYH

MOD. .

.150

PCRACK

BAS.

..102

DSKFRE

ASM. .

..97

PUNCH

INP.

...47

DSKSPC

ASM. .

..55

READ-ME

MSP.

..127

ENDSTR

ASM. .

. .91

READTHIS

..135

EVALUAT

DEF..

.140

RESSTR

ASM.

...95

EVALUAT

MOD..

.140

SAFE2SOL

FOR.

...28

EXPSTR

ASM. .

..46

SAFE2SUB

FOR.

. . .13

FILSTR

ASM. .

..89

SCREENHA

DEF.

..165

FORMULA

DEF..

.168

SCREENHA

MOD.

..154

SETPROB

PAS. .

. . .8

MACAPP

USE..

.258

SETSTR

ASM..

..79

MAPPER

BAS..

.261

SIZFIL

ASM. .

..98

MICROS

DAT..

.265

SIZSTR

ASM..

..90

NORMAL

SRC..

.253

SPREAD

DEF..

.159

PALIND

BAS. .

.268

SPREAD1

MOD. .

.161

PALIND

RUN..

.269

SPREAD2

MOD..

.146

POWSER

BAS. .

.269

SPREAD3

MOD..

.136

POWSER

RUN. .

.270

SRCHFOR

PAS. .

.127

READFORT

ME ..

.271

STRINGST

DEF..

.160

TYPES

DOC..

.271

STRINGST

MOD..

.186

TEST

SEQ..

.217

TESTDC

SEQ..

.217

TIME

TRUSS2

ASM. . BAS..

..80

.218

September

UGHBUG

ASM..

.232

UPCSTR

ASM..

..12

BREAKPT

ASM..

.277

vise

BAS..

.188

BRKPTCOM

BAS. .

.278

VISCIBM

BAS. .

.202

CCITT

C ..

.279

WTRANK

PAS..

.128

EXPS

ST1. .

.279

SDLC

ASM..

.286

SKAM

BAS..

.288

SKAM1

BAS..

.291

August

TBPROLOG

XMODEM

TST.. ASM..

.294

.299

XMODEM

C ..

.300

CITIES

DAT..,

,265

CUBESUM

RUN..,

.268

CUBESUM

BAS..,

.267

CYTOC

DAT...

.265

DENSITY

SRC..,

.253

FACTSUM

BAS..,

.266

FACTSUM

RUN..,

.267

LETS

SRC..,

.254

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 I

I ■L. SENIOR VICE PRESIDENT PUBLISHER I

J H ■W l ■ I H M

EDITOR IN CHIEF HI H /m

HLhJ H H Ki Philip Lemmons W r w

MANAGING EDITOR. BYTE

Frederic S. Langa

ASSISTANT MANAGING EDITOR

Glenn Hartwig

CONSULTING EDITORS

Steve Ciarcia Jerry Pournelle Ezra Shapiro Bruce Webster

SENIOR TECHNICAL EDITORS

Ion R. Edwards. Reviews G. Michael Vose. Themes Gregg Williams. Features

TECHNICAL EDITORS

Dennis Allen Richard Grehan Ken Sheldon George A. Stewart Jane Morrill Tazelaar TOm Thompson Charles D. Weston Eva white Stanley Wszola ASSOCIATE TECHNICAL EDITORS Curtis Franklin. Jr.. Best of B!X Margaret Cook Gurney Book Renews Brenda McLaughlin. Applications Software Renews S an Francisco

COPY EDITORS

Bud Sadler. Chief Ieff Edmonds Faith Hanson Nancy Hayes Cathy Kingery Paula Noonan Warren Williamson Judy Winkler

NEWS AND TECHNOLOGY

Gene Smarte. Bureau Chief. Costa Mesa Jonathan Erickson. Senior Technical Editor. San Francisco Rich Malloy. Senior Technical Editor. New York Cindy Kiddoo. Editorial Assistant. San Francisco

ASSOCIATE NEWS EDITORS

Dennis Barker. Microbytes Cathryn Baskin. Wfafs New Anne Fischer Lent. W hat s New

CONTRIBUTING EDITORS

Jonathan Amsterdam, programming projects Mark Dahmke. video, operating systems Mark Haas, at large Rik Jadrnicek. CAD. graphics, spreadsheets Robert T. Kurosaka. mathematical recreations Phil Lopiccolo. computers in medicine Alastair J. W. Mayer, software Alan R. Miller, languages and engineering Dick Fountain. UK.

Roger Powell, computers and music William M. Raike. Japan Phillip Robinson, semiconductors

ART

Nancy Rice. Art Director

Joseph A. Gallagher. Associate Art Director

Ian Muller. An Assistant

Alan Easton. Drafting

PRODUCTION

David R Anderson. Production Director Denise Chartrand Michael J. Lonsky Virginia Reardon

EXECUTIVE EDITOR. BIX

George Bond

SENIOR EDITOR

David Betz

ASSOCIATE EDITORS

TOny Lockwood

Donna Osgood. San Francisco

BIX GROUP MODERATORS

David P. Allen. Applications Programs Frank Boosman. Artificial Intelligence Leroy Casterline. Other

Marc F. Greenfield. Programming languages and Tools

Jim Howard. Graphics

Gary Kendall. Operating Systems

Steve Krenek. Personal Computers

Brock Meeks. Telecommunications

Barry Nance. New Technology

Donald Osgood. Persona! Computers

Sue Rosenberg. Other

Jon Swanson. Chips

BUSINESS AND MARKETING

DOUG Webster. Director. (603) 924-9027 Patricia Bausum Secretary Brian Warnock. Customer Service Denise A. Greene. Customer Service Tammy Burgess. Customer Credit and Billing

TECHNOLOGY

Clayton Lisle. Director. Business Systems Technology. MH1S Bill Garrison. Business Systems Analyst Jack Reilly. Business Systems Analyst Linda Wolff. Senior Business Systems Analyst

ASSISTANTS

Peggy Dunham. Office Manager Martha Hicks L. Ryan McCombs Chad Mitchell June N. Sheldon

TYPOGRAPHY

Sherry McCarthy Chief Typographer Len Lorette Donna Sweeney

Officers of McGraw-Hill Information Systems Company: President: Richard B Miller Executive Vice Presidents: Frederick P lannoct Construction Information Group. Russell C White, Computers and Communications Information Group I Thomas Ryan Marketing and International. Senior Vice Presidents Francis A. Shinal. Controller Robert C VioJette Manufacturing and “technology Senior Vice Presidents and Publishers: Laurence Altman. Electronics \teek; Harry L. Brown. BYTE; David J. McGrath. Construction Publications. Group Vice President Peter B McCuen. Communications Information. Vice President: Fred O. Jensen. Planning and Development

Officers of McGraw-Hill. Inc: Harold W. McGraw. |r.. Chairman. Joseph L. Dionne. President and Chief Executive Officer; Robert N. Landes. Executive Vice President and Secretary: Walter D. Serwatka Executive Vice President and Chief Financial Officer: Shel F Asen Senior Vice President, Manufacturing: Robert I. Bahash, Senior Vice President. Finance and Manufacturing: Ralph R. Schulz. Senior Vice President. Editorial: George R. Eisinger. Vice President. Circulation; Ralph J. Webb. Vice President and treasurer.

BYTE EVTf . and The Small Systems Journal are registered trademarks of McGraw-Hill Inc

EDITORIAL AND BUSINESS OFFICE: One Phoenix Mill Lane Peterborough New Hampshire 03458 1603)924-9281

West Coast Offices: 425 Battery St.. San Francisco. CA 94111 (415) 954-9718: 3001 Red Hill Ave . Building #1. Suite 222. Costa Mesa CA 92626 (714) 557-6292 New York Editorial Office: 1221 Avenue of the Americas New York. NY 10020. (212) 512-2000

BYTEnet: (617) 861-9764 (set modem at 8-1-N or 7-1-E: 300 or 1200 baud).

BYTE (ISSN 0360 5280! is published monthly with one extra issue per year by McGraw-Hill Inc Founder lames H McGraw u860-!948i Executive editorial, circulation, and advertising offices One Phoenix Mill Lane Peterborough NH 03458 phone 1603) 924-9281 Office hours Moo-Thur 8 30 AM-4 30 PM. Friday 8 30 AM-1 00 PM Eastern Time Address subscriptions to BYTE Subscriptions PO Box 590. Martinsville N| 08836 Postmaster send address changes USPS Form 3579 undelrverabJe copies and fulfillment questions to BYTE Subscriptions PO Box 596 Martr.sv: le N| 08836 Second-class postage paid at Peterborough NH 03458 and additional mailing offices Postage paid at Winnipeg Manitoba Registration number 9321 Subscriptions are $21 for one year S38 for two years and S55 for three years in the US and its possessions In Canada and Mexico S23 for one year $42 for two years 56! for three years $69 for one year air delivery to Europe 31.000 yen for one year air delivery to lapan 15 600 yen for one year surface delivery to lapan. $37 surface delivery elsewhere Ar delivery to selected areas at additional rates upon request Sngle copy price is $3 50 in the US and its possessions S4 2 5 m Canada and Mexico. $4 50 in Europe and S5 elsewhere Foreign subscriptions and sales should be remitted in US funds drawn on a US bank Piease allow six to eight weeks for delivery of first issue Printed in the United States of America

Address editorial correspondence to Editor BYTE. One Phoenix Mill Lane Peterborough NH 03458 Unacceptable manuscripts will be returned if accompanied by sufficient postage Not responsible for lost manuscripts or photos Opinions expressed by the authors are not necessarily those of BYTE

Copyright 1 1986 by McGraw-Hill Inc All rights reserved Trademark registered in the United States Patent and Trademark Office Where necessary permission is granted by the copyright owner for libraries and others registered with the Copyright Clearance Center iCCO to photocopy any article herein for the flat fee of SI 50 per copy of the article or any part thereof Correspondence and payment should be sent directly to the CCC. 29 Congress St Salem MA 01970 Specify ISSN 0360-528CV83 $1 50 Copying done for other than personal or internal reference use without the penrussKX of McGraw-Hill Inc is prohibited Requests for special permission or bulk orders should be addressed to the publisher BYTE is available in microform from University Microfilms International.

300 North Zeeb Rd Dept PR Ann Arbor. Ml 48106 or 18 Bedford Row Dept PR London WCIR 4EI.

England.

Subscription questions or problems should be addressed to BYTE Subscriber Service PO Box 328.

Hancock. NH 03449

2 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

TABLE OF CONTENTS

July .5

August.253

September.277

4 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER 1986

anagram.pas

Programming Project: "Anagram Solving In Pascal," by Bob Keefer. July, page 113. Also see setprob.pas.

program Anagram;

{Copyright 1985 by Bob Keefer}

{Anagram.Pas takes a word of up to 10 letters from the keyboard and rearranges the letters into every possible permutation, or anagram, of the word.}

{It then evaluates the likelihood that each anagram is an English word by looking up every trigram in the word in a probability table, which is stored in a separate file PROB.DAT and is read into the array ProbabiI Ity[X,Y,Z]. Finally, it records the top scoring anagrams in Scoreboard and prints them to the screen.}

{The program must be compiled with the Turbo "c" compiler option to a *.COM file.}

j$A-| jcompiler directive for recursion} |$C-| .... ignore and ~S breaks} {$I-| j.... no i/o checking}

|$V“} {.... no string checking}

const

MaxLength - 13; jbiggest word + 3}

MaxScores « 15 ; {how many winners to store}

type

ScoreLIne * record {One line of the Scoreboard} Winner : string[MaxLength] ;

Points ; integer ; end;

var

Word : array [1..MaxIength] of char; {Word to permute} Wordlength : integer; {Length of Word}

Probability : array [0..26,0..26,0..26] of integer; ScoreBoard : array [1..MaxScores] of ScoreLine; WordToScore : strlng[MaxIength]; {anagram}

DataFile : file of integer; {probability table}

TheWord : String[MaxIength]; {Word as string}

I : Integer; {counter}

procedure Score; var

X,Y,Z,I,J : Integer ; Total : integer ; Unlikelihood ; integer;

procedure KeepScore;

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 5

var

N : integer;

procedure ChalkltUp; var

TempScore, I : integer;

TempName : StrIng[MaxLength];

begin {ChalkltUp}

for I :■ N to MaxScores do begin

with ScoreBoard[I] do Ilf an anagram} if Total>Polnts then {scores better,}

begin {then record it...}

begin

TempScore :* Points;

TempName :■ Winner;

Points :■ Total;

Winner :* WordToScore

end;

if IoMaxScores then

begin {..bump the rest down} with ScoreBoard[I+1] do beg i n

WordToScore :« TempName; Total :* TempScore;

end;

end;

end;

end;

end; {ChalkltUp}

begin {KeepScore}

for N :• 1 to MaxScores do begin

if WordToScore - ScoreBoard[N].Winner

then Total ;■ 0; {eliminate duplicates} if (Total > ScoreBoard[N].Points) then ChalkltUp;

{record good-scoring words}

end;

end; {KeepScore} /

begin {procedure Score}

WordToScore :■ • * + WordToScore + * ’; Total :» 0;

Unlikelihood :« 0;

for I := 1 to Iength(WordToScore) -2 do begin

X ord(copy(WordToScore,I,1))-64;

Y :■ ord(copy(WordToScore,1+1,1))-64; Z :* ord(copy(WordToScore,1+2,1))-64; If X<0 then X:=0;

If Y<0 then Y:=0; if Z<0 then Z:«0;

Total Total + Probabillty[X,Y,Z];

If ProbabiI Ity[X,Y,Z]=0 then Unlikelihood :* succ(UnI ike Iihood)

end;

for J := 1 to Unlikelihood do Total Total div 2;

KeepScore;

end; {procedure Score}

procedure Permute (CurrentLength : integer);

var

I : Integer;

procedure Switch; var

6 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

Temp : char; beg i n

Temp :* Word[CurrentLength]; WordTCurrentLength] :* Word[I]; Wordfl] :■ Temp; end; {Switch}

procedure Outword; begin

WordToScore*; for I :* 1 to Wordlength do WordToScore :* WordToScore + Word[I]; end; {Outword}

begin {Permute body}

if CurrentLength « 1 then begin

Outword;

Score;

end

else for I :« 1 to CurrentLength do begin

Switch;

Permute(CurrentLength - 1); Switch;

end;

end; {Permute}

procedure Getlnput; var

I ; integer; begin

write('Enter word: '); readln(TheWord);

WordLength :« Iength(TheWord); for I :* 1 to WordLength do begin

Word[I] :« upcase(copy(TheWord,1,1));

end;

TheWord :«

for I :» 1 to WordLength do

TheWord TheWord + Word[I];

end; {procedure Getlnput}

procedure ZeroScore; var I : integer;

begin

for I:« 1 to MaxScores do beg i n

with ScoreBoardfl] do begin

Points :* 0;

Winner :■ M ;

end;

end; {withj end; {ZeroScore}

procedure PostScore; var

I ; integer;

Gotlt : boolean;

begin

GotIt:*false;

for I :■ 1 to MaxScores do

( continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 7

begin

with ScoreBoard[I] do begin

If Polnte>0 then

wr J teIn(1:2, • ’.Winner, 1 ’, Points);

end; {with} end; jfor loop} end; {procedure PostScore}

procedure ReadProb;

var X,Y,Z : Integer;

beg I n

asslgn(Dataf1 Ie,’PROB.DAT’); reset(DataFIle); for X :« 0 to 26 do begin wr I te(•*•);

for Y :■ 0 to 26 do begin

for Z ;■ 0 to 26 do begin

read(DatafIle.ProbabiIity[X,Y,Z]);

end;

end;

end;

close(DatafIle); wr IteIn;

end; {procedure ReadProb}

procedure SlgnOn; beg i n

c I rscr;

wrIteInf’Anagram.Pas *); wr I teIn(’By Bob Keefer’); wr 11 eIn(’CopyrIgh t 1985'); wr IteIn; wr IteIn;

writeln(’To halt program, enter "*"’); wr l teIn; wr I teIn; wr IteIn;

writeln(’Reading Probability Table...*); end; {procedure Signon}

begin

end.

{Anagram program}

SignOn; jDIsplay signon message}

ReadProb; {Read probability table}

c I rscr; repeat

Get Input;

ZeroScore;

Permute (WordIength); wr iteln;

PostScore; wr I teIn; wr I teIn;

untiI Word[1]-’*’;

i Get word} clear Scoreboard} {Evaluate words}

{Print resuIts}

setprob.pas

Programming Project: "Anagram Solving in Pascal," by Bob Keefer. July, page 113. Also see anagram.pas.

Keywords: JUL86 Programming Project anagram Pascal Bob Keefer

program SetProb;

{Copyright 1985 by Bob Keefer}

{SetProb.Pos creates a 3-dimensional byte array, ProbobiIity[X,Y,Z]. In which are stored

8 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

the relative probability of each 3-letter trigram found in an input text.

Once the table is completed, it is stored in the disc file PROB.DAT.}

{To use this program to add more data to an existing version of PROB.DAT, modify procedure ZeroProb so that it reads ProbabiIity[X,Y,Z] from PROB.DAT instead of zeroing the array. This can be done by commenting out the lines marked with a single * and restoring the lines marked with a double **.}

var

Chi, Ch2, Ch3 : char;

X, Y, Z : integer;

FiIename : str1ng[15];

TheFiIe : text;

Datafile : file of integer;

Probability : array [0..26,0..26,0..26] of integer; procedure ZeroProb; var

X,Y,Z : integer; begin

{assign (Dataflie,'Prob.dat *);} {**{

{reset(Datafile);} {**}

for X:»0 to 26 do begin

for Y:*0 to 26 do begin

for Z:* 0 to 26 do begin

{*} Probab!Iity[X,Y,Z] :* 0;

{**} {read(DatafiIe,ProbabiIity[X,Y,Z]);}

end;

end;

end;

{close (Datafile);} {**} end; {ZeroProb}

procedure ScaleProb; var

X,Y,Z : integer;

begin

for X:*0 to 26 do begin

for Y:»0 to 26 do begin

for Z:» 0 to 26 do begin Probab!Iity[X,Y,ZJ :«

(Probab!Iity[X,Y,Z] + 1) div 2;

end;

end;

end;

end; {ScaleProb}

procedure Startup;

begin

c I r s c r *

writeIn('SetProb.Pas *); wrlteln(*Copyright 1985 by Bob Keefer*); wr i teln;

write (’Enter filename: *); read In (F 1 Iename); assign (TheFlIe, Filename); reset (TheFlie); end;

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 9

function Cleanup ( A : integer ) : integer; beg i n

If (A>64) and (A<91) then Cleanup :■ A-64 else Cleonup :■ 0; end; {function Cleanup}

procedure Countem; begin

Chi #32;

Ch2 :• #32;

while not EOF (TheFIle) do beg i n

read(TheFiIe,Ch3);

X :■ CleanupfordfupcasefChl^};

Y :■ CIeanup(ord(upcase(Ch2)));

Z :« Cleanup(ord(upcase(Ch3)));

if not (((X=0) and (Y-0)) or ((Y=0) and (Z=0))) then ProbabiIity[X,Y,Z]

ProbabiIity[X,Y,Z] + 1; if Probabi11ty[X,Y,Z] >32000 then ScaleProb; Ch1:«Ch2;

Ch2:«Ch3;

end;

end; {Countem}

procedure WrlteData; var X,Y,Z ; Integer; begin

for X ;« 0 to 26 do begin

for Y :■ 0 to 26 do begin

for Z ;■ 0 to 26 do begin

write(Datafile,ProbabiIlty[X.Y,Z]);

end;

end;

end;

end; {procedure WrlteData}

begin {program SetProb}

ZeroProb;

Startup;

Countem;

assign(DatafIle,’Prob.dat’); rewrite(Dataflie);

Wr1teData; closefDataFile); cIose(TheFlie); wr1te(#7);

end.

chkup.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE CHKDUP - SUBROUTINE TO CHECK FOR DUPLICATED LINES PAGE ,132

; (C) Copyright

COMMENT *

Mode of

where

*

Microstress Corporation 1984, 1985, 1986

use:

call CHKDUP (number,fIag)

number « integer with the element number to check, flag * integer to show success («0) or error (=1).

10 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

SUBTTL

FORMAL

DECLARATIONS

PAGE

cschdp

SEGMENT

*CODE *

ASSUME

CS:cschdp

tab 1 e

db

150 dup (0)

masks

db

1,2,4,8,16,32,64,128

SUBTTL

CHKDUP

- EXECUTABLE CODE

PAGE

PUBLIC

CHKDUP

CHKDUP

PROC

FAR

PUSH

BP

MOV

BP,SP

push

ds

LDS

BX,DWORD PTR [BP+10]

MOV

ax,[BX]

push

ds

mov

bx,cschdp

mov

ds, bx

cmp

ax,0

J«

reset

dec

ax

xor

dx.dx

mov

bx,8

dl v

bx

mov

bx,offset masks

add

bx,dx

mov

ch,[bx]

mov

bx,offset table

add

bx,ax

mov

Cl ,[bx]

push

cx

and

cl ,ch

cmp

cl ,0

Jne

error

pop

cx

or

cl ,ch

mov

[bx],c1

xor

ax, ax

Jmp

exit

error:

pop

cx

mov

ax, 1

Jmp

exit

reset:

mov

bx,offset table

mov

cx,150

byte loop:

mov

[bx],a 1

inc

bx

loop

byte loop

exit:

pop

ds

LDS

BX,DWORD PTR [BP+6]

mov

[bx],ax

pop

ds

MOV

SP,BP

POP

BP

RET

8

CHKDUP

ENDP

cschdp

ENDS

END

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 II

July

date.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. LoygorrI. July, page 199.

TITLE DATE PAGE ,132

SUBROUTINE TO GET THE DATE

; (C) Copyright Microstress Corporation 1984, 1985, 1986 COMMENT *

DATE Is a routine designed to be called from FORTRAN as a subroutine to access the date from the system.

Mode of

use:

call DATE (day,month

where

day « 2-byte Integer containii

month * 2-byte integer contali

♦

year * 2-byte integer contain

SUBTTL

FORMAL DECLARATIONS

PAGE

csdate

SEGMENT

'CODE *

ASSUME

CS:csdate

SUBTTL

DATE - EXECUTABLE CODE

PAGE

PUBLIC

date

date

PROC FAR

PUSH

BP

MOV

BP.SP

PUSH

DS

; Call

the system function.

xor

ax, ax

mov

ah,2Ah

Int

21h

; Handle parameters from calling program

LDS

BX,DWORD PTR [BP+6]

MOV

[BX],cx

xor

ax, ax

mov

a 1 ,dh

LDS

BX,DWORD PTR [BP+10]

MOV

[BX],ax

mov

a 1. d 1

LDS

BX,DWORD PTR [BP+14]

MOV

[BX],ox

; Everything done except housekeeping.

exit:

POP

DS

MOV

SP, BP

POP

BP

RET

0Ch

date

ENDP

csdate

ENDS

END

upcstr.

.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. LoygorrI. July, page 199.

TITLE UPCSTR - SUBROUTINE TO PUT A STRING IN UPPERCASE PAGE ,132

12 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

; (C) Copyright Microstress Corporation 1984, 1985, 1986

July

COMMENT *

UPCSTR is a routine designed to be called from FORTRAN as a subroutine to set all the alphabetic characters to uppercase.

Mode of use: where

string

♦

call UPCSTR (string)

name of the string (variable of type CHARACTER) to be converted to uppercase.

SUBTTL FORMAL DECLARATIONS PAGE

csupcs SEGMENT ’CODE’

ASSUME CS:csupcs

SUBTTL UPCSTR - EXECUTABLE CODE PAGE

PUBLIC

UPCSTR

UPCSTR

PROC

FAR

PUSH

BP

MOV

BP,SP

PUSH

ds

LDS

BX,DWORD

PTR

[BP+6]

character:

CMP

BYTE

PTR

[bx],0

Je

exit

CMP

BYTE

PTR

[bx],6

je

exit

CMP

BYTE

PTR

[bx],*o

JB

next

CMP

BYTE

PTR

[bx],-z

JA

next

AND

BYTE

PTR

[bx],95

next:

INC

bx

Jmp

character

exit:

pop

ds

MOV

SP.BP

POP

BP

RET

4H

UPCSTR

ENDP

csupcs

ENDS

END

safe2sub.for

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

$LINESIZE: 132 $PAGESIZE: 61 $ST0RAGE: 2

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc £ c

c MICROSAFE C

C Structural Analysis by Finite Elements C

C Module : SAFESOLV, 2nd Part C

C Version : 2-D C

C C

C COPYRIGHT (C) by MICROSTRESS Corporation - 1985,1986 C

C ALL RIGHTS RESERVED C

C C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 13

ooo ooo ooo ooo ooo ooo ooo

July

SUBROUTINE parsfn (fI spec,ddrIve,fI dr Iv,dr Iven,fI path,fIname,

+ flextn)

Parse a file specification and get drive, path, name and extension IMPLICIT INTEGER (a-z)

CHARACTER fI drI v*6,fIpath*64,fIname*9,fIextn*5,fIspec*78,coIon*2, + bsIash*2,period*2

Initial Ization.

call setstr (78,flspec) caI I pakstr (fI spec)

caI I upcstr (fI spec) fldrlv-'

cal I setstr (6,fldrlv) f I path-*

+ *

cal I setstr (64,fIpath) flname-' '

cal I setstr (9,fIname) flextn-'

caI I setstr (5,fIextn) colon-': '

caI I setstr (2,coIon) bslash«'\ *

cal I setstr (2,bsI ash) period-'. '

cal I setstr (2,period)

Determine the drive specification

locatn-locstr (1,fI spec,coI on)

If (locatn .eq. 0) then dr I ven-ddrive+1

e I se

call movstr (fI dr Iv,1,1,fI spec,1,locatn) drIven-ascstr (locatn-1,fIspec)-64 end! f

Determine the path specification

f I rstc-locatn+1 I astoc-locatn

10 locatn-locstr (Iastoc+1,fI spec,bsI ash)

If (locatn .ne. 0) then lastoc-locatn goto 10

e I se

call movstr (fI path,1,1,fI spec,fIrstc,Iastoc-fIrstc+1) end! f

Determine the extension specification

length-1enstr(fI spec)

locatn-locstr (Iastoc+1,fI spec,period)

If (locatn .ne. 0) then

cal I movstr (fIextn,1,1,fI spec,locatn,Iength-1ocatn+1)

e I se

Table captionlocatn-Iength+1

endi f

Determine the name spec

ca11 movstr (f1 name,

Pack the return

strings

ca11 pakstr i ca11 pakstr < ca11 pakstr < ca11 pakstr i RETURN

END

ffIdriv) f f 1 path) [ f 1 name; [f1extn)

$PAGE

14 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

J uly

c

c

c

SUBROUTINE trlasemb (i,j,k,th,eyoung,prat Io) Assemble stiffness matrix for triangular plate

DOUBLE PRECISION th,diffnc(2,4),ftcons(9),eyoung,pratio common /coordi/ coonod(2,401) d j ffnc{1 »2)*coonodf 1, J^-coonodM , I ~,2)-coonod(2,J)-coonod(2,I coonodf1,K)-coonod(1,J coonod(2,K;-coonod(2,J coonod(1,I)-coonod(1,K)

• K)

diffnc(2 diffnc(1,3 dlffnc(2,3

diffncf 1,1 _ . _

diffnc(2,1)*coonod(2,I;-coonod(2

ftcons ftcons ftcons ftcons

diffnc(2,3)*diffnc(1,2)-diffnc(1,3)*diffnc(2,2) eyoung*TH/(4*ftcons(6))

»ftcons ■ftcons

1)/(l-pratio u/U+prat Io

!

ftcons(1)«ftcons(7)♦

+ (dlffnc(1,3)*dlffnc(1,3)+diffnc(2,3)*diffnc(2,3))

ftcons(2)-ftcons(7)*

+ (dlffnc(1,1)*diffnc(1,1)+dlffnc(2,1)*dlffnc(2,1))

ftcons(3)-ftcons(7)*

+ (dlffnc(1,3)*dlffnc(1,2)+diffnc(2,3)*dt ffnc(2,2))

ftcons ( 4J-ftcons(7}*ftcons(6) ftcons(5)«ftcons(7)*

(diffnc(1,2)*dlffnc(1,2)+diffnc(2,2)*diffnc(2,2))

$PAGE

11-3*1-2 J1«3*J-2 K1-3*K-2

CALL assemble (11,11,ftcons(1)+ftcons(8)*diffne(2,3)*diffnc(2,3), + -ftcons(8)*dlffnc(1,3)*diffnc(2,3),0.)

CALL assemble (11.J1,-ftcons(1)-ftcons(3)+

+ ftcons(8)*diffnc(2,3)*dlffnc(2.1),

+ _ . -ftcons(4)-ftcons(8)*dlffnc(2,3)*diffnc(1,1),0.)

CALL assemble (11,k1,ftcons(3)+ftcons(8)*diffnc(2,2)*diffnc(2,3), + ftcons(4)-ftcons(8)*dIffnc(2,3)*diffnc( 1 , 2 ), 0 .)

CALL assemble (11 + 1,11 + 1,ftcons(1)+

+ ftcons(8)*diffnc(1,3)*diffnc(1,3),0.,0.)

CALL assemble (11 + 1,J1,ftcons(4)-ftcons(8)*

+ dlffnc(2,1)*diffnc(1,3),-ftcons(1)-ftcons(3)+

+ ftcons(8)*dlffnc(1.1)*dlffnc(1,3),0.)

CALL assemble (I1+1.K1,

+ -ftcons(4)-ftcons(8)*dlffnc(2,2)*diffnc(1,3),

+ _ ftcons(3)+ftcons(8)*dlffnc(1,2)*diffnc(1,3),0.)

CALL assemble (J1,J1,ftcons(2)+ftcons(8)*dlffnc(2,1)*dlffnc(2,1)

+ -ftcons(8)*dI ffnc(2,1)*diffnc(1,1),0.)

CALL assemble (J1,K1,-ftcons(3)-ftcons(5)+

+ ftcons(8)*dIffnc(2,1)*dlffnc(2,2),

+ , -ftcons(4)-ftcons(8)*dIffnc(2,1)*dlffnc(1,2),0.)

CALL assemble (J1+1.J1+1, y '

+ ftcons(2)+ftcons(8)*d!f fnc(1,1)*dlffnc(1,1),0..0.)

CALL assemble (J1+1,k1,ftcons(4)- '

+ ftcons(8)*dlffnc(1,1)*diffne(2,2),-ftcons(3)

+ ftcons(5)+ftcons(8)*dlffnc(1,1)*diffnc(1,2),0.)

CALL assemble (K1,K1,ftcons(5)+ftcons(8)*diffnc(2.2)*diffnc(2,2)

+ -f tcons(8)*diffnc(1,2)*dlffnc(2,2),0.)

CALL assemble (k1+1,k1+1,

* rTIIDll ftcons(5)+ftcons(8)*diffnc(1,2)*dlffnc(1,2),0.,0.)

RETURN END

SUBROUTINE assemble (irow,icoI,addl,add2,add3) Assemble the stiffness matrix

DOUBLE PRECISION stmtrx,stmqcn,add(3),addl,add2,add3 INTEGER long I*4

COMMON /global/ numdof,stmqcn(2,2)

common /sizebw/ malhbw

COMMON /aaaaaa/ stmtrx(8200)

add(1)«add1

addf2)«add2

add(3)«add3

do 10 1-1,3

If (add(l) .ne. 0.) then ic-icol+l-1

If ((Irow .Is. numdof) .and. (Ic .Is. numdof)) then longl-ic+Irow-1-malhbw

{continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 15

o o o

July

If (Irow .ge. Ic) then IongI-IongI+maIhbw*Ic

e I ee

IongI-1ong!+maIhbw*I row endlf

stmtrx(IongI)-stmtrx(IongI)+add(l)

else

IongI«ic+ frow-2-numdof If (Irow .gt. numdof) then If (Ic . le. numdof) then

longi«longI+Ic*(malhbw+1) stmtrx(IongI)«stmtrx(IongI)+add(I)

e I se

Ir-Irow-numdof Icband-!c-numdof

stmqcnf!r,Icband}-stmqcn(Ir,Icband)+add(I) stmqcn(Icband,Ir)-stmqcn(I r, Icband) endlf

e I se

IongI-IongI+1row*(maIhbw+1 ) stmtrx(Iongl)-stmtrx(Iongl)+add(l) endlf endl f END IF

10 continue RETURN END

$PAGE

SUBROUTINE trlloads (Inpl,lnp2,lnp3,th.eyoung.pratlo,Ip I.nodepl) Calculate forces and stresses In triangular plate

DOUBLE PRECISION disdof,cor for,eyoung,pratlo,th,

+ diffnc(2,4),ftcons(9)

DIMENSION lnp(3),cor for(2,3).nodepl(4,500)

INTEGER prevld

common /coord!/ coonod(2,401)

COMMON /plates/ disdof(1203),pltecf(2,4),pIstrs(3,500),

+ reafor(3.400),pstnor(3,400),pstacc(3,400)

prevldfk,I)*M0D(k+l-2,I)+1 next Id(k,I)-MOD(k, I )+1 Inp(1)«Inp1 Inp(2)-Inp2 Inp(3)-inp3 I»nodepl(inp(1).LPL)

J-nodepI(inp(2),LPL)

IF (lnp(3) .It. 0) THEN K—i np(3) nan-2

ELSE

K-nodepI(lnp(3),LPL) nan-3

ENDIF

11-3*1-2

J1»3*J-2

K1-3*K-2

dl f fnc(1,2)-coonodM , J}-coonod(1 , I} dlffnc(2,2)«coonod(2,j)-coonod(2,I ) dlffnc(1,3)«coonodM,K)-coonod(1, j) diffnc(2,3)-coonod(2,K)-coonod(2,J) dlffncCI,1)«coonod(1,l)-coonodf1,lO diffnc(2,1)«coonod(2,I)-coonod(2,K)

ftcons(4)«eyoung/((1+pratIo)*(dIffnc(1,1)*diffnc(2,2)+ diffnc(1,2)*diffnc(2,1)))

ftcons(5)-dIffnc(2,3)*disdof(I1)+diffnc(2,1)*disdof(J1)+

+ diffnc(2.2)*disdof(K1)

ftcons(6)-diffnc(1,3)*disdof(11+1)+diffnc(1,1)*disdof(J1+1)+ + dlffnc(1,2)*disdof(K1+1)

f tconsM ^-(prat Io*f tcons(6)-ftcons(5^*f tcons(4Vp“P r at io) ftcons(2;=(ftcons(6)-pratio*ftcons(5;)*ftcons(4)/(1-pratio) ftcons(3)-(diffnc(1,3)*disdof(II)-diffnc(2,3)*disdof(11+1)+

+ diffnc(1.1)*disdof(J1)-diffnc(2,1)*disdof(J1+1)+

+ diffncM,2)*disdof(K1)-dlffnc(2.2)*disdof(K1+1))*

+ ftcons(4)/2

DO 20 LL-1.NAN INDX-nodepI(Inp(LL),LPL)

16 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

ftcons(7)-ABS(dif fnc(2,nextid(LL,3))-dl ffnc(2,LL))/

+ (ABS(d ? f fnc(l,next id(LL,3))-diffnc(1,LL))+

+ ABS(diffnc(2,nextid(LL.3))-diffnc(2.LL)))

DO 10 L-1,2 "

corfor(L,LL)-TH*.5*(diffnc(1,previd(LL,3))*ftcons(4-L)+ diffnc(2,previd(LL,3))*ftcons(2*L-1)) pi tecf(L,lnp(LL))»pltecf(L,inp(LL))+corfor(L,LL) ftcons(7)«1-ftcons(7)

reafor(L,INDX)-reafor(L.INDX)+corfor(L,LL) pstnor(L,INDX)=pstnor(L,INDX)+ftcons(7) pstacc(L,INDX)-pstacc(L,INDX)+ftcons(7)*ftcons(L)

10 CONTINUE

pstacc(3,INDX)-pstacc(3,INDX)+ftcons(3) pstnor(3,INDX)*pstnor(3,INDX)+1 pIstrsCLL.LPLJspIstrsCLL.LPLJ+ftcons(LL)

20 CONTINUE

IF (nan .EQ. 2) pIstrs(3,LPL)=pIstrs(3,LPL)+ftcons(3)

RETURN

END

$PAGE

SUBROUTINE opnfil (lerror)

C

C Open a file for output with verification C

LOGICAL ffound

CHARACTER inpfil*78,outfI I*78,prompt*55,intgst*25 common /filenm/ InpfiI,outf11 inquire (FILE=outfII,EXIST-ffound)

If (.not.(ffound)) then

cal I setstr f78,outf11) cal I pakstr (outf11) length*lenstr(outfI I)+1 cal I expstr foutf11 ) cal I resstr foutfI I) call setstr (length,outfil) call chopwr (outfiI,lerror)

If (lerror .ne. 0) then cal I resstr (outfI I) length-length-1

call wrfstr (float(length),Intgst) length-lenstr (Intgst)

prompt-* (• * ERROR : File H *\a , * *" cannot be open. Try a +galn.* *) * 7

call setstr f55,prompt) call movstr (prompt,21,0,Intgst,1,Iength) caI I resstr (prompt) write (*,prompt) outfil return endif

cal I resstr (outf11) endi f

OPEN (2,FILE«outfI I,STATUS-*new*)

lerror-0

return

END

$PAGE

SUBROUTINE diskroom (nbytes)

C

C Update count of characters in output file to avoid disk full errors.

C

INTEGER frespc*4,odrIve.scrflg,asclIc COMMON /dskrom/ scrfIg,odrIve C

if (nbytes .eq. 0) then

call dskspc (odr1ve,frespc) frespe-frespc-1

e I se

C

20 frespe-frespe-nbytes C

If (frespc .It. 0) then close (2) asciIc-odrlve+64 write (*,30)

30 format (//* ERROR : Output file disk Is full.*)

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 17

32

35

40

write (*,35) char(ascMc) format (’ Change the disk In drive *,a1, h * and press any ke to continue.*)

cal I confrm

If (scrflg .eq. 0) write (*,40)

format (1x\)

caI I opnfI I ( I error)

If (lerror .ne. 0) goto 32 call dskspc (odrIve,frespc) frespc-frespc-1 goto 20 endl f endl f return end

$P AGE

SUBROUTINE verify (Id IIne,entry,Ierror,maxban.youngm) Verify Input data

Implicit Integer (a-z)

reaI coonod,entry,boulow,bouhlg,ftcons,fItstr,youngm

CHARACTER buffer*126,slash*2,space*2,stcons*25,Iine*79,InpfI 1*78,

+ outfI I*78,per Iod*2,grafch*1,tabchr*2,typpar*14,ordin1*8,

+ errmsg*50,IIntyp*16,IInent*30,txtpar*49,messge*80

DIMENSION numpar(14),Itypar(14,8),bouIow(14,8),bouhia(14,8),

+ Itxtpr(14,8),typpar(2),errmsg(9),Iintyp(14),Iinent(14),

+ ordlnI(8),txtpar(40),messge(3),entry(8),youngm(20)

common /coordl/ coonod(2,401) common /slzebw/ malhbw common /filenm/ InpfI I,outfII

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c

C ARRAY INITIALIZATION

C

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DATA numpar /I,1,1,1,1,1,1,3,3,8.7,5,4,3/

DATA ltypar /14*1,9*2,3*1,2,1,9*2,3*1,2,1,10*2,1,3*2,10*2,1,3*2,

+ 10*1,4*2.10*2.4*1,14*2/

DATA boulow /I.,6*0.,7*1.,8*-10E18,0.,3*1..-10E18,1.,8*-10E18,

+ 0..3*1.,2*-10E18,10*0.,1.,0.,2*-10E18,14*0.,10*1.,

+ 4*0.,10*-10E18,4*1.,14*-10E18/

DATA bouhIg /400.,20.,600.,500..60.,100.,300.,7*0..13*10E18,3.,

+ 14* 10E18,14* 10E18,14* 10E18,14* 10E18,14* 10E18,

+ 14*10E18/

DATA typpar /’ - an Integer *,* - a number ’/

DATA errmsg /’UNEXPECTED END OF INPUT FILE.

+

+

+

+

+

+

+

+

D

+

+

+

+

+

+

+

+

+

+

+

+

+

,* INPUT LINE CONTAINS LESS DATA THAN REQUIRED.

,’ENTRY CANNOT BE INTERPRETED AS A NUMBER. .’INCOMPATIBLE TYPE OF NUMERIC ENTRY IN INPUT LINE. .’ENTRY IS OUTSIDE THE PROPER NUMERIC BOUNDS.

,’THE STIFFNESS MATRIX BAND IS TOO WIDE.

,’ELEMENT WITH TWO IDENTICAL NODES.

.’ELEMENT NODES SHARE THE SAME PHYSICAL LOCATION.

,’DUPLICATED SPECIFICATIONS IN INPUT FILE.

DATA llntyp /’model size ,’mode I size ,’mode I size ,’mode I size ,’mode I size ,’mode I size ,’mode I size ,’node ,’mater I a I ,* beam ,’pI ate ,’fastener ,'nodal loading ,*nodaI restraInt

DATA llnent /’

+

+

+

+

+

+

18 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

o o o

+

+

+

+

♦

+

+

DATA ordlnl

+

+

+

+

+

+

+

DATA Itxtpr

+

+

+

+

+

+

+

stcons-*

IIne-'

+

slash-’/ * cal I setstr(2,slash) space-* *

cal I setstr(2,space)

grafch-char(9)

tabchr-' *

cal I setstr(2,tabchr)

cal I movstr(tabchr,1,0,grafch,1,1)

chrerr-0

idparm-1

locatn-1

If (Idllne .eq. 1) linumb-0 10 IInumb-IInumb+1 I error-1

READ (1.20,END-70, ERR-1000) buffer 20 FORMAT (A126)

cal I setstr(126,buffer) ierror-0

ENDSEP-locstr(1.buffer,sI ash)

IF (ENDSEP .eq. 0) goto 10 call endstr (endsep+1.buffer)

25 Itcons-locstr(Iocatn.buffer,tabchr)

If (Itcons .ne. 0) then

call movstr (buffer,Itcons,0,space,1,1) locatn-ltcons+1 goto 25 endl f locatn-1

30 IF (Iocatn .ge. ENDSEP) THEN chrerr-ENDSEP lerror-2 GOTO 70 endl f

seprtr-loc8tr(Iocatn,buffer.space)

IF (seprtr .eq. locatn) THEN locatn-locatn+1 GOTO 30 endl f

IF ((seprtr .eq. 0) .OR. (seprtr .gt. ENDSEP)) seprtr-ENDSEP

lerror-0

decpop-0

EXPFLG-0

EXPSGN-0

seploc-seprtr-locatn do 50 posItn-1.SEPLOC Index-locatn+positn-1 asclic-ascstr(Index,buffer)

IF ffascllc .gt. 47) .AND. (ascllc .It. 58)) goto 40 IF ((posItn .eq. 1) .AND. ((ascllc .eq. 43) .OR.

,'coordinates of node *

,'properties of material code ’

,'properties of beam •

,'properties of plate •

,'properties of fastener '

,'applied loads to node *

,'Imposed displacements to node '/

/'first

.'second '

.'third ,'fourth *

.'fifth ,'sixth .'seventh '

.'eighth '/

/I.2,3.4.5,6.7,8,11.14,22,29.34.38, 0,0,0,0,0,0.0,9,12,15.23.30,35,39, 0,0,0,0,0,0,0,10.13,16.24.31,36,40, 0.0.0,0,0,0,0,0,0,17.25,32,37.0, 0,0,0,0,0,0,0,0,0.18.26,33,0.0, 0,0,0,0.0,0,0,0,0,19,27,0,0,0, 0,0,0,0,0,0,0,0,0,20,28,0.0.0. 0,0,0,0.0.0.0,0,0,21,0,0.0,0/

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 19

IF

! asdic .eq. 45))) goto 40 (asdic .eq. 46) .AND. (decpop .eq. 0)) THEN decpop-Iocatn+posItn-1 GOTO 40 endi f

IF (((asdic .eq. 68) .OR. (asdic .eq. 69)

+ .OR. (asdic .eq. 101)) .AND. (EXPFLG .eq. EXPFLG-Iocatn+posltn GOTO 40 endi f

IF (((asdic .eq. 43) .OR

.OR.

0 ))

(asciic THEN

.eq. 100)

THEN

40

50

60

.AND. (EXPSGN .eq. 0))

EXPSGN-Iocatn+pos1tn if (asdic .gt. 43) expsgn—expsgn GOTO 40 endi f Ierror-3

chrerr-Iocatn+positn-1 goto 60 continue continue continue IF (terror cal I setstr( caI I movstr( ca11 resstr(

(asdic .eq. 45)) .AND. (EXPFLG .ne. 0)

70

.eq. 3) goto (25,stcons)

(stcons,1,1,buffer,locatn,SEPLOC) (stcons)

ftcons-f1tstr(stcons)

IF ((ftcons .It. boulow(ldline,idparm)) .OR. + (ftcons .gt. bouh!g(idlIne,Idparm))) THEN ierror-5 chrerr-locatn GOTO 70 endi f

IF ((Itypar(IdlIne,idparm) .eq. 1) .and.

► (ftcons .ne. float(Int(ftcons)))) then Ierror-4

IF (decpop .ne. 0) THEN chrerr-decpop GOTO 70

ELSE

IF (EXPSGN .It. 0) THEN chrerr—EXPSGN GOTO 70

ELSE

chrerr-locatn GOTO 70 endi f end! f end! f

entry(1dparm)-ftcons If ((Idparm .eq. 1) ,

then

Itcons«INT(ftcons)

CALL CHKDUP (Itcons,I error) IF (terror .ne. 0) THEN Ierror-9 chrerr-locatn goto 70 end I f

and. (IdlIne .gt. 7) .and. (idlIne .It. 14))

e I se

If ((idparm .ea. 2) .and. (idl!ne .eq. itcons»INT(3*entry(1)+ftcons-3) CALL CHKDUP (Itcons,I error)

IF (ierror .ne. 0) THEN ierror-9 chrerr-locatn goto 70 endi f endi f endi f

locatn«seprtr+1 idparm*idparm+1 IF (idparm .gt. if (idline if (idline

14)) then

numpar(idline)) THEN

6) bouhig(ldline+7,1)=entry(1)

It

eq.

?s

then

bouhig(10,2)»entry(1)

20 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

+

+

+

+

+

♦

♦

bouhigf 10,3)«entryM ) bouhlg(l1,2)«entry(1) bouhigf11,3)»entryf1} bouhlgill,4)-entryf1) bouh igi 11,5 Wont ryi 1) bouhig(12,2)-entry(1) bouh I gf 12,3gentryf 1 ) bouh1gi13,1)-entry(1) bouhlg(l4,1)«entry(1) end! f

If (IdlIne .eq. 2) than bouhIg(10,6)«entry(1) bouhigf11,7)«entry(1) and! f

If (((idline .eq. 10) .and. (entry(4} .na. 0.) .and. (youngm(1nt(antry(6))) .na. 0.)) .or.

((fdIIna .aq. 12) .and. (entry(5) .na. 0.))) than

nod1«Int(entry(2n

nod2-int(entry(3))

Ibanwd«3*(1+abs(nod1-nod2))

If (Ibanwd .gt. malhbw) then lerror-6 goto 70

a I sa

If (Ibanwd .aq. 3) then lerror-7 goto 70 end! f endi f

If (IdlIna .aq. 10) than

If (fcoonodfl ,nod1 ) .eq. (coonod(2,nod1) .eq. i error-8 goto 70 end! f endi f

If (Ibanwd .gt. maxban) maxban

coonodf1,nod2}} .and. coonod(2,nod2))) then

'Ibanwd

else

If (fidltne .eq. 11) .and. (entry(6) .na. 0.) .and. (youngm(!nt(entry(7))) .na. 0.)) than maxnod-max(int(entry(2)),int(entry(3)),

Int(entry(4)))

mInnod-min(Int(entry(2)),Int(entry(3)), int(entrv(4)))

If (antry(5) .na. 0.) than

maxnod-maxfmaxnod,intfentryf5}}} mlnnod-mln(mInnod,int(antry(5;); andl f

Ibanwd«3*(1+maxnod-mInnod)

If (Ibanwd .gt. malhbw) then Iarror-6 goto 70 endi f

do 65 itcons-2,4 nodi-int(entry(I toons)) startp-itcons+1 do 65 Index-startp,5 nod2«int(antry(index))

If (nod2 .na. 0) than

if (nodi .aq. nod2) than ierror-7 goto 70

a I se

If (fcoonodfl,nod1 ) .aq. coonodf1,nod2}} .and. (coonod(2,nod1) .eq. coonod(2,nod2))) then ierror-8 goto 70 end! f endi f endi f continue

if (Ibanwd .gt. maxban) maxban-Ibanwd endi f endi f goto 3000

( continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 21

July

ELSE

goto 30 endif

70 txtpar(1)®’number of nodes In the model

txtpar(2)®'number of types of materials In the model txtpar(3)*’number of beams In the model txtpar(4)®'number of plates In the model txtpar(5)«’number of fasteners In the model txtpar(6)®’number of loaded nodes In the model txtpar(7)®'number of restrained displacements In the model txtpar(8)-'node number txtpar(9)®’x coordinate of the node txtparf10)®'y coordinate of the node txtparC11)®'materI a I number txtpar(12)®'Young''s modulus of the material •’PoIsson’’s ratio of the material •'beam number

•'Index of the first node of the beam •'Index of the second node of the beam •'beam area

•'beam moment of inertia •'beam material code

•'distributed load at the first node of the beam •’distributed load at the second node of the beam •’plate number

•’index of the first node of the plate •’index of the second node of the plate txtpar(25)®'Index of the third node of the plate txtpar(26)«’ index of the fourth node of the plate txtpar(27)«*plate thickness txtpar(28)®’plate material code txtpar(29)®’fastener number

txtpar(30)*’Index of the first node of the fastener 1 index of the second node of the fastener ’fastener area ’fastener stiffness Ioaded node number

'applied load at the node along the x direction

txtparC13j txtparC140 txtpar(15J txtpar(16) txtpar(17 J txtpar(18) txtpar(19; txtpar(20) txtpar(21 ; txtpar(22) txtpar(23) txtpar(24)

txtpar(31 txtpar(32) txtpar(33) txtpar(34)®'I ■>)«'<

txtpar(35)

txtpar(36)®'appIied load at the node along the y direction txtpar(37)®'applied moment at the node along the z direction txtpar(38)®* node number with a restrained degree of freedom txtpar(39)®'restrained degree of freedom of the node txtpar(40)®'Imposed displacement at the node write (*,80) errmsg(Ierror)

80 FORMAT (//' ERROR : ’,A50) cal I dlskroom (67)

write (2,80,err*2000) errmsg(I error) messge(1)■’

+ *

messge(2)»'

+ ’

messge(3)®’

+

cal I setstr (240,MESSGE(1)) stcons®'Encountered ’

call movstr (messae(1),1,1,stcons,1,11)

IF (I error .eq. 1) THEN

stcons®* attempting to read *

ELSE

stcons®* In *

endl f

call setstr (25,stcons)

call constr (messge(1),stcons)

call pakstr (messge(l))

stcons®' line ’

call setstr (6,stcons)

call constr (messge(1),stcons)

call pakstr (messge(l))

call constr (messge(l).space)

call wrfstr (float(Iinumb).stcons)

call constr (messge(1),stcons)

call pakstr (messge(l))

stcons** of file ’

call setstr (9,stcons)

call constr (messge(1).stcons)

call constr (messge(1),space)

22 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

cal I setstr (78,InpfiI) caI I pakstr (lnpfiI) call constr (messge(1),inpfI I) period-*. *

caI I setstr (2,period)

call constr (messge(1),period)

call wrltxt (messge)

IF (ierror .eq. 1) goto 3000 grafch«char(218) cal I setstr (79,1ine) call filstr (196,line) call movstr (line,1,0,grafch,1,1) if (chrerr .ne. 0) then grafch-char(25)

call movstr (Iine,chrerr+1,0,grafch,1,1) end! f

length-lenstr (buffer)+2 grafch-char(191)

call movstr (Iine,Iength,0,grafch,1,1) length-length+1 call endstr (length,Iine) cal I resstr (Iine) write (*,90) Iine 90 format (1x,A79) cal I diskroom (82) write (2,90,err-2000) line Iength-length-3 cal I setstr (79,Iine) grafch-char(179)

call movstr (Iine,1,0,grafch,1,1) call movstr (Iine,2,0,buffer,1,length) length=length+2

call movstr (Iine,length,0,grafch,1,1) length-length+1 cal I endstr (length,Iine) cal I resstr (Iine) write (*,90) Iine cal I diskroom (82) write (2,90,err-2000) line grafch-char(192) cal I setstr (79,1ine) cal I filstr (196,1ine) call movstr (line,1,0,grafch,1,1) if (chrerr .ne. 0) then grafch-char(24)

call movstr (Iine,chrerr+1,0,grafch,1,1) end! f

I ength-1enstr (buffer)+2 grafch-char(217)

caI I movstr (IIne,Iength,0,grafch,1,1)

length-length+1

call endstr (Iength,IIne)

caI I resstr (I ine)

wr l te (*,90) Iine

caI I diskroom (82)

write (2,90,err«2000) line

call filstr (32,messge(1))

if (ierror .eq. 6) then

stcons-’ The bandwidth for *

call movstr (messge(1),1,0,stcons,1,18)

call movstr (messgef1),20,0,Iintyp(idline),1,16)

call pakstr (messge(l))

call constr (messge(1),space)

call wrfstr (entry(1),stcons)

call constr (messge(1),stcons)

stcons-' is •

cal I setstr (4,stcons)

call constr (messge(1),stcons)

call constr (messge(1),space)

call wrfstr ifloat(Ibanwd),stcons)

call constr (messge(1),stcons)

stcons-’ and exceeds the maximum '

call setstr (25,stcons)

call constr (messge(1),stcons)

stcons-’ allowed bandwidth of '

cal 1

setstr

cal 1

constr

cal 1

constr

cal 1

wrfstr

ca 1 1

constr

cal 1

constr

cal 1

writxt

goto

3000

jfl).stcons) j(1).space)

1 22,stcons) messgeM*

messge(1,_,

floot(malhbw).stcons) messge(1),stcons) messge(1).perlod) messge)

endif If (lerror .eq. 7) stcons-* There

ca I cal

stcons«*s In

then

are Identical

node’

cal cal cal cal ca I cal ca I ca I ca I ca I ca I cal goto

end I f

If (lerror stcons

movstr (messge(1),1,0,stcons.1,25) pakstr (messge(l))

setstr constr constr setstr constr resstr pakstr constr wr f str constr constr wrItxt 3000

(5,stcons (messgefl (messge(1

.stcons)

_ „ r ,space)

16,Ilntyo(IdlIne)) messge(l),I Intyp(Idline)) ‘Intypfldline)) messgeM )) messge(1),space) entry(1).stcons)

(messgeM (messge(1 (messge)

!:

stcons)

period)

eq. 8) then

Nodes

ca I I ca I I cal I cal I cal I

movstr pakstr constr wr fstr constr stcons-* and cal I setstr constr constr wrfstr constr stcons-* of cal I setstr constr setstr constr resstr pakstr constr wr fstr constr

,1,0,stcons,1,6) .space)

cal I cal I ca I I ca I I

messge messge

messge % „ _ r _„

float(nod1).stcons) messge(1).stcons)

[5,stcons)

( messgef1'

'messge(1, floot(nod2).stcons) [messge(l).stcons)

sM) .stcons) 5(1) .space)

cal I cal I ca I I ca I I ca I I cal I ca I I cal I

5,stcons) messge(l).stcons)

16.Iintyp(idlIne)) messge(l),Ilntyp(Id IIne)) Iintyp(idline))

Jmessge(1 [messge

w.

space)

fentry(1).stcons) (messge(1).stcons) stcons-* have the same coordinat

caI I setstr cal I constr stcons-*es. caI I setstr constr wrItxt 3000

cal I cal I goto end! f

(25.stcons) (messge(1).stcons)

f4,stcons) (messge(1).stcons) (messge)

if (lerror .eq. 9) then

stcons-* The *

cal I movstr fmessgef1),1,0,stcons,1,5)

call pakstr (messge(l))

call constr (messge(1),space)

call setstr (30,Iinent(idline))

cal I constr (messgeM), I inent (Idl ine))

call resstr (Ilnent(Idline))

call pakstr (messgeM))

call constr (messge(1),space)

call wrfstr (entry(1).stcons)

call constr (messge(1),stcons)

stcons-* appear twice. *

call setstr (15,stcons)

call constr (messge(1),stcons)

24 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

call wrItxt (messge) goto 3000 end i f

stcons** Reading •

call movstr (messge(l),1,0,stcons,1,8)

If (Idparm .eq. 1) then

call movstr (messge(1),10,0,Iintyp(idIine),1,16)

call pakstr (messge(l))

stcons-' I Ines *

cal I setstr (7,stcons}

call constr (messge(1),stcons)

e I se

call movstr (messge(1),10,0,Iinent(idIine),1,30) call pakstr (messge(l)) call constr (messge(1).space} call wrfstr (entry(1),stcons) call constr (messge(1),stcons) endlf

stcons-’ It was expected to find ’

cal I setstr(25,stcons)

call constr(messge(1),stcons)

If ((Idparm .eq. 1) .and. (idllne .gt. 7)) then stcons-’ a ’

e I se

stcons-' the *

endl f

call setstr (5,stcons) call constr (messge(1 ), stcons) call pakstr (messge(l)) call constr (messge(1),space)

Index*Itxtpr(id Iine,Idparm)

call setstr (49,txtpar(index))

cal I constr (messge(l),txtpar(index))

call resstr (txtpar(index))

call pakstr (messge(l))

index-ItyparildlIne,idparm)

call setstr (14,typpar(Index))

cal I constr (messgeM),typpar(index))

call resstr (typpar(index))

call pakstr (messge(l))

stcons-’ between ’

call setstr fl0,stcons)

call constr (messgeM),stcons)

call wrfstr (boulowfldline,idparm),stcons)

call constr (messge(1),stcons)

stcons-’ and ’

call setstr (6,stcons)

call constr (messgefl),stcons)

call wrfstr (bouhigCidlIne,idparm),stcons)

call constr (messge(1),stcons)

stcons-' - as the ’

cal I setstr (11,stcons)

call constr Cmessge(1),stcons)

call setstr (8,ordInI(Idparm))

call constr (messgefl),ordinI(Idparm))

call resstr (ordlnICIdparm))

call pakstr (messge(l))

stcons-’ entry. ’

call setstr (8,stcons^

call constr (messge(1),stcons)

call wrltxt (messge)

goto 3000

1000 write (*,1010)

1010 format (//’ ERROR : CANNOT READ INPUT FILE.’/

+ ' The program cannot continue.’)

ierror—1 goto 3000

2000 write (*,2010)

2010 format (//’ ERROR : CANNOT WRITE OUTPUT FILE.’/

+ ' The program cannot continue.’)

Ierror—1

3000 return end

$PAGE

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 25

SUBROUTINE wrltxt (messge)

C

C Write text on the screen formatting to avoid breaking words C

IMPLICIT INTEGER (a-z)

CHARACTER messge*80,I 1ne*79,endwrd*3,space*2 DIMENSION messge(3)

Ilne«*

+

cal I setstr (79,1Ine) endwrd-*

call setstr (3,endwrd) space-' *

call setstr (2,space) call expstr (messge(l)) startp-1

endtxt-locstr (1,messge(1),endwrd)

110 Index«startp+79

IF (ENDTXT .ge. Index) THEN spcpos-startp-1 120 nxtspc-spcpos+1

Iength-Iocstr (nxtspc.messge(1),space)

IF (length .It. index) THEN spcpos-Iength GOTO 120 end! f

Iength-spcpos-startp

cal I movstr (IIne,1,1,messge(1).startp,length) call resstr (line) write (*,90) IIne 90 format (1x,A79)

cal I dlskroom (82) write (2,90,err-2000j line cal I setstr (79,1ine) startp-spcpos+1 GOTO 110 end I f

endtxt-endtxt-1

call movstr (I Ine,1,1,messge(1),startp.ENDTXT)

cal I resstr (IIne)

wr Ite (*,90) IIne

caI I dlskroom (82)

write (2,90,err«2000) line

goto 3000

2000 write (*,2010)

2010 format (//* ERROR : CANNOT WRITE OUTPUT FILE.*/

+ * The program cannot continue.*)

ierror—1 3000 return end

$PAGE

FUNCTION degree (oppsid,cI osid)

C

C Determine angle in degrees with opposite and next side of triangle. C

IF (abs(closid) .gt. 1e-19) THEN

degree-57.2957795*ATAN(oppsId/cI osid)

IF (closid .LT. 0.) degree-degree+180.

IF (degree .gt. 180.) degree-degree-360.

ELSE

IF (oppsid .ge. 0.) then degree-90.

e I se

degree—90. end! f ENDIF RETURN END

$PAGE

SUBROUTINE datstr(strIng)

C

C Write the date in a string.

C

IMPLICIT Integer (a-z)

CHARACTER string*11,blank*2,buffer*10 call date (day.month.year) write (buffer,10) month,day.year

26 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

10 FORMAT (!2,7\I2.7\I4)

READ (buffer,20) string 20 format (a10)

cal I setstr (11.string) asciic«ascstr(4,string)

if (ascitc .eq. 32) call modstr (string.4,48)

RETURN

END

$PAGE

SUBROUTINE timstr(string)

C

C Write the time-of-day in a string.

C

IMPLICIT integer (a-z) real realsc

CHARACTER string*12,bIank*2,buffer*11 call time (hour.minute,second,sec100) reaI sc-fI oat(second)+fI oat(sec100)/100. write (buffer,10) hour,minute,reaI sc 10 FORMAT (12,* s *,12,*:*,f5.2)

READ (buffer,20) string 20 format (all)

caI I setstr (12,string} asc1ic«ascstr(4,string)

if (asclic .ea. 32) call modstr (string,4,48) asciic*ascstr(7,strIng) if (asdic .eq. 32) then

call modstr (string,7,48) asciic«ascstr(8,string)

if (asciic .eq. 32) call modstr (string,8,48) endi f RETURN END

$PAGE

FUNCTION fltstr (string)

C

C Calculate the floating point value of a string.

C

CHARACTER buffer*26,strIng*25 write (buffer,*) string READ (buffer,10,ERR-300) intstr 10 format (bn,125)

fltstr«float(intstr) goto 500 300 fltstr-0

READ (buffer,310,ERR-500) fltstr 310 format (bn,f25.0)

500 RETURN END

$PAGE

SUBROUTINE wrfstr (reaI,string)

C

C Write a real in a string.

C

implidt integer (a-z) real real

CHARACTER string*25,expnnt*5 if (real .eq. 0.) then

strlng«'0 •

call setstr (25,string) cal I endstr (2,string)

e I se

If ((abs(real) .ge. 1.e11) .or. (abs(real) .It. l.e-5)) then write (string,10) real 10 format (E12.6E2)

cal I setstr (25,string) call pakstr (string) expnnt-'E

call setstr (5,expnnt}

cal I endstr (2,expnnt)

l-locstr (1,string.expnnt)

cal I movstr (expnnt,1,1,string,I,4)

30 1-1-1

if (ascstr(I,strIng) .eq. 48) goto 30 cal I movstr (string,1 + 1,1.expnnt,1,4)

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 27

July

e I se

write (string,40) real 40 format (F19.10)

call setstr (25,string) cal I pakstr (string) l-lenstr (strlng)+1 50 1-1-1

If (ascstr(I,8tring) .eq. 48) goto 50 if (ascstr(I,strIng) .eq. 46) 1-1-1 call endstr (1+1,string) endif endif RETURN END

safe2soI.for

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

$LINESIZE: 132 SPAGESIZE: 61 SSTORAGE: 2

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c

c MICROSAFE

C Structural Analysis by Finite Elements

C Module : SAFESOLV, 1st Part

C Version : 2-D

C

C COPYRIGHT (C) by MICROSTRESS Corporation - 1985,1986

C ALL RIGHTS RESERVED

C

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC PROGRAM safesolv

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C c

c TYPE SPECIFICATION C

c c

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

INTEGER ppmuqq.ofnfIg.echfIg,serf Ig.ascstr,long I*4,longj*4,

+ longk*4,long I*4,ddrIve.odrive,prevld,memava*4,numeIe*4

DOUBLE PRECISION Invqcn,stmtrx,stmqcn,disdof,beamcf,ftcons,pthIck, + eyoung.pratio,diffnc,blngth,bmlcos,bmlsIn,appldf,

+ ratlo.sttemp,th

CHARACTER InpfI I*78,outfI I*78,toufiI*78,txtdisp*24,comand*127,

+ space*2,string*5,datext*11,timtxt*12,intgst*25,dash*1,

+ prompt*56,diamsg*110,reacIb*8,arrow*1,elipss*4,

+ bIank*1,IfdrIv*6,Ifpath*64,ifname*9,ifextn*5,fIspec*78,

+ ofdriv*6,ofpath*64,ofname*9,ofextn*5,toextn*5

LOGICAL ffound

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C c

ARRAY DIMENSIONING C

c c

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

DIMENSION lnvqcn(2,2),ftconsf9),diffnc(2,4),txtdisp(3),plints(3), box la I(600).bshear(2,600),bmomnt(2,600),inp(3).entry(8), sttemp(8,2),reacIb(3),youngm(20),poisson(20),

Ienhbw(l200),nodst3(400),igndof(1200),beamcf(3,3), mxndIf(400),nodebm(2,600),bmarea(600),bmlner(600), matcbm(600),bmdisl(600),bmdis2(600),pIteth(500), matepI(500),nodefs(2,60),fsarea(60),fsstif(60).

nodepl(4,500)

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

COMMON SPECIFICATION

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

COMMON /global/ numdof,8tmqcn(2,2) common /si 2 «bw/ malhbw

COMMON /plates/ disdof(1203),pIteef(2,4),pIstrs(3,500).

+ reafor( 3 ,400),pstnor(3,400),pstacc(3,400)

28 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

I uly

COMMON

common

common

COMMON

common

/qqqqqq/ /filenm/ /forces/ /dskrom/ /coord1/

stmtrx(8200) inpfiI,out f i I appldf(1200) serf Ig,odrive coonod(2,401)

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c

c

c

USER DEFINED FUNCTIONS

C

C

C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

previd(k,I)-M0D(k+l-2,I)+1 nexti d(k,I)=MOD(k, I )+1

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c

C GENERAL INITIALIZATION C

C C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

call time (inithr,initmn,initsc,Iniths) caI I datstr (datext)

C

C

C

C

C

C

call timstr (timtxt)

Show copyright notice on the screen.

cal I logpsI InitialIze variabIes.

serf Ig-0 maxban=6 8 tmqcn(1,1)«0. stmqcnM ,2}=0. stmqcnf2,1)«0. stmqcn(2,2)«0. space-’ *

cal I setstr (2,space)

toextn-*.OUT ’

call setstr (5,toextn)

eIlpss-*... *

cal I setstr (4,elipss}

call defdrv (0,ddrive)

C

C

C

Determine number of stiffness matrix elements which will fit in RAM.

name Ie-memava(stmtrx(1))/4 if (numele . gt. 65535) numele-65535

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c c

C READ THE COMMAND TAIL C

C C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

1 error-ppmuqq

Iength-ascstr if (length .ne. caI I setstr caI I endstr caI I movstr caI I upcstr string-’ IcaI I setstr

S 0 ,0,comand) 1 ,comand)+2

2 ) then '127,comand)

Iength,comand)

'comand,1,0,space,1,1) ’comand)

(4,«trIng)

locatn-locstr (1,comand,string)+3 If (locatn .ne. 3) then

nxtloc-locstr (Iocatn,comand,space) If (nxtloc .eq. 0) nxtloc-length numchr-nxtloc-locatn inpfII-’

cal I setstr f78,inpfiI)

caI I movstr (inpfI I,1,0,comand,locatn.numchr) cal I resstr (Inpf11) ifnflg-1 endi f

call modstr (string,2,79) locatn-locstr (1.comand,string)+3 if (locatn .ne. 3) then

nxtloc-locstr (Iocatn,comand,spaced

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 29

o o o

J uly

If (nxtloc .eq. 0) nxtloc«length numchr-nxtloc-locatn outfII-'

+ *

cal I setstr (78,outf1I)

call movstr (outfI I,1,0,comand,locatn,numchr) cal I resstr (outfI1 ) ofnfIg-1 endi f

string-* E

cal I setstr (3,string) locatn-locstr (1,comand,string)

If (locatn .ne. 0) echflg-1 call modstr (strIng,2,83) locatn-locstr (1,comand,strIng) if (locatn .ne. 0) scrflg=1 endi f

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

SET INPUT AND OUTPUT FILES

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

65 if (ifnflg .eq. 0) then WRITE (*,70)

70 FORMAT (' Input data file name [.INP]? ’\)

READ (*,*(A)*) inpfil

e I se

WRITE (*,72) inpfil

72 FORMAT (' Input data file name [.INP]: \a78) endi f

fIspec-inpfi I

call parsfn (fI spec,ddrIve,lfdr Iv,idr Ive,Ifpath,ifname,ifextn)

Inpf1l-fI spec

if (Ienstr(Ifextn) .eq. 0) then Ifextn-'.INP ' caI I setstr (5,ifextn) call constr (InpfiI,ifextn) endi f

cal I resstr (inpf11)

inquire (FILE-inpfiI,EXIST«ffound)

If (ffound) then

OPEN (1,FILE-inpfII)

e I se

cal I setstr (78,InpfiI)

caI I pakstr (InpfI I)

length-lenstr (inpfiI)

cal I expstr (inpfiI )

cal I resstr (inpfiI)

call wrfstr (float(length),intgst)

length-lenstr (intgst)

prompt-'('' ERROR : File '"',a ,'cannot be found. Try agai

+n.'') ’

call setstr (56,prompt) call movstr (prompt,21,0,Intgst,1,Iength) write (*,prompt) inpfil ifnfIg=0 goto 65 ENDIF

74 toufil-InpfiI

cal I setstr (78,touf11)

locatn-locstr (1,toufI I,Ifextn)

call movstr (toufiI,locatn,1,toextn,1,4)

length-lenstr (toufil)

caI I expstr (toufI I)

caI I resstr (touf11 )

call wrfstr (float(length),Intgst)

length-lenstr (intgst)

prompt-'(*' Output data file name [”,a '*,a78 )

+ •

call setstr (56,prompt)

call movstr (prompt,30,0,intgst,1,length)

if (ofnflg .eq. 0) then

call modstr (prompt,35,63)

string='\ '

cal I setstr (5,string)

call movstr (prompt,38,0,string,1,4)

30 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

o o o

July

ca I I resstr (prompt)

WRITE (*,prompt) toufil READ (*.’(A)’) outfI I

e I se

cal I resstr (prompt)

WRITE (*,prompt) toufiI,outfiI end! f

fIspec«outfi I

call parsfn (fI spec,idrive-1,ofdr1v,odr!ve,ofpath,ofname,ofextn) outfil*fI spec

IF (Ienstr(ofdr!v) .le. 2) then cal I setstr (78,outf!I)

( 1 .< .

cal I endstr (1,outf11) If ( I enstr(ofdriv) .eq (Ienstr(ofpath) .eq (I enstr(ofname) .eq ' Ienstr(ofextn) .eq

constr constr constr constr

0 )

8

0 )

(outfiI,ofdriv] outfiI,ofpath) outfiI,ofname) outf!I,ofextn)

of dr i v* of path* of name= of extns

Ifdriv ifpath \fname toextn

if If If

cal I cal I cal I ca I I endi f

cal I resstr (outfI I) caI I opnfII (Ierror) if (lerror ,ne. 0) then ofnfIg=0 goto 74 end! f

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c c

C START THE OUTPUT FILE C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

caI I diskroom (0)

C

c

c

Header title

caI I diskroom (331)

WRITE (2,80,err«2000) datext,timtxt,inpfiI,outfiI

80 FORMAT ('MICROSAFE - STRUCTURAL ANALYSIS BY FINITE EL*.

+ 'EMENTS\4x,’Version: SAFESOLV (2-D)',2x,’ReI. 1.0’,3x,a10 f 1x,a8// +/* Input data file : ’,A/* Output data file : ',A/) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c c

C START READING THE INPUT FILE C

C C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

diamsg=*Reading model data from file

+

cal 1

setstr (

[110,diamsg)

cal 1

setstr <

[78,InpfI 1)

cal 1

movstr 1

^diamsg,30,0,inpfi1,1,77)

ca 1 1

resstr 1

[inpfi1)

ca 1 1

pakstr (

fdiamsg)

ca 1 1

constr 1

[diamsg,elIpss)

ca 1 1

expstr <

f diamsg)

ca 1 1

resstr 1

[dIamsg)

cal 1

resstr 1

[ofdr Iv)

it ^orariv .eq. ’CON: j sen ig—i

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c

C READ AND PROCESS THE MODEL SIZE LINES C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c

Size header

If (echflg .eq. 1) then

If (scrflg .eq. 1) then WRITE (*,85)

85 FORMAT (/’ SIZE OF THE STRUCTURE’/)

e I se

If (scrflg .eq. 0) write (*,87) diamsg 87 format (/IX,A/’ Slze...’\)

end! f

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 31

ooo ooo ooo ooo ooo

July

ca I I dlskroom (30)

WRITE (2,85,err«2000)

• I se

write (*,87) dlomsg end i f

Number of nodes and degrees of freedom

CALL verlf y(1.entry,I error.maxban.youngm)

IF (lerror .NE. 0) GOTO 994 nnodes«entry(1)

If (echflg .eq. 1) then

If (serf Ig .eq. 1) WRITE (*,90) nnodes 90 FORMAT (* Number of nodes :*,I4)

caI I diskroom (48)

WRITE (2,90,err-2000) nnodes endlf

DO 92 loop-1.nnodes DO 92 Indx-1,3 reaforfindx,loop)«0. pstnorflndx,loop)»0.

92 pstacc(indx,loop)=0. numdof«3*nnodes DO 94 loop-1.numdof 94 appIdf(Ioop)«0.

maIhbw-numeIe/numdof-2 If (malhbw .gt. numdof) maIhbw-numdof longj-numdof*(maIhbw+2) do 96 long 1-1,long]

96 stmtrx(longl)-0.

Number of types of material

CALL verIfy(2,entry,lerror.maxban.youngm)

IF (lerror .NE. 0) GOTO 994 nmater-entry(1)

If (echflg .eq. 1) then

If (scrflg .eq. 1) WRITE (*,98) nmater 98 FORMAT (* Number of materials :*,I4)

cal I dlskroom (48)

WRITE (2,98,err-2000) nmater endlf

Number of beams

CALL verlfy(3,entry,lerror.maxban.youngm)

IF (lerror .NE. 0) GOTO 994 nbeams-entry(1) if (echflg .eq. 1) then

if (scrflg .eq. 1) WRITE (*,100) nbeams 100 FORMAT (' Number of beams :',I4)

call dIskroom (48)

WRITE (2,100,err-2000) nbeams endlf

Number of plates

CALL ver1fy(4,entry,I error.maxban.youngm)

IF (lerror .NE. 0) GOTO 994 nplate-entry(l)

If (echflg .eq. 1) then

if (scrflg .eq. 1) WRITE (*.105) nplate 105 FORMAT (’ Number of plates :*,I4)

caI I dlskroom (48)

WRITE (2,105,err«2000) nplate endlf

DO 107 loop-1.nplate DO 107 indx-1,3 107 plstr8(Indx,loop)-0.

Number of fasteners

CALL verIfy(5,entry,ierror.maxban.youngm)

IF (lerror .NE. 0) GOTO 994 nfastn«entry(1)

If (echflg .eq. 1) then

32 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

if (scrflg .eq. 1) WRITE (*,110) nfastn 110 FORMAT (’ Number of fasteners :’,I4)

call diskroom (48)

WRITE (2,110, er r*=2000) nfastn endi f

C

C Number of loaded nodes C

CALL verify(6,entry,ierror,maxban,youngm)

IF (Ierror .NE. 0) GOTO 994 n lnods=entry(1) if (echflg .eq. 1) then

If (scrflg .eq. 1) WRITE (*,115) nlnods 115 FORMAT (’ Number of loaded nodes :’,I4)

cal I dlskroom (48)

WRITE (2,115,err=2000) nlnods end i f

C

C Number of restrained degrees of freedom C

CALL verIfy(7,entry,Ierror,maxban,youngm)

IF (Ierror .NE. 0) GOTO 994 nresdf«entry(1)

If (echflg .eq. 1) then

if (scrflg .eq. 1) WRITE (*,120) nresdf 120 FORMAT (’ Number of restrained degrees of freedom :’,I4) caI I diskroom (48)

WRITE (2,120,err*2000) nresdf endlf

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c

C READ AND PROCESS THE NODE COORDINATES LINES C

C C

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c

C Coordinates of the nodes C

if (echflg .eq. 1) then

If (scrflg .eq. 1) then WRITE (*,125)

125 FORMAT (//* NODE COORDINATES '//' Node Coordinate X

+ ’Coordinate Y'/)

e I se

if (scrflg .eq. 0) write (*,130)

130 format (’Nodes ...’\)

endif

caI I diskroom (68)

WRITE (2,125,err*2000)

e I se

write (*,130) endif

call chkdup (0,ierror)

DO 160 loop»1,nnodes

CALL verify(8,entry,ierror,maxban,youngm)

IF (ierror .NE. 0) GOTO 994 i-entry(l)

coonodM , i )*entry(2) coonod(2,i)«entry(3) if (echflg .eq. 1) then

if (scrflg .eq. 1) WRITE (*,150) i,entry(2),entry(3)

150 FORMAT (I5,3X,F12.5.3X,F12.5) call diskroom (37)

WRITE (2,150,err®2000) I,entry(2),entry(3) endi f

160 CONTINUE

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c

C READ AND PROCESS THE MATERIAL PROPERTIES LINES C

C C

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c

C Material properties C

If (nmater .gt. 0) then

If (echflg .eq. 1) then

If (scrflg .eq. 1) then

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 33

170

175

180

190

endlf

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c READ AND PROCESS THE BEAM LINES

c

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

write (*,170)

FORMAT (//’ MATERIAL PROPERTIES’// 1 Code Young’, e|8 ^ IH’.'s modulus’,’ Poisson’,1H’,’s ratio’/)

It (serfIg .eq. 0) write (*,175) format (’Mater I a Is...’\) endlf

cal I dlskroom (78)

WRITE (2,170,err«2000)

e I se

write (*,175) endlf

call chkdup (0,lerror)

DO 190 Ioop«1,nmater

CALL verlfy(9,entry,lerror,maxban,youngm)

IF (lerror ,NE. 0) GOTO 994

I-entry(l)

youngm(I)*entry(2)

poIsson(I)«entry(3)

if (echflg .eq. 1) then

1 ..

call dIskroom (39)

WRITE (2.180.err-2000) I,entry(2),entry(3) endlf J

CONTINUE

Beams IF

200

+

+

Beam I j M. Inertia’, Distributed Loads

7 )

205

(nbeams .gt. 0) then If (echflg .eq. 1) then

If (scrflg .eq. 1) then write (*,200)

FORMAT (//’ BEAM DATA’//’

’Length Area

’ Material

e I se

If (scrflg .eq. 0) write (*,205) format (’Beams...’\) endlf

cal I dlskroom (114)

WRITE (2,200,err=2000)

else

write (*,205) endlf

cal I chkdup (0,ierror)

DO 220,loop=1,nbeams

CALL verify(10,entry,ierror,maxban,youngm)

IF (ierror .NE. 0) GOTO 994 i«entry(1) n1=entry(2) n2=*entry(3) mat«entry(6) bmarea( i )*=entry(4) matcbm(I)*mat eyoung=youngm(mat) if ((entryf4) .ne. nodebm(1,i)«n1 nodebmf2,i)=n2 bminer(i)=entry(5) bmdlsl(I)=entry(7) bmdis2fI)=entry(8) mxndlf(nl)*MAX(n1,n2,mxndif(nl)) mxndif(n2)«MAX(n1,n2,mxndif(n2)) endlf

diffncfl, 2 ^*coonodf 1 ,n 2 )-coonod( 1 ,n 1 ) diffnc( 2 , 2 )«coonod( 2 ,n 2 )-coonod( 2 ,nl)

ff n ?iJhf l5 R !^ if 1) C tll;n ) * diffnC 1,2)+diffnC(2,2) * diffnc(2 ’ 2))

if (scrflg'.eq. 1) WRITE (*.210) I,n1,n2.b1ngth,entry(4),

0 .) .and. (eyoung .ne. 0.)) then

34 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

o o o

ooooooo

I uly

+ entry(5),mat,entry(7),entry(8)

210 FORMAT (I5,2I6.F12.3,F10.4,F14.5,5X,I3,5X,2F12.3)

cal I diskroom (92)

WRITE (2,210,err*2000) I,n1,n2,bI noth,entry(4),entry(5), + mat,entry(7),entry(8)

endif

If ((entry(4) .ne. 0.) .and. (eyoung .ne. 0.)) then bmlcos*diffnc(1,2)/blngth bmlsln=dlffnc(2,2j/bIngth IF (entry(5) .NE. 0.) THEN nodst3(n1)*1 nodst3(n2)*1 ENDIF I3*3*n1 12*13-1 11*12-1 J3«3*n2 J2*J3-1 J1-J2-1

IF ((entry(7) .NE. 0.) .OR. (entry(8) .NE. 0.)) THEN ftcons(1)»entry(7)*blngth/6 ftcons(2)»entry(8)*bIngth/6 ftcons(3)=ftcons(1)*bIngth/30 ftcons(4)*ftcons(2)*bIngth/30

appIdf(I1)*appIdf f11)-bmIsIn*(2*ftcons(1)+ftcons(2)) appldf (I2)*appldf c I2Wbml cos*(2*f tcons(1 )+ftcons(2)) appIdf(I3)*appIdf(I3)+8*ftcons(3)+7*ftcons(4) appIdf fj1)*appIdf(j1)-bmIsIn*(ftcons(1}+2*ftcons(2)) appIdf(j2)*appIdf(j2)+bmIcos*(ftcons(1)+2*ftcons(2)) appldf(J3)*appIdf(J3)-7*ftcons(3)-8*ftcons(4)

ENDIF

ftconsfl}»2*eyouna*entry(5)/bIngth ftcons(2)*entry(4)*eyoung/bIngth ftcons(3}*bmlsin/blngth ftcons(4;*bmlcos/bIngth

ftcons(5)*6*ftcons(1 )*ftcons(3)*ftcons(3)+

+ bmlcos*bmIcos*ftcons(2)

ftcons(6)*6*ftcon8(1)*ftcons(3)*ftcons(4)+ bmlcos*bmlsin*ftcons(2)

ftcons(7)*6*ftcons(1)*ftcons(4)*ftcons(4)+

+ bmlsln*bmlsin*ftcons(2)

ftcons(8}*-3*ftcons(1}*ftcons(3} ftcons(9)*-3*ftcons(1)*ftcons(4)

CALL assemble (l 1,11,ftcons(5),-ftcons(6},ftconsf8))

CALL assemble (II,j1,-ftcons(5),ftcons(6),ftcons(8);

CALL assemble (12,12,ftcons(7},-ftcons(9},0.)

CALL assemble (12,jl,ftcons(6),-ftcons(7),-ftcons(9)) CALL assemble (13,13,ftcons(1)*2,0.,0.)

CALL assemble (13,j1,-ftcons(8),ftcons(9),ftcons(1))

CALL assemble (j1,j1,ftcons(5),-ftcons(6),-ftcons(8)) CALL assemble (J2,j2,ftcons(7),ftcons(9),0.)

CALL assemble (j3,j3,ftcons(1)*2,0.,0.)

e I se

If (scrfig .ge. 0) write (*,215) I 215 FORMAT (/* WARNING : The beam*,14,

+ • has been disconnected from the model.*/)

caI I dlskroom (69)

WRITE (2,215,err«2000) I

If ((echflg .eq. 0) .or. (scrfig .eq. 0)) wrlte(*,217) 217 format (* *\)

endl f

220 CONTINUE endif

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c

READ AND PROCESS THE PLATE LINES C

C

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

Plates

IF (nplate .gt. 0) then

If (echflg .eq. 1) then

If (scrfig .eq. 1) then

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 35

240

245

250

260

270

280

write (*,240)

FORMAT (//• PLATE DATA*//' Plate I

* L Thickness Material*/)

e I se

if (scrflg .eq. 0) write (*,245) format (’Plates...*\) endl f

cal I diskroom (78)

WRITE (2,240,err-2000)

e I se

write (*,245) endl f

call chkdup (0,lerror)

DO 360,loop«1,npI ate

CALL verIfy(11,entry,lerror,maxban,youngm)

IF (lerror .NE. 0) GOTO 994 I«entry(1) n1«entry(2 n2»entry(3 n3=entry(4 n4«entry(5, pthIck*entry(6) mat«entry(7)

If (echflg .eq. 1) then

If (scrflg .eq. 1) WRITE FORMAT (15,416,F11.5.5X.I3) call diskroom (50)

WRITE (2,250.err«2000) I,N1,n2,N3,N4,pthick,mat endl f

*entry(6)

=mat

eyoung*youngm(mat)

If ((pthlck .ne. 0.) .and. (eyoung .ne. 0.)) then pratio«poisson(mat) lndx«MAX(n1,n2,n3,n4)

K*.

(*,250) I,N1,n2,N3,N4,pthick,mat

pltethfl)matcp1(1)*

,lndx)

,Indx)

,Indx)

=MAX(mxndIf(N4),Indx) ■coonod(1,N1J ■coonod(2,N1'

■coonod(1,N2 j l-coonod(2,N2)

)»coonod(

>-coonod|

[1.N3)

)»coonod|

k2.Ni )

>-coonodl

:2.N3)

)«coonod(1,N4)-coonodl

;i.N3)

j-coonodl

2.N4

)-coonod|

;2.N3)

)=coonodl

Ji.ni;

)-coonod|

(1.N4)

T7

o

c

o

o

o

N

;2 ,ni;

)-coonod|

(2.N4)

mxndlf(n1)«MAX(mxndlf mxndlf (n2)*MAX(mxndlf mxndlf(n3)«MAX(mxndlf IF (n4 .GT. 0) mxndlf diffnc(1 ,2)«coonod(1 ,N2 diffnc(2,2)*coonod(2,N2 dIf fnc(1,3)«coonod(1,N3 diffnc(2,3)*coonod(2,N3 IF (N4 .EQ. 0) THEN dlffnc(1,1] dIf fnc(2,

ELSE

diffnc( dlffnc( dlffnc( dlffnc(2,1]

ENDIF INDX-1

IF (dlffnc(1,2)*diffnc(2,3) .GT. diffnc(2,2)*diffnc(1,3)) INDX-INDX+4 IF (N4 .EQ. 0) THEN

IF (INDX .EQ. 1) THEN n-n2 n2»n3 n3*n ENDIF

Table captionELSE

.GT.

)) INDX=INDX+2 .GT.

INDX=INDX+1

GOTO (260,270,280,300,310,280,300,320) indx n«n2 n2«n4 n4*n

GOTO 320 n«n2 n2«n3 n3=n

GOTO 320 WRITE (*.290) I

IF (diffnc("

1.31

l*d i f f nc|

[2A)

+

diffnc(J

2.3!

l*di f fncl

il.4)

IF (diffncT

1.4

!*di f fncl

;2.n

+

diffnc(J

2.4)

l*diffncl

1.1

36 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

July

290 FORMAT (* ERROR : ILLEGAL NODE DECLARATION FOR *,

+ •PLATE*,14,*.*)

call diskroom (50)

WRITE (2,290,err«2000) i goto 994

300 n-n2

n2»n3 n3«n4 n4*n

GOTO 320

310 n»n3

n3-n4 n4=n

320 CONTINUE

ENDIF

nodep1(1,1)-N1 nodep1(2,1)=N2 nodep1(3,1)=N3 nodepl(4,I)«N4 IF (N4 .EQ. 0) THEN

CALL trlasemb (N1,N2,N3,pthIck,eyoung,pratio)

ELSE

coonod(1, nnodes+1)-(coonod(1,N1)+coonod(1,N2)+

+ coonodM,N3)+coonod(1,N4))/4

coonod(2,nnodes+1)«(coonod(2,N1)+coonod(2,N2)+

+ coonod(2,N3)+coonod(2,N4))/4

CALL trlasemb (N1,N2,nnodes+1.pthick,eyoung,pratio)

CALL trlasemb (N2,N3,nnodes+1,pthick,eyoung,pratio)

CALL trlasemb (N3,N4,nnodes+1,pthlck,eyoung,pratio)

CALL trlasemb (N4,N1,nnodes+1,pthick,eyoung,pratio) ftcons(1)«stmqcn(1,1)*stmqcn(2,2)+ stmqcn(1,2)*stmqcn(2,1)

InvqcnM,1)-stmqcn(2,2)/ftcons(1) lnvqcn(2,2J*stmqcn(1,1)/ftcons(1) lnvqcn(1,2)—stmqcn(1,2)/ftcons(1) lnvqcn(2,1)«invqcn(1,2)

DO 330 NI-1,4 DO 330 MI-1,2 n-(nodepI(NI,l)-1)*3+MI DO 330 NJ-NI,4 IF (NJ .EQ. NI) THEN MK-MI

ELSE

MK-1

ENDIF

DO 330 m J «MK,2 J-(nodepI(NJ,1)-1)*3+MJ k-minfn,J) l-max(n,J)-k+1 longk-(malhbw+2)*(k-1)+l do 332 m-1,2

longl-fmalhbw+2)*(n-1)+malhbw+m ftcon8(2)«0. do 331 mm-1,2

longj-(maIhbw+2)*(1-1)+maIhbw+mm

331 ftcons(2)«ftcons(2)+stmtrx(longj)*lnvqcn(m,mm)

332 stmtrx(longk)«stmtrx(longk)-ftcons(2)*stmtrx(longi)

330 CONTINUE

DO 350 NI-1,2 DO 340 M-1,4 DO 340 MI-1,2

longl-TmaIhbw+2)*((nodepI(M,i)-1)+3+MI)+ni-2 stmtrx(longi)«0.

340 CONTINUE

DO 345 MI-1,2

345 «tmqcn(ml,ni)-0.

350 CONTINUE

ENDIF

e I se

if (scrflg .ge. 0) write (*,355) 1 355 FORMAT (/* WARNING : The pi ate*,14,

+ * has been disconnected from the model.’/)

caI I dlskroom (70)

WRITE (2,355,err-2000) I

If ((echflg .eq. 0) .or. (scrflg .eq. 0)) write(*,217)

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 37

ooo ooooooo

]uly

end! f

360 CONTINUE endi f

READ AND PROCESS THE FASTENER LINES

Fasteners

IF (nfastn .gt. 0) then

if (echflg .eq. 1) then

If (scrflg .eq. 1) then WRITE (*,380)

380 FORMAT (//’ FASTENER DATA7/

+ * Fastener I J Area StiffnessV)

e I se

if (scrflg .eq. 0) write (*,385)

385 format ('Fasteners...’\)

endi f

call diskroom (70)

WRITE (2,380,err-2000)

e I se

write (*,385) endi f

call chkdup (0,lerror)

DO 400 loop-1.nfastn

CALL verify(12,entry,ierror,maxban,youngm)

IF (lerror .NE. 0) GOTO 994

i-entry(1)

n1-entry(2}

n2«entry(3)

if (echflg .eq. 1) then

if (scrflg .eq. 1) WRITE (*,390) I,n1,n2,entry(4),entry(5) 390 FORMAT (I5,2I6.F12.6,F11.0)

cal I diskroom (42)

WRITE (2,390,err-2000) i,nl,n2,entry(4),entry(5) end! f

fsstif(I)-entry(5)

If (entry(5) .ne. 0.) then ftconsf1)»entry(5) nodefs(1,1}-n1 nodefs(2,i)«n2 fsarea(I)-entry(4)

I1»3*n1-2

12 *11+1

J1«3*n2-2

J2-J1+1

mxndif(n1)-MAX(n1,n2.mxndif(nl)) mxndlf(n2)«MAX(n1,n2,mxndif(n2))

CALL assemble (II,II,ftcons(1),0.,0.)

CALL assemble (II,jl,-ftcons(1),0.,0.)

CALL assemble (12,12,ftcons(1),0.,0.)

CALL assemble (12,j2, — ftcons(1),0.,0.)

CALL assemble (j1,j1,ftcons(1),0.,0.)

CALL assemble (J2,J2,ftconsQI),0.,0.)

e I se

if (scrflg .ge. 0) write (*,395) i 395 FORMAT (/' WARNING : The fastener',14,

+ ' has been disconnected from the model.’/)

call diskroom (73)

WRITE (2,395,err-2000) I

if ((echflg .eq. 0) .or. (scrflg .eq. 0)) write(*,217) end! f

400 CONTINUE end i f

Fix unstlffened degrees of freedom

DO 470 loop-1,nnodes N1-3*Ioop-2

IF (nodst3(loop) .ne. 1) then

IF (mxndif(loop) .EQ. 0) THEN

If (scrflg .ge. 0) write (*,465) loop 465 FORMAT (/' WARNING : The node',14,

38 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

OOO

o o o o o o

July

+ • is not connected to any element In the model.'/)

call diskroom (77)

WRITE (2,465,err-2000) loop

if ((echflg .eq. 0) .or. (scrflg .eq. 0)) write(*,217)

igndof(nl)-l

disdof(nl)-0.

igndof(nl+1)«1

disdof(n1+1)=0.

ENDIF

igndof(N1+2)=1 disdof(N1+2)=0. endi f

470 CONTINUE

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C c

C READ AND PROCESS THE NODE LOADS LINES C

C C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c

C Node loads C

IF (nlnods .gt. 0) then

if (echflg .eq. 1) then

if (scrflg .eq. 1) then WRITE (*,410)

410 FORMAT (//' NODE LOADS'//' Node PX\

+ ’ PY MZ'/)

e I se

If (scrflg .eq. 0) write (*,415) 415 format ('Loads...'\)

end I f

cal I diskroom (75)

WRITE (2,410,err-2000)

e I se

write (*,415) endi f

cal I chkdup (0,terror)

DO 450 loop-1,nlnods

CALL ver!fy(13,entry,I error.maxban,youngm)

IF (terror .NE. 0) GOTO 994 I«entry(1)

If (echflg .eq. 1) then

if (scrflg .eq. 1) WRITE (*,440) I,entry(2),entry(3), + entry(4)

440 FORMAT (15,1X.3F14.2)

cal I diskroom (50)

WRITE (2,440,err-2000) I.entry(2),entry(3),entry(4) endi f

N1-3*I-3 DO 445 j-1,3

appIdf(N1+J)-appIdf(N1+J)+entry(j + 1) 445 reafor(j,I)«reafor(J,i)-entry(j+1)

450 CONTINUE

endi f

Initialize displacements

DO 460 Ioop«1,numdof 460 disdof(loop)«appldf(loop)

Determine last non-zero element In each row

i-0

JHB-6

DO 480 loop-1,nnodes J-3*(mxndlf(loop)-loop+1)

IF (J .LT. JHB) THEN J-JHB

ELSE

JHB-J

ENDIF

DO 480 K-1,3 i-t+1

Ienhbw(I)«min(J,numdof-!+1)

j-M

480 CONTINUE

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 39

July

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C c

C READ AND PROCESS THE NODE RESTRAINTS LINES C

C C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c

C Fixed displacements C

IF (nresdf .gt. 0) then

If (echflg ,eq. 1) then

if (scrfig .eq. 1) then WRITE (*.490)

490 FORMAT (//' MOVEMENT RESTRAINTS'//' Node

+ 'Type of restraint Displacement*/)

e I se

if (scrfig .eq. 0) write (*,495)

495 format ('Restraints...*\)

end! f

caI I diskroom (90)

WRITE (2.490,err*2000)

e I se

write (*,495) endi f

cal I chkdup (0,ierror) txtdispf 1 }*’Trans I at Ion along X axis' txtdisp(2)**Translation along Y axis' txtdisp(3)** Rotation about Z axis '

DO 510 loop*1.nresdf

CALL verify(14,entry,ierror.maxban.youngm)

IF (ierror .NE. 0) GOTO 994 i*entry(1) indxfd=entry(2)

If (echflg .eq. 1) then

If (scrfig .eq. 1) WRITE (*,500) I,txtdisp(1ndxfd),

+ entry(3)

500 FORMAT (I5.8X,A24.F15.5)

call dIskroom (54)

WRITE (2,500,err*2000) 1,txtdisp(indxfd),entry(3) end i f

N1*3*(i-1)+lndxfd disdof(N1)-entry(3)

IF (entry(3) .EQ. 0.) THEN igndof(N1)*2

ELSE

longI*(maIhbw+2)*(n1-1)+1 stmtrxflong!)*1D30 disdof(N1)*stmtrx(longi)*entry(3) igndof(Nl)«-2 ENDIF

510 CONTINUE endi f CLOSE (1)

if ((echflg .eq. 0) .or. (scrfig .eq. 0)) WRITE (*,512)

512 format ('End')

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c

C SOLVE THE SYSTEM [K]{u}-{F{ AND REPORT THE RESULTS IN THE SCREEN C C AND THE OUTPUT FILE C

C C

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

write (*,522) numdof.maxban

522 format (/' Solving the system [K]{u}«{FJ...'/' Number of degrees’, ♦ ' of freedom :',15,' Bandwidth :•i4//

+ ' PASS 1 : FORWARD ELIMINATION’)

11«*1+numdof/80 J1«numdof/i1-2 k 1 **78— j 1 dash-*-' arrow*''

write (*,524) arrow,(dash,1*1,j1).arrow,(bIank,j*1,k1)

524 format (1x,80a1)

C

C Calculate displacements C

longI*-malhbw-1 DO 535 1*1,numdof

40 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

I uly

525

529

530

535

536

540

550

555

If (nextld(I,M) .eq. 1) call pacer longi*longi+maIhbw+2 IF (Igndof(I) .le. 0) then

IF (ABSfstmtrx(longi)) .LT. .000001) THEN M«(i-1)/3+1 j1*i-3*(i1-1)

WRITE (*.525) M.J1

FORMAT (//* ERROR : THE STIFFNESS MATRIX APPEARS TO BE*,

SINGULAR.•/* The elements connected to node ',13 do not contribute any stiffness in the free*/ f * degree of freedom *,11 # *.•/)

cal I diskroom (162)

WRITE (2,525.err*2000) 11, jl goto 994 end I f

DO 530 J*1,Ienhbw(I)-1

l-i+J

IF ((igndof(l) .le. 0) .and. (stmtrx(Iongi+j) .ne. 0.)) then RATIO=stmtrx(longl+j)/stmtrx(longi)

Iongl«(maIhbw+2)*j+Iongi-1 DO 529 k-j+1,lenhbw(I)

I ongI * IongI+1

IF (igndof(l) .le. 0) stmtrx(IongI)*stmtrx(IongI)h ratio*stmtrx(longi-1+k)

CONTINUE '

stmtrxflongl+j)»ratIo disdof(I)«disdof(I)-RATIO*disdof(I) end! f CONTINUE

disdof(i)=disdof(I)/stmtrx(longi)

ENDIF CONTINUE write (*,536)

format (/* PASS 2 : BACKWARDS SUBSTITUTION*) write (*,524) arrow,(dash,1-1.j1).arrow.(bIank,j-1,k1) if (nextid(numdof,II) .eq. 1) call pacer DO 550 l-numdof-1,1,-1 if (next!d(1,11) .eq. 1) call pacer I ongj«(maIhbw+2)*(1-1)+1 IF (igndof(i) .le. 0) then DO 540 K-1,lenhbw(i)-1

disdof(i)-dlsdof(I)-stmtrx(longJ+k)*disdof(i+k) endif CONTINUE write (*,555)

format (/* The system has been succesfully solved.*)

cal 1

setstr

cal 1

setstr

cal 1

movstr

ca 1 1

resst r

ca 1 1

pakstr

cal 1

constr

ca 1 1

expstr

cal 1

resstr

Print displacements

if (serf Ig .eq. 0) then

d!amsg-*WritIng results to file + *

! 110 ,diamsg)

78,outfI I)

dlamsg,25.1,outfiI,1,77) out fiI) diamsg)

diamsg.elIpss)

S diamsg) diamsg) write (*,680) diamsg

680 format (/IX,A/* DispIacements...*\) endif

if (scrflg .eq. 1) THEN WRITE (*,685)

685 FORMAT (//* NODE DISPLACEMENTS’//

+ * Node U V Omega*/)

endl f

cal I diskroom (76)

WRITE (2.685,err-2000)

DO 700 J«1.nnodes If (mxndlf(J) .ne. 0) then

690 ^? r (!!.ix!if&!) ITt ( '’ 6M) 1-1.3)

cal I diskroom (44)

WRITE (2.690.err-2000) J,(disdof(3*(J-1)+l), 1 - 1 , 3 )

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 41

July

endi f

700 CONTINUE

MZ1

Beam corner force*

IF (nbeams .gt. 0) then

If (scrflg .eq. 1) then WRITE (*.710)

710 FORMAT (//’ BEAM CORNER FORCES 1 //

+ * Beam I J FX1 FY1

+ • FX2 FY2 MZ2’/)

else , .

if (scrflg .eq. 0) write (*,205) endi f

cal I diskroom (125)

WRITE (2,710,err-2000)

DO 740 i-1,nbeams mat-matcbm(i) eyoung-youngm(mat)

if ((eyoung .ne. 0.) .and. (bmarea(I) .ne. 0.)) then n1-nodebm(1, 1) n2«nodebm(2,i)

diffnc(1,2)-coonod(1,n2)-coonod(1,n1) diffnc( 2 , 2 )«coonod( 2 ,n 2 )-coonod( 2 ,n 1 ) bIngth-DSQRT(diffnc(1,2)*diffnc(1,2)+

+ diffncf2.2)*diffnc(2.2))

bmlcos-dlffncM,2)/blngth bmlsin-diffnc(2,2)/bIngth I1«3*n1-2

J1-3*n2-2 , v

ftcons(1)*disdof(J1)-dlsdof(II) ftcons(2)«disdof(J1+1)-disdof(11+1)

ftcons(3)*3*(bmIsin*ftcons(1)-bmlcos*ftcons(2))/bIngth f tcons(4)-(bmdis1(I)+bmdi s2( i))*blngth/2.

ftcons(5)-2*eyoung*bminer(i)/bIngth

f tcons(6)=eyoung*bmarea(i)*(bmlcos*f tcons(1)+

+ bmlsin*ftcons(2))/bIngth

beamcf(3.1)«ftcons(5)*(ftcons(3)+2*disdof(I1+2)+

+ disdof(J 1 + 2 ))-(8.*ftcons(4)-bmdis2(i)*

+ blngth/2.)*blngth/90.

beamcf(3,2)-ftcons(5)*(2*disdof(J1+2)+disdof(I1+2)+

+ f tcons(3n+(8.*f tcons(4)-bmdisi(i )*

+ blngth/2.)*bIngth/90.

ftcons(7)-(ftcons(4)+bmdis1(I)*blnath/2.)/3.+ (beamcf(3,1)+beamcf(3,2))/bIngth

ftcons(8)=ftcons(7)-ftcons(4}

beamcf(1,1)—bmlcos*ftcons(6)+bmIsin*ftcons(7) beamcf(1,2)-bmlcos*ftcons(6)-bmlsin*ftcons(8) beamcf(2.1)=-bmlsin*ftcons(6)-bmlcos*ftcons(7) beamcf( 2 , 2 )»bmlsin*ftcons(6)+bmIcos*ftcons(8)

DO 720 J-1,2

DO 720 k-1,3 , , Wl .v

reafor(k,nodebm(j,1))»reafor(k,nodebm(j,i))+beamcf(k,j)

720 CONTINUE

baxia I(I)-ftcons(6)

bshear(1, i)«ftcons(7)

bshear(2,i)=ftcons(8)

bmomnt (1, i )—beamcf (3,1)

bmomnt(2,I)-beamcf(3,2)

if (scrflg .eq. 1) WRITE (*,730) I,n1,n2,

+ (beamcf(k,1),k-1,3),(beamcf(k,2),k-1.3)

730 FORMAT (15,216,IX,6F12.0)

cal I diskroom (92) . .

WRITE (2,730,err-2000) i,n1,n2,(beamcf(k,1),k-1,3),

+ (beamcf(k,2),k-1,3)

endi f

740 CONTINUE

C

c

c

Beam loads and stresses

if (scrflg .eq. 1) WRITE (*,750)

750 FORMAT (//* BEAM LOADS AND STRESSES*//

+ * Beam I J PAX SAX

+ »SH1 SH2 BM1 BM2*/)

call diskroom (130)

WRITE (2.750,err-2000)

42 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

July

DO 760 1*1,nbeams mat«matcbm(I)

If ((youngm(mat) .ne. 0.) .and. (bmarea(l) .ne. 0.)) then ftcons(1)«baxial(I)/bmarea(l)

If (serfIg .«q. WRITE (*.730) I.(nodebm(k,i),k-1,2).

+' box Ial(I),ftcons(1),(bsh«ar(k,l),k«1,2),(bmomnt(k,I),k«1,2)

cal I diskroom (92)

WRITE (2,730,err-2000) I,(nodebm(k,I),k«1,2).baxiaI(I).

+ ftcons(l),(bshear(k,I),k«1,2),(bmomnt(k,i),k»1,2)

end I f

760 continue endl f

Plate corner forces

IF (nplate .gt. 0) then

If (scrflg .eq. 1) then WRITE (*,770)

770 FORMAT (//’ PLATE CORNER FORCES*//

♦ * Plate I J K L FX1 FY1

+ 'FX2 FY2 FX3 FY3 FX4 FY4*/)

e I se

If (scrflg .eq. 0) write (*,245) end I f

cal I diskroom (138)

WRITE (2.770,err-2000)

DO 850 LPL-1,nplate TH-pIteth(LPL) mat-matcpl(Ipl) eyoung*youngm(mat) pratio-polsson(mat)

If ((th .ne. 0.) .and. (eyoung .ne. 0.)) then DO 780 1-1,2 DO 780 J-1,4

780 pIteef(I,J)-0.

IF (nodepI(4,LPL) .EQ. 0) THEN

CALL trlloads (1,2,3,th,eyoung,pratlo,Ipl,nodepl)

ELSE

+

+

+

+

790

800

+

+

+

+

+

+

+

+

coonod(1,nnodes+1)«(coonod(1,nodepI(1,LPL))+

coonod(1,nodepI(2,LPL))+coonod(1.nodepI(3,LPL))+ coonod(1,nodepl(4,LPL)))/4 coonod(2,nnodes+1)«(coonod(2,nodepI(1,LPL))+

coonod(2,nodepI(2,LPL))+coonod(2,nodepl(3,LPL))+ coonod(2,nodepI(4,LPL)))/4 ftcons(7^«0 ftcons f8)»0 ftcons(9)«0 DO 790 1-1,8 DO 790 J-1,2 sttemp(l,j)«0. lnp(3)-nnodes+1 DO 810 1-1,4 J-nextId(I,4)

Inp(1)-nodepl(I,LPL) lnp(2)-nodepl(J.LPL;

DO 800 N1-1,2 DO 800 N2-1,3

dlffnc(N1,N2)»coonod(N1,lnp(N2))

coonod(N1,inp(prevld(N2,3))) ftcons(1)-diffnc(2,3)*dlffnc(1,2)dlffnc(1,3)*d!ffnc(2,2) ftcons(2)-1/(ftcons(1)*(1+pratIo)) ftcons(3)-ftcons(2)*(dIffnc(1,3)*dlffnc(1,2)+ dlffnc(2,3)*dlffnc(2,2)) ftcons(4)-ftcons(2)*(d!ffnc(2,3)*dlffnc(1,2)dlffncf1,3)*diffnc(2,2)) ftcons(5)-ftcons(2)*(dIffnc(1,2)*dlffnc(1,2)+ dlffnc(2,2)*dlffnc(2,2)) ftcons(6)-1/(ftcons(1)*(1-prat Io)) sttemp(2*I-1,1)-sttemp(2*I-1,1)+ftcons(3)+

ftcons(6)*d!ffnc(2.2)*dlffnc(2,3) sttemp(2*l-1,2)«sttempf2*1-1,2)+ftcons(4)

ftcons(6)*dlffnc(2,3)*dlffnc(1,2) sttemp(2*l,1)-sttemp(2*1,1)-ftcons(4)

ftcons(6)*dIffnc(2,2)*d!ffnc(l,3)

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 43

o o o

July

+

+

820

sttemp(2*I,2)»sttemp(2*I,2)+ftcons(3)+

ftcons(6)*dlffnc(1,3)*diffnc(1,2) sttemp(2* J-1,1 )-sttemp(2*J-1,1 )-ftcons(3)-ftcons(5)+ ftcons(6)*diffnc(2,2)*diffnc(2,1) sttemp(2* J-1,2)«sttemp(2*J-1,2)-ftcons(4)

ftcons(6)*dlffnc(2,1)*diffnc(1,2) sttemp(2*J,1)«sttemp(2*J,1)+ftcons(4;

ftcons(6)*dlffnc(2,2)*dlffnc(1,1} sttemp(2*J,2)»sttempi 2*J,2)-ftcons(3)-ftcons(5) + ftcons(6)*diffnc(1,1)*diffnc(1,2)

ftcons(7)-ftcons!

;7)

l+f tcons (

+

ftcons!

6

l*di f fnc(

ftcons(8)-ftcons!

[8]

>

+

ftcons!

[8]

l*dlf fnc(

<0

c

0

0

-♦-*

1

cn

CO

c

0

0

«•-»

l+f tcons(

+

ftconsl

(6)*diffnc(

Table caption810 CONTINUE

ftconsfl}»0 ftcons(2)-0 DO 820 1-1,4 f tcon8(1 )«f tcons(1 )

+ sttempi 2*1-1,1)*disdof(3*nodepl(I,LPL)-2)

+ sttemp(2*I,1)*dlsdof(3*nodepI (I,LPL)-1)

f tcons (2)-ft consist temp(2*I-1,2)*di sdof (3*nodep I (I,LPL)-2)sttemp(2*I,2)*dIsdof(3*nodepl(I,LPL)-1)

CONTINUE

ftcons(3)-ftcons(7)*ftcons(9)-ftcons(8)*ftcons(8) dlsdof(numdof+1)-(ftcons(1)*ftcons(9)+ ftcons(8)*ftcons(2))/ftcons(3)

disdof(numdof+2)«(ftcons(2)*ftcons(7)+ ftcons(8)*ftcons(1))/ftcons(3)

I— nnodes-1 CALL tr Moods CALL tr Moods CALL tr Moods CALL tr Moods DO 830 1-1,3 830 pIstrs(I,LPL)«pIstrs(I,LPL)/4

ENDIF

If (serf Ig .eq. 1) WRITE (*,840) LPL,(nodepI(k,LPL),k«1,4) + •((pI tec f(I,J),1-1,2),J-1,4)

840 FORMAT (15,416,IX,8F9.0)

cal I diskroom (104)

WRITE (2,840,err-2000) LPL,(nodepI(k,LPL).k-1,4),

+ ((pltecf(i,J),i-1.2).J»1,4)

end! f

850 CONTINUE

( 1 , 2 , I,th,eyoung,pratio,Ipl,nodepI ) (2,3,1,th.eyoung.pratio,Ipl,nodepI) f3,4,i,th,eyoung,pratio,Ipl,nodepI ) (4,1,1,th,eyoung,pratio,Ipl,nodepI)

Plate load-intensities and stresses

860

+

+

+

870

+

+

+

+

+

880

if (scrflg .eq. 1) WRITE (*,860)

FORMAT (//* PLATE LOAD INTENSITIES AND STRESSES*//

* Plate I J K L PIX PIY TXY*,

* SX SY TAU SMAX SMIN TMAX * ,

* Angle*/)

caI I diskroom (172)

WRITE (2,860,err-2000)

DO 890 LPL-1,nplate mat-matepI(IpI)

if ((piteth(Ipl) *ne. 0.) .and. (youngm(mat) .ne. 0.)) then DO 870 1-1,3

pIints(I)«pIstrs(I,LPL)*pIteth(LPL) ftcons(3)-SQRT(pIstrs(3,LPL)*pIstrs(3,LPL)+

.25*(pIstr$(2,LPL)-pIstrs(1,LPL))*(pIstrs(2,LPL)pIstrs(1,LPL)))

f tcons(5V.5*(pIstrs(1,LPL)+pIstrs(2,LPL)) ftcons(1;«ftcons(5)+ftcons(3) ftconsf2)»ftcons(5)-ftcons(3) ftcons(4)-degree(2*pIstrs(3,LPL),

pIstrs(2,LPL)-pI strsfl,LPL))/2. if (scrflg .eq. 1) WRITE (*,880) LPL,(nodepl(k,LPL),k-1,4) ,(plints(k),k-1,3),(pistrs(k.LPL),k-1,3) , (ftcons(k),k«1,4)

FORMAT (15,416,IX,10F9.0) cal I diskroom (122)

44 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

890

c

c

c

WRITE (2,880,err-2000) LPL,(nodepI(k,LPL),k«1,4),

(piints(k),k«1,3),(plstrs(k,LPL),k-1,3),(ftcons(k),k-1,4) end I f CONTINUE

Plate stresses at node points

900

if (serf Ig .eq. 1) WRITE (*,900)

FORMAT (//• PLATE STRESSES AT NODE POINTS*//

Node Coordinate X • TAU SMAX

cal I diskroom (151) WRITE (2,900,err-2000) DO 930 1-1.nnodes k-0

DO 910 J-1,3 IF (pstnor(J,I) .GT. 0

Coordinate Y SMIN TMAX

SX Ang I e

/)

SY

r - , -_.) THEN

ftcons(j)«pstacc(J,I)/pstnor(J,I)

■ 1

910

ELSE

k

ENDIF CONTINUE if (k .ne.

1 ) then

ftcons(6)-SQRT(ftcons(3)*ftcons(3)+

25*(ftcons(2)-ftcons(1))*(ftcons(2)-ftcons( 1 )))

ftcons(8) ftcons(4 ftcons

5*(ftcons(lj+ftcons(2))

(4) -f tcons(8)+f tcons(6)

(5) -ftcons(8)-ftcons(6;

920

930

C

C

C

--:cons(8)-ftcons(6;

ftcons(7)«degree(sngI(2*ftcons(3)),

sngI(ftcons(2)-ftcons(1)))/2. if (scrflg .eq. 1) WRITE (*,920) I,coonod(1,I),coonod(2,I) v ,(ftcons(k).k—1,7)

FORMAT (I5,3X,F12.5,3X,F12.5,7F10.0) caI I diskroom (107)

WRITE (2,920,err-2000) I,coonod(1,I),coonod(2,I), h (f tcons(k) ,k—1,7)

endif CONTINUE endif

Fastener forces and stresses

IF

940

(nfastn .gt. 0) then if (scrflg .eq. 1) then WRITE (*,940)

FORMAT (//* FASTENER FORCES AND STRESSES*// ' Fastener I J FX FY

•Angle Stress*/)

e I se

if (scrflg .eq. 0) write (*,385) endif

cal I diskroom (113)

WRITE (2,940,err-2000)

DO 960 LFS-1,nfastn if (fsstif(lfs) .ne. 0.) then nl-nodefs(I.LFS) fs(2,l

n2-nodefs( I1—3*n1—2 J1-3*n2-2

• LFS)

ftconsi ftconsi ftconsi

tif(lfs)*(disdof(I1)-disdof(J1)) f sst I f ( I f f ' > •• ■ .

*f ss

- x .fs)*(disdof(11 + 1)-disdof(J1 + 1))

■SQRT(ftcons(1)*ftcons(1)+ftcons(2)*ftcons(2))

--\ w / \ ' \ ■ / ' \ ' /ti kvwnaytyi'i ivvi

ftcons(4Wdegreefsngl(ftcons(2)),sngI(ftcons(1)))

ftcons(5)«ftcons(3)/fsarea(Ifs)

950

if (scrflg .eq. 1)WRITE (*,950) LFS,n1,n2,

. (ftcons(k),k-1,5)

FORMAT (15,216,IX,5F10.0) cal I diskroom (70)

WRITE

reafor

2,950,err-2000) LFS,n1,n2,(ftcons(k),k—1,5)

reafor(l,n2 reafor(2,nl

1 ,n1)-reafor(1,n1)+ftcons(1

reafor(2,n2, endl f CONTINUE endif

■reafor(1,n2)-ftcons h ■reafor f 2,nl Uf tcons(2 ■reafor(2,n2)-ftcons(2j

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 45

c

c

c

Node internal forces and reactions

reaclb(l)** •

reaclb(2)«* •

reacIb(3)»*ReactIon *

If (serf Ig .eq. 1) then WRITE (*.970)

970 FORMAT (//* NODE INTERNAL FORCES AND REACTIONS*//

♦ * Node Coordinate X Coordinate Y FX*

+ ’ FY M2 7)

else

If (scrflg .eq. 0) write (*.972)

972 format (’React Ions ...*\) end! f

cal I diskroom (142)

WRITE (2,970.err«2000)

DO 990 I«1.nnodes

if (scrflg .«q. 1) WRITE (*.980) I,coonod(1,1),coonod(2.1),

__ .. (reafor(J.I).reacIb(1+abs(Igndof((1-1)*3+J))),j>»1.3)

980 FORMAT (I5.3X.F12.5.3X.F12.5,3(F12.0,1x.a8.1x)) 1 '

caI I diskroom (103)

WRITE (2.980.«rr-2000) I,coonod(1,I),coonod(2,I),

990 + CONTINUE ( r * af « r (J.0.reaclb(1+abs(igndof((i-1)*3+J))).J-1.3) if (scrflg .eq. 0) write (*.512)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c c

c REPORT THE EXECUTION TIME C

c c

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c

C Report the execution time

c

994 cpusec«0.

call time (lasthr,lastmn.Iostsc,losths)

If (lasthr .It. Inlthr) cpusec-86400.

cpusec-cpusec+3600.*(lasthr-lnlthr)+60.*(lostmn-inltmn)+lastsc+ lnitsc+.01*(la*ths-iniths)

„ Ae l f ( 8crf ‘,9 -9«- 0) write (*.995) cpusec

995 format (//* Execution time : \f8.2.* seconds.’)

If (terror .ns. -1) then

call dIskroom (43) write (2,995,err-2000) cpusec end! f

write (*.999)

999 format (* *)

STOP

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c REPORT UNSPECIFIED I/O ERRORS DETECTED C

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

1000 write (*,1010)

1010 format (//* ERROR : CANNOT READ INPUT FILE.*/

+ * The program cannot continue.*)

goto 994 '

2000 wrIte (*,2010)

2010 format (//* ERROR : CANNOT WRITE OUTPUT FILE.’/

+ * The program cannot continue.’)

Ierror*-1 goto 994 END

expstr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE EXPSTR - SUBROUTINE TO EXPAND A STRING TO ITS SIZE PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986

46 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

COMMENT *

EXPSTR Is a routine designed to be called from FORTRAN as a subroutine to expand a string from its actual length to its size by filling the string with blanks.

Mode of use:

call EXPSTR (string)

where

string « name of the string (variable of type CHARACTER) to be expanded.

♦

SUBTTL FORMAL DECLARATIONS PAGE

csexps

SEGMENT

•CODE’

ASSUME

CS:csexps

SUBTTL

EXPSTR

EXECUTABLE CODE

PAGE

PUBLIC

expstr

expstr

PROC FAR

PUSH

BP

MOV

BP.SP

PUSH

ds

LDS

BX,DWORD PTR [BP+6]

mov

ah,32

; Scan

for either end-of-string mark.

scanend:

mov

a1.[bx]

cmp

al ,0

jz

exit

cmp

al ,6

Jz

fI1Iblanks

Inc

bx

jmp

scanend

; Fill

with blanks between logical and

f i 1 Iblanks:

MOV

[BX],ah

Inc

bx

mov

al ,[bx]

cmp

al ,0

jnz

f11Iblanks

; Exit

exit:

POP

ds

MOV

SP.BP

POP

BP

RET

4

expstr

ENDP

csexps

ENDS

END

punch.inp

"Structural Analysis," by Robert W. Johnson and Fernando G. LoygorrI. July, page 199.

This file demonstrates the mixture of text (notes) and Input data allowed in the Microsafe Program Series. The data for the program is contained on the lines that contain a slash character. All lines without a slash and any characters following the slash are ignored by the program.

15 / # of nodes 1 / # of materials

4 / # of beams 8 / f of plates 0 / # of fasteners

( continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 47

Table captionI / # of loaded nodes

Table captionII / # of ImDOsed res!

1

0.0

10.0 /

2

0.0

0.0 /

3

0.0

-10.0 /

4

10.0

10.0 /

5

10.0

0.0 /

6

10.0

-10.0 /

7

20.0

10.0 /

8

20.0

0.0 /

9

20.0

-10.0 /

10

30.0

10.0 /

11

30.0

0.0 /

12

30.0

-10.0 /

13

40.0

10.0 /

14

40.0

0.0 /

15

40.0

-10.0 /

1

10.3E6 0.33 /

1

2 5 0.

5 0.1 1

2

5 8 0.

5 0.1 1

3

8 11 e

1.5 0.1 1

4

11 14

0.5 0.1

1

2 5

4 1 0.

2

5 8

7 4 0.

3

8 11

10 7 0.i

4

11 14

13 10 0.i

5

3 6

5 2 0J

6

6 9

8 5 0.1

7

9 12

11 8 0.1

8

12 15

14 11 0.1

-# Young * s-moduI us PoIsson•s-ratlo

Table caption0.0 0.0 /

-# Q1 Q2

1 /

2 10000. 0.0 0.0 / node f load-x loadrest ra I ned-freedon-#

1 / plate-# nodel node2 node3 node4 thickness material-#

1 /

1 /

1 /

1

1

0.0

/ node-#

3

1

0.0

/

4

1

0.0

/

6

1

0.0

/

7

1

0.0

/

9

1

0.0

/

10

1

0.0

/

12

1

0.0

/

13

1

0.0

/

14

2

0.0

/ never i

15

1

0.0

/

•y moment Imposed-deflection

1 -> restrain x-dlrection

2 -> 3 ->

restrain

restrain

y-dIrectIon rotatIon

lug.Inp

Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

File: LUG.INP is the Idealization of a lug with a bolt in the center and bolted to a strongback at each end of the flange Load angle is 0 deg.

247

1

24

222

0

11

20

169

188

187

186

185

184

183

182

168

144

145

146

147

148

/ NUMBER OF''NODES / NUMBER OF MATERIALS

/ NUMBER OF BEAMS

/ NUMBER OF PLATES

/ NUMBER OF FASTENERS

/ NUMBER OF LOADED NODES

/ NUMBER OF RESTRAINED NODES

0.0000

0.0000

-0.1294

-0.2500

-0.3535

-0.4330

-0.4829

-0.5000

-0.4829

-0.4330

-0.3535

-0.2500

-0.1294

0.0000

1.3000

1.8000

1.7829

1.7330

1.6535

1.5500

1.4294

1.3000

1.1706

1.0500

0.9464

0.8670

0.8171

0.8000

/

/

/

/

/

/

/

/

/

•,

/

NODAL DEFINITION

48 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

J uly

149

0.1294

0.8171

150

0.2499

0.8670

151

0.3535

0.9464

152

0.4330

1.0500

170

0.4829

1.1706

194

0.5000

1.3000

193

0.4829

1.4294

192

0.4330

1.5499

191

0.3535

1.6535

190

0.2500

1.7330

189

0.1294

1.7829

209

0.0000

1.9000

208

- 0.1552

1.8795

207

- 0.3000

1.8196

206

- 0.4242

1.7242

205

- 0.5196

1.6000

204

- 0.5795

1.4552

181

- 0.6000

1.3000

167

- 0.5795

1.1448

142

- 0.5196

1.0000

143

- 0.4242

0.8757

121

- 0.3000

0.7804

122

- 0.1552

0.7205

123

0.0000

0.7000

124

0.1552

0.7205

125

0.2999

0.7804

153

0.4242

0.8757

154

0.5196

1.0000

171

0.5795

1.1448

195

0.6000

1.3000

214

0.5795

1.4552

213

0.5196

1.5999

212

0.4242

1.7242

211

0.3000

1.8196

210

0.1552

1.8795

226

0.0000

2.0000

225

- 0.1811

1.9761

224

- 0.3500

1.9062

223

- 0.4949

1.7949

222

- 0.6062

1.6500

203

- 0.6761

1.4811

180

- 0.7000

1.3000

166

- 0.6761

1.1189

141

- 0.6062

0.9500

120

- 0.4949

0.8051

119

- 0.3500

0.6938

101

- 0.1811

0.6239

102

0.0000

0.6000

103

0.1811

0.6239

126

0.3499

0.6938

127

0.4949

0.8051

155

0.6062

0.9499

172

0.6761

1.1189

196

0.7000

1.3000

215

0.6761

1.4811

230

0.6062

1.6499

229

0.4949

1.7949

228

0.3500

1.9062

227

0.1811

1.9761

238

0.0000

2.1000

237

- 0.2070

2.0727

236

- 0.4000

1.9928

235

- 0.5656

1.8656

221

- 0.6928

1.7000

202

- 0.7727

1.5070

179

- 0.8000

1.3000

165

- 0.7727

1.0930

140

- 0.6928

0.9001

118

- 0.5656

0.7344

100

- 0.4000

0.6072

80

- 0.2070

0.5273

81

0.0000

0.5000

82

0.2070

0.5273

104

0.3999

0.6072

128

0.5656

0.7344

/

/

/

/

/

/

/

/

/

*

*

/

/

/

/

/

/

/

/

/

/

/

/

/

/

/

/

/

/

*

/

/

*

/

/

/

/

/

/

/

/

/

/

*

/

/

/

/

/

/

/

/

/

/

/

/

/

/

/

*

*

*

/

/

/

I continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 49

Jn/y

156

0.6928

173

0.7727

197

0.8000

216

0.7727

231

0.6928

241

0.5656

240

0.4000

239

0.2070

245

0.0000

244

- 0.2329

243

- 0.4500

234

- 0.6363

220

- 0.8000

219

- 0.9400

200

- 1.0900

201

- 1.0000

178

- 1.0000

164

- 1.0000

139

- 0.8000

138

- 1.0000

117

- 0.8000

99

- 0.6000

79

- 0.4000

83

0.4000

105

0.6000

129

0.8000

158

1.0000

157

0.8000

174

1.0000

198

1.0000

217

1.0000

218

1.0900

233

0.9400

232

0.8000

242

0.6363

247

0.4500

246

0.2329

177

- 1.2400

162

- 1.4000

163

- 1.2000

137

- 1.2000

116

- 1.0000

98

- 0.8000

78

- 0.6000

56

- 0.4000

57

- 0.2000

58

0.0000

59

0.2000

60

0.4000

84

0.6000

106

0.8000

130

1.0000

159

1.2000

175

1.2000

176

1.4000

199

1.2400

135

- 1.5450

112

- 1.6950

113

- 1.6000

136

- 1.4000

114

- 1.4000

95

- 1.4000

115

- 1.2000

96

- 1.2000

97

- 1.0000

76

- 1.0000

77

- 0.8000

54

- 0.8000

55

- 0.6000

32

- 0.6000

33

- 0.4000

34

- 0.2000

35

0.0000

36

0.2000

37

0.4000

61

0.6000

0.9000 / 1.0930 /

1.3000 /

1.5070 /

1.6999 / 1.8656 / 1.9928 /

2.0727 / 2.2000 / 2.1693 / 2.0794 /

1.9363 /

1.7650 /

1.6250 /

1.4600 /

1.4600 /

1.3000 /

1.1400 /

0.9800 /

0.9800 /

0.8200 / 0.6350 / 0.5000 /

0.5000 /

0.6350 /

0.8200 / 0.9800 /

0.9800 /

1.1400 /

1.3000 /

1.4600 /

1.4600 /

1.6250 /

1.7650 / 1.9363 / 2.0794 /

2.1690 /

1.3000 /

1.1400 /

1.1400 /

0.9800 /

0.8200 / 0.6600 / 0.5000 /

0.3400 /

0.3400 /

0.3400 /

0.3400 /

0.3400 /

0.5000 /

0.6600 / 0.8200 / 0.9800 /

1.1400 /

1.1400 /

1.3000 /

0.9800 /

0.8200 / 0.8200 / 0.9800 /

0.8200 / 0.6600 / 0.8200 / 0.6600 / 0.6600 / 0.5000 /

0.5000 /

0.3400 /

0.3400 /

0.1700 /

0.1700 /

0.1700 /

0.1700 /

0.1700 /

0.1700 /

0.3400 /

Table caption50

BYTE LISTINGS SUPPLEMENT

IULY-SEPTEMBER. 1986

62

0.8000

0.3400

85

0.8000

0.5000

86

1.0000

0.5000

107

1.0000

0.6600

108

1.2000

0.6600

131

1.2000

0.8200

132

1.4000

0.8200

133

1.6000

0.8200

134

1.6950

0.8200

160

1.4000

0.9800

161

1.5450

0.9800

93

- 1.8450

0.6600

94

- 1.6000

0.6600

71

- 2.0000

0.5000

72

- 1.8000

0.5000

73

- 1.6000

0.5000

74

- 1.4000

0.5000

75

- 1.2000

0.5000

50

- 1.6000

0.3400

51

- 1.4000

0.3400

52

- 1.2000

0.3400

53

- 1.0000

0.3400

29

- 1.2000

0.1700

30

- 1.0000

0.1700

31

- 0.8000

0.1700

8

- 0.8000

0.0000

9

- 0.6000

0.0000

10

- 0.4000

0.0000

11

- 0.2000

0.0000

12

0.0000

0.0000

13

0.2000

0.0000

14

0.4000

0.0000

15

0.6000

0.0000

16

0.8000

0.0000

38

0.6000

0.1700

39

0.8000

0.1700

63

1.0000

0.3400

64

1.2000

0.3400

65

1.4000

0.3400

66

1.6000

0.3400

87

1.2000

0.5000

88

1.4000

0.5000

89

1.6000

0.5000

90

1.8000

0.5000

91

2.0000

0.5000

109

1.4000

0.6600

110

1.6000

0.6600

111

1.8450

0.6600

48

- 2.0000

0.3400

49

- 1.8000

0.3400

25

- 2.0000

0.1700

26

- 1.8000

0.1700

27

- 1.6000

0.1700

28

- 1.4000

0.1700

40

1.0000

0.1700

41

1.2000

0.1700

42

1.4000

0.1700

43

1.6000

0.1700

44

1.8000

0.1700

45

2.0000

0.1700

67

1.8000

0.3400

68

2.0000

0.3400

2

- 2.0000

0.0000

3

- 1.8000

0.0000

4

- 1.6000

0.0000

5

- 1.4000

0.0000

6

- 1.2000

0.0000

7

- 1.0000

0.0000

17

1.0000

0.0000

18

1.2000

0.0000

19

1.4000

0.0000

20

1.6000

0.0000

21

1.8000

0.0000

22

2.0000

0.0000

70

- 2.2000

0.5000

/

/

/

/

/

/

*

/

/

/

/

*

*

/

/

*

/

/

*

*

/

/

*

*

*

/

/

/

/

*

/

/

/

/

/

/

*

/

/

/

/

*

/

/

/

/

/

/

/

/

/

/

/

*

(continual)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 51

120

97

98

117

121

71

72

93

122

72

73

94

123

73

74

95

124

74

75

96

125

75

76

97

126

76

77

98

127

77

78

99

128

78

79

100

129

198

199

218

130

174

175

199

131

175

176

199

132

158

159

175

133

159

160

176

134

160

161

176

135

129

130

158

136

130

131

159

137

131

132

160

138

132

133

161

139

133

134

161

140

106

107

130

141

107

108

131

142

108

109

132

143

109

110

133

144

110

111

134

145

83

84

105

146

84

85

106

147

85

86

107

148

86

87

108

149

87

88

109

150

88

89

110

151

89

90

111

152

90

91

111

153

47

48

71

154

48

49

72

155

49

50

73

156

50

51

74

157

51

52

75

158

52

53

76

159

53

54

77

160

54

55

78

161

55

56

79

162

56

57

80

163

57

58

81

164

58

59

82

165

59

60

83

166

60

61

84

167

61

62

85

168

62

63

86

169

63

64

87

170

64

65

88

171

65

66

89

172

66

67

90

173

67

68

91

174

68

69

92

175

24

25

48

176

25

26

49

177

26

27

50

178

27

28

51

179

28

29

52

180

29

30

53

181

30

31

54

182

31

32

55

183

32

33

56

184

33

34

57

185

34

35

58

186

35

36

59

187

36

37

60

188

37

38

61

189

38

39

62

190

39

40

63

191

40

41

64

192

41

42

65

193

42

43

66

194

43

44

67

195

44

45

68

0.750 1 /

0.450 1 /

0.450 1 /

0.450 1 /

0.450 1 /

0.600 1 / 0.750 1 /

0.750 1 /

0.750 1 /

0.450 1 /

0.450 1 /

0.250 1 /

0.450 1 /

0.250 1 /

0.250 1 /

0.750 1 /

0.450 1 /

0.250 1 /

0.250 1 /

0.250 1 /

0.750 1 /

0.450 1 /

0.250 1 /

0.250 1 /

0.250 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.600 1 / 0.450 1 /

0.450 1 /

0.450 1 /

0.450 1 /

0.550 1 /

0.550 1 /

0.650 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.650 1 /

0.550 1 /

0.550 1 /

0.550 1 /

0.550 1 /

0.650 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.650 1 /

0.550 1 /

116

0

93

94

95

96

97

98

99

217

198

0

174

175

0

157

158

159

160

0

129

130

131

132

133

104

105

106

107

108

109

110

0

70

71

72

73

74

75

76

77

78

79

80

81

82

83

84

85

86

87

88

89

90

91

47

48

49

50

51

52

53

54

55

56

57

58

59

60

61

62

63

64

65

66

67

54 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

196 45 46 69 68

197 1 2 25 24

198 2 3 26 25

199 3 4 27 26

200 4 5 28 27

201 5 6 29 28

202 6 7 30 29

203 7 8 31 30

204 8 9 32 31

205 9 10 33 32

206 10 11 34 33

207 11 12 35 34

208 12 13 36 35

209 13 14 37 36

210 14 15 38 37

211 15 16 39 38

212 16 17 40 39

213 17 18 41 40

214 18 19 42 41

215 19 20 43 42

216 20 21 44 43

217 21 22 45 44

218 22 23 46 45

219 117 99 118 0

220 105 129 128 0

221 100 80 101 0

222 82 104 103 0

169

0.0

25000.0

0 / NODAL LOADS

2

0.0

5000.0

0 /

3

0.0

5000.0

0 /

4

0.0

5000.0

0 /

5

0.0

5000.0

0 /

19

0.0

2500.0

0 /

20

0.0

2500.0

0 /

21

0.0

5000.0

0 /

22

0.0

5000.0

0 /

1

0.0

2500.0

0 /

23

0.0

2500.0

0 /

71 2 0.0000000 / NODAL RESTRAINTS

72 2 0.0000000 /

73 2 0.0000000 /

74 2 0.0000000 /

88 2 0.0000000 /

89 2 0.0000000 /

90 2 0.0000000 /

91 2 0.0000000 /

2 1 0.0000000 /

3 1 0.0000000 /

4 1 0.0000000 /

5 1 0.0000000 /

19 1 0.0000000 /

20 1 0.0000000 /

21 1 0.0000000 /

22 1 0.0000000 /

23 1 0.0000000 /

70 2 0.0000000 /

1 1 0.0000000 /

92 2 0.0000000 /

0.550 1 /

0.550 1 /

0.550 1 /

0.650 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.650 1 /

0.550 1 /

0.550 1 /

0.750 1 /

0.750 1 /

0.750 1 /

0.750 1 /

Table caption- N1 PX PY MZ

N1 FIXITY DEFLECTION

diskpc.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

TITLE DSKSPC - SUBROUTINE TO GET THE DISK FREE SPACE AVAILABLE.

PAGE .132

; (C) Copyright Microstress Corporation 1985, 1986 COMMENT *

DSKSPC Is a routine designed to be called from FORTRAN as a subroutine to determine the available disk free space.

[continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 55

Mode of use:

call DSKSPC (drive,nbyt)

where

drive ■ Integer variable containing the drive number (0*default, 1-A, etc...)

nbyt ■ Integer-4 variable containing the number of free bytes aval table In the disk.

*

SUBTTL FORMAL DECLARATIONS PAGE

csdsks SEGMENT 'CODE*

ASSUME CS:csdsks

SUBTTL DSKSPC - EXECUTABLE CODE PAGE

PUBLIC DSKSPC DSKSPC PROC FAR

PUSH BP MOV BP.SP PUSH DS

; Get the drive number.

LDS BX,DWORD PTR [BP+10]

MOV dx,[bx]

; Call the system function, mov ah,36h Int 21h

; Handle parameters from calling program xor dx.dx cmp ax,0FFFFh Je exit mu I cx mu I bx

; Everything done except housekeeping, exit:

LDS sI,DWORD PTR [BP+6]

MOV [si],ax inc si Inc si

MOV [si],dx POP DS MOV SP.BP POP BP RET 8h

DSKSPC ENDP csdsks ENDS

END

movstr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE MOVSTR - SUBROUTINE TO MOVE A STRING INTO ANOTHER STRING PAGE ,132

; (C) Copyright Mlcrostress Corporation 1984, 1985, 1986 COMMENT *

MOVSTR Is a routine designed to be called from FORTRAN as a subroutine to move a string into another string.

Mode of use:

call MOVSTR (deststr,Inidest,eosf,sourstr,inisour,Iength)

where

deststr « destination string name.

Inldest * character in "deststr" where the new string will go. eosf = end-of-string flag to extract (*1) or to insert (=0). sourstr * source string name.

56 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

Inisour ■ character in "sourstr" where the substring starts, length * number of characters to be contained by the substring.

This routine does not check the proper bounds of the indices "inidest" and "inisour", but it does check the validity of "length".

*

SUBTTL FORMAL DECLARATIONS PAGE

csmovs SEGMENT 'CODE*

ASSUME CS:csmovs

SUBTTL MOVSTR - EXECUTABLE CODE PAGE

PUBLIC MOVSTR MOVSTR PROC FAR

PUSH BP MOV BP.SP PUSH DS PUSH ES

; Handle parameters from calling program LES BX,DWORD PTR [BP+22]

MOV cx,ES:[BX]

; Check positive request for location in destination string, push cx cmp cx,0 jIe outbounds LES di.DWORD PTR [BP+26] mov bx,di scanendl:

mov a I,es:[bx] cmp a I,0 je outbounds cmp a I,6 Je outbounds inc bx

loop scanendl

; The location request for the destination string is legitimate, pop cx dec cx add di,cx

LDS BX,DWORD PTR [BP+10] mov cx.ds:[bx]

; Check positive request for location In source string, push cx cmp cx,0 jle outbounds LDS si,DWORD PTR [BP+14] mov bx.si scanend2:

mov a I,ds:[bx] cmp a I,0 Je outbounds cmp a I,6 Je outbounds inc bx

loop scanend2

; The location request for the source string is legitimate, pop cx dec cx add si,cx Jmp numchars

; There was a non-legal request. Exit leaving the strings untouched, outbounds:

pop cx Jmp exit

; Continue with rest of parameters, numchars:

mov ax,ds

LDS BX,DWORD PTR [BP+6] mov cx,de:[bx] cmp cx,0

( continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 57

j Ie exit

LDS BX,DWORD PTR [BP+18] mov dx,ds:[bx] push dx mov ds.ox

; Determine the length of the source string, xor dx.dx mov bx,st scanensour:

mov al,ds:[bx]

Inc dx Inc bx cmp a I,0 jz endsour cmp a I,6 jz endsour cmp dx.cx jl scanensour inc dx

endsour:

dec dx mov cx.dx

; Determine the physical length of the destination string, xor dx,dx mov bx,di scanendest:

mov al ,es:[bx]

Inc dx Inc bx cmp a I,0 Jz enddest cmp a 1,6 Jnz nologend pop ax mov ax,1 push ax nologend:

cmp dx,cx jl scanendest Inc dx

enddest:

dec dx mov cx,dx

; Move the substring from source into destination, rep movsb

; Add an end-of-string byte if extract («1) but not If insert (*0). pop dx cmp dx,0 jz exit mov a 1,6 mov es:[di], aI

; Everything done except housekeeping, exit:

POP ES POP DS MOV SP,BP POP BP RET 18H

MOVSTR ENDP csmovs ENDS

END

memava.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. LoygorrI. July, page 199.

TITLE MEMAVA - FUNCTION TO DETERMINE HOW MUCH MEMORY CAN BE ADDED PAGE ,132

; (C) Copyright by Microstress Corporation 1985, 1986 ; Written by Fernando Garcla-Loygorri

58 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

COMMENT *

MEMAVA is a routine designed to be called from FORTRAN as a function to determine how much memory is available to the last common block as dynamic memory.

Mode of use:

size - MEMAVA (var)

where

var « variable name of the last array in the last common block, size - name of the 4-byte integer variable receiving the return value.

♦

SUBTTL FORMAL DECLARATIONS PAGE

csmema SEGMENT * CODE *

ASSUME CS:csmema

SUBTTL MEMAVA - EXECUTABLE CODE PAGE

PUBLIC MEMAVA memava PROC FAR

PUSH BP MOV BP ,SP PUSH DS

; Get total amount of room In machine, mov ax,40h mov ds,ax mov bx,13h mov ax,[bx] mov cI,6 shl ax,cl

; Get address of parameter from program. LDS BX,DWORD PTR [BP+6] mov dx,ds mov cI,4 shr bx.cl inc bx add dx,bx sub ax,dx

; Convert to words in DX:AX because that ; a 4-byte integer, push ax mov cl,13 shr ax,cl mov dx,ax pop ax mov cl,3 shl ax,cl

; Everything done except housekeeping. POP DS MOV SP,BP POP BP RET 4

memava ENDP csmema ENDS

; Save registers.

; Point to the location in memory where ; DOS keeps the total amount of memory:

; Segment 40h, offset 13h-14h.

; Get number of K In AX.

; Multiply by 64 to get the total number ; of paragraphs (groups of 16 bits).

; Address of the parameter.

; Store the segment to add later.

; Divide by 16 to get the number of ; paragraphs In the offset.

; Increment for the one partially used.

; Add it to the segment.

; Substract it from the total, is where FORTRAN expects the return of

; Save it for later.

; Set to isolate top 3 bits.

; Isolate them by shifting.

; Move them to DX.

; Recover it.

; Multiply by 8 (words/paragraph) by ; shifting 3 pi aces.

; Recover the registers saved.

; Discard the Input parameter.

END

chopwr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

TITLE CHOPWR - SUBROUTINE TO CHECK IF A FILE IS READY TO BE OPEN PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986

( continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 59

COMMENT *

Mode of use:

call CHOPWR (name,flag)

where

name - string with the name of the file to be checked, flag ■ Integer to show success (*0) or error (<>0).

SUBTTL FORMAL DECLARATIONS PAGE

cschow SEGMENT ’CODE’

ASSUME CS:cschow

SUBTTL CHOPWR - EXECUTABLE CODE PAGE

PUBLIC CHOPWR CHOPWR PROC FAR

PUSH BP

MOV BP.SP

push ds

LDS DX,DWORD PTR [BP+101

MOV cx.20h

mov ah,3Ch

Int 21h

jb exit

mov bx,ax

mov ah,3Eh

Int 21h

xor ax,ax

exit:

LDS BX,DWORD PTR [BP+6]

mov [bx],ax

pop ds

MOV SP,BP

POP BP

RET 8

CHOPWR ENDP cschow ENDS

END

brochure.doc

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

—•INTRODUCTION——

The following manual Is presented In a very basic format because it was designed for printing on any printer. This procedure was followed to allow potential users of the MICROSAFE 2-D package to print the ondisk brochure as an assist In evaluating the programs.

The information contained in this brochure has been extracted from the 139 page, 8.5 x 11 Inch manual supplied with the purchased programs. The manual is professionally typeset in a custom binder and contains much more Information about the use of the programs that is summarized here.

The programs are written for In-core finite element solutions of models with any combination of up to 400 nodes, 500 plates, 600 beams and 60 fasteners. The beam elements may have cross-sectional area and moment of Inertia and the plate elements may be triangular or quadrilateral membranes.

This software package was written for the IBM-PC running DOS 2.0. It may also be used with the rest of IBM computers of the PC line, Including the PC/AT. Other computers will be able to run MICROSAFE 2-D as long as they are closely compatible with the IBM-PC.

60 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

The minimum IBM-PC configuration required is one double-sided disk drive and the availability of 448K memory. Bigger memory configurations (up to 704K or the maximum recognized by DOS, whichever is lower) are fully exploited by MICROSAFE 2-D to allow the analysis of models with larger bandwidths. In addition, the plotting program will require a combination graphics monitor/IBM Graphics Display Adapter.

For efficiency reasons MICROSAFE 2-D is a two-part package:

Part one is a program called SAFEPLOT used to present graphical displays of the model along with all input data for accuracy verification and assistance in correcting any data errors.

The SAFEPLOT program generates plots of the nodal diagrams and structural element diagrams as well as the properties, applied loads, imposed deflections, restraints and coordinate values for all elements of the model. Windows are available for the user to see enlarged views of parts of the model. Details too small to be resolved in a larger scale view may thus be displayed.

Part two Is a set of two programs, called SAFESOLV and SAFESOLB, used to conduct the actual structural analysis using the stiffness method finite element analysis for 2-dimenslonal structures. SAFESOLB Is a special version of SAFESOLV used to solve a unique class of problems.

The analysis programs SAFESOLV and SAFESOLB present a commented listing of the input describing the model (optional) and tables of internal loads and stresses for each element. These tables include corner forces tabulated for each element as well as for all nodes, the latter showing the overall equilibrium of forces for the model. Deflections are also presented for all nodes.

In addition, the package includes example input files, and other miscellaneous files to set up the computer and printer and to generate a MICROSAFE 2-D input file.

The package has been written in the FORTRAN language and makes extensive use of machine language routines to increase the speed and the capabilities of the programs.

—TABLE OF CONTENTS OF THE MICROSAFE 2-D MANUAL——————

This Is the table of contents of the MICROSAFE 2-D User’s Manual. Most of the information in this brochure has been extracted and condensed from the manual.

TABLE OF CONTENTS III

PREFACE 1

1 INTRODUCTION 3

1.1 Organization of the MICROSAFE 2-D disks 4

1.2 Set-up instructions for the production disks 6

1.2.1 Setting-up the SAFEPLOT disk 6

1.2.2 Setting-up the SAFESOLV disk 7

1.2.3 Setting-up the SAFESOLB disk 8

1.2.4 Setting-up a data disk 8

1.3 Usage and copying of the MICROSAFE 2-D package 8

2 DESCRIPTION OF FINITE ELEMENTS 11

2.1 Nodes 11

2.2 Beams 12

2.3 Plates 14

2.4 Fasteners 15

3 INTRODUCTION TO MODELING 17

4 DESCRIPTION OF THE INPUT DATA FILE 19

4.1 Overview of the input file 19

4.2 Input file summary 21

4.3 Number of nodes 22

4.4 Number of materials 22

4.5 Number of beams 22

4.6 Number of plates 23

4.7 Number of fasteners 23

4.8 Number of loaded nodes 23

4.9 Number of specified displacements 24

4.10 Node definition 25

( continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 61

4.11 Material definition 26

4.12 Beam definition 27

4.13 Plate definition 29

4.14 Fastener definition 30

4.15 Node loads definition 31

4.16 Freedom restraint definition 32

5 CREATING THE MODEL - INPUT GENERATION 33

6 PLOTTING THE MODEL - SAFEPLOT PROGRAM 35

6.1 Starting the SAFEPLOT program 35

6.2 Running the SAFEPLOT program 36

6.3 SAFEPLOT program command summary 38

6.4 SAFEPLOT program command description 39

6.4.1 Plot a new file 39

6.4.2 Plot beam elements 40

6.4.3 Display beam area values 40

6.4.4 Display beam moment of Inertia values 41

6.4.5 Display beam material codes 41

6.4.6 Display beam numbers 42

6.4.7 Clear screen 42

6.4.8 Plot beam distributed loads 43

6.4.9 Display distributed beam load values 43

6.4.10 Enlarge window 44

6.4.11 Display fasteners 45

6.4.12 Display fastener area values 45

6.4.13 Display fastener numbers 45

6.4.14 Display fastener stiffness values 46

6.4.15 Plot node loads 46

6.4.16 Display node load values 47

6.4.17 Move window 48

6.4.18 Plot nodes 48

6.4.19 Display node coordinates 49

6.4.20 Display node numbers 49

6.4.21 Plot plates 49

6.4.22 Display plate material codes 50

6.4.23 Display plate numbers 50

6.4.24 Print display Image 50

6.4.25 Display plate thickness values 50

6.4.26 Quit program 51

6.4.27 Plot restraints 51

6.4.28 Display restraint vaIues(Imposed displacements) 51

6.4.29 Shrink window 52

6.4.30 Display the model World 52

7 ANALYZING THE MODEL 53

7.1 Choosing between the SAFESOLV and SAFESOLB programs 53

7.2 Starting the solution program

7.3 Running the solution program

8 DESCRIPTION OF THE OUTPUT FILE

8.1 Header

8.2 Listing of input data

8.3 Listing of output data

8.4 Node displacements

8.5 Beam corner forces

8.6 Beam loads and stresses

8.7 Plate corner forces

8.8 Plate load Intensities and stresses

8.9 Plate stresses at node points

8.10 Fastener forces and stresses

8.11 Node internal forces and reactions

9 PROGRAM MESSAGES

9.1 Warning messages

9.2 Error messages

9.2.1 Recoverable errors

9.2.2 Non-recoverab I e error messages A REFERENCES

B MICROSAFE 2-D SUMMARIES B.1 SAFESOLV program B.2 SAFEPLOT program

B. 3 Input file format C EXAMPLES

C. 1 Beam With Multiple Supports C.2 Skin Lap-splice With Fasteners C.3 Spar-bulkhead Intersection C.4 Built-up Transport Airplane Frame C.5 Lame Problem

D PURCHASE FORM INDEX

54

56

59

59

60 62

63

64

65

66

67

68 68 69 71 71 77 77 79 87 89

89

90

91

93

94 98

106

111

121

131

133

62 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

«B«Usage and copying of the MICROSAFE 2-D package===========* ! =========

The BYTE copy of the MICROSAFE 2-D source code is for private use and is not to be distributed in compiled form. Please use the complete MICROSAFE 2-D discs for distribution since they are safer and more complete for a new user.

Users of MICROSAFE 2-D should be aware that both the computer programs and the User’s Manual that make up the MICROSAFE 2-D package fall under the scope of the 1976 Copyright Act and that MICROSTRESS Corporation holds a copyright on them.

MICROSTRESS Corporation does not sell buyers a license to use its programs but actually sells copies of them in a manner similar to the way publishing companies sell books.

The MICROSAFE 2-D programs are not copy-protected. This allows the legal owner to make a back-up copy as a protection against accidental destructIon.

The original disk, the back-up copy or a hard disk copy may be used, BUT ONLY ONE OF THE ABOVE MAY BE USED AT THE SAME TIME.

Any other use would be a violation of the copyright because the user paid for only one copy. On the other hand, there is no restriction on who uses the package or which computer runs it, but if the user wants to run simultaneously several copies of the program each copy must be purchased. Contact MICROSTRESS Corporation about conditions for multiple-copy purchases.

The MICROSTRESS Corporation also authorizes the distribution of copies of the disks included in the MICROSAFE 2-D package, to prospective buyers, only if the following stipulations are satisfied:

* The distribution of copies is for evaluation purposes ONLY. Use of the programs on a regular basis and/or with the intention of applying results is only permitted to those purchasing the MICROSAFE 2-D package.

* No charge whatsoever may be collected, in any form, for the distribution.

* The recipient of the evaluation copy MUST be instructed by the donor, in advance, of these conditions.

* The copy must be COMPLETE, containing ALL the files included in the manufacturer’s release. This is to prevent the evaluation of incomplete copies.

* THE PRINTED MANUAL IS NOT TO BE REPRODUCED. The on-disk documentation is adequate for evaluation with the many examples included. The printed manual contains additional documentation that is necessary for reliable applications of the MICROSAFE 2-D software to the design of structures.

Purchasers of this software will be registered and notified of any enhancements and/or corrections that may be developed as long as their mailing addresses are kept up to date.

The MICROSTRESS Corporation welcomes comments of any kind about the MICROSAFE 2-D programs and this user’s manual. We encourage the users of this package to write to us relating experiences and suggestions to make it a better product.

As a follow up, a three dimensional version of this program is currently in development.

LIMITATIONS OF LIABILITY FOR USE AND THE RESULTS OF USE

The MICROSAFE 2-D software package has been tested by numerous engineers for problems of the type shown In the examples in Appendix C of the printed manual. New applications may uncover application problems beyond these and many other tests that have been run. If problems are detected, please notify the MICROSTRESS Corporation and an attempt will be made to correct the problem.

{continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 63

These programs are provided on an “as Is” basis and the MICROSTRESS Corporation does not guarantee, warrant or make any other representation regarding the use of these programs or the use of results generated from these programs. The user is responsible for the engineering validation of the program’s mathematical results and the suitability of this analysis to the problem being analyzed.

-—DESCRIPTION OF FINITE ELEMENTS—

—Nodes—

Nodes are used to define the shape of the finite element model. A node is dimensionless and has the properties of physical coordinates only.

Each node is Identified by a unique number, an integer between one and the total number of nodes, both Inclusive.

Concentrated loads and node restraints are applied to the nodes of the model to define the load conditions to be analyzed. An adequate number of restraints must be defined to prevent the complete model from being able to translate In the x-direction, the y-direction and from any Inplane rotation.

The idealized model deforms under the effect of the applied loads and restraints. The deformations are represented by translations and rotations of the nodes In the global coordinate system.

The node restraints generate reactions from the combination of applied loads and Imposed deflections. These reactions are presented in the global coordinate system, along with any residual loads at nodes that are not restrained, in the SAFESOLV model solution printed output.

MICROSAFE 2-D allows the user to create a model with up to 400 nodes. The amount of memory (RAM) above 448K increases the available bandwidth for the model rather than allowing more nodes.

Not every node needs to be connected to the structural elements of the model since the program will ignore nodes that are disconnected from all elements.

—Beams—

Beam elements are used to define axial and bending stiffnesses between any two nodes. The shear stiffness terms are omitted since they are insignificant for the vast majority of problems.

Because this version of the MICROSAFE 2-D software is used to analyze models that are two-dimensional the only stiffnesses that are defined are contained within the plane of the model.

The sequence of the nodes defining the beam determines the local coordinate system. The properties of the beam and its internal loads are defined in the context of the local coordinate system.

The cross—sect IonaI area of the beam may be defined as zero to disconnect the element from the rest of the model. The moment of inertia may also be defined as zero to reduce it to a rod.

Beam loads are distributed loads and are defined by values of force per unit of length at each end of the beam. These distributed load end values may be of different magnitude and sign at each end to represent any desired loading. A linear variation is assumed between the two ends of the beam. The loads are converted to statically equivalent node loads at each node of the beam except for the case of rods, where the moments are neglected due to the lack of moment of Inertia.

Up to 600 beams may be included in a model to be analyzed with MICROSAFE 2-D. 7

—Plates—

Plates are used to define the membrane and shear stiffness connecting three or four nodes. The user is free to use any sequence to define the nodes of a plate.

64 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

The geometric properties of the plate are completely defined by the node locations and the thickness, which Is assumed to be constant throughout the plate.

The plates idealized with MICROSAFE 2-D are isotropic, so the material properties in the two orthogonal directions are equal.

The triangular plates used in conventional finite element analysis systems are simple but do not provide precisely symmetrical properties. To avoid this, MICROSAFE 2-D allows the use of quadrilateral plates. The plate Is divided into four triangular plates connecting the centroid with each of the four sides of the original quadrilateral plate. The stiffness contribution of each of the four triangular plates is computed as usual and included in the global stiffness matrix.

A beneficial side effect is a dramatic increase in the effective resolution of the grid (by as much as 40% In some models). The results demonstrate that the quadrilateral plates should be used whenever possible in finite element solutions for more accurate results.

Plates may overlap other plates, as when fasteners are used. Since this is a two-dimensional program, the eccentricity of the plates in the thickness direction will be neglected.

The plate internal axial loads and stresses are defined in the x-axis direction and in the y-axis direction and shears are defined at 45 degrees to the x and y axis. Corner forces are also defined for each node of the plate and are relative to the global coordinate system.

MICROSAFE 2-D allows a model to contain up to 500 plates.

■■■Fasteners--*

Fasteners are used to define a connection between any two nodes. The fastener element transfers an inplane load between the two nodes based on the relative deflection between these nodes and the stiffness of the fastener element. The stiffness is defined for the fastener element explicitly by input and is therefore not a function of the distance between the nodes.

The fastener area Is only used to allow fastener shear stresses to be calculated and Is Irrelevant for the stiffness calculation.

Up to 60 fasteners may be included In a model to be analysed through MICROSAFE 2-D.

—DESCRIPTION OF THE INPUT DATA FILE———————————

...Overview of the input file**

The three programs that make up the MICROSAFE 2-D software package use a common input data file containing all the relevant Information about the finite element model to be analyzed.

When the plotting program Is used to check out the data in a given data file, the user knows It will be correct when run with SAFESOLV.

The Input data file is a group of lines of text in a given order that may be created with any editor or wordprocessing system that produces an ASCII output file.

The MICROSAFE 2-D programs scan the input file sequentially ignoring all lines that do not contain a slash character ( / ); this way the user can mix lines with comments througout the entire file for future reference.

The data area in the lines of the input file is filled with Individual numerical entries. Each entry must be separated from the others by one or more blank spaces and no other punctuation symbols (commas, dashes, ...) are allowed.

For each given line of the Input file the programs expect a certain number of numerical entries and each entry is supposed to be of a certain type and fall within a certain range of values. The entries

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 65

not complying with those rules will be rejected ond o detailed error message will be displayed.

-■■Input file summary—

The Input lines must be ordered In the following manner:

Type

Model size definition

Format Description

NN / Number-of-nodes

NM / Number-of-materla Is

NB / Number-of-beams

NP / Number-of-pIates

NF / Number-of-fasteners

NL / Number-of-Ioaded-nodes

NR / Number-of-lmposed-restralnts

NI NX NY / Node X-coordlnate Y-coordlnate

MI ME MP /

Material Young *s-moduI us Poisson-ratIo

Beam Node -1

Node definition

(One IIne per node untII all nodes are defined)

Material definition (One IIne per material unt 11 all materials are defined)

Beam definition BI BN1 BN2 BA BMI BM BQ1 BQ2 /

Node-2 Area

(One line per beam Moment-of-InertI a Material

until all beams are D.Load-at-node-1 D.Load-at-node-2

defined)

Plate definition PI PN1 PN2 PN3 PN4 PT PM / Plate Node-1

, Node-2 Node-3

(One line per plate Node -4 Thickness Material

untII all piates are defined)

Fastener definition FI FN1 FN2 FA FS / Fastener Node -1 Node-2

Area

(One line per fastener Stiffness

untII all fasteners are defined)

Node loads definition LNI PX PY MZ / Node X-load Y-load Z-moment (One IIne per loaded node untII all node loads are defined)

Freedom restraint definition RNI RC FD / Node Freedom Displacement (One line per restrained freedom unt II all restraints are defined)

All the lines not containing a slash character (/) will be treated as comment lines and Ignored.

Each Input line Is described in detail in the manual. The following is a typical example:

■■■Node deflnItIon=»*

Input: NI NX NY /

DescrIptIon:

NI Is the number of the node defined by the subsequent coordinates. Format: Integer or whole number Range: 1 <« NI <■ NN Units: None

Remarks: No two nodes are allowed to have the same number and no gaps are allowed In the node number sequence which starts with one. See note below.

NX is the x-coordlnate of the node along the x-axls.

NY Is the y-coordinate of the node along the y-axis.

Format: Real

Range: -10E19 <■ NX or NY <« 10E19 Units: Length

Remarks: Several nodes can have the same coordinate values, as when overlapping structure is defined.

Repeat this input line until all nodes are defined.

66 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

.—PLOTTING THE MODEL - SAFEPLOT PROGRAM—

...Starting the SAFEPLOT program===

The input data is verified with graphical displays of the model elements and with properties superimposed as defined by interactive user input.

The following command will run the SAFEPLOT program:

A>d:SAFEPLOT m c I«lnpfspec

The m, c and I-Inpfspec parameters are optional and they may be specified In any order.

The m parameter is used to set the monochrome mode. This option is useful when using a combination monitor/display card that does not work well with colors other than black and white.

The c parameter centers all plot values relative to the element centroid rather than make them stack around it. This is useful in fine grid models where the printed value is large relative to the element.

The i-inpfspec option may be used to specify the file to be plotted. The inpfspec may be any valid DOS file name with drive specification, directory path, name and type as desired. Only the name is required. If not specified, the program will revert to the default drive and to the current directory and an extension of .INP will be automatically added by SAFEPLOT.

For example:

A>B:SAFEPLOT m I-beam C

The program is in drive B: and the Input file Is BEAM.INP in the default drive A:. Both the monochrome and the centering options have been selected.

...SAFEPLOT program command summary————————-—* 1

Command: CODE options

CODE specifies the action to be taken.

CODE Description of function selected with CODE

A Run Another data file - program prompts for file name.

B Plot Beam elements as magenta lines.

BA Display Beam Area values in magenta.

BI Display Beam moment of Inertia values in magenta.

BM Display Beam Material codes in magenta.

BN Display Beam Numbers In magenta.

C Clear screen of alt plotted and displayed data.

D Plot Distributed beam loads as a magenta surface.

DV Display Distributed beam load Values in magenta.

E Get In the Enlarge mode.

B : Move bottom of the box up.

L : Move left side of the box to the right.

R : Move right side of the box to the left.

T : Move top of the box down.

- : Reverse direction of movement.

F Plot Fasteners as cyan lines.

FA Display Fastener Area values in cyan.

FN Display Fastener Numbers in cyan.

FS Display Fastener Stiffness values In cyan.

L Plot nodal Load vectors as cyan arrows.

LV Display nodal Load Values In cyan.

M Move the window - The cursor keys may also be used.

N Plot Nodes as cyan circular symbols.

NC Display Node Coordinate values in cyan.

NN Display Node Numbers In cyan.

P Plot Plates as a white surface.

PM Display Plate Material codes in white.

PN DIsploy Plate Numbers in white.

PR Print display without the "Option to plot?" prompt.

\

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 67

PT Display Plate Thickness values In white.

Q Quit - used to terminate this program run.

R Plot type of nodal freedom Restraints as white symbols.

RV Display node Restraint Values In white.

S Shrink display grid to previous window.

W Display the World - the complete model.

Options are parameters used to specify the request with more detail when necessary. There are two types of options:

Range: Used by commands that plot elements or properties of elements, a range Is a compact form of specifying a list of elements for which the request is made.

The range Is specified with two integers, the first and last values of the range. If both entries are missing. It will plot the entire range, while If only one entry is present, that Item will be plotted.

Direction: Required by the Move command to specify the

direction of movement from the present window. It is specified by a single digit.

Here are some examples:

Option to plot? BA ■> Display all the beam area values.

Option to plot? nn 1 18 *> Display the node numbers for all the

nodes in the range from 1 to 18, both inclusive.

Option to plot? F 23 ■> Plot the fastener numbered 23.

Each command Is described In detail in the manual, In a similar way

to the following examples:

Move window

Command: M CODE

Range: CODE values are 1, 2, 3, 4, 6, 7, 8, or 9.

Effect: Moves the window to the adjacent according to the code value. The the direction of movement In the the number 5 key to the key with by CODE.

window location code values indicate numeric keypad from the number specified

Remarks: The display window may be moved in one of the eight directions around it by using the key layout in the numeric pad to specify the direction:

7 ■ up and left 8 « up 9 ■ up and right

4 m ••ft 5 6 - right

1 * down and left 2 ■ down 3 - down and right

There will be an overlap of about 10% between adjacent windows to allow a good indexing of the images both visually and to create a mosaic of images obtained In a printer (see the PR command). If the desired movement of the window amounts to half-frame or less, the Enlarge command should be used (see 6.4.10).

This command does not enlarge the Image and so the Shrink command will not return the window back to the previous frame from where it was moved but to the previous frame from where the image was actually enlarged.

If numbers are to be entered from the numeric keypad, the Num Lock key may need to be toggled to switch the numeric key pad from the cursor control state to the numeric entry state.

SPECIAL NOTE: The cursor keys uparrow, leftarrow, rightarrow and downarrow and the Home, Pg Up, Pg Dn and End keys will also move the window in the same manner as the Move command described above. They are less cumbersome to use, requiring only to press the key in desired direction relative to the central key with the number 5.

68 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

■*=Plot nodes*****

Command: N inIt last

Range: 1 <- inlt, last <■ NN

Effect: All the nodes in the specified range of nodes will be

plotted as rings in cyan color centered on the location of the node.

If last is omitted only the node inlt will be displayed.

If both init and last are omitted all nodes will be plotted.

—ANALYZING THE MODEL—«— Starting the solution program

The following command will run the analysis program

A>d:SAFESOLV i*Inpfspec o-outfspec e s

The e and s parameters may be in any order including being mixed with the input and output options. The e is used to print an echo of the input data in the output file and s is used to list the output file on the screen at the same time that It is created.

The I«lnpfspec and o*outfspec parameters are also optional inputs. The I«inpfspec option is used to set the input file name. The o=outfspec option is used to specify the file to be used for all printed output. The sequence of the i-inpfspec and o**outfspec options may be reversed. If one or both of these parameter keys and associated filenames are omitted the program will ask for the missing file names during the run.

The inpfspec and outfspec may be any valid DOS file name with optional drive specification, directory path and type as desired. If a file type is not specified, the program will use .INP for the input file type and .OUT for the output file type.

The output file may be left completely unspecified (as long as 0* is included) and the program will automatically use the same drive, directory path and name as the Input file and the .OUT extension.

As a special case the output file data can be routed to any legal output devtce known to DOS, In which case no output diskfile will be generated. An example of this is the screen device CON: or the line printer LPT1:. This is useful when screen output or printed output, but not diskfile, Is desired or where insufficient hard disk or RAM disk space is available. The program will ask for another disk if the output fills up the existing floppy disk (see below) but this option is not available with a fixed disk or with a RAM disk.

For example:

B>B:SAFES0LV I-a:beam o» e ■> The program is in drive B:

(also the default), the input file Is BEAM.INP In drive A: and the output file Is BEAM.OUT In the same drive A:. The echo option has been seIected.

C>$AFES0LV i-Beam o»A: «> The program is in the

default drive C:, the input file is BEAM.INP in the default drive C: and the output file Is BEAM.OUT In drive A:. None of the echo or screen options have been selected.

Running the solution program

After the logo of the program is displayed in the screen the program

will evaluate the parameters passed in the command line-If any

and It will prompt for the Input and output file names If missing.

After the Input file has been specified, SAFESOLV will try to locate It. If the program cannot find It, It will print the following message on the screen:

( continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 69

July

ERROR : File "inpfspec" cannot be found. Try again.

The program will then prompt for the proper file specification again.

After the output file has been specified, SAFESOLV will try to set it up.

If the program cannot open the output file, It will print the following message on the screen:

ERROR : File "outfspec" cannot be open. Try again.

The program will then prompt for the proper file specification again.

Once SAFESOLV has located the Input file, It will proceed to read Its contents and will verify Its validity. The screen will show the progress as the data is read from the input file with a string of words progressing across the screen as follows:

Size...Nodes...Materials...Beams...Plates...Fasteners...Loads . Restraints...End

Each keyword corresponds to a block of lines In the input file. The word End marks the completion of the process of reading the input

After reading the input file, it will start the solution of the resulting stiffness matrix.

The structural relationships In the model are represented mathematically by a system of simultaneous equations. The number of equations In the system is equal to the number of degrees of freedom and s reported by the SAFESOLV program prior to solving the system. In plane stress models like those analyzed with the MICROSAFE 2-D package there are three degrees of freedom per node.

The SAFESOLV programs keep the user Informed of the progress In each step by a plotted bar progressing between end marks on the screen. This helps to give an Idea of the amount of time required to finish

The entire process will take only a few seconds for simple models like the beam shown In Appendix C or several minutes for bigger models For example. It takes approximately 5 minutes for 100 node, well-ordered models like the spar-bulkhead or frame examples in the same Appendix.

The 8087 coprocessor chip significantly reduces the above solution t mes. If Installed, all the programs in the MICROSAFE 2-D package will take advantage of its presence. The switch to the 8087 is automatically performed by the programs and no user Intervention is required.

The solution time for a matrix is very sensitive to the bandwidth encompassing the element stiffness terms in the stiffness matrix. The bandwidth depends on the order selected for the node numbering.

Once SAFESOLV has solved the system of simultaneous equations, it will proceed to write the results to the output file. The screen will show the progress as the data is written with a progression of words like:

Displacements...Beams...Plates...Fasteners...Reactions...End

The program then finishes by reporting the total amount of time required to analyze the model for future reference and returns control to the operating system.

—DESCRIPTION OF THE OUTPUT FILE—

The SAFESOLV programs report all the information In a single output

file. The name and destination -drive, directory path- of the

output file is specified by the user at the beginning of each run.

The output file is a plain text file. In ASCII form, and does not contain any special control characters other than the standard carriage-return/Iine-feed at the end of each line

70 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

The first lines of the output file generated by SAFESOLV contain a header that is handy to quickly identify the run. For example:

MICROSAFE - STRUCTURAL ANALYSIS BY FINITE ELEMENTS

Version: SAFESOLV (2-D) Rel. 1.0 4/02/1985 1:00:00

Input data file : A:BEAMTEST.INP Output data file : C:BEAMTEST.OUT

It shows the date and time of day when the file was created and the data files involved. It also displays the version and release number of the MICROSAFE 2-D package used.

The input data is displayed in labeled tables as the program progressively reads the input file. All short form inputs, input positional values and restraint codes are enhanced/translated to form a complete readable model data description.

*«List ing of input data==*

The program starts by displaying the parameters that define the size of the mode I:

SIZE OF THE STRUCTURE

Number of nodes : 25 Number of materials : 2 Number of beams : 24 Number of plates : 36 Number of fasteners : 0 Number of loaded nodes : 7 Number of restrained degrees of freedom : 3

and continues with the node coordinates definition:

NODE COORDINATES

Node Coordinate X Coordinate Y

1 .00000

2 20.00000

3 40.00000

4 60.00000

5 10.00000

.00000

6.00000

12.00000

18.00000

7.50000

In the same order that they are specified in the file, not necessarily in a sorted form. The following table presents the material codes definition:

MATERIAL PROPERTIES

Code Young's modulus Poisson's ratio

1 10500000.

2 10500000.

3 10700000.

4 400000.

.33000

.33000

.30000

.11000

and then the program displays the tables with the properties for the

different types of elements- beams, plates and fasteners- in this

order. If one or more types of elements are missing from the model definition, the corresponding tables will not be included.

The table containing the beam properties looks like:

BEAM DATA

Beam

I

J

Length

Area

M. Inertia

Material Distributed Loads

1

1

2

20.881

.2000

.00020

1

.000

.000

2

2

3

20.881

.2000

.00000

1

.000

.000

3

3

4

20.881

.2000

.00512

2

.000

.000

4

8

9

13.396

.2200

.00000

2

.000

2500.000

5

9

10

13.396

.2200

.06250

1

2500.000

5000.000

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 71

6 10 11 13.396 .2200 .12500 1 5000.000 5000 000

7 15 16 6.100 .2400 .00000 1 .000 . 000

The labels I and J are used to represent the end nodes of the beam. After the beam data table comes the table with the definition of the plates:

PLATE DATA

Plate I J K

112 5

2 15 8

3 2 3 6

4 2 9 5

L Thickness Material

0 .05000 3 12 .05000 3 0 .05500 4 0 .06000 4

The labels I, J, K and L are used to represent the corner nodes of the plate.

The last element table will contain the Information about the defined fasteners:

FASTENER DATA

Fastener I J Area Stiffness

1 7 22 .250000 5000000.

2 8 23 .250000 0.

WARNING : The fastener 2 has been disconnected from the model.

3 9 24 .250000 5000000.

As Is the case with the beams and plates, a warning message will be Included when a given element Is disconnected from the model.

The labels I and J are used to represent the end nodes of the fastener.

The last tables of the echoed Input data correspond to the node loads and the node restraints and they look like this:

Table captionNODE LOADS

Node

PX

PY

MZ

4

.00

1000.00

.00

11

.00

2000.00

670000.00

18

.00

5000.00

.00

25

5000.00

5000.00

.00

MOVEMENT

RESTRAINTS

Node

Type of

restraint

DI sp 1 acemei

1

Translation

along X axis

.00000

1

Rotation about Z axis

.00000

4

Trans 1 at Ion

along X axis

.00000

4

Trans 1 at Ion

along Y axis

.02500

4

Rotation about Z axis

.00000

The labels PX, PY and MZ are used to represent the node loads in the x-axis and y-axls directions and the torque around the z-axis respect Ively.

*»-L I s11 ng of output dat Quu»u»B»iH»uH aUB „ a , ul „„ UISS3E

Th« information generated by SAFESOLV about the stato of the deformed model is always written to the specified output file with no options to be specified* Again* to see the output data on the screen the user must specify the s option in the command line.

72 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

Like the Input data, the output data Is displayed In labeled tables as the SAFESOLV program progressively generates It. The following Sections explain in some detail what the different columns in the different tables report.

Because of the huge amount of output data generated by SAFESOLV for even mid-sized models, the program constantly monitors the amount of space available in the disk where the output file is being written to prevent a fatal '‘disk full*' system error which would terminate the run.

If the disk becomes full in the process of writing the output data, SAFESOLV will trigger a recovery process to allow the data to be split across different diskettes. This process will be repeated as many times as necessary.

■■■Node dispIacements»««

The first table of the output data is always the listing of the displacements of the nodes in the three degrees of freedom. The table has the following format:

NODE DISPLACEMENTS

Node U

V Omega

1

2

3

5

.000000

2.190833

2.190039

.000000

.000000

-.000137

-.000230

.000000

.000000

-.028178

-.012243

.000000

Note that the nodes that happen to be disconnected from the model are not Included in this table. Node displacements at the indicated node are presented in a right handed Cartesian coordinate system.

The U parameter represents the nodal deflection in the x-dlrection with positive x being to the right.

The V parameter represents the nodal deflection in the y-direction with positive y being up.

The Omega parameter represents the nodal rotation with positive being defined as counter-clockwise.

—Beam corner forces—

Beam corner forces are presented as loads applied to the Indicated ends of the beam elements.

BEAM CORNER FORCES

Beam

I

J

FXI

FYl

MZI

FX2

FY2

MZ2

1

1

2

-748.

134.

27455.

-212.

-134.

-1736.

3

2

3

212.

134.

1736.

-212.

226.

-21576.

4

3

4

512.

-226.

21576.

-512.

226.

27585.

Note that the beams that happen to be disconnected from the model are not included in this table.

Data for node I, which corresponds to the first node of the beam, correspond to forces and moments with labels ending in the numeral 1. Data for node J, which corresponds to the second node of the beam, correspond to forces and moments with labels ending in the numeral 2.

These forces are defined in the global, right handed, Cartesian coordinate system.

The FXI parameters represent the corner forces in the x-direction with positive x being to the right.

The FYl parameters represent the corner forces in the y-direction with positive y being up.

The MZi parameters represent the end moments around the z-axis with a positive value being counterclockwise.

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 73

July

For each beam, the reported corner forces must be In static equilibrium with the applied beam distributed loads. For example, In the case of beam 1 above there Is equilibrium In the y-dlrection with no distributed load applied In that direction, while the distributed load applied In the x-dlrectlon amounts to 960 units, balancing FX1 and FX2.

—Beam loads and stresses—

Beam Internal loads and stresses are presented In relation to the beam element local coordinate system In the following manner:

BEAM LOADS AND STRESSES

Beam

I

J

PAX

SAX

SHI

SH2

BMI

BM2

1

1

2

-134.

-43.

-748.

212.

-27455.

-1736.

3

2

3

-212.

-55.

-134.

226.

-1736.

-21576.

4

3

4

-226.

-72.

-512.

-512.

-21576.

27585.

Axial load (PAX) represents the force along the axis of the element, which coincides with the local x-axls and Is defined as being positive from node I to node J. Axial tension is positive and axial compression Is therefore shown as negative.

The axial stress (SAX) follows the same sign conventions as PAX.

The SHi parameters represent the shear forces at both ends of the

beam. The shear at the second node (SH2) is defined along the local positive y-axis, located 90 degrees counter-clockwise from the x-axls. The shear at the first node (SHI) is defined In the opposite direction to SH2.

The BMi parameters represent the bending moments at the ends of the beam. Positive bending Is defined as producing compression in the positive y-surface of the beam. Therefore, the positive bending moment at the second node (BM2) Is counterclockwise and

the positive bending moment at the first node Is clockwise.

»==Plate corner forces**®*

Plate corner forces are presented as forces applied to the nodes at

the corners of the plate element.

PLATE CORNER FORCES

Plate I

J

K

L FXI •• v FYI

FX2

FY2

FX3

FY3

FX4

FY4

1 1

2

5

0 -5751. -1883.

824.

2306.

4927.

-423.

0.

0.

2 2

3

10

9 -6735. -2116.

3141.

-125.

2461.

2997.

1132.

-756.

4 2

9

5

0 3292. -1345.

1310.

1703.

-4602.

-358.

0.

0.

5 2

6

9

0 -3891. -1370.

2731.

2703.

1160.

-1333.

0.

0.

The plates that happen to be disconnected from the model are not included In this table. Data for node I, which corresponds to the first node defined for the plate, Is presented under labels ending in the numeral 1. Data for nodes J, K and L is presented in a similar way.

These forces are defined in the global, right handed, Cartesian coordinate system.

The FXi parameters represent the corner forces In the x-direction with positive x being to the right.

The FYi parameters represent the corner forces In the y-dlrection with positive y being up.

For each plate, the reported corner forces must be In static equilibrium. The user may check that it is true by adding all the corner forces of each plate in a given direction, as is the case in the example table shown above.

**«Plate load intensities and stresses—

74 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

The table following the plate corner forces displays the plate load intensities and stresses and looks like:

July

Table captionPLATE LOAD INTENSITIES AND STRESSES

Plate

TMAX

I

J K L Ang 1 e

PIX

PIY

TXY

1

22282.

1

2 5 0 62.

1461.

237.

931.

2

9806.

2

310 9 64.

811.

212.

388.

4

8427.

2

9 5 0 84.

1151.

327.

89.

5

14446.

2

6 9 0 55.

683.

173.

676.

SX

SY

TAU

SMAX

SMIN

29219.

4740.

18620.

39262.

-5303

16225.

4233.

7758.

20035.

424

23012.

6542.

1790.

23204.

6349

13657.

3455.

13515.

23002.

-5890

The PIX, PIY and TXY values represent the plate load intensities in the x, y and xy directions respectively.

The SX, SY and TAU values represent the plate stresses in the x, y and xy directions respectively.

The SMAX, SMIN and TMAX values represent the plate principal stresses: maximum axial stress, minimum axial stress and maximum shear stress.

The Angle parameter shows the orientation of the principal stresses In the global coordinate system.

The principal stress data are calculated with the traditional Mohr’s circle method.

The xy direction is used to indicate the 45 degree diagonal between the x and y axes for shear flows (TXY) and shear stresses (TAU).

For quadrilateral plates, the stress matrix is formed by assembling the stress matrices of four Individual triangular plate elements. This method prevents the unsymmetricaI error associated with the usual stiffness matrix for a two-plate idealization of a quadrilateral plate. The data values presented are an average of the values of the triangular subelements.

■—Plate stresses at node points—

The SAFESOLV program presents average stresses for the plate elements at each node. This Is done In a table similar to the following examp Ie:

PLATE STRESSES AT NODE POINTS

Node Coord- X Coord- Y SX SY TAU SMAX SMIN TMAX Angle

1 .00000 .00000 24478. 8639

2 40.00000 12.00000 22816. 4372

3 80.00000 24.00000 13179. 2650

5 120.00000 36.00000 7465. 9091

6 20.00000 15.00000 19249. 8462

21085. 39081.

-5965.

22523.

55

11074. 28005.

-817.

14411.

65

8483. 17898.

-2070.

9984.

61

8306. 16623.

-67.

8345.

42

13414. 28313.

-602.

14458.

56

Only the nodes that are used to define plates will be included in the table.

These averages are derived from the stresses in actual triangular plates and in triangular subelements used in the idealization of quadrilateral plates. For this reason stresses may be higher or lower at the nodes than the average plate element stresses shown In the previous Section.

■■■Fastener forces and stresses—

After the plate data has been reported in the output file, SAFESOLV

includes a table with forces and stresses In the fasteners-If any

are present:

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 75

Table captionFASTENER FORCES AND STRESSES

Fastener

I

J

FX

FY

F

Ang 1 e

Stress

1

7

22

88.

-1.

88.

-1.

351.

2

8

23

29.

2.

29.

3.

115.

3

9

24

84.

-1.

84.

-1.

334.

Node I corresponds to the first node of the fastener and node J corresponds to the second node.

The FX and FY values represent the fastener load transfer In the x and y directions respectively.

The F and Angle values represent the vector sum of the load transfer

components and its line of action relative to the global x-axis.

The Stress value represents the fastener shear stress due to load transfer.

=«Node internal forces and react ions—

A summation of all element corner forces and applied nodal loads for

each node is presented in this section. The results of this summation

show the reaction forces for each node.

NODE INTERNAL FORCES AND REACTIONS

Node Coord-X

Coord-Y

FX

FY

MZ

1 .00000

.00000

-748. Reaction

134.

React ion

27455.

React ion

2 .00000

96.00000

0.

0.

0.

3 432.00000

96.00000

0.

0.

0.

4 432.00000

.00000

-512. Reaction

226.

React ion

27585.

Reaction

The coordinates for each

node followed by the force in

the x

direction, the

i force In

the y-dlrectlon

and

the moment

In the

z

Table captiondirection are presented.

If the model idealization results In a poorly or Ill-conditioned matrix, the inaccuracy will be shown as a nonzero value for nodes with no restrained degrees of freedom. Each restrained degree of freedom is Indicated by the word Reaction printed after the force value to aid In identifying the reactions. A review of this data is necessary to prove the accuracy of the solution.

—PROGRAM MESSAGES—————————————

There are three kinds of messages that the MICROSAFE 2-D programs

provIde:

Informative messages: The ones the programs use to keep you up to date about what they are doing.

Warning messages: The programs inform the user of facts that may be right but, if wrong, may have disastrous consequences.

Error messages: Diagnostics the programs make when they encounter a

situation they cannot handle and that requires some changes to be introduced by the user.

The following is a sample of the Section In the manual that describes

the error messages:

Message:

ERROR : INCOMPATIBLE TYPE OF NUMERIC ENTRY IN INPUT LINE.

Encountered In line 1066 of file WRNGTYPE.INP.

|108 192 199 2.4 0 .020 1 /|

Reading properties of plate 108 it was expected to find the index of the third node of the plate - an integer between 1 and 400 - as the fourth entry.

Occurrence: Both the SAFEPLOT and the SAFESOLV programs.

76 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

Explanation: One of the entries In the line is of a type (integer, real, ... ) incompatible with the type of the expected data.

The arrows in the error message point to the character responsible for the type change and the following message states the required type for the entry.

Action: Check the input file and replace the entry with the Incorrect type.

Execute the program again with the modified input file.

—EXAMPLES—————————————————————————

Beam With Multiple Supports

This example shows the program in one of its simplest uses. The model, specified In file BEAM.INP, represents a beam of constant properties with fully fixed supports at the left end and a simple support near mid-span. A 500 pound per inch distributed load is applied between the supports and nodal loads are applied at the free end of the cantilevered portion of the beam.

THIS IS FILE BEAM.INP AND WAS USED FOR EXAMPLE #1 IN THE DOCUMENT This model represents a beam fixed at the left end with a mid-span support.

The left span has distributed loads and the right end has concentrated loads.

9 / # nodes

1 / # materials

8 / # beams

0 / # plates

0 / # fasteners

1 / # loaded nodes

4 / f specified displacements

1 0.0 0.0 / nodal coordinates

2 2.5 0.0 /

3 5.0 0.0 /

4 7.5 0.0 /

5 10.0 0.0 /

6 15.0 0.0 /

7 20.0 0.0 /

8 25.0 0.0 /

9 30.0 0.0 /

1

10

.3E6 0.33 /

material

propertIes

1

1

2

0.5

1.0

1

-500.

-500.

/ beams

2

2

3

0.5

1.0

1

-500.

-500.

/

3

3

4

0.5

1.0

1

-500.

-500.

/

4

4

5

0.5

1.0

1

-500.

-500.

/

5

5

6

0.5

1.0

1

0.

0.

/

6

6

7

0.5

1.0

1

0.

0.

/

7

7

8

0.5

1.0

1

0.

0.

/

8

8

9

0.5

1.0

1

0.

0.

/

9 1000. -500. 10000. / applied nodal loads PX PY MZ

1 1 0.0 / specified displacements

1 2 0.0 /

1 3 0.0 /

5 2 0.0 /

—Skin Lap-splice With Fasteners—————————————

The lap-splice model represents two .050 Inch thick sheet metal rectangles that are fastened together with three fasteners. The sheet metal parts are defined in separate regions so that they do not overlap and thus the plot of each part does not interfere with the plot of the other part.

Fasteners transfer loads from one node to another according to the relative deflections of the nodes, and the actual locations of the

nodes are Ignored. For this reason parts being fastened together may be located anywhere the user desires.

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 77

THIS IS FILE SPLICE.INP : EXAMPLE #2o IN THE MANUAL. The model represents two pieces of sheet metal, represented by QUADRILATERAL plates, fastened together with three rivets. These pieces are positioned s1de-by-sIde to avoid overlapping and allow the plots to be easier to see.

30 / number of nodes

1 / number of materials

0 / number of beams

16 / number of plates

3 / number of fasteners

3 / number of loaded nodes

6 / number of restrained degrees of freedom

1

0.2

0 / node defin11Ions

2

1.2

0 /

3

2.2

0 /

4

3.2

0 /

5

4.2

0 /

6

0.2

1 /

7

1.2

1 /

8

2.2

1 /

9

3.2

1 /

10

4.2

1 /

11

0.2

2 /

12

1.2

2 /

13

2.2

2 /

14

3.2

2 /

15

4.2

2 /

16 0 3 /

17 1 3 /

18 2 3 /

19 3 3 /

20 4 3 /

21 0 4 /

22 1 4 /

23 2 4 /

Other example models are defined on the MICROSAFE DISK #1

********** MICROSAFE 2-D PURCHASE FORM **********

Purchased from: MICROSTRESS Corporation 10950 FOREST AVE SO. SEATTLE. WASHINGTON, 98178

Federal Tax No. #: 91-1287902

Wash. State Tax #: C 600 572 139 Purchase date: / /

PRODUCT DESCRIPTION

QTY

PRICE PRICE EACH EXTENDED

SAFESOLV and SAFESOLB - solution program

$50

SAFEPLOT - plotting program

$50

MICROSAFE PACKAGE - all above programs

$75

TOTAL PURCHASE PRICE «

PLEASE MAKE CHECKS PAYABLE TO: MICROSTRESS Corporation

The above amounts include state and local taxes within Washington state and all postage within the USA. Please include appropriate postage and instructions for mailing outside of the USA.

Formal documentation is included with all programs shown above.

78 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

The undersigned has read the "Usage and Copying of the MICROSAFE 2-D package" and "Limitations of Liability for Use and the Results of Use" sections of the MICROSAFE 2-D Manual Brochure and agrees to abide by these terms and conditions.

MAILING ADDRESS:

Signature

_ name

_ street address or P.0, box

_ city, state and ZIP code

/

setstr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE SETSTR - SUBROUTINE TO MARK THE PHYSICAL END OF A STRING PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986

COMMENT *

SETSTR is a routine designed to be called from FORTRAN as a subroutine to mark the physical end of a string at the location specified by the Input.

Mode of use: where

cal I SETSTR (i.string)

i - index to specify the location in the string of the character where the end-of-strIng mark is to be written, string ■ name of the string (variable of type CHARACTER) to be marked.

This routine only checks the index "i" is greater than zero. ♦

SUBTTL FORMAL DECLARATIONS PAGE

cssets SEGMENT 'CODE*

ASSUME CS:cssets

SUBTTL SETSTR - EXECUTABLE CODE PAGE

PUBLIC SETSTR SETSTR PROC FAR

PUSH BP MOV BP.SP PUSH ds

LDS BX,DWORD PTR [BP+10]

MOV CX,[BX]

DEC CX

; Check positive request, cmp cx,0 jge inbounds xor cx.cx

; Mark the physical end of the string, inbounds:

LDS BX,DWORD PTR [BP+6]

ADD BX.CX XOR AL,AL MOV [BX],AL

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 79

; Exit.

POP ds MOV SP.BP POP BP RET 8H

SETSTR ENDP cssets ENDS

END

time.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

Note 12

Note 13

Note 14

Note 15

Note 16

Note 17

Note 18

Note 19

Note 20

Note 21

Note 22

Note 23

Note 24

Note 25

Note 26

Note 27

Note 28

Note 29

Note 30

Note 31

Note 32

Note 33

Note 34

Note 35

Note 36

Note 37

POP

BP

RET

10H

time

ENDP

cstime

ENDS

END

pakstr.

asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE PAKSTR - SUBROUTINE TO PACK A STRING PAGE .132

; (C) Copyright Microstress Corporation 1984, 1985, 1986 COMMENT »

PAKSTR is a routine designed to be called from FORTRAN as a subroutine to pack a string by eliminating blank characters at both ends.

Mode of use:

call PAKSTR (string)

where

string - name of the string (variable of type CHARACTER) to be reset.

*

SUBTTL FORMAL DECLARATIONS PAGE

cspaks SEGMENT ’CODE*

ASSUME CS:cspaks

SUBTTL PAKSTR - EXECUTABLE CODE PAGE

PUBLIC PAKSTR PAKSTR PROC FAR

PUSH BP MOV BP,SP PUSH ds

LDS SI,DWORD PTR [BP+6] mov DI,s!

; Scan for the first non blank character scanonbIank:

mov a I,[si]

Inc si cmp a I,32 Jz scanonblank

; Move characters until any end-of-string mark is found, dec si xor cx,cx

scanend:

mov a I,[si] cmp a I,0 jz scanback cmp a I,6 jz scanback mov [di],al Inc 8 I Inc di Inc cx jmp scanend

; Move back until a non-blank character or the beginning of the string is found scanback: 9

cmp cx,0 je logical dec cx

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 81

July

dec dt mov a I, [d i ] cmp a I,32 jz scanback inc dl

; Add a logical end-of-strIng mark If necessary, logical:

cmp dl,sI jz exit mov a 1,6 mov [di],a

; Exit

exit:

POP ds

MOV SP.BP POP BP

RET 4

PAKSTR

END P

cspaks

ENDS

END

confrm.

asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

Note 38

Note 39

Note 40

Note 41

Note 42

Note 43

Note 44

Note 45

Note 46

Note 47

Note 48

Note 49

Note 50

Note 51

Note 52

Note 53

Note 54

Note 55

Note 56

Note 57

pacer.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrf. July, page 199.

TITLE PACER - SUBROUTINE TO PACE THE EXECUTION OF A PROGRAM PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986

COMMENT * *

PACER is a routine designed to be called from FORTRAN as a subroutine to plot a symbol in the screen to show a program is running.

Mode of use:

every time is *

caI I PACER

required to show the pace.

SUBTTL FORMAL DECLARATIONS

PAGE

CSPACE SEGMENT ‘CODE*

ASSUME CS:CSPACE

SUBTTL PACER - EXECUTABLE CODE

PAGE

PUBLIC PACER

PACER PROC FAR

PUSH BP MOV BP.SP mov ah,10 xor bh,bh mov cx,1 mov a 1,176 Int 10h mov ah,3 xor bh.bh int 10h mov ah,2 inc dl int 10h MOV SP,BP POP BP RET

PACER ENDP

CSPACE ENDS

END

logpsI.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

Note 58

Note 59

Note 60

Note 61

Note 62

Note 63

Note 64

Note 65

Note 66

cslogd SEGMENT 'CODE*

ASSUME CS:cslogd

; Image of the logo:

Image D6 DB DB DB DB DB DB DB DB DB DB DB DB DB DB DB

ivvvvvvvvvvvvvvvvvvwvvvvwvvvvvvvwvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv(

V

7

7

7

7

7

7

7

7

7

7

7

7

7

tm

.SAFE

/////////

Stress Analysis using Finite Elements Version : 2-D Release : 1.0

•6688888856666666666658666668686686666668686686666888886868666/ TCompMed from BYTE Magazine source code: Not for d i st r l but ionT e668588585866866886588o668566656666666666668858655666686666666X, Copyright (C) 1985, 1986 by Microstress Corporation 10950 Forest Av. S Seattle, WA. 98178 All rIghts reserved

7

7

7

7

7

7

7

7

7

7

7

7

7

7

Ovvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv]

SUBTTL LOGPSL - EXECUTABLE CODE PAGE

PUBLIC logpsl logpsl PROC FAR

PUSH

MOV

mov

Int

mov

Int

cl I

push

mov

mov

mov

mov

add

mov

mov

xor

push

mov

mov

mov

mov

char:

retracel:

In

test

jnz

retrace2:

In

test

Jz

mov

stosb

Inc

I nc

loop

pop

pop

st i

mov

int

mov

xor

BP

BP ,SP ax ,3 10h

ax,503h 10h

es

ax,40h es ,ax di,63h dx.es:[di] dx, 6

ax,0b800h e8, ax di .di ds

ax.cslogd ds ,ax

si,offset image cx.1279

a I , dx a! .1

retracel

a I ,dx al .1

retrace2 al,[si ]

si

di

char

ds

es

ax,500h 10h

dx.1300h bx.bx

84 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

mov

ah, 2

Int

10h

MOV

SP,BP

POP

BP

RET

logps1

ENDP

cslogd

ENDS

END

intsgn.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

TITLE INTSGN - FUNCTION TO DETERMINE THE SIGN OF AN INTEGER PAGE ,132

; (C) Copyright Microstress Corporation 1985, 1986 COMMENT *

INTSGN Is a routine designed to be called from FORTRAN as a function to return the sign of an Integer.

Mode of use:

sign - INTSGN (integer)

where

sign - value returned by the function, the integer sign, integer - name of the integer (variable of type INTEGER-2) whose sign is requested.

♦

SUBTTL FORMAL DECLARATIONS PAGE

csisgn SEGMENT * CODE *

ASSUME CS:csisgn

SUBTTL INTSGN - EXECUTABLE CODE PAGE

PUBLIC INTSGN INTSGN PROC FAR

PUSH BP MOV BP,SP PUSH ds

LDS BX,DWORD PTR [BP+6] mov cx,[bx] cmp cx,0 Jg positive Jl negative xor ax,ax Jmp exit posItIve:

mov ax, 1 jmp exit negative:

mov ax,0ffffh ; Value Is returned in AX. exit:

POP ds MOV SP.BP POP BP RET 4H

INTSGN ENDP csisgn ENDS

END

[continued]

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 85

July

constr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

TITLE CONSTR - SUBROUTINE TO CONCATENATE TWO STRINGS PAGE .132

: (C) Copyright Microstress Corporation 1984, 1985, 1986

COMMENT * ....

CONSTR is a routine designed to be called from FORTRAN as a

to concatenate two strings.

Mode of use:

call CONSTR (deststr.eourstr)

where

deststr *■ destination string name.

sourstr - source string name to be concatenated to

*

SUBTTL FORMAL DECLARATIONS PAGE

cscons SEGMENT ’CODE*

ASSUME CS:cscon8

SUBTTL CONSTR - EXECUTABLE CODE PAGE

PUBLIC CONSTR CONSTR PROC FAR

PUSH BP MOV BP.SP PUSH DS PUSH ES

j Locate end of the destination string (logical or physical)

LES dI,DWORD PTR [8P+10] dec d! scanendl:

Inc di

mov a I,es:[di] cmp a I,0 je exit cmp a I,6 jne scanendl mov bx.di

; Locate the physical end of the destination string. scanend2:

Inc bx

mov a I,es:[bx] cmp a I,0 jne scanend2 sub bx.di mov dx.bx

; Locate end of the source string (logical or physical)

LDS si,DWORD PTR [BP+6] mov bx,si xor cx.cx scanendsource:

mov a I,[bx] cmp a I,0 Je foundend cmp a I,6 je foundend inc bx Inc cx

jmp scanendsource ; Check if there is enough room, foundend:

cmp dx,cx jge copy

subroutine

••deststr”.

86 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

mov cx,dx

; Tack the source string at the end of the destination string, copy:

rep movsb

; Add a logical end-of-string mark If not physical end already, mov al,es:[di] cmp a I,0 jz exit mov a I,6 mov es:[dl],al

; Everything done except housekeeping, exit:

POP ES POP DS MOV SP.BP POP BP RET 8

CONSTR ENDP cscons ENDS

END

I enstr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

Note 67

Note 68

Note 69

Note 70

Note 71

Note 72

Note 73

Note 74

Note 75

Note 76

Note 77

Note 78

Note 79

Note 80

Note 81

Note 82

Note 83

Note 84

Note 85

Note 86

Note 87

Note 88

Note 89

Note 90

Note 91

Note 92

Note 93

Note 94

Note 95

Note 96

I uly

POP

ds

MOV

SP,BP

POP

BP

RET

4

1enstr

ENDP

cs1ens

ENDS

END

Iwcstr

.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. LoygorrI. July, page 199.

TITLE LWCSTR - SUBROUTINE TO PUT A STRING IN LOWERCASE PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986 COMMENT *

LWCSTR Is a routine designed to be called from FORTRAN as a subroutine to set all the alphabetic characters to lowercase.

Mode of use:

caI I LWCSTR (string)

where

string ■ name of the string (variable of type CHARACTER) to be converted to lowercase.

*

SUBTTL FORMAL DECLARATIONS PAGE

cslwcs SEGMENT ’CODE*

ASSUME CS:cslwcs

SUBTTL LWCSTR - EXECUTABLE CODE PAGE

PUBLIC I westr Iwcstr PROC FAR

PUSH

bp

MOV

bp.sp

PUSH

ds

LDS

BX,DWORD

PTR [BP+61

character:

CMP

BYTE PTR

[bx],0

je

exit

CMP

BYTE PTR

[bx],6

J«

exit

CMP

BYTE PTR

[bx].’A*

JB

next

CMP

BYTE PTR

[bx],*Z*

JA

next

OR

BYTE PTR

[bx],32

next:

INC

bx

Table captionJmp character

exit:

pop

ds

MOV

sp.bp

POP

bp

RET

4

Iwcstr

ENDP

cs1wes

ENDS

END

88 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

modstr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE MODSTR - SUBROUTINE TO MODIFY A STRING BY REPLACING A CHARACTER PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986 COMMENT *

MODSTR is a routine designed to be called from FORTRAN as a subroutine to modify a string by replacing a character in it.

Mode of use:

call MODSTR (deststr,posItIon,asciic)

where

deststr * destination string name.

position « character in "deststr" to be replaced.

ascilc ■ ASCII code of the character to be put in the string.

♦

SUBTTL FORMAL DECLARATIONS PAGE

csmods SEGMENT 'CODE*

ASSUME CSicsmods

SUBTTL MODSTR - EXECUTABLE CODE PAGE

PUBLIC modstr modstr PROC FAR

PUSH BP MOV BP.SP PUSH DS

; Handle parameters from calling program LDS BX,DWORD PTR [BP+6]

MOV ax,DS:[BX]

LDS BX,DWORD PTR [BP+10]

MOV cx,DS:[BX]

LDS bx,DWORD PTR [BP+14]

; Check positive request for location in destination string, cmp cx,0 jle exit dec cx add bx,cx mov [bx],al

; Everything done except housekeeping, exit:

POP DS MOV SP,BP POP BP RET 0CH

modstr ENDP csmods ENDS

f i Istr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE FILSTR - SUBROUTINE TO FILL A STRING WITH A GIVEN CHARACTER PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985

[continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 89

July

COMMENT *

FILSTR i8 a routine designed to be called from FORTRAN as a subroutine to fill a string with a character specified as a parameter.

Mode of use:

cal I FILSTR (l.string)

where

I - ASCII code of the character to be used to fill the string, string ■ name of the string (variable of type CHARACTER) to be

reset.

*

SUBTTL FORMAL DECLARATIONS PAGE

csflls SEGMENT * CODE'

ASSUME CS:csflls

SUBTTL FILSTR - EXECUTABLE CODE PAGE

PUBLIC FILSTR FILSTR PROC FAR

PUSH BP MOV BP.SP PUSH ds

LDS BX,DWORD PTR [BP+10] mov ah,[bx]

LDS BX,DWORD PTR [BP+6]

; Write character until an end-of-strIng mark is found, scanend:

mov a I,[bx] cmp al,0 Jz exit cmp al,6 jz exit mov [bx],ah Inc bx Jmp scanend

; Exit exit:

POP ds MOV SP,BP POP BP RET 8

FILSTR ENDP csflls ENDS

END

sizstr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

TITLE SIZSTR - FUNCTION TO DETERMINE STRING SIZE PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986 COMMENT *

SIZSTR Is a routine designed to be called from FORTRAN as a function to return the size of a string.

Mode of use:

size - SIZSTR (string)

where

size - 2-byte integer returned by the function, the string size, string * name of the string (variable of type CHARACTER) whose length is requested.

90 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

SUBTTL FORMAL DECLARATIONS PAGE

cssizs

SEGMENT

’CODE*

ASSUME

CS:cssizs

SUBTTL

SIZSTR

EXECUTABLE CODE

PAGE

PUBLIC

s 1 zstr

s i zstr

PROC FAR

PUSH

BP

MOV

BP ,SP

PUSH

ds

LDS

BX,DWORD PTR [BP+6]

xor

ax, ax

scanend

:

mov

cl,[bx]

inc

ax

cmp

cl ,0

J«

exit

inc

bx

imp

scanend

; Value

is returned in AX.

exit:

POP

ds

MOV

SP.BP

POP

BP

RET

4h

sizstr

ENDP

css izs

ENDS

END

endstr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

TITLE ENDSTR - SUBROUTINE TO MARK THE LOGICAL END OF A STRING PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986 COMMENT *

ENDSTR is a routine designed to be called from FORTRAN as a subroutine to mark the logical end of a string at the location specified by the i nput.

Mode of use:

call ENDSTR (i,string)

where

i ■ index to specify the location in the string of the character where the Ioglcal-end-of-string mark is to be written, string - name of the string (variable of type CHARACTER) to be marked.

♦

SUBTTL FORMAL DECLARATIONS PAGE

csends SEGMENT ’CODE*

ASSUME CS:csends

SUBTTL ENDSTR - EXECUTABLE CODE PAGE

[continued]

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 91

PUBLIC ENDSTR ENDSTR PROC FAR

PUSH BP MOV BP.SP PUSH ds

LDS BX,DWORD PTR [BP+10]

MOV CX,[BX]

DEC CX

; Check positive request, cmp cx,0 Jge Inbounds xor cx,cx

; Check the logical mark Is not beyond the physical mark. I nbounds:

LDS BX.DWORD PTR [BP+6]

scanend:

mov a I,[bx] cmp a I.0 jz exit cmp cx.0 Jz mark dec cx Inc bx jmp scanend

; Mark the logical end of the string, mark:

mov AL.6 MOV [BX],AL

; Exit, exit:

POP ds MOV SP.BP POP BP RET 8H

ENDSTR ENDP csends ENDS

END

deIf11.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. LoygorrI. July, page 199.

TITLE DELFIL - SUBROUTINE TO DELETE A FILE PAGE ,132

; (C) Copyright Microstress Corporation 1985, 1986 COMMENT *

DELFIL is a routine designed to be called from FORTRAN as a subroutine to delete a file specified with drive (optional), path (optional), name and extension in an ASCIIZ string.

Mode of use:

call DELFIL (flname)

where

flname - name of the file (variable of type CHARACTER) to be deleted.

SUBTTL FORMAL DECLARATIONS PAGE

csdelf SEGMENT * CODE *

ASSUME CS:csdelf

SUBTTL DELFIL - EXECUTABLE CODE PAGE

92 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

PUBLIC delfil deIfiI PROC FAR

PUSH BP MOV BP.SP PUSH ds

LDS dx,DWORD PTR [BP+6]

; Use Function Call from DOS 2.0. mov ah,41h Int 21h POP ds MOV SP.BP POP BP RET 4

delfil ENDP csdelf ENDS

END

locstr.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE LOCSTR - SUBROUTINE TO LOCATE A STRING INSIDE ANOTHER STRING PAGE .132

; (C) Copyright Microstress Corporation 1984,1985, 1986 COMMENT *

LOCSTR is a routine designed to be called from FORTRAN as a function to locate a string inside another string.

Mode of use:

pos ■ LOCSTR (1,stringl,string2)

where

i ■ location where the search in the destination string is to start.

strlngl « name of the destination string (variable of type

CHARACTER) where the source string is to be searched. string2 « name of the source string (variable of type CHARACTER) to be located inside the destination string.

♦

SUBTTL FORMAL DECLARATIONS PAGE

cslocs SEGMENT 'CODE*

ASSUME CS:cslocs

SUBTTL LOCSTR - EXECUTABLE CODE PAGE

PUBLIC locstr locstr PROC FAR

PUSH BP

MOV BP.SP

PUSH DS

PUSH ES

; Handle parameters from calling program LES BX,DWORD PTR [BP+14]

MOV CX.ES:[BX]

; Check positive request, push cx

cmp cx,0

Jle outbounds

LES DX,DWORD PTR [BP+10]

mov bx.dx

scanend:

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 93

July

mov

cmp

Je

cmp

J«

Inc

loop

; The request pop LOS OEC push

o I,es:[bxl a I , 0

outbounds al ,6

outbounds

bx

scanend Is legitimate, cx

BX,DWORD PTR [BP+6]

CX

cx

ADD DX.CX

; Determine the length of the destinotl xor si,si

mov di.dx

scanendest:

mov a I.es:[dI]

Inc si

Inc di

cmp a 1,0

Jz end_dest

cmp a 1,6

Jnz scanendest

end_dest:

on

string.

mov cx,si

push cx

; Determine the length of the source strina xor si,si

mov dl,bx

scanensour:

mov oI,ds:[d1]

Inc si

inc di

cmp a 1,0

Jz end_8our

cmp a 1,6

jnz scanensour

end_sour:

xchg bx,s i

push si

; Locate source string in destination string, scandest:

mov dl,dx

pop si

push si

xor ah,ah

mov a I,ds:[sI]

c I d

repnz scasb

jcxz failure

: F ' rst m«u r ° Ct ^ °' 80Urc « is f ound in destination, check the rest, mov ax,a I

dec di

push cx

mov cx,bx

repz cmpsb

jcxz success

; No complete match, proceed search in destination strina pop cx y

jmp scandest

; The index for the request was out of bounds

outbounds:

pop

xor

jmp

; No match was failure:

cx

ax. ax ex 11

found, return zero.

pop si

pop cx

pop cx

xor ax,ax

jmp exit

; A complete match was found, return success:

location of first character.

94 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

pop

cx

pop

s i

pop

ax

sub

ax,cx

pop

cx

add

o

X

o

X

; Everything

done excc

exit:

POP

ES

POP

DS

MOV

SP, BP

POP

BP

RET

0Ch

locstr

ENDP

cs 1 ocs

ENDS

END

resstr,

.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. LoygorrI. July, page 199.

TITLE RESSTR - SUBROUTINE TO RESET A STRING TO FORTRAN STANDARDS PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985 COMMENT *

RESSTR is a routine designed to be called from FORTRAN as a subroutine to reset a string to FORTRAN standards by removing end-of-string marks and filling the string with blanks.

Mode of use:

cal I RESSTR (string)

where

string ■ name of the string (variable of type CHARACTER) to be reset.

♦

SUBTTL FORMAL DECLARATIONS PAGE

csress SEGMENT 'CODE*

ASSUME CS:csress

SUBTTL RESSTR - EXECUTABLE CODE PAGE

PUBLIC RESSTR RESSTR PROC FAR

PUSH BP MOV BP,SP PUSH ds

LDS BX,DWORD PTR [BP+6] mov ah,32

; Scan for either end-of-string mark, scanend:

mov a I,[bx] cmp al,0 jz physical cmp a I,6 Jz logical Inc bx jmp scanend

; Fill with blanks between logical and physical marks, logical:

MOV [BX],ah inc bx mov a I,[bx]

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 95

]uly

cmp a 1,0 jnz logical

; Remove the physical end of string mark physical:

MOV [BX],ah

; Exit

POP ds MOV SP.BP POP BP RET 4

RESSTR ENDP csress ENDS

END

defdrv.asm

"Structural Analysis." by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE DEFDRV - SUBROUTINE TO GET OR SET

THE DEFAULT DISK DRIVE

PAGE .132

; (C) Copyright Microst ress

Corporation 1984, 1985, 1986

COMMENT *

Mode of use:

call DEFDRV (oper.unit) where y

oper - Integer to specify get (-0) or set (-1).

unit « integer for drive number (0»A,1»B,...).

SUBTTL FORMAL DECLARATIONS

PAGE

csdefd SEGMENT ’CODE’

ASSUME CS:csdefd

SUBTTL DEFDRV - EXECUTABLE CODE

PAGE

PUBLIC DEFDRV

DEFDRV PROC FAR

PUSH BP

MOV BP.SP

push ds

MOV BX,[BPl+10 MOV ax,[BX]

cmp ax,0

Jnz set

MOV ah,19h

Int 21h

mov bx,[bp]+6

xor oh,ah

mov [bxj.ax

Jmp exit

set:

mov bx,[bpl+6

mov dx,[bx]

mov ah.OEh

int 21h

exit:

pop ds

MOV SP,BP

POP BP

RET 8

96 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

DEFDRV endp csdefd ENDS END

dskfre.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorri. July, page 199.

TITLE DSKFRE - SUBROUTINE TO GET THE DISK FREE SPACE AVAILABLE.

PAGE ,132

; (C) Copyright Microstress Corporation 1985, 1986 COMMENT *

DSKFRE is a routine designed to be called from FORTRAN as a subroutine to determine the available disk free space.

Mode of use: where

drive

nscl <

nfcl < ntcl ■ nbys '

♦

call DSKFRE (drive,nscl,nfcl,ntcl,nbys)

« integer variable containing the drive number (0=default, 1-A, etc...)

integer variable containing the number of sectors per cluster or an error flag (=FFFFh).

integer variable containing the number of free clusters. Integer variable containing the total number of clusters, integer variable containing the number of bytes per sector.

SUBTTL FORMAL DECLARATIONS PAGE

csdskf SEGMENT ’CODE*

ASSUME CS:csdskf

SUBTTL DSKFRE - EXECUTABLE CODE PAGE

PUBLIC DSKFRE DSKFRE PROC FAR

PUSH BP MOV BP,SP PUSH DS

; Get the drive number.

LDS BX,DWORD PTR [BP+22]

MOV dx,[bx]

; Call the system function, mov ah,36h Int 21h

; Handle parameters from calling program cmp ax,0FFFFh je exit

LDS si,DWORD PTR [BP+6]

MOV [si],cx

LDS si,DWORD PTR [BP+10]

MOV [si],dx

LDS si,DWORD PTR [BP+14]

MOV [si],bx

; Everything done except housekeeping, exit:

LDS si,DWORD PTR [BP+18]

MOV [si],ax POP DS MOV SP.BP POP BP RET 14H

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 97

July

DSKFRE ENDP csdskf ENOS

END

sizfic.asm

"Structural Analysis," by Robert W. Johnson and Fernando G. Loygorrl. July, page 199.

Note 97

Note 98

Note 99

Note 100

Mode of use: where

size * * fI name

*

Note 101

Note 102

Note 103

Note 104

Note 105

Note 106

Note 107

Note 108

Note 109

Note 110

Note 111

Note 112

Note 113

Note 114

Note 115

98

Note 116

I isptest.doc

"BYSO Lisp and Waltz Lisp,” by William Wong. July, Page 293

"BYSO Lisp Benchmark 1-4-86 WGW"

"Test Loop"

(defun loop-test (fn limit)

(fn) ) )

(defun dummy ())

"CONS Test"

(setq cons-a nil)

(defun cons-test () (cons cons-a cons-a))

"Integer Addition Test"

(setq add-a 1 add-b 2)

(defun add-test () (+ add-a add-b))

"Integer Multiplication Test"

(setq multiply-a 1 multiply-b 2)

(defun mu 11iply-test () (* multiply-a multiply-b))

"Assignment Test"

(setq assign-a '(1 2 3))

(defun assign-test () (setq assign-a assign-a))

"List Indexing Test"

(setq list-index-list '())

(do m 1 (+ II)))

((« i 128))

(setq Iist-index-l1st (cons i list-index-list)) )

(defun list-index () (nth 120 list-index-list))

"Vector Index Test"

(setq vector-test-array (array 'sexpr 128))

(defun vector-index () (aref vector-test-array 120))

"String Index Test"

(setq string-test-array (array 'char 128))

(defun string-index () (aref string-test-array 120))

"Write test creates a new file and writes 64 kbytes to it."

[continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 99

( defun write-test ()

( do-write-test ( open *b:test )

512

( array ’char 128 )

)

)

( defun do-write-test ( file records buffer )

( do 0

(( zerop ( setq records ( - records 1 ))) ( ( prInc buffer file )

) )

; Waltz Lisp Benchmark 1-4-86 WGW

; Test Loop

(def loop-test (lambda (fn limit)

(do ( l 1 ( ♦ I 1 )))

((equal t limit))

(fn) ) ))

(def dummy (lambda ()))

; CONS Test (setq cons-a nil)

(def cons-test (lambda () (cons cons-a cons-a)))

; Integer Addition Test

(setq add-a 1)

(setq add-b 2)

(def add-test (lambda () (+ add-a add-b)))

; Integer Multiplication Test

(setq multiply-a 1 )

(setq multlply-b 2)

(def multiply-test (lambda () (* multiply-a multlply-b)))

; Assignment Test (setq assign-a ’(1 2 3))

(def assign-test (lambda () (setq assign-a assign-a)))

; List Indexing Test

(setq list-index-list ’())

(do ((i 0 (+ l 1)))

((equal i 128))

(setq list-index-list (cons i Iist-lndex-Iist)) ) (def list-index (lambda () (nth 120 list-index-list)))

; Vector Index Test (Arrays Not Supported)

; String Index Test

(setq string-test-array MM )

close file ))

100 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

Chapter Notes

TITLE TIME - SUBROUTINE TO GET THE TIME OF THE DAY PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986 COMMENT * *

TIME is a routine designed to be called from FORTRAN as a subroutine to access the time of the day from the system.

Mode of use:

call TIME (hour.minute,second,hundredth)

where

hour - integer variable containing the hour of the dayth. minute - integer variable containing the minute of the hour, second * integer variable containing the second of the minute, hundredth « integer variable containing the hundredths of the second.

*

SUBTTL FORMAL DECLARATIONS PAGE

cstime SEGMENT ’CODE’

ASSUME CS:cstime

SUBTTL TIME - EXECUTABLE CODE PAGE

PUBLIC time

time PROC FAR

PUSH BP

MOV BP,SP

PUSH DS

; Call the system function, xor ax,ax

mov ah,2Ch

int 21h

; Handle parameters from calling program xor ax,ax

mov al.dl

LDS BX,DWORD PTR [BP+6]

MOV [BX],ax

mov al,dh

LDS BX,DWORD PTR [BP+10]

MOV [BX],ax

mov a I,cl

LDS BX,DWORD PTR [BP+14]

MOV [BX],ax

mov al.ch

LDS BX,DWORD PTR [BP+18]

MOV [BX],ax

; Everything done except housekeeping, exit:

POP DS

MOV SP.BP

80 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

TITLE CONFRM - SUBROUTINE TO CONFIRM AN OPERATION BY PRESSING ANY KEY PAGE ,132

; (C) Copyright Microstress Corporation 1985, 1986

COMMENT * *

Mode of use:

call CONFRM

*

SUBTTL FORMAL DECLARATIONS PAGE

csconf SEGMENT ’CODE*

ASSUME CS:csconf

SUBTTL CONFRM - EXECUTABLE CODE PAGE

PUBLIC confrm confrm PROC FAR

PUSH BP

MOV BP.SP

mov a I,8

mov ah,0Ch int 21h

MOV SP.BP

POP BP

RET

confrm ENDP csconf ENDS END

82 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

TITLE LOGPSL - SUBROUTINE TO PUT IN THE SCREEN THE LOGO OF THE PROGRAM PAGE ,132

; (C) Copyright Fernando G. Loygorri 1984, 1985, 1986

COMMENT *

Mode of use:

cal I logpsI

*

SUBTTL FORMAL DECLARATIONS PAGE

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 83

TITLE LENSTR - FUNCTION TO DETERMINE STRING LENGTH PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986 COMMENT * *

LENSTR i8 a routine designed to be called from FORTRAN as a function to return the length of a string.

Mode of use:

length - LENSTR (string)

where

length - 2-byte integer returned, the string length, string - name of the string (variable of type CHARACTER) whose length is requested.

*

SUBTTL FORMAL DECLARATIONS PAGE

cslens SEGMENT 'CODE*

ASSUME CS:cslen8

SUBTTL LENSTR - EXECUTABLE CODE PAGE

PUBLIC Ienstr I enstr PROC FAR

PUSH BP

MOV BP,SP

PUSH ds

LDS BX,DWORD PTR [BP+6]

xor ax,ax

scanend:

mov cI,[bx]

cmp cI,0

je exit

cmp cl,6

je exit

i nc bx

Inc ax

jmp scanend

; Value is returned In AX. exit:

{continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 87

TITLE SIZFIL - FUNCTION TO DETERMINE FILE SIZE PAGE ,132

; (C) Copyright Microstress Corporation 1985, 1986

COMMENT *

SIZFIL is a routine designed to be called from FORTRAN as a function to return the size in bytes of the file specified by the input.

size - SIZFIL (flname)

4-byte integer returned with th e file size.

* name of the file (variable of type CHARACTER) whose size is requested.

SUBTTL FORMAL DECLARATIONS PAGE

cssizf SEGMENT ’CODE’

ASSUME CS:cssizf

SUBTTL SIZFIL - EXECUTABLE CODE PAGE

PUBLIC SIZFIL SIZFIL PROC FAR

PUSH BP MOV BP.SP PUSH ds

LDS DX,DWORD PTR [BP+6]

; Find first (and only) matching file xor cx,cx mov ah,4Eh int 21h

; Get the current Disk Transfer Address mov ah,2Fh int 21h add bx,26 mov ax,es:[bxl mov dx,es:[bx]+2

; Exit

POP ds MOV SP,BP POP BP RET 4

SIZFIL ENDP cssizf ENDS

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

(do «i 0 (+ I 1)))

((equal I 128))

(setq string-test-array (cat "I” string-test-array)) )

(def string-index (lambda () (substring string-test-array 120 120)))

; Write test creates a new file and writes 64 kbytes to it.

(def write-test (lambda ()

( do-wrlte-test ( outflle "b:test H )

512

string-test-array ) ))

(def do-write-test (lambda (file records buffer)

( do ()

! ( zerop ( setq records ( - records 1 ))) ( close file )) princ buffer file ) ) ))

;; Golden Common Lisp Benchmark 1-4-86 WGW

;; Test Loop

(defun loop-test (fn limit)

(do (( i 1 ( + i 1 ))) f(- I limit))

(apply fn niI) ) )

(defun dummy () )

;; CONS Test (setq cons-a nil)

(defun cons-test () (cons cons-a cons-a))

;; Integer Addition Test (setq add-a 1 add-b 2)

(defun add-test () (+ add-a add-b))

;; Integer Multiplication Test (setq multlply-a 1 multlply-b 2)

(defun multiply-test () (* multlply-a multiply-b))

;; Floating Point Addition Test (setq fp-add-a 1.2 fp-add-b 234324.3)

(defun fp-add-test () (+ fp-add-a fp-add-b))

;; Floating Point Multiplication Test

(setq fp-multiply-a 1.2 fp-muItIply-b 234324.3)

(defun fp-muItIply-test () (* fp-multiply-a fp-muItipIy-b))

;; Assignment Test (setq assign-a '(1 2 3))

(defun assign-test () (setq assign-a assign-a))

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 101

I uly

;; List Indexing Test

(setq I 1st—Index—Iist ’())

(do U\ 1 (+ I 1)))

(- i 128))

(setq list-index-list (cons I Iist-index-Iist)) ) (defun list-index () (nth 120 list-index-list))

;; Vector Index Test

(setq vector-test-array (make-array 128 :ini11 al-eIement nil)) (defun vector-index () (aref vector-test-array 120))

;; String Index Test (setq string-test-array

(make-array 128 :eIement-type ’string-char :initial-eIement 32)) (defun string-index () (aref string-test-array 120))

"Write test creates a new file and writes 64 kbytes to it."

(defun write-test ()

(do-wrlte-test (open "b:test" idirectlon *:output)

512

(make-array 128 :eIement-type ’string-char)

( defun do-write-test ( file records buffer )

(do ()

(( zerop ( setq records ( - records 1 ))) ( close file )) ( prInc buffer file )

pcrack.bas

"Stress Analysis," by D. Lee Petersen and Steven L. Crocuh. July, page 219.

1000 REM

1010 REM PROGRAM PCRACK.BAS IN MICROSOFT BASIC

1020 REM

1030 REM PROGRAM USAGE NOTES

1040 REM (1) USE CONSISTENT PHYSICAL UNITS

1050 REM (2) NUMBER OF ELEMENTS <= 30

1060 REM

1070 DEFINT I-N

1080 OPTION BASE 1

1090 DIM A(30,30),DY(30)

1100 REM-READ BASIC MODEL PARAMETERS

1110 INPUT "CRACK PRESSURE, CRACK LENGTH, NUMBER OF ELEMENTS";P.CL,N 1120 W«CL/(2!*N)

1130 INPUT "MATERIAL PROPERTIES - G,PR";G,PR

1140 REM-SET CONSTANTS

1150 PI-3.14159

1160 CON—G/(PI*W*(1!-PR))

1170 REM - GAUSS-SEIDEL ITERATION PARAMETERS

1180 TOL- .00001 1190 ITMAX-2*N 1200 OMEGA-1.3

1210 REM-INITIALIZE DY AND COMPUTE A MATRIX

1220 FOR 1-1 TO N 1230 DY(I)*0!

1240 FOR J-1 TO N

102 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

r 1250 A(I.J)-C0N/(4!*(J-I)"2 - II)

1260 NEXT J

1270 NEXT I

1280 REM - SOLVE EQUATIONS BY GAUSS-SEIDEL ITERATION

1290 FOR NUM - 1 TO ITMAX 1300 ERRMAX-0!

1310 FOR 1-1 TO N

1320 TEMP-0!

1330 FOR J-1 TO N

1340 TEMP-TEMP+A(I,J)*DY(J)

1350 NEXT J

1360 TEMP«(P-TEMP)/A(I,I)

1370 DY(I)«OY(I)+OMEGA*TEMP

1380 ERRI-ABS(TEMP)

1390 IF ERRI > ERRMAX THEN ERRMAX-ERRI

1400 NEXT I

1410 IF ERRMAX <- TOL THEN GOTO 1460

1420 PRINT USING"ITERATION, MAXIMUM ITERATE ## #.######";NUM;ERRMAX

1430 NEXT NUM

1440 PRINT "ITERATION PROCESS DID NOT CONVERGE AFTER";ITMAX;" ITERATIONS!" 1450 STOP

1460 REM-PRINT RESULTS

1470 PRINT "ELEM CRACK OPENING CRACK OPENING COMPUTED STRESS"

1480 PRINT " (NUMERICAL) (ANALYTICAL)"

1490 DELB-CL/N 1500 X—(CL+DELB)/2!

1510 B-CL/2

1520 CON-2!*(1!-PR)*P*B/G 1530 FOR I - 1 TO N 1540 SIGYY-0!

1550 FOR J - 1 TO N

1560 SIGYY-SIGYY+A(I,J)*DY(J)

1570 NEXT J

1580 X-X+DELB

1590 DD-CON*SQR(1!-(X~2/8~2))

1600 PRINT USING" ## ##•#### ##-#### ######.#";I;OY(I);DD;SIGYY

1610 NEXT I 1620 END

msp.pas

"A Material Selection Program," by Brother Tom Sawyer and Michael Pecht. July, page 235.

PROGRAM MSP;

{ Material selection program {

\ Major sections: Utilities, Fllework, Newbase, Addtobase and Searchbase} jBTS eV 1 ^/® 5 major file handling rev. 9/15/85 tuning etc. 1/20/86 }

|$B-{ (*compiler directive for direct read*)

CONST

maxattributes » 31; maxquaIifiers ■ 10; maxalablen * 20; maxqlablen ■ 10; max items * 300; maxroot * 6;

TYPE

attrnum * 0..maxattr1butes;

Itemnum ■ 0..maxltems; qualnum ■ 0..maxquaIifiers; flag - -1..1;

attrlab - STRING[maxalab Ienl;

quallab ■ STRING[maxqIabIenl;

itemlab - STRING[maxaIabIenJ;

qualifiers * ARRAY[quaInum] OF quallab;

attrdata - (NUL.D1 ,D2,D3.D4,D5.D6,D7,D8,D9,D10);

Itemdata - ARRAY [attrnum] OF attrdata; attrrec ■ RECORD atnum : attrnum; atname : attrlab;

( continued )

BYTE USTINGS SUPPLEMENT • IULY-SEPTEMBER 1986 103

I uly

qlnum : qualnum; qua Is : qua I 1fiers END;

itemrec - RECORD fid ; CHAR; inum ; INTEGER; iname : itemlab; idata : itemdata END;

rankitemrec ■ RECORD rating : INTEGER;

Item ; Itemrec END;

rootname = STRINGfmaxroot]; finamrec * RECORD id : CHAR; rtnam: rootname; name : itemlab END;

Trackrec * RECORD nofiterns : INTEGER; atnum ; attrnum; atrbute ; attrdata; selection ; CHAR; atname ; attrlab; qua I name : qua I Iab END;

markarray * ARRAYTattrnum attrtable * ARRAY |attrnum Itemtable ■ ARRAY | itemnum ranktable * ARRAY[itemnum afile ■ FILE OF attrrec; if i le - FILE OF itemrec; Nfile * FILE OF Finamrec; Tfile - FILE OF Trackrec; strl ® string[80];

OF BOOLEAN;

OF attrrec;

OF Itemrec;

OF rankitemrec;

VAR

exit : BOOLEAN; ch:CHAR;

firoot : rootname; finame ; itemlab; volid : STRING[2];

{Utilities Procedures}

PROCEDURE Center(astringistri); {center a string on the screen}

indent : INTEGER;

BEGIN

indent :* (80 - LENGTH(astring)) DIV 2;

WRITELN(•*:indent,astrIng)

END;

FUNCTION Spa(indent:INTEGER);CHAR; {insert spaces in a write(ln) statement} BEGIN

indent :« indent - 1;

WRITE(*':indent);

Spa :« * •

END;

PROCEDURE Rdupcase(VAR ch:CHAR); {read and capitalize a character} BEGIN

READ(ch);

IF ch IN ['a *..* z * 1 THEN ch :« CHR(ORD(ch) - 32)

END;

PROCEDURE Fixa (istr:strI;VAR a Iab:attrIab);

VAR {Change a string into an attribute label}

J:INTEGER; 5

BEGIN

a I ab :■ M ;

FOR J := 1 TO maxalablen DO a lab CONCAT(aIab.• ’);

104 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

FOR J :* a Iab[J END; {FIxa

1 TO LENGTH(lstr) DO :* Istr[J] ;

{File handling section}

PROCEDURE Getfiname(VAR firoot;rootname; VAR finame:itemIab;

VAR choice:CHAR; VAR exit:BOOLEAN); Create and check new file names, show available data bases} ifiroot is the root name of the data base files} exit Is true if user chooses main menu or files don’t exist} •choice may be changed if no AT or IM files are present}

VAR *

chx : CHAR;

nfrec : finamrec; {global to Proc. Getfiname} tempstr ; strl; nffile : Nfile;

PROCEDURE Showbases(VAR chx:CHAR);

BEGIN

GOTOXYf1,10);

Center(’List of current data base names:'); WRITELN;

RESET(nfflie);

WHILE NOT (EOF(nffile)) DO BEGIN

READ(nff1le,nfrec);

WITH nfrec DO IF id > THEN BEGIN

WRITELN(Spa(25),id,': ’.name); chx :■ id END

END jwhile}

END; jShowbases}

PROCEDURE Addtosearch(VAR fI root:rootname; VAR finame:Itemlab;

VAR exit:BOOLEAN; chx:CHAR);

VAR

found : BOOLEAN; ch : CHAR;

BEGIN

found :■ FALSE;

REPEAT

REPEAT

GOTOXY(1,21);

Center('PI ease type in the LETTER of your choice.');

Center('Press RETURN to EXIT.’);

Rdupcase(ch)

UNTIL (ch IN ['A'..CHX]) OR (eoln);

IF eoln THEN exit TRUE ELSE BEGIN

RESET(nffIle);

WHILE NOT (EOF(nffile)) DO BEGIN

READ(nffiIe,nfrec);

WITH nfrec DO IF id - ch THEN BEGIN

flroot rtnam; flname :■ name; found :- TRUE END {if}

END; {while}

IF NOT found THEN

Center('There is no file with that letter*);

END {else}

UNTIL (found) OR (exit)

END; {Addtosearch}

PROCEDURE Checkatim(firoot;rootname; VAR choice:CHAR; VAR exit:BOOLEAN); {for choices B and C: check to see if attribute/item files have data}

[continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 105

I uly

VAR

ch : CHAR; fnam : strl; atrec : Attrrec;

Itrec : Itemrec; atf I Ie: AfI Ie; itfile: Ifila;

BEGIN

fnam CONCAT(voI id, f I root,’AT.DTA’);

ASSIGN(atfIle,fnam);

RESET(atflie);

READ(atf Me,atrec);

IF atrec.atnum - 0 THEN {no attributes exist}

BEGIN

clrscr; G0T0XY(1,5);

Center(*Sorry but no attributes have been created for that data base.*) WRITELN(Spa(8),*A) Go to the section that creates the attribute table. WRITELN(Spa(8),’B) Exit to the Main Menu.\CHR( 10)) ;

Center('Type In the LETTER of your choice’);

REPEAT Rdupcase(ch) UNTIL ch IN [’A’.’B’l;

IF ch » ’A’ THEN choice ’A’

ELSE exit TRUE END;

CLOSE(atfiIe);

IF (choice * ’C’) AND (NOT exit) THEN BEGIN

fnam C0NCAT(voI id,fI root,•IM.DTA*);

ASSIGN(itflI e,fnam);

RESET(ItfiIe);

READ(!tf Me, Itrec);

IF Itrec.Inum ■ 0 THEN {there is no data}

BEGIN

clrscr; G0T0XY(1,5);

Center(’Sorry but there is no data in that data base.’); WRITELN(Spaf8),’A) Go to the ADD DATA section.*);

WRITELN(Spa(8),’B) Exit to the Main Menu.’,CHR(10));

Center(*Type in the LETTER of your choice’);

REPEAT Rdupcase(ch) UNTIL ch IN [’A’.’B’l;

IF ch - *A* THEN choice :« *B*

ELSE exit TRUE END;

CLOSE(itf Me)

END {if choice - C}

END; {Checkatim}

PROCEDURE NewatIm(fI root;rootname;finame:11emIab;ch:CHAR);

{Create Attribute (AT) and Item (IM) files and initialize first record}

VAR

tempstr: stri; count ; INTEGER; atrec:attrrec; itrec:itemrec; atfile: Afile;

Itflle:Ifile;

BEGIN

WITH atrec DO BEGIN

atnum :■ 0; atname :*= finame; qlnum :=* 0;

FOR count :** 0 to maxqua I I f iers DO quals[count] :« **;

END;

WITH Itrec DO BEGIN

fid :« ch; iname :* finame; inum := 0;

FOR count :* 0 to maxattributes DO idata[count] :* NUL {lowest value}

END;

tempstr :« CONCAT(voI id,f!root,’AT.DTA’);

ASSIGN(atfile,tempstr);

REWRITE(atfile);

WRITE(atfile.atrec);

CLOSE(atfile);

tempstr := CONCAT(voI id,firootIM.DTA’);

ASSIGN(itfile,tempstr);

REWRITE(ltfile);

WRITE(itfile,itrec);

106 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

r

CLOSE(11f tI*);

ENO; {NewatIm|

PROCEDURE NewfI Ie(VAR fI root:rootnam#; VAR f(name:itemlab; VAR exit:BOOLEAN); |Get and verify new data base name}

{Store If not a duplicate else get another name or exit}

VAR *

okay,found : BOOLEAN; chx : CHAR;

I en,temp Int : INTEGER;

Iabstr,tempstr,fnam : strl; atf11e : AfI Ie;

BEGIN

gotoxy(1,21);

Center('PIease type in the name of the new data base.*);

Center('Press RETURN for main menu.'); exit FALSE;

REPEAT

okay :■ TRUE;

WRITELN;

WRITE(Spa(20),'*=> '); READLN(con,labstr); len := LENGTH(Iabstr;;

IF len « 0 THEN

exit :« TRUE (* EXIT *)

ELSE IF len > maxalablen THEN BEGIN

okay :« FALSE;

WRITELN(Spa(20),*A name may not exceed ’.maxalablen,' characters.')

END 7

ELSE

BEGIN {Create a file rootname (first 6 non-space characters)} tempstr :■ labstr; tempint :■ POS(’ '.tempstr);

WHILE tempint <> 0 DO BEGIN

DELETE(tempstr,tempint,1); tempint :-POS(* ',tempstr)

END;

tempint :* len - maxroot;

IF tempint > 0 THEN DELETE(tempstr.maxroot+1.tempint); firoot :■ tempstr;

Fixa(Iabstr,finame);

tempstr :« CONCAT(voIid,fI root,'AT.DTA’);

ASSIGN(atflle,tempstr);

{$ 1 -}

RESET(atflie);

IF IORESULT ■ 0 THEN {duplicate name}

BEGIN

CLOSE(atfile); c I rscr; gotoxyh ,5);

Center('Sorry, but the first six characters of two data base names’)* Center('may not be identical.');

Showbases(chx); gotoxyf1,21);

Centerf’Type in another name please.');

Center(’(Press RETURN for main menu.)’);

OKAY FALSE END

ELSE {add name to list of file names}

BEGIN

RESET(nfflie);

tempint :■ 0; found := FALSE;

WHILE (NOT EOF(nfflle)) AND (NOT found) DO BEGIN

READ(nffIle.nfrec);

IF nfrec.id - ’«’ THEN found TRUE; tempint tempint + 1 END;

IF found THEN tempint :■ tempint - 1;

WITH nfrec DO BEGIN

id :■ CHR(tempint + 65);

( continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 107

rtnam :* firoot; name flname END;

SEEK(nffile,templnt);

WRITEfnffIle,nfrec);

NewatIm(fI root,flname.nfrec.Id)

END {else add name}

l$I+»

END {else create rootname}

UNTIL okay - TRUE END; {Newflle}

PROCEDURE Removef11e(fI root:rootname; flname:itemlab;

VAR exlt:BOOLEAN; chx:CHAR);

{Removes a data base (IM and AT files) and replaces

ft I aID In FInames.DTA with the ’@* character.}

VAR

templnt : INTEGER; found ; BOOLEAN; ans : strl; atf11e:AffIe;

ItfI Ie:If Ile;

BEGIN

Center(*You are about to permanently remove the data base'); WRITELN(Spa(20),flname);

Center(*You must type the word YES (In capitals) to do this.'); WRITE(’-»-> ’); READLN(ans);

IF ans <> ’YES* THEN exit TRUE

ELSE

BEGIN

ans :« CONCAT(voI Id,fI root,’AT.DTA’);

ASSIGN(atfIle.ans);

ERASE(atfIle);

ans :« CONCAT(voIld.fI root,•IM.DTA’);

ASSIGN(11fI I e,ans);

ERASEfitfIle);

RESET(nffIle);

templnt :• 0; found :■ FALSE;

WHILE (NOT EOF(nfflle)) AND (NOT found) DO BEGIN

READ(nffIle.nfrec);

IF nfrec.rtnam ■ firoot THEN found :* TRUE; templnt :* templnt + 1 END;

IF found THEN templnt :* templnt - 1;

WITH nfrec DO BEGIN Id :«

rtnam :* •*; name ”

END;

SEEK(nffIle f tempint);

WRITE(nffIle.nfrec); exit TRUE END

END; {Removeflie}

PROCEDURE ShowtItIe(choIce:CHAR);

BEGIN

clrscr; G0T0XY(1,2);

CASE choice OF

’A*: Center(’CREATE A NEW DATA BASE’);

’B’: Center(’ADD DATA’);

’C’: Center(’SEARCH THE DATA BASE*);

*D*: Center(’REMOVE A DATA BASE*)

END {case}

END; {ShowtItIe}

BEGIN {GetfI name} clrscr;

exit :* FALSE;

j$H

tempstr :* CONCAT(volId, ’FINAMES.DTA’);

ASSIGN(nffI Ie.tempstr);

RESET(nffile);

IF (IORESULT <> 0) AND (choice » *A’) THEN {create the name file}

108 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

BEGIN

REWRITE(nffiI«);

WITH nfrec DO {initialize finame record 0}

BEGIN

id :» ’*•; rtnam :* M ; name :■ ••

END;

WRITE(nffile,nfrec)

END

ELSE IF IORESULT <> 0 THEN {no data bases available}

BEGIN *

Center('There are no data bases available’);

Center(’You will have to create one before doing any further work ')• exit TRUE END

ELSE; {dummy option}

i$I+}

IF NOT exit THEN BEGIN

Showtitle(choice);

Showbases(chx);

CASE choice OF

*A*: Newfile(firoot,finame,exit);

’B’..’D’: Addtosearch(firoot.finame,exit,chx)

END; {case}

IF NOT exit THEN CASE choice OF

*B*,*C*: Checkatim(firoot.choice,exit);

'D* : Removefile(firoot,finame,exit,chx)

END {case}

END;

CLOSE(nffile)

END; {Getflname}

PROCEDURE Searchbase(firoot:rootname; finame;itern Iab); {search data base} VAR

exit : BOOLEAN; fnam ; strI; atable ; attrtable;

Tree : Trackrec;

Trfile : Tfile;

PROCEDURE Wtandrank(VAR It:RanktabIe;atn:attrnum;atrrattrdata;

qIn:quaInum ;wt;INTEGER; wtit:BOOLEAN);

VAR

J.last.baseval.atrval ; INTEGER;

PROCEDURE Rank I 1st(VAR ItrRanktable; Iast;INTEGER);

VAR {selection sort by decreasing rating}

J.K.hdx : INTEGER; switch : BOOLEAN; high : rankitemrec;

BEGIN

FOR J 1 TO last-1 DO BEGIN

switch :« FALSE;

high It[J]; hdx :■ J;

FOR K J + 1 TO last DO

IF It[K].rating > high.rating THEN BEGIN

switch :* TRUE; high :« It[K]; hdx :« K END; {If}

IF switch THEN {must switch places}

BEGIN

It [hdx] :« It[J];

It[j] ;■ high

END

END {for J}

END; {Ranklist}

BEGIN {Wtandrank} baseval :■ ORD(atr);

[continued]

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 109

last :■ It[0].Item.Inum; {# of items in array}

FOR J 1 TO last DO BEGIN

atrval :■ ORD(It[J].1 tern.Idata[atn]);

IF (wtit) AND (atrval > 0) THEN

11[J J•rating :■ It[J].rating + ROUND(wt*ABS(baseval-atrvaI)/qIn)

END;

IF wtit THEN Rank!Ist(It•last)

END; {Wtandrank}

PROCEDURE Searchfor(VAR It:ranktabIe; atnrattrnum; atr:attrdata;

fnam:stri; seI code:CHAR; VAR Zflag:flag);

{Get data from file or from ranktable. It[0] used to pass values to output} VAR

memsrch : BOOLEAN;

J.cnt.last : INTEGER; itrec : itemrec; tempatr : attrdata; itf11e:Ifile;

PROCEDURE Checkrec(VAR cnt:INTEGER);

I look for data in It or on disk}

changes It and uses seI code,tempatr,atr.memsrch, and J}

VAR

match : BOOLEAN;

BEGIN

match :■ FALSE;

CASE selcode OF

*A* ; IF tempatr <- atr THEN match :« TRUE;

*B* : IF tempatr * atr THEN match :« TRUE;

*C' : IF tempatr >« atr THEN match TRUE

END; {case}

IF (memsrch) AND (tempatr ■ NUL) THEN {Include "no data" items} match TRUE;

IF match THEN BEGIN

cnt :* cnt ♦ 1;

IF memsrch THEN {data is in It}

It[cnt] :« It[J]

ELSE {data is on disk}

BEGIN

ItTcntl.ratIng :* 0; {Initialize rating}

ItfcntJ.item :* Itrec END

END {if match}

END; {Checkrec}

BEGIN {Searchfor} cnt :« 0;

Zflag :« 0; {assume no data is present}

last :■ It[0].I tern.Inum;

IF last = 0 THEN {search disk file}

BEGIN

memsrch :« FALSE;

ASSIGN(itfile.fnam);

RESET(Itfile);

READfitfile,Itrec);

It[0].I tern.I name :» itrec.iname; {data base name}

WHILE NOT EOF(itfIle) DO BEGIN

READ(!tfIle.itrec); tempatr :■ Itrec.idata[atn];

Checkrec(cnt);

END;

CLOSE(itfiIe);

IF cnt * 0 THEN Zflag :* -1 {No items found in data base}

END {Iast=0}

ELSE {search array It}

BEGIN

memsrch :■ TRUE;

FOR J :« 1 TO last DO BEGIN

tempatr :» IT[J].1 tern.idata[atn];

Checkrec(cnt)

END;

IF cnt » 0 THEN Zflag 1 {No Items in It fit the new constraint}

110 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

J uly

END; {else}

lt[0].Item.ldata[0] := atr; {desired qualifier value}

IF Zflag <> 1 THEN {change item count. New list or no items in data base}

IT[0].itern.inum :» cnt END; {Searchfor}

PROCEDURE Dumpdata(VAR A :attrtab Ie;VAR IT:ranktable;atn:attrnum;

print;markarray;VAR seI code,I data,dev:CHAR);

{Output list and rating to console or printer}

VAR

devnam : stri; ch,If : CHAR; outf iIe : text;

PROCEDURE PAUSE;

BEGIN

IF DEVNAM - 'con:* THEN BEGIN

GOTOXY(1,24);

Center('Press any key to continue.*); repeat until keypressed; cIrscr END

END; {PAUSE}

PROCEDURE Outlist; {output list and rating}

VAR

j,last.pos,Ioopcount:INTEGER;

PROCEDURE Heading;

BEGIN

GOTOXY(1, 2);

WRITELNfOutffle,'RANKED LISTING':20,'Number of iterns':20,It[0].itern.inum:4); WRITELN(outf!le,'Data Base; ’:18,IT[0].itern.iname,If);

RESET(Trf1le);

WRITELN(outfiIe,'Attribute*:16,'Qualifier *:32,'# of Items':13.If);

WHILE NOT EOF(Trfile) DO BEGIN

READ(TrfI Ie,trec);

WITH tree DO BEGIN

WRITE(outfI Ie,atname:23);

CASE selection OF

'A*: WRITEfoutf1 Ie,' ',A[atnum].qua Is[1],' to *,qual name);

'B*: WRITE(outfiIe,’ *,'equal to *,qualname);

'C': WRITE(outf1 Ie,' ',qualname,' to ',A[atnum].qua Is[A[atnuml.qInum]) END; {case}

WRITELN(outfI Ie,nofItems:5)

END {with}

END; {while}

WRITELN(outf1le,If,' NO.','ITEM ':20,'RATING':9,If)

END; {Heading}

BEGIN {Outlist} c I rscr;

Heading;

last :« It[0].I tern.inum; loopcount:- 1;

FOR J ;« 1 TO last DO BEGIN

WRITELN(outfIle,J:3,': ’,IT[J].I tern.iname,IT[J].rating:6);

IF (J MOD 10 - 0) AND (loopcount <> last) AND (devnam - 'con:') THEN BEGIN Pause;

Heading

END;

loopcount :« loopcount+1 END;

WRITELN(outfI Ie,If, I f) ;

Pause

END; {Outlist}

PROCEDURE Crtdata; { Output the actual data to screen {

VAR ’

J.K.POS,lasta,last I,C : INTEGER;

( continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 111

I os to A[0].atnum;

lost! lt[0].I tern.Inum;

clrscr; GOTOXY(10.2); WRITELN('Dota Base: ’.IT[0].I tern. WRITE(Spa(19));

C 0; {count for

FOR K :■ 1 TO lasta DO IF PRINT[K] - TRUE THEN BEGIN

WRITE(A[K].atname);

C C + 1;

IF C MOD 3 - 0 THEN BEGIN WRITELN;

WRITE(Spa(19))

END

END; {If true}

WRITELN;

FOR J 1 TO losti DO

name);

Iinefeeds}

BEGIN

WRITELN(Spa(5),IT[J].ltem.lname);

C 0;

WRITE(Spa(13));

FOR K :» 1 TO lasto DO BEGIN , ,,

POS:- ORD(IT[J].Item.Idato[K]); IF PRINT[K] - TRUE THEN BEGIN

WRITE(A[K].qua Ie[POS]:20);

C C + 1;

IF C MOD 3 - 0 THEN BEGIN WRITELN;

END {if modi END {If true|

END; {for k|

WRITELN;

IF J MOD 3 - 0 THEN PAUSE

END;

IF last I - 0 THEN

WRITELN(Spo(15),‘No Items fit this condition.’); WRITELN END; {Crtdataj

PROCEDURE Printdata; { Output the actual data to printer} VAR

J.K.POS.lasta.lastl,C ; INTEGER;

BEGIN clrscr;

WRITELN(OutfIle.If); lasta :■* A[0].atnum; c :■ 0;

FOR K 1 to lasta DO IF prlnt[K] *= TRUE THEN c c + 1;

IF c > 3 THEN

WRITEfoutfIle,CHR(15)); {Epson compressed print on} WRITELN(outfile.’Data Base: ’:17,IT[0].I tern.iname,If); lastl :» IT[0].I tern.inum;

WRITE(outfIle, ” :20);

C 0; {count for linefeeds}

FOR K 1 TO lasta DO

IF PRINT[K] - TRUE THEN BEGIN

WRITE(outfIle,A[K].atname);

C :■ C + 1;

IF C MOD 5 = 0 THEN WRITE(outf11e,If,* *:20)

END; {IF TRUE}

WRITELN(outfIle);

FOR J 1 TO lastl DO

BEGIN

WRITE(outfIle,If,IT[J].I tern.I name:20);

112 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

C := 0;

FOR K :■ 1 TO lasta DO BEGIN

POS:« ORD(IT[J].item.idata[K]);

IF PRINT[K] - TRUE THEN BEGIN

WRITE(outfile,A[K].quals[POS]:15,* C :*= C + 1;

IF C MOD 5 - 0 THEN WRITE(outfIle,If,’':20)

END |IF TRUE}

END; {FOR K}

WRITELN(outf Me)

END; {for j}

IF last! « 0 THEN WRITELN(outfI I e, ’ No

WRITELN(outf He, If ,CHR(18))

END; {Printdata}

Items fit this condition.'); {EPSON COMPRESSED MODE OFF}

PROCEDURE Lmenu(VAR I data,devrCHAR);

VAR ans ; CHAR;

BEGIN

GOTOXY(1,22);

Centerf'Type the LETTER of your choice.');

GOTOXYt1,3);

Center('DISPLAY DATA FOR ITEMS IN RANKED LIST.'); REPEAT

G0T0XY(1,7);

WRITELN(Spa(18),'A) List values on the screen.'); WRITELN($pa(18),'B) List values on the printer.'); WRITELN(Spa(18),'C) No data list is desired.'); Rdupcase(ans)

UNTIL ans IN ['A'..'C'];

IF ans - 'C' THEN Idata ;■ 'N'

ELSE

Idata 'Y';

IF ans - 'B' THEN dev :» 'P'

ELSE

dev := 'C*

END; {Lmenu}

BEGIN {Dumpdata}

If := CHR(10); {linefeed character}

WRITELN(If);

IF dev - 'C' THEN DEVNAM 'con:'

ELSE

DEVNAM :« '1st:'; assign(outf1le,devnam);

RESET(outfile);

IF LDATA ■ 'Y' THEN {user wants a listing of the data}

BEGIN '

IF devnam - 'con:' THEN Crtdata ELSE

Printdata;

PAUSE

END;

IF LDATA - 'L' THEN {output ranked list and see if user wants to list data} BEGIN OUTLIST;

Lmenu(Idata,dev)

END;

CLOSE(outfIle)

END; {Dumpdata}

PROCEDURE PICKATTR(VAR A:attrtable; fI root:rootname); VAR {Main procedure for Searchbase}

COUNT,WT ; INTEGER;

ch,chx.se I code,dev,If : CHAR;

OKAY,SHOW,WTIT : BOOLEAN; atn.TEMPatn : attrnum; fnam : strI; atr : attrdata;

July

( continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 113

ITMATTR : Itemdata;

Zflog : flag;

PICKED,PRINT ; markarray;

IT : ranktable;

PROCEDURE GETQUAL(J:INTEGER;VAR atr:attrdata;VAR seI code:CHAR);

K : INTEGER;

QLN : qualnum;

CH.CHX : CHAR;

BEGIN clrscr; gotoxy(12,5);

WRITELN('ATTRIBUTE #’,A[J].atnum,*: \ A[J].atname);

CHX :« *@*; {char that preceeds the letter *A’{

FOR K :■ 1 TO A[J].qlnum DO BEGIN

CHX SUCC(CHX);

WRITELN(Spa(12),CHX:3,*; *,A[j].quals[K]);

END; L Jy

REPEAT

gotoxy(1,22);

Centeri'Type the LETTER of the qualifier that will be the’);

Center(’PIVOT (MINIMUM acceptable value) of your search. *); Rdupcase(ch)

UNTIL CH IN [ * A*..CHX];

GOTOXY(1,22); clreol; WRITELN; cl reol;

QLN :* ORD(CH) - 64; {change letter to qualifier

atr :■ ITMATTR[QLN]; jqual jjl to actual qualifier valued

REPEAT

gotoxyf1,16);

Center('Range Select Ion:*);WRITELN;

WRITELNfSpaf10),'A: Include qualifiers from "A" to "',ch,* M *)WRITELN(Spa(10),*B: Choose qualifier ‘".ch,*" only*);

WRITELN(Spa(10),*C: Include qualifiers from ‘",ch,*" to M, ,chx *"* If) Center(*Type the LETTER of your choice.*);

Rdupcase(ch)

UNTIL CH IN [*A*..*C*]; selcode CH END; {GETQUAL}

PROCEDURE Showattr(VAR Mark:Markarray;VAR chx:CHAR);

{Mark Is not changed by this proc.J

VAR

J,Iast : INTEGER;

BEGIN

last :** A[0].atnum; cIrscr; gotoxyf1,5);

Center(’CHOOSE ATTRIBUTES’);

WRITE(If,Spa(8),'CODE ATTRIBUTE’);

IF last <= 16 THEN WRITELN(lf)

ELSE

BEGIN

GOTOXY(40,7);

WRITELN(’CODE ATTRIBUTE’,If)

END;

CHX ’A’;

IF last <» 16 THEN FOR J 1 TO last DO BEGIN

IF MARK[J] THEN

WRITELN(Spa(4).’CHOSEN: •,A[J].atname)

ELSE

WRITELN(Spa(9l.CHX,’: ’.A[J].atname);

CHX := SUCC(CHX)

END

ELSE

BEGIN

FOR J := 1 TO 16 DO 8EGIN

IF MARK[J] THEN

WRITELN(Spa(4).’CHOSEN: ’,A[J].atname)

114 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

WRITELN(Spa(9),CHX,’: *,A[J].atname);

CHX :« SUCC(CHX)

END;

FOR J :« 17 TO last DO BEGIN

GOT OXY(40,J-8);

IF MARK[Jl THEN

WRITELN(’CHOSEN: •,A[J].atname)

ELSE

WRITELN(’ *,CHX,’: \ A[J].atname);

CHX SUCC(CHX)

END

END {ELSE!

END; {SHOWATTR}

PROCEDURE Getcode(VAR ch,chx:CHAR);

jchx not changed by this proc}

BEGIN

REPEAT

gotoxyf1 ,22);

Centerf’Type a LETTER to choose an item.*);

Center(’Press SPACEBAR when done. ’);

Rdupcase(ch)

UNTIL CH IN [’ \’A\.CHX]

END; {Getcode}

PROCEDURE Getweight(VAR wt:INTEGER); VAR

ch ; CHAR; BEGIN REPEAT

clrscr; gotoxyf1,5);

Center(*SeIect the RELATIVE IMPORTANCE (weight) you wish to assign’); CenterC’to this attribute in the overall selection process:*); G0T0XY(1,8);

WRITELN(Spa(22),*A: GREATEST’);

WRITELN(Spa(22),*B: HIGH’);

WRITELN(Spa(22),’C: MEDIUM’);

WRITELN(Spa(22),*D: LOW’);

WRITELN(Spa(22),*E: LEAST’); gotoxyf1,22);

Center(’Type In the LETTER of your choice.’);

Rdupcase(ch)

UNTIL ch IN [’A*..*E*];

CASE ch OF

’A’:WT :- 50; { MULTIPLE OF TEN USED TO PRODUCE WHOLE NUMBER }

’B*:WT :- 40; | VALUE IN THE RANKING PROCEDURE }

*C*:WT :» 30;

’D’:WT :- 20;

*E’:WT :- 10 END {case}

END; jGetweight}

PROCEDURE SHOWORNO(VAR show:BOOLEAN;numofiterns:INTEGER;zfI:fIag;VAR dev:CHAR); VAR

ans: CHAR;

PROCEDURE Showmenu(VAR ch:CHAR);

BEGIN

GOTOXYf1,22);

Center(*Type the LETTER of your choice.*);

REPEAT

GOTOXY(1,10);

WRITELN(Spa(18),*A) Print ranked list on screen.’);

WRITELN(Spa(18),*B) Print ranked list on printer.’);

WRITELN(Spa(18), *C) No listing desired.’Jf);

Rdupcase(ch)

UNTIL ch IN [*A’..’C’]

END; {Showmenuf

BEGIN {Showorno} clrscr; gotoxy(1,5);

ANS *N*; {ASSUME NO-SHOW DATA}

IF ZFL - 0 THEN

[continued]

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 115

BEGIN

WRITELN(Spa(19).NUMOFItemS,• Items meet your spec!fIcatIons.',If);

Center('Choose an option for listing these items.');

Showmenu(ans)

END {IF ZFL - 0 {

ELSE IF ZFL - -1 THEN BEGIN

Center('The data base has no Items which fit your requIrments.*); ans *C' {force a M no show"}

END

ELSE

BEGIN

Center('There are no Items that fit the new specifications.');

WRITELN;

Center('Choose an option for the PREVIOUS list.’);

Showmenu(ans)

END; {ELSE}

IF ANS - 'C' THEN show FALSE ELSE

show :« TRUE;

IF ans - 'B' THEN dev 'P'

ELSE dev 'C'

END; {Showorno}

PROCEDURE SELECTERR(VAR OKAY,WTIT : BOOLEAN);

VAR

CH : CHAR;

BEGIN

OKAY FALSE; {ASSUME NO REPITITION OF ITEM} cIrscr; gotoxyh ,5);

Centeri’That Item has been selected already');

GOTOXYC1,8);

Center('NOTE: If you reselect the attribute:');

WRITELNfIf,Spa(18),'1) Only qualifiers that are within the range already' WRITELN(Spa(23),'seIected will be used In the data search.');

WRITELN(If,Spa(18),'2) The list will retain its original weighting’); WRITELN(Spa(23),'for this attribute.’); gotoxyf1,21);

Centerf'Type the LETTER "R" to repeat this Item selection.');

Center('Press any other key to make another selection.*);

READ(CH);

IF CH IN ['R'.'r'] THEN BEGIN

OKAY :« TRUE;

WTIT :» FALSE {SAME ATTRIBUTE THEREFORE. DO NOT WEIGHT"TT AGAIN}

END; cIrscr

END; {SELECTERR}

PROCEDURE In I tatr;

{Initialize Itmattr array and create tempfile for tracking selections}

VAR

atr : attrdata;

J : INTEGER; tempstr : strl;

BEGIN

tempstr CONCAT(voI id,'TEMPFILE.DTA');

ASSIGN(trfIle,tempstr);

REWRITE(trflie); atr := NUL;

ITMATTR[0] atr;

FOR J :» 1 TO maxquaI IfIers DO BEGIN

atr :« SUCC(atr);

ITMATTR[J] :« atr END

END; {In I tatr}

PROCEDURE In ItpIckfVAR MARKrmarkarray;VAL:BOOLEAN);

1 1n11 a marker array}

VAR

J : INTEGER;

116 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

BEGIN

FOR J :* 1 TO maxattributes DO MARK[J] :« VAL END; {In?tpIck|

PROCEDURE Keeptrack(numitm:INTEGER; atn-.attrnum; atr:attrdata; sel:CHAR); {Store the search criteria In a temporary file for later output}

BEGIN

IF zflag - 1 THEN numitm 0; {no Items met the requirements}

WHILE NOT EOF(TrflIe) DO READ(TrfiIe,tree);

WITH tree DO BEGIN

nofltems :* numitm;

atnum :« atn;

atrbute ;* atr;

seIect ion :« seI ;

atname ;» A[atn].atname;

qualname := A[atn].quals[ORD(atr)]

END;

WRITE(TrflIe,tree)

END; {Keeptraek}

BEGIN {Pickattr}

If CHR(10); {linefeed character}

COUNT 0;

IT[0].I tern.Inum :« 0; {marks first time through procedure}

{Searchfor uses this number to determine what data to accept} fnam :« CONCAT(voI Id, f I root,*IM.DTA*);

INITatr;

INITPICK(PICKED.FALSE);

REPEAT

SHOWATTR(PICKED.CHX);

GETCODE(CH,CHX);

IF CH <> * * THEN BEGIN

atn ORD(CH) - 64; { change letter to attribute# }

OKAY :« TRUE; WTIT TRUE; {default-no repetition, weight choices}

IF PICKED[atn] THEN SELECTERR(OKAY,WTIT);

IF OKAY THEN BEGIN

PICKED[atn] :■ TRUE; {marker for selected item}

IF WTIT THEN GETWEIGHT(WT);

GETQUAL(atn,atr,selcode);

SEARCHFOR(IT,atn,atr,FNAM.se I code,Zflag);

SHOWORNO(SHOW,IT[0].1 tern.1num.ZfIag,dev); {dev is the output device}

Keeptrack(It[0].item.inum,atn,atr.selcode); {*C**con: *P*«prn:}

IF zflag - 0 THEN {a new list has been generated}

Wtandrank(It,atn,atr,A[atn].qlnum,wt,wt1t);

IF SHOW THEN BEGIN

CH :■ *L*; {Show the ranked list}

DUMPDATA(A,IT,atn,print,selcode,ch,dev);

IF CH ■ *Y* THEN {Dump returned message to list data}

BEGIN

INITPICK(PRINT,FALSE);

PRINT[atn] TRUE; {Mark attribute as selected}

REPEAT clrscr; gotoxy(1,5);

WRITELN(Spa(22),*A) List all attributes.*);

WRITELN(Spa(22),’B) List selected attributes.*); gotoxyM ,22);

Center(*Type in the LETTER of your choice.*);

Rdupcase(ch)

UNTIL CH IN [*A*,*B*];

IF CH - *A* THEN

INITPICK(PRINT,TRUE)

ELSE

BEGIN

REPEAT

SHOWATTR(PRINT,CHX);

GETCODE(CH,CHX);

IF CH <> * * THEN

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 117

BEGIN

TEMPatn :■ ORD(CH) - 64; j Change letter to attrubute#} PRINT[TEMPatn] ;■ TRUE; {Marker for selected item}

END

UNTIL CH - • •

END; {ELSE}

CH *Y*; { Reset value of ch so dump will list data }

DUMPDATA(A,IT.atn.prInt.selcode.ch.dev)

END; {If ch - *Y*}

CH :■ *©' {Prevent accidental exit from main loop}

END {If show}

END {If okay}

END {If ch <> * ’}

UNTIL CH - * *;

ERASE(TrfI Ie)

END; {PICKATTR}

PROCEDURE Loadatr(VAR A:attrtable; flroot:rootname; VAR exit:BOOLEAN);

{Load and check attribute file}

VAR

J : INTEGER; fnam : strI; atf11e : af11e;

BEGIN clrscr;

fnam C0NCAT(volId,fI root,*AT.DTA*);

ASSIGN(atflle.fnam);

RESET(atfI Ie);

READ(atf11e, A[0l);

FOR J 1 TO A[0].atnum DO read (atfIle,a[J]);

CLOSE(atfI Ie)

END; {Loadatr}

PROCEDURE Introsb;

BEGIN clrscr; gotoxy (1,5);

Center(’SEARCH DATA BASE’); wrIteIn;

Centerf'The routine Is used to search for the Items which fit');

Centerf’the values or range of values which you select.*); gotoxyf1,22);

Center(’Press any key to begin.'); repeat until keypressed; cIrscr

END; {Introsb}

BEGIN {Searchbase}

Introsb; exit :« FALSE;

Loadatr(atab le.fi root.ex 11);

IF NOT exit THEN Pickattr(atable.fI root);

END;

PROCEDURE Addtobase(firoot:rootname; fI name:itern lab);

{Collect and store the data for the materials in}

{the MSP system. BTS 11/10/84 rev 4/10/85}

VAR

fdex : CHAR; itdex: INTEGER; atable : attrtable; itable : itemtable;

PROCEDURE GETDATA(VAR A:attrtabIe;VAR I:itemtable; ITDEX;INTEGER;var fdexrchar); VAR {GET ITEM NAME AND VALUES OF EACH ATTRIBUTE}

J.ITMCNT : INTEGER;

CH : CHAR;

NAMSTR : I tern lab;

PROCEDURE FIXI (LSTR:strI;VAR ILAB:I tern Iab);

VAR {CHANGE A STRING INTO AN ITEM LABEL}

J:INTEGER;

118 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

BEGIN ILAB :«

FOR J :■ 1 TO maxalablen DO ILAB CONCAT(ILAB, 1 ’);

FOR J :« 1 TO LENGTH(LSTR) DO ILABfJl :« LSTR[J];

END; {FIXI}

PROCEDURE PIacedata(inum.anum:INTEGER; ch:CHAR);

BEGIN {Put qualifier va

WITH I[inum] DO

CASE ch OF

’A’: Idata

'anum'

:* D1;

’B’: Idata

‘anum^

:» D2;

’C’: Idata

|anum'

D3;

•D’; Idata

|anum’

:« D4;

’E’: Idata

|anum'

:« D5;

’F': Idata

‘anurn*

D6;

*G*: Idata

|anum'

:* D7;

’H’: Idata

'anum^

D8;

T: Idata

|anum'

:* D9;

’J’: Idata

'anum (

D10

’X’; Idata

lanum^

NUL

Table captionEND

Table captionEND; {Placedata}

In the item record’s data array} {ten categories + NUL}

PROCEDURE GetquaI(J,itmcnt;INTEGER);

VAR

K ; INTEGER; ch.chx : CHAR;

BEGIN c I rscr;

GOTOXY(1 ,4);

WRITELN(Spa(15),’Attribute #*,A[J].atnum,*: ',A[J].atname); chx :* {char that is one before the letter ’A*}

FOR K 1 TO A[J].qlnum DO

BEGIN

chx SUCC(chx);

WRITELN(Spa(15),chx:3,': ’,A[J].qua Is[K]);

END;

REPEAT

GOTOXYf1 , 15);

Center(*Type in the LETTER of the qualifier that best describes’); WRITELN(Spa(20) , ’your item”s ’, A[ J] . atname) ;

Center('Type the letter X for "No Data Available"’);

Rdupcase(ch)

UNTIL ch IN [ ’A’. .chx,’X’];

Placedata(Itmcnt,J,ch)

END; {Getqual}

PROCEDURE VERIFYITEM(VAR ITM:1temrec;ITMCNT:INTEGER); VAR {VERIFY DATA FOR AN ITEM.}

CH.CHX ; CHAR;

J,N,Iast : INTEGER;

BEGIN REPEAT c I rscr; gotoxy(1,4);

WRITELN(Spa(18),’VERIFY DATA FOR \ITM.iname,CHR(10)); WRITELN(Spa(17),’CODE ATTRIBUTE QUALIFIER’,CHR(10));

CHX *A*;

Iast :« A[0].atnum;

IF last <» 16 THEN FOR J 1 TO last DO

BEGIN

N ORD(ITM.Idata[J]);

WRITELN($pa(18),CHX,’; •,A[J].atname:20,A[J].quals[N]:14);

CHX SUCC(CHX)

END

ELSE

BEGIN

FOR J 1 TO 16 DO

BEGIN

N ORD(ITM.ldata[J]);

WRITELN(’ ’,CHX,': ’,A[J].atname;20,A[J].qua Is[N]:14);

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 119

CHX :« SUCC(CHX)

END;

FOR J :« 17 TO lost DO BEGIN

N :» ORD(ITM.ldoto[J]);

GOTOXY(40,5+J);

WRITELN(' ’.CHX.*; ’,A[J].atnome:20,A[J].quals[N]:14);

CHX SUCC(CHX)

END

END; {ELSE}

CHX PRED(CHX); {READJUST CODE}

REPEAT

GOTOXY(1,22);

Centerf'Type o LETTER to change on Item or SPACEBAR to continue.'); Rdupcase(ch)

UNTIL CH IN [’ \'A'..CHX];

lost ORD(CH) - 64; { CHANGE LETTER TO ATTRIBUTE #}

IF CH <> ' ' THEN GETQUAL(last,ITMCNT)

UNTIL CH - ' '

END; {VERIFYITEM}

PROCEDURE GETNAME(VAR ILAB:Itemlab); VAR

ch : CHAR; okay: BOOLEAN; len ; INTEGER;

Itnam : stri;

BEGIN clrscr;

GOTOXYfl,4);

Centerf'Please type in the name of the new item.’);

WRITELN(Spa(20),'A name may not exceed ',maxaIabIen,’ characters. ’); REPEAT

okay :•» FALSE:

G0T0XYf5,7);

READLN(con.Itnam);

LEN LENGTH(itnam);

IF LEN > maxalablen THEN BEGIN

GOTOXYfl.22);

Centerf'Too many characters In the name')

END

ELSE

BEGIN

FlXI(Itnam.llob);

REPEAT

GOTOXYfl,22);

Centerf’Press E to change (edit) name. Press C to continue’); Rdupca8e(ch);

GOTOXY(1,21); del line; del line UNTIL ch IN ['C’.’E’];

IF ch - 'C' THEN okay TRUE

END

UNTIL okay END; {GETNAME}

BEGIN {Getdata}

l[0].iname A[0].atname; {database name}

ITMCNT 0;

REPEAT

ITDEX ITDEX + 1;

ITMCNT ITMCNT + 1;

GETNAME(NAMSTR);

ifitmcnt].fId fdex; {file identifier }

itITMCNT1.iname NAMSTR;

I[ITMCNTJ.inum ITDEX; c I rscr; gotoxy(1,4);

WRITELN(Spaf18),A[0].atname);

WRITELN(Spa(18) •’Get attributes for ’,NAMSTR);

FOR J := 1 TO A[0].atnum DO GETQUAL(J,ITMCNT);

VERIFYITEM(I[ITMCNT],ITMCNT);

120 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

Center('Type "Q" to quit, any other key to enter another item.’);

Rdupcase(ch);

UNTIL ch - 'Q';

l[0].inum :« ITDEX; {total number of Items now in the list}

END; {GETDATA}

PROCEDURE Putawayd(VAR I;Itemtable; f1 root:rootname);

VAR {Save items to file}

J.fnsh : INTEGER; fnam: stri;

Itf11e : Ifile;

Itrec : itemrec;

BEGIN

fnam :« CONCAT(voI id,firoot,*IM.DTA');

ASSIGN(11 file.fnam);

RESET(Itflie);

READ(Itfile,itrec);

fnsh :* l[0].inum - itrec.inum; {# of items to be added to the file}

IF fnsh > 0 THEN BEGIN

itrec I[0];

SEEK(Itfile,0);

WRITE(ItfIle,Itrec);

$EEK(Itfile,FileSize(Itfile)); {go to end of file}

FOR J :• 1 TO fnsh DO wr11 e(11 fiIe,I[j]);

END;

CLOSE(Itfile)

END; {Putawayd}

PROCEDURE Loadatrx(VAR Aiattrtable; f l root:rootname; VAR ITDEX:INTEGER; VAR fdexichar); VAR {load attribute table and check IM file }

J : INTEGER; fnam : strI; atfiIe : afile; itfile : ifile;

Itrec: itemrec;

BEGIN clrscr;

fnam :« CONCAT(volld.firoot,'AT.DTA*); assign (atfile.fnam);

RESET(at f1 Ie); read (atfI Ie,o[0]);

FOR J :« 1 TO A[0J.atnum DO read (atf11e.a[j]);

CLOSE(atfile);

fnam :« CONCAT(voI Id,firoot,'IM.DTA*); assign (itfIle.fnam);

RESETHtf I le); read (itfIle,itrec);

ITDEX itrec.inum; fdex :■ itrec.fid;

SEEK(itfI Ie,ITDEX);

READ(itfI Ie,Itrec); cIrscr; gotoxy(1 ,4) ;

WRITELN(Spa(18),'there are **itdex,’ items in *,a[0].atname);

IF itdex > 0 THEN

WRITELN(Spa(18),'The last Item in the list is: \itree.iname); gotoxyfl,21);

Center('Press any key to continue.'); repeat until keypressed;

CLOSE(Itfile)

END; {Loadatrx}

PROCEDURE Introab;

BEGIN clrscr; gotoxy (1.8);

Center('ADD DATA');

wrlteln;

wr IteIn;

Center(*This routine is used to add Items to the data base. '); wr iteln;

WRITELN(Spa(15),'An Item''s name may not exceed *.rnaxaIabIen,* characters.');

(i continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 121

gotoxyf1,21);

Center('Press any key to begin.'); repeat until keypressed; cIrscr

END; }Introab}

BEGIN {Addtobase}

Introab;

Loadatrx(atabIe,f1 root,ITDEX,fdex);

Getdata(atabIe,ltab Ie,ITDEX,fdex);

Putawayd(I tab le.fi root)

END;

PROCEDURE Newbase(f1 root;rootname;f1 name:itemlab); {Create attribute table for a data base} jBTS 10/24/84 rev 4/10/84 10/3/85}

VAR

acount ; INTEGER; exit : BOOLEAN;

Atable : Attrtable;

PROCEDURE FIXQ (LSTR:strl;VAR QLAB:qua I Iab);

VAR {change a string Into a qualifier

J:INTEGER;

BEGIN

QLAB

FOR J :■ 1 TO maxqlablen DO QLAB CONCAT(QLAB,' ');

FOR J 1 TO LENGTH(LSTR) DO QLAB[J] LSTR[J]

END; {FIXQ

IabeI}

PROCEDURE BIankattr(VAR A:Attrrec);

VAR {Initialize an attribute record}

J : INTEGER;

BEGIN

A.atnum :■ 0;

A.atname ;■

A.qlnum 0;

Flxq('No data',A.qua Is[0]);

FOR J :■ 1 TO maxquaIlf1ers DO A.quaIsfJ] :* *'

END; {Blankattr}

PROCEDURE GETATTR(VAR A:Attrrec;VAR acount:INTEGER;VAR exit: BOOLEAN); VAR {Get an attribute name}

LEN : INTEGER; atrSTR : attrlab;

LABSTR : strl;

CH : CHAR; okay : BOOLEAN;

BEGIN

okay :* FALSE; {assume bad input} cIrscr;

REPEAT

GOTOXY(1, 5);

WRITELN(Spa(5),'Please type In a name for attribute #',acount,': ')• READLN(con,labstr); len LENGTH(Iabstr);

IF len IN [1..maxaIabIenl THEN BEGIN

Fixa(labstr,atrstr); A.atnum :■ acount; A.atname :* atrstr; okay TRUE

END

ELSE IF len <> 0 THEN

WRITELN(Spa(10),*A name may not exceed ',maxaIabIen,' characters.')

LLdt

BEGIN

GOTOXY(1.20);

WRITELN(Spa(10),’You have not typed in any name for attribute ’ acoi Center(*Press the LETTER "Q" to confirm that this is okay.’);

Center(’Press any other key to go back.’);

Rdupcase(ch); clrscr;

t)

122 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

IF ch - ’Q* THEN exit := TRUE END

UNTIL okay OR exit END; {GETATTR}

PROCEDURE GETQUAL(VAR A:Attrrec; acount:INTEGER);

VAR {Get qualifier names for an attribute}

QCOUNT,LEN ; INTEGER;

QLSTR : qua I lab;

LABSTR ; stri;

CH : CHAR;

BEGIN

LEN :« 1; QCOUNT 0; clrscr; gotoxy(30,5);

WRITELN(Spa(5),'Attribute #'.acount,* *.A.atname);

WRITELN;

WRITELN(Spa(5),'Qualifier Number (The limit is *.maxquaIifiers,*)*);

WHILE (qcount < maxquaI 1fiers) AND (len <> 0) DO BEGIN

GOTOXY(1, 21);

Center('Press RETURN to exit.');

GOTOXY(12,10+qcount);

WRlTE(qcount+1:2,': ');

READLN(con,labstr);

LEN LENGTH(LABSTR);

IF LEN IN [1..maxqlablen] THEN BEGIN

FIXQ(LABSTR,QLSTR); qcount :* qcount + 1;

A.qua Is[QCOUNT] :■ QLSTR {A.quals[0] defaults to 'No data'}

END

ELSE IF LEN <> 0 THEN BEGIN

GOTOXY(20,20);

WRITELN(Spa(10),'A name may not exceed '.maxqlablen,' characters.');

G0T0XY(1,10+qcount); clreol END ELSE BEGIN

gotoxy(20,20);

WRITELN('You have entered '.QCOUNT.' qualifiers.');

Centerf'Press the LETTER M Q" to confirm that you are finished.');

Center('Press any other key to add more qualifiers.');

Rdupcase(ch);

GOTOXY(1,20); del line; del line; del line;

IF CH - 'Q' THEN LEN 0 ELSE LEN 1 END;

END; {while}

A.qlnum qcount {store the # of qualifiers in the record}

END; {Getqual}

PROCEDURE Checkaq(VAR A:attrtab Ie);

VAR {show list and allow user to edit it}

J.K.ANUM.N : INTEGER;

CH.CHX ; CHAR;

OKAY : BOOLEAN;

PROCEDURE EDITQ(J.N:INTEGER); {EDIT qualifiers}

VAR

LEN ;INTEGER;

LABSTR ; stri;

QLSTR : qua I lab;

BEGIN

REPEAT

gotoxyf1,21);

Centerf'Type in a new qualifier name');

Center('Press RETURN to continue.');

READLN(con,labstr);

LEN LENGTH(LABSTR);

IF LEN <> 0 THEN

IF LEN IN [1..maxqlablen] THEN BEGIN

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 123

FIXQ(LABSTR.QLSTR);

A[J].qua Is[N] QLSTR END ELSE

WRITELN(Spa(13), *A name may not exceed *,maxqIabIen, UNTIL LEN IN [0..maxqIabIenl END; {EDITQ}

PROCEDURE EDITA(J:INTEGER); {EDIT ATTRIBUTE NAME}

LEN : INTEGER;

LABSTR : strl; atrSTR : attrlab;

BEGIN

REPEAT

gotoxyM ,21);

Centerf'Type In a new attribute name*);

CenterC‘Press RETURN to continue.*);

READLN(con,Iabstr);

LEN :« LENGTH(LABSTR);

IF LEN <> 0 THEN

IF LEN IN [1..maxalablen] THEN BEGIN

FIXA(LABSTR,atrSTR);

A[J].atname :« atrSTR END ELSE

WRITELN(Spa(13),*A name may not exceed *,maxaIabIen,* UNTIL LEN IN [0..maxalablenl END; {EDITA}

BEGIN {Checkaq} c I rscr;

Center(*Check and edit attributes and qualifiers.*); WRITELN(A[0].atname);

ANUM :■ A[0J.atnum;

IF anum >■ 1 THEN FOR J 1 TO ANUM DO REPEAT

OKAY :« FALSE; clrscr;

GOTOXY(l,2);

CHX :■

WRITELNf‘ATTRIBUTE #*,A[J].atnum);

WRITELN(CHX,*: *,A[J].atname);

IF A[J].qInum > 0 THEN BEGIN

FOR K :« 1 TO A[J].qlnum DO BEGIN

CHX :« SUCC(CHX);

WRITELN(CHX:3,*: *,A[J].qua Is[K]);

END;

REPEAT

GOTOXYM, 21);

Center( *Type @ to change the attribute name,’); Center(*a LETTER to change a qualifier name or*); Center(‘Press the SPACE BAR to continue. *); Rdupcase(ch)

UNTIL CH IN [• •,*®*..CHX];

IF CH - ’©* THEN EDITA(J)

ELSE IF CH IN [*A*..CHX] THEN BEGIN

N :« ORD(CH) - 64; {change char to qualifier #} EDITQ(J.N)

END

ELSE

OKAY TRUE END (*if A[J].qlnum*)

UNTIL OKAY END; {Checkaq}

PROCEDURE Putawaya(A:attrtabIe; ft root;rootname);

VAR

J : INTEGER; fnam : strl;

* characters

characters.*

124 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

at f fIe : afI Ie;

BEGIN c | r s c r *

fnam CONCAT(volid.firoot,*AT.DTA*); assign(atfiIe,fnam);

RESET(atf He);

FOR J :« 0 TO A[0].atnum DO wr !te(atfI Ie,a[j]);

CLOSE(atfI Ie)

END; {Putawaya}

PROCEDURE Intronb;

BEGIN clrscr; gotoxy (1,8);

Center('CREATE DATA BASE SHELL*); wrIteln; wrIteIn;

Centerf’This routine Is used to name;*);

CenterC'the data base**s attributes and their qualifiers*); gotoxyM ,21);

Center(’Press any key to continue.*);

REPEAT UNTIL KEYPRESSED;

END; |Intronb}

BEGIN {Newbase}

Intronb; exit :« FALSE;

AtabIe[0].atname :* finame; acount :« 1;

WHILE (acount <« maxattributes) AND (NOT exit) DO BEGIN

BIankat t r(AtabIe[acount]);

Getattr(AtabIe[acount],acount.exit);

IF (acount - 1) AND (exit - TRUE) THEN acount 0;

IF (NOT exit) THEN BEGIN

Getqua 1(Atab1e[acount],acount); clrscr;

GOTOXY(1,5);

WRITELN($pa(10),*You have finished creating *,acount,* attribute(s).*);

WRITELN(Spa(10),*The latest of which was *.AtabIefacount].atname);

WRITELN;

WRITELN(Spa(10),*A) Create another attribute.*);

WRITELN(Spa(10),*B) Go on to the next step (edit the entries).*);

GOTOXY(1,21);

Center(*Type In the LETTER of your choice.*);

REPEAT Rdupcase(ch) UNTIL ch IN [*A’,’B*];

IF ch - ’B* THEN exit TRUE ELSE acount :■ acount + 1 END; Iif not exit}

AtabIe[0].atnum :« acount END; {while}

IF acount > 0 THEN BEGIN

Checkaq(Atable);

Putawaya(AtabIe.firoot)

END

END; (*Newbase*)

PROCEDURE Mainmenu (VAR ch:CHAR);

BEGIN Clrscr; gotoxyM,5);

Center(*Materia18 Selection Program*);

GOTOXYM. 8);

Center(’MAIN MENU*);

GOTOXY(I.II);

WRITELN(Spa(22),*A) Create a new data base*);

WRITELN(SpaC22),*B) Add data to an existing data base*);

WRITELN(Spaf22).*C) Search for selected items*);

WRITELN(SpaC22),*D; Remove a data base*);

WRITELN(Spa(22),*E) System overview*);

WRITELN(Spa(22),*Q) Quit the program’);

gotoxy (1.21); (cMtinuaft

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 125

J uly

Canter('Type In the LETTER of your choice’); Rdupcose(ch)

END; (*Mainmenu*)

PROCEDURE Intromaln;

BEGIN

textbackground(7); textcolor(l); clrscr; gotoxy(1,5);

Center(’MATERIALS SELECTION PROGRAM’); gotoxyi1,9);

CenterC’wrItten by');

Center(’Bro. Tom Sawyer, esc and Michael Pecht*); wr IteIn; write In;

Center(’MeehanIcaI Engineering Department'); Center!'University of Maryland*);

Center(*CoI Iege Park MD 20742');

Center('(301) 454-8866'); gotoxyf1,21);

Center('Press any key to continue.');

REPEAT UNTIL KEYPRESSED;

END; {Intromaln}

PROCEDURE Explain; {Give an overview of the system and its use}

BEGIN clrscr;

GOTOXYf1,4);

Center('SYSTEM OVERVIEW');

WRITELN;

Center(’TERMS:');

WRITELN;

Center('ATTRIBUTE - A physical property or characteristic of the material WRITELN;

Center('QUALIFIER - One of a range of values that describes the property. WRITELN;

Center('RELATIVE IMPORTANCE - The weight you wish to give to an attribute Center('relatIve to the other attributes your "ideal" material must have. WRITELN;

Center('PIVOT - This is the MINIMUM acceptable value for the qualifier WRITELN; H

Center(’RANGE - Qualifier values around the pivot.');

Centerf'You may choose only the pivot or all values on either side of it. Center('The farther away a value lies from the pivot, the more weight it Center('is given in the calculation of overall acceptability (rank) G0T0XY(1.23); V '

Center('Press ANY KEY to return to the main menu.'); REPEAT UNTIL Keypressed END; {Explain}

: S;

BEGIN {MAIN PROGRAM - MSP}

Intromaln;

volld :* 'A:'; {this Is the Id of the data file volume} REPEAT

exit :« FALSE;

Mainmenu(ch);

IF ch IN ['A*..*D*] THEN Get fI name(fI root,fI name,ch,exit);

IF NOT (exit) THEN CASE ch OF

'A*; Newbase(fIroot,finame);

*B*: Addtobase(fI root,finame);

'C': Searchbase(fI root,fIname);

'E': Explain END

UNTIL ch - *Q*; textbackground(0); clrscr END.

126 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

reod-me.pas

"A Material Selection Program," by Brother Tom Sawyer and Michael Pecht. July, page 235.

MSP by Brother Tom Sawyer, esc, and Michael Pecht, Mechanical Engineering Department, University of Maryland, College Park, MD 20742. Drive for data files set to A:. You can change the assignment of <volid> in the main

block or insert a user input option.

srchfor.pas

"A Material Selection Program," by Brother Tom Sawyer and Michael Pecht. July, page 235.

PROCEDURE Searchfor(VAR It:ranktabIe; atniattrnum; atr:attrdata;

fnam:stri; seI code:CHAR; VAR Zflagiflag);

{Get data from file or from ranktable. It[0] used to pass values to output} VAR

memsrch : BOOLEAN;

J.cnt.last : INTEGER; itrec : itemrec; tempatr : attrdata; itfiIe:Ifile;

PROCEDURE Checkrec(VAR ent:INTEGER);

{look for data in It or on disk}

{changes It and uses seI code,tempatr,atr.memsrch, and j}

VAR

match ; BOOLEAN;

BEGIN

match :■ FALSE;

CASE selcode OF

'A' : IF tempatr <« atr THEN match :* TRUE;

’B’ ; IF tempatr - atr THEN match := TRUE;

■C* : IF tempatr >« atr THEN match := TRUE

END; {case}

IF (memsrch) AND (tempatr * NUL) THEN {Include "no data" items} match :■* TRUE;

IF match THEN BEGIN

ent ent + 1;

IF memsrch THEN {data is in It}

It[cnt] :■ It[J]

ELSE {data is on disk}

BEGIN

It[cntl.rating :■ 0; {initialize rating}

It[cntJ.item :* itrec END

END {if match}

END; {Checkrec}

BEGIN {Searchfor} ent :« 0;

Zflag 0; {assume no data is present}

last :« It[0].itern.Inum;

IF last = 0 THEN {search disk file}

BEGIN

memsrch :=* FALSE;

ASSIGN(itflle,fnam);

RESET(itfiI•);

READ(Itflle,itrec);

It[0].I tern.Iname :■ itrec.iname; {data base name}

WHILE NOT E0F(ItflIe) DO BEGIN

READ(ltfIle,Itrec);

{continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 127

July

tempatr :« itrec.ldata[atn];

Checkrec(cnt);

END;

CLOSE(11fI I e);

IF cnt - 0 THEN Zflag :« -1 {No items found in data base}

END {last-0} ’

ELSE {search array It}

BEGIN

memsrch TRUE;

FOR J 1 TO last DO BEGIN

tempatr IT[J].I tern.idata[atn];

Checkrec(cnt)

END;

IF cnt - 0 THEN Zflag 1 {No Items In It fit the new constraint}

END; {else}

It[0].Item.idata[0] atr; {desired qualifier value}

IF Zflag <> 1 THEN {change item count. New list or no items in data base} IT[0J.Item.inum cnt

END; {Searchfor}

wtrank.pas

"A Material Selection Program." by Brother Tom Sawyer and Michael Pecht. July, page 235.

PROCEDURE Wtandrank(VAR It:Ranktable;atn:attrnum;atrrattrdata;

VAR qlnrqualnum ;wt:INTEGER; wtit:BOOLEAN);

J,last.baseval.atrval : INTEGER;

PROCEDURE Rank Iist(VAR ItiRanktable; Iast:INTEGER);

VAR {selection sort by decreasing rating}

J,K,hdx ; INTEGER; switch : BOOLEAN; high : rankltemrec;

BEGIN

FOR J 1 TO last-1 DO BEGIN

switch :« FALSE;

high :« It[J]; hdx J;

FOR K J + 1 TO last DO

IF It[K].rating > high.rating THEN BEGIN

switch :« TRUE; high :« It[K]; hdx :« K END; {if}

IF switch THEN {must switch places}

BEGIN

It[hdx] It[J]; It[J] :« high

END END {for J}

END; {Rank list}

BEGIN {Wtandrank} baseval := ORD(atr);

last :» It[0].item.Inum; {# of Items in array}

FOR J ;■ 1 TO last DO

BEGIN

atrval :« ORD(It[J].Item.Idatafatn]);

IF (wtit) AND (atrval > 0) THEN It[jj.

END;

IF wtit THEN Rank I 1st(It,Iast)

END; {Wtandrank}

\UUYUI * KJ J 1 nciN

.rating := It[J].rating + ROUND(wt*ABS(baseval-atrval)/qln)

128 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

coIc.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

EMODULE Calc;

(* A simple spreadsheet program.

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved.

*)

FROM Spreadsheet IMPORT setValue, getValue, setFormula, getFormula,

maxRow, maxCol, setAutomatic, setManual, recalculate, operationStatus, Status, clearAII;

IMPORT Spreadsheet;

FROM DispIayHandIer IMPORT setCorner, setPrecIsion, setColWidth, moveCursor, message;

IMPORT DispIayHandIer;

FROM CommandProc IMPORT command, CommandType, readCommand;

FROM Misc IMPORT fatal;

FROM Terminal IMPORT Beep;

PROCEDURE init;

BEGIN

Spreadsheet.Init;

DisplayHandler.init;

END init;

PROCEDURE doLoop;

VAR c:command;

currCelI Row, currCelI Co I:CARDINAL; BEGIN

currCeIIRow :■ 1; currCeIICoI :« 1;

LOOP

readCommand(c, currCelIRow, currCeIICoI);

CASE c.type OF

CellRef: newCurrCeI I(currCeI I Row, currCellCol, c.row, c.col);

| SetValue: setVaIue(currCeI I Row, currCellCol, c.value);

checkStatus;

| SetFormula: setFormula(currCelIRow, currCellCol, c.form); checkStatus;

| Left, Right,

Up, Down: IF moveCursor(c.type) THEN

moveCurrCelI(currCelIRow, currCelI Co I, c.type);

NewCorner:

Precision:

ColWidth:

Automatic:

ManuaI:

RecaIc:

Copy:

Clear:

Quit:

END;

setCorner(c.row, c.col); setPrecision(c.precis ion); setColWidth(c.colWidth); setAutomatic; setManuaI; recaIculate;

doCopy(currCeIIRow, currCellCol, c.row, c.col); cIearAII;

EXIT;

ELSE

fatal('doLoop: unknown command type');

END;

END;

END doLoop;

PROCEDURE doCopy(fromRow, fromCol, toRow, toCoI:CARDINAL); VAR v:REAL;

BEGIN

(* check for status? *)

setValue(toRow, toCol, getVaIue(fromRow, fromCol)); setFormula(toRow, toCol, getFormuIa(fromRow, fromCol)); END doCopy;

PROCEDURE newCurrCeI I(VAR currCelIRow, currCeIICoI:CARDINAL;

row, coI:CARDINAL);

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 129

BEGIN

IF (row >- 1) AND (row <- moxRow()) AND (col>»1) AND (col <- maxColQ) THEN currCeI I Row :■ row; currCeIICoI :■ coI;

ELSE

Beep;

END;

END newCurrCeI I;

PROCEDURE moveCurrCelI(VAR currCellRow, currCeIICoI;CARDINAL;

direction:CommandType);

BEGIN

CASE direction OF

Up: IF currCellRow > 1 THEN DEC(currCeI I Row); ELSE Beep; END;

Down: IF currCellRow < maxRow() THEN INC(currCeI I Row); ELSE Beep; END;

Left: IF currCeHCof > t THEN DEC(currCe I ICol ); ELSE Beep; END;

Right: IF currCellCol < maxColQ THEN INC(currCeIICol); ELSE Beep; END;

ELSE

fatal(‘moveCurrCelI: unknown direction');

END;

END moveCurrCeI I;

PROCEDURE checkStatus;

BEGIN

CASE operatlonStatus OF

OK: (* do nothing *);

| RangeError: message("Out of range");

ELSE

Beep;

END;

END checkStatus;

BEGIN

In 11; doLoop; END Calc.

disklo.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE Disk 10;

(* For low-level I/O to a temporary disk file. Used in the virtual implementation of the spreadsheet.

The Volume stuff is specific to MacModuIa-2's implementation of the file system. You will have to make changes for your system.

Can't mix reading and writing: only reads can occur between a startRead and an endRead, and similarly for writes.

FROM FileSystem IMPORT File, Volume, ReadBytes, WriteBytes, SetPosition,

Vo IumeDriveName, OpenVolume, Interna I Dr IveNumber, Create, OpenFile, CloseVolume, CloseFile, Delete, fiIeErrSysEnabIe, GetFiIeLength;

FROM MyStorage2 IMPORT ALLOCATE, DEALLOCATE;

FROM Misc IMPORT assert, fatal;

FROM SYSTEM IMPORT TSIZE, ADR, ADDRESS;

FROM StringStuff IMPORT stringLen;

CONST sectorSize * 512; (* bytes per sector; must be power of 2 *)

maxCardinaILog2 « 16; (* equivalent to # of bits in a CARDINAL *)

sectors IzeLog2 * 9; (* log base 2 of sector size *)

maxSectorsPerAddress ■ 10; (* max sectors in one disk address *)

f1 IeName « "sstemp"; bytesPerWord ■ 2;

TYPE Sector - CARDINAL;

DiskAddress « POINTER TO daRec; daRec * RECORD

130 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

size:CARDINAL;

contents:ARRAY[1..maxSectorsPerAddress] OF Sector; END;

SectorList « POINTER TO sectorRec; sectorRec * RECORD

sector -.Sector; next:SectorList;

END;

VAR sectorsWrItten:ARRAY[1..maxSectorsPerAddress] OF Sector; (* for writing

nSectorsWritten: [0..maxSectorsPerAddress] curDiskAddress:DiskAddress; nSectorsRead:[0..maxSectorsPerAddress]; freeSectors: SectorList; posInSector:CARDINAL;

*>

♦)

nextSector:CARDINAL; (* file: File; (*

volume:Volume; rewriting:BOOLEAN; (*

sectorsPerHigh:CARDINAL;

next available sector the scratch file *)

(* for writing k rewriting for reading k rewriting *) for reading *) list of free sectors *) position in current sector *) in file (at end of file) *)

TRUE if we are rewriting existing sectors *)

(* § of sectors represented by a 1 in the high CARDINAL of SetPosition. See goToSector. *)

PROCEDURE init;

VAR i:CARDINAL;

BEGIN

freeSectors :» NIL; nextSector :* 0; posInSector := 0; sectorsPerHigh :■ 1;

FOR I :« 1 TO maxCardinalLog2 - sectorSizeLog2 DO sectorsPerHigh :■ 2 * sectorsPerHigh;

END;

makeScratchFiIe;

END init;

PROCEDURE clear;

VAR temp:SectorLIst;

BEGIN

CloseFile(file);

DeIete(voIume, fileName);

CloseVoIume(voIume);

WHILE freeSectors <> NIL DO temp :* freeSectors; freeSectors :* freeSectors^.next;

DISPOSE(temp);

END;

END clear;

PROCEDURE makeScratchFile;

(* Create a new file. This is Mac-specific. Change for your own system.

With the MacModula-2 file system, you first have to open a volume (I.e. disk), then create the file, then open it. With most other file systems, probably a single call to Create will do it. *)

VAR vname:ARRAY[0..26] OF CHAR;

BEGIN

VolumeDriveName(Interna I DriveNumber, vname);

(* Use the disk in the Mac's internal disk drive *)

OpenVoIume(voIume, vname);

fiIeErrSysEnabIe :■ FALSE; (* Turn off default error handling *)

DeIete(voIume, fileName); (* Delete the file, if it exists *)

f 11eErrSysEnable :- TRUE; (* Turn on error handling *)

Create(volume, fileName, "????", "????");

(* The last two args are creator and filetype; they're unimportant. *) OpenF1 Ie(fI Ie, volume, fileName);

END makeScratchFile;

PROCEDURE startWrite;

BEGIN

nSectorsWrItten :■ 0; rewriting :- FALSE; posInSector :■ sectorSIze;

END startWrite;

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 131

PROCEDURE endWrIte():DiskAddress;

VAR da:01skAddress;

I:CARDINAL;

BEGIN

assert(nSectorsWrItten <> 0, "endWrite: nothing written");

(* allocate just enough space for the number of sectors written *) da :■ newDiskAddress(nSectorsWritten);

FOR i 1 TO nSectorsWrItten DO

da".contents[1] :■ sectorsWritten[i];

END;

RETURN da;

END endWrite;

PROCEDURE startRewrIte(da:DiskAddress);

BEGIN

rewriting :■ TRUE; curDiskAddress :■ da; nSectorsWr1tten 0; posInSector sectorSize;

END startRewr1te;

PROCEDURE endRewrIte():DIskAddress;

VAR newda:DiskAddress;

I:CARDINAL;

BEGIN

assert(nSectorsWr1tten <> 0, "endRewrite: nothing written");

IF nSectorsWritten - curDiskAddress*.size THEN RETURN curDiskAddress;

ELSE

newda :* newDiskAddress(nSectorsWritten);

IF nSectorsWritten < curDiskAddress".size THEN FOR 1 :« 1 TO nSectorsWritten DO

newda".contents[i] :« curDiskAddress".contentsTI];

END;

FOR I :« nSectorsWritten+1 TO curDiskAddress".size DO freeSector(curDiskAddress".contents[i]);

END;

ELSE

FOR I :■ 1 TO curDiskAddress".size DO

newda".contents[i] curDiskAddress".contentsfi];

END; J

FOR i curDiskAddress".size+1 TO nSectorsWritten DO newda".contentsfi] :■ sectorsWrittenfi];

END;

END;

freeDiskAddress(curDiskAddress);

RETURN newda;

END;

END endRewrite;

PROCEDURE startRead(da:DiskAddress);

BEGIN

curDiskAddress :=* da; nSectorsRead :« 0; posInSector :* sectorSize;

END startRead;

PROCEDURE endRead;

BEGIN

(* There is nothing to do when a read is ended, but I leave this procedure here for symmetry. *)

END endRead;

PROCEDURE WriteReaI(r:REAL);

BEGIN

WrIteNBytes(ADR(r), TSIZE(REAL)*bytesPerWord);

END WrlteReaI;

PROCEDURE ReadReaI(VAR r:REAL);

BEGIN

ReadNBytes(ADR(r), TSIZE(REAL)*bytesPerWord);

END ReadReaI;

PROCEDURE WrIteString(VAR s:ARRAY OF CHAR);

(* Assumes strings <* 255 chars *)

VAR Ien:CARDINAL;

132 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

clen:ARRAY[0..1] OF CHAR;

BEGIN

len :*= stringLen(s);

assert(len <« 255, "DisklO.WriteString: too long"); cIen[0] CHR(len);

Wr I teNBytes(ADR(cIen), 1);

Wr fteNBytes(ADR(s), len);

END WriteString;

PROCEDURE ReadStrlng(VAR s:ARRAY OF CHAR);

VAR Ien:CARDINAL;

cIen:ARRAY[0..1] OF CHAR;

BEGIN

ReadNBytes(ADR(clen), 1) ; len :« ORDfcIen[0]);

ReadNBytes(ADR(s), len);

s[ I en] 0C;

END ReadStrlng;

PROCEDURE WrIteCard(c:CARDINAL);

BEGIN

WriteNBytes(ADR(c), TSIZE(CARDINAL)*bytesPerWord);

END WriteCard;

PROCEDURE ReadCard(VAR c:CARDINAL);

BEGIN

ReadNBytes(ADR(c), TSIZE(CARDINAL)*bytesPerWord);

END ReadCard;

PROCEDURE WriteNBytes(a:ADDRESS; count:CARDINAL);

VAR leftInSector:CARDINAL;

BEGIN

IF count <> 0 THEN

IF posInSector ■ sectorSize THEN (* this sector full; get another *) newSector;

assert(posInSector • 0, "WrIteNBytes; failed to get new sector"); END;

leftlnSector :« sectorSize - posInSector;

IF count > leftlnSector THEN WriteBytes(fiIe, a, leftlnSector);

INC(po9InSector, leftlnSector);

INC(a, leftlnSector);

WrIteNBytes(a, count-1 eftInSector);

ELSE

WriteBytes(flle, a, count);

INC(posInSector, count);

END;

END;

END WriteNBytes;

PROCEDURE ReadNBytes(a;ADDRESS; count CARDINAL);

VAR leftlnSector, actuaI:CARDINAL;

BEGIN

IF count <> 0 THEN

IF posInSector * sectorSize THEN INC(nSectorsRead);

WITH curDiskAddress^ DO

IF nSectorsRead > size THEN

fata I("ReadNBytes: attempt to read too much");

ELSE

goToSector(contents[nSectorsRead]); posInSector :■ 0;

END;

END;

END;

leftlnSector sectorSize - posInSector;

IF count > leftlnSector THEN

ReadBytes(fIle, a, leftlnSector, actual);

assert(actual - leftlnSector, "ReadNBytes: actual <> leftlnSector"); INC(posInSector, leftlnSector);

INC(a, leftlnSector);

ReadNBytes(a, count-1 eftInSector);

ELSE

ReadBytes(f11e, a, count, actual);

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 133

assert(actuaI - count, "ReadNBytes: actual <> count");

INC(posInSector, count);

END;

END;

END ReadNBytes;

PROCEDURE newSector;

BEGIN

INC(nSectorsWrltten); posInSector :■ 0;

IF rewriting THEN

IF nSectorsWrItten > curDlskAddress^.size THEN brandNewSector;

ELSE

goToSector(curDIskAddress".contents[nSectorsWrIttenl);

END;

ELSE

brandNewSector;

END;

END newSector;

PROCEDURE brandNewSector;

VAR tempiSectorLIst;

BEGIN

IF freeSectors <> NIL THEN

sectorsWrItten[nSectorsWrItten] :■ freeSectors".sector;

goToSector(freeSectors".sector);

temp :« freeSectors;

freeSectors :* freeSectors".next;

DISPOSE(temp);

ELSE

sectorsWrItten[nSectorsWritten] := nextSector; goToSector(nextSector);

INC(nextSector);

END;

END brandNewSector;

PROCEDURE goToSector(s-.Sector);

(* We have to be careful here because the SetPosition function takes two 16-bit CARDINALS, a high and a low; the actual file position is high*(2"16) + low, which can't be computed directly. So we calculate

(In init) the number of sectors represented by a 1 in the high position, and work from there. The correctness of the formula depends on the sector size being a power of 2.

If the place we're going to is beyond the end of the file, the file Is padded appropriately.

*)

VAR hi. lo. curHI, curLo:CARDINAL;

bIanks:ARRAY[1..sectorsIze] OF CHAR;

BEGIN

hi :* s DIV sectorsPerHIgh;

lo :* (s MOD sectorsPerHIgh)*sectorSize;

GetFileLength(file, curHi, curLo);

WHILE fcurHi < hi) OR ((curHi - hi) AND (curLo < lo)) DO

(* file too short; pad it with a sector's worth of junk *)

SetPosItion(fiIe, curHi, curLo);

WriteBytes(file, ADR(blanks), sectorSize);

GetFileLength(file, curHi, curLo);

END;

SetPos11ion(f11e, hi, lo);

END goToSector;

PROCEDURE freeSector(s.-Sector);

(* Put the sector in sorted order In the list of free sectors. Keeping

the list sorted should improve disk access time, since the head will only move In one direction (and possibly not at all) when the next sector is used. *)

VAR 8 I, news IrSectorList;

BEGIN

NEW(news I);

news I".sector :* s;

IF (freeSectors ■ NIL) OR (freeSectors".sector >- s) THEN newsl".next :* freeSectors; freeSectors :* news I;

134 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

ELSE

81 :* freeSectors;

WHILE (sl^.next <> NIL) AND (sI~.next^.sector < s) DO sI :* sI*.next;

END;

news Inext :■ si*.next;

8 I*.next :■ news I;

END;

END freeSector;

PROCEDURE newDiskAddress(nSectors:CARDINAL):DiskAddress;

VAR da:DiskAddress;

BEGIN

ALLOCATE(da, TSIZE(CARDINAL)+nSectors*TSIZE(Sector)); da*.size := nSectors;

RETURN da;

END newDiskAddress;

PROCEDURE freeDlskAddress(VAR da:DiskAddress);

BEGIN

IF da <> NIL THEN

DEALLOCATE(da, TSIZE(CARDINAL)+da*.size*TSIZE(Sector)); da NIL;

END;

END freeDiskAddress;

PROCEDURE freeDiskStorage(VAR da:DiskAddress);

VAR i:CARDINAL;

BEGIN

FOR ! :« 1 TO da*.size DO freeSector(da*.contents[1]);

END;

freeDiskAddress(da);

END freeDiskStorage;

PROCEDURE empty(da:DiskAddress):BOOLEAN;

BEGIN

RETURN da - nuI IDiskAddress;

END empty;

BEGIN

nuIIDiskAddress NIL;

END DisklO.

readthis

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

Guide to the Source Code for BYTE's Spreadsheet Programming Project

The spreadsheet program consists primarily of 8 modules:

Calc (.MOD file only)

Cel(List

CommandProc

DispIayHandIer

Evaluator

FormuI a

ScreenHandler

Spreadsheet.DEF

Top-level module

Lists of cells for dependency maintenance Command processor: reads and parses input In charge of the screen display Parses and evaluates formulas Maintains formula data structures Low-level interface to screen

Definition of the spreadsheet abstract data type

Corresponding to

the Spreadsheet definition module are four

impIementatIons:

Implementation:

Naive

Dependency

Sparse

Virtual

Modules used:

Spreadsheet 1 Spread8heet2 Spreadsheet3, Celll Spreadsheet3, Cel 12, DisklO

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 135

There is a single Cell definition module, used by both Cell Implementation modules. To use a particular Implementation, compile the necessary modules and rename the compiled code to omit the number. For instance, to use the sparse implementation, compile Spread3.M0D and Cel II.MOD, yielding Spreadsheet3.REL and Celll.REL (if you are using MacModula-2; the filename extensions may differ for other compilers). Then rename the REL files to Spreadsheet.REL and Cell.REL. Finally, link.

Besides these modules, there are also some support modules:

CharStuff Misc

MyStoragel MyStorage2 MyTermlnaI NumToString StringStuff

The difference between MyStoragel and MyStorage2 is that the latter returns NIL when an allocation falls for lack of memory. This is very important for the virtual implementation of the spreadsheet. For testing purposes, MyStorage2 will pretend to run out of memory after only a few K bytes have been allocated. You will want to change this if you Intend to use the virtual implementation.

A couple of machine-specific places in the code will need to be changed If you are not using a Macintosh. The ScreenHandIer module does some strange things to get around a bug in the Macintosh Quickdraw facility. And the DisklO module uses MacModula-2's FileSystem module, which is tailored to some extent to the Macintosh file system. You may need to make minor changes for your Implementation.

spread3.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

Note 12

Note 13

Note 14

Note 15

Note 16

Note 17

Note 18

Note 19

Note 20

Note 21

Note 22

Note 23

PROCEDURE setAutomatIc;

BEGIN

automatic :* TRUE;

END setAutomatIc;

PROCEDURE setManual;

BEGIN

automatic :* FALSE;

END setManuaI;

PROCEDURE inRange(row, coI;CARDINAL):BOOLEAN;

BEGIN

RETURN (row >- 1) AND (row <- maxRowH) AND (col >■ 1) AND (col <■ maxColiJi;

END inRange;

PROCEDURE setVaIue(row, coI:CARDINAL; value:REAL); VAR c:ceI I; '

BEGIN

IF inRange(row, col) THEN getCelI(row, col, c);

c.value :■ value; c.status :* OK; setCelI(row, col, c); operationStatus := OK; displayed I(row, col);

IF automatic THEN recalc(row, col);

END;

ELSE

operationStatus :■ RangeError;

END;

END setValue;

PROCEDURE getVaIue(row, coI:CARDINAL):REAL;

(* Get the value at row, col. *)

VAR c;celI;

BEGIN

IF NOT inRange(row, col) THEN operationStatus RangeError;

RETURN 0.0;

ELSE

getCelI(row, col, c);

IF c.status <> OK THEN operationStatus :■ c.status;

RETURN 0.0;

ELSE

operationStatus :« OK;

RETURN c.value;

END;

END;

END getValue;

PROCEDURE setFormuIa(row, coI:CARDINAL; f:formula); VAR c:ceI I;

BEGIN

IF inRange(row, col) THEN freeDependencIes(row, col); getCelI(row, col, c);

WITH c DO form :■ f; value :* 0.0; status :■ OK; setCelI(row, col, c);

evaIuateFormuIa(form, row, col, value, status); setDependencles(row, col); dIspIayCeI I(row, col);

IF automatic THEN recalc(row, col);

END;

END;

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 137

operatlonStatus :• OK;

ELSE

operatlonStatus RangeError; END;

END setFormula;

PROCEDURE getFormu Ia(row, co I -.CARDINAL) : f ormu I a; VAR c:ceI I;

BEGIN

IF InRange(row, col) THEN operatlonStatus OK; getCelI(row, col, c);

RETURN c.form;

ELSE

operatlonStatus :* RangeError;

RETURN emptyFormula;

END;

END getFormula;

PROCEDURE status(row, col:CARDINAL)rStatus;

VAR c:ceI I;

BEGIN

IF lnRange(row, col) THEN getCelI(row, col, c); operatlonStatus :■ OK;

RETURN c.status;

ELSE

operatlonStatus :■ RangeError;

RETURN RangeError;

END;

END status;

PROCEDURE maxRow():CARDINAL;

BEGIN

RETURN maxCard;

END maxRow;

PROCEDURE maxCoI():CARDINAL;

BEGIN

RETURN maxCard;

END maxCoI;

PROCEDURE recalculate;

BEGIN

doForAII Cells(evalCelI); operatIonStatus :■ OK;

END recalculate;

PROCEDURE evalCelI(row, coIiCARDINAL; VAR c:ceI I); VAR val:REAL;

stat:Status;

BEGIN

WITH c DO

IF (status <> Empty) AND (status <> SyntaxError) AND (NOT Formula.empty(form)) THEN evaluateFormula(form, row, col, val. stat);

IF (stat <> status) OR (val <> value) THEN status :* stat;

vaIue :« vaI; dlsplayCelI(row, col);

END;

END;

END;

END evalCelI;

PROCEDURE recaIc(row, coI:CARDINAL);

VAR val;REAL;

stat:Status; c:ceI I;

BEGIN

getCelI(row, col, c);

WITH c DO

138 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

Chapter Notes

IMPLEMENTATION MODULE Spreadsheet;

(* * This module Is used for both the sparse and virtual implementations.

It depends on the module Cell (implementation module Cel II for sparse, Cel 12 for virtual).

*)

FROM Formula IMPORT formula, emptyFormuI a;

IMPORT Formula;

FROM Evaluator IMPORT evaIuateFormuI a;

FROM Misc IMPORT fatal;

FROM DispIayHandIer IMPORT displayCell;

FROM Cel I List IMPORT cellList, cellRow, cellCol, nextCell, initFIndDep, nextDep, addToCelIList, removeFromCeIIList, nuIICeI IList, empty;

FROM Storage IMPORT ALLOCATE, DEALLOCATE;

FROM Cell IMPORT cell, getCell, setCell, doForAIICeI Is, initSheet, clearSheet;

CONST maxCard - 65535; (* Largest CARDINAL in this implementation *)

VAR automatlc:BOOLEAN;

PROCEDURE init;

BEGIN

automatic :■ TRUE; initSheet;

END init;

PROCEDURE cI earAI I;

BEGIN

clearSheet;

END clearAII;

136 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

IF (status <> Empty) AND (status <> SyntaxError)

AND (NOT Formula.empty(form)) THEN evaIuateFormuIa(form, row, col, val, stat);

IF (stat <> status) OR (val <> value) THEN status :* stat; value :« val; setCelI(row, col, c); displayCelI(row, col); recaIcDependents(c);

END;

ELSE

recaIcDependents(c);

END;

END;

END recalc;

PROCEDURE recalcDependents(VAR c:cell);

VAR cl reel ILIst;

BEGIN

cl : = c.dependentCeI 18;

WHILE NOT empty(cl) DO

recalc(celIRow(clceI ICo I(cI)); cl :* nextCelI(cl);

END;

END recaIcDependents;

PROCEDURE setDependencies(row, coI:CARDINAL);

VAR r, c:CARDINAL;

cel:ce11;

BEGIN

getCelI(row, col, cel);

IF cel.status <> SyntaxError THEN InitFIndDep(row, col, cel.form);

WHILE nextDep(r, c) DO IF InRange(r, c) THEN getCelI(r, c, cel);

addToCelI List(cel.dependentCeI Is, row, col); setCelI(r, c, cel);

END;

END;

END;

END setDependencles;

PROCEDURE freeDependenc!es(row, coI:CARDINAL);

VAR r, c:CARDINAL;

ceI:ceI I;

BEGIN

getCell(row, col, cel);

IF cel.status <> SyntaxError THEN In ItFIndDep(row, col, cel.form);

WHILE nextDep(r, c) DO IF inRange(r, c) THEN getCell(r, c, cel);

removeFromCelILIst(ceI.dependentCeI Is, row, col); setCelI(r, c, cel);

END;

END;

END;

END freeDependencles;

PROCEDURE cI ear(row, coI:CARDINAL);

BEGIN

(* not Implemented *)

END clear;

BEGIN

END Spreadsheet.

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 139

evaluat.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE Evaluator;

FROM Spreadsheet IMPORT Status;

FROM Formula IMPORT formula;

EXPORT QUALIFIED evaIuateFormuI a, evaIuateStrIng, refexpr;

PROCEDURE evaluateFormula(f:formula; row, col:CARDINAL;

VAR v:REAL; VAR s:Status);

PROCEDURE evaIuateStrIng(str:ARRAY OF CHAR; row, coI:CARDINAL;

VAR v:REAL; VAR s:Status);

PROCEDURE refexpr(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL;

VAR v:REAL; VAR 8-.Status; addBase:CARDINAL) ;

END Evaluator.

displayh.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE D!spIayHand1er;

FROM CommandProc IMPORT CommandType;

EXPORT QUALIFIED wrItePrompt, moveCursor, setPrecIsIon, setColWIdth, dtsplayCell, dlspIayFormuI a, Inlt, setCorner, message;

PROCEDURE wrItePrompt(row, coI:CARDINAL);

PROCEDURE moveCursor(dIrectIon:CommandType):BOOLEAN;

PROCEDURE setPrecIsIon(p:CARDINAL);

(* * number of decimal places to be shown *)

PROCEDURE setCo 1WIdth(cw:CARDINAL);

PROCEDURE dlspIayCeI I(row, coI:CARDINAL);

PROCEDURE dlspIayFormula(row, coI:CARDINAL);

PROCEDURE setCorner(row, coI:CARDINAL);

PROCEDURE Inlt;

PROCEDURE message(s:ARRAY OF CHAR);

END DlspIayHandIer.

evaIuate.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

Note 1

Note 2

Note 3

Note 4

Note 5

IF <expr> , <expr> , <expr>

<valexpr> :<term> j <addop> <term> \

<term> :<factor>{ <mulop> <factor> {

<factor> real | <cellref> | - <factor> | ( <expr> )

<cellref> :[ <refexpr> , <refexpr> ]

<refexpr> :<addop> real | real <relop> ::■ < > | ■ | <> j >■ | <«

<addop> ::* ♦

<mulop> : :* * /

1 =« TRUE, 0 - FALSE.

*)

FROM Ml sc IMPORT fatal, assert;

FROM Spreadsheet IMPORT maxRow, maxCol, Status, status, getValue;

FROM StrlngStuff IMPORT strlng40, string160, strlngCopy, findChar;

FROM CharStuff IMPORT isDigit, IsWhite;

FROM ReaIConversIons IMPORT StrToReal, Rea IProcResponses, ReaIConversionRes;

FROM Formula IMPORT formula;

IMPORT Formula;

FROM DispIayHandIer IMPORT message;

FROM StringOps IMPORT Concat;

TYPE

relOpType * (Less, Greater, Equal, LessEqual, GreaterEquaI, NotEqual);

VAR curRow, curCo I:CARDINAL;

PROCEDURE evaIuateFormula(f:formula; row, coI:CARDINAL; VAR v:REAL;

VAR s:Status);

VAR str:strIng160;

BEGIN

Formu I a.toStrIng(f, str);

evaIuateStr1ng(str, row, col, v, s);

END evaIuateFormuI a;

PROCEDURE evaluateStrfng(str:ARRAY OF CHAR; row, coIiCARDINAL; VAR v:REAL;

VAR s:Status);

VAR pos:CARDINAL;

BEGIN

pos :* 0;

curRow row;

curCoI :* col;

expr(str, pos, v, s, TRUE);

END evaluateString;

(* <expr> <valexpr> <relop> <valexpr> | IF <expr> , <expr> , <expr> *) PROCEDURE expr(VAR str;ARRAY OF CHAR; VAR pos:CARDINAL;

VAR v:REAL; VAR s:Status; evaI:BOOLEAN);

VAR v1:REAL;

rop:relOpType;

BEGIN

IF nextChar(str, pos) THEN

IF (str[pos] - T) AND (str[pos+1] - ’F*) THEN INC(pos. 2);

ffexpr(str, pos, v, s, eval);

ELSE

valexpr(str, pos, v, s, eval);

IF s - OK THEN

IF nextChar(str, pos) THEN rel0p(8tr, pos, rop, s);

IF s <> OK THEN (* shouldn't have looked at next char *) s OK;

ELSE

valexpr(etr, pos, vl, s, eval);

IF s - OK THEN

IF applyRelOp(rop, v, vl) THEN v :* 1.0;

ELSE

v ;■ 0.0;

(continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 141

END;

END;

END;

END;

END;

END;

ELSE

8 :* SyntaxError; error(str, pos);

END;

END expr;

(* IF <expr> , <expr> , <expr> *)

PROCEDURE Ifexpr(VAR str:ARRAY OF CHAR; VAR posCARDINAL;

VAR v:REAL; VAR s:Status; evaI:BOOLEAN);

(* ifexpr has to eval both branches, even though it knows the

value of the test, because we do not separate parsing from evaluation. It doesn't cause a problem because there are no side-effects. *)

VAR vTrue, vFalse;REAL;

BEGIN

expr(str, pos, v, s, eval);

IF s - OK THEN

IF (NOT nextChar(str, pos)) OR (str[pos] <> ’,') THEN s SyntaxError; error(8tr, pos);

ELSE

INC(pos);

expr(8tr, pos, vTrue, s, v <> 0.0);

IF s - OK THEN

IF (NOT nextChar(str, pos)) OR (str[pos] <> ',') THEN s ;■ SyntaxError; error(str, pos);

ELSE

INC(pos);

expr(str, pos, vFalse, s, v ■ 0.0);

IF s - OK THEN IF v - 0.0 THEN v :■ vFaIse;

ELSE

v :■ vTrue;

END;

END;

END;

END;

END;

END;

END ifexpr;

PROCEDURE reIOp(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL;

VAR rop:relOpType; VAR s:Status);

BEGIN

IF str[pos] - THEN rop :■ EquaI; s OK;

INC(posj;

ELSIF str[pos] - *>' THEN IF str[pos+1] - THEN

rop :* GreaterEquaI;

INC(pos, 2); s OK;

ELSE

rop :« Greater; s :« OK;

INC(pos);

END;

ELSIF str[pos] « '<* THEN IF str[pos+1] = THEN

rop :«■ LessEqua I ;

INC(pos, 2); s OK;

ELSE

rop :» Less;

INC(pos); s OK;

END;

ELSE

142 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

s :« SyntaxError; (* no message; this isn't a real error *) END; '

END relOp;

PROCEDURE appIyReIOp(rop:relOpType; BEGIN

▼ 1 • Y 4 • ixlML j <

~ ~ ^ w Wf M ^ |

CASE rop OF EquaI: NotEquaI: Less: Greater: LessEqual:

RETURN vl * v2; RETURN v1 <> v2; RETURN vl < v2; RETURN vl > v2; RETURN vl <- v2;

GreaterEqual: RETURN vl >= v2;

ELSE

fatal(*applyBoolOp: unknown op type');

END;

END appIyReI Op;

(* <vaIexpr> <term> } <addop> <term> { *)

PROCEDURE vaIexpr(VAR str:ARRAY OF CHAR; VAR pos;CARDINAL;

VAR v:REAL; VAR siStatus; evaI;BOOLEAN);

VAR vliREAL;

op:CHAR;

BEGIN

term(str, pos, v, s, eval);

WHILE (s * OK) AND nextChar(str, pos) DO IF NOT addOp(str[pos]) THEN RETURN;

END;

op :* strfpos];

INC(pos);

term(str, pos, vl, s, eval);

IF (s - OK) AND eval THEN IF op - THEN v :■ v + vl;

ELSE

v :■ v - vl;

END;

END;

END;

END valexpr;

(* <term> :<factor>{ <mulop> <factor> \ *)

PROCEDURE term(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL;

VAR v:REAL; VAR s:Status; eva I : BOOLEAN) ;

VAR vl:REAL;

op:CHAR;

BEGIN

factor(str, pos, v, s, eval);

WHILE (s - OK) AND nextChar (str, pos) DO IF NOT mu I0p(8tr[pos]) THEN RETURN;

END;

op :■ strfpos];

INC(pos);

factor(str, pos, vl, s, eval);

IF (s - OK) AND eval THEN IF op - THEN v :■ v * vl;

ELSIF vl = 0.0 THEN 8 :« DivByZero;

ELSE

v v / vl;

END;

END;

END;

END term;

(* <factor> ::- real | <cellref> | - <factor> | ( <expr> ) *)

PROCEDURE factor(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL;

VAR v:REAL; VAR s:Status; evaI:BOOLEAN);

[continued]

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 143

Chapter Notes

IMPLEMENTATION MODULE Evaluator;

(* Evaluator for the spreadsheet.

*)

(* grammar for formulas: ( \\ means "zero or more" ) <expr> <valexpr> | <valexpr> <relop> <valexpr> |

140 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

July

BEGIN

IF NOT naxtChar(str, pos) THEN 9 :■ SyntaxError; arror(str, pos);

ELSIF isDiglt (str[pos]) THEN parssRsaI(str, pos, v, s);

ELSE

INC(pos);

CASE str[pos-1] OF

• [•s cellRef(str, pos, v, s, aval);

| factor(str, pos, v, s, aval);

v -v;

| axpr(str, pos, v, s, aval);

IF s - OK THEN

IF (NOT naxtChor(str, pos)) OR (strfpos] <> •)•) THEN s SyntaxError; arror(str, pos);

ELSE

INC(po8);

END;

END;

ELSE

s :■ SyntaxError; error(str, pos);

END;

END;

END factor;

(* <callraf> [ <rafaxpr> , <rafaxpr> ]

Opanlng [ is alraady read. *)

PROCEDURE caI IRaf(VAR str;ARRAY OF CHAR; VAR posiCARDINAL;

VAR v;REAL; VAR s:Status; avaI:BOOLEAN);

VAR vRow, vCol:REAL;

r, c;CARDINAL;

BEGIN

rafaxpr(8tr, pos, vRow, s, curRow);

IF s - OK THEN

IF (NOT naxtChar(str, pos)) OR (strfpos] <> ',*) THEN 8 SyntaxError; arror(str, pos);

ELSE

INC(pos);

rafaxpr(str, pos, vCol, s, curCol);

IF s - OK THEN IF aval THEN

rangaChack(vRow, vCol, r, c, s);

END;

IF s - OK THEN IF aval THEN

rafaranca(r, c, v, s);

END;

IF s - OK THEN

IF naxtChar(str, pos) AND (strfpos] = *]*) THEN INC(pos);

ELSE

s SyntaxError; errorfstr, pos);

END;

END;

END;

END;

END;

END;

END cal IRaf;

(* <refexpr> <addop> raal | raal *)

PROCEDURE rafaxpr(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL;

VAR v:REAL; VAR s:Status; addBasarCARDINAL);

VAR op:CHAR;

BEGIN

IF NOT naxtChar(str, pos) THEN s :» SyntaxError; arror(str, pos);

ELSE

IF addOp(str[pos]) THEN

144 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

op :» str[pos];

INC(pos);

ELSE

op :■ 0C;

END;

IF NOT nextChar(str, pos) THEN s :■ SyntaxError; error(str, pos);

ELSE

parseReal(str, pos, v, s);

IF s - OK THEN IF op - THEN v :■ FLOAT(addBase) + v; ELSIF op - THEN

v :* FLOAT(addBase) - v; END;

END;

END;

END;

END refexpr;

PROCEDURE addOp(c:CHAR):BOOLEAN; BEGIN

RETURN (c - ’+’) OR (c - ’-•); END addOp;

PROCEDURE mu I Op(c:CHAR):BOOLEAN; BEGIN

RETURN (c - ’*’) OR (c * ’/’);

END mu I Op;

Table captionPROCEDURE rangeCheck(vRow, vCol:REAL; VAR r, c:CARDINAL; BEGIN

(vRow >■ 1.0)

AND

(vRow

<- FLOAT|

JmaxRowQ))

(vCol >- 1.0)

AND

(vCol

<- FLOAT(

[maxCol()))

r :« TRUNC(vRow); c TRUNC(vCol); ELSE

s :« RangeError; END;

END rangeCheck;

VAR s:Status);

PROCEDURE reference(row, coI:CARDINAL; VAR v:REAL; VAR s:Status); BEGIN '

IF status(row, col) - OK THEN v :* getValue(row, col); s OK;

ELSE

s :■ RefError;

END;

END reference;

PROCEDURE parseReal(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL; VAR v:REAL;

VAR s:Status);

VAR real,msg:strIng40;

endPos CARDINAL;

BEGIN

skIpToEndOfReaI(str, pos, endPos); strIngCopy(reaI, str, pos, endPos);

StrToReaI(reaI, v);

CASE ReaIConverslonRes OF noError; s :* OK;

| InvalldStr: s :■ SyntaxError;

Concat(msg, "Invalid real; ", real); message(msg);

| overflow: s Overflow;

| underflow: s :■ Underflow;

ELSE

fataI("parseReaI: unknown error");

END;

pos :■ endPos+1;

END parseReal;

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 145

PROCEDURE sklpToEndOfReal(str:ARRAY OF CHAR; po«:CARDINAL;VAR endPos:CARDINAL); BEGIN

endPos ;■ pos;

WHILE (endPos <- HIGH(str)) AND

findChar("0123456789E. M , str[endPos], pos) DO INC(endPos);

END;

DEC(endPos);

END skIpToEndOfReoI;

mytermin.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE MyTermlnal;

(♦ Some small but useful additions to the Terminal module. * *)

EXPORT QUALIFIED WrlteStrlng, WrlteLn, Write, Read, ClearScreen, Beep,

WrlteLnString, Wrltelnt, WrlteCard, pause, spaces, places;

PROCEDURE WrIteStrIng(s:ARRAY OF CHAR);

PROCEDURE WrlteLn;

PROCEDURE WrIte(c:CHAR);

PROCEDURE Read(VAR c:CHAR);

PROCEDURE ClearScreen;

PROCEDURE Beep;

PROCEDURE WrIteLnStrlng(s:ARRAY OF CHAR);

PROCEDURE Wrltelnt(!:INTEGER; spaces:CARDINAL);

PROCEDURE WrIteCard(c, spaces:CARDINAL);

PROCEDURE pause(msg:ARRAY OF CHAR);

(* Prevents the screen from blanking and returning to the Finder until the user hits a key. msg Is typed out. *)

PROCEDURE spaces(n:INTEGER);

(* Prints n spaces, If n > 0. *)

PROCEDURE pI aces(c:CARDINAL):CARDINAL;

(* Returns the number of places It would take to print c. *)

END MyTermlnaI.

spread2.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

CONST maxR - 32; maxC - 60;

TYPE

cell - RECORD

value: REAL; form: formula; status: Status; dependentCeI Is: cel Hist; END;

VAR sheet: ARRAY[1..maxR], [l..maxC] OF cell; automatlc:BOOLEAN;

PROCEDURE Inlt;

VAR row, coI:CARDINAL;

BEGIN

automatic :■ TRUE;

FOR row :■ 1 TO maxR DO FOR col :* 1 TO maxC DO WITH sheet[row, col] DO status :« Empty; form :■ emptyFormuI a; dependentCeI Is :« nuIICeI IList;

END;

END;

END;

END init;

PROCEDURE clearAII;

VAR row, col-.CARDINAL;

BEGIN

FOR row :■ 1 TO maxR DO FOR col :■ 1 TO maxC DO WITH sheet[row, col] DO

status :• Empty;

Formula.free(form); form :■ emptyFormula;

END;

END;

END;

END cIearAII;

PROCEDURE setAutomatIc;

BEGIN

automatic :* TRUE;

END setAutomatIc;

PROCEDURE setManual;

BEGIN

automatic := FALSE;

END setManuaI;

PROCEDURE InRange(row, coI:CARDINAL):BOOLEAN;

BEGIN

RETURN (row >« 1) AND (row <• maxR) AND (col >= 1) AND (col <« maxC); END InRange;

PROCEDURE setValue(row, coI CARDINAL; vaIue:REAL);

BEGIN

IF InRange(row, col) THEN

sheetfrow, col].value :« value; sheetfrow, col].status :■ OK; operatlonStatus :■ OK; dlsplayCelI(row, col);

IF automatic THEN

recalc(row, col);

END;

ELSE

operatlonStatus :■ RangeError;

END;

END setValue;

[continued]

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 147

Chapter Notes

IMPLEMENTATION MODULE Spreadsheet;

The DEPENDENCY Implementation Is an array with dependency information: each cell knows which other cells depend on its value. In automatic mode, whenever a value Is changed the tree of dependencies is traversed depth-first, and the display handler is called for each changed value.

*)

FROM Formula IMPORT formula, emptyFormuI a;

IMPORT Formula;

FROM Evaluator IMPORT evaIuateFormuI a;

FROM Mi sc IMPORT fatal;

FROM DispIayHandIer IMPORT displayCell;

FROM Cel IList IMPORT cellList, cellRow, cellCol, nextCell, initFindDep, nextDep, addToCeI IList, removeFromCeI IList, nuIICeI I List, empty;

146 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

PROCEDURE gatVolu*(row, col:CARDINAL):REAL;

(* Get the value at row, col. *)

BEGIN

IF NOT InRange(row, col) THEN

operatlonStatus :■ RangeError;

RETURN 0.0;

ELSIF 8heet[row, col].status <> OK THEN

operatlonStatus sheet[row, col].status; RETURN 0.0;

ELSE

operatlonStatus :■ OK;

RETURN sheet[row, col].value;

END;

END getValue;

PROCEDURE setFormula(row, co I-.CARDINAL; f-.formula); BEGIN

IF lnRange(row, col) THEN freeDependenc!es(row, col);

WITH sheet[row, col] DO form f; vaIue :■ 0.0; status ;■ OK;

evaIuateFormuIa(form, row, col, value, status); setDependencles(row, col); dlsplayCelI(row, col);

IF automatic THEN recalc(row, col);

END;

END;

operatlonStatus :« OK;

ELSE

operat lonStatus :=* RangeError;

END;

END setFormula;

PROCEDURE getFormuIa(row, coI:CARDINAL):formuI a;

BEGIN

IF lnRange(row, col) THEN operatlonStatus :■ OK;

RETURN sheet[row, col].form;

ELSE

operatlonStatus :■ RangeError;

RETURN emptyFormuI a;

END;

END getFormula;

PROCEDURE cl ear(row, coI:CARDINAL); BEGIN

IF inRange(row, col sheetTrow, col' sheet row, col sheet[row, col

ELSE

operatlonStatus

) THEN

.status := Empty;

.form :« emptyFormuI a; .dependentCeI Is := nuIICeI ILIst; := OK;

operationStatus :■ RangeError;

END;

END clear;

PROCEDURE status(row, coI:CARDINAL):Status; BEGIN

IF !nRange(row, col) THEN operatlonStatus :« OK;

RETURN sheet[row, col].status;

ELSE

operatIonStatus :* RangeError; RETURN RangeError;

END;

END status;

PROCEDURE maxRow()iCARDINAL;

BEGIN

RETURN maxR;

END maxRow;

148 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

PROCEDURE maxCoI():CARDINAL;

BEGIN

RETURN maxC;

END maxCoI;

PROCEDURE recalculate;

VAR row, coI:CARDINAL; val:REAL; stat:Status;

BEGIN

FOR row :■ 1 TO maxR DO FOR col :* 1 TO maxC DO WITH sheet[row, col] DO

IF (status <> Empty) AND (status <> SyntaxError) AND (NOT Formula.empty(form)) THEN evaluateFormula(form, row, col, val, stat);

IF (stat <> status) OR (val <> value) THEN status :* stat; value :* val; displayCelI(row, col);

END;

END;

END;

END;

END;

operatlonStatus :« OK;

END recalculate;

PROCEDURE recaIc(row, coI:CARDINAL);

VAR val .-REAL; stat:Status; cl:ceIIL1st;

BEGIN

WITH sheet[row, col] DO

IF (status <> Empty) AND (status <> SyntaxError)

AND (NOT FormuI a.empty(form)) THEN evaIuateFormuIa(form, row, col, val, stat);

IF (stat <> status) OR (val <> value) THEN status :« stat; vaIue vaI; displayCelI(row, col); recaIcDependents(sheet[row, col]);

END;

ELSE

recaIcDependents(sheet[row, col]);

END;

END;

END recalc;

PROCEDURE recaIcDependents(VAR c:cell);

VAR cl reelIList;

BEGIN

cl :* c.dependentCeI Is;

WHILE NOT empty(cl) DO

recalc(celIRowfcl), ceI I Co I(cI)); cl :■ nextCelI(cl);

END;

END recalcDependents;

PROCEDURE setDependencies(row, coI;CARDINAL);

VAR r, c:CARDINAL;

BEGIN

IF sheetfrow, col].status <> SyntaxError THEN inltF!ndDep(row, col, sheet[row, col].form);

WHILE nextDep(r, c) DO IF lnRange(r, c) THEN

addToCelILIst(sheet[r, c].dependentCeI Is, row, col); END;

END;

END;

END setDependencIes;

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 149

PROCEDURE freeDependencies(row, coI:CARDINAL);

VAR r, c:CARDINAL;

BEGIN

IF sheet[row, col].status <> SyntaxError THEN InitFlndDep(row, col, sheet[row, col],form);

WHILE nextDep(r, c) DO IF inRange(r, c) THEN

removeFromCeIILIst(sheet[r, c]. dependentCeMs, row, col); END;

END;

END;

END freeDependsncI as;

BEGIN

END Spreadsheet.

dispIayh.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE DispIayHandIer;

(* Top row of screen is for display of messages; 2nd, of formulas; 3nd row is for entry; rest Is spreadsheet. *)

FROM CommandProc IMPORT CommandType;

FROM MyTermlnal IMPORT WrlteCard, ClearScreen, Beep;

IMPORT Formula;

FROM Spreadsheet IMPORT getValue, getFormula, InRange, status, Status;

FROM StrlngStuff IMPORT strlngLen, $trIngAssIgn, strlng80, string40;

FROM Misc IMPORT fatal, min;

FROM NumToStrlng IMPORT cardToStrIng, reaIToStrIng;

FROM ScreenHandIer IMPORT setCursorPos, Write, WrlteStrlng;

IMPORT ScreenHandIer;

CONST

messageRow « 0; messageCol ■ 0; formuIaDispIayRow ■ 1; formulaDisplayCol - 0; promptRow « 2; promptCol * 0; colNumberRow ■ 3; colNumberCol » 4; rowNumberRow * 5; rowNumberCol * 0; cornerRow * 5; cornerCol = 4; initial Co IWId t h « 6; maxColWldth - 25; minColWidth - 1; inltiaIPrecision * 2; maxPrecision ■ 6; mInPrecision - 0; maxScreenRow ■ 20; maxScreenCol ■ 70;

VAR celICursorRow, ceIICursorCoI, cornerCeI I Row, cornerCeIICoI, precision, colWidth, lastRow, lastCol:CARDINAL;

PROCEDURE Inlt;

BEGIN

cornerCeIIRow :■ 1; cornerCeIICoI :* 1; ceIICursorRow :« cornerCeI I Row; ceIICursorCoI :■ cornerCeIICoI; precision :« initia IPrecision; colWidth initiaICoIWidth;

ScreenHandIer.Init; redispI ay;

END inlt;

150

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

PROCEDURE writePrompt(row, coI:CARDINAL);

BEGIN

cIearToEOL(promptRow, promptCol);

Write('[');

Wr i teCard(row, 0); Wrlte(','); Wr 1 teCard(co I , 0); Wr IteStrIng("]: ");

END writePrompt;

PROCEDURE message(s:ARRAY OF CHAR);

BEGIN

cIearToEOL(messageRow, messageCoI); WriteString(s);

END message;

PROCEDURE moveCursor(dlrectioniCommandType):BOOLEAN; BEGIN

CASE direction OF

Up; IF ceIICursorRow > cornerCeI I Row THEN DEC(celICursorRow); displayCelICursor;

RETURN TRUE;

ELSE

| Down:

| Left:

I Right;

ELSE

fatal(

Beep;

END;

IF ceIICursorRow < lastRow THEN INC(ceIICursorRow); dispIayCeIICursor;

RETURN TRUE;

ELSE

Beep;

END;

IF celICursorCol > cornerCeIICoI THEN DEC(ceIICursorCoI); dispIayCeIICursor;

RETURN TRUE;

ELSE

Beep;

END;

IF celICursorCol < lastCol THEN INC(ceIICursorCoI); dIspIayCeIICursor;

RETURN TRUE;

ELSE

Beep;

END;

moveCursor; unknown direction');

END;

RETURN FALSE;

END moveCursor;

PROCEDURE displayCelICursor; BEGIN

(* do nothing for now *) END dIspIayCeIICursor;

PROCEDURE setPrecIsIon(p:CARDINAL);

(* number of decimal places to be shown *)

BEGIN

IF (p < minPrecisIon) OR (p > maxPrecision) THEN me8sage("IIlegal precision");

ELSE

precision :■ p; displayCelIs;

END;

END setPrecision;

PROCEDURE s e t Co IWId t h(cw:CARDINAL);

BEGIN

IF (cw < minColWidth) OR (cw > maxColWidth) THEN message("II legal column width");

ELSE

coI Width cw+1; redisplay;

I continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 151

July

END;

END setCoI Width;

PROCEDURE setCorner(row, BEGIN

IF InRange(row, col) cornarCelIRow :■ cornerCelICol celICursorRow :■ calICursorCol redispI ay;

ELSE

col:CARDINAL);

THEN row; col; row; col;

message("CeI I out of ronga");

END;

END setCornar;

PROCEDURE dlsplayFormula(row, coI:CARDINAL);

BEGIN

cIaarToEOL(formuIaDIspIayRow, formu IaDispIayCoI);

Formula.wrlte(getFormula(row, col));

END dIspIayFormuI a;

PROCEDURE dlsplayCalI(row, coI:CARDINAL);

VAR dummy:BOOLEAN;

BEGIN

dummy :■ dIspCaI I(row, col);

END dlsployCelI;

PROCEDURE dlspCalI(row, coI:CARDINAL):BOOLEAN;

(* Returns TRUE If It actually displays the call *)

VAR screenRow, screenCoI:CARDINAL;

BEGIN

IF (row >- cornarCelIRow) AND (col >* cornarCaIICoI) THEN screenRow :■ (row - cornarCaI I Row) + cornerRow; screenCoI (col - cornarCaIICoI)*coIWldth + cornerCol;

IF (screenRow <« maxScreenRow) AND (screenCol <* maxScreenCoI) THEN satCursorPos(screenRow, screenCoI);

Wr I te (*|*)5

dispIayVaIue(row, col, mTn(maxScreenCo1-screenCo 1 + 1 , coIWldth- 1 )); RETURN TRUE;

END;

END;

RETURN FALSE;

END dispCelI;

PROCEDURE displayValue(row, col, spacerCARDINAL);

VAR strlng:strlng40;

I, I an rCARDINAL;

BEGIN

IF space > 0 THEN

valToStrIng(row, col, string); len strIngLen(string);

IF len >- space THEN FOR I := 0 TO space-1 DO Wrlte(strlng[I]);

END;

ELSE

spaces(space-len);

IF len <> 0 THEN

FOR I 0 TO len-1 DO Wr I te(strIng[I]);

END;

END;

END;

END;

END dIspIayVaIue;

PROCEDURE valToStr ing(row, co I-.CARDINAL; VAR string:ARRAY OF CHAR);

BEGIN

CASE 8 tatu 8 (row, col) OF

OK: realToString(getVaIue(row, col), precision, string);

152 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

1 uly

Empty: strlng[0] :■ 0C;

DivByZero: str1ngAssign(strIng, "?DIV"); RefError: strIngAssIgnfstring, M ?REF ");

RangeError: stringAssign(string, M ?RNG"); Overflow: strIngAssignfstrIng, "?OVF");

Underflow: strIngAssIgn(strIng, "?UNF"); SyntoxError: stringAssIgn(string, "?SYN");

ELSE

strIngAssign(strIng, "???");

END;

END valToString;

PROCEDURE redisplay;

VAR row, coI:CARDINAL;

BEGIN

ClearScreen; dlspIayCoI Numbers; dlspIayRowNumbers; displayCelIs;

END redisplay;

PROCEDURE displayCelIs;

VAR row, coI:CARDINAL;

BEGIN

row :■ cornerCeIIRow; col :* cornerCeIICol;

WHILE dispCeI I(row, col) DO REPEAT

INC(col);

UNTIL NOT dlspCeI I(row, col); lastCol :■ col-1;

INC(row);

col :■ cornerCelICol;

END;

lastRow :» row-1;

END displayCelIs;

PROCEDURE dispIayCo(Numbers;

VAR s:string80;

screenCol, celICol, space, i:CARDINAL;

BEGIN

setCursorPos(coI NumberRow, colNumberCol); screenCol :■ colNumberCol; celICol :■ cornerCelICol;

WHILE screenCol <* maxScreenCol DO Wr!te(’|’);

cardToStrIngfceIICoI, s); centerStrlng(s, coI Width-1);

space :- min(maxScreenCo1-screenCoI, colWidth-1); IF space <> 0 THEN FOR I :■ 0 TO space-1 DO carefulWrite(s, l);

END;

END;

INCfscreenCoI, space+1);

INC(celICol);

END;

setCursorPos(colNumberRow+1, 0);

FOR I :■ 0 TO maxScreenCol DO WrIte(*-*);

END;

END displayColNumbers;

PROCEDURE dispIayRowNumbers;

VAR s:strlng40;

•creenRow, celIRow, I, upperLImlt:CARDINAL;

BEGIN

screenRow :■ rowNumberRow;

celIRow :■ cornerCeIIRow;

upperLImit :■ cornerCo1-rowNumberCo1-2;

WHILE screenRow <■ maxScreenRow DO cardToStrlngfceIIRow, s); setCursorPos(screenRow, rowNumberCoI);

FOR I 0 TO upperLimit DO carefulWrIte(e, I);

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 153

END;

INC(screenRow);

INC(celI Row);

END;

END displayRowNumbers;

(*** utilities ***)

PROCEDURE centerStrIng(VAR s:ARRAY OF CHAR; space CARDINAL);

(* center the string In the given space, padding the left with blanks *) VAR spaceCount, I, Ien;CARDINAL;

BEGIN

len :■ strIngLen(s);

IF len < space THEN

spaceCount :■ (space - len) DIV 2;

IF spaceCount <> 0 THEN FOR i :• len TO 0 BY -1 DO s[i+spaceCount] :* s[i];

END;

FOR I :* 0 TO spaceCount-1 DO s[l]

END;

END;

END;

END centerString;

PROCEDURE carefuIWrite(VAR s:ARRAY OF CHAR; I;CARDINAL);

BEGIN

IF I >■ stringLen(s) THEN WriteO *);

ELSE

Wr 11e(8[I]);

END;

END carefulWrite;

PROCEDURE clearToEOL(row, coI:CARDINAL); BEGIN

setCursorPo 8 (row, col); spaces(maxScreenCoI - col + 1 ); setCursorPo 8 (row, col);

END clearToEOL;

PROCEDURE spaces(n:CARDINAL);

BEGIN

WHILE n > 0 DO Wrlte(' ’);

DEC(n);

END;

END spaces;

BEGIN

END DisplayHandler.

screenha.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE ScreenHandIer;

FROM QuickDrawl IMPORT TextMode, srcOr, GetPen, DrawText, QDPtr, Rect, DrawChar, Point, MoveTo, Move, Fontlnfo, GetFontlnfo, EraseRect, SetRect, TextWidth, CharWidth;

FROM StringOps IMPORT Length;

FROM SYSTEM IMPORT ADR;

VAR charWidth, charHeight, charAscent, charDescent:INTEGER;

PROCEDURE init;

(* Sets up for current font *)

VAR lnfo:FontInfo;

154 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

BEGIN

TextMode(srcOr);

GatFontInfo(info);

WITH Info DO

charWidth :« widMax;

charHeight :« ascent + descent + leading; charAscent :« ascent; charDescent :■ descent;

END;

END Init;

PROCEDURE setCursorPos(row, coI:CARDINAL); (* zero-based *)

BEGIN

MoveTo(VAL(INTEGER, coI)*charWidth, VAL(INTEGER, (row+1))*charHeight); END setCursorPos;

PROCEDURE getCursorPos(VAR row, coI:CARDINAL);

VAR p:Point;

BEGIN

GetPen(p);

row :« (p.v DIV charHeight)-1; col :» p.h DIV charWidth;

END getCursorPos;

PROCEDURE WrIte(ch:CHAR);

BEGIN

erase(0, charAscent, charWidth, -charDescent);

DrawChar(ch);

END Write;

PROCEDURE WriteString(s:ARRAY OF CHAR);

VAR Ien:INTEGER;

BEGIN

len VAL(INTEGER, Length(s));

erase(0, charAscent, TextWidth(QDPtr(ADR(s)), 0, len), -charDescent); DrawText(QDPtr(ADR(s)), 0, len);

END WriteStrIng;

PROCEDURE erase(left, top, right, bottom:INTEGER);

VAR penPos:Point;

bIankRect:Rect;

BEGIN

GetPen(penPos);

SetRect(blankRect, penPos.h + left, penPos.v - top,

? enPos.h + right, penPos.v - bottom);

;

END erase;

BEGIN

END ScreenHandler.

mytermin.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE MyTerminal;

(* Some small but useful additions to the Terminal module. *) IMPORT Terminal;

VAR powerOfTen: ARRAY[0..4] OF CARDINAL;

PROCEDURE WrIteLnStrIng(t:ARRAY OF CHAR); BEGIN

Terminal.WrIteString(s);

TerminaI.WriteLn;

END WriteLnStrlng;

( continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 155

I uly

PROCEDURE Wrltelnt(l:INTEGER; spaces:CARDINAL):

BEGIN '

IF I < 0 THEN

IF spaces <> 0 THEN

wrIteNum(CARDINAL(-l), spaces-1, TRUE);

ELSE

wrIteNum(CARDINAL(-i), 0, TRUE);

END;

ELSE

END wr,teNum ( CARDINAL ( f )» spaces, FALSE);

END Writelnt;

PROCEDURE WrIteCard(c, spaces:CARDINAL);

BEGIN

wrIteNum(c, spaces, FALSE);

END WrlteCard;

PROCEDURE wrIteNum(c, spaces:CARDINAL; neg:BOOLEAN);

VAR p:CARDINAL;

i:INTEGER;

BEGIN

p :« places(c);

FOR I 1 TO INTEGER(spaces) - INTEGER(p) DO Terminal.Wr!te(' •);

END;

IF neg THEN

Terminal.Write( , - f );

END;

FOR I p-1 TO 0 BY -1 DO

Terminal.Write(CHR((c DIV powerOfTenfi]) + ORDf’0’))): c :■ c MOD powerOfTenfi];

END;

END writeNum;

PROCEDURE pI ace s(c:CARDINAL):CARDINAL;

(* Returns the number of places c takes to print; i.e. trunc(1+log10(c)) VAR I:CARDINAL; N

BEGIN

FOR I ;■ 4 TO 0 BY -1 DO

*)

IF (c DIV powerOfTenfI]) > 0 THEN RETURN 1+1;

END;

END;

RETURN 1;

END places;

PROCEDURE pause(msg:ARRAY OF CHAR);

(* Prevents the screen from blanking and returning to the Finder until the user hits a key. msg is typed out. *)

VAR ch:CHAR;

BEGIN

Terminal.WrlteStrlng(msg);

TerminaI.Read(ch);

END pause;

PROCEDURE spaces(n;INTEGER);

VAR i:INTEGER;

BEGIN

FOR l :« 1 TO n DO

Terminal.WrIte(’ ’);

END;

END spaces;

(*** Copies of Terminal procedures ***)

PROCEDURE Wr!teString(s:ARRAY OF CHAR);

BEGIN

TerminaI.WriteString(s);

END WrlteStrtng;

PROCEDURE WrlteLn;

BEGIN

156 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

July

TerminaI.Wr1teLn;

END WrlteLn;

PROCEDURE Write(ciCHAR); BEGIN

TerminaI.WrIte(c);

END Write;

PROCEDURE Read(VAR c:CHAR); BEGIN

TerminaI.Read(c);

END Read;

PROCEDURE ClearScreen;

BEGIN

Terminal.ClearScreen; END ClearScreen;

PROCEDURE Beep;

BEGIN

Terminal.Beep;

END Beep;

BEGIN

powerOfTen

*0'

1;

powerOfTen

Y

:* 10;

powerOfTen

Y

100;

powerOfTen

’3'

:« 1000;

powerOfTen

V

:* 10000;

Table captionEND MyTerminal.

charstuf.def

Programming Project: "Build a Spreadsheet Program/' by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE CharStuff;

(* Useful functions for manipulating characters. *)

EXPORT QUALIFIED TAB, EOF, getChar, ungetChar, toUpper, toLower, toString, IsAlphaNum, isLetter, isUpper, isLower, IsDigit, isWhlte;

CONST TAB - 11C;

EOF ■ 0C; (* end of file *)

(* getChar and ungetChar use InOut’s Read procedure but allow you to push a character back on the Input. Only one character at a time can be ungotten. getChar returns EOF on end of file. *)

PROCEDURE getChar():CHAR;

PROCEDURE ungetChar;

(* These next few are useful for classifying characters. *)

PROCEDURE IsAIphaNum(c:CHAR):BOOLEAN;

PROCEDURE IsLe11 e r(c:CHAR):BOOLEAN;

PROCEDURE IsUpper(c:CHAR):BOOLEAN;

PROCEDURE IsLowe r fc:CHAR):BOOLEAN;

PROCEDURE isDlgIt(c:CHAR):BOOLEAN;

PROCEDURE IsWhIte(c:CHAR):BOOLEAN; (* space, tab or newline (EOL) *)

(* This converts a lower-case character to upper-case, or does nothing If the character isn't a lower-case character. The same procedure is available In module StrlngStuff under the name charCap. *)

PROCEDURE toUpper(c:CHAR):CHAR;

PROCEDURE toLower(c:CHAR):CHAR;

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 157

PROCEDURE toStrlng(c:CHAR; VAR s:ARRAY OF CHAR);

(* Converts the character c Into a string. This procedure won’t be needed for the new Modula-2 standard, because a single character will be compatible with a string. *)

END CharStuff.

charstuf.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE CharStuff;

FROM InOut IMPORT Read, EOL, WriteStrlng;

VAR ch:CHAR;

ungotten:BOOLEAN;

PROCEDURE getChar():CHAR;

BEGIN

IF ungotten THEN

ungotten :« FALSE;

ELSE

Read(ch);

END;

RETURN ch;

END getChar;

PROCEDURE ungetChar;

BEGIN

IF ungotten THEN

WrlteStrlng("ungetChar: can only unget one character at a time"); HALT; '

ELSE

ungotten :« TRUE;

END;

END ungetChar;

PROCEDURE lsAIphaNum(c:CHAR):BOOLEAN;

BEGIN

RETURN isLetter(c) OR IsDlglt(c);

END IsAlphaNum;

PROCEDURE IsLe11 e r(c:CHAR):BOOLEAN;

BEGIN

RETURN IsUpper(c) OR isLower(c);

END IsLetter;

PROCEDURE isUpper(c:CHAR):BOOLEAN;

BEGIN

RETURN (c >- •A*) AND (c <- ’Z’);

END isUpper;

PROCEDURE i8 Lowe r(c:CHAR):BOOLEAN;

BEGIN

RETURN (c >- ’a’) AND (c <« * 2 ');

END IsLower;

PROCEDURE isDiglt(c:CHAR):BOOLEAN;

BEGIN

RETURN (c >- *0*) AND (c <« ’9’);

END IsDiglt;

PROCEDURE isWh11 e(c:CHAR):BOOLEAN;

BEGIN

RETURN (c * * •) OR (c « TAB) OR (c = EOL); END IsWhite;

PROCEDURE toUpper(c:CHAR):CHAR;

BEGIN

IF IsLower(c) THEN RETURN CAP(c);

158 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

ELSE

RETURN c;

END;

END toUpper;

PROCEDURE toLower(c:CHAR):CHAR;

BEGIN

IF isUpper(c) THEN

RETURN CHR(ORD(c) - ORD(’A’) + ORD(*a*));

ELSE

RETURN c;

END;

END toLower;

PROCEDURE toString(c:CHAR; VAR s:ARRAY OF CHAR); BEGIN

S l I J . “ ,

END toString;

BEGIN

ungotten :■ FALSE; END CharStuff.

spread.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE Spreadsheet;

(* Defines the spreadsheet data type. There are a variety of implementations:

The DUMB implementation is Just an array. In automatic mode, every time a value is set, It recalculates the whole spreadsheet. It calls the display handler to redraw those cells which have changed.

The DEPENDENCY implementation is an array with dependency information: each cell knows which other cells depend on Its value. In automatic mode, whenever a value Is changed the tree of dependencies is traversed depth-first, and the display handler Is called for each changed value.

The SPARSE DEPENDENCY implementation is like the dependency, but uses a sparse array of blocks of cells Instead of a real array.

The VIRTUAL SPARSE DEPENDENCY implementation is like the sparse dependency, but will write blocks of cells to the disk when memory is full, and swap them in as needed.

*)

FROM Formula IMPORT formula;

EXPORT QUALIFIED setValue, getValue, setFormula, getFormula, status,

Status, maxRow, maxCol, setAutomatIc, setManual, recalculate. Init, InRange, operationStatus, clearAII;

TYPE Status - (OK, Empty. DivByZero, Overflow, Underflow,

RefError, RangeError. SyntaxError);

VAR operat ionStatus: Status; , a ^ t _

(* Spreadsheet operations (like setValue, etc.) will set this to OK if success, otherwise to an error status, usually RangeError. *)

PROCEDURE init;

PROCEDURE setVaIue(row, col:CARDINAL; vaIue:REAL);

(* Sets the value of the cell at row, col. If automatic recalculation is turned on, this will result in a recalc, operationStatus - RangeError If row, col Is out of range. *)

{continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 159

July

PROCEDURE getVaIue(row, coI:CARDINAL):REAL;

(* Get the value at row, col. Returns 0.0 and sets operatlonStatus to RangeError If out of range. *)

PROCEDURE setFormuIa(row, col:CARDINAL; f:formula);

(* Sets the formula. Computes the value for the cell and displays it operatlonStatus ■ RangeError If row, col out of range. *)

PROCEDURE getFormulo(row, col:CARDINAL):formula;

(* Returns the formula, operatlonStatus - RangeError If out of range. *) PROCEDURE cleorAII;

(* Clears all the spreadsheet’s cells. «)

PROCEDURE 8tatus(row, col:CARDINAL):Status;

(* Returns the cell's status. Con set operationStotus to RangeError. *) PROCEDURE maxRow():CARDINAL;

(* Returns the maximum row value for the spreadsheet. *)

PROCEDURE maxCol():CARDINAL;

(* Returns the maximum column value for the spreadsheet. *)

PROCEDURE satAutomatlc;

(* Sets recalc mode to automatic. *)

PROCEDURE setManual;

(* Sets recalc mode to manual. *)

PROCEDURE recalculate;

(* Recalculates the spreadsheet. Any cell which changes Is redisplayed. *) PROCEDURE lnRonge(row, col:CARDINAL):BOOLEAN;

(* Returns TRUE If row, col ore within the bounds of the spreadsheet (row between 1 and maxRow, column between 1 and maxCol). *)

END Spreadsheet.

stringst.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE StrlngStuff;

EXPORT QUALIFIED string40, string80, strlng160, string255, strlngCap, charCap, stringLen, strlngCopy, stringEqual. deleteChar, findChar, stringAssign, insertChar;

TYPE

strIng40 - ARRAY[0..40l OF CHAR; string80 - ARRAY[0..80J OF CHAR; strlng160 - ARRAY[0..160] OF CHAR; str!ng255 - ARRAY[0..255] OF CHAR;

PROCEDURE chorCap(ch:CHAR):CHAR;

PROCEDURE stringCap(VAR s:ARRAY OF CHAR);

PROCEDURE stringLen(VAR s:ARRAY OF CHAR):CARDINAL;

PROCEDURE stringAssIgn(VAR dest:ARRAY OF CHAR; source:ARRAY OF CHAR); PROCEDURE stringCopy(VAR dest. source:ARRAY OF CHAR; from, to:CARDINAL); PROCEDURE stringEqual(si. s2:ARRAY OF CHAR):BOOLEAN;

PROCEDURE deleteChar(VAR s:ARRAY OF CHAR; pos:CARDINAL);

PROCEDURE insertChar(ch:CHAR; VAR s:ARRAY OF CHAR; posCARDINAL);

160 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

PROCEDURE flndChar(s:ARRAY OF CHAR; ch:CHAR; VAR pos:CARDINAL):BOOLEAN; END StrIngStuff.

July

spreadl.mod

Programming Project: "Build a Spreadsheet Program." by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE Spreadsheet;

(* Defines the spreadsheet data type. There are a variety of implementations:

The DUMB implementation is just an array. In automatic mode, every time a value is set, it recalculates the whole spreadsheet. It calls the display handler to redraw those cells which have changed.

*)

FROM Formula IMPORT formula, emptyFormula;

IMPORT Formula;

FROM Evaluator IMPORT evaIuateFormuI a;

FROM Mi sc IMPORT fatal;

FROM DisplayHandler IMPORT displayCell;

CONST maxR * 32; maxC = 60;

TYPE cell - RECORD

value: REAL; form: formula; status: Status;

END;

VAR sheet: ARRAY[1..maxR], [1..maxC] OF cell; automatic:BOOLEAN;

PROCEDURE init;

VAR row, coI:CARDINAL;

BEGIN

automatic :■ TRUE;

FOR row :- 1 TO maxR DO FOR col :- 1 TO maxC DO

sheetTrow, col].status Empty; sheet[row, colj.form :« emptyFormuI a; END;

END;

END init;

PROCEDURE cI earAI I;

VAR row, coI:CARDINAL;

BEGIN

FOR row :« 1 TO maxR DO FOR col :« 1 TO maxC DO WITH sheet[row, col] DO status :« Empty;

Formula.free(form); form :* emptyFormuI a;

END;

END;

END;

END clearAII;

PROCEDURE setAutomatic; BEGIN

automatic :• TRUE; END setAutomatic;

PROCEDURE setManual;

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 161

BEGIN

automatic FALSE;

END setManuaI;

PROCEDURE InRange(row, coI:CARDINAL):BOOLEAN;

BEGIN

RETURN (row >■ 1) AND (row <- maxR) AND (col >- 1) AND (col <= maxC) END inRange; 7

PROCEDURE setVaIue(row, coI:CARDINAL; vaIue:REAL);

BEGIN '

IF InRange(row, col) THEN

sheetTrow, coll.value ;■ value; sheet[row, col].status :* OK; operatlonStatus :* OK; dIspIayCeI I(row, col);

IF automatic THEN recaIcuI ate;

END;

ELSE

operatlonStatus :» RangeError;

END;

END setVaIue;

PROCEDURE getVaIue(row, coI:CARDINAL):REAL;

BEGIN

IF NOT lnRange(row, col) THEN

operatlonStatus :■ RangeError;

RETURN 0.0;

ELSIF sheet[row, col].status <> OK THEN

operatlonStatus :■ sheetfrow, col].status:

RETURN 0.0;

ELSE

operatlonStatus := OK;

RETURN sheet[row, col].value;

END;

END getVaIue;

PROCEDURE setFormuIa(row, coI:CARDINAL; f;formula);

IF InRange(row, col) THEN WITH sheet[row, col] DO form f; value 0.0;

status OK;

evaIuateFormuIa(form, row, col, value, status); displayCelI(row, col);

IF automatic THEN recalculate;

END;

END;

operatlonStatus :■ OK;

ELSE

operatlonStatus :» RangeError;

END;

END setFormula;

PROCEDURE getFormuIa(row, coI CARDINAL):formuI a;

BEGIN

IF InRange(row, col) THEN operatlonStatus :« OK;

RETURN sheet[row, coll.form;

ELSE

operatlonStatus :« RangeError;

RETURN emptyFormuI a;

END;

END getFormula;

PROCEDURE cl ear(row, coI;CARDINAL);

BEGIN J

IF InRange(row, col) THEN

sheetfrow, coll.status := Empty; sheet[row, colj.form :« emptyFormuI a; operatlonStatus :« OK;

ELSE

162 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

operationStatus :* RangeError;

END;

END clear;

PROCEDURE status(row, co I CARDINAL) -.Status;

BEGIN

IF inRange(row, col) THEN operationStatus :■ OK;

RETURN sheet[row, col].status;

ELSE

operationStatus :* RangeError;

RETURN RangeError;

END;

END status;

PROCEDURE maxRow():CARDINAL;

BEGIN

RETURN maxR;

END maxRow;

PROCEDURE maxCoI():CARDINAL;

BEGIN

RETURN maxC;

END maxCoI;

PROCEDURE recalculate;

VAR row, coI;CARDINAL; vaI:REAL; stat:Status;

BEGIN

FOR row :* 1 TO maxR DO FOR col :* 1 TO maxC DO WITH sheet[row, col] DO

IF (status <> Empty) AND (status <> SyntaxError) AND (NOT Formula.empty(form)) THEN evaIuateFormuIa(form, row, col, val, stat);

IF (stat <> status) OR (val <> value) THEN status :* stat; value :« val; displayCelI(row, col);

END;

END;

END;

END;

END;

operationStatus :■ OK;

END recalculate;

BEGIN

END Spreadsheet.

numstostr.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

pxEDEFINITION MODULE NumToString;

EXPORT QUALIFIED cardToString, realToString;

PROCEDURE cardToStrIng(c:CARDINAL;

VAR s:ARRAY OF CHAR);

PROCEDURE realToStrlng(r:REAL; precision: CARDINAL; VAR s:ARRAY OF CHAR);

END NumToString.

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 163

mystor1.def

Progrommlng Project: "Build o Spreadsheet Program,“ by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE MyStoragej FROM SYSTEM IMPORT ADDRESS;

EXPORT QUALIFIED bytesPerWord, ALLOCATE, DEALLOCATE, available CONST bytesPerWord = 2;

PROCEDURE ALLOCATE(VAR a:ADDRESS; nBytes:CARDINAL);

PROCEDURE DEALLOCATE(VAR a:ADDRESS; nBytesCARDINAL);

PROCEDURE oval IabIe(nBytes: CARDINAL):BOOLEAN;

END MyStorage.

r.umtostr .mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE NumToString;

frou ^ tr ‘ n 9 Stuf f IMP ?EL^ r ' n « L#n * f,ndCh <"-. InsertChar. deleteChar;

FROM NumConversions IMPORT CardToStr; *

FROM ReaIConversIons IMPORT RealToFormStr. RealProcResponses,

RealConversionRes, Rea IToSciStr;*

CONST maxDigits - 7; (* if the number would be larger than this, we use

scientific notation and preserve this many digits *)

™CEDURE cardToStr ing(c.-CARDINAL; VAR s:ARRAY OF CHAR);

VAR fieldWIdthrCARDINAL; '

BEGIN

(* keep trying to convert until success *) fieldWidth :« 0; '

REPEAT

INC(fieldWidth);

CardToStr(c, s, fieldWidth);

UNTIL (s[0] <> 0C) (* success *)

END cardTo?Jri.!gt ldWidth " ^ ( * '° n9eSt Cardina ' " 5 plaCes

long *)

BEGIN° URE realToStrin 9( r:REAL: precis Ion .-CARDINAL; VAR s : ARRAY OF CHAR);

RealToFormStrtr. s, maxDigIts+2. precision); (* +2 for sign and dec. pt. *) IF Rea IConversionRes ■ fieldError THEN ” * '

(* string too long—use scientific notation *)

END‘ RealT ° SCiStr ^ r ’ S * 101 2 ^ : 10 spaces ov *rall, 2 sig. digits *)

cosmeticize(s);

END reaIToString;

PROCEDURE cosmeticize(VAR s:ARRAY OF CHAR); (* For reals only. Things to fix:

1 • no Ieading bIanks

2 . no leading zero: add one

3. trailing zeros: delete them

4. trailing decimal point: remove it

*)

VAR i:CARDINAL;

164 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

BEGIN

(* delete leading blanks *)

WHILE s[0] « * ' DO deleteChar(s, 0);

END;

(♦insert a leading 0 if necessary ♦) IF (s[0] « '.’) THEN insertChar(*0*, s, 0);

END;

(♦ remove trailing zeros ♦)

I :* strlngLen(s)-1;

WHILE s[i] - ’0’ DO s[i] :« 0C;

DEC(i);

END;

(♦ remove trailing decimal point ♦) IF s[I] * THEN s[i] 0C;

END;

END cosmeticize;

BEGIN

END NumToString.

screenha.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE ScreenHandIer;

EXPORT QUALIFIED init, setCursorPos, getCursorPos, Write, WriteString; PROCEDURE init;

PROCEDURE setCur8orPos(row, coI:CARDINAL);

PROCEDURE getCursorPos(VAR row, coI:CARDINAL);

PROCEDURE Write(ch:CHAR);

PROCEDURE WriteStrIng(s:ARRAY OF CHAR);

END ScreenHandIer.

mystor1.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE MyStorage;

(♦ The "available" function should figure out how much memory is actually available, and return TRUE if that is >■ its argument. But for the purposes of testing, my function just assumes there are 5K available and decrements a counter each time it is called. You will want to change this if you intend to use the spreadsheet. ♦)

IMPORT Storage;

FROM SYSTEM IMPORT ADDRESS;

PROCEDURE ALLOCATE(VAR a:ADDRESS; nBytes:CARDINAL);

BEGIN

IF ava11abIe(nBytes) THEN

Storage.ALLOCATE(a, (nBytes+1) DIV bytesPerWord);

ELSE

a :- NIL;

END;

END ALLOCATE;

[continued]

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 165

PROCEDURE DEALLOCATE(VAR a:ADDRESS; nBytes:CARDINAL); BEGIN

Storage.DEALLOCATE(a, (nBytes+1) DIV bytesPerWord); a :« NIL;

END DEALLOCATE;

VAR freeBytes:CARDINAL;

PROCEDURE avaI IabIe(nBytes:CARDINAL):BOOLEAN;

BEGIN

IF nBytes <- freeBytes THEN DEC(freeBytes, nBytes);

RETURN TRUE;

ELSE

RETURN FALSE;

END;

END avallable;

BEGIN

freeBytes :• 5 * 1024; (* 5K for testing purposes *)

END MyStorage.

mystir2.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE MyStorage2;

FROM SYSTEM IMPORT ADDRESS;

EXPORT QUALIFIED ALLOCATE, DEALLOCATE, available; PROCEDURE ALLOCATE (VAR a: ADDRESS; nWords .-CARDINAL) ; PROCEDURE DEALLOCATE(VAR a:ADDRESS; nWords:CARDINAL); PROCEDURE avaiIabIe(nWords:CARDINAL):BOOLEAN;

END MyStorage2.

mystor2.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE MyStorage2;

(* The "available" function should figure out how much memory is actually available, and return TRUE if that is >= its argument. But for the purposes of testing, my function just assumes there are 6K available and decrements a counter each time it is called. You will want to change this if you intend to use the spreadsheet. *)

IMPORT Storage;

FROM SYSTEM IMPORT ADDRESS;

VAR freeWordsCARDINAL;

PROCEDURE ALLOCATE (VAR a .-ADDRESS; nWords : CARDINAL) ;

BEGIN

IF aval IabIe(nWords) THEN

Storage.ALLOCATE(a, nWords);

DEC(freeWords, nWords);

ELSE

a :« NIL;

END;

END ALLOCATE;

PROCEDURE DEALLOCATE(VAR a:ADDRESS; nWords:CARDINAL);

166 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

BEGIN

Storage.DEALLOCATE^, nWords);

INC(freeWords, nWords); a NIL;

END DEALLOCATE;

PROCEDURE ava iI ab I e( nWo r ds :CARDINAL):BOOLEAN;

BEGIN

RETURN nWords <« freeWords;

END avaitable;

BEGIN

freeWords :■ 3 * 1024; (* 3K words (6K bytes) for testing purposes *)

END MyStorage2.

disklo.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE DIsklO;

(* For low-level I/O to a temporary disk file. Used in the virtual implementation of the spreadsheet. *)

EXPORT QUALIFIED init, WriteReal, ReadReal, WriteString, ReadString,

DiskAddress, WriteCard, ReadCard, startRead, startWrite, endRead, empty, endWrite, startRewrite, endRewrite, freeDiskStorage, nuIIDiskAddress, clear, freeDiskAddress;

TYPE DiskAddress;

VAR nulIDiskAddress:DiskAddress;

PROCEDURE Init;

PROCEDURE clear;

PROCEDURE startWrite;

PROCEDURE endWr11e():DIskAddress;

PROCEDURE startRewrite(da:DiskAddress);

PROCEDURE endRewrIte():DiskAddress;

PROCEDURE startRead(da:DiskAddress);

PROCEDURE endRead;

PROCEDURE Wr1teReaI(r:REAL);

PROCEDURE ReadReal(VAR r:REAL);

PROCEDURE WrIteStr!ng(VAR s:ARRAY OF CHAR);

PROCEDURE ReadStr1ng(VAR s:ARRAY OF CHAR);

PROCEDURE Wr11eCard(c:CARDINAL);

PROCEDURE ReadCard(VAR c:CARDINAL);

PROCEDURE freeDiskStorage(VAR da:DiskAddress);

(* Frees the disk address and the associated storage on the disk. *) PROCEDURE freeDiskAddress(VAR da:DiskAddress);

PROCEDURE empty(da:DIskAddress):BOOLEAN;

END DisklO.

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 167

formula.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE Formula;

EXPORT QUALIFIED formula, toStrlng, toFormula, free, write, empty, length, emptyFormula;

TYPE formula;

VAR emptyFormula:formuI a;

PROCEDURE toStrIng(f:formula; VAR s:ARRAY OF CHAR);

PROCEDURE toFormuI a(s:ARRAY OF CHAR):formuI a;

PROCEDURE free(VAR f:formuI a);

PROCEDURE wrIte(f:formuI a);

PROCEDURE empty(f:formula):BOOLEAN;

PROCEDURE Iength(f:formuI a):CARDINAL;

END Formula.

formuI a.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE Formula;

FROM StrlngStuff IMPORT strlngLen, strIngAssign; FROM MIsc IMPORT assert;

FROM Terminal IMPORT Write;

FROM MyStorage IMPORT allocate, deallocate;

TYPE formula - POINTER TO ARRAY[0..32000] OF CHAR;

PROCEDURE toStr!ng(f:formula; VAR s:ARRAY OF CHAR); VAR l, Ien:CARDINAL;

BEGIN

IF f - NIL THEN s[0] :« 0C;

ELSE

len :» length(f);

FOR I :- 0 TO len-1 DO IF I > HIGH(s) THEN RETURN;

ELSE

s[I] f"[!];

END;

END;

IF len <« HIGH(s) THEN s[len] :■ 0C;

END;

END;

END toStrlng;

PROCEDURE toFormuIa(s:ARRAY OF CHAR):formuI a;

VAR f:formuI a;

I. Ien:CARDINAL;

BEGIN

len :» strIngLen(s);

IF len = 0 THEN RETURN NIL;

168 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

ELSE

f :* new(len);

FOR i :■ 0 TO len-1 DO f-[I] : = s[1];

END;

f*[Ien] 0C;

RETURN f;

END;

END toFormula;

PROCEDURE wrIte(f:formula);

VAR I, Ien:CARDINAL;

BEGIN

len :*= length(f);

IF len <> 0 THEN

FOR i := 0 TO len-1 DO Wr1te(f A [I]);

END;

END;

END write;

PROCEDURE empty(f:formuI a):BOOLEAN;

BEGIN

RETURN f - NIL;

END empty;

PROCEDURE Iength(f:formula):CARDINAL;

VAR i:CARDINAL;

BEGIN

IF f - NIL THEN RETURN 0;

ELSE

I :« 0;

WHILE f*[I] <> 0C DO INC(i);

END;

RETURN I;

END;

END length;

PROCEDURE new(nChars:CARDINAL):formula;

VAR f:formula;

BEGIN

allocate(f, nChars+1);

assert(f <> NIL, "FormuI a.new: out of room"); RETURN f;

END new;

PROCEDURE free(VAR f:formuI a);

BEGIN

IF f <> NIL THEN

deallocate(f, length(f)+1); f :* NIL;

END;

END free;

BEGIN

emptyFormula :« NIL;

END Formula.

cel 1181.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE CellLlst;

FROM Formula IMPORT formula;

EXPORT QUALIFIED cellLlst, nextCell, InitFindDep, nextDep, cellRow, cellCol, addToCelI List, removeFromCeI I List, nuIICeI IList, empty, freeCelIList;

[continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 169

TYPE c«lILIet;

VAR nul ICel IList :c«l ILIet;

PROCEDURE empty(cl:celIList):BOOLEAN;

PROCEDURE nextCelI(cl:celIList):celILIet;

PROCEDURE celIRow(cl:celIL!et):CARDINAL;

PROCEDURE cel I Co I(cl:celIL!st):CARDINAL;

PROCEDURE initFIndDep(curRow, curCol:CARDINAL; f:formula); PROCEDURE nextDep(VAR row, col:CARDINAL):BOOLEAN;

PROCEDURE addToCelILIet(VAR cl:celILIet; row. coI CARDINAL); PROCEDURE removeFromCeIILIet(VAR cltcelILIet; row, coI:CARDINAL); PROCEDURE freeCelILIet(VAR cl reelILIet);

END CelILIet.

commanddp.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE CommandProc;

FROM InOut IMPORT ReadString;

FROM Evaluator IMPORT evaIuateStrIng;

IMPORT Formula;

FROM Spreadsheet IMPORT Status;

FROM StrlngStuff IMPORT strlngLen, flndChar, strlngCopy, string160, strlng80, strlngCap, deleteChar;

FROM NumConversIons IMPORT StrToCard, NumConversionRes, NumProcResponses; FROM Terminal IMPORT Beep;

FROM DispIayHandIer IMPORT wrltePrompt, dispIayFormuI a, message;

FROM StringOps IMPORT Concat;

VAR commandstring: string160; curRow, curCoI:CARDINAL;

PROCEDURE readCommand(VAR c:command; crRow, crCo I-.CARDINAL);

BEGIN

curRow := crRow; curCoI :« crCoI; dispIayFormuIa(curRow, curCol);

LOOP

wr itePrompt(curRow, curCol);

REPEAT

ReadStrIng(commondString);

UNTIL commandString[0] <> 0C; stringCap(commandString);

IF commandParse(commandStrIng, c) THEN EXIT;

END;

END;

END readCommand;

PROCEDURE commandParse(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN;

VAR ch:CHAR;

BEGIN

ch :■ s[0];

deIeteChar(s, 0);

CASE ch OF

170 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

’A’:

c.type

:® Automatic;

* C *:

RETURN

copy(s, c);

*D # :

c.type

:» Down;

•F’:

RETURN

setFormula(s, c);

*K

c.type

:* Clear;

*L # :

c.type

Left;

'M*:

c.type

Manua1;

# N*:

RETURN

o

CO

L_

a>

c

i_

o

a>

c

•P*:

RETURN

preclsion(s, c);

* Q *:

c.type

:* Quit;

*R*:

c.type

Right;

'U*:

c.type

:■ Up;

•V:

RETURN

setValue(s, c);

RETURN

co1Wldth(s, c);

c.type

:* Recalc; doCe1IRef(s, c);

RETURN

ELSE

Beep;

s[0]

:* 0C;

Table captionmessage("II IegaI character"); RETURN FALSE;

END;

RETURN TRUE;

END commandParse;

PROCEDURE copy(VAR s:ARRAY OF CHAR; VAR c;command):BOOLEAN;

BEGIN

c.type :« Copy;

RETURN celIRef(s, c);

END copy;

PROCEDURE setFormuIa(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN; BEGIN

c.type :■ SetFormula;

c.form :* FormuI a.toFormuIa(s);

RETURN TRUE;

END setFormula;

PROCEDURE newCorner(VAR s:ARRAY OF CHAR; VAR c:command);BOOLEAN; BEGIN

c.type :■ NewCorner;

RETURN celIRef(s. c);

END newCorner;

PROCEDURE prec!slon(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN; BEGIN

c.type :■ Precision;

RETURN cardFromStrlng(s, c.precIsI on);

END precision;

PROCEDURE setVaIue(VAR s:ARRAY OF CHAR; VAR c:command)iBOOLEAN; VAR stat:Status;

BEGIN

evaluateStrlng(s, curRow, curCol, c.value, stat); c.type SetValue;

IF stat <> OK THEN cantEvalMsg(s);

END;

RETURN stat - OK;

END setValue;

PROCEDURE coIWldth(VAR s;ARRAY OF CHAR; VAR c:command):BOOLEAN; BEGIN

c.type :« ColWidth;

RETURN cardFromStrlng(s, c.colWIdth);

END colWldth;

PROCEDURE doCeI I Ref(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN; VAR b:BOOLEAN;

BEGIN

b ;■ cel I Re f1(s, c); c.type Cell Ref;

RETURN b;

END doCelI Ref;

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 171

I uly

PROCEDURE ceI I Ref(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN;

(* Syntax: [ <formulo> , <formula> ] *)

VAR IeftPos:CARDINAL;

BEGIN

IF NOT fIndChar(•, *[\ leftPos) THEN message("II legal cell specification—no left bracket 1 ');

RETURN FALSE;

ELSE

WHILE s[0] <> ’[• DO deIeteChar(s, 0);

END;

deIeteChar(e, 0);

RETURN celIRef1(s, c);

END;

END cel I Ref;

PROCEDURE cel I Ref 1(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN;

(* Syntax: <formula> , <formula> ] *)

VAR st:Status; v:REAL;

rowForm, colForm: strlng80; commaPos, rIghtPos:CARDINAL;

BEGIN

IF (NOT flndChar(s, commaPos)) OR

(commaPos ■ 0) OR (commaPos ■ strlngLen(s)-1) THEN message("IIlegal cell specification—bad comma");

RETURN FALSE;

ELSIF (NOT f!ndChar(s, ']’, rightPos)) OR (rlghtPos < commaPos) THEN message("II IegaI ceil specification—bad right bracket");

RETURN FALSE;

ELSE

strIngCopyfrowForm, s, 0, commaPos-1);

str IngCopy(colForm, s, commaPos+1, rightPos-1);

evaIuateStrIng(rowForm, curRow, curCol, v, st);

IF st <> OK THEN

cantEvaIMsg(rowForm);

RETURN FALSE;

ELSE

c.row :- TRUNCfv);

evaluateString(colForm, curRow, curCol, v, st);

IF st <> OK THEN

cantEvaIMsg(coI Form);

RETURN FALSE;

ELSE

c.col :- TRUNC(v);

RETURN TRUE;

END;

END;

END;

END cel I Ref 1;

PROCEDURE cardFromStrIng($:ARRAY OF CHAR; VAR c:CARDINAL):BOOLEAN; BEGIN

StrToCard(s, c);

IF NumConverslonRes <> noError THEN

message("CouId not convert number");

END;

RETURN NumConverslonRes = noError;

END cardFromStrIng;

PROCEDURE cantEvaIMsg(formStrIng:ARRAY OF CHAR);

VAR msg:strlng160;

BEGIN

Concat(msg, "Cannot evaluate ", formStrlng); message(msg);

END cantEvalMsg;

BEGIN

END CommandProc.

ELSE

operatlonStatus :■ RangeError;

END;

END clear;

172 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

PROCEDURE status(row, coI:CARDINAL):Status; BEGIN

IF InRange(row, col) THEN operatlonStatus :* OK;

RETURN sheet[row, col].status;

ELSE

operatlonStatus :* RangeError;

END;

END status;

PROCEDURE maxRowQ: CARD INAL;

BEGIN

RETURN maxR;

END maxRow;

PROCEDURE maxCoI () .-CARDINAL;

BEGIN

RETURN maxC;

END maxCoI;

PROCEDURE recalculate;

VAR row, col CARDINAL; val:REAL; statiStatus;

BEGIN

FOR row 1 TO maxR DO FOR col ;* 1 TO maxC DO WITH sheet[row, col] DO

IF (status » OK) AND (NOT FormuIa.empty(form)) THEN evaluateFormula(form, row, col, val, stat);

IF (stat <> status) OR (val <> value) THEN status :■ stat; value val;

dlsplayCelI(row, col);

END;

END;

END;

END;

END;

operatlonStatus OK;

END recalculate;

BEGIN

END Spreadsheet.

ceI 12.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE Cell;

(* This module Implements the virtual spreadsheet. It uses the module DisklO for low-level I/O. Despite what It says in the article, I do not check touchCount for overflow. *)

FROM Cel ILIst IMPORT ceI ILIst, nuIICeIILIst. freeCeI IList, nextCell, ceI I Row, cellCol, addToCeI ILIst;

IMPORT CelILIst;

FROM MyStorage2 IMPORT ALLOCATE. DEALLOCATE;

FROM Formula IMPORT formula, emptyFormuI a;

IMPORT Formula;

FROM Misc IMPORT fatal, assert;

FROM Spreadsheet IMPORT Status;

FROM DisklO IMPORT DIskAddress, Init, WrtteReal, ReadReal, WriteString, clear, ReadString, WriteCard, ReadCard, freeDiskStorage, nuI IDiskAddress, empty, startWrite, endWrlte, startRewrIte, endRewrite, startRead, endRead, freeDIskAddress;

FROM StrlngStuff IMPORT string255;

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 173

CONST nRows ■ 10; nCole ■ 10;

TYPE

cellArray - ARRAY[0..nRows-1], [0..nCoIe-1] OF cell; cellArrayPtr ■ POINTER TO cellArray; ceIIChunkPtr - POINTER TO cellChunk; celIChunk - RECORD

startRow, startCol:CARDINAL; down, right; ceIIChunkPtr;

InMemory, dlrty:BOOLEAN; touchedLastrCARDINAL; dlskAddr:DIskAddress; ceI I 8: cel IArrayPtr;

END;

VAR sheet:ceIIChunkPtr; touchCount:CARDINAL;

PROCEDURE InItSheet;

BEGIN

sheet :« newCeIIChunk(1, 1, NIL, NIL); inlt; (* DisklO *) touchCount :■ 0;

END InltSheet;

PROCEDURE clearSheet;

VAR rowCcp, coICcp, temp;ceIIChunkPtr;

BEGIN

clear; (* DisklO *) rowCcp :■ sheet;

WHILE rowCcp <> NIL DO coICcp :■ rowCcp".rIght;

WHILE coICcp <> NIL DO temp :■ coICcp; coICcp :■ coICcp".right; freeCelIChunk(temp);

END;

temp :■* rowCcp; rowCcp :« rowCcp".down; freeCelIChunk(temp);

END;

InltSheet;

END clearSheet;

PROCEDURE getCeI I(row, coI:CARDINAL; VAR creel I);

VAR ccprceIIChunkPtr;

BEGIN

INC(touchCount);

IF findCelIChunk(row, col, ccp) THEN IF NOT ccp".InMemory THEN getCelIsFromDisk(ccp);

END;

WITH ccp" DO

c r* cells"[row-startRow, co1-startCoI]; touchedLast ;■ touchCount;

END;

ELSE

cIearCeI I(c);

END;

END getCelI;

PROCEDURE setCeI I(row, coI:CARDINAL; creel I);

VAR ccprceIIChunkPtr;

BEGIN

INC(touchCount);

IF NOT fIndCeIIChunk(row, col, ccp) THEN ccp r» addCeIIChunk(row, col, ccp);

END;

IF NOT ccp".InMemory THEN getCelIsFromDIsk(ccp);

END;

WITH ccp" DO

ceI Is"[row-startRow, co1-startCoI] r= c; touchedLast r= touchCount; dirty r= TRUE;

174 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

END;

END setCeI I;

PROCEDURE addCeIIChunk(row, coI:CARDINAL; ccp:ceIIChunkPtr):ceIIChunkPtr;

VAR newCcp:ceIIChunkPtr;

BEGIN

newCcp :* newCeIIChunk(start(row, nRows), start(col, nCols), NIL, NIL); WITH ccp* DO

IF (row >* startRow) AND (row < startRow+nRows) THEN

(* the new cell chunk belongs to the right of this one *) newCcp*.rIght right; right newCcp;

ELSIF row >■ startRow+nRows THEN

(* the new cell chunk belongs below this one *)

IF (down ■ NIL) OR (row < down*.startRow) THEN (* the new cell chunk belongs directly below *) newCcp*.down :* down; down :« newCcp;

ELSE (* It belongs to the left of the one below ★)

assert((row >» down*.startRow) AND (row < down*.startRow+nRows), "addCeIIChunk: wrong chunk returned"); newCcp*.rIght :« down; newCcp*.down :* down*.down; down :* newCcp;

END;

ELSE

fata I('addCeIIChunk: wrong cell chunk returned*);

END;

END;

RETURN newCcp;

END addCeIIChunk;

PROCEDURE start(rowOrCoI, n:CARDINAL):CARDINAL;

(* computes start row or start col. *)

BEGIN

RETURN ((rowOrCo1-1) DIV n)*n + 1;

END start;

PROCEDURE findCeIIChunk(row, coI:CARDINAL; VAR ccp:ceIIChunkPtr):BOOLEAN;

(* Returns TRUE If It finds the cell chunk containing the cell [row,col].

If It returns FALSE, then ccp will point to the cell chunk just "beforewhere the right cell chunk should be. Before can mean just above, or Just to the left, depending upon where the new cell chunk should be put. *)

BEGIN

ccp :» sheet;

WHILE row >* ccp*.startRow+nRows DO WITH ccp* DO

IF (down ■ NIL) (* need to add a new chunk below this one *0

OR frow < down*.startRow) (* need new chunk between this and next *) OR (frow < down*.startRow+nRows) AND

(col < down*.startCol)) THEN (* need new chunk below & left *) RETURN FALSE;

ELSE

ccp :* down;

END;

END;

END;

(* We are now on the correct row *)

WHILE col >■ ccp*.8tartCol+nCols DO

IF (ccp*.right - NIL) OR (col < ccp*.rIght*.startCoI) THEN RETURN FALSE;

ELSE

ccp :■ ccp*.right;

END;

END;

RETURN TRUE;

END fIndCelIChunk;

PROCEDURE doForAIICells(cp:celIProc);

VAR rowCcp, coICcp;ceIIChunkPtr;

BEGIN

rowCcp sheet;

REPEAT

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 175

coICcp:- rowCcp;

REPEAT

doForCelIChunk(coICcp, cp); coICcp :■ coICcp*.rIght;

UNTIL coICcp - NIL; rowCcp :■ rowCcp*.down;

UNTIL rowCcp - NIL;

END doForAIICeI Is;

PROCEDURE doForCelIChunk(ccp:ceIIChunkPtr; cp:celIProc); VAR row, coI:CARDINAL;

BEGIN

WITH ccp* DO

IF NOT InMemory THEN

getCelIsFromDisk(ccp);

END;

FOR row :■ startRow TO startRow+nRows-1 DO FOR col :« startCol TO startCoI+nCoIs-1 DO

cp(row, col, ceI Is*[row-startRow, co1-startCoI]); END;

END;

END;

END doForCelIChunk;

PROCEDURE newCelIChunk(startR, startC:CARDINAL; d,r:celIChunkPtr):ceIIChunkPtr

VAR ccpicelIChunkPtr;

BEGIN

NEW(ccp);

WHILE ccp ■ NIL DO (* out of memory; throw out a chunk to disk *) putCelIsOnDisk;

NEW(ccp);

END;

WITH ccp* DO

cells :■ newCelIArray();

startRow startR;

startCol startC;

down :* d;

right r;

inMemory :* TRUE;

dirty TRUE;

touchedLast 0;

dlskAddr :■ nuIIDiskAddress;

END;

RETURN ccp;

END newCeIIChunk;

PROCEDURE freeCeIIChunk(VAR ccp:ceIIChunkPtr);

BEGIN

IF ccp^.inMemory THEN

freeCelIArray(ccp A .ceI Is);

END;

freeDiskAddress(ccp A .diskAddr);

DISPOSE(ccp);

ccp :«* NIL;

END freeCelIChunk;

PROCEDURE newCelIArray():cellArrayPtr;

VAR captceI IArrayPtr;

BEGIN

NEW(cap);

WHILE cap = NIL DO putCeI IsOnDisk;

NEW(cap);

END;

clearCellArray(cap);

RETURN cap;

END newCeI IArray;

PROCEDURE freeCeI IArray(VAR cap;ceI IArrayPtr);

VAR row, coI:CARDINAL;

BEGIN

FOR row :« 0 TO nRows-1 DO FOR col :« 0 TO nCols-1 DO WITH cap*[row, col] DO

176 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

freeCelIList(dependentCeI Is);

FormuI a.free(form);

END;

END;

END;

DISPOSE(cap); cap :« NIL;

END freeCeI IArray;

PROCEDURE clearCelIArray(VAR copies I IArrayPtr);

VAR row, col:CARDINAL;

BEGIN

FOR row :« 0 TO nRows-1 DO FOR col i- 0 TO nCols-1 DO clearCelI(cap"[row, col]);

END;

END;

END cIearCeI I Array;

PROCEDURE clearCelI(VAR cice II);

BEGIN

WITH c DO

status :* Empty; form i« emptyFormuI a; dependentCeI Is i- nuIICeI ILIst;

END;

END clearCelI ;

(* Virtual memory stuff *)

PROCEDURE getCelIsFromDIsk(ccpiceIIChunkPtr);

BEGIN

WITH ccp" DO

cells i- newCeI IArray(); (* This may result in a chunk being swapped out *) readCeI Is(ceI Is, diskAddr); inMemory i« TRUE; dirty i- FALSE;

END;

END getCeI IsFromDIsk;

PROCEDURE putCelIsOnDisk;

VAR ccpiceIIChunkPtr;

BEGIN

ccp i- fIndChunkToThrowOut();

WITH ccp" DO IF dirty THEN

writeCells(ccp".celIs, ccp".diskAddr);

END;

freeCelIArray(celIs); inMemory ;* FALSE;

END;

END putCelIsOnDisk;

PROCEDURE flndChunkToThrowOut()icelIChunkPtr;

(* Uses LRU to find chunk to discard. Looks through every cell chunk in memory, returning the one accessed least recently.

Resets touchCount. *)

VAR rowCcp, ccp, IruCcpicelIChunkPtr;

BEGIN

IruCcp :■ NIL; (* the least recently used chunk found *)

rowCcp i* sheet;

WHILE rowCcp <> NIL DO ccp :* rowCcp;

WHILE ccp <> NIL DO WITH ccp" DO IF inMemory AND

((IruCcp ■ NIL) OR (touchedLast < IruCcp".touchedLast)) THEN IruCcp :« ccp;

END;

ccp ;■ right;

END;

END;

rowCcp rowCcp".down;

END;

[continued]

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 177

I uly

assort(IruCcp <> NIL, "fIndChunkToThrowOut: no chunks In memory!");

(* This is possible if, say, there are so many cell chunks allocated that the storage for them, even when the cells parts are on disk, exceeds memory capacity. *)

RETURN IruCcp;

END fIndChunkToThrowOut;

PROCEDURE wrIteCells(cap:cellArrayPtr; VAR da:DiskAddress);

VAR s:string255;

row, coI:CARDINAL;

BEGIN

IF empty(da) THEN startWrite;

ELSE

startRewrIte(da);

END;

FOR row :■ 0 TO nRows-1 DO FOR col 0 TO nCols-1 DO WITH cap~[row,col1 DO WrIteReal(value;;

WrIteCard(CARDINAL(status));

FormuI a.toStrIng(form, s);

WriteString(s);

writeCelIList(dependentCeI Is);

END;

END;

END;

IF empty(da) THEN da :« endWriteQ;

ELSE

da :■ endRewrIte();

END;

END wr i teCe Ms;

PROCEDURE readCeI Is(cap:ceI IArrayPtr; da:DIskAddress);

VAR s:strlng255;

row, col, temp:CARDINAL;

BEGIN

startRead(da);

FOR row :* 0 TO nRows-1 DO FOR col 0 TO nCols-1 DO WITH cap~[row,col] DO ReadReaI(vaIue);

ReadCard(temp); status :■ Status(temp);

ReadStrlng(s);

form :* FormuI a.toFormuIa(s); readCelIList(dependentCeI Is);

END;

END;

END;

endRead;

END readCelIs;

PROCEDURE writeCelILIst(cI:ceI IList);

(* Writes a cell list by first writing Its length, then the pairs of row,col *) VAR clisticelIList;

Ien:CARDINAL;

BEGIN

clist :« cl; len :■ 0;

WHILE NOT CelIList.empty(clist) DO INC(len);

clist :* nextCeI I(cIist);

END;

WriteCard(len); clist :* cl;

WHILE NOT CelIList.empty(clist) DO WrlteCard(cellRow(cl1st));

WriteCard(celI Co I(clist)); clist :* nextCeI 1(cIist);

END;

END writeCelIList;

PROCEDURE readCelI List(VAR c1:ceI 1List);

VAR len, i, row, coI:CARDINAL;

BEGIN

178 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

]uly

ReadCard(Ien); cl :■ nulICelIList;

IF len <> 0 THEN FOR I :« 1 TO len DO ReadCardfrow};

ReadCard(coI);

addToCelIList(cI, row, col);

END;

END;

END readCelI List;

(* * For debugging only.

PROCEDURE wrIteChunk(ccp:ceIIChunkPtr); BEGIN

WriteOP);

MyTerminal.WriteCard(ccp^.startRow, 0); Wr I te(•,•);

MyTerminal.WriteCard(ccp^.startCoI, 0); Wr 1 te(']*);

END writeChunk;

*)

BEGIN END Cell.

commandp.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE CommandProc;

FROM Formula IMPORT formula;

EXPORT QUALIFIED command, CommandType, readCommand;

TYPE CommandType - (CellRef, SetValue, SetFormula, Left, Right, Up, Down, NewCorner, Precision, ColWidth, Automatic, Manual, Recalc, Copy, Clear, Quit);

command ■

RECORD

CASE type:CommandType OF

CellRef, NewCorner, Copy: row, coI:CARDINAL;

SetValue: value:REAL;

SetFormula: form: formula;

Precision: prec1sion:CARDINAL;

ColWidth: coIWldthCARDINAL;

END;

END;

PROCEDURE readCommand(VAR cicommand; crRow, crCoI:CARDINAL);

END CommandProc.

ceI 11st.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

FROM Spreadsheet IMPORT Status;

FROM StrlngOps IMPORT Delete;

TYPE

cel(List - POINTER TO cel INode; cel INode - RECORD

row, coI:CARDINAL; next:celILIst;

END;

VAR strIngrstrIng160; cRow, cCoI:CARDINAL;

PROCEDURE empty(cI:ceI IL1st);BOOLEAN;

BEGIN

RETURN cl - NIL;

END empty;

PROCEDURE nextCelI(cl:celILIst);ceIILIst;

BEGIN

RETURN cr.next;

END nextCelI;

PROCEDURE celIRow(cl:celILIst):CARDINAL;

BEGIN

RETURN cl A .row;

END ceI I Row;

PROCEDURE cel I Co I(cl;cel ILIst):CARDINAL;

BEGIN

RETURN cl*.col;

END celICoI;

PROCEDURE In11FIndDep(curRow, curCo I;CARDINAL; f:formula); BEGIN

FormuI a.toStrIng(f, string); cRow :* curRow; cCoI ;* curCoI;

END InItFIndDep;

PROCEDURE nextDep(VAR row, co I : CARD I NAL) -.BOOLEAN;

(* assumes syntactically correct formula *)

VAR IbPos, commaPos, rbPos:CARDINAL; vCol, vRowiREAL; srStatus;

BEGIN

IF (NOT flndChar(string, ’[*. IbPos)) OR (NOT fIndChar(strIng, commaPos)) OR

(NOT findChar(string, ']', rbPos)) THEN RETURN FALSE;

ELSE

INC(IbPos);

refexpr(strIng, IbPos, vRow, s, cRow);

IF s <> OK THEN

WrIteLnStrIngC'nextDep; s <> OK");

END;

INC(commaPos);

refexpr(strIng, commaPos, vCol, s, cCol);

IF s <> OK THEN

WrIteLnString("nextDep: s <> OK");

END;

row TRUNC(vRow);

col TRUNC(vCol);

Delete(string, 0, rbPos+1);

RETURN TRUE;

END;

END nextDep;

PROCEDURE addToCelI List(VAR cl:ceIILIst; row, coI:CARDINAL); VAR newcI:ceI IL1st;

BEGIN

IF NOT member(row, col, cl) THEN NEW(newcl); newcl^.row :• row; newc I *\co I :« co I ; newcl^.next :» cl;

180 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

cl newcI;

END;

END addToCeIILIst;

PROCEDURE member(row, coI:CARDINAL; cl:celIList):BOOLEAN;

BEGIN

WHILE cl <> NIL DO

IF (row * cl*.row) AND (col » cl*.col) THEN RETURN TRUE;

ELSE

cl :* cl*.next;

END;

END;

RETURN FALSE;

END member;

PROCEDURE removeFromCeIIList(VAR cl:celILIst; row, coI:CARDINAL); (* Writes error If not found. *)

VAR temp, prev:ceI ILIst;

BEGIN

temp :* cl; prev :* NIL;

WHILE temp <> NIL DO

IF (temp^.row « row) AND (temp*.col « col) THEN IF temp - cl THEN cl :■ cl*.next;

ELSE

prev*.next :■ temp^.next;

END;

DISPOSE(temp);

RETURN;

ELSE

prev :* temp; temp temp*.next;

END;

END;

Wr IteStr Ing("removeFromCel ILIst: ");

WrIteCardfrow, 3);

WrlteCard(coI, 3);

Wr I teLnStrIng(" not found");

END removeFromCeIILIst;

PROCEDURE freeCeI ILIst(VAR cl:ceIILIst);

VAR temp:celILIst;

BEGIN

WHILE cl <> NIL DO temp :* cI; cl :■ cI*.next;

DISPOSE(temp);

END;

END freeCelILIst;

BEGIN

nulICelILIst :■ NIL;

END CelILIst.

cell.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE Cell;

FROM CelILIst IMPORT celILIst;

FROM Formula IMPORT formula;

FROM Spreadsheet IMPORT Status;

EXPORT QUALIFIED cell, getCell, setCell, doForAIICelIs, InltSheet, clearSheet, cellProc;

TYPE

cel I - RECORD

{continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 181

value: REAL; form: formula; status: Status; dependentCelIs: celILIst;

END;

cellProc - PROCEDURE(CARDINAL, CARDINAL, VAR cell);

PROCEDURE InitSheet;

PROCEDURE clearSheet;

PROCEDURE getCeI I(row, coI:CARDINAL; VAR c:cell); PROCEDURE setCeI I(row, coI:CARDINAL; c:cell); PROCEDURE doForAIICells(cp:celIProc);

END Cell.

ceI 11.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE Cell;

FROM CelILIst IMPORT ceI ILIst, nuIICeI ILIst, freeCeIILIst; FROM Storage IMPORT ALLOCATE, DEALLOCATE;

FROM Formula IMPORT formula, emptyFormuI a;

IMPORT Formula;

FROM Mlsc IMPORT fatal, assert;

FROM Spreadsheet IMPORT Status;

CONST nRows - 10; nCols ■ 10;

TYPE

cellArray - ARRAY[0..nRows-1],[0..nCoIs-1] OF cell; ceIIChunkPtr - POINTER TO cellChunk; cel IChunk - RECORD

startRow, startCol:CARDINAL;

cells:cellArray;

down, right: ceIIChunkPtr;

END;

VAR sheet:celIChunkPtr;

PROCEDURE InitSheet;

BEGIN

sheet :« newCeIIChunk(1, 1, NIL, NIL);

END InitSheet;

PROCEDURE clearSheet;

VAR rowCcp, coICcp, temp:ceIIChunkPtr;

BEGIN

rowCcp :« sheet;

WHILE rowCcp <> NIL DO coICcp :* rowCcp^.right;

WHILE coICcp <> NIL DO temp :« coICcp; coICcp :■ coICcp^.right; freeCelIChunk(temp);

END;

temp :« rowCcp; rowCcp :* rowCcp^.down; freeCelIChunk(temp);

END;

initSheet;

END clearSheet;

PROCEDURE getCeI I(row, coI:CARDINAL; VAR c:cell);

VAR ccp:ceIIChunkPtr;

182 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

BEGIN

IF findCelIChunk(row, col, ccp) THEN WITH ccp" DO

c cel 18[row-8tartRow, co1-startCoI];

END;

ELSE

cIearCeI I(c);

END;

END getCelI;

PROCEDURE setCeI I(row, coIiCARDINAL; creel I);

VAR ccprcelIChunkPtr;

BEGIN

IF NOT fIndCeIIChunk(row, col, ccp) THEN ccp :■ addCeIIChunk(row, col, ccp);

END;

WITH ccp" DO

ceI Is[row-startRow, co1-startCoI] :* c;

END;

END setCeI I;

PROCEDURE addCelIChunk(row, col:CARDINAL; ccprcelIChunkPtr)rceIIChunkPtr;

VAR newCcprcelIChunkPtr;

BEGIN

newCcp :« newCelIChunk(start(row, nRows), start(col, nCols), NIL, NIL); WITH ccp" DO

IF (row >- startRow) AND (row < startRow+nRows) THEN

(* the new cell chunk belongs to the right of this one *) newCcp".right :• right; right r* newCcp;

ELSIF row >■ startRow+nRows THEN

(* the new cell chunk belongs below this one *)

IF col < down".startCol THEN

(* the new cell chunk belongs to the left of the one below *) assert((row >■ down".startRow) AND (row < down".startRow+nRows), "addCelIChunk: wrong chunk returned"); newCcp".right r* down; newCcp".down :■ down".down; down r* newCcp;

ELSE (* it just belongs directly below *) newCcp".down down; down :• newCcp;

END;

ELSE

fatal('addCelIChunkr wrong cell chunk returned');

END;

END;

RETURN newCcp;

END addCelIChunk;

PROCEDURE star t (rowOrCo I , n -.CARDINAL) r CARD INAL;

(* computes start row or start col. *)

BEGIN

RETURN ((rowOrCo1-1) DIV n)*n + 1;

END start;

PROCEDURE findCelIChunk(row, coIiCARDINAL; VAR ccp:ceIIChunkPtr);BOOLEAN;

(* Returns TRUE if It finds the cell chunk containing the cell [row,col].

If it returns FALSE, then ccp will point to the cell chunk just "before" where the right cell chunk should be. Before can mean just above, or just to the left, depending upon where the new cell chunk should be put. *)

BEGIN

ccp :■ sheet;

WHILE row >- ccp".startRow+nRows DO WITH ccp" DO

IF (down ■ NIL) (* need to add a new chunk below this one *)

OR (row < down".startRow) (* need new chunk between this and next *; OR ((row < down".startRow+nRows) AND

(col < down".startCol)) THEN (* need new chunk below k left *) RETURN FALSE;

ELSE

ccp down;

END;

END;

I continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 183

Chapter Notes

IMPLEMENTATION MODULE CelIList;

(* Implements cell lists, and finding dependencies in formulas.

*)

FROM StrlngStuff IMPORT string160, flndChar;

FROM Formula IMPORT formula;

IMPORT Formula;

FROM Storage IMPORT ALLOCATE, DEALLOCATE;

FROM MyTerminal IMPORT WrlteString, WriteCard, WriteLnStrIng;

FROM Evaluator IMPORT refexpr;

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 179

J uly

END;

(* We are now on the right row *)

WHILE col >- ccp*.startCol+nCols DO

IF (ccp*.right - NIL) OR (col < ccp*.right*.startCoI) THEN RETURN FALSE;

ELSE

cep ;■ ccp*.right;

END;

END;

RETURN TRUE;

END findCelI Chunk;

PROCEDURE doForAIICells(cp:celIProc);

VAR rowCcp, coICcprcelIChunkPtr;

BEGIN

rowCcp :■ sheet;

REPEAT

coICcp:- rowCcp;

REPEAT

doForCeIIChunk(coICcp, cp); coICcp :« coICcp*.right;

UNTIL coICcp - NIL; rowCcp :« rowCcp*.down;

UNTIL rowCcp - NIL;

END doForAIICelIs;

PROCEDURE doForCelIChunk(ccp:ceIIChunkPtr; cpicelIProc);

VAR row, coI:CARDINAL;

BEGIN

WITH cep* DO

FOR row :« startRow TO startRow+nRows-1 DO FOR col :■ startCol TO startCol+nCols-1 DO

cp(row, col, eel Isfrow-startRow, co1-startCoI]);

END;

END;

END;

END doForCelIChunk;

PROCEDURE newCelIChunk(startR, startCrCARDINAL; d,r;ceIIChunkPtr):ceIIChunkPtr VAR ccprcelIChunkPtr;

BEGIN

NEW(ccp);

WITH cep* DO

startRow startR; startCol :» startC; down :« d; right :« r; clearCelIChunk(ccp);

END;

RETURN cep;

END newCeIIChunk;

PROCEDURE freeCeIIChunk(VAR ccp:celIChunkPtr);

VAR row, col:CARDINAL;

BEGIN

FOR row 0 TO nRows-1 DO FOR col :« 0 TO nCols-1 DO WITH cep*.eells[row, col] DO freeCelIList(dependentCeI Is);

Formula.free(form);

END;

END;

END;

DISPOSE(ccp); ccp :« NIL;

END freeCelIChunk;

PROCEDURE cIearCeIIChunk(VAR ccp:ceIIChunkPtr);

VAR row, coI:CARDINAL;

BEGIN

FOR row :■ 0 TO nRows-1 DO FOR col :» 0 TO nCols-1 DO

clearCelI(ccp*.cells[row, col]);

END;

184 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

END;

END cIearCeIIChunk;

PROCEDURE clearCeI I(VAR c:cell); BEGIN

WITH c DO

status :■ Empty; form :* emptyFormuI a; dependentCeIIs :■ nuI ICeI ILIst; END;

END cIearCeI I;

BEGIN END Cell.

misc.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE Mi sc;

FROM MyTermlnal IMPORT pause, WriteLnString;

PROCEDURE fatal(msg:ARRAY OF CHAR);

BEGIN

Wr iteLnString(msg); pause('Hit any key to die—’);

HALT;

END fatal;

PROCEDURE assert(testrBOOLEAN; msg:ARRAY OF CHAR); BEGIN

IF NOT test THEN fatal(msg);

END;

END assert;

PROCEDURE max(a, b:CARDINAL):CARDINAL;

BEGIN

IF a > b THEN RETURN a;

ELSE

RETURN b;

END;

END max;

PROCEDURE min(a, b:CARDINAL):CARDINAL;

BEGIN

IF a < b THEN RETURN a;

ELSE

RETURN b;

END;

END min;

BEGIN END Misc.

mi sc.def

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

DEFINITION MODULE Misc;

EXPORT QUALIFIED fatal, assert, max, min;

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 185

PROCEDURE fatal(msg:ARRAY OF CHAR);

(* Prints the message, does a pause, and HALTs. *)

PROCEDURE assert(test:BOOLEAN; msg:ARRAY OF CHAR);

(* If test Is FALSE, fatal Is called with msg. Else, nothing. *)

PROCEDURE max(a, b:CARDINAL):CARDINAL;

PROCEDURE min(a, b:CARDINAL):CARDINAL;

END Mlsc.

strIngst.mod

Programming Project: "Build a Spreadsheet Program," by Jonathan Amsterdam. July, page 96.

IMPLEMENTATION MODULE StrlngStuff;

PROCEDURE charCap(ch:CHAR):CHAR;

BEGIN

IF (ch >- 'a*) AND (ch <« ‘z') THEN RETURN CAP(ch);

ELSE

RETURN ch;

END;

END charCap;

PROCEDURE strlngCap(VAR s:ARRAY OF CHAR);

VAR I:CARDINAL;

BEGIN

FOR l 0 TO stringLen(s) DO s[ l ] :« charCap(s[I]);

END;

END strlngCap;

PROCEDURE strlngLen(VAR s:ARRAY OF CHAR):CARDINAL;

VAR i:CARDINAL;

BEGIN

FOR I :« 0 TO HIGH(s) DO IF s[I] - 0C THEN RETURN I;

END;

END;

RETURN HIGH(s)+1;

END strIngLen;

PROCEDURE strIngAssign(VAR destrARRAY OF CHAR; sourcerARRAY OF CHAR); VAR I:CARDINAL; '

BEGIN

i := 0;

LOOP

IF I > HIGH(dest) THEN EXIT;

ELSIF I > HIGH(source) THEN dest[I] := 0C;

EXIT;

ELSE

dest[I] := sourcefi];

END;

INC(I);

END;

END strIngAssIgn;

PROCEDURE strlngCopy(VAR dest, sourcerARRAY OF CHAR; from, to:CARDINAL); VAR I, num:CARDINAL;

BEGIN

IF from <« to THEN num :* to-from+1;

FOR I :■ 0 TO num-1 DO

IF I > HIGH(dest) THEN

186 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

July

RETURN;

ELSIF i+from > HIGH(source) THEN dest[i] :« 0C;

RETURN;

ELSE

dest[l] :« source[i+from];

END;

END;

IF num <= HIGH(dest) THEN dest[num] :* 0C;

END;

ELSE

dest[0] 0C;

END;

END stringCopy;

PROCEDURE stringEqual(si, s2:ARRAY OF CHAR):BOOLEAN;

VAR I:CARDINAL;

BEGIN

FOR i 0 TO HIGH(sl) DO IF i > HIGH(s2) THEN RETURN si[I] - 0C;

ELSIF sl[l] <> s2[I] THEN RETURN FALSE;

ELSIF s 1 [ 1] - 0C THEN RETURN TRUE;

END;

END;

RETURN TRUE;

END stringEqual;

PROCEDURE deIeteChar(VAR s:ARRAY OF CHAR; pos:CARDINAL);

VAR i-.CARDINAL;

BEGIN

FOR I :« pos TO HIGH(s)-1 DO s[i] s[i+1];

END;

END deleteChar;

PROCEDURE InsertChar(ch:CHAR; VAR s:ARRAY OF CHAR; pos:CARDINAL);

VAR i:CARDINAL;

BEGIN

FOR I stringLen(s)-1 TO pos BY -1 DO s[1+1] :■ s[i];

END;

s[pos] :* ch;

END InsertChar;

PROCEDURE findChar(s:ARRAY OF CHAR; ch:CHAR; VAR pos;CARDINAL):BOOLEAN; VAR 1, Ien;CARDINAL;

BEGIN

len :■ stringLen(s);

IF len * 0 THEN RETURN FALSE;

ELSE

FOR I :« 0 TO len-1 DO IF s[i] - ch THEN pos :« I; RETURN TRUE;

END;

END;

RETURN FALSE;

END;

END findChar;

BEGIN

END StrlngStuff.

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 187

vi $c.bos

"Small-Scale Engineering Applications," by J. Nell Stone. July, page 253.

10 REM ESTIMATE VISCOSITY - May 85 - VISC/BAS 20 REM Final, Sept 2nd, 1985 30 REM Edited for BYTE Dec 85 40 GOTO 160

70 DATA" 80 DATA" 90 DATA" 100 DATA"

50 DATA"****** VISCOSITIES ******"

60 DATA"* OF LIQUIDS AND MIXTURES *"

by"

J.NeiI Stone"

Ledge Engineering Inc"

179 Lansdowne Avenue"

110 DATA" Kingsville, Ontario, N9Y 3J2"

120 DATA" "

130 DATA" **** May 1985 ***♦"

140 CLS:FOR J-1 TO 9:READ Y:PRINT@ FN LC(NR/2-5+J,NS/2-17),Y:NEXT

150 RETURN

160 CLEAR 1500

170 DEFINTJ-L,N:DEFSTRX-Z

180 DIM

Y,J,K,NS,KP,Y%,LC,KQ,AT,KC,N,UT,A,J9,ET,TR,TL,J8,J$,KS,RD,NL,NC,F2,NR,V,NM ’simple vars

190 POKE 16409,1 ’Set caps mode

200 NS=64:NR«16:LF»1 'screen parameters for TRS80

210 ’NS*80:NR«24:LF-128 ’screen parameters for 80x24 (IBM)

220 DEF FN LC(J,K)«(J-1)*NS+K-1 230 GOSUB 50 ’display title

240 DIM A(2,92),AX(10),AY(10),YT(8),Y(8),AV(10),AM(10),YN(10),YM(3),MC(10) ’arrays

250 REM Set up message strings

260 Y(1)«"MoI ecu I or weight":Y(2)«"Cr11lea I temp, K":Y(3)-"Crtt!cal press, atm“:Y(4)-"Crltlcal vol, cc/moP:Y(5)*»"Acentrlc factor":Y(8)="MeItIng point, deg C":Y(6)-"Denslty. g/cc (SG)":Y(7)-"Temp. of density measure, deg C"

270 YM(1)»"Przezdziecki 4 Sridhar":YM(2)-"StieI 4 Thodos":YM(3)«"AIChE Data Prediction Manual"

280 Z-:Z1«CHR$(91)+CHR$(10)+CHR$(13)+"Xx"+CHR$(9):Z3-" ":Z4-"<~

":Z6-".-0123456789":Z2-Z6+Z1:Z5-Z6+"ED+"+CHR$(13)+CHR$(8)

290 Z8-“USE UP. DOWN, RT ARROWS TO SELECT ENTRY. <X> TO EXIT.“:Z9-"USE "+Z4+" TO CORRECT. PRESS <ENTER> WHEN DONE":ZC-STRING$(17.“ ")

300 Y1-"###.##":Y2-"#ii(#":Y3."##.####":Y4="####.####•• ;Y5="##.####-

310 REM Set up constants

320 C1-273.16:C2-2/7:C3-1E-10

330 ON ERROR GOTO 7190

340 GOTO 1000 * to main prog

390 REM All-purpose screen for 1,2 or 3 col numeric entry

400 REM Screen layout

410 CLS:PRINT TA8((NS-LEN(ZA))/2) ZA

420 PRINT STRING$(NS-1,"=")

430 FOR J=1 TO NT:J$=RIGHT$(STR$(J),1)

440 PRINT YT(J);

450 IF INSTR(ZD,J$) THEN PRINT:GOTO 490 ELSE IF INSTR(ZG,J$) THEN 480 460 IF J8>2 THEN PRINT TAB(NS-46);A(0,KS+J-1);

470 IF J8>1 THEN PRINT TAB(NS-30);A(1.KS+J-1);

480 PRINT TAB(NS-14);A(2,KS+J-1)

490 NEXT

500 REM Display data os SP to prevent overflows 510 PRINT® FN LC(14,1),STRING$(NS-1,95)

520 PRINT® FN LC(15,1),CHR$(30);ZB;

530 REM Begin display

540 KQ«NS-17:KP=KL+1:J9*6:GOTO 600

550 PRINT® FN LC(KP+1,KQ+1),Z;

560 PRINT® FN LC(16,1),CHR$(30);Z8;

570 Y$=*INKEY$: IF Y$-"“ THEN 570 580 IF INSTR(Z2,Y$)=0 THEN 570 590 J9-INSTR(Z1,Y$)

600 IF J9=0 THEN 760 ELSE PRINT® FN LC(KP+1,KQ+1),Z3;

610 ON J9 GOTO 640,620,620,630,630,670 620 J9=1:GOTO 650 630 RETURN 640 J9—1

650 KP-KP+J9:IF KP>KM+1 THEN KP=KL+1 ELSE IF KP<KL+1 THEN KP-KM+1

188 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

I uly

660 GOTO 710

670 ON J8 GOTO 710,700

680 IF KQ-NS-49 OR KQ-NS-33 THEN KQ-KQ+16 ELSE KQ-NS-49 690 GOTO 710

700 IF KQ-NS-33 THEN KQ-NS-17 ELSE KQ-NS-33 710 ZF-STR$(KP-1):ZF-RIGHT$(ZF,LEN(ZF)-1“

720 IF INSTR(ZO.ZF) THEN IF J9-6 THEN J9=1:GOTO 650 ELSE 650 730 IF INSTR(ZG.ZF) THEN KQ-NS-17 740 GOTO 550

750 REM Data entry section

760 PRINT®FN LC( 16,1),CHR$(30);Z9;

780 PRINT®™ LC(KP+1,KQ+1),ZC;:PRINT@ FN LC(KP+1.KQ+5),ZE;CHR$(95);

790 Y$-INKEV$:IF Y$-"" THEN 790 800 YX-INSTR(Z5,Y$) : IF Y%-0 THEN 790 810 IF YX>15 THEN ON Y%-15 GOTO 880,860 820 KC-KC+1

830 ZE=ZE+Y$ ^ ^

840 PRINT® FN LC(KP+1.KQ+KC+4),Y$;CHR$(95);

850 GOTO 790

860 KC-KC-1:IF KC<«0 THEN KC»0:ZE=“" ELSE ZE=LEFT$(ZE,KC)

870 GOTO 780

880 KE-(KQ-NS+49)/16

890 A(KE,KP+KS-2)-VAL(ZE) , „ .

900 PRINT® FN LC(KP+1,KQ+1),ZC;:PRINT@ FN LC(KP+1.KQ+4),CSNG(VAL(ZE));

910 ZE«"":J9-1

920 IF KQ-NS-17 THEN KP-KP+1 930 IF KP>KM+1 THEN KP-KL+1 940 GOTO 670 990 REM Main program

1000 GOSUB 8000 ’introductory text

1010 GOSUB 6620 ’title etc

1020 GOSUB 6080 ’main menu

1030 ON NM GOSUB 1250,1250,1500 ’goto correct routine

1040 IF NC<>6 THEN 1060

1050 ON ERROR GOTO 0:END ’end of program

1060 FOR K-0 TO 2:FOR J-1 TO 8:A(K,J)«0:NEXTJ,K:LP«0 1070 IF NC-5 THEN JP-0:LT-0 1080 ON NC-3 GOTO 1020,1010

1240 REM Viscosity prediction by both methods

1250 IF NE THEN 1290 ’go to input if returned by error

1260 GOSUB 8270 ’intro text

1270 GOSUB 2000 ’name of substance

1280 GOSUB 8550 'load data from file. If any

1290 GOSUB 2030 ’enter phys props

1300 GOSUB 2150 ’calc for substance

1310 GOSUB 6170 ’calculation options

1320 IF TN-0 THEN G0SU8 2360:GOSUB 4500 ELSE G0SU8 2500

'calc for temp of interest

1330 GOSUB 6400 ’what next

1340 ON NC GOTO 1360,1310,1370

1350 RETURN

1360 CLS:GOSUB 5000:GOTO 1330

1370 FOR K-0 TO 2:F0R J-1 TO 8:A(K,J)-0:NEXTJ,K:LP-0:GOTO 1270 1490 REM Mixture routine

1500 IF NE THEN 1540 ’to entry If return on error 1510 GOSUB 8470 'intro blurb

1520 GOSUB 3000 ’get names of materials

1530 IF NL-2 THEN GOSUB 3120 ’range of calcs?

1540 GOSUB 3250 ’data in

1550 GOSUB 3490 ’estimate missing viscosities

1560 GOSUB 3750 'viscosity of mixture/print

1570 GOSUB 6510 ’what next?

1580 ON NC GOTO 1610,1530,1650 1590 RETURN

1600 REM Hardcopy results „ M1B

1610 IF AL THEN CLS:PRINT"Too latel Cannot print results for range now.":GOSUB 7070:GOTO 1570

1620 CLS:GOSUB 5410 ’hardcopy results

1630 GOTO 1570

1640 REM Clean out data

1650 AL-0:FOR J-1 TO NL:FOR K-0 TO 2:A(K,J)-0:NEXT K,J:GOTO 1520 1990 REM Input material data 2000 CLS:KS-1

2010 INPUT"Nome of Substance";YB

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 189

2020 RETURN

2030 CLS:NE-0 'reset error flog

2040 KS-1 :KL-1 :KM-8:ZA-"PROPERTIES OF "+YB

2050 ZB-" *: ZD-" ": ZG-" ": J8-1

2060 IF NM-2 THEN KM-7 'no f. pt needed for St 4 Th

2070 FOR J-1 TO KM:YT(J)-Y(J):NEXT 'Instol titles

2080 NT-9-NM 'no of titles

2090 GOSUB 410 'to doto Input

2100 GOSUB 2600 'check Input doto volld

2110 IF NE THEN NE«0:GOTO 2090 ELSE GOSUB 8850

2120

MW-A(2,1):TC-A(2,2):PC-A(2,3):VC-A(2,4) ,7)+C1 'get doto In equation variables 2130 RETURN

:W-A(2,5):TF-A(2,8)+C1:SG-A(2,6):TD-A(2

2140 REM Calculate basic parameters 2150 CLS

2160 TR-TD/TC:FZ-.29056-.08775+W 'Yamada 4 Gunn, 1973

2170 GOSUB 2290

2180 VS-MW/SG/F2 'calc scaling factor

2190 IF NM-2 THEN GOTO 2320 'Stiel and Thodos

2200 REM Pr and Sr method

2210 TR-TF/TC

2220 GOSUB 2290

2230 VM-F2+VS

2240 VZ-.0085*TC*W-2.02+VM/(•342+TR+.894)

2250 F1-4.27+.032*MW-.077+PC+.014*TF-3.82*TR

2260 B-.33+VC/F1 - 1.12

2270 RETURN

2280 REM Calc f2(t)

2290 F2«FZ~((1-TR)~C2) 'Yamada 4 Gunn 1973 2300 RETURN

2310 REM Stiel and Thodos parameter 2320 ES-TC*(1/6)

2330 ES-ES/SQR(MW)/(PC-(2/3))

2340 RETURN

2350 REM Calc for specific temp 2360 TR-(Tl+C1)/TC 2370 GOSUB 2290:V-F2*VS

2380 IF NM-2 THEN GOTO 2420 'to Stiel and Thodos 2390 ET-B*(V/VZ-1):ET-1/ET 2400 GOTO 2480

2410 REM Stiel and Thodos calc

2420 IF TR<1.5 THEN U8-34E-05*(TR~.94) ELSE UB=17.78E-05*((4.58*TR1.67)*(5/8)) 'calc low press vise 2430 RD-VC/V

2440 UT-(((.0093324+RD-.040758)*RD+.058533)*RD+.023364)*RD+.1023

2450 UT-UT*UT*UT*UT

2460 UT-UT-1E-04+UB

2470 ET-UT/ES

2480 RETURN

2490 REM Calc for range of temps 2500 CLS

2510 FOR TL-TS TO TE STEP TN 2520 GOSUB 2360 2530 GOSUB 5170 2540 GOSUB 4650 2550 NEXT

2560 TL-TL-TN 'restore last temp calc’d

2570 IF N THEN GOSUB 7070 2580 RETURN

2590 REM Check validity of Input data 2600 FOR J-KS TO KS+5 2610 IF A(2,J)>0 THEN 2630

2620 CLS:PRINT Y(J-KS+1);" cannot be zero or negative.“:NE=1 2630 NEXT

2640 IF NE THEN PRINT:PRINT"Program will return to data entry. Please correct Input.":GOSUB 7070 3

2650 RETURN

2990 REM Initial Input for mixtures 3000 CLS:JP-0

3010 NL-0 * intialise - NL no of comps

3020 NL-NL+1:YN(NL)-"":MC(NL)-0:PRINT "Nome of component no:";NL "- just <ENTER> If no more componentsINPUT YN(NL)

3030 IF YN(NL)<>“" THEN IF NL<10 GOTO 3020

3040 NL-NL-1:IF NL<2 THEN PRINT "Must have at least two components.":GOTO 3020

190 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

J uly

3060 PRINT "Are your compositions in wt% or mol% - type <W> or <M>"

3070 YR="WwMm":G0SUB 7040

3080 MX=(KA>2) ’mx true if mol%

3090 IF MX THEN YU-"molX" ELSE YU-"wtX"

3100 RETURN

3110 REM Calculate for range

3120 CLS:AL-0:MP*0:PRINT "Do you want to automatically calculate viscosities for a rangeof compositions Y/N?"

3130 GOSUB 7030 3140 IF KA>2 THEN 3230

3150 PRINT "Minimum value of ";YU" for ";YN(1);:INPUT AL

3160 IF (AL<0) OR (AL>100) THEN PRINT YU;"must be in range 0-100":GOTO 3150 3170 PRINT "Maximum value of ";YU" for ";YN(1);:INPUT AH

3180 IF (AH<0) OR (AH>100) OR (AH<AL) THEN PRINT YU;"must be in range 0-100

and max must be bigger than min.":GOTO 3170

3190 PRINT "Increments of “;YU" for ";YN(1);:INPUT AD

3200 PRINT:PRINT "Do you want hardcopy of the results as they are done, Y/N?" 3210 GOSUB 7030

3220 MP=(KA<3) ‘true if hardcopy needed 3230 RETURN

3240 REM Initial data entry for mixtures

3250 FOR J=1 TO NL:IF LEN(YN(J))>NS-51 THEN YT(J+1)-LEFT$(YN(J).NS-51) ELSE YT(J+1)=YN(J)

3260 NEXT

3270 YT(1)-STRING$(NS-46," ")+"Visc - cp"+STRING$(7," ")+"Mol.Wt"+STRING$(10," ")+YU

3280 ZA-"MIXTURE VISCOSITY INPUT DATA"

3290 ZB-"LEAVE ANY UNKNOWN DATA AS 0 - MW NOT NEEDED IF USING MOL%"

3300 ZD-"1.":ZG-"":J8-3:NT«NL+1:KL-2:KM-NL+1:KS«0 3310 IF AL THEN A(2,1)-AL:A(2,2)-100-AL 3320 GOSUB 410 'screen routine

3330 GOSUB 3390 'check data

3340 IF NE THEN NE-0:GOTO 3320 'return if data check not OK

3350 FOR J-1 TO NL:AV(J)«A(0,J):AM(J)=A(1,J):AX(J)-A(2,J):NEXT 'put data into

working vars; ov-vlsc,om«mw,ax=frn

3360 TL—1000 'flag to show temp not set

3370 RETURN

3380 REM Check screen input for mixtures 3390 CLS:NE-0:A=0

3400 FOR J-1 TO NL

3410 IF NOT MX THEN IF A(1,J)<=0 THEN PRINT"MoI ecu I or wt for ";YN(J); M

required":NE»1

3420 IF NL<>2 OR AL-0 THEN

IF A(2,J)<0 OR A(2,J)>100 THEN PRINT YU;"

of

";YN(J); M out of range":NE-1 3430 A-A+A(2,J)

3440 NEXT

3450 IF A>100 OR A<100 THEN PRINT"Components do not odd to 100 ";YU:NE-1

3460 IF NE THEN GOSUB 7070 3470 RETURN

3480 REM Estimate viscosity of missing items

3490 CLS:NK-0 'nk is temperature flag

3500 FOR LM-1 TO NL 'Im is main counter

3510 IF AV(LM) THEN 3720 'skip if vise given

3520 MC(LM)=1:PRINT "Estimating viscosity of ";YN(LM)

3530 PRINT:PRINT "Is ";YN(LM):PRINT "a non-ossociating compound, Y/N?";

3540 GOSUB 7030

3550 IF KA<3 THEN NM-1 ELSE NM-2

3560 YB-YN(LM):KS-LM*8+4:A(2,KS)=AM(LM):GOSUB 8550 'check for dato on disk 3570 CLS:NE=0 'reset error flag 3580 KL-1:KM=8:ZA»"PROPERTIES OF "+YB 3590 ZB-"":ZD-"":ZG-"":J8-1

3600 IF NM-2 THEN KM-7 'no f. pt needed for St 4 Th

3610 FOR J-1 TO KM:YT(J)-Y(J):NEXT 'install titles

3620 NT-9-NM 'no of titles

3630 GOSUB 410 'to data Input

3640 GOSUB 2600 'check input data valid

3650 IF NE THEN NE-0:GOTO 3630 ELSE GOSUB 8850

MW»A(2,KS):TC-A(2,KS+1):PC-A(2,KS+2):VC»A(2,KS+3):W-A(2,KS+4):TF-A(2,KS+7)+C1: SG»A(2,KS+5):TD-A(2,KS+6)+C1 'get dato in equation variables 3670 GOSUB 2150 ’start calculation

3680 CLS:IF NK-0 THEN NK-1:INPUT "Temperature of estimote, deg C.";TL 3690 GOSUB 2360

3700 AV(LM)-ET:A(0,LM)-CSNG(ET) ’sove answer

3710 CLS:PRINT "Viscosity of ";YN(LM);" calculated":GOSUB 7010:NM-3

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 191

3720 NEXT 3730 RETURN

3740 REM Calculate vise of mixture 3750 IF AL THEN GOTO 3790

3760 IF NOT MX THEN GOSUB 3890 *conv to moles if nec

3770 GOSUB 3960 'calculate mixture vise

3780 GOTO 3860 'to return

3790 N-0:FOR A-AL TO AH STEP AO

3800 AX(1)-A:AX(2)-100-A

3810 IF NOT MX THEN GOSUB 3890

3820 GOSUB 3960

3830 IF MP THEN GOSUB 5570

3840 GOSUB 4730

3850 NEXT

3860 IF NL>2 OR AL-0 THEN GOSUB 4550 ELSE IF N THEN GOSUB 7070 'to screen if results requ’d 3870 RETURN

3880 REM Convert to mole frn

3890 AT=0:FOR J-1 TO NL

3900 AY(J)«AX(J)/AM(J):AT-AT+AY(J)

3910 NEXT

3920 FOR J-1 TO NL 3930 AX(J)«AY(J)*100/AT 3940 NEXT:RETURN 3950 REM Vise of mixture 3960 AT-0

3970 FOR J-1 TO NL

3980 AT-AT+AX(J)*LOG(AV(J))

3990 NEXT

4000 ET-EXP(AT/100) 'viscosity of mixture 4010 RETURN

4490 REM Print results 4500 CLS

4510 PRINT "Viscosity of ";YB;“ at“;:PRINT USING “ ###.# deg C is ###.### cp";TL,ET 4520 PRINT 4530 RETURN

4540 REM Screen print for mixture 4550 CLS

4560 PRINT "Viscosity of mixture of:"

4570 FOR J-1 TO NL

4580 PRINT TAB(5) USING Y1;A(2,J)::PRINT" ";YU;“ ";YN(J)

4590 NEXT V '

4600 PRINT: IF TLo-1000 THEN PRINT "at "; TL; " deg C":

4610 PRINT " is";:PRINT USING Y3;ET;:PRINT " cp"

4620 GOSUB 7070 4630 RETURN

4640 REM Screen print list of results 4650 IF TLoTS AND N<>0 THEN 4680 4660 N-0:PRINT "Viscosity of ";YB

4670 PRINT TAB(5) "Temperature, deg C";TAB(NS-25)"Viscosity, cp" 4680 PRINT TAB(12) USING Y2;TL;:PRINT TAB(NS-23) USING Y4;ET 4690 N-N+1

4700 IF N=NR-4 THEN GOSUB 7070:N=0:CLS 4710 RETURN

4720 REM Screen display list of mixture results 4730 IF AoAL AND N<>0 THEN 4760 'jump titles if not 4740 CLS:N=0:PRINT TAB(12);YU;" of";TAB(54)"Viscositv" 4750 PRINT YN(1);TAB(25) YN(2);TAB(58)"cp"

4760 PRINT USING Y1;A;

4770 PRINT TAB(25) USING Y1;100-A;

4780 PRINT TAB(56) USING Y3;ET 4790 N-N+1

first time

4800 IF N=NR-4 THEN GOSUB 7070:N-0 4810 RETURN

4990 REM Hardcopy results

5000 IF TN THEN CLSrPRINT "Too late! Cannot print results for ranae now.GOSUB 7070:GOTO 5150 9

5005 GOSUB 6000

5010 CLS:ON JP GOTO 5020,5090 5020 GOSUB 5290:GOSUB 5330 5030 LPRINT

5040 LPRINT TAB(5) "viscosity of 5050 LPRINT:LPRINT TAB(25) USING 5060 LPRINT:LPRINT 5070 GOTO 5150

“:YB;" estimated by method of ";YM(NM); Y4+" cp at "+Y2+" deg C";ET,TL

is:

192 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

5080 REM Table heading

5090 IF LT THEN 5140 ’LT is flog for table 5100 GOSUB 5290

TAB(5)"Substance";TAB(25)"Temperature";TAB(40)"Viscosity";TAB(52)"Method" 5120 LPRINT TAB(30)"deg C";TAB(44)"cp"

5130 LPRINT:LT«1 . .

5140 LPRINT TAB(5)YB;:LPRINT TAB(29) USING Y2;TL;tLPRINT TAB(40) USING Y4;ET;:LPRINT TAB(52) YM(NM)

5150 RETURN

5160 REM List results for temp range on printer

5170 IF LP-0 THEN 5270 5180 IF TLoTS THEN 5250 5190 GOSUB 5290:GOSUB 5330

5200 LPRINT TAB(5)"EstImated viscosities using method 5210 LPRINT , „

5220 LPRINT TAB(10)"Temperature";TAB(45)“Viscosity" 5230 LPRINT TAB(13)"deg C";TAB(49)"cp"

5240 LPRINT , v

5250 LPRINT TAB(14) USING Y2;TL;:LPRINT TAB(45) USING 5260 IF TL+TN>TE THEN LPRINT 5270 RETURN

5280 REM Print heading

5290 LPRINT TAB(5)"Project: “;YP;TAB(55)YD

of ";YM(NM)

Y4;ET

5300 LPRINT 5310 RETURN

5320 REM Input data print

5330 LPRINT TAB(5)"INPUT DATA for “;YB

5340 LPRINT

5350 FOR J-1 TO 9-NM

5360 LPRINT TAB(10) Y(J); -.LPRINT TAB(45) USING Y4;A(2,J)

5370 NEXT 5380 LPRINT 5390 RETURN

5400 REM Hardcopy for mixtures 5410 GOSUB 5290

5420 LPRINT TAB(40)"INPUT DATA":LPRINT

5430 LPRINT TAB(5)"Substance";TAB(35)"Visc - cp";TAB(48)"Mol. wt";TAB(63)YU

5440 FOR J-1 TO NL

5450 LPRINT TAB(5) YN(J);

5460 LPRINT TAB(35) USING Y3;AV(J);

5470 IF MC(J) THEN LPRINT"*";

5480 LPRINT TAB(48) USING Y1;AM(J);

5490 LPRINT TAB(61) USING Y1;A(2.J)

5500 NEXT

5510 LPRINT:LPRINT TAB(10) "* means estimated value, not input"

5520 LPRINT:LPRINT TA8(5) “Viscosity of mixture";

5530 IF TLo-1000 THEN LPRINT" at";TL;" deg C";

5540 LPRINT" ls";:LPRINT USING Y3;ET;:LPRINT" cp.":LPRINT 5550 RETURN

5560 REM Table of mixture viscosities

5570 IF AoAL THEN 5700 ’only print title first time

5580 GOSUB 5290

5590 LPRINT:LPRINT TAB(5) "Viscosities of mixtures of:"

5600 LPRINT:FOR J-1 TO 2 5610 LPRINT TAB(10);YN(J)

5620 NEXT 5630 LPRINT

5640 IF TLo-1000 THEN LPRINT TAB(5)" at";TL; B deg C ";

5650 LPRINT TAB(5) "are as follows:"

5660 LPRINT:LPRINT TAB(17);YU;" of ";

5670 LPRINT TAB(55)"Viscosity"

5680 LPRINT TAB(5);YN(1);TAB(30);YN(2);TAB(58)"cp"

5690 LPRINT

5700 LPRINT TAB(5) USING Y1;A;:LPRINT TAB(30) USING Y1;100-A;

5710 LPRINT TAB(55) USING Y3;ET 5720 IF A+AD>AH THEN LPRINT 5730 RETURN

5990 REM Hardcopy option menu 6000 CLS:IF JP-2 THEN 6060

6010 PRINT® FN LC(1,(NS-7)/2),"PRINT OPTIONS"

6020 PRINT:PRINT TAB(5)"l) Print Just the current result complete with input data* 1

6030 PRINT TAB(5)"2) Print table heodlngs and start table for all":PRINT TAB(8)"resuIts until new project is started."

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 193

6040 NC-2:G0SUB 7120

6050 JP«NC * JP ■* flag for choice

6060 RETURN

6070 REM Main menu 6080 CLS

6090 PRINT® FN LC(1 # ( NS-4J/2)."MAIN MENU"

non-associating liquid - most

6100 PRINT:PRINT TAB(5)"l) Viscosity of accurate"

6110 PRINT JAB(5)"2) Viscosity of associating liquid — not very accurate" Viscosity of liquid mixture"

7120

6120

6130

6140

6150

PRINT TAB(5 NC-3:GOSUB NM-NC RETURN

6160

6170

6180

6190

6200

6210

6220

6230

6240

6250

6260

6270

6280

6290

6300

6310

6320

6330

6340

6350

6360

6370

.6380

REM Calculation options CLS

PRINT® FN LC(1,fNS-10)/2),"CALCULATION OPTIONS"

PRINT:PRINT TAB(5)"1) Estimate viscosity for one specific temperature PRINT TAB(5)"2) Estimate viscosity for a range of temperatures"

PRINT

NC=2:GOSUB 7120 TN»0

ON NC GOTO 6370

CLS:INPUT"Start of temperature range, deg C";TS INPUT"End of temperature range, deg C";TE INPUT"Temperature interval in range, deg C";TN PRINT:PRINT "Everything correct, Y/N?

GOSUB 7030 IF KA>2 THEN 6250

CLS:PRINT "Do you want results tabulated on printer. Y/N? "

GOSUB 7030 LP-(KA<3)

IF LP THEN PRINT "Press <ENTER> when printer is ready" ELSE 6380 Y*INKEY$:IF Y«"" THEN 6350 GOTO 6380

CLS:INPUT"Temperature, deg C";TL RETURN

6390 REM Menu after calc

6400 PRINT TAB((NS-4)/2),"WHAT NEXT"

6410 PRINT

6420 PRINT TAB(5)"1) Hardcopy of result (one result only)."

6430 PRINT TABf5 V'2) Viscosity for same material at another temperature." 6440 PRINT TAB(5)"3) Viscosity for different substance of the same type!" 6450 PRINT TAB(5V'4) Main menu."

6460 PRINT TAB(5)"5) New project (all data lost) "

6470 PRINT TAB(5)"6) End program."

6480 NC=6:GOSUB 7120 6490 RETURN

6500 REM Menu after mix

6510 PRINT TAB((NS-4)/2),"WHAT NEXT"

6520 PRINT

6530 PRINT TAB(5V'1} Hardcopy of results"

6540 PRINT TABC5)"2) Another calculation for same materials." 6550 PRINT TAB(5)"3) Calculate for a different mixture."

6560 PRINT TAB(5)"4; Main menu."

6570 PRINT TAB(5)"5) New project (all data lost)."

6580 PRINT TAB(5)"6) End program."

6590 NC*6:GOSUB 7120 6600 RETURN

6610 REM Project intro routine

6620 CLS:INPUT"Enter project title";YP

6630 YD«LEFT$(TIME$,8):PRINT "Project date (default « ";YD;")"::INPUT YD 6640 RETURN * ' * '

6990 REM Subroutines 7000 REM Delay

7010 FOR J-1 TO 1000:NEXT:RETURN 7020 REM Check Inkey 7030 YR»"YyNn"

7040 Y-INKEY$:IF Y-"" THEN 7040

7050 KA-INSTR(YR.Y):IF KA THEN RETURN ELSE 7040

7060 REM Press key to cont

7070 PRINT® FN LC(NR,1),"PRESS ANY KEY TO CONTINUE";

7080 Y-INKEY$:IF Y-"" THEN 7080 7090 CLS 7100 RETURN

7110 REM Select from menu

7120 PRINT:PRINT"Choose by number"

194 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

7130 Y-INKEY$:IF Y- M " THEN 7130 7140 YX-VAL(Y)

7150 IF Y%<1 OR YX>NC THEN 7130 7160 PRINT Y:NC-Y%

7170 RETURN

7180 REM Error trap

7190 CLS

7200 IF ERR/2+1-5 THEN 7250 7210 IF ERR/2+1-11 THEN 7290 7220 IF ERR/2+1-54 THEN 7360 7230 IF ERR/2+1-6 THEN 7270

7240 PRINT "Error In Iine";ERL:ON ERROR GOTO 0:RESUME

7250 PRINT "Illegal function call error has occurred in Iine";ERL:GOSUB 7340 7260 PRINT "Look for negative or zero values of input data":GOTO 7310 7270 PRINT "Overflow error has occurred In Iine";ERL:GOSUB 7340 7280 PRINT "Look for very low or very high values of input data":GOTO 7310 7290 PRINT "Division by zero error has occurred in Iine";ERL:GOSUB 7340 7300 PRINT "Look for very low or zero values of input data"

7310 PRINT "Check that input data units are correct, and that all values orewithln the range of the correlation"

7320 GOSUB 7070:NE-1 *ne is error flag 7330 RESUME 1030

7340 PRINT "Program will return to data entry to allow you to checkvalidity of your Input data"

7350 RETURN

7360 PRINT "No such file"

7370 GOSUB 7070:CLOSE:JF-1:RESUME NEXT 7990 REM Introductory blurb 8000 CLS

8010 GOSUB 8220:IF NB THEN 8200

8020 CLS:PRINT “This program estimates viscosities of pure liquids and mixtures"

8030 PRINT:PRINT "The viscosities of pure, non-associating, liquids are estlmotedby the method of J.W.PrzezdzieckI and T.Sridhar publishedin the AIChEJ, Feb. 1985, p333. It is the most accurate methodand should be used if possible."

8040 PRINT:PRINT "Data required for the estimate are the molecular weight, thecrfttcal properties, the acentric factor, and at least onevalue of density at a known temperature."

8050 PRINTrPRINT "This method gives estimates with an average error of 9%, and amaximum error of 40X, but results are very unreliable if usedfor associating liquids."

8060 PRINT:GOSUB 7070 8070 CLS

8080 PRINT“For associating liquids there is really no reliable predictivemethod."

8090 PRINT:PRINT "The method used in this program is that of Stiel and Thodos,as described in ’The Properties of Gases and Liquids’ byReid and Sherwood, 2nd Ed., p437.“

8100 PRINT:PRINT "Data required for the estimate are the molecular weight, thecritlcal properties, the acentric factor, and at least onevalue of density at a known temperature."

8110 PRINT:PRINT "This method gives quite large errors (as much as

80%),usually on the low side, for some associating liquids, but noother method

is any more accurate."

8120 PRINT:GOSUB 7070 8130 CLS

8140 PRINT "Prediction of viscosities for liquid mixtures from purecomponent data is also rather unreliable."

8150 PRINT'.PRINT "The method used in this program is procedure 8H from the AIChE’Data Prediction Manual’. It is appropriate for systems wherethe mixtures have viscosities intermediate between those of thecomponents."

8160 PRINT:PRINT "Data required for the estimate are either the viscosities ofthe components, or the data listed previously to allow them tobe estimated.";

8170 PRINT "Liquid compositions may be entered in moIX or wtX.but in the latter case the molecular weight is also required."

8180 PRINT:PRINT "This method Is not suitable for systems that have maxima ormlnima in the mixture properties."

8190 GOSUB 7070 8200 RETURN

8210 REM Routine to bypass blurbs

8220 PRINT "This program Includes explanatory text and InstructIons.If you are familiar with the program, you can bypass these.Do you want Instructions displayed for this run, Y/N?"

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 195

8230 GOSUB 7030

8240 NB»(KA>2) *nb is flag Indicating No Blurbs 8250 RETURN

8260 REM Blurb for Pic S method 8270 CLS:IF NB THEN 8450 8280 IF NM-2 THEN GOTO 8370

8290 PRINT "This calculation method gives quite accurate results for most" 8300 PRINT "non-associating compounds. Any errors tend to be on the low" 8310 PRINT "side, and the errors are more pronounced at lower temperatures." 8320 PRINT "reaching a maximum close to the freezing point."

8330 PRINT:PRINT "The only common organics that cannot be handled are a I coho Is,"

8340 PRINT "both aliphatic and aromatic. Cyclic and branched compounds ":PRINT"tend to give quite large errors, usually on the low side."

8350 PRINT "Organic acids seem to be predictable."

8360 GOTO 8440 8370 CLS

8380 PRINT "This calculation method gives reasonable results for many"

8390 PRINT "compounds. It works best at temperatures from"

8400 PRINT "the boiling point up, and the errors are more pronounced":PRINT "at lower temperatures."

8410 PRINT "Only use this method for associating compounds."

PRINTiPRINT "For all other substances, the Przezdziecki and Sridhar" PRINT "method is better."

8420

8430

8440

8450

8460

8470

8480

GOSUB 7070 RETURN

REM Blurb for mixtures IF NB THEN 8530 CLS

8490 PRINT "This section calculates viscosities of the pure components,

the viscosity of liquid for up to 10component8.' viscosities are not

mixturesfrom the

known, they wiI I

8500 PRINT:PRINT "If the pure component

beestimated by one of the methods available. Leaving thevlscosity value as zero during data entry will automaticallyactlvate the estimating procedure." 8510 PRINTiPRINT 'If there are only two components, a range of mixtures can becalculated automatically - you will be prompted for the rangeif this option is chosen."

8520 GOSUB 7070 8530 RETURN

8540 REM Read data from file 8550 CLS

8560 PRINT"Checking disk for data..."

8570 GOSUB 8780:GOSUB 8670:GOSUB 8720

8580 IF N>L0F(1)/LF THEN 8650

8590 A(2,KS)-CVS(MF$):A(2,KS+1)«CVS(TF$)

8600 A(2,KS+2)-CVS(PF$):A(2,KS+3)=CVS(VF$)

8610 A(2.KS+4)=CVS(WF$):A(2,KS+5)=CVS(DF$)

8620 A(2,KS+6)-CVS(SF$):A(2,KS+7)-CVS(FF$)

8630 FOR J-1 TO 7:IF ABS(A(2,KS+J))<C3 THEN A(2,KS+J)=0 8640 NEXT 8650 RETURN

8660 REM Open file for crit data 8670 Y«LEFT$(YH,1)+"CRIT/DAT"

8680 OPEN"R",1,Y,128

8690 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$,4 AS VF$,4 AS WF$,4 AS DF$,4 AS SF$,4 AS FF$,60 AS XF$

8700 RETURN

8710 REM Find If name In record 8720 N-1 8730 GET 1,N

8740 J-LEN(YH):K-LEN(NF$):IF LEFT$(NF$,J)«YH THEN IF RIGHT$(NF$,K

J)»STRING$(K-J," ") THEN 8760

8750 N=N+1:IF N<=L0F(1)/LF THEN 8730

8760 RETURN

8770 REM Convert name to caps 8780 YH-YB

8790 FOR J-1 TO LEN(YB)

8800 K»ASC(MID$(YB,J))

8810 IF K>96 AND K<123 THEN YL«CHR$(K-32):MID$(YH,J)=YL 8820 NEXT 8830 RETURN

8840 REM Write data to disk

8850 IF N<*LOF(1)/LF THEN LSET FF$«=MKS$(A(2,KS+7)):GOTO 8920 8860 LSET NF$-YH

196 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

8870 LSET MF$=MKS$(A(2.KS)):LSET TF$=MKS$(A(2,KS+1)) 8880 LSET PF$=MKS$(A(2,KS+2)):LSET VF$=MKS$(A(2,KS+3)) 8890 LSET WF$=MKS$(A(2,KS+4)):LSET DF$=MKS$(A(2,KS+5)) 8900 LSET SF$=MKS$(A(2,KS+6)):LSET FF$=MKS$(A(2,KS+7)) 8910 LSET BF$*"

8920 PUT 1,N 8930 CLOSE 1 8940 RETURN

critical.bas

"Small-Scale Engineering Applications," by J. Neil Stone. July, page 253.

10 REM Predict critical props program - Apr 85 - CRITICAL/BAS 20 REM Rummens & Rajan, Can.J.Ch.E., Jun 1979, 349 - general 30 REM Edited for BYTE Dec 1985 40 GOTO 170

50 DATA"***** CRITICAL PROPERTY **♦**" 60 DATA"** PREDICTION **"

70 DATA" by"

80 DATA" J.Neil Stone"

90 DATA" Ledge Engineering Inc"

100 DATA" 179 Lansdowne Avenue"

110 DATA" Kingsville, Ontario, N9Y 3J2"

120 DATA" "

130 DATA" **** Apr 1985 ♦***"

140 CLS:FOR J-1 TO 9:READ Y:PRINT@ FN LC(NR/2-5+J,NS/2-17),Y:NEXT

150 RETURN

160 REM Initialize

170 CLEAR 500

180 DEFINT J-L,N:DEFSTR R,X-Z

190 DIM Y,K,J,M,TD,Y%,LF,KA

200 POKE 16409,1 'Set caps mode

210 NS«64:NR-16:LF-1 ’parameters for TRS80

220 , NS-80:NR-24:LF«128 'parameters for 80x24

230 DEF FN LC(J,K)«(J-1)*NS+K-1

240 GOSUB 50 'display title

250 DIM PB(3),E(2,11),Y(12),P(2),TR(2),F(1),V(2) ’arrays 260 REM Set up message strings

270 Y(1)="MoI ecu Iar we 1ght":Y(5)-"B.Pt.":Y(2)-Y(5)+" deg C":Y(3)-”SpecifIc gravity. 20/4“:Y(4)-" (opt)":Y(6)»"Vap.Press, ":ZZ(8)«"Density, g/cc”:Y(8)»"deg F":Y(9)»"deg C”:Y(10)«"mmHg":Y(11)-"psia":Y(12)-"kPa"

280 Y1Y2="###.###“:Y3-"###.##"

290 Z-“—>":Z1-CHR$(10)+CHR$(91)+CHR$(9)+CHR$(13)+"X"+"x":Z3-" ":Z4«".+

0123456789":Z2-Z4+Z1:Z5=CHR$(8)+CHR$(13)+"ED"+Z4

300 Z8«"USE UP, DN. RT ARROWS TO SELECT ENTRY. <X> TO EXIT":Z9-"USE <-- TO CORRECT. PRESS <ENTER> WHEN DONE":ZA-STRING$(17," “)

310 REM Set up constants

320 C1-1.5:C2-36:C3-42:C4-35:C5-.3143:C6-.0838:C7-8.315E

03:C8«1.9:C9-.26:CA»2.38:CB=.2:CC-.489:CD«.225:CE-.511:CF«660:CG«.1:CH*1,8:CJ= 32:CK-.10135:CL-760:CM-14.696:CN-1000:CP-273.16

330 ON ERROR GOTO 6130

340 GOTO 1500 ’to main program

490 REM Screen routine - put titles in ZZ()

500 CLS:PRINT® FN LC(1,(NS-LEN(RA))/2),RA

510 PRINT STRING$(NS-1

520 FOR J-KL TO KM

530 IF J-7 THEN PRINT:GOTO 570

540 IFJ-KL THEN PRINT TAB(5) ZZ(J) TAB(NS-14) E(2,J):GOTO 570 550 PRINT TAB(5) ZZ(J);

560 IF J>3 THEN PRINT TAB(NS-30) E(1,J) TAB(NS-14) E(2,J) ELSE PRINT 570 NEXT

580 PRINT® FN LC(NR-3,1),STRING$(NS-1,95)

590 PRINT® FN LC(NR-2.1),CHR$(30);RB;

600 KQ»NS-17:KP-KL+1:J9»3:GOTO 660 610 PRINT® FN LC(KP+1,KQ+1).Z;

620 PRINT® FN LC(NR-1,1),CHR$(30);Z8;

630 Y$-INKEY$:IF Y$- M ” THEN 630 640 IF INSTR(Z2,Y$)-0 THEN 630 650 J9-INSTR(Z1,Y$)

660 IF J9-0 THEN 800 ELSE PRINT® FN LC(KP+1,KQ+1),Z3;:ON J9 GOTO

(continual

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 197

690,680,710,680 670 RETURN 680 J9-J9-3

690 KP-KP+J9:IF KP>KM+1 THEN KP-KL+1 ELSE IF KP<KL+1 THEN KP-KM+1

700 GOTO 750

710 ON J8 GOTO 750,740

720 IF KQ-NS-49 OR KQ-NS-33 THEN KQ-KQ+16 ELSE KQ-NS-49 730 GOTO 750

740 IF KQ-NS-33 THEN KQ-NS-17 ELSE KQ-NS-33 750 ZF-STR$(KP-1):ZF-RIGHT$(ZF,LEN(ZF)-1)+","

760 IF INSTR(RD.ZF) THEN IF J9-3 THEN J9»1:GOTO 690 ELSE 690 770 IF INSTR(RE.ZF) THEN KQ-NS-17 780 GOTO 610

790 REM Dota entry section

800 PRINT® FN LC(NR-1,1),CHR$(30);Z9;

810 KC-1:ZE-V$

820 PRINT® FN LC(KP+1,KQ+1),ZA;:PRINT® FN LC(KP+1,KQ+1)+4.ZE;CHR$(95):

830 Y$=INKEV$:IF Y$="" THEN 830

840 IF INSTR(Z5.Y$)=0 THEN 830

850 ON INSTR(Z5.Y$) GOTO 900,920

860 KC-KC+1

870 ZE-ZE+Y$

’introductory text 'get title etc ‘get initial info ’input data 'calculate critprops ’results on screen ‘What next?

880 PRINT® FN LC(KP+1.KQ+1)+KC+3,Y$;CHR$(95);

890 GOTO 830

900 IF KC-0 THEN 830 ELSE KC-KC-1:IF KC-0 THEN ZE-"“ ELSE ZE-LEFT$(ZE.KC)

910 GOTO 820

920 KE-(KQ-NS+49)/16

930 E(KE,KP-1)=VAL(ZE)

940 PRINT® FN LC(KP+1,KQ+1),ZA;:PRINT@ FN LC(KP+1,KQ+1)+3.CSNG(VAL(ZE)); 950 ZE-'"': J9-1 v v u

960 IF KQ-NS-17 THEN KP-KP+1 970 IF KP>KM+1 THEN KP-KL+1 980 GOTO 710 1490 REM Main program 1500 GOSUB 6500 1510 GOSUB 4610 1520 GOSUB 3000 1530 GOSUB 2000 1540 GOSUB 2500 1550 GOSUB 3500 1560 GOSUB 4500

1570 ON NC GOTO 1590,1600,1610,1610 1580 CLS:ON ERROR GOTO 0:END 1590 GOSUB 4000:GOTO 1560 ’to hardcopy routine 1600 GOSUB 5000:GOTO 1560 'save to disk

1610 FOR J—1 TO 2:F0R K—1 TO 8:E(J,K)—0:NEXTK,J 'clean out input array 1620 ON NC-2 GOTO 1510,1520 y

1990 REM Data input 2000 CLS

2010 RA-"INPUT DATA FOR "+YA

2020 RB-"DATA FOR SECOND VAPOUR PRESSURE POINT OPTIONAL"

2030 RD="2,3,7,"

2040 RE-“1, "

2050 J8-2

2060 KL-1:KM=8:0N JF GOTO 2080.2080,2090 2070 E(1,4)=CK*CN:G0T0 2100 2080 E(1,4)-CL:GOTO 2100 2090 E(1,4)-CM

2100 ZZ(1)-Y(1):ZZ(2)-STRING$(NS-36, '* ")+"VaIue"+STRING$(9," “)+"Temperature , ':ZZ(3)=STRING$(43." ")+YT:ZZ(4)-Y(5)+"

"+YP+ M /“+YT:ZZ(5)=Y(6)+" "+YP:ZZ(6)-ZZ(5):ZZ(7)=" "

2110 GOSUB 500 'to screen entry 2120 M=E(2,1)

2130 N-4

2140 FOR J-0 TO 2 2150 ON JF GOTO 2170,2180,2190

2160 P(J)=E(1,J+N)/CN:T(J)-E(2,J+N)+CP:C-CN+CK:GOTO 2200

&

ESl'H+N^CK/CUTjJj-ECZ.J+Nj+CP^-CLrGOTO 2200

E(1,J+N)*CK/CL:

=(E(2.J+N)-CJ)/CH+CP:C-CL:GOTO 2200

2170 P 2180 P

2190 P(J)“E(1,J+N)+CK/CM:T(J)-(E(2|J+N)-Cj)/CH+CP:C-CM 2200 NEXT 2210 SG-E(1,8):D-SG+CN

2220 IF JF-2 OR JF-3 THEN T-(E(2,8)-CJ)/CH ELSE T-E(2.8) 2230 T(3)-T+CP V ‘

2240 RETURN 2490 REM Calculation

198 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

2500 CLS

2510 PRINT M CoIcuI ating"

2520 IF P(2)=0 THEN N-0 ELSE N-1

2530 IF P(0)=0 THEN GOSUB 2710 ELSE TB=T(0):TD-T(0)

2540 T1-C1*TD 2550 FOR J-0 TO 1 2560 TR(J)=T(N+J)/T1

2570 F ( J )-C2/TR(J)+C3*L0G(TR(J))-C4-TR(J)^6

2580 NEXT

2590 DF=F(0)-F(1)

2600 AL=(L0G(P(N)/P(N+1))-C5.DF)/(L0G(T(N)/T(N+1))-C6*DF)

2610 PC-EXP(LOG(P(N))-C5*F(0)-AL*(LOG(TR(0))-C6*F(0)))

2620 VC=C7*T1/PC/(C8+C9*AL)

2640 TR(2j=T(3)/T*i^V(2 j=M*(CC-CD*TR(2)+CE*( (1 -TR(2) )*(1/3) ) )/D 2650 T2=T1+CF*(V(1)-V(2))

2660 IF ABS(T2-T1)<-CG THEN 2680

2670 T1=T2:G0T0 2550 'loop if not converged

2680 PB(0)-T1:P8(1)-PC:PB(2)-VC*CN:PB(3)-.2033*AL-1.1816

2690 RETURN

2700 REM Estimate bpt by Antoine 2710 B«LOG(P(1)/P(2))/(1/T(2)-1/T(1))

2720 A-LOG(P(1))+B/T(1)

2730 TD-B/(A-LOG(C))

2740 RETURN 2980 REM

2990 REM Compound name

3000 INPUT"Nome of compound";YA

3010 IF JF THEN 3130 * j f is unit flog

3020 PRINT:PRINT"Which units ore you using?"

3030 PRINT:PRINT"1) mmHg ond deg C"

3040 PRINT"2) mmHg ond deg F"

3050 PRINT"3) psia and deg F"

3060 PRINT"4) kPo ond deg C"

3070 NC-4:GOSUB 6070

3080 JF-NC:ON JF GOTO 3100.3110.3120

3090 YP=Y(

2 )

1:YT*Y(

[9

IrGOTO 3130

3100 YP-YI

) :YT«YI

<9J

1 :GOTO 3130

3110 YP-YI

10 ;

!:YT»YI

;s;

1:GOTO 3130

3120 YP-YI

[11!

):YT-YI

is;

Table caption3130 RETURN

3490 REM Disploy results on screen

3500 CLS , , „„ ,

3510 YC-"CRITICAL PROPERTIES OF "+YA:J=(NS-LEN(YC))/2 3520 PRINT TAB(J);YC 3530 PRINT

3540 J-(NS-40)/2:K-(NS+30)/2

3550 PRINT TAB(Jj"Critical temperature, K:";:PRINT TAB(K) USING Y1;PB(0)

3560 PRINT TAB(J)"Criticol pressure. MPo:";:PRINT TAB(K) USING Y3;PB(1)

3570 PRINT TAB(J+19)"otmo:"PRINT TAB(K) USING Y1;PB(1)/CK

3580 PRINT TAB(J)"Critical volume, cc/mol:";:PRINT TAB(K) USING Y1;PB(2)

3590 PRINT , v

3600 PRINT TAB(J)"PIt 2 er acentric factor :";:PRINT TAB(K) USING Y2;PB(3)

3610 PRINT TAB(J)"RIedeI critical parameter :";:PRINT TAB(K) USING Y2;AL

3620 GOSUB 6030

3630 RETURN

3990 REM printer output 4000 CLS

4010 J-PEEK(14312) AND 240 'check if printer ready 4020 IF J-48 THEN 4060

4030 PRINT"Printer not on line - press <ENTER> when ready"

4040 Y«INKEY$:IF Y- M " THEN 4040

4050 GOTO 4000

4060 IF LP THEN 4370

4070 PRINT"If you ore going to calculate properties for several substances":PRINT"the results can be printed os a table."

4080 PRINT"Otherwlse they will be printed with each set as a separate":PRINT"report."

4090 PRINT"Press <T> for tabulated results, <S> for seporote reports"; 4100 YR*"Tt S s":GOSUB 6010 4110 LP-(KA<3)

4120 LPRINT TAB(10)"ProJect: ";YB;TAB(70)YD:LPRINT

4130 IF LP THEN 4270

4140 REM Single printout

4150 J«(80-LEN(YC))/2:LPRINT TAB(J);YC

[continued]

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 199

]uly

USING Y1;PB(0 USING Y3;PB

4160 LPRINT

4170 LPRINT TAB(18)"CrItIcoI temperoture, K:"::LPRINT TAB(55 4180 LPRINT TA8(18)"Crltlcol pressure, MPa:"j:LPRINT TAB(55 4190 LPRINT TAB(37)"atma:";:LPRINT TAB(55) USING Y1;PB(1)/.10133 41M0 LPRINT TAB ^ 18 ^" Crltlcal volum «* cc/moILPRINT TAB(55) USING Y1;PB(2)

4220 LPRINT TAB(18)"P1tier acentric factor :";:LPRINT TAB(55) USING Y2:PB(3) 4230 LPRINT TAB(18)"Rledel critical parameter :"j:LPRINT TAB(55) USING Y2;AL:GOTO 4240 v '

4240 LPRINT:LPRINT TAB(10)"These properties calculated using the method of Rummens ond Rajan":LPRINT TA8(10)“wlth the following Input dataLPRINT 4250 LPRINT TAB(18)"Mo I ecu Iar weight"::LPRINT TAB(55) USING Y3:M 4260 IF P(0) THEN LPRINT TAB(18) Y(5)+" "+YT;:LPRINT TAB(55) USING Y1;E(2,4) 4270 LPRINT TAB(18) ZZ(5);:LPRINT TAB(45) USING Y2+" "+YP+" @"+Y1+"

"+YT;E(1,5),E(2,5)

4280 IF E(1,6) THEN LPRINT TAB(18) ZZ(6);:LPRINT TAB(45) USING Y2+" "+YP+" @"+Y1+" "+YT;E(1,6),E(2,6)

4290 LPRINT TA8(18)ZZ(8);:LPRINT TAB(45) USING Y2+

"+YT;E(1,8),E(2,8)

4300 LPRINTCHR$(12)

4310 GOTO 4380 4320 REM Tabular printout

4330 LPRINT TAB(10)"Name";TAB(50)"CrItIcoI";TAB(70 4340 LPRINT TABf40V'Temp"jTAB(50)"Pressure";TAB(62 . ' K";TAB(49)"MPa atm";TAB(62

g/cc"+" @"+Y1+“

40

("Acentric"

)"Vo 1ume":TAB(70)"factor" ("cc/moI"

4350 LPRINT TAB 4360 LPRINT

4370 LPRINT TAB(10);YA;:LPRINT TAB(40) USING Y1;PB(0);:LPRINT TAB(47) USING

:LPRINT TAB :LPRINT TAB

Y3;PB(1);:

Y1;PB(2);:

4380 RETURN 4490 REM Menu 4500 CLS 4510 PRINT® FN LC(1,NS/2-3)," 4520 PRINT:PRINT TAB(10) M 1) H

USING Y1;PB(1 USING Y2;PB

10133;:LPRINT TAB(62) USING

WHAT NEXT"

Hardcopy of results"

Save critical properties to disk" New project"

Calculate another material"

End program"

4530 PRINT TAB 4540 PRINT TAB 4550 PRINT TAB 4560 PRINT TAB 4570 NC»5:G0SUB 6070 4580 RETURN

4600 REM Project Intro routine 4610 CLS:LP«0:JF«0:INPUT"Enter project t!tle";YB 4620 YD«LEFT$(TIME$,8):PRINT"Project date (default 4630 RETURN

4990 REM Save critical data

5000 GOSUB 5240:GOSUB 5120:GOSUB 5170

5010 CLS:PRINT"Savlng to file ";Y

5020 IF N>LOF(1)/LF THEN LSET XF$«STRING$(64," ")

5030 LSETNF$=YH

5040 LSETMF$«MKS$(M):LSETBF$»MKS$(TB)

";YD;")";:INPUT YD

5050 LSETTF$-MKS$(PB(0 5060 LSETVF$*MKS$(PB

fflj;

LSETPF$-MKS$(PB

10133)

•I ^FTWFtmlulir^'tf PRr

5070 LSETDF$»MKS$(SG):LSETSF$-MKS$(T)

5080 PUT1.N 5090 CLOSE 1 5100 RETURN

5110 REM Open file for crlt data 5120 Y=LEFT$(YA,1)+"CRIT/DAT"

5130 OPEN"R",1,Y,128

5140 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$,4 AS VF$,4 AS WF$,4 AS DF$,4 AS SF$,64 AS XF$

5150 RETURN

5160 REM Find If name In record 5170 N-1

5180 IF N>LOF(1)/LF THEN 5220 5190 GET 1,N

5200 J=LENfYH):K-LEN(NF$):IF LEFT$(NF$,J)*YH THEN IF RIGHT$(NF$,KJ)»STRING$(K-J," ") THEN 5220 5210 N=N+1:GOTO 5180 5220 RETURN

5230 REM Convert name to cops 5240 YH-YA

5250 FOR J-1 TO LEN(YA)

5260 K«ASC(MID$(YA,J))

5270 IF K>96 AND K<123 THEN YL-CHR$(K-32):MID$(YH,J)-YL 5280 NEXT

200 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

I uly

5290 RETURN

5990 REM Subroutines

6000 YR«"YyNn"

6010 Y»INKEY$: IF Y« ,: " THEN 6010

6020 KA-INSTR(YR.Y):IF KA THEN PRINT " ";Y:RETURN ELSE 6010 6030 PRINT® FN LC(NR-1, 1),“PRESS ANY KEY TO CONTINUE";

6040 Y*INKEY$: IF Y«" M THEN 6040 6050 CLS 6060 RETURN

6070 PRINT:PRINT"Choose by number 6080 Y*INKEY$:IF Y«"" THEN 6080 6090 Y%-VAL(Y)

6100 IF Y%<1 OR Y%>NC THEN 6080 6110 PRINT Y:NC-YX 6120 RETURN 6130 CLS

6140 IF ERR/2+1*5 OR ERR/2+1-11 OR ERR/2+1-6 THEN 6160 6150 PRINT"Error In I 1ne";ERL:ON ERROR GOTO 0:RESUME 6160 PRINT"Math error has occurred in line";ERL

6170 PRINT"Program will return to data entry to allow you to re-enter your input data."

6180 PRINT"Look for very low or very high, zero or negative values of":PRINT"input data."

6190 PRINT"Check that input data units are correct, and that all values arewithin the range of the correlation."

6200 GOSUB 6030: RESUME 1530 6490 REM Opening text 6500 CLS

6510 PRINT"This program calculates the critical properties and

acentric":PRINT"factors for many compounds.":PRINT

6600 PRINT"It is based on the correlation by Rummens and Rajan,

published":PRINT"In the Can.J.Ch.E., Jun 1979, (Vol 57, No.3), page 349."

6610 PRINT:PRINT"Input data required are the molecular weight, the vapor"

6620 PRINT"pressure at any two temperatures, and the density at

any":PRINT"temperature."

6630 PRINT:PRINT"One of the vapor pressure points may be the normal

boiIing":PRINT"point, although the authors recommend against this,

and":PRINT"suggest two other points 40 to 60 K apart will give best results"

6640 GOSUB 6030

6650 RETURN

I istingl.bas

"Small-Scale Engineering Applications," by J. Neil Stone. July, page 253.

8540 REM Read data from file 8550 CLS

8560 PRINT"Checking disk for data..."

8570 GOSUB 8780:GOSUB 8670:GOSUB 8720

8580 IF N>LOF(1)/LF THEN 8650

8590 A(2,KS)»CVS(MF$):A(2,KS+1)»CVS(TF$)

8600 A(2,KS+2)-CVS(PF$):A(2,KS+3)-CVS(VF$)

8610 A(2,KS+4)-CVS(WF$):A(2,KS+5)-CVS(DF$)

8620 A(2,KS+6)-CVS(SF$):A(2,KS+7)-CVS(FF$)

8630 FOR J«1 TO 7:IF ABS(A(2,KS+J))<C3 THEN A(2,KS+J)»0 8640 NEXT 8650 RETURN

8660 REM Open file for crit data 8670 Y«LEFT$(YH,1)+"CRIT/DAT"

8680 OPEN"R",1,Y,128

8690 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$, 4 AS VF$,4 AS WF$,4 AS DF$,4 AS SF$,4 AS FF$,60 AS XF$ 8700 RETURN

8710 REM Find if name In record 8720 N-1 8730 GET 1,N

8740 J-LEN(YH):K-LEN(NF$):IF LEFT$(NF$,J)-YH THEN IF RIGHT$(NF$,K-J)«STRING$(K-J," ") THEN 8760 8750 N-N+1:IF N<«L0F(1)/LF THEN 8730 8760 RETURN

8770 REM Convert name to caps

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 201

8780 VH-VB

8790 FOR J-1 TO LEN(YB)

8800 K«ASC(MID$(YB.J))

8810 IF K>96 AND K<123 THEN YL-CHR$(K-32):MID$(YH,J)-YL 8820 NEXT 8830 RETURN

8840 REM Write data to disk

8850 IF N<-LOF(1)/LF THEN LSET FF$-MKS$(A(2,KS+7)):

GOTO 8920 8860 LSET NF$-YH

8870 LSET MF$«MKS$(A(2.KS)):LSET TF$=MKS$(A(2.KS+1)) 8880 LSET PF$«MKS$(A(2,KS+2)):LSET VF$=MKS$(A(2,KS+3)) 8890 LSET WF$-MKS$(A(2,KS+4)):LSET DF$=MKS$(A(2,KS+5)) 8900 LSET SF$=MKS$(A(2,KS+6)):LSET FF$-MKS$(A(2,KS+7)) 8910 LSET BF$« M 8920 PUT 1.N 8930 CLOSE 1 8940 RETURN

list!ng2.bas

"Small-Scale Engineering Applications," by J. Nell Stone. July, page 253.

200 NS=64:NR»16:LF«1 ’screen parameters for TRS80

210 ’NS»80:NR=24:LF-128 ’screen parameters for 80x24 (IBM)

220 DEF FN LC(J,K)-(J-1)*NS+K-1

vleclbm.bas

"Small-Scale Engineering Applications," by J. Neil Stone. July, page 253.

0 REM ESTIMATE VISCOSITY - May 85 - VISCIBM.BAS. Version for BASICA 10 REM Final, Sept 2nd, 1985

20 REM Data input screen based on concept of L.E.Sparks, ACCESS 1982, p10 30 REM Edited for BYTE Dec 85 40 GOTO 160

50 DATA"****** VISCOSITIES ******"

60 DATA"* OF LIQUIDS AND MIXTURES *"

by"

J.Neil Stone"

Ledge Engineering Inc"

179 Lansdowne Avenue"

110 DATA" Kingsville, Ontario, N9Y 3J2"

120 DATA" "

130 DATA" **** May 1985 **♦*"

140 CLS:FOR J-1 TO 9:READ Y:LOCATE NR/2-5+J,NS/2-17:PRINT Y:NEXT

150 RETURN

160 CLEAR 1500

170 DEFINT J-L,N:DEFSTR X-Z

180 DIM

70 DATA" 80 DATA" 90 DATA" 100 DATA"

Y,J,K,NS,KP,Y%,LC,KQ,AT,KC,N,UT,A,J9,ET,TR,TL,J8,J$,KS,RD,NL,NC,F2,NR,V,NM ’simple vars

210 NS=80:NR-24:LF=128 ’ parameters for 80x24 (IBM)

220 DEF FN LC(J,K)*(J-1)*NS+K-1 230 GOSUB 50 'dispI ay ti11e

240 DIM A(2,92),AX(10),AY(10),YT(8),Y(8),AV(10),AM(10),YN(10),YM(3),MC(10) ’arrays

250 REM Set up message strings

260 Y(1)="MoI ecu I or weight":Y(2)«"Cr11icaI temp, K":Y(3)="CriticaI press, atm":Y(4)="Critlea I vol, cc/moI":Y(5)*"Acentric factor":Y(8)="Me11ing point, deg C":Y(6)*"Density, g/cc (SG)":Y(7)*"Temp. of density measure, deg C"

270 YM(1)="PrzezdzieckI & Sridhar":YM(2)-"StieI & Thodos":YM(3)="AIChE Data Prediction ManuaI"

280 Z= "—> " : Z1 =CHR$ (91) +CHR$ (10) +CHR$ (13 ) + "Xx " +CHR$ ( 9 ) : Z3= " " : Z4= " <—

":Z6»".-0123456789":Z2«Z6+Z1:Z5*Z6+"ED+"+CHR$(13)+CHR$(8)

290 Z8="USE UP, DOWN, RT ARROWS TO SELECT ENTRY. <X> TO EXIT.":Z9»"USE "+Z4+"

202 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

TO CORRECT. PRESS <ENTER> WHEN DONE":ZC-STRING$(17," "):ZS=STRING$(79, 11 ")

300 Y1-"###.##":Y2-"###":Y3-"##.####":Y4="####.####":Y5-"##.####

310 REM Set up constants

320 C1*273.16:C2-2/7:C3*1E-10

330 ON ERROR GOTO 7190

340 GOTO 1000 'to main prog

390 REM All-purpose screen for 1,2 or 3 col numeric entry

400 REM Screen layout

410 CLS:PRINT TAB((NS-LEN(ZA))/2) ZA

420 PRINT STRING$(NS-1,"»" }

430 FOR J*1 TO NT:J$-RIGHT$(STR$(J),1)

440 PRINT YT(J);

450 IF INSTR(ZD,J$) THEN PRINT-.GOTO 490 ELSE IF INSTR(ZG,J$) THEN 480 460 IF J8>2 THEN PRINT TAB(NS-45);A(0.KS+J-1);

470 IF J8>1 THEN PRINT TAB(NS-29);A(1,KS+J-1);

480 PRINT TAB(NS—13);A(2,KS+J-1)

490 NEXT

500 REM Display data as SP to prevent overflows 510 LOCATE 14,1:PRINT STRING$(NS-1,95)

520 LOCATE 15,1:PRINT ZS;:LOCATE 15,1:PRINT ZB;

530 REM Begin display

540 KQ-NS-17:KP-KL+1:J9=6:G0T0 600

550 LOCATE KP+1,KQ+1:PRINT Z;

560 LOCATE 16,1:PRINT ZS;:LOCATE 16,1:PRINT Z8;

570 Y$*INKEY$: IF Y$* ,,,, THEN 570

580 IF LEN(Y)«1 THEN IF INSTR(Z2,Y$)-0 THEN 570

590 IF LEN(Y)»1 THEN J9-INSTR(Z1,Y$) ELSE J9=ASC(RIGHT$(Y,1)):IF J9-80 THEN

J9-2 ELSE IF J9=72 THEN J9=1 ELSE 570

600 IF J9=0 THEN 760 ELSE LOCATE KP+1,KQ+1:PRINT Z3;

610 ON J9 GOTO 640,620,620,630,630,670 620 J9*1:GOTO 650 630 RETURN 640 J9=-1

650 KP*KP+J9:IF KP>KM+1 THEN KP-KL+1 ELSE IF KP<KL+1 THEN KP*KM+1

660 GOTO 710

670 ON J8 GOTO 710,700

680 IF KQ-NS-49 OR KQ*NS-33 THEN KQ*KQ+16 ELSE KQ*NS-49 690 GOTO 710

700 IF KQ-NS-33 THEN KQ-NS-17 ELSE KQ*NS-33 710 ZF*STR$(KP-1):ZF*RIGHT$(ZF,LEN(ZF)-1)+","

720 IF INSTR(ZD.ZF) THEN IF J9*6 THEN J9-1:GOTO 650 ELSE 650 730 IF INSTR(ZG.ZF) THEN KQ-NS-17 740 GOTO 550

750 REM Data entry section

760 LOCATE 16,1:PRINT ZS;:LOCATE 16,1:PRINT Z9;

770 KC-1:ZE*Y$

780 LOCATE KP+1,KQ+1:PRINT ZC;:LOCATE KP+1,KQ+5:PRINT ZE;CHR$(95);

790 Y$»INKEY$: IF Y$- ,,M THEN 790

800 Y%*INSTR(Z5,Y$):IF Y%«0 THEN IF LEN(Y$)>1 AND ASC(RIGHT$(Y$,1))«75 THEN 860 ELSE 790

810 IF Y%>15 THEN ON Y%-15 GOTO 880,860 820 KC-KC+1 830 ZE*ZE+Y$

840 LOCATE KP+1,KQ+KC+4:PRINT Y$;CHR$(95);

850 GOTO 790

860 KC-KC-1:IF KC<-0 THEN KC-0:ZE- M " ELSE ZE-LEFT$(ZE,KC)

870 GOTO 780

880 KE*(KQ-NS+49)/16

890 A(KE,KP+KS-2)-VAL(ZE)

900 LOCATE KP+1,KQ+1:PRINT ZC;:LOCATE KP+1,KQ+4:PRINT CSNG(VAL(ZE));

910 ZE-"":J9-1

920 IF KQ-NS-17 THEN KP-KP+1 930 IF KP>KM+1 THEN KP-KL+1 940 GOTO 670 990 REM Main program

1000 GOSUB 8000 'introductory text

1010 GOSUB 6620 'title etc

1020 GOSUB 6080 'main menu

1030 ON NM GOSUB 1250,1250,1500 'goto correct routine

1040 IF NC<>6 THEN 1060

1050 ON ERROR GOTO 0:END 'end of program

1060 FOR K-0 TO 2:FOR J-1 TO 8:A(K,J)-0:NEXTJ,K:LP-0

1070 IF NC-5 THEN JP-0:LT-0

1080 ON NC-3 GOTO 1020,1010

1240 REM Viscosity prediction by both methods

[continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 203

1250 IF NE THEN 1290 1260 GOSUB 8270 1270 GOSUB 2000 1280 GOSUB 8550 1290 GOSUB 2030 1300 GOSUB 2150 1310 GOSUB 6170

•go to Input If returned by error • intro text •name of substance •load data from file, if any •enter phys props •calc for substance 'calculation options 1320 IF TN-0 THEN GOSUB 2360:GOSUB 4500 ELSE GOSUB 2500 •calc for temp of Interest 1330 GOSUB 6400 *what next

1340 ON NC GOTO 1360,1310,1370 1350 RETURN

1360 CLS:GOSUB 5000:GOTO 1330

1370 FOR K-0 TO 2:FOR J-1 TO 8:A(K,J)»0:NEXT J ,K: LP-0-.GOTO 1270 1490 REM Mixture routine

1500 IF NE THEN 1540 'to entry if return on error 1510 GOSUB 8470 •Intro blurb

1520 GOSUB 3000 ’get names of materials

1530 IF NL-2 THEN GOSUB 3120 ’range of calcs?

1540 GOSUB 3250 'data in

1550 GOSUB 3490 •estimate missing viscosities

1560 GOSUB 3750 ’viscosity of mixture/print

1570 GOSUB 6510 'what next?

1580 ON NC GOTO 1610,1530,1650 1590 RETURN

1600 REM Hardcopy results

1610 IF AL THEN CLS:PRINT M Too latel Cannot print results for range now.":GOSUB 7070:GOTO 1570

1620 CLS:GOSUB 5410 ’hardcopy results

1630 GOTO 1570

1640 REM Clean out data

1650 AL-0:FOR J-1 TO NL:FOR K-0 TO 2:A(K,J)«0:NEXT K.JrGOTO 1520 1990 REM Input material data 2000 CLS:KS«1

2010 INPUT"Name of Substance";YB 2020 RETURN

2030 CLS:NE-0 ’reset error flag

2040 KS-1:KL»1:KM-8:ZA-"PR0PERTIES OF "+YB

2050 ZB-" M :ZD-" M :ZG-"":J8-1

2060 IF NM-2 THEN KM-7 ’no f. pt needed for St k Th

2070 FOR J-1 TO KM:YT(J)-Y(J):NEXT ’Instal titles

2080 NT-9-NM 'no of titles

2090 GOSUB 410 'to data input

2100 GOSUB 2600 ’check Input data valid

2110 IF NE THEN NE»0:GOTO 2090 ELSE GOSUB 8850

2120

MW=A(2,1):TC-A(2,2):PC-A(2,3):VC=A(2,4):W*A(2,5):TF-A(2,8)+C1:SG=A(2,6):TD=A(2 ,7)+C1 ’get data in equation variables 2130 RETURN

2140 REM Calculate basic parameters 2150 CLS

2160 TR-TD/TC:FZ«.29056-.08775*W ’Yamada k Gunn, 1973 2170 GOSUB 2290

2180 VS-MW/SG/F2 ’calc scaling factor

2190 IF NM-2 THEN GOTO 2320 ’Stiel and Thodos

2200 REM Pr and Sr method

2210 TR-TF/TC

2220 GOSUB 2290

2230 VM—F2*VS

2240 VZ-.0085*TC*W-2.02+VM/(.342*TR+.894)

2250 F1=4.27+.032*MW-.077*PC+.014*TF-3.82*TR

2260 B-.33+VC/F1 - 1.12

2270 RETURN

2280 REM Calc f2(t)

2290 F2-FZ*((1-TR)~C2) •Yamada & Gunn 1973 2300 RETURN

2310 REM Stiel and Thodos parameter 2320 ES«TC~(1/6)

2330 ES-ES/SQR(MW)/(PC~(2/3))

2340 RETURN

2350 REM Calc for specific temp 2360 TR-(TL+C1)/TC 2370 GOSUB 2290:V=F2*VS

2380 IF NM-2 THEN GOTO 2420 *to Stiel and Thodos 2390 ET-B*(V/VZ-1):ET-1/ET 2400 GOTO 2480

204 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

2410 REM StleI and Thodos calc

2420 IF TR<1.5 THEN UB=34E-05*(TR~.94) ELSE UB»17.78E-05*((4.58*TR1.67)*(5/8)) 'calc low press vise 2430 RD-VC/V

2440 UT«(((.0093324*RD-.040758)*RD+.058533)*RD+.023364)*RD+.1023

2450 UT-UT*UT*UT*UT

2460 UT-UT-1E-04+UB

2470 ET-UT/ES

2480 RETURN

2490 REM Calc for range of temps 2500 CLS

2510 FOR TL-TS TO TE STEP TN 2520 GOSUB 2360 2530 GOSUB 5170 2540 GOSUB 4650 2550 NEXT

2560 TL-TL-TN ’restore last temp calc’d

2570 IF N THEN GOSUB 7070 2580 RETURN

2590 REM Check validity of input data 2600 FOR J-KS TO KS+5 2610 IF A(2,J)>0 THEN 2630

2620 CLS:PRINT Y(J-KS+1);" cannot be zero or negative.":NE=1 2630 NEXT

2640 IF NE THEN PRINT:PRINT"Program will return to data entry. Please correct input. M :GOSUB 7070 2650 RETURN

2990 REM Initial input for mixtures 3000 CLS:JP-0

3010 NL-0 • intialise - NL no of comps

3020 NL-NL+1:YN(NL)-" M :MC(NL)-0:PRINT "Name of component no:";NL just <ENTER> if no more componentsINPUT YN(NL)

3030 IF YN(NL)o"" THEN IF NL<10 GOTO 3020

3040 NL-NL-1:IF NL<2 THEN PRINT "Must have at least two components:GOTO 3020 3050 CLS

3060 PRINT "Are your compositions in wt% or mol% - type <W> or <M>"

3070 YR-"WwMm":GOSUB 7040

3080 MX»(KA>2) ’mx true if mol%

3090 IF MX THEN YU-"molX" ELSE YU-"wtX"

3100 RETURN

3110 REM Calculate for range

3120 CLS:AL-0:MP-0:PRINT "Do you want to automatically calculate viscosities for a rangeof compositions Y/N?"

3130 GOSUB 7030 3140 IF KA>2 THEN 3230

3150 PRINT "Minimum value of ";YU" for ";YN(1);:INPUT AL

3160 IF (AL<0) OR (AL>100) THEN PRINT YU;"must be in range 0-100":GOTO 3150 3170 PRINT "Maximum value of ";YU" for ";YN(1);;INPUT AH

3180 IF (AH<0) OR (AH>100) OR (AH<AL) THEN PRINT YU;"must be in range 0-100

and max must be bigger than min.":GOTO 3170

3190 PRINT "Increments of ";YU" for ";YN(1);:INPUT AD

3200 PRINTrPRINT "Do you want hardcopy of the results as they are done, Y/N?" 3210 GOSUB 7030

3220 MP«(KA<3) ’true if hardcopy needed 3230 RETURN

3240 REM Initial data entry for mixtures

3250 FOR J-1 TO NL:IF LEN(YN(J))>NS-51 THEN YT(J+1)»LEFT$(YN(J),NS-51) ELSE YT(J+1)»YN(J)

3260 NEXT

3270 YT(1)-STRING$(NS-46," ")+"Visc - cp"+STRING$(7," ")+"MoI.Wt"+STRING$(10," ")+YU

3280 ZA-"MIXTURE VISCOSITY INPUT DATA"

3290 ZB-"LEAVE ANY UNKNOWN DATA AS 0 - MW NOT NEEDED IF USING MOL%"

3300 ZD-"1,":ZG-"":J8-3:NT-NL+1:KL-2:KM-NL+1:KS-0 3310 IF AL THEN A(2,1)-AL:A(2,2)»100-AL 3320 GOSUB 410 ’screen routine

3330 GOSUB 3390 ’check data

3340 IF NE THEN NE«0:GOTO 3320 ’return if data check not OK

3350 FOR J-1 TO NL:AV(J)-A(0,J):AM(J)-A(1,J):AX(J)«A(2,J):NEXT ’put data into

working vars; av-vI sc,am-mw,ax-frn

3360 TL—1000 ’flag to show temp not set

3370 RETURN

3380 REM Check screen Input for mixtures 3390 CLS:NE-0:A-0 3400 FOR J-1 TO NL

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 205

3410 IF NOT MX THEN IF A(1,J)<-0 THEN PRINT"MoI ecu Iar wt for M ;YN(J); M requI red":NE-1

3420 IF NL<>2 OR AL-0 THEN IF A(2,J)<0 OR A(2,J)>100 THEN PRINT YU;" of ";YN(J); M out of range":NE«1 3430 A-A+A(2,J)

3440 NEXT

3450 IF A>100 OR A<100 THEN PRINT M Componente do not add to 100 M ;YU:NE«1 3460 IF NE THEN GOSUB 7070 3470 RETURN

3480 REM Estimate viscosity of missing Items

3490 CLS:NK«0 'nk Is temperature flag

3500 FOR LM-1 TO NL ’lm is main counter

3510 IF AV(LM) THEN 3720 ’skip If vise given

3520 MC(LM)«1:PRINT "Estimating viscosity of ";YN(LM)

3530 PRINT:PRINT "Is ";YN(LM):PRINT "a non-associating compound, Y/N?";

3540 GOSUB 7030

3550 IF KA<3 THEN NM-1 ELSE NM-2

3560 YB-YN(LM):KS-LM*8+4:A(2,KS)-AM(LM):GOSUB 8550 ’check for data on disk 3570 CLS:NE-0 ’reset error flag 3580 KL-1:KM-8:ZA-"PROPERTIES OF "+YB 3590 ZB-"":ZD-"":ZG-"":J8-1

3600 IF NM-2 THEN KM-7 ’no f. pt needed for St k Th

3610 FOR J-1 TO KM:YT(J)»Y(J):NEXT ’Instal titles

3620 NT-9-NM ’no of titles

3630 GOSUB 410 ’to data Input

3640 GOSUB 2600 'check Input data valid

3650 IF NE THEN NE-0:GOTO 3630 ELSE GOSUB 8850

3660

MW»A(2,KS):TC«A(2.KS+1):PC-A(2.KS+2):VC-A(2.KS+3):W»A(2,KS+4):TF«A(2.KS+7)+C1: SG-A(2,KS+5):TD*A(2,KS+6)+C1 ’get data In equation variables 3670 GOSUB 2150 'start calculation

3680 CLS:IF NK-0 THEN NK«1:INPUT "Temperature of estimate, deg C.";TL 3690 GOSUB 2360

3700 AV(LM)-ET:A(0,LM)-CSNG(ET) 'save answer

3710 CLS:PRINT "Viscosity of ";YN(LM);" caIcuIated":G0SUB 7010:NM-3

3720 NEXT

3730 RETURN

3740 REM Calculate vise of mixture 3750 IF AL THEN GOTO 3790

3760 IF NOT MX THEN GOSUB 3890 ’conv to moles If nec

3770 GOSUB 3960 ’calculate mixture vise

3780 GOTO 3860 ’to return

3790 N=0:FOR A-AL TO AH STEP AD

3800 AX(1)»A:AX(2)-100-A

3810 IF NOT MX THEN GOSUB 3890

3820 GOSUB 3960

3830 IF MP THEN GOSUB 5570

3840 GOSUB 4730

3850 NEXT

3860 IF NL>2 OR AL-0 THEN GOSUB 4550 ELSE IF N THEN GOSUB 7070 ’to screen if results requ’d 3870 RETURN

3880 REM Convert to mole frn

3890 AT«0:FOR J-1 TO NL

3900 AY(J)-AX(J)/AM(J):AT-AT+AY(J)

3910 NEXT

3920 FOR J-1 TO NL 3930 AX(J)-AY(J)*100/AT 3940 NEXT:RETURN 3950 REM Vise of mixture 3960 AT-0

3970 FOR J-1 TO NL

3980 AT-AT+AX(J)*LOG(AV(J))

3990 NEXT

4000 ET»EXP(AT/100) ’viscosity of mixture 4010 RETURN

4490 REM Print results 4500 CLS

4510 PRINT "Viscosity of ";YB;" at";:PRINT USING " ###.# deg C Is ###.### cp";TL,ET 4520 PRINT 4530 RETURN

4540 REM Screen print for mixture 4550 CLS

4560 PRINT "Viscosity of mixture of:"

4570 FOR J-1 TO NL

206 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

4580 PRINT TAB(5) USING Y1;A(2,J);:PRINT" ";YU;" M ;YN(J)

4590 NEXT

4600 PRINTrIF TLo-1000 THEN PRINT "ot " j TL;" deg C";

4610 PRINT " is";:PRINT USING Y3;ET;:PRINT " cp"

4620 GOSUB 7070 4630 RETURN

4640 REM Screen print list of results 4650 IF TLoTS AND N<>0 THEN 4680 4660 N-0:PRINT “Viscosity of ";YB

4670 PRINT TAB(5) "Temperature, deg C";TAB(NS-25)"Viscosity, cp"

4680 PRINT TAB(12) USING Y2;TL;:PRINT TAB(NS-23) USING Y4;ET 4690 N-N+1

4700 IF N-NR-4 THEN GOSUB 7070:N=0:CLS 4710 RETURN

4720 REM Screen display list of mixture results

4730 IF AoAL AND N<>0 THEN 4760 'jump titles if not first time 4740 CLS:N-0:PRINT TAB(12);YU;" of";TAB(54)"Viscosity"

4750 PRINT YN(1);TAB(25) YN(2);TAB(58)"cp"

4760 PRINT USING Y1;A;

4770 PRINT TAB(25) USING Y1;100-A;

4780 PRINT TAB(56) USING Y3;ET 4790 N-N+1

4800 IF N-NR-4 THEN GOSUB 7070:N-0 4810 RETURN

4990 REM Hardcopy results

5000 IF TN THEN CLS:PRINT "Too late! Cannot print results for range

now.":GOSUB 7070:GOTO 5150

5005 GOSUB 6000

5010 CLS:0N JP GOTO 5020,5090

5020 GOSUB 5290:GOSUB 5330

5030 LPRINT

5040 LPRINT TAB(5) "viscosity of ";YB;" estimated by method of ";YM(NM);" is:"

5050 LPRINT:LPRINT TAB(25) USING Y4+" cp at "+Y2+" deg C";ET,TL

5060 LPRINT:LPRINT

5070 GOTO 5150

5080 REM Table heading

5090 IF LT THEN 5140 'LT is flag for table 5100 GOSUB 5290 5110 LPRINT

TAB(5)"Substance";TAB(25)"Temperature";TAB(40)"Viscosity";TAB(52)"Method"

5120 LPRINT TAB(30)"deg C";TAB(44)"cp"

5130 LPRINT:LT-1

5140 LPRINT TAB(5)YB;:LPRINT TAB(29) USING Y2;TL;:LPRINT TAB(40) USING Y4;ET;:LPRINT TAB(52) YM(NM)

5150 RETURN

5160 REM List results for temp range on printer 5170 IF LP-0 THEN 5270 5180 IF TLOTS THEN 5250 5190 GOSUB 5290:GOSUB 5330

5200 LPRINT TAB(5)"Estimated viscosities using method of ";YM(NM)

5210 LPRINT

5220 LPRINT TAB(10)"Temperature";TAB(45)"Viscosity"

5230 LPRINT TAB(13)"deg C";TAB(49)"cp"

5240 LPRINT

5250 LPRINT TAB(14) USING Y2;TL;:LPRINT TAB(45) USING Y4;ET 5260 IF TL+TN>TE THEN LPRINT 5270 RETURN

5280 REM Print heading

5290 LPRINT TAB(5)"Project: ";YP;TAB(55)YD 5300 LPRINT 5310 RETURN

5320 REM Input data print

5330 LPRINT TAB(5)"INPUT DATA for ";YB

5340 LPRINT

5350 FOR J-1 TO 9-NM

5360 LPRINT TAB(10) Y(J);:LPRINT TAB(45) USING Y4;A(2,J)

5370 NEXT 5380 LPRINT 5390 RETURN

5400 REM Hardcopy for mixtures 5410 GOSUB 5290

5420 LPRINT TAB(40)"INPUT DATA":LPRINT

5430 LPRINT TAB(5)"Substance";TAB(35)"Visc - cp";TAB(48)"Mo I. wt";TAB(63)YU

5440 FOR J-1 TO NL

5450 LPRINT TAB(5) YN(J);

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 207

5460 LPRINT TAB(35) USING Y3;AV(J);

5470 IF MC(J) THEN LPRINT"*";

5480 LPRINT TAB(48) USING Y1;AM(J);

5490 LPRINT TAB(61) USING Y1;A(2,J)

5500 NEXT

5510 LPRINT:LPRINT TAB(10) "* means estimated value, not Input"

5520 LPRINT:LPRINT TAB(5) "Viscosity of mixture";

5530 IF TLo-1000 THEN LPRINT" at";TL;" deg C";

5540 LPRINT" is";:LPRINT USING Y3;ET;:LPRINT" cp.":LPRINT 5550 RETURN

5560 REM Table of mixture viscosities

5570 IF AoAL THEN 5700 'only print title first time

5580 GOSUB 5290

5590 LPRINT:LPRINT TAB(5) "Viscosities of mixtures of:"

5600 LPRINT:FOR J-1 TO 2 5610 LPRINT TAB(10);YN(J)

5620 NEXT 5630 LPRINT

5640 IF TLo-1000 THEN LPRINT TAB(5)" at";TL;" deg C ";

5650 LPRINT TAB(5) "are as follows:"

5660 LPRINT:LPRINT TAB(17);YU;" of ";

5670 LPRINT TAB(55)"VIscosIty"

5680 LPRINT TAB(5);YN(1);TAB(30);YN(2);TAB(58)"cp"

5690 LPRINT

5700 LPRINT TAB(5) USING Y1;A;:LPRINT TAB(30) USING Y1;100-A;

5710 LPRINT TAB(55) USING Y3;ET 5720 IF A+AD>AH THEN LPRINT 5730 RETURN

5990 REM Hardcopy option menu

6000 CLS:IF JP=2 THEN 6060

6010 LOCATE 1,(NS-7)/2:PRINT "PRINT OPTIONS"

6020 PRINT:PRINT TAB(5)"1) Print Just the current result complete with Input data"

6030 PRINT TAB(5)"2) Print table headings and start table for all":PRINT TAB(8)"resuIts until new project is started."

6040 NC-2:GOSUB 7120

6050 JP-NC 'JP * flag for choice

6060 RETURN

6070 REM Main menu

6080 CLS

6090 LOCATE 1,(NS-4)/2:PRINT "MAIN MENU"

6100 PRINT:PRINT TAB(5)"1) Viscosity of non-associating liquid - most accurate"

6110 PRINT TAB(5)"2) Viscosity of associating liquid - not very accurate" 6120 PRINT TAB(5)"3) Viscosity of liquid mixture"

6130 NC=3:GOSUB 7120 6140 NM=NC 6150 RETURN

6160 REM Calculation options 6170 CLS

6180 LOCATE 1,(NS-10)/2:PRINT "CALCULATION OPTIONS"

6190 PRINT:PRINT TAB(5)"1) Estimate viscosity for one specific temperature" 6200 PRINT TAB(5)"2) Estimate viscosity for a range of temperatures"

6210 PRINT

6220 NC*2:GOSUB 7120 6230 TN=0

6240 ON NC GOTO 6370

6250 CLS:INPUT"Start of temperature range, deg C";TS 6260 INPUT"End of temperature range, deg C";TE 6270 INPUT"Temperature interval in range, deg C";TN 6280 PRINT:PRINT "Everything correct, Y/N? ";

6290 GOSUB 7030 6300 IF KA>2 THEN 6250

6310 CLS:PRINT "Do you want results tabulated on printer, Y/N? "

6320 GOSUB 7030 6330 LP*(KA<3)

6340 IF LP THEN PRINT "Press <ENTER> when printer is ready" ELSE 6380 6350 Y*INKEY$:IF Y*"" THEN 6350 6360 GOTO 6380

6370 CLS:INPUT"Temperature, deg C";TL 6380 RETURN

6390 REM Menu after calc

6400 PRINT TAB((NS-4)/2),"WHAT NEXT"

6410 PRINT

6420 PRINT TABf5V'1J Hardcopy of result (one result only)."

6430 PRINT TAB(5r'2) Viscosity for same material at another temperature."

208 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

6440 PRINT TAB(5)"3) Viscosity for different substance of the same type."

6450 PRINT TAB(5)"4) Main menu."

6460 PRINT TAB(5)"5) New project (all data lost)."

6470 PRINT TAB(5)"6) End program."

6480 NC=6:GOSUB 7120 6490 RETURN

6500 REM Menu after mix

6510 PRINT TAB((NS-4)/2),"WHAT NEXT"

6520 PRINT

6530 PRINT TAB(5)"1) Hardcopy of results"

6540 PRINT TAB(5)"2) Another calculation for same materials."

6550 PRINT TAB(5)"3) Calculate for a different mixture."

6560 PRINT TAB(5)"4) Main menu."

6570 PRINT TAB(5)"5) New project (all data lost)."

6580 PRINT TAB(5)"6) End program."

6590 NC«6:GOSUB 7120 6600 RETURN

6610 REM Project intro routine

6620 CLS:INPUT"Enter project title";YP

6630 YD-LEFT$(DATE$,10):PRINT "Project date (default = ";YD;")";:INPUT YD

6640 RETURN

6990 REM Subroutines

7000 REM Delay

7010 FOR J-1 TO 2000:NEXT:RETURN 7020 REM Check inkey 7030 YR»"YyNn"

7040 Y*INKEY$:IF Y-"" THEN 7040

7050 KA«INSTR(YR,Y):IF KA THEN RETURN ELSE 7040

7060 REM Press key to cont

7070 LOCATE NR,1:PRINT "PRESS ANY KEY TO CONTINUE";

7080 Y«INKEY$:IF Y«"" THEN 7080 7090 CLS 7100 RETURN

7110 REM Select from menu

7120 PRINT:PRINT"Choose by number"

7130 Y«INKEY$:IF Y-"" THEN 7130 7140 Y%«VAL(Y)

7150 IF Y%<1 OR Y%>NC THEN 7130 7160 PRINT Y:NC-Y%

7170 RETURN

7180 REM Error trap

7190 CLS

7200 IF ERR-5 THEN 7250 7210 IF ERR-11 THEN 7290 7220 IF ERR*54 THEN 7360 7230 IF ERR*6 THEN 7270

7240 PRINT "Error in Iine";ERL:0N ERROR GOTO 0:RESUME

7250 PRINT "Illegal function call error has occurred In Iine";ERL:GOSUB 7340 7260 PRINT "Look for negative or zero values of input data":GOTO 7310 7270 PRINT "Overflow error has occurred in Iine";ERL:GOSUB 7340 7280 PRINT "Look for very low or very high values of input data":GOTO 7310 7290 PRINT "Division by zero error has occurred in Iine";ERL:GOSUB 7340 7300 PRINT "Look for very low or zero values of input data"

7310 PRINT "Check that input data units are correct, and that all values arewithin the range of the correlation"

7320 GOSUB 7070:NE-1 'ne is error flag 7330 RESUME 1030

7340 PRINT "Program will return to data entry to allow you to checkvaIidity of your input data"

7350 RETURN

7360 PRINT "No such file"

7370 GOSUB 7070:CLOSE:JF=1:RESUME NEXT 7990 REM Introductory blurb 8000 CLS

8010 GOSUB 8220:IF NB THEN 8200

8020 CLS:PRINT "This program estimates viscosities of pure liquids and mixtures"

8030 PRINT:PRINT "The viscosities of pure, non-associating, liquids are estimated by the";CHR$(13);"method of J.W.Przezdzleeki and T.Sridhar published in the AIChEJ,"

8035 PRINT "Feb. 1985, p333. It Is the most accurate method and should be used";CHR$(13);"If possible."

8040 PRINT:PRINT "Data required for the estimate are the molecular weight, the critical";CHR$(13);"properties, the acentric factor, and at least one value of density at a";CHR$(13);"known temperature."

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 209

8050 PRINTrPRINT "This method gives estimates with an average error of 9%, and a maximum error of 40%, but results are very unreliable If used for associating IIqulds."

8060 PRINT:G0SUB 7070 8070 CLS

8080 PRINT'Tor associating liquids there Is really no reliable predictive method."

8090 PRINT:PRINT "The method used In this program is that of Stiel and Thodos, as descrI bed";CHR$(13);"In *The Properties of Gases and Liquids* by Reid and Sherwood, 2nd Ed., p437."

8100 PRINT:PRINT "Data required for the estimate are the molecular weight, the critical M ;CHR$(13);"propertIes, the acentric factor, and at least one value of density at a";CHR$(13);"known temperature."

8110 PRINTrPRINT "This method gives quite large errors (as much as -80%), usually on the Iow";CHR$(13);"sIde, for some associating liquids, but no other method is any more accurate."

8120 PRINTrGOSUB 7070 8130 CLS

8140 PRINT "Prediction of viscosities for liquid mixtures from pure component data !s";CHR$(13);"also rather unreliable."

8150 PRINTrPRINT "The method used In this program is procedure 8H from the AIChE *Data";CHR$(13);"Predict Ion Manual*. It is appropriate for systems where the mixtures have";CHR$(13);"viscosities Intermediate between those of the components."

8160 PRINTrPRINT "Data required for the estimate are either the viscosities of the components, or the data listed previously to allow them to be estimated. Liquid";

8170 PRINT "compositions may be entered In mol% or wt%, but in the latter case the";CHR$(13);"mo I ecu Iar weight Is also required."

8180 PRINTrPRINT "This method is not suitable for systems that have maxima or minima in the";CHR$(13);"mixture properties."

8190 GOSUB 7070 8200 RETURN

8210 REM Routine to bypass blurbs

8220 PRINT "This program includes explanatory text and

instruct Ions.";CHR$(13);"If you are familiar with the program, you can bypass these.";CHR$(13);"Do you want instructions displayed for this run, Y/N?"

8230 GOSUB 7030

8240 NB-(KA>2) *nb is flag Indicating No Blurbs 8250 RETURN

8260 REM Blurb for P&S method 8270 CLSrIF NB THEN 8450 8280 IF NM-2 THEN GOTO 8370

8290 PRINT "This calculation method gives quite accurate results for most"

8300 PRINT "non-associating compounds. Any errors tend to be on the low"

8310 PRINT "side, and the errors are more pronounced at lower temperatures," 8320 PRINT "reaching a maximum close to the freezing point."

8330 PRINT:PRINT "The only common organics that cannot be handled are a I coho Is,"

8340 PRINT "both aliphatic and aromatic. Cyclic and branched compounds ":PRINT"tend to give quite large errors, usually on the low side."

8350 PRINT "Organic acids seem to be predictable."

8360 GOTO 8440 8370 CLS

8380 PRINT "This calculation method gives reasonable results for many"

8390 PRINT "compounds. It works best at temperatures from"

8400 PRINT "the boiling point up, and the errors are more pronounced":PRINT "at lower temperatures."

8410 PRINT "Only use this method for associating compounds."

8420 PRINTrPRINT "For all other substances, the Przezdziecki and Srldhar"

8430 PRINT "method is better."

8440 GOSUB 7070 8450 RETURN

8460 REM Blurb for mixtures 8470 IF NB THEN 8530 8480 CLS

8490 PRINT "This section calculates the viscosity of liquid mixtures from the";CHR$(13);"viscosities of the pure components, for up to 10 components." 8500 PRINTrPRINT "If the pure component viscosities are not known, they will be estimated by";CHR$(13);"one of the methods available. Leaving the viscosity value as zero during"

8505 PRINT"data entry will automatically activate the estimating procedure." 8510 PRINTrPRINT "If there are only two components, a range of mixtures can be calculated";CHR$(13);"automatically - you will be prompted for the range if this option is chosen."

8520 GOSUB 7070

210 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

8530 RETURN

8540 REM Read data from file 8550 CLS

8560 PRINT"Checking disk for data..."

8570 GOSUB 8780:GOSUB 8670:GOSUB 8720

8580 IF N>LOF(1)/LF THEN 8650

8590 A(2,KS)-CVS(MF$):A(2.KS+1)«CVS(TF$)

8600 A(2,KS+2)-CVS(PF$):A(2,KS+3)=CVS(VF$)

8610 A(2.KS+4)«CVS(WF$):A(2.KS+5)=CVS(DF$)

8620 A(2,KS+6)«CVS(SF$):A(2.KS+7)»CVS(FF$)

8630 FOR J-1 TO 7:IF ABS(A(2.KS+J))<C3 THEN A(2,KS+J)=0 8640 NEXT 8650 RETURN

8660 REM Open file for crit data 8670 Y*LEFT$(YH,1)+"CRIT.DAT"

8680 OPEN"R",1,Y,128

8690 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$,4 AS VF$,4 AS WF$,4 AS DF$,4 AS SF$,4 AS FF$,60 AS XF$

8700 RETURN

8710 REM Find If name In record 8720 N-1 8730 GET 1,N

8740 J-LEN(YH):K-LEN(NF$):IF LEFT$(NF$,J)«YH THEN IF RIGHT$(NF$,K

J)«STRING$(K-J," M ) THEN 8760

8750 N-N+1: IF N<-LOF(1)/LF THEN 8730

8760 RETURN

8770 REM Convert name to caps 8780 YH-YB

8790 FOR J-1 TO LEN(YB)

8800 K-ASC(MID$(YB,J))

8810 IF K>96 AND K<123 THEN YL=CHR$(K-32):MID$(YH,J)-YL 8820 NEXT 8830 RETURN

8840 REM Write data to disk

8850 IF N<«LOF(1)/LF THEN LSET FF$«MKS$(A(2,KS+7)):GOTO 8920 8860 LSET NF$«YH

8870 LSET MF$*MKS$(A(2,KS)):LSET TF$-MKS$(A(2.KS+1))

8880 LSET PF$=MKS$(A(2,KS+2)):LSET VF$=MKS$(A(2,KS+3))

8890 LSET WF$-MKS$(A(2»KS+4)):LSET DF$-MKS$(A(2,KS+5))

8900 LSET SF$»MKS$(A(2,KS+6)):LSET FF$=MKS$(A(2,KS+7))

8910 LSET BF$«"

8920 PUT 1,N 8930 CLOSE 1 8940 RETURN

crItibm.bas

"Small-Scale Engineering Applications," by J. Nell Stone. July, page 253.

0 REM Predict critical properties - Apr 85 - CRITIBM.BAS. Version for BASICA

10 REM Rummens k Rajan, Can.J.Ch.E., Jun 1979, 349

20 REM Data Input screen concept by L.E.Sparks, ACCESS, 1982 p 10.

30 REM Edited for BYTE Dec 1985 40 GOTO 170

*****"

**"

CRITICAL PROPERTY PREDICTION by"

J.Neil Stone"

Ledge Engineering Inc"

179 Lansdowne Avenue" Kingsville, Ontario, N9Y 3J2"

50 DATA"*****

60 DATA"**

70 DATA"

80 DATA"

90 DATA"

100 DATA"

110 DATA"

120 DATA"

130 DATA" **** Apr 1985 ***♦"

140 CLS:FOR J-1 TO 9:READ Y:LOCATE NR/2-5+J,NS/2-17:PRINT Y:NEXT 150 GOSUB 6250:RETURN 160 REM Initialize 170 CLEAR 500

180 DEFINT J-L,N:DEFSTR R,X-Z

190 DIM Y,K,J,M,TD,Y%,LF,KA

200 ’POKE 16409,1 ’Set caps mode

210 ’NS-64:NR-16:LF«1 ’parameters for TRS80

220 NS-80:NR-24:LF-128 ’parameters for 80x24

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 21!

230 DEF FN LC(J ,K)-(J-1)*NS+K-1

3 S^“).S(2 , .l!)!Y(?2).P(2).Tll(a).F(1).V(2) *orroy.

260 REM Set up messog© *trlngs . , Y(5)+ . d c «:Y(3)-"Specific

CORRECT. PRESS <ENTER> WHEN DONE":ZA-STRING$(17, )

=32:CK-.10135:CL-760:CM-14.696:CN«1000:CP-273.16

330 ON ERROR GOTO 6130 340 GOTO 1500 * to main program

490 REM Screen routine - put titles In ££U 500 CLS:LOCATE 1.(NS-LEN(RA))/2):PRINT RA 510 PRINT STRING$(NS-1."-")

520 FOR J=KL TO KM

US IS SIl^N^KSc!) ZZ(J> TAB(NS-14) E(2.J):C0T0 570 SIS IF I J>3 T THeN ) PRINT ) TAB(NS-30) E(1.J) TAB(NS-14) «2.J) ELSE ORIOT

«? ISIte

“:Z4-".+

' :Z9“"USE <— TO

»660:CG».1:CH»1.8:CJ

660

590 LOCATE NR.- „

595 LOCATE NR-2.1:PRINT RB;

600 KQ«NS-17:KP*KL+1:J 9*3:GOTO 610 LOCATE KP+1.KQ+1:PRINT Z;

620 LOCATE NR-1.1 -.PRINT STRING$(NS-1,

625 LOCATE NR-1.1:PRINT Z8;

yWNKEYS-IF Y$*"" THEN 630

lllf~

rWAWl locate KP41 ,KQ4l .PRINT Z3::0N JO OOTO

690.680.710.680 670 RETURN

III KP-KP+J9:IF KP>KM+1 THEN KP-KL+1 ELSE IF KP<KL + 1 THEN KP-KM+1 700 GOTO 750

nl IF S=Ss-59 7 0r’kSnS-33 THEN KQ=KQ+16 ELSE KQ-NS-49 740 IF T KQ-n1-33 THEN KQ=NS-17 ELSE KQ=NS-33

i - “ ~

770 IF INSTR(RE.ZF) THEN KQ-NS-17 780 GOTO 610

in ;sSa?s'Sr:s:s«?'s?r.nc«ns-,.- ■>.

805 LOCATE NR-1.1:PRINT Z9;

III JoSfli'wtl.KOfl.PRINT ZA; :LOCATE KPtl .KQ4144.PRINT ZE;CHR$(95);

IZ ^!S(» P Y V «):o't«N N .S UR(Y$)>- ANO ASC(RIGHT$(Y$, 1 ))*75 THEN 900 ELSE 830

850 ON INSTR(Z5,Y$) GOTO 900.920 860 KC-KC+1

880 L0CATE V KP+1,KQ+1+KC+3:PRINT Y$;CHR$(95);

900 i? T Jc=0 0 THEN 830 ELSE KOKC-1:IF KC=0 THEN ZE="“ ELSE ZE=LEFT$(ZE.KC)

910 GOTO 820

920 KE*»(KQ-NS+49)/16

US lSStE P ^®SrINT ZA;.LOCATE KR.1 ,K0.H3:PRINT CSHG(VAL(ZE));

950 ZE»"":J9*1 _ ,

960 IF KQ=NS-17 THEN KP=KP+1 970 IF KP>KM+1 THEN KP=KL+1 980 GOTO 710 1490 REM Main program

212

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

1500 GOSUB 6500 1510 GOSUB 4610 1520 GOSUB 3000 1530 GOSUB 2000 1540 GOSUB 2500 1550 GOSUB 3500 1560 GOSUB 4500

* Introductory text

* get title etc ’get initial info ’Input data ’calculate critprops ’results on screen ’What next?

1570 ON NC GOTO 1590,1600,1610,1610 1580 CLS:ON ERROR GOTO 0:END

1590 GOSUB 4000:GOTO 1560 * to hardcopy routine 1600 GOSUB 5000:GOTO 1560 ’save to disk

1610 FOR J«1 TO 2:FOR K»1 TO 8:E(J,K)=0:NEXT K,J 'clean out input array 1620 ON NC-2 GOTO 1510,1520 1990 REM Data input 2000 CLS

2010 RA»"INPUT DATA FOR "+YA

2020 RB="DATA FOR SECOND VAPOUR PRESSURE POINT OPTIONAL"

2030 RD="2,3,7,"

2040 RE-"1, M 2050 J8-2

2060 KL«1:KM»8:0N JF GOTO 2080,2080,2090

2070 E( 2080 E( 2090 E(

■CK*CN:GOTO 2100 ■CL:GOTO 2100

1,4)-CM

2100 ZZ(1)®Y(1):ZZ(2)*STRING$(NS-36," ")+"VaIue"+STRING$(9,"

.- — f 4 W(5)+"

(7)-"

")+“Temperature":ZZ(3)«STRING$(43," ")+YT:ZZ(4

- Y(6)+ M "--“

“+YP+"/"+YT:ZZ(5)-Y(

"+YP:ZZ(6)-ZZ(5):ZZ(

2110 GOSUB 500 ’to screen entry 2120 M-E(2,1)

2130 N-4

2140 FOR J-0 TO 2

2150 ON JF GOTO 2170,2180,2190

2160 P(J)-E(1,J+N)/CN:T(J)-E(2,J+N)+CP:C»CN*CK:GOT0 2200 2170 P(J)-E(1,J+N)*CK/CL:T(J)-E(2,J+N)+CP:C»CL:GOTO 2200 2180 P(J)-E(l.J+N)*CK/CL:T(J)=(E(2,J+N)-CJ)/CH+CP:C-CL:G0T0 2200

2190 P(J)«E(1,J+N)*CK/CM:T(J)-(E(2,J+N)-CJ)/CH+CP:C-CM 2200 NEXT

2210 SG«E(1,8):D«SG*CN

2220 IF JF-2 OR JF-3 THEN T-(E(2,8)-CJ)/CH ELSE T-E(2,8) 2230 T(3)-T+CP 2240 RETURN

2490 REM Calculation 2500 CLS

2510 PRINT"CaIcuI at Ing"

2520 IF P(2)=0 THEN N-0 ELSE N-1

2530 IF P(0)=0 THEN GOSUB 2710 ELSE TB-T(0):TO-T(0)

2540 T1-C1*TD 2550 FOR J-0 TO 1 2560 TR(J)-T(N+J)/T1

2570 F(J)-C2/TR(J)+C3*LOG(TR(J))-C4-TR(J)"6

2580 NEXT

2590 DF-F(0)-F(1)

2600 AL-(L0G(P(N)/P(N+1))-C5*DF)/(L0G(T(N)/T(N+1))-C6*DF)

2610 PC«EXP(LOG(P(N))-C5*F(0)-AL*(LOG(TR(0))-C6*F(0)))

2620 VC-C7*T1/PC/(C8+C9*AL)

2630 V(1)-VC/(CA+CB*AL)

2640 TR(2)-T(3)/T1:V(2)-M*(CC-CD*TR(2)+CE*((1-TR(2))"(1/3)))/D 2650 T2-T1+CF*(V(1)-V(2))

2660 IF ABS(T2-T1)<-CG THEN 2680

2670 T1-T2:G0T0 2550 ’loop If not converged

2680 PB(0)-T1:PB(1)-PC:P8(2)=VC*CN:PB(3)-.2033*AL-1.1816

2690 RETURN

2700 REM Estimate bpt by Antoine 2710 B=LOG(P(1)/P(2))/(1/T(2)-1/T(1))

2720 A-LOG(P(1))+B/T(1)

2730 TO-B/(A-LOG(C))

2740 RETURN 2980 REM

2990 PEM Compound name

3000 INPUT"Name of compound":YA

3010 IF JF THEN 3130 * J f le unit flag

3020 PRINT:PRINT"WhIch unite are you using?"

3030 PRINT:PRINT"1) mmHg and deg C"

3040 PRINT"2) mmHg and deg F"

3050 PRINT"3) pel a and deg F"

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 213

July

3060 PRINT“4) kPa and dag C"

3070 NC-4:G0SUB 6070 3080 JF-NC:ON JF GOTO 3100,3110,3120 :GOTO 3130 :GOTO 3130 :GOTO 3130

):YT«Y(8)

3130 RETURN 3490 REM Display results on screen 3500 CLS

3510 YC-"CRITICAL PROPERTIES OF "+YA:J«(NS-LEN(YC))/2 3520 PRINT TAB(J);YC 3530 PRINT

3540 J«(NS-40)/2:K«(NS+30)/2

3090 YP-YI

;i2;

): YT-YI

J9)

3100 YP-YI

10

):YT-YI

9)

3110 YP-YI

10

I: YT-YI

8)

3120 YP-YI

:i i:

1:YT-YI

[8)

3550 PRINT TAB 3560 PRINT TAB

JV'C

0 M c

(K) USING Y1;PB(0) (K) USING Y3;PB(1)

’check if printer ready

Critical temperature, K:";:PRINT TAB(K)

. Critical pressure, MPa:";:PRINT TAB(k, _

3570 PRINT TAB(J+19)"atma: M ;:PRINT TAB(K) USING Y1;PB(1)/CK 3580 PRINT TAB(j)“Crit leal volume, cc/moI: M ;:PRINT TAB(K) USING Y1;PB(2) 3590 PRINT

3600 PRINT TABf JV'PI tzer acentric factor :";:PRINT TAB(K) USING Y2;PB(3) 3610 PRINT TAB(j)"Rledel critical parameter :“;:PRINT TAB(K) USING Y2;AL 3620 GOSUB 6030 3630 RETURN

3990 REM printer output 4000 CLS

4010 J«PEEK(14312) AND 240 4020 IF J-48 THEN 4060

4030 PRINT"PrInter not on line - press <ENTER> when ready"

4040 Y«INKEY$:IF Y*““ THEN 4040 4050 GOTO 4000 4060 IF LP THEN 4370

4070 PRINT"If you are going to calculate properties for several substances":PRINT"the results can be printed as a table."

4080 PRINT"Otherwise they will be printed with each set as a separate":PRINT"report."

4090 PRINT"Press <T> for tabulated results, <S> for separate reports":

4100 YR-"TtSs":GOSUB 6010 4110 LP-(KA<3)

4120 LPRINT TAB(10)"ProJect: ";YB;TAB(70);YD:LPRINT 4130 IF LP THEN 4270 4140 REM Single printout 4150 J»(80-LEN(YC))/2:LPRINT TAB(J);YC 4160 LPRINT

4170 LPRINT TABf18)"Cr11lea I temperature, K:";:LPRINT TAB(55 4180 LPRINT TAB(18)"Crltical pressure, MPa:";:LPRINT TAB(55 4190 LPRINT TABf37V'atma:";:LPRINT TAB(55) USING Y1;PB(1)/.10133 4200 LPRINT TAB(18)"Cr11lea I volume, cc/moI:";:LPRINT TAB(55) USING Y1;PB(2) 4210 LPRINT V ’

4220 LPRINT TAB(18)"Pitzer acentric factor :“;:LPRINT TAB(55) USING Y2;PB(3) 4230 LPRINT TAB(18)"R!edel critical parameter :";:LPRINT TAB(55) USING Y2:AL:GOTO 4240 V '

4240 LPRINT:LPRINT TAB(10)"These properties calculated using the method of Rummens and Rajan":LPRINT TAB(10)"with the following Input data:":LPRINT 4250 LPRINT TAB(18)"Moleculor weight";:LPRINT TAB(55) USING Y3;M 4260 IF P(0) THEN LPRINT TAB(18) Y(5)+" "+YT;:LPRINT TAB(55) USING Y1;E(2,4) 4270 LPRINT TAB(18) ZZ(5);:LPRINT TAB(45) USING Y2+" "+YP+" @"+Y1+"

“+YT;E(1,5),E(2,5)

4280 IF E(1,6) THEN LPRINT TAB(18) ZZ(6);:LPRINT TAB(45) USING Y2+" "+YP+" @"+Y1+" "+YT;E(1,6),E(2,6)

4290 LPRINT TAB(18)ZZ(8);:LPRINT TAB(45) USING Y2+" g/cc"+" @"+Y1+"

"+YT;E(1,8),E(2,8)

4300 LPRINT CHR$(12)

4310 GOTO 4380

4320 REM Tabular printout

4330 LPRINT TAB(10)"Name";TAB(50)"Cr111caI";TAB(70)”Acent rIc"

4340 LPRINT TAB(40)"TempTA8(50)"Pressure";TAB(62)"Vo Iume";TAB(70)"factor" 4350 LPRINT TAB(40)" K";TAB(49)"MPa atm";TAB(62)"cc/moI"

4360 LPRINT

4370 LPRINT TAB(10);YA;:LPRINT TAB(40) USING Y1;PB(0);:LPRINT TAB(47) USING Y3;PB(1);:LPRINT TAB(55) USING Y1;P8(1)/.10133;:LPRINT TAB(62) USING Y1;PB(2);:LPRINT TAB(70) USING Y2;PB(3)

4380 RETURN 4490 REM Menu 4500 CLS

4510 LOCATE 1,NS/2-3:PRINT "WHAT NEXT"

USING Y1;PB(0) USING Y3;PB(1;

214 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

I uly

4520 PRINTiPRINT TAB(10)"1) Hardcopy of results 11

4530 PRINT TAB(10)“2) Save critical properties to disk 11

4540 PRINT TAB(10)"3) New project 11

4550 PRINT TAB(10) 11 4) Calculate another material 11

4560 PRINT TAB(10)"5) End program 11

4570 NC-5:GOSUB 6070

4580 RETURN

4600 REM Project intro routine

4610 CLS:LP-0:JF=0:INPUT"Enter project title M ;YB

4620 YD*LEFT$(DATE$, 10) :PRINT"Project date (default * 11 ; YD; 11 ) 11 INPUT YD 4625 IF YD* 1111 THEN YD=LEFT$(DATE$, 10)

4630 RETURN

4990 REM Save critical data

5000 GOSUB 5240:GOSUB 5120:GOSUB 5170

5010 CLS:PRINT M Saving to file M ;Y

5020 IF N>L0F(1 )/LF THEN LSET XF$»STRING$(64, 11 M )

5030 LSET NF$-YH

5040 LSET MF$=MKS$(M):LSET BF$=MKS$(TB)

5050 LSET TF$=MKS$(PB(0)):LSET PF$«MKS$(PB(1)/.10133)

5060 LSET VF$=MKS$(PB(2)):LSET WF$=MKS$(PB(3))

5070 LSET DF$=MKS$(SG):LSET SF$=MKS$(T)

5080 PUT 1,N

5090 CLOSE 1

5100 GOSUB 6250:RETURN

5110 REM Open file for crit data

5120 Y-LEFT$(YH, 1) +"CRIT.DAT 11

5130 OPEN"R",1,Y,128

5140 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$,4 AS VF$,4 AS WF$,4 AS DF$,4 AS SF$,64 AS XF$

5150 RETURN

5160 REM Find if name in record 5170 N-1

5180 IF N>LOF(1)/LF THEN 5220 5190 GET 1,N

5200 J-LEN(YH):K-LEN(NF$):IF LEFT$(NF$,J)«YH THEN IF RIGHT$(NF$,K -J)«STRING$(K-J, 11 M ) THEN 5220 5210 N«N+1:G0T0 5180 5220 RETURN

5230 REM Convert name to caps 5240 YH-YA

5250 FOR J-1 TO LEN(YA)

5260 K-ASC(MID$(YA,J)) 5270 IF K>96 AND K<123 THEN YL=CHR$(K-32):MID$(YH,J)-YL

5280 NEXT

5290 RETURN

5990 REM Subroutines

6000 YR-"YyNn 11

6010 Y-INKEY$: IF Y- 1111 THEN 6010

6020 KA»INSTR(YR,Y): IF KA THEN PRINT 11 11 ;Y:RETURN ELSE 6010 6030 LOCATE NR-1.1:PRINT "PRESS ANY KEY TO CONTINUE";

6040 Y«INKEY$: IF Y- 1111 THEN 6040 6050 CLS 6060 RETURN

6070 PRINT:PRINT"Choose by number 11 ;

6080 Y«INKEY$: IF Y-" 11 THEN 6080 6090 Y%-VAL(Y)

6100 IF Y%<1 OR Y%>NC THEN 6080 6110 PRINT Y:NC«Y%

6120 RETURN 6130 CLS

6140 IF ERR-5 THEN 6160

6150 PRINT"Error in line";ERL:ON ERROR GOTO 0:RESUME 6160 PRINT"Math error has occurred in line";ERL

6170 PRINT"Program will return to data entry to allow you to re-enter your input data."

6180 PRINT"Look for very low or very high, zero or negative values of "’.PRINT 11 Input data."

6190 PRINT"Check that input data units are correct, and that all values arewithin the range of the correlation."

6200 GOSUB 6030: RESUME 1530 6240 REM Delay

6250 FOR J-1 TO 4000:NEXT:RETURN 6490 REM Opening text 6500 CLS

6510 PRINT"This program calculates the critical properties and acentric":PRINT"factors for many compounds.":PRINT

[miimed)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 215

July

6600 PRINT"It Is based on the correlation by Rummens and Rajan,

published":PRINT"In the Can.J.Ch.E., Jun 1979, (Vol 57, No.3), page 349."

6610 PRINT:PRINT"Input data required are the molecular weight, the vapor"

6620 PRINT"pres8ure at any two temperatures, and the density at

any":PRINT"temperature."

6630 PRINT:PRINT"One of the vapor pressure points may be the normal

bolIIng":PRINT"polnt, although the authors recommend against this,

and":PRINT"suggest two other points 40 to 60 K apart will give best results"

6640 GOSUB 6030

6650 RETURN

ascstr.asm

"Structural Analysis." by Robert W. Johnson and Fernando G. LoygorrI. July, page 199.

TITLE ASCSTR - FUNCTION TO DETERMINE ASCII CODE PAGE ,132

; (C) Copyright Microstress Corporation 1984, 1985, 1986

COMMENT *

ASCSTR is a routine designed to be called from FORTRAN as a function to return the ASCII code of the character specified by the input.

Mode of use: where

code * ASCSTR (I,string)

*

code « value returned by the function, the requested ASCII code. I ■ Index to specify the location in the string of the character whose ASCII code is requested.

string - name of the string (variable of type CHARACTER) where the requested character is located.

SUBTTL FORMAL DECLARATIONS PAGE

csascs SEGMENT 'CODE*

ASSUME CS:csascs

SUBTTL ASCSTR - EXECUTABLE CODE PAGE

PUBLIC ascstr ascstr PROC FAR

PUSH BP

MOV BP,SP

PUSH ds

LDS BX,DWORD PTR [BP+10]

MOV CX,[BX]

; Check positive request, cmp cx,0

jle outbounds

; Locate the end of the string (logical or physical) LDS BX,DWORD PTR [BP+6]

scanend:

mov a I,[bx]

cmp a I,0

Je outbounds

cmp a I,6

je outbounds

inc bx

loop scanend

; Value is returned In AX.

XOR AH,AH

jmp exit

; Handle a request out of bounds, outbounds:

xor ax.ax

exit:

POP ds

216 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

I uly

MOV

SP.BP

POP

BP

RET

8h

ascstr

ENDP

csascs

ENDS

Table captionEND

test.seq

"Analog Circuit Analysis," by David McNeill.

July, page 170. See ac.prg for detaiIs.Commodore 64

%14

* TEST CIRCUIT

*

* FILE NAME IS TEST

*

R1 1 2 10K

R2 2 3 40K

R3 4 3 4K

Cl 2 3 100PF

VIN 1 0 -2 DC 1 0 AC

VCC 4 0 20 DC

Q1 3 2 0 1

.MODEL 1 NPN BF-50 BR-1 IS-1E-14 VA=100 CJE-2PF CJC-4PF .OUT 4 V(3) V(3)/(VIN) ZIN(VIN) Z0UT(3)

.END

testdc.seq

"Analog Circuit Analysis," by David McNeill. July, page 170. See ac.prg for details.

7 .

0 .

0 .

V(3)/(VIN)

6 ,

0 .

0 .

ZIN(VIN),

R1,

0 .

0 .

Z0UT(3),

R2,

3 .

.02 .

1 .

R3,

-2 .

1 .

2 .

Cl.

1 .

.01 .

3 .

VIN,

0 ,

IE-14 ,

4 .

VCC.

5 .

1 .

0 .

Q1»

1 .

1 .

0 .

1 .

0 .

2E-12 .

10000 ,

3 ,

4E-12 ,

1 .

20 .

6E-10 .

2 .

4 .

6E-09 .

0 .

0 .

1 ,

0 ,

6 .

1 .

0 •

0 .

1.0.0.

1 .

0 .

4 .

40000 ,

5 .

-5 .

2 .

3 .

3 .

3 .

2 ,

0 .

0 .

0 .

0 .

0 .

1 .

5 .

0 .

0 .

0 .

1 .

1 .

3 .

4000 ,

1 .

0 .

4 ,

0 .

-2 .

3 .

0 .

5 .

0 .

0 .

0 .

0 ,

0 ,

0 .

0 ,

0 .

-1 .

10 .

0 .

3 .

IE-10 ,

0 .

0 .

2 ,

0 .

0 .

3 .

0 .

V(3).

Table captionBYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 217

truss2.bas

"Engineering on o Micro." Chris Pedicinl. July, poge 145.

PROGRAM - TRUSS2: VERSION 1.0: COPYRIGHT 1984 - C.S. PEDICINI

DIM XNOD(100),YNOD(100).NCON(100,2).AR(100)

DIM A(200.25),B(200),STR(100)

DIM XXYY(4),BK(4,4)

DIM EKEY(5),NUM(10,10),NDIG(6),MARKER(10),ID(3,7),NMK(6) DIM IL0AD(100,2),RLOAD(100),MENUS(4,7),PRNT$(5) ^

’ DATA FOR GRAPHICS

10 20 30

40 ON ERROR GOTO 22000 50 DEFINT I-N 60 GOSUB 20000 70 •

80 ‘ DIMENSION VARIABLES 90 100 110 120 130 140 150 160 170

180 DATA 6.6.12288.18504.12360 190 DATA 6,6.8192,8224.8224 200 DATA 6,6.12288,4168.30752 210 DATA 6.6,30720,14344,30728 220 DATA 6,6,18432.30792,2056 230 DATA 6,6,30720.30784,30728 240 DATA 6,6,30720,30784,30792 250 DATA 6,6,30720,2120.2056 260 DATA 6,6,12288,12360.12360 270 DATA 6.6.30720.30792,30728 280 *

290 DATA 9,9,0.48.48,252.48,48,0.0 295 DATA 7.7.14336.-258,14590.0,0 300 '

310 * DATA FOR SPREADSHEET EDITOR 320 ’

330 DATA 1.8,10,10,10,20 340 DATA 1.8.6,6,6.18 350 DATA 1,8,1,1,10,18 360 *

370 DATA "MAIN MENU","DATA EDITOR"."GRAPHICS"."PRINT DATA" "ANALYSIS/RESULTS", "GET/SAVE/DELETE"."QUIT"

380 DATA "FEM DATA EDITOR"."EDIT NODES","EDIT ELEMENTS"."EDIT LOADS"

"FIND BANDWIDTH","CONTROL CARDS",""

390 DATA "GRAPHICS","ORIGINAL GEOMETRY"."FINAL GEOMETRY","STRESS PLOT”,

"DELETE" "m E Ih S hY E/DELETE,,,,,GET DATA “ FEM MODEL", "SAVE DATA. FEM MODEL", 420 *

430 • READ DATA 440 *

450 FOR 1-1 TO 10: FOR J=0 TO 4: READ NUM(I,J): NEXT J: NEXT I 460 FOR 1=0 TO 9: READ MARKER(I): NEXT I

465 FOR 1-0 TO 6: READ NMK(I): NEXT I

470 FOR K=1 TO 3: FOR J=1 TO 6: READ ID(K,J) : NEXT J: NEXT K

480 FOR 1-1 TO 4: FOR J-1 TO 7: READ MENU$(I,J): NEXT J: NEXT I

485 FOR 1-1 TO 5: PRNT$(I)»"Y": NEXT I

490 •

500 * INITIALIZE VARIABLES 510 *

520 BLANK$="

530 FKEY$»" ESC = RETURN TO MENU, FI = DELETE LINE. "+CHR$(27)+CHR$(24)+CHR$(25) +CHR$(26)+" POSITION CURSOR"

540 MAXNP-100: MAXEL-100: MAXLD-100: MBW-30 DV$«"A:": DAT1$*DATE$: EXAG-1 EKEY(1)«30000000#: EKEY(2)=30000 IERR-0: NLOAD-0: NUMNP-0: NUMEL-0 FOR 1-1 TO MAXEL AR(I)«1I NEXT I

550

560

570

572

574

576

580

590

600

MAIN MENU

218

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

610 IMENU-1: GOSUB 25000: IOPT-ISEL 620 IF IRETO0 THEN GOTO 610

630 ON IOPT GOSUB 650,3460,31000,10000,5610.24010

640 GOTO 610

650 '

660 ’ DATA EDITOR MENU 670 •

680 IMENU-2: GOSUB 25000: IOPT2-ISEL

690 IF IRETO0 THEN RETURN

700 ON IOPT2 GOSUB 730,780,830,880,3070

710 GOTO 680

720 1

730 • EDIT NODES 740 1

750 NCUR-NUMNP: NLMT-MAXNP: K-1: GOSUB 950 760 NUMNP-NCUR: ID(K,1)«NFRST: RETURN 770 •

780 • EDIT ELEMENTS 790 *

800 NCUR-NUMEL: NLMT-MAXEL: K-2: GOSUB 950 810 NUMEL-NCUR: ID(K,1)«NFRST: RETURN 820 '

830 * EDIT LOADS 840 *

850 NCUR-NLOAD: NLMT-MAXLD: K-3: GOSUB 950 860 NLOAD-NCUR: ID(K,1)«NFRST: RETURN 870 '

880 # CALCULATE BANDWIDTH 890 ’

900 CLS

910 GOSUB 30000

920 LOCATE 12,30: PRINT USING "MAX BANDWIDTH * ###";BW

930 LOCATE 16,27: PRINT "PRESS ANY KEY TO CONTINUE"

940 A1$«INKEY$: IF A1$-"" THEN 940 ELSE RETURN 950 •

960 ’ ** FULL SCREEN EDITOR **

970 ’

980

990

1000

1010

1020

1030

1040

1050

LOCATE 24,15

1060 GOSUB 2840 1070 *

1080 * ** SPREADSHEET CONTROL INPUT **

1090 '

1100 A1$-INKEY$ : IF A1$«"" THEN GOTO 1100 1110 IF ASC(A1$)«27 THEN RETURN

1120 IF LEN(A1$)-2 THEN A2«ASC(RIGHT$(A1$,1)): GOSUB 1150 ELSE GOSUB 1330 1130 GOTO 1050 1140 •

1150 •** CURSOR KEYS **

1160 •

1170 IF A2-59 THEN GOSUB 1880: RETURN

1180 IF A2-80 OR A2-72 THEN GOSUB 2390: RETURN

1190 IF A2«77 AND NCOL<MXCOL THEN GOSUB 2950: NCOL-NCOL+NLEN: RETURN

ELSE IF A2-77 THEN RETURN

1200 IF A2-75 AND NCOL>MNCOL THEN GOSUB 2950: NCOL-NCOL-NLEN: RETURN ELSE IF A2-75 THEN RETURN 1210 •

1220 ’** PgUp..PgDn..Home..End **

1230 *

1240 IF A2-81 AND NFRST<«NCUR-15 THEN NFRST-NFRST+15 ELSE IF A2-81 THEN NFRST-NCUR

1250 IF A2-73 AND NFRST>15 THEN NFRST-NFRST-15 ELSE IF A2-73 THEN NFRST-1

1260 IF A2-71 THEN NFRST-1: 'HOME

1270 IF A2-79 THEN NFRST-NCUR: 'END

1280 IF A2-81 OR A2-73 OR A2-71 OR A2-79 THEN GOSUB 2950: COLOR 7,0:

GOSUB 2140: RETURN 1290 ' INPUT ERROR

1300 MSG$«"INVALID KEY ENTRY":SCREEN 0.0.1,1

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 219

GET NUMERIC VALUE

1310 GOSUB 26000: SCREEN 0.0,0,0: LOCATE 24,1: PRINT BLANK$;: LOCATE 24,4 PRINT "COMMAND = :RETURN

1320 '

1330 ' ** ALTER NUMERIC VALUE **

1340 *

1350 1360 1370 1380 1390 1400 1410 1420 1430

X-24: Y-15: GOSUB 21090 IF IERR-1 THEN RETURN NR-NFRST+NROW-8 IF NR>NLMT THEN RETURN ON K GOSUB 1450.1490,1530

IF NR>NCUR THEN NCUR-NCUR+1: LOCATE 3,53: PRINT USING "###"-NCUR LOCATE NROW.1: I-NR: GOSUB 2640

IF NR-NCUR AND NROW<21 THEN I-NCUR+1: LOCATE NROW+1,1: GOSUB 2640 IF NCOL<MXCOL THEN GOSUB 2970: NCOL-NCOL+NLEN: RETURN ELSE IF NROW<-21 THEN GOSUB 2970: NCOL-MNCOL:

NROW-NROW+1:RETURN 1440 RETURN

1450 * VALUE ALTERATION NODES 1460 NC- INT(NCOL/10)+1

1470 IF NC-2 THEN XNOD(NR)-VALNEW: ELSE IF NC-3 THEN YNOD(NR)-VALNEW 1480 RETURN V '

1490 • VALUE ALTERATION ELEMENTS 1500 NC- INT(NC0L/6)+1

1510 IF NC-2 THEN NCON(NR,1)-VALNEW: ELSE IF NC-3 THEN NC0N(NR,2)-VALNEWELSE IF NC-4 THEN AR(NR)-VALNEW 1520 RETURN

1530 ’ LOAD VALUE ALTERARION 1540 NC- INT(NC0L/9)+1

1550 IF NC-1 THEN ILOAD(NR,1)-VALNEW: ELSE IF NC-2 THEN ILOAD(NR,2)-VALNEWELSE IF NC-3 THEN RLOAD(NR)-VALNEW 1560 RETURN 1570 *

1580 * PAGE HEADERS 1590 1

1600 CLS: LOCATE 25,5: PRINT FKEY$;

1610 LOCATE 1,(80-LEN(TITLE$))/2: PRINT TITLE$

1620 LOCATE 2.2:PRINT USING "PAGE = ##";PAGE

1630 IF K-1 THEN A1$-"NODE" ELSE IF K-2 THEN A1$-"ELEMENT" ELSE IF K-3

THEN A1$-"LOAD"

1640 A1$-A1$+" EDITOR"

1650 LOCATE 2.(80-LEN(A1$)-8)/2: PRINT "... ";A1$;" ...»: LOCATE 2,70: PRINT DAT1$

1660 LOCATE 3,25: PRINT USING "CURRENT NUMBER OF ENTRIES - ###":NCUR 1670 ON K GOSUB 1690,1710.1750 1680 RETURN

1690 •** HEADER FOR NODES **

1700 PRINT : PRINT: PRINT " NODE 1710 •** HEADER FOR ELEMENTS **

1720 PRINT

1730 PRINT " ELEM NODE NODE SECTION"

1740 PRINT "NO. I J AREA": RETURN

1750 ’** HEADER FOR LOAD EDITING **

1760 PRINT:PRINT: PRINT " NODE I-CODE ICOL-40

LOCATE 8.IC0L: FOR I-ICOL TO 75: PRINT LOCATE 10,ICOL:PRINT "** I-CODE LOCATE 12,ICOL:PRINT LOCATE 13.ICOL:PRINT

1770

1780

1800

1810

1820

1830

1840

1850

1860

1870

1880

1890

1900

1910

1920

X-COORD Y-COORD " : RETURN

LOAD VALUE"

LOCATE 14,ICOL:PRINT "** LOCATE 15,ICOL:PRINT "**

LOCATE 17,ICOL: RETURN

l

’ DELETE A LINE

NEXT I

MEANING **"

0 FORCE IN X DIRECTION **"

1 FORCE IN Y DIRECTION **"

2 FIXITY IN X DIRECTION *“

3 FIXITY IN Y DIRECTION *"

FOR I-ICOL TO 75: PRINT

NEXT I

LOCATE 24,1 : PRINT "TO DELETE THIS LINE PRESS. Y IN$-INKEY$ : IF IN$-"" THEN 1910

IF IN$-"Y" OR IN$-"y" THEN GOSUB 2950: GOTO 1930 ELSE RETURN 1930 LOCATE 24,1 : PRINT BLANK$; : LOCATE 24,1 : PRINT "DELETION BEGINNING 1940 IF NFRST+NR0W-8>NCUR THEN RETURN 1950 FOR I-NFRST+NR0W-8 TO NCUR

1960 IF I-NLMT THEN 2080

1970 ON K GOTO 1980.2010,2040

1980 * DELETE NODAL VALUES 1990 XNOD(I)-XNOD(1+1): YNOD(I)-YNOD(I+1)

2000 GOTO 2080

2010 • DELETE ELEMENT VALUES

220 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

July

2020 AR(I)=AR(I+1): NCON(I.1)-NC0N(I+1.1): NCON(I,2)-NC0N(I+1.2)

2030 GOTO 2080

2040 ‘ BEGIN MODULE DELETE CURRENT LINE 2050 ILOAD(I,1)-ILOAD(I+1,1)

2060 ILOADfl,2)-ILOAD(I+1,2)

2070 RLOAD(I)- RLOAD(I+l)

2080 NEXT I

2100 COLOR^©: 1 LOCATE 3,53: PRINT USING "###";NCUR 2110 GOSUB 2140 2120 RETURN 2130 *

2140 * FULL DATA LIST

2160 DEF SEG -4HB800: FOR 1-1120 TO 3360 STEP 160: FOR J-0 TO (MXCOL+NLEN)*2

STEP 2: POKE I+J.0: NEXT J: NEXT I: DEF SEG

2170 LOCATE 8,1: NROW-8: IF NCUR<14 THEN NFRST-1

2180 ON K GOSUB 2200.2260.2330

2190 RETURN

2200 ’ ** NODE POINTS **

2220 F IF I>NCUR+1 T OR N I>NLMT THEN 2240 ELSE IF I-NCUR+1 THEN

2230 T US WNT US?NG « "### ^^“^PRINT USING - ###•####": XNOD(I) .YNOD(I)

2240 NEXT I

2250 RETURN

2260 * ** ELEMENTS **

2280 F IF I>NCUR+1 T 0R NF >NLMT 4 THEN 2310 ELSE IF I-NCUR+1 THEN

S T US m N ; ‘iiP^^C.D.NCONO.M,

2300 PRINT USING n ###.##“;AR(I)

2310 NEXT I 2320 RETURN 2330 * ** LOADS **

2340 FOR I-NFRST TO NFRST+14

2350 IF I>NCUR+1 OR I>NLMT THEN 2370

2360 PRINT USING 11 ### ";ILOAD (1,1),ILOAD(1,2);:

PRINT USING "######•###"; RLOAD(I)

2370 NEXT I 2380 RETURN 2390 2400 2410 2420 2430 2440 2450 2460 2470 2480 2490 2500

> HANDLE UP/DOWN SCROLLING...AND MOVING CURSOR *

IF A2-80 THEN 2530

• SCROLL DOWN

IF NR0W>8 THEN GOSUB 2940: NROW-NROW-1: RETURN IF NROW-8 AND NFRST-1 THEN RETURN ELSE NFRST-NFRST-1

»

• SCROLL DOWN START AT 8 GOTO 23 ADD A LINE

FOR 1*3200 TO 1120 STEP -160: FOR J=0 TO (MXCOL+NLEN)*2 STEP 2: I1*PEEK(I+J): POKE I+J+160,I1: NEXT J: NEXT I 2510 DEF SEG

LOCATE 8.1: I-NFRST: GOSUB 2640: RETURN SCROLL UP

IF NFRST+NR0W-8-NCUR+1 THEN RETURN IF NROW<22 THEN GOSUB 2940: NROW-NROW+1: RETURN NFRST-NFRST+1

2520

2530

2540

2550

2560

2570

2580

2590

2600

2610

SCROLL UP START AT 8 GOTO 14 ADD A LINE

FOR 1-1280 TO 3360 STEP 160: FOR J-0 TO (MXC0L+NLEN)*2 STEP 2: I1-PEEK(I+J): POKE I+J-160,11: NEXT J: NEXT I 2620 DEF SEG

LOCATE 22,1: I-NFRST+14: GOSUB 2640: RETURN

2630 2640 2650 2660 2670 2680 2690 RETURN

• LIST 1 LINE OF DATA AT .I.

i

ON K GOSUB 2680.2720.2770: RETURN

• ** EDIT NODES **

IF I-NCUR+1 THEN PRINT USING H

M

"Si:

[continued]

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 221

I uly

M M;s PRINT USING - ###.####'*;

2720

2730

2740

2750

2760

2770

2780

2700 PRINT USING

XNOD(I),YNOD(I)

2710 RETURN

** EDIT ELEMENTS **

IF I-NCUR+1 THEN PRINT USING “ ###

PRINT USING " m "11,NCON(1,1),NCON(I,2);

RETURN 1 ” USING ** EDIT LOADS **

PRINT USING " §§§ ILOAD (1,1),ILOADfI 2) ••

PRINT USING "######.###"' RLOAD I) U.1).ILOAO(I,2)..

2790 RETURN 2800 •

2®’® ! HIGHLIGHT AN AREA ON THE SCREEN AT CURRENT

2®2® , CURSOR LOCATION (NROW.NCOL) LENGTH -NLEN

2830

2840 COLOR 0,7 2850 F$-""

2860 FOR L-1 TO NLEN

2870 LOCATE NROW.NCOL+L

2880 C$-CHR$(SCREEN(NROW.NCOL+L))

2890 PRINT C$

2900 NEXT L 2910 COLOR 7,0 2920 RETURN 2930 ’

2940 ’ REMOVE HIGHLIGHT ON THE SCREEN AT CURRENT

2950 * CURSOR LOCATION (NROW.NCOL) LNEGTH-NLEN

2960 •

2970 COLOR 7.0 2980 F$»""

2990 FOR L-1 TO NLEN

3000 LOCATE NROW,NCOL+L

3010 C$=CHR$(SCREEN(NROW,NCOL+L))

3020 PRINT C$

3030 NEXT L 3040 COLOR 0,7 3050 RETURN 3060 •

CONTROL CARDS

"; I: RETURN

X-3: Y-8

CLS: LOCATE 1,25: PRINT "TRUSS CONTROL VARIABLES"

i'Ar*rl lf’f : noJKI " USE UP / D0WN ARROWS TO POSITION CURSOR AND ENTER " 16,5: PRINT Y0UR VALUE - USE RETURN KEY TO TERMINATE THE ENTRY" LOCATE 18,5: PRINT " <Esc> RETURNS TO MENU"

PRINT "TITLE: ";TITLE$

3070 3080 3090 3100 3110 3120 3130 3140 3150 3160 3170 3180 3190 3200 3210 3220 3230 3240

GOTO 3270 ELSE GOTO 3210

LOCATE 3.1: LOCATE 5.1: LOCATE 7,1: LOCATE 9,1:

* TRAP KEYS »

LOCATE X, Y,1 A1$*INKEY$:

PRINT

PRINT

PRINT

"DATE : ";DAT1$

"ELASTIC MODULUS (PSI) : ";EKEY(1) "DESIGN STRENGTH (PSI) : ";EKEY(2)

rr tu? ii^ IF o A ^u"Jt! EN 3220 ELSE IF ASC(A1$)»27 THEN 3400 IF LEN(A1$)<>2 THEN GOTO 3300

if A1 “ 72 then goto 3250 ELSEIF A1=80 then

3250

3260

3270

3280

3290

3300

3310

3320

3330

3340

3350

3360

3370

3380

3390

3400

3410

3420

3430

IF X>7 THEN GOTO 3210 IF X>«5 AND GOTO 3210

X=CSRLIN-2: Y«26: ELSE IF X<*7 AND X>3 THEN X=CSRLIN-2: Y=8 X<9 THEN X-CSRLIN+2: Y«26: ELSE IF X«3 THEN X=5: Y=8

VALUE ENTERED

IF ASC(A1$)<»32 OR ASC(A1$)>127 THEN GOTO 3140 PRINT A1$; :X«CSRLIN

THEN LINE INp UT;TITLE$ :TITLE$»A1$+TITLE$

IF CSRLIN-5 THEN LINE INPUT;DAT1$ IF CSRLIN-7 THEN LINE INPUT;A2$

IF CSRLIN-9 THEN LINE INPUT;A2$

IF X<»5 THEN Y*8 ELSE Y-26 GOTO 3140

•

CHECK VALIDITY OF ENTRIES

DAT1$-A1$+DAT1$ :EKEY(l)-VAL(A1$+A2$) :EKEY(2)-VAL(A1$+A2$)

IF EKEY(1)<1 OR EKEY(2)<1 THEN MSG$-"INVALID PROPERTIES":

222 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

GOSUB 26000 :GOTO 3100

3440 IF LEN(DAT1$)<>10 THEN MSG$*"INVALID DATE SPECIFICATION": GOTO 3100

GOSUB 26000

3450

3460

3470

3480

3490

3500

3510

3520

3530

3540

3550

3555

3560

3563

3565

3567

3568 3570 3575 3580 3585 3590 3600 3610 3620

RETURN

GRAPHICS

IMENU=3: GOSUB 25000: I0PT3-ISEL IF IRETO0 THEN RETURN GOSUB 3540 GOTO 3490

GRAPH MESH

IF I0PT3*1 THEN EXAG=0: GOTO 3570 CLS• LOCATE 5 1

PRINT " ENTER AN EXAGGERATION RATIO FOR THE NODE DEFLECTIONS" PRINT " IF YOU ENTER A ONE THEN STRUCTURE DISTORTION WILL BE PRINT " TO SCALE..."; ‘.INPUT EX AG IF EXAG<0 THEN EXAG-0 CLS: LOCATE 12.30: PRINT "THINKING"

DETERMINE MAX/MIN

XMIN-XNOD(l)+EXAG*B(1): YMIN=YNOD(1)-EXAG*B(2): XMAX-XMIN: YMAX-YMIN

F ?F IOPT3*1 N THEN DXI®0: DYI*0 ELSE DXI«EXAG*B(I*2-1): DYI-+EXAG*B(1*2) IF XMIN>XNOD(I)+DXI THEN XMIN«XNOD(I)+DXI ELSE IF XMAX<XNOD(I)+DXI

3630 IF YMIN>YNOD(I)+DYI THEN YMIN*YNOD(I)+DYI ELSE IF YMAX<YNOD(I)+DYI THEN YMAX«YNOD(I)+DYI

3650 IF E XMIN«XMAX OR YMIN-YMAX THEN MSG$*"NODAL COORDINATE ERROR":

GOSUB 26000: RETURN 3652 *

FIND MAXIMUM SCALE AND ALTER MAX/MIN TO FIT

3654

3656

3660

3670

3675

3677

3679

3680

3681 3690 3700 3710 3720 3730 3750

S1*210/(XMAX-XMIN): S2-180/(YMAX-YMIN)

IF S1>S2 THEN SM1-S2 ELSE SM1-S1

DEL«.5*(210/SM1-XMAX+XMIN): XMAX-XMAX+DEL: XMIN=XMIN-DEL DEL* .5*(180/SM1 -YMAX+YM IN): YMAX-YMAX+DEL: YMIN-YMIN-DEL

PLOT FROM (200,10)-(620,190)

PX*(XMAX-XMIN)/420 py«(YMAX-YMIN)/180 SCREEN 2 :CLS FOR 11-1 TO NUMEL I-NCON(I1,1): J-NCON(I1,2)

IF IOPT3-1 THEN DXI-0: DYI-0: DXJ-0: DYJ-0 ELSE

DXI-EXAG*B(I*2-1):DYI«+EXAG*B(I*2): DXJ-EXAG*B(J*2-1):DYJ-+EXAG*B(J*2)

3770

3775

3780

3782

3784

3786

3788

3790

3792

3794

3796

3798

3800

3802

3804

IX-INT(200+(XNOD(Ij+DXI-XMIN)/PXj IY-INT(190-(YNOD(I)+DYI-YMIN)/PY)

JX*INT(200+(XNOD(JHDXJ-XMIN)/PX)

JY-INT(190-(YNOD(J)+DYJ-YMIN)/PY)

DETERMINE IF PTS IN WINDOW

JCASE-0

IF IX>620 OR IX<200 OR IY>190 OR IY<10 THEN JCASE*1 IF JX>620 OR JX<200 OR JY>190 OR JY<10 THEN JCASE-JCASE+2

ON JCASE GOTO 3814,3814,3868 LINE (IX,IY)-(JX,JY)

PUT (IX-3,IY-3),NMK,OR: PUT (JX-3,JY-3),NMK,OR IF I0PT3-3 AND ABS(STRf11))>-EKEY(2) THEN

>5004 ir iurio-o /mnu ado i r\v jl i j

LINE ((IX+JX)/2-4.(IY+JY)/2-2)-((IX+JX)/2+4.(IY+JY)/2+2).1.BF

3806

3808

3810

3812

3814

3816

GOTO 3868

ONE POINT IN.. MAKE IT (IX.IY) OTHER IS (JX.JY)

IF JCASE-1 THEN KX-IX: KY-IY: IX-JX: IY-JY: JX-KX: JY-KY IF IX-JX AND JY>190 THEN JY-190: GOTO 3860 ELSE IF IX-JX THEN JY-10: GOTO 3860

3818 SLOPE-(JY-IY)/(JX-IX): BINT-JY-SLOPE*JX 3820 ’

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 223

3822 IF SLOPE-0 AND JX>620 THEN JX-620: GOTO 3860 ELSE IF SLOPE-0 THEN JX-200: GOTO 3860 3824 *

3826 KY-SLOPE*200+BINT

3828 IF KY>-10 AND KY<-190 AND SLOPE>0 AND KY>JY THEN JX-200

SSI?00? 6 Sy-K?: SmSSl ^ KY< " 190 AN ° SL ° PE<0 AN ° KY<JY THEN

3830 KY-SLOPE*620+BINT

iQ/jA AN ° KY< “ 190 AND SLOPE>0 AND KY<JY THEN JX-620:

Jxle20: JY-KY- GOTO 3860 ^ KY< " 19 ® AND SLOPE<0 AND KY>JY THEN 3834 ’’

3836 KX-(190-BINT)/SLOPE

3838 IF KX>-200 AND KX<-620 AND SLOPE>0 AND KX<JX THEN JX=KX

sx.fs.js? zffssr * ««»*> ««- s?«2s

3840 KX«(10-BINT)/SLOPE

3842 IF KX>-200 AND KX<=620 AND SLOPE>0 AND KX>JX THEN JX-KX

2™*5 ik SE rATA K T«R« 00 AND KX< “ 620 AN0 SLOPE<0 AND KX<JX THEN JX-KX: JY-10: GOTO 3860

3844 *

3860 LINE (IX.IY)-(JX.JY)

3862 PUT (IX-3,IY-3),NMK.OR

3868 NEXT II 3870 *

GRAPHICS MENU

3880

3890

3900

3904

3906

3908

3910

3914

3916

3918

LOCATE 1,1,1: SOUND 300,3: PRINT "SELECTION - "

LOCATE 10,2: PRINT "1..NUMBER NODES"

LOCATE 12,2: PRINT "2..NUMBER ELEMENTS"

LOCATE 14,2: PRINT "3..ZOOM"

LOCATE 16,2: PRINT "<Esc>..NEXT MENU"

X-1: Y-12: GOSUB 21010: IF IERR-1 THEN SCREEN 0: RETURN IF VALNEW<1 OR VALNEW>4 THEN GOTO 3900 ELSE GOPT-VALNEW LOCATE 1.1: PRINT " THINKING "

3920 XX-EXAG

3930 ON GOPT GOSUB 3970.4050,4500 3940 IF GOPT-3 THEN GOTO 3660 ELSE GOTO 3900 3950 RETURN 3960 *

3970 * NUMBER NODES 3980 ’

3990 FOR 1-1 TO NUMNP

4000 SX-200+(XNOD(I)-XMIN+XX*B(2*I-1))/PXSY-190-(YNOD(I)-YMIN+XX*B(2*I))/PY 4010 GOSUB 4170 4020 NEXT I 4030 RETURN 4040 *

4050 * NUMBER ELEMENTS 4060 ’

4070 FOR 1-1 TO NUMEL 4080 II-NCONfI,1); JJ-NC0N(I,2)

4090 XCOORD=(XNOD(II)+XNOD(JJ)+XX*(B(2*II-1)+B(2*JJ-1 )))*

4 00 YCOORD-(YNOD(II)+YNOD(J J)+XX*(B(2*11)+B(2*JJ)))*. 5

4120 GOSUB 0 417 COORD_XM ^ N ^ PX: SYa190 “(YCOORD-YMIN)/PY 4130 NEXT I 4140 RETURN 4150 '

4160 ; PUT A VALUE OF "I" AT (SX.SY) ON GRAPHICS SCREEN

4190 FDIG=INT(I/100) >620 ^ ^ SY>19 ® ™ EN RETURN

4200 SDIG-INT((I-FDIG*100)/10)

4210 TDIG»INT(I-FDIG*100-SDIG*10)

4220 IF FDIG<»0 THEN 4270 4230 FOR II-0 TO 9

tltl J”?! 0 -" THEN F0R j! * 0 T0 5: NDIG(J)-NUM(FDIG+1,J): NEXT J

till PUT(SX-7,SY).NOIG.PSET

4270 IF FDIG<-0 AND SDIG<-0 THEN GOTO 4320

4280 FOR 11-0 TO 9

4300 NEXT S II G “ H ^ F ° R J " 0 T ° 51 NDIG ( J )“ NUM (SDIG+1.J): NEXT J 4310 PUT(SX.SY).NDIG.PSET

)*.5

JY-KY:

JY-KY:

JY-190:

JY-10:

224 BYTE LISTINGS SUPPLEMENT • 1ULY-SEPTEMBER. 1986

4320 IF FDIGc-0 AND SDIG<-0 AND TDIG<-0 THEN RETURN 4330 FOR I1-0 TO 9

4340 IF TDIG-II THEN FOR J-0 TO 5 : NDIG(J)-NUM(TDIG+1,J): NEXT J 4350 NEXT II

4360 PUT(SX+7,SY),NDIG,PSET 4370 RETURN 4495 *

4500 ’ ZOOM FUNCTION 4505 ’

4510 LOCATE 25,1:PRINT BLANK$;: LOCATE 25,1: PRINT "LOCATE CROSSHAIRS TO ONE CORNER OF ZOOM AREA AND PRESS RETURN KEY TO ENTER";

4520 XFIN-320:YFIN-100

4530 IF XFIN>630 THEN XFIN-630 ELSE IF XFIN<200 THEN XFIN-200 ELSE IF YFIN>190 THEN YFIN-190 ELSE IF YFIN<10 THEN YFIN-10 4540 PUT (XFIN.YFIN),MARKER

4550 A1$-INKEY$: IF A1$="" THEN 4550 ELSE IF ASC(A1$)-27 THEN: RETURN ELSE IF ASC(A1$)-13 THEN GOTO 4590 ELSE A1=ASC(RIGHT$(A1$,1))

4560 PUT (XFIN.YFIN),MARKER

4570 IF A1=77 THEN XFIN-XFIN+6 ELSE IF A1-75 THEN XFIN-XFIN-6 ELSE IF A1-72 THEN YFIN-YFIN-2 ELSE IF A1-80 THEN YFIN-YFIN+2 4580 GOTO 4530

4590 LOCATE 25,1:PRINT BLANK$;: LOCATE 25,1: PRINT "LOCATE CROSSHAIRS TO OTHER CORNER OF ZOOM AREA AND PRESS RETURN KEY TO ENTER";

4600 XLOC1-XFIN:YLOC1-YFIN

4610 IF XFIN>630 THEN XFIN-630 ELSE IF XFIN<0 THEN XFIN-0 ELSE IF YFIN>199 THEN YFIN-199 ELSE IF YFIN<10 THEN YFIN-10 4620 PUT (XFIN.YFIN),MARKER

4630 A1$-INKEY$: IF A1$-"" THEN 4630 ELSE IF ASC(A1$)-27 THEN RETURN ELSE IF ASC(A1$)-13 THEN GOTO 4670 ELSE A1-ASC(RIGHT$(A1$,1))

4640 PUT (XFIN.YFIN),MARKER

4650 IF A1-77 THEN XFIN-XFIN+6 ELSE IF A1-75 THEN XFIN-XFIN-6 ELSE IF A1-72 THEN YFIN-YFIN-2 ELSE IF A1-80 THEN YFIN-YFIN+2 4660 GOTO 4610

4670 REM ** COMPUTE NEW SCALE FOR DWG. **

4680 IF (XLOC1-XFIN)-0 OR (YLOC1-YFIN)=0 THEN

MSG$-"ZOOM POINTS IN HORIZONTAL OR VERTICAL LINE": GOSUB 26000:RETURN 4690 IF XLOC1<XFIN THEN XMAX«XMIN+PX*(XFIN-200): XMIN=XMIN+PX*(XLOC1-200) ELSE XMAX-XMIN+PX*(XLOC1-200): XMIN-XMIN+PX*(XFIN-200)

4700 IF YLOC1<YFIN THEN YMAX-YMIN+PY*(190-YLOC1): YMIN=YMIN+PY*(190-YFIN) ELSE YMAX-YMIN+PY*(190-YFIN): YMIN-YMIN+PY*(190-YLOC1)

4710 RETURN 5600 *

5610 1 GET/SAVE/DELETE DATA FILES 5620 '

5630 IMENU-4: GOSUB 25000: I0PT5-ISEL 5640 IF IRETO0 THEN RETURN 5650 GOSUB 26400 5660 GOSUB 23000

5670 IF IERR-53 AND IOPT5-2 THEN GOTO 5680 ELSE IF IERRO0 THEN GOTO 5630 5680 LOCATE 24,10

5690 IF I0PT5-1 THEN PRINT "ENTER FILE TO GET ";: ELSE IF IOPT5-2 THEN PRINT "ENTER FILE TO SAVE";: ELSE PRINT "ENTER FILE TO DELETE";

5700 X-24: Y-33: GOSUB 21000

5710 IF IERRO0 THEN GOTO 5630 5720 NAM$»INPT$

5730 ON I0PT5 GOSUB 5760,5940,6110

5740 GOTO 5630 5750 *

5760 • LOAD AN EXISTING MESH 5770 •

5780 NAM$=DV$+NAM$: OPEN NAM$ FOR INPUT AS 3

5790 INPUT #3,TITLES

5800 INPUT #3,NUMEL,NUMNP,NMAT,NLOAD

5810 INPUT #3,EKEY(1),EKEY(2),EKEY(3),EKEY(4),EKEY(5)

5820 FOR 1-1 TO NUMNP

5830 INPUT #3,K,XN0D(K),YN0D(K)

5840 NEXT I

5850 FOR 1-1 TO NUMEL

5860 INPUT #3, J,NCON(J,1),NC0N(J,2),AR(J)

5870 NEXT I

5880 FOR 1-1 TO NLOAD

5890 INPUT #3, ILOAD(1,1),I LOAD(1,2),RLOAD(I)

5900 NEXT I

5910 CLOSE #3: RETURN

5920 REM ** END MODULE TO RELOAD MATERIAL/LOAD DATA **

5930 *

( continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 225

}uly

5940

5950

5960

5970

5980

5990

6000

6010

6020

6030

6040

6050

6060

6070

6080

6090

6100

6110

6120

6130

6140

6150

6160

6170

# SAVE MODEL DATA

t

NAM$-DV$+NAM$: OPEN NAM$ FOR OUTPUT AS 3 WRITE #3.TITLES

WRITE #3.NUMEL,NUMNP,NMAT,NLOAD WRITE #3.EKEY(1),EKEY(2).EKEY(3).EKEY(4).EKEY(5) FOR 1-1 TO NUMNP WRITE #3,I.XN0D(I).YN0D(I)

NEXT I

FOR 1-1 TO NUMEL

WRITE #3. I.NCON(I,1),NCON(I.2),AR(I)

NEXT I

FOR 1-1 TO NLOAD

WRITE #3. ILOAD(I,1),ILOAD(I,2),RLOAD(I)

NEXT I v '

CLOSE #3:RETURN

»

’ DELETE A FILE

CLS: SOUND 500,4 LOCATE 5,30: PRINT

***** WARNING ***»*"

LOCATE 5,10: PRINT "A DELETED FILE CAN NOT BE RECOVERED ... TO DELETE" LOCATE 7,10: PRINT “

. - - PRESS .. Y .. ELSE ANY OTHER KEY TO ABORT"'

„ A1$—INKEY$: IF A1$-"" THEN 6170 ELSE IF A1$="Y" OR A1$-"y" THEN KILL DV$+NAM$: RETURN ELSE RETURN y

10000 *

10010 * ANALYSIS 10020 10070 10074 10078 IERR-1 10082 10086

IERR-0: CLS: LOCATE 2,30: PRINT "CHECKING DATA": PRINT FOR 1-1 TO NUMEL

IF NCON(I,1)-NCON(I,2) THEN PRINT "ELEMENT "+STR$(I)+" NODE ERROR":

IF AR(I)<-0 THEN PRINT "ELEMENT "+STR$(I)+" AREA ERROR": IERR-1 " NODE NOT DEFINED ;1 ? > IERR-1° R NCON(I ' 1)<m0 THEN PRINT "ELEMENT " + STR$(I) +

" 0 NODE NOT F DEFINED" 2 hlERS-i° R NCON(I>2)< “ 0 THEN PRINT "ELEMENT "+STR$(I) + NEXT I

LOCATE 25,10: PRINT "PRESS ANY KEY TO CONTINUE":

A1$«INKEY$: IF A1$-"" THEN 10094 IF IERRO0 OR ASC(A1$)-27 THEN IERR-0: RETURN GOSUB 30000

IF BW>MBW THEN MSG$-"BANDWIDTH EXCEEDS ALLOWABLE":GOSUB 26000- RETURN NDF NUMNP > 2 AXNP THEN MSG *“" T0 ° MANY nodes " : GOSUB 26000: RETURN FOR I1-1 TO NDF FOR JJ-1 TO BW A(11,JJ)=0: B(11)=0 NEXT JJ NEXT II

10088

10090

10094

10096

10100

10102

10105

10107

10108 10110 10120 10130 10140 10150 10160 10170 10180 10190 10200 10210 10220 10230 10240 10250 10260

; COMPUTE ELEMENT STIFFNESS/ADD TO GLOBAL

FOR IELE-1 TO NUMEL GOSUB 10700 NEXT IELE

’ IMPOSE LOADS/FIXITIES

CP-10'12

FOR 1-1 TO NLOAD

26000 RETURN 10 ^*’ 1 >NUMNP ™ EN MSG *“" ERR0R IN LOAD"+STR$(I) : GOSUB B(J)-RLOAD(I) OAD(I ' 2) ’ 0 ° R IL0AD (I,2)=1 ™ EN j -2*IL0AD(I,1)-1+IL0AD(I,2):

10280 IF ILOAD(I.2)-2 OR ILOAD (I,2)-3 THEN J«2*ILOAD(I,1)-3+IL0AD(I,2)• A(J.1)-A(J,1)*CP: B(J)=RLOAD(I)*A(J,1) J ' * '

10290 NEXT I

10300

10310

10320

10330

10340

10350

10360

10370

’ SOLVE MATRIX

FOR N-1 TO NDF FOR L-2 TO BW

IF A(N,L)=0 THEN GOTO 10450 I-N+L-1

C=A(N,L)/A(N,1)

226 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

10380 J-0

10390 FOR K-L TO BW

10400 J-J+1

10410 A(I,J)-A(I,J)-C*A(N,K)

10420 NEXT K

10430 A(N,L)»C

10440 B(I)«B(I)-A(N,L)*B(N)

10450 NEXT L

10460 B(N)«B(N)/A(N,1)

10470 NEXT N

10480 REM ** BACK SUBSTITUTION **

10490 FOR M-2 TO NDF

10500 N-NDF+1-M

10510 FOR L-2 TO BW

10520 IF A(N,L)«0 THEN GOTO 10550

10530 K-N+L-1

10540 B(N)«B(N)-A(N,L)*B(K)

10550 NEXT L 10560 NEXT M 10570 •

10580 * CALCULATE STRESSES 10590 *

10600 IF NUMNPc-0 THEN RETURN 10610 FOR IELE-1 TO NUMEL 10620 NN1«NCON(IELE,1)

10630 NN2«NC0N(IELE,2)

10640 X«XNOD(NN2)-XNOD(NN1)

10650 Y«YNOD(NN2)-YNOD(NN1)

10660 E«EKEY(1)/(X~2+Y~2)

10670 STR(IELE;-E*(X*(B(2*NN2-1)-B(2*NN1-1))+Y*(B(2*NN2)-B(2*NN1)))

10680 NEXT IELE 10690 RETURN 10700 *

10710 * ELEMENT STIFFNESS... ELEMENT # IELE 10720 •

10730 NN1-NCON(IELE,1 )

10740 NN2«NCON(IELE,2)

10750 X-XNOD(NN2)-XNOD(NN1)

10760 Y-YNOD(NN2)-YNOD(NN1)

10770 AEL«AR(IELE)*EKEY(1)/(SQR(X A 2+Y^2))^3

10780

XXYY( 4

l)-x

10790

xxyy(:

>)-x

10800

XXYY(:

5)—Y

10810

XXYYO

O-v

10820 FOR 1= 1 TO 4

10830 FOR J-1 TO 4

10840 BK(I,J)-AEL*XXYY(I)*XXYY(J)

10850 NEXT J

10860 NEXT I

10870 FOR 11-1 TO 2

10880 FOR 12-1 TO 2

10890 FOR J1-1 TO 2

10900 FOR J2-1 TO 2

10910 JJ«2*NCON(IELE,J2)-2+J1

10920 II«2*NCON(IELE > I2)-1+I1-JJ

10930 IF II>0 THEN

I«2*(I1-1)+I2: J-2^(J1-1)+J2:

A( JJ,11)-A(JJ,11)+BK(I,J)

10940 NEXT J2

10950 NEXT J1

10960 NEXT 12 10970 NEXT II 10980 RETURN 20000 #

20010 • ROUTINE: SCREEN RESET AND CW NOTICE 20020 •

20030 KEY OFF

20040 FOR 1-1 TO 10: KEY I # MM : NEXT I

20050 FOR J-0 TO 3: SCREEN 0,0,J,0: CLS: NEXT J

20060 •

20070 • PRINT COPYRIGHT NOTICE 20080 •

20090 SCREEN 0,0,0,1

20100 FOR 1-5 TO 70 STEP 5: LOCATE 6,1: PRINT "- H ; : LOCATE 20,1:

PRINT n - M ; : NEXT I

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 227

LOCATE

LOCATE

20110 20120 1984"

20130 20140 20150 20160 20170 20180 21000 21010 21020 21030 21040 21050 21060 21070 21080 A1$« HM 21090 IERR-0

9,36:

11,15:

PRINT

PRINT

"TRUSS2"; "REVISION

1.00

COPYRIGHT

C.S. PEDICINI

COLOR 0,15 LOCATE 16,25,0 COLOR 7,0 SCREEN 0,0,0,0 A1$-INKEY$: IF RETURN

PRINT " PRESS ANY KEY TO CONTINUE "

A1$

THEN 20170

STRING INPUT MODULE

X,Y ... CURSOR LOCATION TO PRINT STRING A1$ ... MAY CONTAIN FIRST CHARACTER IERR... 1 FOR ABORT VALNEW. NUMERIC RESULT INPT$...STRING RESULT

21100 21110 21120 21130 21140 LOCATE 21150 21160 21170 21180 21190 21200 21210 21220 21230 22000 22010 22020 22030 22040 22080 MSG$«""

INPT$=A1$: IF LEN(A1$)=0 THEN GOTO 21120 IF ASC(A1$)-13 THEN 21190 IF ASC(A1$)-27 THEN IERR-1: RETURN LOCATE X,Y: PRINT INPT$;

A1$*INKEY$:IF A1$«"" THEN 21130

IF ASC(A1$)-8 AND LEN(INPT$)>=1 THEN INPT$-MID$(INPT$,1,LEN(INPT$)-1) X A Y: PRINT INPT$;" GOTO 21130 V J J

:RETURN

IF ASC(A1$)-27 THEN IERR=1 IF ASC(A1$)-13 THEN 21190 INPT$«INPT$+A1$:LOCATE X,Y:

CONVERT VALUE

VALNEW-VAL(INPT$)

RETURN

ERROR TRAP MODULE

ERR . BASIC ERROR CODE

MSG$ . ERROR TEXT

PRINT INPT$;: GOTO 21130

22090

22100

22110

22120

22130

22140

22150

22160

22170

22180

22190

22200

22210

22220

22230

22240

23000

23010

23020

23030

23040

23050

23060

23070

23090

23100

23110

23120

23130

23135

23137

23140

23150

23160

23170

23180

IF ERR-24 OR ERR-25 OR ERR-27 THEN MSG$*"PRINTER ERROR" IF ERR-53 THEN MSG$-"FILE DOES NOT EXIST"

IF ERR-57 THEN MSG$»"DOS ERROR ON DISKETTE I/O"

"DISK FULL"

"INPUT PAST END OF FILE"

"BAD FILE NAME"

"DISK WRITE PROTECTED"

"DISK NOT READY"

IF ERR-61 THEN MSG$ IF ERR-62 THEN MSG$ IF ERR=64 THEN MSG$ IF ERR-70 THEN MSG$ IF ERR-71 THEN MSG$

IF ERR-72 THEN MSG$«"DISK MEDIA ERROR"

IF MSG$-"" THEN MSG$*"ERROR CODE "+STR$(ERR)

* PRINT ERROR MSG

IERR-ERR: SCREEN 0.0,1,1: RESUME 22240 RETURN

GOSUB 26000: SCREEN 0.0.0,0

' DETERMINES DIRECTORY FOR PATH DV$ USING SCREENS 0,2 AND 3 ’ FILE LIST IS IN LINES 3-22..LINE 24 IS COMMAND LINE

• DV$. DIRECTORY/PATHNAME

’ NUMFIL.. NUMBER OF FILES

’ I.J.K... USED AS INDICES

* X.Y. LOCATION OF FILE FOR SCREEN 0

l

CLS: NAM$="": IERR=0: SCREEN 0,0,2,2: CLS

LOCATE 12,35: COLOR 0,15: PRINT "SORTING":COLOR 7,0

I

’ XFER FILES FROM SCREEN 3 TO SCREEN 1... FIND # OF FILES

’ INTERPRETIVE MODE • COMPILED MODE NUMFIL=0

11-2: 12-18: 13=17: 14=13-11: 15-4 ’11-1: 12-13: 13-12: 14=13-11: 15=6 SCREEN 0,0,3,2: CLS: FILES DV$+"*.*• I FOR 1=11 TO 24 FOR J-1 TO 15 SCREEN 0.0,3,2

IF SCREEN(I,I2*J-I3)=32 OR SCREEN(I,I2*J-I3)=0 THEN GOTO 23260

228 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

23190 A1$»""

23200 FOR K—13 TO -14

23210 A1$«A1$+CHR$(SCREEN(I,I2*J+K))

23220 NEXT K

23230 NUMFIL-NUMFIL+1

23240 X=15*INT(NUMFIL/20)+1: Y«NUMFIL-INT(X/15)*19+2

23250 SCREEN 0,0,0,2: LOCATE Y,X: PRINT A1$

23260 NEXT J 23270 NEXT I 23280 SCREEN 0,0,0

23290 LOCATE 1,30: PRINT " DRIVE CODE - ";DV$

23300 RETURN 23310 •

23320 0 ERROR TRAP 23330 *

23340 GOSUB 22000

23350 IF ERR-53 THEN RESUME 23280

23360 GOSUB 26000: IERR-1

23370 RETURN

24000 •

24010 * TRANSFER CONTROL 24020 •

24030 CLS

24040 CLS: SOUND 400,2: LOCATE 6,30

24050 PRINT " ***** WARNING ***♦*":LOCATE 7,20

24060 PRINT " BEFORE YOU EXIT THIS PROGRAM MAKE SURE YOU":LOCATE 8,23

24070 PRINT M HAVE SAVED ALL OF YOUR DATA FILE(S) "

24080 LOCATE 13,30: PRINT "ARE YOU SURE Y-YES"

24090 A1$-INKEY$:IF A1$- M " THEN 24090 ELSE IF A1$-"y" OR A1$="Y" THEN SYSTEM 24100 RETURN 25000 ’

25010 • MENU PRINT/ENTRY

25020 * MENU$(10,6)... 10 MENUS, 6 ITEMS PER MENU

25030 1 IMENU.MENU TO BE PRINTED

25040 * ISEL. ITEM SELECTED FROM MENU

25050 * IRET. <>0 IF ABORTED

25060 *

25070 CLS

25080 LOCATE 1,(80-LEN(TITLE$))/2: PRINT TITLES 25090 LOCATE 1,70: PRINT DAT1$

25100 LOCATE 4,30: PRINT MENU$(IMENU,1)

25110 •

25120 OPTMAX-0 25130 FOR 1-2 TO 7

25140 IF MENU$(IMENU,I)-"" THEN 25170

25150 OPTMAX-OPTMAX+1

25160 LOCATE 2*1+3,27: PRINT 1-1; M M ;MENUS(IMENU,I)

25170 NEXT I 25180 0

25190 0 ACCEPT OPTION 25200 ‘

25210 LOCATE 25,60: PRINT "ESC - MAIN MENU";

25220 IRET-0

25230 LOCATE 22,30: COLOR 0,15: PRINT "SELECTION - "; :COLOR 7,0 25240 X-22: Y-43: GOSUB 21000

25250 IF IERR-1 THEN IRET-1: RETURN

25260 IF VAL(INPT$)<>0 AND VAL(INPT$)<-OPTMAX THEN ISEL=VAL(INPT$): RETURN 25270 MSGS-"INVALID MENU RESPONCE ": SCREEN 0,0,1,1: GOSUB 26000:

SCREEN 0,0,0,0: INPT$-"": LOCATE 22,42: PRINT " ":GOTO 25240

26000 0

26010 0 ERROR SUBROUTINE

26020 0 MSGS... CONTAINS ERROR MESSAGE

26030 0

26040 CLS: SOUND 600,6 26050 LN-LEN(MSGS)

26060 LOCATE 7,32: PRINT "PROBLEM"

26070 LOCATE 10,INT((80-LN)/2): PRINT MSG$

26080 LOCATE 15,27: PRINT "PRESS ANY KEY TO CONTINUE";

26090 AlS-INKEYS: IF A1$»"" THEN 26090 ELSE RETURN 26100 0 26400 0

26410 0 CURRENT DIRECTORY/PaTH 26420 0 26430 CLS

26440 LOCATE 12,10

26450 PRINT "CURRENT DIRECTORY: ";: COLOR 0,7: PRINT " ";DV$;" ":COLOR 7,0

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 229

I uly

26460 LOCATE 14,10

26470 PRINT "NEW DIRECTORY:"

26472 LOCATE 20,10: PRINT " TO CHANGE DIRECTORIES/DRIVES ENTER THE NAME OF "

26474 LOCATE 21,10: PRINT " THE NEW DRIVE AND PRESS THE RETURN KEY. TO

RETAIN

26476 LOCATE 22,10: PRINT " THE CURRENT ONE PRESS THE RETURN KEY."

26478 LOCATE 14,25,1

26480 A1$-INKEY$: IF A1$-"" THEN 26480 ELSE IF ASC(A1$)-13 THEN RETURN 26490 X-14: Y-25: COLOR 0,7: GOSUB 21090: COLOR 7.0

26500 IF IERRO0 THEN RETURN

26510 IF RIGHT$(INPT$,1)-":" THEN DV$-INPT$: RETURN

26520 MSG$-"INVALID DRIVE SPECIFICATION": GOSUB 26000: GOTO 26400

30000 *

30010 ’ DTERMINE BANDWIDTH . REF SEGERLIND PG 18

30020 * NCON(I.J)... ELEMENT NUMBERS

30030 * MDIFF. MAX NODE DIFFERENCE IN AN ELEMENT

30040 ' NUMEL.NUMBER OF ELEMENTS

30050 ’ BW. BANDWIDTH

30060 ’

30070 MDIFF-0: CLS: LOCATE 12,35: PRINT "WORKING"

30080 FOR 1-1 TO NUMEL

30090 DIFF«ABS(NCON(I,1)-NCON(I,2)): IF DIFF>MDIFF THEN MDIFF-DIFF

30100 NEXT I

30110 BW-2*(MDIFF+1)

30120 RETURN 30130 *

31000 *

31010 ' ROUTINE TO PRINT TO SCREEN OR LINEPRINTER

31020 ' PRNT$(5). ARRAY OF Y/N PRINT CHOICES

31030 *

31040 CLS: LOCATE 1,28: PRINT "PRINTER CONTROL VARIABLES"

31050 LOCATE 5,28: PRINT "ENTER TO PRINT TO SCREEN"

31060 LOCATE 7,28: PRINT "ENTER TO PRINT LINEPRINTER"

31070 COLOR 0,15: LOCATE 5,34: PRINT “ S “: LOCATE 7,34: PRINT " L ":

COLOR 7,0

31080 LOCATE 13,30: PRINT "ENTRY -": X-13: Y-38: GOSUB 21000 31090 IF INPT$="S“ OR INPT$-"8" THEN INPT$-"S": GOTO 31120 ELSE IF INPT$-"L“ OR INPT$-“I" THEN INPT$»"L“: GOTO 31120 31100 RETURN 31110 *

31120 * ESTABLISH PRINT OPTIONS 31130 '

31140 X-5: Y-28

31150 PRNT$(1)-"Y": FOR 1-2 TO 5: PRNT$(I)-PRNT$(1): NEXT I

31160 CLS

31170 LOCATE 17,5: PRINT " USE UP/DOWN ARROWS TO POSITION CURSOR AND ENTER "

31180 LOCATE 18,5: PRINT “ Y/N ..CAPITALS ONLY!.. USE F10 TO CONTINUE"

31190 LOCATE 20,5: PRINT “ <Esc> RETURNS TO MENU"

31200 LOCATE 3.1: PRINT " PRINT Y/N"

31210 LOCATE 5.1: PRINT "NODE POINT DATA. ";PRNT$(1)

31220 LOCATE 7.1: PRINT "ELEMENT DATA. ";PRNT$(2)

31230 LOCATE 9,1: PRINT "LOAD AND MATERIAL DATA- ";PRNT$(3)

31240 LOCATE 11,1:PRINT "STRESS/STRAIN RESULTS. ";PRNT$(4)

31250 LOCATE 13,1:PRINT "NODE DISPLACEMENTS. ";PRNT$(5)

31260 ’

31270 • TRAP KEYS 31280 '

31290 LOCATE X,Y,1

31300 A1$-INKEY$: IF A1$- M " THEN 31300 ELSE IF ASC(A1$)=27 THEN RETURN 31310 IF LEN(A1$)<>2 THEN IF A1$-"Y" OR A1$-"N" THEN LOCATE X.Y.1:

PRINT A1$: PRNT$(INT(X/2-1.5))-A1$: GOTO 31290 ELSE GOTO 31290 31320 A1»ASC(RIGHT$(A1$,1))

31330 IF A1-72 AND X>-7 THEN X-CSRLIN-2

31340 IF A1=80 AND X<13 THEN X-CSRLIN+2

31350 IF A1<>68 THEN 31290 31360 ’

31370 * PRINT DATA 31380 *

31382 GOSUB 31390: CLOSE #1: RETURN ’ STANDARD ESCAPE

31390 IF INPT$-"S" THEN OPEN "SCRN:" FOR OUTPUT AS #1: GOTO 31470 31400 OPEN "LPT1:" FOR OUTPUT AS #1

31410 CLS: LOCATE 10,10: PRINT "SET UP PRINTER AND PRESS ANY KEY WHEN READY

II

31420 A1$-INKEY$ : IF A1$="" THEN 31420 ELSE IF ASC(A1$)-27 THEN RETURN 31430 CLS: LOCATE 13,30:PRINT "PRINTING DATA";

31440 LOCATE 16,20: PRINT "TO STOP PRINTING PRESS ESC KEY"

31450 PRINT #1,CHR$(27)"N"CHR$(6)

230 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

31460 ’

31470 * OUTPUT NODE DATA 31480 *

31490 IF PRNT$(1)<>"Y" THEN 31610 31530 FOR 1-1 TO NUMNP

31540 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN

31545 IF 1=1 OR CSRLIN=23 THEN GOSUB 32190:

PRINT #1, TAB(10);"NODE X-COORD Y-COORD";CHR$(10);CHR$(10)

31550 PRINT #1. TAB(10);

31560 PRINT #1, USING " ### ":I;

31570 PRINT #1. USING - ###.#####";XNOD(I),YNOD(I)

31590 NEXT I

31600 *

31610 * LIST ELEMENTS 31620 ’

31630 IF PRNT$(2)<>"Y" THEN 31760 31680 FOR 1=1 TO NUMEL

31690 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN

31695 IF 1=1 OR CSRLIN-23 THEN GOSUB 32190:

PRINT #1, TAB(10);" ELEM NODE NODE SECTION":

PRINT #1, TAB(10);" NO. I J AREA" ,CHR$( 10)

31700 PRINT #1, TAB(10);

31710 PRINT #1, USING “ ### ";I,NCON(I,1),NCON(I,2);

31720 PRINT #1. USING "###.###";AR(I)

31740 NEXT I

31750 *

31760 * LIST LOADS 31770 *

31780 IF PRNT$(3)o"Y" THEN 31890 31820 FOR 1=1 TO NLOAD

31830 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN

31835 IF 1=1 OR CSRLIN-23 THEN GOSUB 32190:

PRINT #1. TAB(10);"NODE NO. CODE VALUE".CHR$(10),CHR$(10)

31840 PRINT #1, TAB(10);

31850 PRINT #1, USING " ### ";ILOAD(I.1).ILOAD(I.2);

31860 PRINT #1, USING " #.##" A "*";RLOAD(I)

31870 NEXT I

31880 *

31890 * OUTPUT RESULTS 31900 *

31910 IF PRNT$(4)<>“Y" THEN 32020 31950 FOR 1=1 TO NUMNP

31960 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN

31965 IF 1=1 OR CSRLIN-23 THEN GOSUB 32190:

PRINT #1. TAB(10);"NODE NO X-DISP. Y-DISP. ",CHR$(10),CHR$(10)

31970 PRINT #1, TAB(10):

31980 PRINT #1, USING " ### ";I;

31990 PRINT #1. USING " ###.#####";B(2*I-1),B(2*I)

32000 NEXT I

32010 ’

32020 ' OUTPUT RESULTS 32030 *

32040 IF PRNT$(5)o"Y" THEN 32170 32080 FOR 1=1 TO NUMEL

32090 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN

32095 IF 1=1 OR CSRLIN-23 THEN GOSUB 32190:

PRINT #1, TAB(10);"ELEM NO STRESS-PSI FORCE-LBS",CHR$(10),CHR$(10)

32100 PRINT #1, TAB(10);

32110 PRINT #1. USING “ ### ";I;

32120 PRINT #1. USING " #######.";STR(I),STR(I)/AR(I)

32130 NEXT I

32140 IF INPT$o"S“ THEN CLOSE #1: RETURN

32150 LOCATE 25,5: PRINT "PRESS ANY KEY TO CONTINUE";

32160 A1$=INKEY$: IF A1$="" THEN 32160 ELSE RETURN 32170 CLOSE #1: RETURN 32180 *

32190 * PAGE HEADER 32200 ’

32210 IF INPT$<>"S" THEN X=5: WHILE X: LPRINT CHR$(10): X-X-1: WEND: GOTO 32240

32220 LOCATE 25,5: PRINT "PRESS ANY KEY TO CONTINUE";

32230 A1$=INKEY$: IF A1$=“" THEN 32230 ELSE CLS

32240 PRINT #1. CHR$(10)

32250 PRINT #1. SPC(1);DAT1$

32260 PRINT #1. TAB(40-LEN(TITLE$)/2); TITLE$

32270 PRINT #1, CHR$(10)

32280 RETURN

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 231

July

ughbug.asm

"An 8031 In-CIrcult Emulator," by George Dinwiddle. July, page 181.

TITLE • UGHBUG VERSION 1.00 12 January 1986 *

SBTTL * Copyright 1986 by George Dinwiddie *

PGLEN 55

NOTICE : This monitor program may be copied and distributed on the condition that all copyright notices and this notice remain intact. This program is provided without any warranty or assumption of liability whatsoever. If It doesn’t work or it breaks something, I’m sorry, but It’s not my problem.

On the positive side, if this program helps you, I am glad to be of assistance. I ask only two favors. First, if you fix any bugs or add any enhancements, please send me a copy. (CP/M 8" SSSD or IBM-PC 5.25" are best for me.) Secondly, If you use this program to help develop a commercial product, please remember me. As a suggestion, a $50.00 donation would be a bargain for you and welcome by me. If you would prefer, either a sample of your product or a donation more in line with the profits on your product would be ok, too. If you use this program on a home project, I understand that you can’t alway afford to pay for the value of good software. My own CP/M computer would be worthless without the wonderful public domain software that I have received for free. If you want to send me your favorite public domain goody, great. In any event, you are welcome to this — enjoy, enjoy.

George Dinwiddie 10965 Trotting Ridge Way Columbia, MD 21044

REVISION HISTORY :

Version 1.00 George Dinwiddie 12 January 1986.

First public release. Fixed GO-from-break bug.

Version 0.16 George Dinwiddie 26 January 1984 Added JUMPTABLE and HEXMATH functions.

WISH LIST :

Load command (*L') to load ram from a hex file through the terminal port.

Find command ('F’) to search for sequences specified in hex or ascii. I always Intended to add this one but never did. That's the reason the Insert command isn’t a Fill command.

Disassemble command (maybe 'Ll’ for Unassemble).

Single-line assembler. It’s amazing how good you get at hand assembly when you practice. Still, It would be nice to have this.

MOTE : Some labels are of the following form : IF000 == IF

THN000 « THEN ELS000 »« ELSE NDI000 «= ENDIF

MONBASE

EQU

APPBASE

EQU

RAMBASE

EQU

UARTBASE

EQU

UARTDATA

EQU

UARTCONT

EQU

RAMEND

EQU

BYTENUM

EQU

STACK

EQU

0000H ;4K MONITOR

2000H ;8K APPLICATION EPROM

4000H ;8K RAM

7800H ;TERMINAL (uart) LOCATION UARTBASE ; C/D* * A0 (UARTBASE+1)

5FFFH ;END OF EXTERNAL RAMSPACE (RAMEND-8) ;FROM HERE ON USED BY BREAK ROUTINE 50H ;stack begins here

232 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

PCON

87H

AVOCET ASSEMBLER DOESN’T KNOW PCON

J uly

EQU

;reserved Internal ram locations

RESERVED EQU 48H ;reserved internal ram

HIBYTE EQU RESERVED ;TOP OF 16-BIT ADDRESS

LOBYTE EQU RESERVED*1 ;BOTTOM OF 16 BIT ADDRESS

FIRST EQU RESERVED+2 ;START ADDRESS HIGH (LOW IN RESERVED+3)

LAST EQU RESERVED+4 ;END ADDRESS HIGH (LOW IN RESERVED+5)

TO EQU RESERVED+6 ;TO ADDRESS HIGH (LOW IN RESERVED+7)

; reserved

register bank

(and aliases for those registers)

RESBANK

EQU

1

jregister bank 1

<

REG0

EQU

8*RESBANi

REG1

EQU

REG0+1

;sometimes you can’t use R1

REG2

EQU

REG0+2

REG3

EQU

REG0+3

REG4

EQU

REG0+4

REG5

EQU

REG0+5

REG6

EQU

REG0+6

REG7

EQU

REG0+7

•.character

equates

CR

EQU

0DH

CARRIAGE RETURN

LF

EQU

0AH

LINE FEED

SPACE

EQU

20H

SPACE CHARACTER

TAB

EQU

09H

TAB CHARACTER

DOT

EQU

2EH

PERIOD

BACKSP

EQU

08H

BACKSPACE

EOT

EQU

04H

end of text

Table caption;***********************************************************

ORG MONBASE

START: JMP UGHBUG

ORG START+03H

LJMP RAMBASE+03H

ORG START+0BH

LJMP RAMBASE+0BH

ORG START+13H

LJMP RAMBASE+13H

ORG START+1BH

LJMP RAMBASE+1BH

ORG START+23H

LJMP RAMBASE+23H

;INTERRUPT VECTORS JUMP TO RAM

;***********************************

LJMPTBL:

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP

LJMP COOL WARM

IN

INCH

INHEX

BYTES

BADDR

THRADR

OUT

OUTCH

OUTS

OUT2S

CRLF

OUT2H

OUTR0

OUTC2HS

PDATA

LJMP INCI 6

LJMP DEC16

LJMP CPY

LJMP BRKPT

PAGE

MSIGNON:

DB CR, LF, ’Ughbug MCS-51 monitor, version 1.00*

( continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 233

July

DB CR, LF. 'copyright 1986 by George Dinwiddie.', LF, 04H

*********************************************************

UGHBUG: MOV MOV SETB CLR CLR MOV MOV MOVX

Table captionCLEAR:

SP.#STACK STACK.SP RS0 RSI A

DPTR.#BYTENUM R0,#(RAMEND-BYTENUM+1)

;store stack pointer for cool start ;SELECT REGISTER BANK 1

Table caption©DPTR.A

Table caption;clear space used by break routine

INC

DPTR

DJNZ

R0.CLEAR

DLAY:

DJNZ

ACC.DLAY

WAIT HERE FOR UART TO WAKE-UP

DJNZ

R0.DLAY

MOV

DPTR,#UARTCONT

INIT UART

CLR

A

MOVX

©DPTR.A ;

send three zeros because you don't know

NOP

i

In what crazy mode the ugh-art wakes up

DJNZ

ACC,$-1

MOVX

©DPTR.A

NOP

DJNZ

ACC,$-1

MOVX

©DPTR.A

NOP

DJNZ

ACC,$-1

MOV

A.#40H

software reset uart

MOVX

@DPTR,A

CLR

A

many thanks to Ernest Penzenstad1er

NOP

;for taming the Infamous 8251A ugh-artl

DJNZ

ACC,$-1

MOV

A,#01001110B

MODE

MOVX

©DPTR.A

MOVX

A,©DPTR

GET STATUS

JNB

ACC.0,$-1

WAIT FOR TXRDY

MOV

A,#00110111B

COMMAND

MOVX

©DPTR.A

MOV

DPTR.fMSIGNON

CALL

PDATA

COOL:

MOV

SP.STACK

; *************************************************************

WARM:

MOV

DPTR,#MPROMPT

;WARM START

CALL

PDATA

CALL

INCH

JNB

ACC.6.$+5

JUMP IF NOT A LETTER

CLR

ACC. 5

CONVERT LOWER TO UPPER CASE

MOV

R7.A

SAVE CHARACTER INPUT

MOV

DPTR.#FUNTAB

POINT TO FUNCTION TABLE

SCAN:

CLR

A

MOVC

A,@A+DPTR

JZ

WARM

;END OF TABLE

CJNE

A.0FH.NEXT

;COMPARE WITH SAVED CHARACTER

MOV

A.#01H

MOVC

A,©A+DPTR

;GET HIGH BYTE OF JUMP

MOV

R2.A

;SAVE IN R2

MOV

A,#02H

MOVC

A,@A+DPTR

;GET LOW BYTE OF JUMP

MOV

R3.A

;SAVE IN R3

PUSH

REG3

-.PUSH R3 (LOW BYTE)

PUSH

REG2

;PUSH R2 (HIGH BYTE)

RET

;POP & JUMP

NEXT:

INC

DPTR

INC

DPTR

INC

DPTR

JMP

SCAN

PAGE

;*************************************************************

HELP:

MOV

DPTR.#MHELP

CALL

PDATA

JMP

WARM

Table caption234 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

*************************************************************

J uly

DUMP:

DMP1: DMP3:

DMP4:

DMP5:

NEWLIN:

SPACES:

MORE:

MOREC:

ENDHEX:

DASCII:

DASCI1:

DASCI2:

CALL

BADDR

JNC

DMP3

CLR

ACC. 5

CJNE

A,#'I’,DMP1

JMP

DUMP I

JMP

WARM

MOV

FIRST,HIBYTE

MOV

(FIRST+1),LOBYTE

MOV

LAST,#0FFH

MOV

(LAST+1),#0FFH

CJNE

A,#CR,DMP4

JMP

(NEWLIN-6)

CALL

BADDR2

JB

F0,DMP5

MOV

LAST,HIBYTE

MOV

(LAST+1),LOBYTE

MOV

DPTR,#MINDEX

LCALL

PDATA

MOV

DPH,FIRST

MOV

DPL,(FIRST+1)

ANL

DPL,#0F0H

CALL

CRLF

MOV

R0.DPH

CALL

OUTR0

MOV

R0.DPL

CALL

OUTR0

CALL

OUT2S

MOV

A, (FIRST+1)

XRL

A, DPL

JZ

MORE

CALL

OUT3S

INC

DPTR

CALL

MIDCHK

JMP

SPACES

CALL

0UTC2HS

MOV

A,LAST

CJNE

A,DPH.MOREC

MOV

A,(LAST+1)

CJNE

A,DPL,MOREC

JMP

ENDHEX

INC

DPTR

CALL

MIDCHK

JZ

DASCII

JMP

MORE

INC

DPTR

CALL

MIDCHK

JZ

DASCII

CALL

0UT3S

JMP

ENDHEX

CALL

0UT4S

MOV

DPH,FIRST

MOV

DPL.(FIRST+1)

ANL

DPL,#0F0H

MOV

A, (FIRST+1)

XRL

A, DPL

JZ

DASCI2

CALL

OUTS

INC

DPTR

CALL

MIDCHK

JMP

DASCII

CLR

A

MOVC

A.GA+DPTR

MOV

B,A

CLR

C

;CONVERT LOWER TO UPPER CASE ;DUMP INTERNAL RAM

;DUMP PROGRAM MEMORY

;DEFAULT IF NO END ADDRESS ENTERED

;CARRIAGE RETURN READ

Table caption;DISPLAY ADDRESS

Table caption;BLANK LOCATIONS BEFORE FIRST ;JUMP IF EQUAL

Table caption;NOW DUMP ASCII

Table caption;NOW DUMP ASCII (LAST LINE)

Table caption;SHOW ASCII EQUIVALENT

( continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 235

SUBB

A,#SPACE

JC

BAD3

SUBB

A,#(7FH-SPACE)

JC

0K3

BAD3:

MOV

B.#DOT

0K3:

MOV

A,B

CALL

OUTCH

MOV

A.LAST

CJNE

A.DPH.DASCI3

MOV

A,(LAST+1)

CJNE

A.DPL.DASCI3

JMP

WARM

DASCI3:

INC

DPTR

CALL

MIDCHK

JNZ

DASCI2

MOV

A.#16

ADD

A,(FIRST+1)

ANL

A,#0F0H

JNC

$+4

INC

FIRST

MOV

(FIRST+1).A

JMP

NEWLIN

;*************************************************************

TABENT

EQU 11

;LENGTH OF SFR TABLE ENTRY

OFF 1

EQU 6

;OFFSET TO HEX ADDRESS

0FF2

EQU 5

;OFFSET TO FETCH CONTENTS

0FF3

EQU 8

;OFFSET TO CHANGE CONTENTS

DUMPI:

CALL

BADDR

JNC

$+5

LJMP

WARM

MOV

FIRST.LOBYTE

MOV

LAST,#0FFH

XRL

A,#CR

JZ

(LINE-6)

CALL

BADDR2

JB

F0.$+6

;CARRIAGE RETURN READ

MOV

LAST.LOBYTE

MOV

A.#7FH

;TOP OF RAM

CLR

C

SUBB

A.FIRST

JC

DSFR

;DONE RAM—DO SFR’S

MOV

DPTR.#MINDEX

LCALL

PDATA

LINE:

CALL

CRLF

MOV

A.#7FH

;TOP OF RAM

CLR

C

SUBB

A,FIRST

JC

DSFR

;DONE RAM—DO SFR'S

MOV

R0.FIRST

ANL

REG0,#0F0H

;8«R0

CALL

OUTR03S

;DISPLAY ADDRESS

SPICES:

MOV

A.FIRST

•.SPACES BEFORE BEGINNING

XRL

A, R0

JZ

NXTBYT

CALL

OUT3S

INC

R0

MOV

A,#07H

ANL

A.R0

JNZ

$+5

LCALL

OUTS

jMIDDLE OF LINE

JMP

SPICES

NXTBYT:

CALL

OUT2H

CALL

OUTS

MOV

A.R0

XRL

A.LAST

JNZ

$+5

LJMP

WARM

236 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

July

INC

R0

MOV

A,#07H

ANL

A.R0

JNZ

$+5

LCALL

OUTS

;MIDDLE OF LINE

MOV

A,#0FH

ANL

A,R0

JNZ

NXTBYT

;NOT END OF LINE

MOV

A,FIRST

ANL

A,#0F0H

ADD

A.#10H

MOV

FIRST,A

JMP

LINE

DSFR:

MOV

DPTR,#(SFRTAB-TABENT)

MOV

R1.#6

CALL

CRLF

DSFR1:

MOV

A,#TABENT

ADD

A,DPL

MOV

DPL,A '

JNC

$+4

INC

DPH

MOV

A,#OFF1

;OFFSET TO SFR HEX LOCATION

MOVC

A,@A+DPTR

CLR

C

SUBB

A,FIRST

JC

DSFR1

;NOT TO FIRST YET

DSFR5:

MOV

A,#OFF1

MOVC

A,@A+DPTR

;GET HEX LOCATION OF SFR

MOV

R0,FIRST

XRL

A, R0

JZ

DSFR10

INC

FIRST

;WASN'T A VALID SFR

MOV

A,FIRST

JZ

(LINE-6)

;BACK TO RAM

CJNE

A,LAST,DSFR5

JMP

WARM

;DONE

DSFR10:

CALL

OUTR0

MOV

A.#(*-’)

CALL

OUTCH

CALL

PDATA

•.OUTPUT LOCATION LABEL (ALTERS DPTR)

MOV

A,#(':')

CALL

OUTCH

MOV

A,#LOW(DSFR20)

PUSH

ACC

MOV

A,#HIGH(DSFR20)

PUSH

ACC

MOV

A.#(0FF2-4)

•.OFFSET TO "MOV R0.SFR"

JMP

©A+DPTR

DSFR20:

CALL

OUTR0

CALL

OUT2S

DJNZ

R1.DSFR30

MOV

Rl.#6

CALL

CRLF

DSFR30:

INC

FIRST

MOV

A,#(TABENT-4)

ADD

A, DPL

MOV

DPL. A

JNC

$+4

INC

DPH

MOV

A,FIRST

JNZ

$+5

LJMP

LINE

DEC

A

XRL

A,LAST

JNZ

DSFR5

JMP

WARM

[continued]

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 237

COPY:

CALL

THRADR

CALL

CPY

JMP

WARM

;** + + + + * + + + ***** + + + + *** + + + + + + ****** + *** + * + + + * + + + + * + * + * + * + * + * + *

VERIFY:

CALL

THRADR

VER10:

MOV

DPH,FIRST

MOV

DPL,(FIRST+1)

CLR

A

MOVC

A,©A+DPTR

MOV

R1 ,A

MOV

DPH,TO

MOV

DPL,(TO+1)

CLR

A

MOVC

A,©A+DPTR

MOV

R2, A

XRL

A.R1

JZ

VER20 ;JUMP IF EQUAL

CALL

CRLF

MOV

R0,#FIRST

CALL

OUT2H

MOV

R0,#(FIRST+1)

CALL

OUT2H

CALL

OUT2S

MOV

R0,#REG1 ;R1

CALL

OUT2H

CALL

0UT4S

MOV

R0,#TO

CALL

OUT2H

MOV

R0,#(TO+1)

CALL

OUT2H

CALL

OUT2S

MOV

R0,#REG2 ;R2

CALL

OUT2H

VER20:

MOV

A,FIRST

CJNE

A,LAST,VER30

MOV

A,(FIRST+1)

CJNE

A,(LAST+1),VER30

JMP

WARM

VER30:

MOV

R0,#(FIRST+1)

CALL

I NCI 6

MOV

R0,#(TO+1)

CALL

I NCI 6

JMP

VER10

;*************************************************************

ALTER:

CALL

BADDR

JNC

ALT05

JNB

F0,ALTEND ;ERROR

CLR

ACC.5 ;CONVERT LOWER TO UPPER CASE

CJNE

A,#(* I’).ALTEND ;ERROR

JMP

SUBSTUT

ALT05:

MOV

FIRST,HIBYTE

MOV

(FIRST+1),LOBYTE

ALT10:

CALL

CRLF

MOV

R0.#FIRST ;SHOW ADDRESS

CALL

0UT2H

INC

R0

CALL

OUT2H

ALT15:

CALL

OUTS

MOV

DPH,FIRST

MOV

DPL,(FIRST+1)

CLR

A

MOVC

A,@A+DPTR ;GET DATA

MOV

R1 , A

MOV

R0,#REG1 ;SHOW DATA

CALL

OUT2H

MOV

A.#(•-')

CALL

OUTCH

CALL

BYTES

JNC

ALT20

XRL

A,#BACKSP

Table caption238 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

JZ

BACKUP

XRL

A.#BACKSP

;RESTORE A

XRL

A,#DOT

JZ

BACKUP

ALTEND:

JMP

WARM

;ERROR

ALT20:

JB

F0.ALT30

;<CR> OR SPACE

MOV

A.LOBYTE

MOVX

@DPTR.A

•.CHANGE DATA

ALT30:

MOV

R0,#(FIRST+1)

CALL

I NCI 6

MOV

A,B

XRL

A,#CR

JZ

ALT 10

MOV

A,(FIRST+1)

ANL

A,#07H

JZ

ALT 10

JMP

ALT 15

BACKUP:

MOV

R0,#(FIRST+1)

CALL

DEC 16

JMP

ALT 10

;*************************************************************

MODIFY

CALL

BADDR

MOV

DPH.HIBYTE

MOV

DPL,LOBYTE

MOD10:

CALL

INCH

CJNE

A,#BACKSP,NOTBS

DEC

DPL

MOV

A.#0FFH

CJNE

A,DPL,MOD10

DEC

DPH

JMP

MOD 10

NOTBS:

CJNE

A.#EOT.$+6

LJMP

WARM

MOVX

©DPTR,A

INC

DPTR

JMP

MOD 10

;*************************************************************

SUBSTUT

.

CALL

BADDR

MOV

R0,LOBYTE

IF010:

MOV

A,#7FH

;IF ADDRESS >- 80H OR <=

F0H

CLR

C

SUBB

A, R0

JNC

ELS010

MOV

A,#0F0H

CLR

C

SUBB

A, R0

JC

ELS010

THN010:

MOV

DPTR,#(SFRTAB-TABENT)

SUB60:

MOV

A,#TABENT

;INCREMENT TABLE POINTER

ADD

A, DPL

MOV

DPL. A

JNC

$+4

INC

DPH

MOV

A.#OFF1

;FIND 1ST ENTRY >= R0

MOVC

A,®A+DPTR

CLR

C

SUBB

A, R0

JC

SUB60

;NOT FOUND YET

SUB65:

MOV

A.#OFF1

;INCREMENT R0 TO LINE IN

TABLE

MOVC

A,®A+DPTR

XRL

A, R0

JZ

SUB70

;FOUND IT

INC

R0

JMP

SUB65

ELS010:

JMP

LS010

;RELAY STATION

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 239

SUB70:

CALL

CRLF

CALL

OUTR03S

CALL

PDATA

MOV

A.#(’:•)

CALL

OUTCH

MOV

REG1.R0

MOV

A,#LOW(SUB80)

PUSH

ACC

MOV

A,#HIGH(SUB80)

PUSH

ACC

MOV

A,#(0FF2-4)

JMP

©A+DPTR

SUB80:

CALL

OUTR0

MOV

A.#(’-’)

CALL

OUTCH

MOV

R0.REG1

CALL

BYTES

IF020:

JNC

ELS020

MOV

A,B

XRL

A,#BACKSP

JZ

THN020

MOV

A.B

XRL

A,#DOT

JZ

THN020

JMP

WARM

THN020:

IF030:

CJNE

R0.#80H,ELS030

THN030:

MOV

R0.#7FH

JMP

IF010

ELS030:

MOV

A.DPL

CLR

C

SUBB

A,#(TABENT+4)

MOV

DPL, A

JNC

$+4

DEC

DPH

MOV

A.#(0FF1)

MOVC

A,@A+DPTR

MOV

R0, A

JMP

IF010

ELS020:

JB

F0.SUB90

SETB

F0

MOV

R0.LOBYTE

MOV

A,#LOW(SUB90)

PUSH

ACC

MOV

A,#HIGH(SUB90)

PUSH

ACC

MOV

A,#(0FF3-4)

JMP

OA+DPTR

SUB90:

MOV

R0.REG1

IF035:

JB

F0,NDI035

THN035:

MOV

DPTR.#MNONO

CALL

PDATA

NDI035:

IF040:

CJNE

R0,#0F0H.NDI040

THN040:

MOV

R0,#0FFH

NDI040:

INC

R0

JMP

IF010

LS010:

CALL

CRLF

CALL

OUTR03S

SUB20:

CALL

0UT2H

MOV

A. #C-*>

CALL

OUTCH

MOV

REG1,R0

CALL

BYTES

MOV

R0.REG1

IF050:

JNC

ELS050

MOV

A,B

XRL

A,#BACKSP

JZ

THN050

Table caption;DISPLAY ADDRESS ;ALTERS DPTR (ADDS 4)

Table caption;MOV R1,R0

;CRASHES R0 ;DISPLAY DATA

;RESTORE R0

;IF CHARACTER - DOT OR BACKSPACE

Table caption;ERROR

Table caption;THEN BACKUP

Table caption;CRASHES R0 ;RESTORE R0

Table caption;IF R0 = 0F ;THEN R0 - FFH

;clobbers r0

;IF CHAR. - BACKSP. OR DOT

Table caption240 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

MOV

A.B

XRL

A,#DOT

JZ

THN050

JMP

WARM

THN050:

»

THEN BACKUP

IF060: MOV

A, R0

JNZ

NDI060 ;

IF R0 = 0

THN060: MOV

R0,#0F1H ;

THEN R0 = F1H

NDI060:

NDI050:

DEC

R0

F010: JMP

IF010 ;

ALSO USED FOR RELAY

ELS050:

IF070: JB

F0.NDI070 ;

IF NOT SPACE OR CR

THN070: MOV

A,LOBYTE

THEN CHANGE BYTE

MOV

@R0, A

NDI070: INC

R0

MOV

A,#07H

ANL

A,R0

JZ

F010

CALL

0UT2S

JMP

SUB20

;*************************************************************

INSERT: CALL

THRADR

MOV

DPH,FIRST

MOV

DPL,(FIRST+1)

INS10: MOV

A, (TO+1)

MOVX

@DPTR,A

MOV

A, DPH

CJNE

A,LAST,INS20

MOV

A, DPL

CJNE

A,(LAST+1),INS20

JMP

WARM

INS20: INC

DPTR

JMP

INS10

Table caption*************************************************************

BREAK:

MOV

CLR

MOVC

MOV

IF100: JZ

THN100: MOV MOV MOV MOV ADD MOV JNC INC MOV CLR MOVC MOV MOV CLR MOVC CLR SUBB MOV JNC DEC CALL CLR MOV MOV

CLEAR1: MOVX INC DJNZ

; REMOVE OLD BREAKPOINT DPTR,#BYTENUM A

A,®A+DPTR

R1,A ;SAVE OLD BYTENUM IN R1

NDI100 ;IF THERE IS AN OLD BREAKPOINT

FIRST,#HIGH(BYTENUM+1) ;THEN REMOVE IT FIRST+1,#LOW(BYTENUM+1)

LAST,#HIGH(BYTENUM)

A,#LOW(BYTENUM)

A,R1 ;ADD OLD BYTENUM

LAST+1.A

$+4

LAST

DPTR,#(RAMEND-1)

A

A,@A+DPTR TO,A

DPTR,#RAMEND

A

A,©A+DPTR C

A,R1 ;SUBTRACT OLD BYTENUM

TO+1,A

$+4

T0

CPY

A ;CLEAR END OF RAM

DPTR,#BYTENUM

R0,#(RAMEND-BYTENUM+1-3) ;LEAVE JUMP INSTRUCTION

®DPTR,A

DPTR

R0.CLEAR1

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 241

NDI100:

CALL

BYTES

;INSTALL NEW BREAKPOINT

IF150: JNC

NDI150

;IF NOT VALID HEX

JMP

WARM

;THEN END

NDI150:

IF155: JNB

F0,NDI155

; IF CR

XRL

A,#SPACE

JZ

NDI100

;AND NOT SPACE

JMP

WARM

;THEN END

NDI155: MOV

FIRST,HIBYTE

MOV

FIRST+1,LOBYTE

MOV

DPTR,#BYTENUM

MOV

A,#3

;IN CASE OF DEFAULT

MOVX

©DPTR.A

MOV

R1.A

;SAVE DEFAULT NEW BYTENUM

IF160: MOV

A, B

XRL

A,#CR

JZ

NDI160

THN160: CALL

INHEX

;get BYTENUM

IF170: JNC

ELS170

; Tf not valid hex

THN170: MOV

A, B

;then check for space or CR

XRL

A,#SPACE

JZ

THN160

MOV

A,B

XRL

A,#CR

JZ

NDI170

MOV

DPTR,#BYTENUM

CLR

A

MOVX

©DPTR.A

JMP

WARM

ELS170: MOV

DPTR,#BYTENUM

;else accept only 3, 4 or 5

MOVX

©DPTR.A

MOV

R1, A

;SAVE NEW BYTENUM

SUBB

A.#3

JC

BAD4

SUBB

A.#(6-3)

JNC

BAD4

JMP

NDI170

BAD4: MOV

DPTR,#BYTENUM

CLR

A

MOVX

©DPTR,A

JMP

WARM

NDI170:

NDI160:

MOV

DPTR,#(RAMEND-2)

;FIRST,FIRST+1 AND HIBYTE,LOBYTE ; BOTH CONTAIN BREAK ADDRESS ;R1 CONTAINS NEW BYTENUM

MOV

A,#02H

;"LJMP"

MOVX

©DPTR.A

MOV

A,FIRST+1

ADD

A,R1

;ADD BYTENUM

MOV

LAST+1,A

MOV

DPTR,#RAMEND

MOVX

©DPTR,A

MOV

A,FIRST

JNC

$+3

INC

A

MOV

LAST,A

MOV

DPTR,#(RAMEND-1)

MOVX

©DPTR.A

MOV

R0,#(LAST+1)

;ADJUST (LAST,LAST+1)

CALL

DEC 16

MOV

TO.#HIGH(BYTENUM+1)

MOV

TO+1,#LOW(BYTENUM+1)

CALL

CPY

;SAVE INSTRUCTIONS IN END OF RAM

MOV

DPL,LOBYTE

MOV

DPH,HIBYTE

;INSERT JUMP TO BRKPT

MOV

A,#02H

;"LJMP"

MOVX

©DPTR.A

INC

DPTR

Table caption242 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

MOV

A,#HIGH(BRKPT)

MOVX

@DPTR,A

INC

DPTR

MOV

A,#LOW(BRKPT)

MOVX

@DPTR,A

JMP

WARM

;*************************************************************

BRKPT:

PUSH ACC

PUSH PSW

PUSH B

PUSH DPH

PUSH DPL

MOV STACK,SP ;save current stack level for cool start

SETB RS0 ;SELECT REGISTER BANK 1

CLR RSI

MOV DPTR,#MBRK1

CALL PDATA

MOV DPTR,#(BYTENUM)

CLR A

MOVC A,®A+DPTR

MOV R0,A

MOV DPTR,#(RAMEND)

CLR A

MOVC A,©A+DPTR

CLR C

SUBB A,R0

MOV B A

MOV DPTR.#(RAMEND-1)

CLR A

MOVC A,@A+DPTR

MOV R0,A

JNC $+3

DEC R0

CALL OUTR0

MOV R0,B

CALL OUTR0

MOV DPTR,#M8RK2

CALL PDATA

MOV A.STACK

CLR C

SUBB A,#4

MOV R0,A

CALL OUT2H

MOV DPTR,#M8RK3

CALL PDATA

INC R0

CALL OUT2H

MOV DPTR,#MBRK4

CALL PDATA

INC R0

CALL OUT2H

MOV DPTR,#MBRK5

CALL PDATA

INC R0

CALL OUT2H

INC R0

CALL 0UT2H

MOV DPTR,#MBRK6

CALL PDATA

MOV R0,#STACK

CALL 0UT2H

JMP WARM

Table caption;*************************************************************

CALL

BYTES

JNC

$+5

LJMP

WARM

JNB

F0.GXXXX

CJNE

A, #CR,GO

;LOOK AGAIN IF SPACE

MOV

HIBYTE.#HIGH(BYTENUM+1)

MOV

LOBYTE,#LOW(BYTENUM+1)

MOV

SP,STACK

{restore stack If necessary

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 243

Table captionGXXXX:

POP

DPL

POP

DPH

POP

B

POP

PSW

POP

ACC

PUSH

LOBYTE

PUSH

RET

HIBYTE

;***********.****************.**.********

HEXMATH:

CALL BADDR

JNC $ +5

LJMP WARM

MOV FIRST,HIBYTE

MOV (FIRST+1),LOBYTE

CALL BADDR

JNC $+5

LJMP WARM

MOV

ADD

MOV

MOV

ADDC

MOV

A,(FIRST+1) A,LOBYTE (LAST+1),A A,FIRST A.HIBYTE LAST,A

MOV

CLR

SUBB

MOV

MOV

SUBB

MOV

CALL

MOV

CALL

MOV

CALL

CALL

MOV

CALL

MOV

CALL

CALL

MOV

CALL

CALL

MOV

CALL

MOV

CALL

CALL

MOV

CALL

MOV

CALL

CALL

MOV

CALL

JMP

A, (FIRST+1)

A,LOBYTE (TO+1).A A,FIRST A.HIBYTE TO.A CRLF

R0.#FIRST

0UT4HS

OUTCH

OUTS

R0,#HIBYTE 0UT4HS A.#*-•

OUTCH

OUTS

R0.#LAST

0UT4HS

CRLF

R0.#FIRST

0UT4HS

A.#'-'

OUTCH

OUTS

R0.#HIBYTE

0UT4HS

A

OUTCH

OUTS

R0.#TO

0UT4HS

WARM

:STORE LOW BYTE OF SUM ;STORE HIGH BYTE OF SUM

;STORE LOW BYTE OF DIFFERENCE

;STORE HIGH BYTE OF DIFFERENCE ;POINT TO ADDEND

:POINT TO AUGEND

.•POINT TO SUM ;POINT TO SUBTRAHEND

:POINT TO MINUEND

;POINT TO DIFFERENCE

. Wwimi

JUMPTABL:

MOV

CALL

JMP

DPTR,#MJUMP

PDATA

WARM

PAGE

**************^* #4 , <l4ti([l|

routine pdata

WRITES A MESSAGE TO THE TERMINAL

244 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

July

; ENTER WITH DPTR POINTING

TO BEGINNING OF MESSAGE

; AND 04H

AT END OF MESSAGE

•

PDATA1: CALL

OUTCH

INC

DPTR

PDATA: CLR

A

MOVC

CJNE

RET

A,@A+DPTR

A,#EOT,PDATA1

;*************************************************************

•ROUTINE

IN

; READ AN

8-BIT CHAR FROM 8251A UART

IN: PUSH

DPH

PUSH

DPL

MOV

DPTR.#UARTCONT

MOVX

A, ©DPTR

JNB

ACC.1,$-1 ;

WAIT FOR RX RDY

DEC

DPL ;

POINT TO DATA REGISTER

MOVX

A,©DPTR

POP

DPL

POP

DPH

RET

;*************************************************************

• ROUTINE

INCH

; READ A

CHARACTER, ZERO HIGH BIT, k ECHO BACK TO TERMINAL

INCH: CALL

IN

READ 8-BIT CHAR.

ANL

A,#7FH

ZERO HIGH BIT

JMP

OUT

ECHO BACK

;*************************************************************

;ROUTINE

OUTCH

; OUTPUT

A CHARACTER

OUTCH: CALL

OUT

JNC

NOINPU

TEST FOR INPUT DURING OUTPUT

CALL

IN

GET RID OF THE CHARACTER

JMP

COOL

RESET STACK POINTER

NOINPU: RET

;*************************************************************

;ROUTINE

OUT

; SEND "A" REGISTER TO UART

; SET CARRY IF RX BUFFER IS FULL

OUT: PUSH

DPH

PUSH

DPL

PUSH

ACC

;SAVE OUTPUT BYTE

MOV

DPTR,#UARTCONT

MOVX

A,©DPTR

JNB

ACC.0,$-1

WAIT FOR TX EMPTY

MOV

C.ACC.1

MOV RX RDY TO CARRY

DEC

DPL

POINT TO DATA REGISTER

POP

ACC

RESTORE OUTPUT BYTE

MOVX

©DPTR,A

AND OUTPUT IT

POP

DPL

POP

DPH

RET

PAGE

30

Table caption* * * 4c ** 414c 41* *** * ** *** * *** **** ** ** ** ********* *********** **** ** * *

ROUTINE INHEX

READS 1 ASCII HEX CHAR, CONVERTS TO BINARY IN ACC. k STORES ORIGINAL CHAR IN B REG.

CARRY SET IF NOT VALID HEX, CLEARED OTHERWISE.

( 1 continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 245

July

INHEX:

CALL

INCH

;GET CHARACTER

MOV

B.A

; STORE IN B

CJNE

A,#CR,NOTCR

;IF <CR> SEND <LF> ALSO

MOV

a.#lf

CALL

OUTCH

NOTCR:

MOV

A.B

; RESTORE CHARACTER

JNB

ACC.6.$+5

; IF LOWER CASE

CLR

ACC. 5

;CONVERT TO UPPER CASE

CLR

C

SUBB

A.#’0’

JC

BAD

; ACC < * 0 *

SUBB

A.#10

JNC

$+7

; ACC > * 9 *

ADD

A,#10 ;RESTORE

LJMP

GOOD

; * 0 * <- ACC <« ’9'

ADD

A.K’e’+ie-'A'

’+10) ; CORRECT FOR (

JB

ACC.7,BAD

; *9* < ACC < ‘A*

CLR

C

SUBB

A,#16

JNC

BAD

; ACC > *F #

ADD

A.#16

GOOD:

CLR

C

RET

BAD:

SETB

C

RET

******************************#*********#*#**************,,,,„** ROUTINE BYTES

READ IN TWO BYTE HEX NUMBER TO HIBYTE.LOBYTE LAST CHARACTER READ RETURNED IN B REGISTER

ERROR CODES: CARRY: F0:

LEADING <CR> OR SPACE 0 1 (CHAR IN ACC)

LEADING NONHEX CHARACTER 1 1 (CHAR IN ACC)

OTHER NONHEX CHARACTER 1 0 (CHAR IN ACC)

BYTES:

SETB

F0

;NO HEX READ YET

CLR

A

MOV

HIBYTE,A

MOV

LOBYTE,A

MORE1:

CALL

INHEX

JNC

OKI |

iJUMP IF HEX DIGIT

MOV

A.B

;LOOK AT ASCII

CJNE

A,#CR,$+6

LJMP

CR1

CJNE

A,#SPACE,BAD1

CR1:

CLR

C

RET

OKI:

CLR

F0

MOV

R0,#LOBYTE

POINTER

XCHD

A,@R0

PUT 0 DIGIT IN LOW END OF LOBYTE

SWAP

A

ACC NOW HAS DIGIT 1 IN HIGH END

XCHD

A,@R0

ACC NOW HAS DIGITS 1.0

XCH

A,@R0

ACC HAS DIGITS 2,X;LOBYTE DONE.

DEC

R0

POINT TO HIBYTE

XCHD

A,@R0

ACC NOW HAS DIGITS 2.3

SWAP

A

ACC HAS DIGITS 3,2

XCH

A,@R0

HIBYTE DONE

JMP

MORE1

LOOK FOR ANOTHER DIGIT

BAD1:

SETB

RET

C

PAGE

19

;*************************************************************

•ROUTINE

BUILD ADDRESS

t

READ IN

A 16-BIT HEX NUMBER TO HIBYTE.LOBYTE.

»

RETURNS

WITH CARRY & F0 SET IF A SECOND COMMAND CHARACTER

Table captionIS FOUND. CHARACTER WILL BE IN ACCUMULATOR. RETURNS WITH CARRY SET AND F0 CLEAR IF NON-HEX.

246 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

I uly

Table captionBADDR:

Table captionADDRNOK:

CALL

BYTES

JNC

ADDROK

JB

F0.ADDRNOK

JMP

WARM

JB

F0.BADDR

RET

SECOND COMMAND CHARACTER ERROR

LEADING SPACE OR CR

Table caption*************************************************************

;ROUTINE

BUILD ADDRESS #2

; READ IN

A 16-BIT HEX NUMBER TO HIBYTE.LOBYTE.

; IGNORES

LEADING SPACES. RETURNS WITH F0 SET IF

; A LEADING CARRIAGE RETURN IS FOUND.

BADDR2: CALL

BYTES

JNC

$+5

LJMP

WARM ;NON-HEX

JNB

F0.ADDROK2 ;NUMBER READ

CJNE

A,#CR,BADDR2 ;IGNORE LEADING SPACE

ADDROK2:

RET

;*************************************************************

;ROUTINE

OUTPUT SPACES

; OUTPUTS

1. 2. 3, OR 4 SPACES

0UT4S: CALL

OUTS

0UT3S: CALL

OUTS

0UT2S: CALL

OUTS

OUTS: MOV

A.#SPACE

JMP

OUTCH

;*************************************************************

•ROUTINE

OUTPUT CODE, TWO HEX, SPACE

: OUTPUTS

PROGRAM MEMORY BYTE POINTED OUT BY DPTR

; AS TWO ASCII CHARACTERS FOLLOWED BY A SPACE.

; USES B REGISTER AS TEMP. STORE

OUTC2HS:

CLR

A

MOVC

A.@A+DPTR

MOV

B,A ;TEMP STORE

CALL

OUTHL

MOV

A.B

CALL

OUTHR

JMP

OUTS

I*************************************************************

;ROUTINE

MIDCHK

; INSERTS

A SPACE IF LOW NYBBLE OF DPTR « 8.

: RETURNS

WITH LOW NYBBLE IN ACC.

; DESTROYS B REGISTER.

MIDCHK: MOV

A.DPL

ANL

A.#0FH

XRL

A.#08H

JNZ

NOTMID

XCH

A.B

CALL

OUTS

XCH

A.B

NOTMID: XRL

A,#08H ;RESTORE A

Table captionRET

Table captionPAGE 14

Table caption*************************************************************

ROUTINES OUTPUT HEX LEFT

OUTPUT HEX RIGHT

CONVERTS A NYBBLE IN ACC. TO ASCII AND SENDS IT

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 247

July

OUTHL:

SWAP

A

OUTHR:

ANL

A,#0FH

JNB

ACC.3.H2

5 <8

JB

ACC.2,HI

:>-c

JNB

ACC.1.H2

;<A

HI:

ADD

A,#07H

H2:

ADD

A.#C0 # )

;CONVERT TO ASCII

JMP

OUTCH

PAGE

9

Table caption********************************************* *********** *****

ROUTINE

OUTPUT TWO HEX OUTPUTS HEX CONTENTS OF LOCATION POINTED OUT BY R0

0UT2H:

MOV

CALL

MOV

JMP

A,@R0

OUTHL

A,@R0

OUTHR

************************************************************* ROUTINE CRLF

SENDS A CARRIAGE RETURN AND A LINE FEED

CRLF:

MOV

CALL

MOV

JMP

A,#CR

OUTCH

A.#LF

OUTCH

*************************************************************

ROUTINE DECREMENT 16

DECREMENTS A 16-BIT NUMBER POINTED OUT BY R0.

ENTER WITH LOW BYTE @R0 k HIGH BYTE @(R0-1).

CARRY SET ON OVERFLOW, CLEARED OTHERWISE.

DEC16:

clr

C

DEC

@R0

MOV

A,©R0

CPL

A

JNZ

DECEND

DEC

R0

DEC

®R0

MOV

A,@R0

CPL

A

JNZ

DECEND

SETB

C

DECEND:

RET

PAGE

17

;*************************************************************

• ROUTINE

INCREMENT 16

INCREMENTS A 16-BIT NUMBER POINTED OUT BY R0.

ENTER WITH LOW BYTE @R0 k HIGH BYTE @(R0-1).

CARRY

SET ON OVERFLOW, CLEARED OTHERWISE.

INCI 6:

CLR

C

INC

@R0

MOV

A,@R0

JNZ

INCEND

DEC

R0

INC

@R0

MOV

A,@R0

JNZ

INCEND

SETB

C

INCEND:

RET

PAGE

20

;*************************************************************

•[routine

THREE ADRESSES

GETS THREE 16-BIT HEX NUMBERS AND STORES THEM IN

M FIRST

", "LAST", AND "TO" RESPECTIVELY.

248 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

THRADR: CALL

BADDR

JC

THRERR

MOV

FIRST,HIBYTE

MOV

(FIRST+1),LOBYTE

CALL

BADDR

JC

THRERR

MOV

LAST,HIBYTE

MOV

(LAST+1).LOBYTE

CALL

BADDR

JC

THRERR

MOV

TO.HIBYTE

MOV

(TO+1),LOBYTE

RET

THRERR: JMP

COOL

;*************************************************************

;ROUTINE

COPY

; COPIES

PROGRAM MEMORY LOCATED "FIRST" TO "LAST"

; TO RAM

LOCATION STARTING AT "TO"

CPY: MOV

DPH,FIRST

MOV

DPL,(FIRST+1)

CLR

A

MOVC

A.GA+DPTR

MOV

DPH.TO

MOV

DPL,(TO+1)

MOVX

@DPTR,A ;PUT DATA

MOV

A,FIRST

CJNE

A,LAST.CPY2

MOV

A,(FIRST+1)

CJNE

A,(LAST+1),CPY2

RET

;DONE

CPY2: MOV

R0,#(FIRST+1)

n CALL

I NCI 6

MOV

R0,#(TO+1)

CALL

INC16

JMP

CPY

;*************************************************************

•ROUTINE

OUT, 2 HEX, 3 SPACES

; OUTPUTS

LOCATION POINTED OUT BY R0 FOLLOWED BY 3 SPACES

OUT2H3S:

CALL

0UT2H

JMP

0UT3S

PAGE

11

; *************************************************************

;ROUTINE

OUTPUT R0

; OUTPUTS

THE CONTENTS OF R0

; (8051 CAN’T ACCESS SFR’S INDIRECTLY—UGH)

OUTR0: MOV

A,R0

CALL

OUTHL

MOV

A,R0

JMP

OUTHR

PAGE

9

;*************************************************************

•ROUTINE

OUTPUT R0, 3 SPACES

; OUTPUTS

THE CONTENTS OF R0 AND THREE SPACES

OUTR03S:

CALL

OUTR0

JMP

0UT3S

;*************************************************************

;ROUTINE

OUTPUT FOUR HEX. SPACE

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 249

OUTPUTS TWO CONSECUTIVE INTERNAL MEMORY LOCATIONS. OUT B? W R0 ° F WHICH ( HIGH BYTE 0F NUMBER ) Is POINTED

0UT4HS: CALL

0UT2H

INC

R0

CALL

0UT2H

JMP

OUTS

PAGE

;************»*********************,**,,,,, ***,#* ****************

FUNTAB:

;FUNCTION TABLE

DB

*A*

DW

ALTER

DB

’B*

DW

BREAK

DB

’C’

DW

COPY

DB

’D’

DW

DUMP

DB

•G*

DW

GO

DB

'H*

DW

HELP

DB

•r

DW

INSERT

DB

•J’

DW

JUMPTABL

DB

•M’

DW

MODIFY

DB

•V 1

DW

VERIFY

DB

’#•

DW

HEXMATH

DB

00H ;END OF TABLE

SFRTAB:

;SPECIAL FUNCTION REGISTER TABLE

DB

•P0 *, 04H

MOV

R0,P0

RET

CLR

F0

RET

DB

'SP *,04H

MOV

R0,SP

RET

CLR

F0

RET

DB

'DPL \04H

MOV

R0.DPL

RET

MOV

DPL.R0

RET

DB

*DPH • t 04H

MOV

R0.DPH

RET

MOV

DPL.R0

RET

DB

* PCON *,04H

MOV

R0,PCON

RET

MOV

PCON.R0

RET

DB

*TCON*,04H

MOV

R0.TCON

RET

MOV

TCON.R0

RET

DB

* TMOD *,04H

MOV

R0,TMOD

RET

MOV

TMOD.R0

RET

DB

’TL0 • # 04H

Table caption250 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

MOV

R0.TL0

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

CLR

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

RET

DB

MOV

RET

MOV

TL0.R0

•TL1 *,04H

R0.TL1

TL1.R0

•TH0 *,04H

R0.TH0

TH0.R0

*TH1 \04H

R0.TH1

TH1,R0

’PI ’,04H

R0.P1

P1.R0

* SCON *.04H

R0.SCON

SCON.R0

•SBUF*,04H

R0.SBUF

SBUF.R0

•P2 ’,04H

R0.P2

F0

'IE *,04H

R0.IE

IE ,R0

• P3 *.04H

R0.P3

P3.R0

•IP ’,04H

R0.IP

IP.R0

•PSW ’,04H

R0.PSW

PSW.R0

•ACC ’,04H

R0.ACC

ACC.R0

•B *,04H

R0.B

B,R0

Table captionRET

Table caption*************************************************************

MPROMPT:

DB

CR,LF,’UGH:*.04H

(continu«f)

Table captionBYTE LISTINGS SUPPLEMENT • 1ULY-SEPTEMBER. 1986 251

J uly

MHELP:

MBRK1:

MBRK2:

MBRK3:

MBRK4:

MBRK5:

MBRK6:

MINDEX:

MNONO:

MJUMP:

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

CR.LF,’REGISTER BANK 1 IS RESERVED’

CR,LF,* LAST 9 BYTES OF EXT. RAM USED BY BREAK ROUTINE*

CR,LF,’ RAM 0 48H-50H IS USED BY MONITOR*

CR.LF,’RAM ABOVE 50H IS USED FOR STACK’,LF CR.LF,’COMMANDS ARE *,LF

CR,LF,*A SSSS*,TAB,TAB,TAB,’ALTER EXTERNAL MEMORY*

CR,LF,*AI SS’.TAB,TAB,TAB,’ALTER INTERNAL MEMORY’

CR.LF.’B {AAAA {#}}*.TAB,TAB,’BREAK e AAAA (#-3,4,OR 5)

CR,LF,*C SSSS FFFF TTTT’,TAB,’COPY BLOCK OF MEMORY’

CR,LF,*D SSSS {FFFF}’,TAB,TAB,’DUMP PROGRAM MEMORY’

CR.LF,’DISS {FF}’,TAB,TAB,’DUMP INTERNAL MEMORY’

CR.LF,*G {AAAA}’,TAB,TAB,’GO @ AAAA OR BREAKPOINT’

CR.LF,*H’.TAB,TAB,TAB.’HELP’

CR.LF,* I SSSS FFFF HH’,TAB,TAB,* INSERT "HH” INTO MEMORY’ CR.LF,’J’, TAB, TAB,TAB, ’LIST JUMP TABLE’

CR.LF,*M SSSS’,TAB,TAB,TAB,’MODIFY EXTERNAL MEMORY (ASCII)’ CR.LF,’V SSSS FFFF TTTT’,TAB,’VERIFY MEMORY’

CR.LF,’# MMMM NNNN *.TAB,TAB,’HEX ADDITION & SUBTRACTION* CR.LF,04H

DB CR.LF,’BREAK AT LOCATION \04H

DB CR.LF,’ACC - \04H

DB ’ PSW - ’,04H

DB • B - *,04H

DB ’ DPTR - ’,04H

DB ’ SP - *,04H

DB CR.LF,* 01234567 89ABCDE F’,04H

DB CR.LF,’OOPS, THAT’,27H,’S A NO-NO !’,04H

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

DB

END

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

CR.LF,

’0026 *0029 ’ 002C

* 002F *0032 *0035 ’0038

* 003B ’ 003E *0041 *0044 ’0047 *004A

* 004D ’0050 *0053

COOL’,TAB, ’COOL START (RESET STACK POINTER)’ WARM’.TAB, ’WARM START’

IN’,TAB. ’GET A BYTE FROM THE UART*

INCH’,TAB, ’GET A CHARACTER (ZERO PARITY)’ INHEX’,TAB. ’GET A HEX CHAR (CARRY-NONHEX)’ BYTES’.TAB, *2 BYTE HEX TO HI/LOBYTE’

BADDR*,TAB, ’BUILD ADDRESS *

THRADR*,TAB, ’THREE ADDRESSES’

OUT’.TAB, ’OUTPUT BYTE IN ACC.’

OUTCH’.TAB, ’OUTPUT CHARACTER IN ACC.’

OUTS’.TAB, ’OUTPUT SPACE’

OUT2S*.TAB, ’OUTPUT 2 SPACES’

CRLF’.TAB, ’OUTPUT [CR] AND [LF]’

OUT2H*,TAB, ’OUTPUT LOC. POINTED BY R0’

OUTR0’,TAB, ’OUTPUT CONTENTS OF R0*

OUTC2HS*,TAB, ’OUTPUT PROG. MEM. POINTED* SPACE’

PDATA’.TAB, ’OUTPUT MESSAGE POINTED BY DPTR’ INC16’,TAB, ’INCREMENT 2 BYTE NO.’

* BY DPTR, AND CR.LF, *0056 CR.LF, *0059 ’ (R0-LOW BYTE)’

CR.LF, ’005C DEC16’.TAB, ’DECREMENT 2 BYTE NO ’ (R0+1-HIGH BYTE)’

CR.LF, *005F CPY’.TAB, ’BLOCK COPY’

CR.LF, *0062 BRKPT’.TAB. ’BREAKPOINT ROUTINE*

04H

252 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

density.src

Programming Insight:"PoIar Normal Distribution," by Alain Latour. August, page 131. Also see normal.src.

function NormDens (x : real) : real; const c - 0.3989422804; begin

NormDens :« c * exp(-sqr(x) / 2)

end;

function NormProb (x : Real) : Real;

const b0 - +0.319381530; bl = -0.356563782;

b2 - +1.781477937; b3 « -1.821255978; b4 - +1.330274429; p - +0.2316419; var Temp, t : Rea I;

Positive : Boolean;

begin

Positive :■ x > 0; x Abs(x);

t 1 / (1 + p * X);

Temp NormDens(x)*t*(b0+t*(b1+t* (b2+t*(b3+b4*t))));

If Positive then Temp :■ 1 - Temp; NormProb :■ Temp

end;

norma I.src

Programming Ins 1ght;"PoIar Normal Distribution," by Alain Latour. August, page 131. Also see density.src.

Program Norma I;

Var I : Integer;

Y1, Y2 : Real;

Freq : Array[0..30] of Integer;

Procedure Initialize;

Var I : integer;

Begin „ „

For i:> 0 to 30 do Freq[i] 0 End;

Procedure Classify (Y: Real);

Const MinY * -3.5;

YRange - 7.0;

NbClasses - 30;

Var Temp : Integer;

Begin

Temp Trunc((Y-MinY)/Y Ran 9«*NbCIasses);

If Temp < 1 then Temp :* 0

else if Temp > NbClasses then Temp NbClasses;

Freq[Temp] Freq[Temp] + 1 End;

Procedure NorDev (Var Y1, Y2 : Real);

Var VI, V2, S ; Real;

Begin

J The "Repeat until" loop Is repeated 1.27 times

* (continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 253

on the average with a standard deviation of 0.587 (c.f. D. Knuth (1969), page 104) } Repeat

VI :■ 2*Random -1;

V2 2*Random -1;

S Sqr(VI) + Sqr(V2) untiI S < 1;

S Sqrt(-2*In(S)/$);

Y1 V1*S;

Y2 V2*S

End;

Beg i n

Initialize;

For i:« 1 to 5000 do Begin

NorDev(Y1,Y2);

Classify(YI);

Classify(Y2)

End;

For I:«0 to 30 do

Wrlteln(I:6,Freq[I]:12)

End.

Iets.src

“Let’s C and CSD," by William Wong. August, page 267.

/* Byte Benchmark: Eratosthenes Sieve

02-22-86 WGW «« */

^define ITERATIONS 10 /* number of times to

perform test */

#def!ne LOCAL 1 /* use stack for flags */

#define GLOBAL 0 /* use global area for flags */

typedef char flag ; /* different types make a

difference */

#include <stdio.h> /* standard I/O definitions */

/*- Main Function - */

#deflne SIZE 7000 #if GLOBAL

flag flags [ SIZE + 1 ] ; /* prime number flag array */

#endlf

main ()

/*- Variable definitions - */

/* v

/* Note: only some register specifications will be used due to the */

/* limited number of registers available.

Normally, the first */

/* items are allocated to registers. */

register int 1 ; /* ordered by preference */

register int k ;

register int prime ;

register int count ;

register Int iterations ;

#if LOCAL

flag flags [ SIZE + 1 ] ;

/* prime number flag array */

#end!f

254 BYTE LISTINGS SUPPLEMENT • 1ULY-SEPTEMBER. 1986

/*- Show off start of execution -*/

printf ( "Starting Eratosthenes Sieve Benchmark\n\n" ) ;

printf ( "%d iterations.\n\n", ITERATIONS ) ;

for ( iterations * ITERATIONS ; iterations ; — iterations )

/* - 7 — Initialize Sieve Flag Array - */

for ( i » 0 ; 1 < SIZE ; ++ i )

flags [ i ] * 1 ; /* mark all as prime numbers */

/*- Search for Prime Numbers - */

for ( 1 ■ 0 /* scan for next prime number */

, count * 0 /* keep count of primes found */

; 1 < SIZE ; ++ i

If ( flags [ I ] !* 0 ) /* check if prime found */

/* - Prime found. Count it and unmark

multiples -*/

++ count ; /* increment number of primes */

for ( prime * i + 1 + 3

/* mark multiples as non-prime */

, k - 1 + prime /* start with first multiple */

; k < SIZE ; k +* prime

f lags [ k ] ■ 0 ;

/* reset multiples to non-prime */

\ ^

/*- Mark end of execution - */

printf ( "%d prime numbers found.\n", count ) ; printf ( "End of Test\n\n" ) ;

i

/* ..«« End of Eratosthenes Sieve Benchmark *==« */

. pa .

/* .... Byte Benchmark: Calculation Test 02-22-86 WGW *»«* */

#include <stdio.h> /* standard I/O definitions */

/* ===== Main Function *===* */

#define ITERATIONS 5000

main ()

i

float a, b, c ; int ! ;

/*- Show start of test - */

printf ( "Start of Calculation Test.\n\n" ) ;

/*- Perform test loop - */

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 255

for ( • ■ ITERATIONS /* setup for timing loop */

, o - 2.71828 . b - 3.14159 , c * 1

J I /* exit when end of test */

7*-Perform balanced set of calculations- */

c *- a ; /* same as c - c * a */

c *- b ; '

c /■ a ; /* same as c « c / a */

/*- Show end of test - */

prlntf ( "End of test. Accumulated error: %f\n\n\ c - 1 ) ;

/* —- End of Eratosthenes Sieve Benchmark */

.pa

/* «— Byte Benchmark: Write 64 kbyte file 02-22-86 WGW ===== */

^include <stdio.h> /* standard I/O definitions */

/* ■>» Main Test Function «»= */

#def!ne RECORDS 512 /* records in test file */ ^define REC_SIZE 128 /* size of records,

total is 64kbyes */

main ()

Int file ;

Int records ;

char buffer [ REC_SIZE ] ;

Int i ; /* buffer fill index */

static char filename [] * "B:TEST" ;

/*- Show start of test - */

printf ( "Writing TEST file.\n\n" ) ;

/* - Fill output buffer with recognizable

information -*/

for ( 1 * 0 ; 1 < sizeof ( buffer );++!) buffer [ 1 ] - I ;

/* - Write information

*/

if (( file * creat ( flle_name, 0 )) > -1 )

/* - pile opened, try writing all the records —

for ( records « RECORDS ; records ; — records ) if ( write ( file, buffer, sizeof ( buffer )) !« sizeof ( buffer ))

printf ( "Write error.\n" ) ; /* show error */ break ; /* exit from loop */

256 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

/* - Close down the file - */

close ( file ) ;

\

e I se

printf ( "Cannot open %s\n", file_name ) ;

/*- Show end of test - */

printf ( "End of Write Test.\n\n" ) ;

I

/* « End of Write 64 kbyte File Benchmark ===*= */

.pa

/* Byte Benchmark: Read 64 kbyte file

02-22-86 WGW «« */

#1ncIude <stdio.h> /* standard I/O definitions */

/* «««« Main Test Function ■«»* */

^define RECORDS 512 /* records in test file */

#define REC_SIZE 128 /* size of records,

total is 64kbyes */

main ()

Int file; int records ; char buffer [ REC_SIZE ] ; static char flle_name [] - "B:TEST" ;

/*- Show start of test - */

printf ( "Reading TEST file.\n\n" ) ;

/*- Read information - */

if (( file ■ open ( file_name, 0 )) > -1 )

/* - File opened, try reading all the records - */

for ( records - RECORDS ; records ; — records ) if ( read ( file, buffer, sizeof ( buffer )) !« slzeof ( buffer ))

printf ( "Read error.\n" ) ;/* show error */ break ; /* exit from loop */

\

/+ -Close down the file - */

close ( file ) ;

I

e I se

printf ( "Cannot open %s\n", filename ) ;

/*- Show end of test -*/

printf ( "End of Read Test.\n\n M ) ;

!

/* —- End of Read 64 kbyte File Benchmark ■»=* */

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 257

macapp.use

"MacApp: An Application Framework," by Kurt J. Schmucker. August, page 189.

{ The Smallest MacApp Application }

\ Copyright 1986 by Productivity Products International, Inc.}

{ The MAIN Program }

PROGRAM SmallApp;

USES

{ This set of units are portions of the Macintosh ROM }

MemTypes, QuickDraw, OSIntf, Toollntf,

{ This set of units are portions of MacApp }

UObject, UList, UMacApp, UPrinting,

I This unit has the SmaI IApp-specific classes }

USmalI App;

VAR aSmallAppIicatIon: TSmaI IAppIication; } The application object only one of these per application }

BEGIN

InitTooIbox(8); j initialize the ToolBox; 8 calls to MoreMasters {

InitPrinting; { Initialize the print shop }

New(aSmallAppIication);

aSmaIlAppIication.ISmaIlAppIication;

aSmallAppIIcation.Run;

END.

| *** The Unit it uses. This is typically in two separate files: one for the interface and one for the implementation. ***}

Inc. }

{ The Smallest Possible MacApp Application } j Copyright 1986 by Productivity Products International,

UNIT USmalIApp; INTERFACE

USES

{ This set of units are portions of the Macintosh ROM {

MemTypes, QuickDraw, OSIntf, Toollntf. Packlntf,

j This set of units are portions of MacApp }

UObject, UList, UMacApp, UPrinting;

CONST

myFIleType = ’MAMO’; { The file type ("MacApp MOuse’) for documents

of this appIicat ion }

mySignature * ’SMAP'; J The application signature of SMall Application }

myWindowType = 1001; { The resource ID of the WIND resource which

defines the windows used to

j display the documents of this application.

TYPE

TSmaI IAppI I cat ion = OBJECT(TAppIication)

{ - INITIALIZE THE APPLICATION - }

PROCEDURE TSmaI IAppIication.ISmaI IAppIication;

|-MAKE A DOCUMENT-}

FUNCTION TSmallAppIicat ion.DoMakeDocument(itsCmdNumber: CmdNumber): TDocument; OVERRIDE; 1

258 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

END;

TSmaIIDocument ■ OBJECT(TDocument)

{ -FIELDS-}

fSmallVIew: TSmallView;

{ - INITIALIZE A DOCUMENT - \

PROCEDURE TSmaI I Document.ISmaI I Document;

{ -MAKE A VIEW- \

PROCEDURE TSmalIDocument.DoMakeViews(forPrinting: BOOLEAN); OVERRIDE;

{-MAKE A WINDOW- \

PROCEDURE TSmalIDocument.DoMakeWindows; OVERRIDE;

END;

TSmallView - OBJECT(TVIew)

{-INITIALIZE A VIEW-}

PROCEDURE TSmalIView.ISmalIView(itsSmaIIDocument: TSmalIDocument);

{-RENDER THE IMAGE-}

PROCEDURE TSmalIVIew.Draw(area: Rect); OVERRIDE;

END;

IMPLEMENTATION

} Copyright 1985 by Productivity Products International, Inc.} { USmallApp Implementation }

* .

*****************************************************************************(

i t

***************************************************************************** j

METHODS FOR ALL THE SMALLAPP CLASSES

Note that methods are grouped by class and that the order of methods in any class is the following }

(by convention only, since Object Pascal forces no order): }

(1) the Initialization method, if any, }

(2) the Inspect method - a private debugging method, if needed }

(3) the Free method, if overridden, and}

(4) the remaining methods in alphabetical order. }

************************************************************************* } ************************************************************************* }

| ik************* TSmaI IAppIication Methods ********************* }

PROCEDURE TSmalIAppI I cat ion.ISmaI IAppIicat ion;

BEGIN

SELF.IAppIication(myFileType);

END;

j-MAKE AND INITIALIZE A DOCUMENT-}

FUNCTION TSmaI I App I 1 cation.DoMakeDocument(11sCmdNumber: CmdNumber):

TDocument; OVERRIDE;

VAR aSmalIDocument:TSmaIIDocument;

[continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 259

BEGIN

NEW(aSmalIDocument);

aSmalI Document.ISmaIIDocument;

DoMakeDocument :■ aSmaI I Document;

END;

{ *************** TSmaIIDocument Methods ********************** }

PROCEDURE TSmaI I Document.ISmaI I Document;

BEGIN

SELF.IDocument(myFI IeType, mySignature, TRUE, FALSE);

END;

{ - MAKE AND INITIALIZE ALL THE NECESSARY VIEWS - \

PROCEDURE TSmaI I Document.DoMakeViews(forPrInting: BOOLEAN); OVERRIDE* VAR smallView: TSmallView;

BEGIN

NEW(smalIView);

smaIIView.ISmalIView(SELF);

SELF.fSmaI IVIew :« smallView;

END;

|-MAKE ALL THE NECESSARY WINDOWS-}

PROCEDURE TSmaI I Document.DoMakeWindows; OVERRIDE;

VAR aWindow: TWindow;

BEGIN

aWindow ;■ NewSimp IeWindow(myWindowType, FALSE { NOT a DialogWindowf,

kWantHScrolI Bar, kWantVScrolI Bar,

SELF.fSmaIIView);

END;

| ************************** TSmallVie 1

PROCEDURE TSmaIIView.ISmalIView(itsSma VAR viewRect: Rect;

aStdHandIer: TStdPrIntHandIer;

BEGIN

SetRect(viewRect, 0, 0, 500, 500); IV!ew(NIL,

itsSmaI I Document, viewRect, sizeFIxed,

sizeFlxed,

FALSE, hlOff);

Methods ************************ | I Document: TSmaI I Document);

! This view has no parent view, and shows a smaI I Document,

I In a 500 x 500 rectangle, that does not change if the frame Is changed horizontally, or vertically,

i and can't make selections

and doesn't highlight when the window is inactive. \

New(aStdHandIer);

aStdHandIer.IStdPrintHandIer(SELF, FALSE); { The second parameter, ItsSquareDots. is FALSE since this application does not mix text and graphics. Slightly higher resolution is available with this setting. \

END;

}-RENDER THE IMAGE-}

PROCEDURE TSmaI IView.Draw(area: Rect); OVERRIDE;

FUNCTION MakeRect(top, left, bottom, right: INTEGER): Rect; VAR r: Rect;

BEGIN

SetRect(r, left, top, right, bottom);

MakeRect :* r;

END;

260 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

BEGIN

PenNorma1; PaintOval 1

'MakeRect1

[74, 72. 139, 127);

1; |

EraseOva1(

[MakeRect1

[84, 74, 138. 125);

1 ; |

FrameOva1 (

'MakeRect1

[109, 84, 129, 115;

1 );

EraseRect1

[MakeRect1

[109, 84, 123. 115]

i):

FrameOva11

'MakeRect1

[98, 87, 107, 96));

FrameOva11

[MakeRect1

98. 104, 107, 113)); {

PaintOva1 \

[MakeRect1

[101, 90. 104, 93)]

l; 1

Pa IntOva11

[MakeRect1

[101, 107, 104, 110)); \

PaintOval1

[MakeRect1

fill, 97, 117, 103)); I

PaintOva11

[MakeRect1

53, 52, 91. 90));

PaintOval(MakeRect1

[53. 110, 91, 148)); J

Outline of the mouse head Outline of the mouse face Mouse mouth (part 1 of 2) Mouse mouth (part 2 of 2) Left eye \

Right eye }

Left pupiI \

Right pupiI \

Nose \

Left ear \

Right ear }

Table captionFrameRect(MakeRect(20, 20, 170, 180));

A bounding rectangle \

END;

END.

mapper.bas

"Similarity Mapping," by Rob Spencer. August, page 85.

• similarity mapping

• I Robin W. Spencer

GOSUB Initialize GOSUB SetMenus GOSUB InputData GOSUB ShowTabIe GOSUB InitializeMap GOSUB ShowMap GOSUB RefineMap GOSUB ShowMap

WHILE NOT AI I Done

GOSUB WaitForMenu GOSUB HandleMenu GOSUB ShowMap

WEND

GOSUB ShowQuitBox

IF ButtonId-1 THEN RUN ELSE SYSTEM

subroutines

Initialize:

DEFINT I-n

WINDOW 1,,(0,20)-(512,340),3 CALL TEXTFONT(0):CALL TEXTSIZE(12)

CLS

True ■ -1 : Fa Ise ■ 0 AlIDone«FaIse MaxlteratIons«20 R - .15 : Criter ion ■ .2

xleft - 0 : xrlght - 512 * screen window in pixels

ytop - 20 ; ybottom ■ 320

xcenter ■ (xleft + xrlghO/2 ycenter * (ytop + ybottom;/2 DEF FNPx(x) - x*Scale + xcenter DEF FNPy(y) ■ y*Scale + ycenter RETURN

SetMenus:

MENU 1,0,1,"Control"

MENU 1,1,1,"Change Map"

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 261

MENU 1,2,1,"Show Table" MENU 1,3,0,"-"

MENU 1,4,1,"Quit"

MENU 2,0,0,"" MENU 3,0,0,"" MENU 4,0,0,"" MENU 5,0,0,"" RETURN

InputData:

PRINT:PRINT" Select the Input file:" InputFI Ie$ - FILES$(1,"TEXT")

OPEN InputF!Ie$ FOR INPUT AS #1

INPUT#1, Title$

INPUT#1, NumPoInts

NumPalrs - NumPoInts*(NumPoints-1)/2

abel$(Nillnp|int8) 0,nt8),X(NUmF,0intS),y(NUn ’ POints) ’ Dx(Nu,nPoints),Dy(NumPoints )' 1

FOR i-1 TO NumPoints INPUT# 1, Labe I $0 )

NEXT I

FOR i-2 TO NumPoints

FOR J-1 TO i-1

INPUT#1, d(i.J) <J(j.i)-d(i.j)

IF d(l,J)<0 THEN NEXT J NEXT i CLOSE#1 RETURN

NumPaIrs

NumPairs-1

Initial IzeMap: dmax-0

find the two most distant points FOR I«1 TO NumPoints-1

FOR j»I+1 TO NumPoints

IF d(I,J)>dmax THEN dmax-d(l,j) NEXT J NEXT I

J1-I : J2-J

xHO- 0 ; y(J1 )-0

x(j2)- dmax : y(J2)-0

Scale - .6*(xright-xleft)/dmax * scale in pixels per distance unit dnext«0

find the third most distant point FOR I«1 TO NumPoints

IF i-jl OR I-J2 THEN FirstLoop deIta-d(I.j1)+d(I,J2)-d(j1,j2)

IF de I todnext THEN dnext-deI to:j3=i FirstLoop:

NEXT I

x (J3)*d(J1,J3)-dnext/2 y(j3)-SQR(d(j1.J3)-2-x(J3)-2)

FOR 1-1 TO NumPoints Initialize all the other points

IF I-J1 OR i-J2 OR i-J3 THEN SecondLoop x(|)-(d(II,I)"2-d(j2.ir2+dmox-2)/(2*dmox) y( I )-SQR(ABS(d(j 1,1 )'"2-x( I)*2))

IF (x(!)-x(J3))*2+y(J3)~2 < d(j3,l)~2 THEN y(i)= SecondLoop:

NEXT I

-yo:

FOR I«1 TO NumPoints the coordinate set

x(I) ■ x(I) - dmax/2 NEXT I RETURN

center

RefineMap:

Converged - False : Iteration « 1 : OldError - 10000

262 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

WHILE NOT AIIDone AND NOT Converged AND Iteration < Maxiterations GOSUB IterateMap

IF MENU(0)>0 THEN GOSUB HandleMenu GOSUB ShowMap

IF ABS(PercentError - OldError) < Criterion THEN Converged * True IF PercentError > OldError THEN R * .7*R OldError « PercentError Iteration * Iteration + 1

WEND

Title$ - Title$ + " (final) 1 '

RETURN

IterateMap:

SumError*0

FOR i-1 TO NumPoints Dx(i)«0 : Dy(i)»0 NEXT i

FOR i-1 TO NumPoints-1 * calculate the changes Dx() and Dy()

FOR j«i + 1 TO NumPoints

IF d(i,j)<0 THEN InnerLoop * allow for unknown

distances

dcalc«SQR((x(i)-x(j))-2 + (y(i)-y(j))*2)

IF dcalc=0 THEN InnerLoop

delta « (d(I.j)/dcaIc-1)*(x(j)-x(i))

Dx(i)«Dx(i)-deIta Dx(j)»Dx(j)+deIta

delta * (d(i,j)/dcaIc-1)*(y(j)-y(i))

Dy(i)«Dy(i)-delta Dy(j)*Dy(J)+deIta

SumError = SumError + ((dcaIc-d(i.j))/d(i,j))^2 InnerLoop:

NEXT j NEXT I

FOR i-1 TO NumPoints ' make the changes to the points

x(i)»x(i) + Dx(1)*R y(i)-y(i) + Dy(i)*R NEXT i

PercentError ■ 100^SQR(SumError/NumPairs)

RETURN

WaitForMenu:

WHILE MENU(0)«0

WEND

RETURN

Hand I©Menu:

Itemld - MENU(1)

IF Itemld - 4 THEN AIIDone-True : RETURN ON Itemld GOSUB ShowPaneI.ShowTabIe MENU 1,0,1 RETURN

ShowTabIe:

CALL TEXTFONT(4):CALL TEXTSIZE(9): CALL TEXTMODE(1)

CLS

PRINT:PRINT" Distance table for ";Title$

IF Iterations THEN GOSUB SetFormat ELSE Formats*" #####*'

PRINT

FOR i-1 TO NumPoints

PRINT TAB(12+6*1);I;

NEXT i

PRINT:PRINT

Sum»0

FOR 1-1 TO NumPoInt*

PRINT USING"##) \ \";1,Lobel$(i);

FOR J-1 TO NumPoints

IF J<l THEN d-d(I.J) ELSE d-0

IF J>l AND Iterotlon>0 THEN d-SQR((x(I)-x(j))~2 + (y(i)-y(J))~2)

IF J>l AND d(I,J)>0 THEN Sum-Sum + (d-d(i,j)) A 2

IF d>0 THEN PRINT USING Formot$;d; : ELSE PRINT SPACE$(6);

NEXT J PRINT

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 263

NEXT I

PRINT:PRINT TAB(40);"observed \ caIcuIated":PRINT IF IteratIon>0 THEN PRINT USING" Average error - "+Format$+" SQR(Sum/NumPaIrs).PercentError

BUTTON 1,1."Ok",(400,280)-(480,310)

GOSUB GetButton BUTTON CLOSE 1 RETURN

SetFormat:

I ength-INT(.43*L0G(ABS(dmax)) ♦ 1.5)

Format$-" "♦STRING$(Iength,"#")+"."

WHILE LEN(Format$)<6 Format$-Format$+"#"

WEND

RETURN

ShowMap:

Cls

PRINT TItle$

PRINT USING" Iteration ##";Iteration

IF Iterations THEN PRINT USING" ###.# % error";PercentError FOR 1-1 TO NumPoInts

CALL MOVETO(FNPx(x(i)),FNPy(y(I)))

PRINT "E \-LabelS(i);

NEXT i RETURN

ShowPaneI:

WINDOW 2,,(3,24)-(509,48),-4 CALL TEXTFONT(0):CALL TEXTSI2E(12)

BUTTON 1,1, "rotate",(2.2)-(52,22)

EDIT FIELD 1,"0",(56,4)-(88,19)

RESTORE ShowPaneI x-94

FOR i-2 TO 8 READ IdS

BUTTON I,1,IdS>(x,2)-(x+52,22) x-x+54 NEXT I

DATA expand,shrInk,fI Ip,up,down,Ieft,rIght BUTTON 9,1,"Ok",(x.2)-(x+30.22)

WHILE DIALOG(0)<>0:WEND * flush pending dialog events Done-Fa Ise WHILE NOT Done

GOSUB GetButton GOSUB MoveMap WINDOW OUTPUT 1 GOSUB ShowMap WINDOW OUTPUT 2

WEND

WINDOW CLOSE 2 RETURN

GetButton:

Event-0 WHILE Eventol

Event - DIALOG(0)

WEND

Buttonld-DIALOG(I)

RETURN

MoveMap:

IF ButtonId-1 THEN IF ButtonId-2 THEN IF ButtonId-3 THEN IF ButtonId«4 THEN IF ButtonId-5 THEN IF ButtonId-6 THEN IF ButtonId-7 THEN IF ButtonId=8 THEN IF ButtonId-9 THEN RETURN

GOSUB RotateMap Scale-Scale*!.1 Sea Ie«ScaI e/1.1 GOSUB FlipMap ycenter » ycenter - 5 ycenter - ycenter + 5 xcenter « xcenter - 5 xcenter « xcenter + 5 Done-True

(###.# %)

264 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

RotateMap:

theta - VAL(EDIT$(1)) theta-theta*3.14159/180 s I ne*SIN(theta) : cos Ine«COS(theta) FOR i*1 TO NumPoInts

xt - xHHcosine - yfH*sine y(0* y(i)*cosine + x(i)*sine x(l)* xt NEXT i RETURN

FI

ipMap:

FOR 1-1 TO NumPoInts x(i)« -x(i)

NEXT I RETURN

ShowQuitBox:

WINDOW 2, "",(150,105)-(360,160),-2 BUTTON 1,1,"Run Again",(10,10)-(100,40) BUTTON 2,1,"Quit",(110,10)-(200,40 ) GOSUB GetButton WINDOW CLOSE 2 CLS

RETURN

micros.dat

"Similarity Mapping," by Rob Spencer. August, page 85.

Table caption"Cluster Example" 12

Ace,App1e

lie,Atar1

800,Comm

64,Compaq,IBM PC.Kaypro II

.Osborne

I.TI 99/4A.TRS Color/80

2.66

3.79 ,

2.61

3.94 .

2.82 ,

1.17

5.41 ,

5.46 ,

6.79 ,

6.34

4.15 ,

4.20 ,

5.23 ,

4.82 .

3.26

2.49 ,

4.07 ,

4.87 ,

4.98 ,

5.33 , 5.19

2.43 ,

3.57 ,

4.37 ,

4.47 ,

5.01 , 4.85 ,

0.99

4.33 ,

3.34 ,

1.10 ,

1.88 ,

7.41 , 5.66 ,

5.28 ,

4.80

4.18 ,

3.15 ,

1.02 ,

1.85 ,

7.30 , 5.52 ,

5.17 ,

4.69 ,

0.24

2.08 ,

2.12 ,

3.42 ,

3.33 ,

4.70 , 3.27 ,

3.63 ,

3.03 ,

3.99 . 3.84

4.69 ,

3.80 ,

1.83 ,

1.96 ,

7.36 , 5.46 ,

5.58 ,

5.13 ,

1.13 , 1.19

citles.dat

"Similarity Mapping," by Rob Spencer. August, page 85.

"Intercity distances"

9

Boston,NY,DC,Miami.Chicago Seattle,SF,LA,Denver 206

429. 233

1504,1308,1075 963, 802, 671,1329 2976,2815,2684,3273,2013 3095,2934,2799,3053,2142, 808 2979,2786.2631,2687,2054.1131, 379 1949,1771,1616,2037, 996,1307,1235,1059

cytoc.dat

"Similarity Mapping," by Rob Spencer. August, page 85.

"Cytochrome C sequence distances" 12

human,monkey,dog,horse,donkey pig,rabbit.kangaroo,duck pigeon,chicken,turtle 1

13,12

17,16,10 16,15, 8, 1

13.12, 4, 5, 4

12 . 11 , 6 , 11 , 10 , 6

12.13, 7,11,12, 7, 7

(continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER 1986 265

August

18,17,14,16.15,13.11,15, 3. 4 19,18,13,16,15,13.11,14, 7, 8. 8

17,16,12,16,15,13,10,14 16,15,12,16,15.13, 8,14, 3

factsum.bas

Mathematical RecreatIons:"Number Games," by Robert T. Kurosaka. August, page 333.

10 REM-< Sum-of-FactorI a Is Routine >—

20 REM-< Bob Kurosaka >—

30 REM

40 DIM A(10),B(100),F(10) :REM A()=digits, B()=sums, F()=factor la Is.

50 DATA 1,1,2,6,24,120,720,5040,40320,362880 60 FOR J»1 TO 10 70 READ F(J)

80 NEXT J 90 CLS

100 PRINT "Program generates factorial sum sequences."

110 PRINT

120 PRINT "Lower limit, upper limit 130 INPUT LL, UL 140 LL=ABS(INT(LL))

150 UL«ABS(INT(UL))

160 REM

170 FOR N-LL TO UL :REM Sequences for each no.

LL to NN

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

SP-0

:REM SP counts the steps before a cycle :REM Make the first term-N :REM Print the current term :REM Make a copy of latest term

B(SP)=N PRINT B(SP);

M»B(SP)

REM

REM Break up the term into its component digits :REM D ■ no.

REM T - no.

D-1

T«INT(M/10)

A(D)=M-10*T

of digits of "Tens" in M REM Store rightmost digit In array A D-D+1: M=T: GOTO 250

IF T<>0 THEN REM

REM Calculate the sum of the factorials of the digits in A()

SUM-0

FOR 1-1 TO D SUM-SUM+F(A(I ) + 1) NEXT I

REM See if sum has occurred already. 1=0

WHILE B(I)<>SUM AND I<»SP 1 = 1+1

WEND

IF B(I)=SUM AND I<«SP THEN 440 SP=SP+1 :REM one more step

B(SP)«SUM :REM Store SUM in array B

GOTO 200 REM

PRINT SUM; "* loops to step "; I :REM Show

where it repeats

PRINT

NEXT N

END

266

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

factsum.run

Mathematical Recreations:"Number Games," by Robert T. Kurosaka. August, page 333.

Table captionProgram generates factorial sum sequences. Lower limit, upper limit ? 24, 27

24 26 722 5044

loops to step 4

169 363601

1454

169 *

25 122 5 120 4 1454 169 * loops to

24 26 722

step 9

5044

169 363601

26 722 5044 169

to step 3

363601 1454

169

♦ loops

27 5042 147 5065

961 363601

1454

169

Table caption363601 * loops to step 5 Ok

cubesum.bas

Mathematical Recreations:"Number Games," by Robert T. Kurosaka. August, page 333.

10 REM-< Sum-of-Cubes Routine >

20 REM-< Bob Kurosaka >

30 REM

40 DIM A(10),B(100) :REM A() holds digits,

B() holds sums.

50 CLS

60 PRINT "Program generates sequences of cube-sums."

70 PRINT

80 PRINT "Lower limit, upper limit 90 INPUT LL, UL 100 LL-ABS(INT(LL))

110 UL«ABS(INT(UL))

120 REM

130 FOR N-LL TO UL :REM Sequences for each

no. LL to NN

140 SP-0

150 B(SP)«N 160 PRINT B(SP);

170 M-B(SP)

:REM SP counts the steps before a cycle :REM Make the first term-N :REM Print the current term

:REM Make a copy of latest term

180 REM

190 REM Break up the term into its component digits

200 D»1 :REM D - no. of digits

210 T-INT(M/10) :REM T - no. of "Tens" in M

220 A(D)«M-10*T :REM Store rightmost digit in array

230 IF T<>0 THEN D-D+1: M-T: GOTO 210

240 REM

250 REM Calculate the sum of the cubes of the digits In A()

260 SUM-0

270 FOR 1-1 TO D

280 SUM«SUM+A(I )*A(I)*A(I)

290 NEXT I

300 REM See If sum has occurred already.

310 1-0

320 WHILE B(I)<>SUM AND I<-SP 330 I-I+1 340 WEND

350 IF B(I)«SUM AND I<-SP THEN 400

A

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 267

360 SP-SP+1 :REM one more step

370 B(SP)»SUM :REM Store SUM In array B 380 GOTO 160 390 REM

400 PRINT SUM; "* loops to step I :REM Show where It repeats 410 NEXT N 420 END

cubesum.run

Mathematical RecreatIons:"Number Games," by Robert T. Kurosaka. August, page 333.

Table captionProgram generates sequences of cube-sums.

23

35

152

134

92

737 713 371

Lower 11

imit, upper

1imit ? 21, 25

loops

to step 7

21 9

729 1080

513 153 153 *

24

72

351

153

153

* loops to step

loops

to step 5

25

133

55

250

133

♦ loops to step

22 16

217 352

160 217 * loops to step 2

Ok

palind.bas

Mathematical RecreatIons:"Number Games," by Robert T. Kurosaka. August, page 333.

10 REM-< Palindromic Sums Routine >

20 REM-< Bob Kurosaka >

30 REM

40 SP$«" " :REM One space Inside quotes

50 D$«"0123456789"

60 YES-(I-I)

70 DIM A(100) :REM A() holds the the digits.

80 CLS

90 PRINT "Program generates sequences that end In pal Indromes."

100 PRINT

110 PRINT "Lower limit (>10) and upper limit ";

120 INPUT LL, UL 130 LL=ABS(INT(LL))

140 UL-ABS(INT(UL);

150 IF LL<10 THEN 110 160 FOR N-LL TO UL

170 SP-0 :REM SP counts the steps before a cycle 180 REM

190 REM Break up the term Into Its component digits 200 M-N :REM Make a copy of latest term

210 D»1 :REM D - no. of digits

220 T»INT(M/10) :REM T - no. of "Tens" in M 230 A(D)«M-10*T :REM Store rightmost digit in array A

240 IF T<>0 THEN D-D+1: M=T: GOTO 220

250 ODD-ABS ((I NT (D/2) <>D/2 ) ) :REM Even or odd

no. of digits?

260 REM

270 REM Print the latest term 280 FOR I-D TO 1 STEP -1 290 PRINT MID$(D$,A(I)+1,1);

300 NEXT I 310 PRINT SP$;

320 REM

330 REM Check for palindrome 340 FOR 1-1 TO D/2 350 PL«(A(I)*A(D-I+1))

360 IF NOT PL THEN I-D/2 :REM Exit from loop if no. Is not a pa I.

370 NEXT I

380 IF PL THEN 580

390 REM

400 REM Add each digit to its reverse Image counterpart

268 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

410 FOR 1-1 TO D/2+ODD 420 A(I)»A(I)+A(D-I+1)

430 A(D-I+1)-A(I)

440 NEXT I

450 REM Check for carry 460 FOR 1-1 TO D 470 IF A(I)<10 THEN 500 480 A(I)-A(I)-10 490 A(I + 1)-A(I+1)+1 500 NEXT I

510 IF A(D+1)-0 THEN 540 520 D-D+1

530 ODD-ABS((INT(D/2)<>D/2))

540 SP-SP+1 550 GOTO 280 560 REM

570 REM Indicate that a cycle has been found

580 PRINT "* at step M ; SP

590 FOR 1-1 TO D

600 A(I)=0

610 NEXT I

620 NEXT N

630 END

palind.run

Mathematical Recreations:"Number Games," by Robert T. Kurosaka. August, page 333.

Program generates sequences that end in pa Iindromes.

Lower limit (>10) and upper limit ? 75. 80

75 132 363 * at step 2

76 143 484 * at step 2

77 * at step 0

78 165 726 1353 4884 * at step 4

powser.bas

Mathematical Recreations:"Number Games," by Robert T. Kurosaka. August, page 333.

79 176 847 1595 7546 14003 44044 * at step 6

80 88 * at step 1 Ok

10 REM-< Delete and Add Routine >

20 REM-< Bob Kurosaka >

30 REM

40 N-50 :REM N-number of integers in starting

sequence.

50 DIM SF$(3), A(N) :REM SF$() holds suffixes,

A() holds sequence.

60 DATA nd, rd, th

70 FOR J-1 TO 3: READ SF$(J): NEXT J 80 REM 90 CLS

100 PRINT "Program uses a deIete-and-add process" 110 PRINT "to generate i^p for 1-1 to ";N; "/ p." 120 PRINT: INPUT "Enter a value for p (power)"; P 130 P-ABS(INT(P))

140 IF P<2 THEN 100 150 REM

160 PRINT: PRINT "Starting sequence:"

170 FOR 1-1 TO N 180 A(I)»I 190 PRINT I;

200 NEXT I 210 PRINT 220 REM

230 FOR R-P TO 2 STEP-1

{continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 269

240 DC-0 :REM Counts the number

of terms deleted.

250 FOR J-R TO N STEP R :REM Delete every Jth term

260 A(J)»0

270 DC-DC+1

280 NEXT J

290 REM

300 REM -< Print deleted orroy >

310 WSF«SGN(R-3)+2 :REM Select suffix

320 PRINT: PRINT "Delete every R; SF$(WSF);

M term:*'

330 FOR 1-1 TO N

340 IF A(I)<>0 THEN PRINT A(I); ELSE PRINT "*";

350 NEXT I 360 REM

370 REM -< Compute Partial Sums >

380 K-1

390 FOR J-2 TO N-DC :REM There will be N-DC

valid numbers.

400 K-K+1 :REM K points to next

term to be added.

410 IF A(K)«0 THEN K-K+1 :REM Skip zero (deleted)

terms.

420 A(J)«A(J-1)+A(K) :REM Calculate partial sum.

430 NEXT J

440 N-N-DC :REM Revise the number of valid terms In A().

450 REM

460 REM -< Print Partial Sums >

470 PRINT: PRINT: PRINT "Partial sums:" 480 FOR 1-1 TO N 490 PRINT A(I);

500 NEXT I 510 PRINT 520 NEXT R 530 END

powser.run

Mathematical Recreations:"Number Games," by Robert T. Kurosaka. August, page 333.

Program uses a deIete-and-add process to generate i^p for i-1 to 50 / p.

Table captionEnter a value for p (power)? 4 Starting sequence:

1

2 3

4

5

6

7 8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

De 1 <

jte every

4

th

term:

1

2 3

* 5

6

7

* 9

10

11 :

* 13

14

15 ■

17

18

19 * 21

22

23 *

25

26

27

* 29 30

31

* 33

34

35

*

37 38 39 *

41

42

43 *

Table caption46 47 * 49 50

Table captionPartial sums:

1 3

6

11

17 24

33

43

54 67 81

96

113

131

150

171

193

216

241 267

294

323

353

384

417

451

486

523 561

600 641

683

726

771

817

864

913

963

Delete every 3 rd term:

1 3*11 17 * 33 43 * 67 81 * 113 131 *

171 193 * 241 267 * 323 353 * 417 451 *

523 561 * 641 683 * 771 817 * 913 963

Partial sums:

1 4 15 32 65 108 175 256 369 500

671 864 1105 1372 1695 2048 2465 2916

3439 4000 4641 5324 6095 6912 7825 8788

270 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

Delete every 2 nd term:

1 * 15 * 65 * 175 * 369 * 671 * 1105 * 1695 * 2465 * 3439 * 4641 * 6095 * 7825 *

Partial sums:

1 16 81 256 625 1296 2401 4096 6561

10000 14641 20736 28561

Ok

readfort.me

"Object-Oriented FORTH," by Dick Pountain, August, page 227. Also see types.doc.

A minor addition concerning error handling must be made to the TYPES.SCR or TYPES.DOC code. In screen 2 of the source code, the system sets up a third stack called OSTACK, which incorporates no checking for underflow or overflow. In certain circumstances, overflow could occur. If you are debugging a new type and an operation crashes in such a way that FORTH executes an ABORT, OPOP wiI I never be reached and a stray item will be left on the OSTACK. If repeated enough, this could overflow the stack.

To solve the problem, you need to modify ABORT to reset OSTACK. The way to do this depends on your FORTH system.

This Is the actual code that you'll need:

: ORESET OSTACK DUP 16 ♦ SWAP ! ; ( Reset

OSTACK to empty)

: MYABORT ORESET ABORT ;

To replace ABORT by MYABORT, a variety of routes are open. In a good professional FORTH system, ABORT will be vectored through a variable, or other known memory location, to let you set up custom error handling. The variable might be called, for example, UABORT, and you would use:

* MYABORT UABORT !

You need to find out how It's done in your own system.

If your system does not provide vectored execution for ABORT, then you need to check out the internals of the definition of your ABORT, perferably by using a decompiler, but at worst by studying its hex dump.

At some point, usually at the very end, ABORT calls QUIT. If you can find the address of this call to QUIT (let's call it ZZZZ), then instead of MYABORT you can define:

: MYQUIT ORESET QUIT ;

and then do a dirty patch of MYQUIT into this address:

' MYQUIT ZZZZ l

Test the redefined ABORT carefully before proceeding, as a flaky ABORT is pretty explosive in effect.

types.doc

"Object-Oriented FORTH," by Dick Pountain, August, page 227. Also see readfort.me.

Screen # 1

0 ( Type definitions 1

2 ( Working variables for object compiler)

3 VARIABLE SIZE ( Holds storage size of type)

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 271

4 VARIABLE INHERIT

5 VARIABLE OPS

6 VARIABLE STASH

7 VARIABLE PUBLIC

8 VARIABLE LASTLOCAL

9 VARIABLE IN.TYPE.DEF?

10 VARIABLE VAL (

( Holds address of Inherited ops vocab)

( Holds address of end of ops vocabulary)

( Temporary store for current vocabuI ary)

( Holds link to ordinary dictionary)

( Holds address of last word In type)

( Flag; are we In a type definition?)

Flag; has a VAL Index been declared?)

11

12 0 CONSTANT FALSE FALSE NOT CONSTANT TRUE ( For readabiIIty)

13

14 ( I refuse to use THEN, which Is a syntactic

abomination!!)

15 ; ENDIF [COMPILE] THEN ; IMMEDIATE —>

Screen # 2

0 ( Type definitions 1

2 ( Make a third stack to hold current object's

address ; its size

3 determines how deeply type definitions may be compounded)

4 CREATE OSTACK HERE 16 + , 16 ALLOT

5

6 ( Push parameter stack to object stack)

7 : OPUSH OSTACK -2 OVER +! @ ! ; ( n - )

8

9 ( Pop object stack and discard)

10 : OPOP 2 OSTACK +! ; ( - )

11

12 ( Copy top of object stack and ADD to top

of parameter stack)

13 ; OCOP+ OSTACK © e + ; ( n - n )

14

15 — >

Screen # 3

0 ( Type definitions 1

2 ( Compile offset into instance variable and bump the total)

OFFSET SIZE @ 2 + , SIZE +!

( size- )

( Purely for brevity)

: COMPLIT [COMPILE] LITERAL

Table caption8 ( Compile code to add offset into object body)

Table caption9 : COMPILE.ADDOFF COMPLIT COMPILE OCOP+ ;

Table caption( size- )

10

11

( Create a new

instance variable of

12

: VAR CREATE

OFFSET

13

IMMEDIATE

14

DOES>

® COMPILE.ADDOFF ;

15

—>

Screen # 4

0 ( Type definitions 1

( Open a type declaration)

- LATEST PUBLIC !

CREATE

HERE LASTLOCAL !

0 SIZE !

TRUE IN.TYPE.DEF? ! FALSE INHERIT !

TYPE>

NFA of last public wor Make a header)

Store its PFA)

Initial I sat ions)

2

3

4

5

6

7

8 9

10 ( Mark boundary which hides the

Instance variables)

11 : OPS> HERE ( Address following

last VAR)

272 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

12

0 C,

13

LATEST ,

14

DUP CONTEXT ©

15

N>LINK OPS ! ;

( Make dummy name field)

( Link field points to last VAR)

( Let Forth know about dummy word)

( Save its LFA) —>

Screen # 5

0 ( Type definitions 1

2 ( Save current vocabulary; set operations

vocabuI ary)

3 ; UNLOCK CONTEXT © DUP © STASH ! ! ;

( key- )

4

5 ( Restore current vocabulary)

6 ; LOCK STASH © CONTEXT © ! ;

7

8 ( Look up an operation In its type vocabulary)

( key-CFA)

9 : FINDOP BL WORD SWAP ( Get operation name

10 UNLOCK FIND LOCK ( Find it)

11 0= ABORT" unrecognised operator " ;

( Abort if not found)

12

13

14

)

Screen # 6

0 ( Type definitions 1

2 ( Execute an operation immediately, if found)

3 : DO.OP SWAP OPUSH FINDOP EXECUTE OPOP ;

( addr key - ?)

4

5 ( Compile operation calling sequence)

6 : COMPILE.CALL COMPILE OPUSH , COMPILE OPOP ;

( CFA- )

7

8 ( Look-up operation and compile it)

9 : COMPILE.OP FINDOP SWAP COMPLIT

( addr key- )

10 COMPILE.CALL ;

11

12 ( Fetch size field contents from instance

variable or type)

13 ; SZ© 2 + © ; ( addr - size)

14

15 : SELF ; ( Optional; used for readability only) —> Screen § 7

0 ( Type definitions 1

2 ( Create an instance variable of a predefined type)

( addr-)

3 : MAKE.STRUCTVAR DUP SZ® ( get size)

4 SWAP © ( fiat

5 CREATE . OFFSET ( Store key and size)

6 IMMEDIATE

7 DOES> DUP @ SWAP SZ® 2 - ( Get key and offset)

8 COMPILE.ADDOFF ( Compile code_ )

9 FINDOP ( to treat as. )

10 COMPILE.CALL ; ( an object. )

11

12 ( Compile or interpret an operation

according to state)

13 : DO.OR.COMP STATE © IF COMPILE.OP

( addr key- )

14 ELSE DO.OP

15 ENDIF ; —>

Screen # 8

0 ( Type definitions 1

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 273

2 ( Allot space Initialised to zeroes)

3 : ALLOTZ DUP HERE SWAP 0 FILL ALLOT ; ( n - )

4

5 ( Execute an operation called INIT if

there is one)

6 : INITIALIZE SWAP OPUSH

7 UNLOCK LIT” INIT" FIND LOCK

8 IF EXECUTE ELSE DROP ENDIF OPOP ;

9

10 ( Create a new Instance of a type)

( addr )

11 : MAKE.INSTANCE CREATE HERE SWAP

12 DUP 9 DUP . ( Store key into Instc)

13 SWAP SZ® ALLOTZ ( Allot Its storage)

14 INITIALIZE IMMEDIATE

15 DOES> DUP 9 DO.OR.COMP ; —>

Screen # 9

0 ( Type definitions 1

2 : INCLUDE> * >BODY 9 INHERIT l ;

( Inherit ops from old type)

3

4 ( Juggle dictionary pointers to seal the type body)

5 : LINKS HERE BODY> >LINK PUBLIC 9 SWAP I ( - )

6 LASTLOCAL 9 BODY> >NAME OPS 9 l

7 INHERIT 9 LASTLOCAL 9 BODY> >LINK l ;

8

9 ( Close type declaration)

10 : ENDTYPE> LATEST CREATE LINKS

( Close the body)

11 , SIZE 9 , ( Store key and size)

12 FALSE IN.TYPE.DEF? I

13 DOES> IN.TYPE.DEF? 9 IF MAKE.STRUCTVAR

14 ELSE MAKE.INSTANCE

15 ENDIF ; —>

Screen # 10

0 ( Array definitions 1

2 ( Calculate address of array element)

3 : INDEX+ ROT * + ; ( Index PFA width addr)

4

5 ( Interpret an array operation)

( index PFA key - )

6 : ARRAY.DO.OP FINDOP ( Get operation CFA)

7 ROT ROT 4 + DUP 9

( Get width of element)

8 INDEX+

( Calculate element address)

9 OPUSH EXECUTE OPOP ; ( Do it!)

10

11 ( Place index on stack at compile time)

12 : VAL[ TRUE VAL ! [COMPILE] [ ; IMMEDIATE

13

14 ( Reset the VAL flag)

15 : -VAL FALSE VAL ! ; —>

Screen # 11

0 ( Array definitions 1

2 ( Compile an array operation)

( {index} PFA key - )

3 : ARRAY.COMP.OP FINDOP >R

( Get op CFA and stash it)

4 4 + DUP 9

( Get width of array)

5 VAL 9

( Index at compile time?)

6 IF INDEX+ COMPLIT ( CompiIe el. addr)

7 ELSE SWAP COMPLIT COMPLIT

( or code to calc )

8 COMPILE INDEX+ ( at runtime)

9 ENDIF

274 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

10

11

12

13

14

15

R> COMPILE.CALL ~VAL ;

( comp!Ie op call)

Compile or interpret an array op) index PFA key - )

ARRAY.DO.OR.COMP STATE @ IF ARRAY.COMP.OP

ELSE ARRAY.DO.OP END IF ; —>

Screen # 0

12

Table captionArray definitions

Table captionCreate a typed array as an instance variable) count PFA-)

Table captionARRAY.VAR CREATE DUP ® , OVER ,

( Store key and

count)

3

SZ® DUP ,

( Store

width of element)

4

*

( Size

■ count * width)

5

OFFSET

( Store

offset etc.)

6

IMMEDIATE

7

DOES> DUP

@

( Get key)

8

FINDOP >R

( Get op CFA and stash it)

9

DUP 6 + @

( Get offset)

10

2 - SWAP 4

+ @

( Get width)

11 (

; Compile el addr) VAL

® IF

INDEX* COMPILE.ADDOFF

12 |

r or code to...)

ELSE

SWAP COMPLIT COMPLIT

13 1

{ calculate It..

.)

COMPILE INDEX*

14 1

[ at runtime)

COMPILE OCOP+

Table caption15 ENDIF R> COMPILE.CALL ~VAL

Table caption—>

( count PFA - )

Screen § 13

0 ( Array definitions 1

2 ( Make a new array instance)

3 : MAKE.ARRAY CREATE 2DUP •

( Store key and count)

4 SZ® DUP , SWAP

( Store width)

5 * ALLOTZ

( AI lot the space) IMMEDIATE

DOES> DUP ® ARRAY.DO.OR.COMP

6

7

8 9

Create an array object or variable)

10

11

12

13

14

15

count +++ : ARRAY-OF

)

>B0DY IN.TYPE.DEF? ® IF ARRAY.VAR ELSE MAKE.ARRAY ENDIF ;

Screen # 14

DATA STRUCTURES EMPLOYED INTERNALLY

0 (

1

2 OBJECT

3

4

5

6

7

8 9

10 11

12 TYPE DEFINING WORD

13

Table captionwidth

+-+

| header | key

-+

i

storage

fields

—+ i

ARRAY-OF OBJECTS

| header | key

| count

| width

| elements

i

—+

14 | header | key | size |

15 +-+-+-+

Screen # 15

0 (

1 VAR NAME

2 +-+-+

3 | header | offset |

4 + -+-+

5

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 275

August

6 STRUCTVAR NAME

8 | header | key | offset |

9 +-+-+-+

10

11 ARRAY.VAR NAME

12 +-+-+-+-+-+

13 | header | key | count | width | offset j

14 +-+-+-+-+-+

15

276 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

breakpt.asm

Programming InsIght:"BrookIng Out," by Edward Batutis. September, page 127. Also see brkptcom.bas.

; BREAKPT

; Copyright 1985, Edward Batutis

; Invokes the breakpoint Interrupt when Ctrl-Shift-Shift ; combination Is pressed.

; Assembled with the IBM Macro Assembler Version 1.00

cseg segment

para

public 'code*

assume

csrcseg,

dsrcseg

org

100h

breakpt proc

Jmp

instal1

copyright

db

•BREAKPT (c) Copyright 1985

db

* Edward J. Batutis•,01ah

old_int9_vector

label

dword

old_lnt9_offs

dw

?

old_int9_seg

new_J nt9:

dw

?

Table caption; call old keyboard routine by simulating an Int pushf

ca 1 1

cs:o1d_lnt9_vector

push

es ;

save registers

push

ax

push

bx

mov

ax,40h ;

look at keyboard flagl in

mov

es.ax ;

ROM BIOS data area

mov

bx,17h

mov

a 1,es:[bx]

and

a 1,07h ;

mask off everything but lowest

*

three bits

cmp

a 1 ,7 ;

are Ctrl-Shift-Shift depressed?

jne

quit ;

no, quit

; turn

on the trap flag

pop

bx ;

restore registers

pop

ax

pop

es

push

ax ;

save register

pushf

*

get flags into ax

pop

ax

or

ax,0100h ;

set trap flag on

push

popf

ax ;

put new flags back

pop

ax ;

restore ax

nop

!

wait one Instruction

Table captionIret ; debug is invoked at this instruction

[continued]

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 277

quit:

P°P *> x ; restore registers when

Pop ax • quitting

pop es

done:

iret

END_OF_RESIDENT_C0DE LABEL BYTE

banner db InstalI:

mov

mov

int

cmp

Jo

mov

mov

mov

mov

Int

mov

mov

mov

Int

mov

Int

*BREAKPT installed.’,10,13,'$'

; get interrupt vector for ; keyboard interrupt

interrupt vector function interrupt 9

; are we already installed?

; yes, just exit

; save old keyboard Interrupt ; address

ah,35h ; get

al,9 ; get

21 h

bx,offset new_int9 no_instalI

oId_lnt9_of f8,bx oId_int9_seg,es

dx,offset banner ah, 9 21 h

ah,25h al ,9

dx,offset new_Int9 21 h

; print banner ; print string function

; set keyboard Interrupt ; to point to new_int9 ; set Interrupt function ; set Interrupt 9 ; point to new routine

terminate, but stay partially resident point to last byte of resident routlnes+1

dx.offset END_OF_RESIDENT CODE+1 27h

no_instalI:

int 20h

breakpt endp

cseg ends

end breakpt

don't instalI, Just exit

brkptcom.bas

Programming Insight:"Breaking Out," by Edward Batutis. September, page 127. Also see breakpt.asm.

100

110

120

140

150

160

170

180

190

200

210

220

230

240

250

260

270

280

'RUN THIS PROGRAM TO CREATE breakpt.com PRINT "Creating breakpt.com" OUTFILE$*"breakpt.com"

DATA &hEB, &h74, &h90, &h42, &h52, 4h45, DATA &h20, &h28, &h63, &h29, &h20, &h43, DATA &h69, &h67, &h68, &h74, &h20, &h31, DATA &h20, &h45, &h64, &h77, &h61, &h72, DATA &h20, &h42, &h61, &h74, &h75, &h74, DATA &h00, &h00, &h00, &h9C, &h2E, &hFF, DATA &h50, &h53. &hB8, &h40, &h00, &h8E, DATA &h26, &h8A, &h07, &h24, &h07, &h3C, DATA &h58, &h07, &h50, &h9C, &h58, &h0D, DATA &h58, &h90, &hCF, &h5B, &h58, &h07, DATA &h41, &h4B, &h50, &h54, &h20, &h69, DATA &h6C, &h6C, &h65, &h64, &h2E, *h0A, DATA &hB0, &h09, &hCD, &h21, &h81, &hFB, DATA &h89, &h1E, &h31, &h01, &h8C, &h06, DATA &h01, &hB4, &h09, *hCD, &h21, &hB4,

&h41,

&h6F,

&h39,

&h64,

&h69,

&h1E,

&hC0,

&h07,

&h00,

&hCF,

&h6E,

&h0D,

&h35.

&h33,

&h25,

&h4B, &h70, &h38, &h20, &h73, &h31, &hBB, &h75, &h01, &h42, &h73, &h24, &h01, &h01, &hB0,

&h50, &h79, &h35, &h4A, &h1A, &h01, &h17, &h0E. &h50, &h52, &h74, &hB4, &h74, &hBA, &h09.

&h54 &h72 &h2C &h2E &h00 &h06 &h00 &h5B &h9D &h45 &h61 &h35 &h ID &h61 &hBA

278 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

290 DATA 4h35. 4h01, 4hCD, 4h21. 4hBA, 4h62. 4h01. 4hCD, 4h27, 4hCD 300 DATA 4h20 310 TOTAL- 161

320 OPEN OUTFILE$ AS #1 LEN-1 330 FIELD #1.1 AS A$

340 FOR 1-1 TO TOTAL

350 READ A

360 LSET A$-CHR$(A)

370 PUT 1

380 NEXT 390 CLOSE 400 PRINT"Done."

410 END

ccitt.c

Programming Project:"CaIcuI ating CRCs by Bits and Bytes," by Greg Morse. September, page 114. Also see xmodem.c, sdlc.asm, and xmodem.asm.

/* Straightforward, non-optimlzed CRC-CCITT routine */

/* Assumes 16-bit integer variables */

/* MSB of integer is MSB of CRC result */

#define POLY 0x8408

/* POLY - 1021 In bit rev order*/

BLKCRC(bufptr, crcres, count) unsigned char *bufptr; unsigned Int *crcres, count;

^ Int i;

♦crcres - 0; /* for SDLC use 0xFFFF */

for (1-1; !<-count; ++1, bufptr++) /* do for whole BLK*/ bytecrc(bufptr, crcres) /* do CRC for 1 char */ return (*crcres);

} /* end BLKCRC */

bytecrc(bufptr, crcres) unsigned char *bufptr; unsigned Int *crcres;

unsigned Int j,ch,Q;

ch - (unsigned int) *bufptr; /* get char, to int fmt*/ for (J-1; j<«8; J++) | /* do each bit LSB 1st */

Q-(*crcres&0x0001)^(ch&0x0001)/* Q-R0 XOR D */

If ( Q — 0x0001) { /* Q is one */

♦crcres- *crcres»1; /* shift right one */ ♦crcres- *crcres~POLY; /* XOR with number */

else /* Q is zero */

♦crcres- *crcres»1; /* just shift no XOR */ ch - ch »1; /* move next data bit*/

/* into position */

} /* end FOR - data bits all done */

return (*crcres); f /* end bytecrc */

exps.st1

"Atari ST Software Development," by Michael Rothman. September, page 223.

********** Example 1 **********

/* format.c */

/* Format a floppy disk on the ST. Return 0 If sucess,*/ else non-zero.

Edit History:

000 19-Sep-85 MR Creation

001 07-Feb-86 MR Modified for BYTE article [continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 279

/* #deflne DEBUG 1 */

#fnclude <osblnd. /* C bindings for OS routines */

#deflne HITRACK 79 /* Highest numbered track */

fdeflne SECTORS 9 /* Sectors per track */

#deflne MAGIC 0x87654321L/* Required by Flopfmt() */

#deflne VIRGIN 0xE5E5 /* Pattern to write to sectors */ #deflne ILEAVE 1 /* Interleave factor */

fdeflne DISKTYPE 2 /* Single side, 80 track */

fdeflne NOLOAD 0 /* No loader code In boot sector */

fdeflne RANDOM 0x1000000L/* make protobt make a random */

fdeflne BOOTSECT 1 /* Side 0, sect 1 gets boot sect */

fdefine TRACK0 0 /* Track for boot sector */

fdeflne SIDE0 0 /* Format side 0 */

extern void errprlnt();

/* error notification routine */

format(devno)

Int devno; /* device holding media to format */

/* Automatic variables */

/* count tracks */ register Int I;

/* buffer for track, protoboot */ register char *buf;

/* success In format? */ register Int succ, totsucc » 0;

/* doesn't do anything */ long fI I Ier;

/* Code */

/* Allocate memory for track. The ST formate one track at a time, and requires sufficient RAM to verify that track in memory. Malloc Is a GEMOOS call. */

buf « MaIloc(8192L);

#1fdef DEBUG

errprlnt(0, "insuff memory for format"); #endif

return(-l);

/* Format each track. VIRGIN is the value to write to the newly formatted track. This particular value (0xE5E5) is suggested in the documentation, but many values are possible. Flopfmt is XBIOS. */ for (i-HITRACK; l>«0; i—)

succ = Flopfmt(buf, filler, devno, SECTORS.

i. SIDE0, ILEAVE, MAGIC. VIRGIN); totsucc +* succ;

/* Release memory. GEMDOS */

Mf ree(buf);

/* For the purposes of this routine, I won’t accept any bod sectors. But, if there were any, their numbers would have been left in the buffer, buf, after each track was formatted. I could alternatively retried, or recorded the bad sectors if I were developing my own file system. */

if (totsucc !» 0)

#1fdef DEBUG #endIf

I

errpr!nt(totsucc, "format failed"); return(-1);

280 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

/* Now we need to put a boot sector on the disk. */

/* Allocate a 512 byte buffer */ buf - Mai Ioc(512L);

/* Prototype a boot sector in that buffer.

The second parameter is a serial number for the disk. The value I have chosen asks the XBIOS to generate a random number. XBIOS */

P r o t o b t(b u f,RANDOM,DISKTYPE,NO LOAD);

/* Write out the boot buffer to track 0, side 0.

Last parameter is how many sectors to write. */

succ - FIopwr(buf.filler,SIDENO,BOOTSECT,TRACK0,SIDE0,1);

/* Throw away memory */

Mf ree(buf);

/* Return success or failure */ return (succ);

\

********* Example 2 ********

This is a trap handler of the sort you might use if you were programming the ST in 68000 assembler, or you were using a high level language and needed to write a binding for access to a BIOS, XBIOS or GEMDOS function. The functions assume the C calling conventions, that is, if there are any parameters, they are assumed to have been pushed onto the stack In reverse order, and to be no smaller than a word (16 bits). The number of the routine itself must be pushed last, Just before the trap call. Of course if you are developing using the C provided in Atari's kit for developers, this process will be transparent to you, since a set of bindings is available which makes TOS calls look Just like ordinary C function calls.

; At entry, any arguments for the function have been pushed on the stack

; In reverse order, C-style. Then the function number was pushed.

; Finally this routine was called, so as we enter the return address of

; the caller Is on top of the stack.

retsv: ds.l ; some memory for a long variable

traprtn:

move.I (a7)+, retsv trap #13

move.I retsv, -(a7) rts

Save off the return address, because the OS functions don't expect it.

Trap to the BIOS function. (BIOS is available through trap 13, XBIOS through 14, GEMDOS through trap 1).

Put the return address back on stack.

Return to caller.

********** Example 3 **********

/* SAMPLE.C Original version provided by Atari as part of the developer's kit. Rearranged, cleaned up, defines added, many variable names changed,and all comments added by M.R.

*/

/* This program is a simple example of use of some

( continued )

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 281

VDI primitives and certain parts of the AES, In particular the window library and the event handler. It opens a window on the desktop and draws a filled ellipse In It.

It waits for the user to move the window or resize It and then redraws the ellipse. If the user selects the window close box, the program closes the window and then terminates.

*/

/* Defines. These ore all Just for readtblllty. */

Idefine COLOR0 0 7 '

Idefine COLOR1 1 #deflne SCREEN 1 Idefine SOLID 1 Idefine PATTERN 2 #define USER 4 #deflne DOT 1 Idefine SYSTEM 1 Idefine RC 2 Idefine ARROW 0 Idefine WORKAREA 4 Idefine WNAME 2 Idefine WINDAREA 1 #deflne CLIPON 1 #define WM.REDRAW 20 idefine WM.CLOSED 22 idefine WM.SIZED 27 Idefine WM_MOVED 28 idefine WF_CURRXYWH 5

/* Window type bits */ idefine NAME 0x0001 Idefine CLOSE 0x0002 idefine MOVE 0x0008 Idefine SIZE 0x0020

/* These arrays are used by the VDI In Its own code. The developer Is expected to allocate room for them somewhere In the application. */

Int contrI[12], lntin[256], ptsin[256], lntout[256l. ptsout[256];

main()

{

/* Local variables */

/* For the workstation */

Int workln[l0]; /* Input values for v_openvwk() */ Int workout[56]; /* Ouput values for v_openvwk() */ Int shandle; /* Workstation (screen) handle */

/* Variables for our appIIcatIon's window */

Int

Int

Int

whandle; w!nd_type; xwork;

Int ywork;

Int wwork; Int hwork; int xbord;

Int ybord;

Int

Int

Int

/* Window handle */

/* Holds window attribute bits */

/* X coordinate, upper left hand corner, work area of window */

/* Y coordinate, upper left hand corner, work area of window */

/* Width, work area of window */

/* Height, work area of window */

/* X coordinate, upper left hand corner, border of window */

/* Y coordinate, upper left hand corner, border of window */

Width, border area of window */ Height, border area of window */

/*

/•

wbord; hbord;

xcen, ycen; /* Coordinates of central point i^window */

/* These four variables are returned by graf_handIe() (described later). They are not used further in this applIcation. */

Int gr_wchar, gr — hchar; /* Width and height of a character

282 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

cell for font used In menus and dialogs */

int gr wbox, grjibox; /* Width and height of box large

enough to hold a system font character */

/* Mi see I Ianeous */

int ap_id; /* Application id */

int cl!p[4]; /* Holds coordinates defining clip region */

Int mgbuf[8]; /* Buffer for message events from AES */

int dummy; /* Word buffer for miscellaneous use */

/* Begin program */

/* AppI_Init Is the AES initialization routine.

It makes the AES aware of the application, and Initializes certain AES data structures. The application id It returns can be used later by the application for other AES routines. */

ap_Id = appl_Inlt();

/* When the application starts, GEM has already opened the screen workstation for its own use. Therefore the screen has a workstation handle (identifier). We need this handle to open our own virtual workstation with the attributes we would like. The routine graf_handle (part of the AES graphics library) returns this handle.

It also puts certain character size info Into the passed parameters (which we don't happen to need). */

shandle - graf.handIe(&gr_wchar,&gr_hchar,&gr_wbox,&gr_hbox);

/* Now we can open a virtual workstation. If the attributes of the GEM opened physical workstation were to our liking, we could just use it. Or we could change the attributes with VDI attribute calls. As often Is the case, GEM provides redundancy - a decision as to elegance is up to you.

The workin array will define the default attributes we want. Note these are all defaults. We will modify some during the main loop of the program. */

/* The device type - 1 is for screen */ work In[0] - SCREEN;

/* Set the line type to a solid line */ work!n[1] * SOLID;

/* Polyline color index to 1 (The background color defaults to whatever Is In color register 0.

The foreground to whatever is In register 1. So by selecting 1, we are selecting the default foreground color. Incidentally, on a monochrome system. 0 defaults to white, and 1 to black. Thus the screen has that black on white, Mac-1 Ike appearence). */ work!n[2] - C0L0R1;

/* Marker type 1 - which happens to be a dot.

This is set for completeness; there is no use of the polymarker routine In this application. */ workln[3] ■ DOT;

/* Polymarker color set to 1. Ditto */ workln[4] - COLOR1;

/* Text face to the system face */ work In[5] - SYSTEM;

/* Text color */ workln[6] - C0L0R1;

/* Fill interior style. The available styles for a fill are hollow, solid, pattern, hatch, and user-defined. Hollow fills with the background color (index 0).

(continued)

BYTE LISTINGS SUPPLEMENT • IUIY-SEPTEMBER. 1986 283

Solid with the currently selected fill color. The other three choices are further modified by the fill style Index (see the next entry In array) to pick the fill pattern.

*/

workin[7] - SOLID;

/* Fill Index style. This modifies fill Interior style to seIect the actual fill style (unless the Interior style is solid or hollow). We’ll Just select the default 1. */ workln[8] - 1;

/* Fill color. */ workfn[9] - C0L0R1;

/* The last entry In the array selects either roster coordinates (machine specific) or normalized device coordinates (portable). */ workin[10] ■ RC;

/* Open our virtual workstation, passing It the Input orray, the physical workstation handle, and the ouput array. Note, the virtual workstation’s handle Is returned In the same variable which held the physical handle. A VDI routine. */

v_opnvwk(workIn, ishondle, workout);

/* Set the mouse cursor form to the arrow. Yes, this is the default anyway, but this is supposed to be an example program, you know? The second parameter In grof_mouse Is a dummy In this case. If the mouse form selected was not pre-deflned, the second parameter would have to be a pointer to a mouse form definition block - a data structure for defining a mouse-driven cursor. Graf_mouse Is an AES routine. */

g r a f_mou se(ARROW,idummy);

* Time to get Into the meat of the problem. We want to create a window for our application. The first thing to do Is get the size of the desktop window. This Is a window GEM creates when the system boots. Since it occupies the entire screen. It Is a guide to the maximum area our application can use. The function wlnd_get can be used to get various values; here we are going to get the size of the work area (area not Including border) of the desktop window (the first parameter is 0, Indicating the desktop window). Since we Intend OUR window to use this entire area, we put the results Into the variables we will be using to define the border of our window. This and all the functions beginning wlnd_ are AES functions. */

wlnd_get(0.WORKAREA,&xbord,&ybord.&wbord,*hbord);

/* Now we know the size for our window. To create It, we need to specify Its attributes, and Its border size. */

/* We wont a window with a name, a close box, a move bar and a size box... */

wlnd_type - NAME | CLOSE | MOVE | SIZE;

/* O.K. Make me a window. This call sets up Internal data structures and establishes the maximum size for the window, but It does not actually draw the window on the screen. */

whondle ■ wlnd_create(wlnd_type,xbord,ybord,wbord.hbord);

/* We specified we wanted a window with a name, but now we need to specify what that name Is.

This function can also be used to set or change other window parameters. */

284 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

w 1 n d_s e t(wh a n dI«, WNAME, "S AMPLE " . 0 . 0 ) ;

/* At last, draw the window. We have decided to draw It initially in its full size, but we could vary the last four parameters of this function if we desired otherwise. */

wind_open(whandle.xbord,ybord,wbord,hbord);

/* Incidentally, we have never found out the size of the work area of our window. We’ll need that later, so let’s do It with the wlnd_calc function. This function, given the window type can determine either the border or the work area dimensions. */

wind_calc(WINDAREA,wind_type,xbord,ybord,wbord.hbord, ftxwork,&ywork.fcwwork,&hwork);

/* Now, draw the filled ellipse In our window and wait for messages from the AES. If it’s a window resize or move message, recalculate the window work area, clear it, and redraw the ellipse. */

do

/* If the user expands the size of the window, not only will the AES send a resize message, it will also send a redraw message, on the assumption that more of the window is visible, and you might want to update It. We are redrawing the entire visible portion of the window work area on receipt of a resize message anyway, so we can ignore the redraw message. */

if (mgbuf[0] !- WM_REDRAW)

/* Hide the cursor. Otherwise area under it will not be affected by VDI routines. AES. */ v_hlde_c(shandle);

/* Set up the clipping rectangle to equal the work area of the window. Actually, we have no Intention of drawing outside these boundaries anyway, but as I said, this is a demo program, so here’s how you specify clip. All subsequent graphic primitives In the VDI will respect these boundaries, unless the routine Is called again with a different clip rectangle, or with the second parameter set to 0 (which means turn clipping off altogether). VDI. */

clip

clip

clip

clip

■xwork;

■ywork;

■xwork+wwork-1; ywork+hwork-1;

vs_cllp(shandle,CLIPON,clip);

/* Let’s clear the window work area to background color. There are lots of ways to do this. Here we set the interior fill style to pattern, the interior style index to 8 (which selects a "solid" pattern), and the fill color to 0, the background color. Then we call a primitive - v_bar, which draws a filled bar of the size defined by Its second parameter (for which we used the already available clip rectangle). All these routines are VDI. */

vsf_lnter lor(shandIe,PATTERN); vsf_styIefshand I e , 8 ); vs f_co I or(shand I e,COLOR0); v_bar(shandle,clIp);

/* Set the fill Interior and color to the desired style. Calculate the ellipse center point. And vollal - draw the ellipse. These are all VDI routines. */

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 285

vs fainter lor(shandIe.USER); vsf_coI or(shandI e, 1); xcen«xwo r k+wwo r k/2; ycen*ywork+hwork/2;

v_el 1 ipse(shandIe,xcen,ycen,wwork/ 2 ,hwork/ 2 );

/* Reshow the cursor, since we're done drawing. AES. */ v_show_c(shandle);

/* End of the part we don't do on a redraw message. */

/* O.K. Go to sleep until we get a message that the user has done something Interesting. AES. */ evnt_mesag(&mgbuf;;

/* user wanted to resize window or move It, the new border coordinates will have been left In the message buffer, positions 4 through 7. Use them to recalculate the work area size and reset the coordinates of the entire window. */

If (mgbuf[0] — WM_SIZED || mgbuf[0] — WMJ40VED)

wind_calc(WINDAREA,wind_type,mgbuf[4],mgbuf[5],

mgbuf[6],mgbuf[7],ixwork,&ywork,

&wwork,&hwork);

w!nd_set(whandle,WF_CURRXYWH,mgbuf[4],mgbuf[5], mgbuf[6],mgbuf[7]);

/* Repeat until the message from the AES says the user clicked the window close box. */ while (mgbuf[0] !- WM_CLOSED);

/* Close and delete the window. The data structure remains allocated until a window delete. */

wfnd_close(whandle); wlnd_deIete(whandIe);

/* Close the virtual workstation. */ v_clsvwk(shandle);

/* Tell the AES the application Is done, and terminate */ appl_exlt();

sdlc.asm

Programming Project:"CalculatIng CRCs by Bits and Bytes," by Greg Morse. September, page 114. Also see xmodem.c, ccltt.c, and xmodem.asm.

* part A: calling main pgm for SDLC subroutine

*

NAM SDLC

Sttl Calculate SDLC FCS a byte at a time Ifpl use /d0/defs/os9def8 use /d0/defs/os9defs endc

Table captionmod CRCsIz.CRCnam,prgrm+objet,reent+1.CRCBeg.CRCMem CRCNam fes "SDLC”

org

0

CRCReg

equ

. ; ;keep

CRCHI

rmb

1 ;; these

CRCLO

rmb

1 ;; statements

Temp

rmb

1 ;;

stakbot

rmb

200-.

CRCMem

equ

•

CRCBeg

equ

♦

Table captiontogether

Table caption286 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

Table captiondo CRC on "T" show result * $1B26

Table captiondo CRC on "THE" show result ■ $44BE

do CRC on fox text

show result * $DF91

"txmit" 1's complement of CRC

"txmlt" LSB first then MSB do CRC on fox and FCS

show result ■ $F0B8 always

* . .

•port B: Calculation subroutine "SDLC" 28 AUG 85

* PUBLIC DOMAIN SOFTWARE DONATED BY:

• GREG MORSE Richmond B.C. CANADA %

CRCRtn equ * begin BYTE-wise FCS-SDLC

♦ ; +

* Calculate the FCS-SDLC value for a block of data

* Polynomial used * X**16 + X**12 +X**5 +1

* data is processed as If by SDLC chip that is

* LSB of char first

* on entry:

* X points to data buffer

* D contains number of chars In buffer <* 32767

* mem locations CRCHi, CRCLo, Temp are don’t care

* They must occupy adjacent locations with CRCHi

* at the low address

* On Exit

* X point past last char in buffer

* D new CRC value for block

* CRCHI,CRCLO new CRC for block

* Temp destroyed

*

♦ DOC NOTES:

♦ T ■ Data eor CRCLo

♦ U « (T7 T6 T5 T4 0 0 0 0) eor (T3 T2 T1 T0 0 0 0 0

♦ V7» (U7 0 0 00000; eor (T1 0 0 00000

* During calcs CrcLo not needed so is used as

* scratch area.

* The Inner loop from CRC.10 takes 86 cycles

* The routine requires 1 byte of scratch

* 2 bytes for the result, and 6 bytes of stack

*5

pshs y leay d,x pshs y Idd #$FFFF std CRCReg DoByt equ

♦

Idb crclo CRC.10 equ eorb ,x+ tfr b,a andb #$F0 anda #$0F std CRCLo I s I a I s I a

(continued)

save users y

start addr + byte count equals ending address plus 1 init FCS to all 1’s initialize CRC area * alt entry point for 1 byte CRC calc needs modified return see CRC.99

♦Begin Inner Loop one loop per byte CYCLES B-T7 T6 T5 T4 T3 T2 T1 T0

A-T7 T6 T5 T4 T3 T2 T1 T0

B*T7 T6 T5 T4 0 0 0 0

A- 0 0 0 0 T3 T2 T1 T0

A—>CRCLo; B—>Temp A- 0 00 T3 T2 T1 T0 0

A- 0 0 T3 T2 T1 T0 0 0

1 eax

foxmsg,PCR

Idd

#i

bsr

crcrtn

Idy

#0

Ibsr

shoregs

1 eax

foxmsg,PCR

Idd

#3

bsr

crcrtn

Idy

#i

Ibsr

shoregs

1 eax

foxmsg,PCR

Idd

#foxsiz

bsr

crcrtn

Idy

#2

Ibsr

shoregs

coma

comb

stb

FoxCRC,PCR

sta

FoxCRC+1,PCR

1 eax

foxmsg,PCR

Idd

#foxsiz+2

bsr

crcrtn

Idy

#3

Ibsr

shoregs

cl rb os9

F$Ex1t

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 287

18 1 a

A- 0 T3 T2 T1 T0 0 0

0

18 1 a

A- T3 T2 T1 T0 0 0 0

0

eora

Temp

A- U7 U6 U5 U4 0 0 0

0

eora

CRCLo

A- U7 U6 U5 U4 T3 T2 T1

T0

sta

Temp

temp- U7 U6 U5 U4 T3 T2

T1 T0

c 1 rb

1 sra

A- 0 U7 U6 U5 U4 T3 T2

T1

rorb

B-T000 0 0 0 0 0

eorb

Temp

B- V7 U6 U5 U4 T3 T2 T1

T0

1 sra

A- 0 0 U7 U6 U5 U4 T3

T2

rorb

B- T1 V7 U6 U5 U4 T3 T2

T1

Isra

A- 0 0 0 U7 U6 U5 U4

T3

rorb

B- T2 T1 V7 U6 U5 U4 T3

T2

Isra

A- 0 0 0 0 U7 U6 U5

U4

rorb

B- T3 T2 T1 V7 U6 U5 U4

T3

Isra

A- 0 0 0 0 0 U7 U6

U5

rorb

B= U4 T3 T2 T1 V7 U6 U5

U4

eorb

CRCHI

B- new CRCLo

eora

Temp

A- new CRCHI

std

CRCReg

one data byte all done

RC.99

equ

•make RTS If doing only 1

byte

cmpx

*s

x past end of buffer?

bio

CRC.10

if not repeat inner loop

Note:

B still = CRCLo

1 eas

2,8

pop topaddr

pu 1 s

y.pc

restore y and return

♦FoxMsg equ

*

fee

/THE.QUICK,BROWN.FOX,0123456789/

foxsiz

equ

♦-foxmsg

foxcrc

fdb

0 room for fox FCS bytes

USE shoregs.src

utility subrtn to print reas

emod

os9 directive

CRCSIz

equ

*

Table caption(28)

Table caption(32)

Table caption(36)

Table caption(40)

Table caption(42)

(54)

(58)

(62)

( 66 )

(70)

(74)

(79)

skam.bas

"Keyed File Accese In BASIC," by Stephen C. Perry. September, page 137. Also see skaml.bas.

1 *

2 | SAMPLE PROGRAM USING KEYED ACCESS ROUTINES

5 UA$«"A" * .. DRIVE CONTAINING DATA

16 OPEN “R",#2,UA$+":DATA.EMP",84 * .. OPEN DATA FILE

AS A2$^VaS ZP$ S KY$ ’ 20 AS NM$ ’ 6 AS BD$ ’ 1 AS SX$ ' 3 AS JC $* 20 AS A1$, 20 18 *

19 * KY$ - ZIP CODE (KEY) JC$ - JOB CODE

20 • NM$ - NAME A1$ - STREET ADDR.

21 BD$ - BIRTH DATE A2$ - CITY-STATE

22 ' SX$ - SEX ZP$ - ZIP CODE

23

25 MXX-150: F1$-"PTR.EMP" • ..INDEX FILE NAME

30 IIX-1: GOSUB 2000 • ..INITIALIZE DATA STRUCTURE

32 INPUT "OPERATION (D.A.L.S.LA,U.Q)";Q$

33 IF Q$«"D" THEN GOSUB 150: GOTO 32 ’ DELETE

34 IF Q$-"L" THEN GOSUB 180: GOTO 32 * LIST INDIVIDUAL DATA

35 IF Q$="A" THEN GOSUB 100: GOTO 32 > ADD 1V1UUAL UATA

36 IF Q$-"S" THEN IIX-8: GOSUB 2000: GOTO 32 ’ DISPLAY STATISTICS

37 IF Q$-"LA"THEN GOSUB 200: GOTO 32 • L ST ALL RECORDS

38 IF Q$="U" THEN GOSUB 250: GOTO 32 • UPDATE RECORD

40 IF Q$o"Q" THEN 32 UKU

50 CLOSE: END

97 *

98 • ***** ADD RECORD

99 •

100 INPUT "SS#";A$ : IF A$«"END" THEN 120 ELSE IF LEN(A$1<>9 THEN ina ell II%-5:G0SUB 2000: IF RC%<>0 THEN LSET KY$=A$: GOTO 102 ELSE PRINT"** ERROR - KEY ALREADY EXISTS": GOTO 100

102 INPUT "NAME“;F$: LSET NM$-F$

105 INPUT "BIRTH DATE";F$: LSET BD$«F$

107 INPUT "SEX";F$: LSET SX$-F$

288 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

INPUT “JOB CODE";F$: LSET JC$-F$

INPUT "STREET";F$: LSET A1$=F$

INPUT "CITY-STATE";F$: LSET A2$«F$

INPUT "ZIP CODE";F$: LSET ZP$=F$

IIX-2: GOSUB 2000 ADD RECORD

IF RCX-0 THEN 100 ELSE PRINT"** ERROR - RECORD CANNOT BE STORED": GOTO

II%-7: GOSUB 2000 RETURN

»

• ***** DELETE RECORD

STORE POINTERS

IF A$«"END" THEN 156

109

110 111 112

115

116 100 120 122

147

148

149 *

150 ST%-0

151 INPUT "CODE TO DELETE";A$

152 II%*4: GOSUB 2000

154 IF RC%«0 THEN ST%«1 ELSE

155 GOTO 151

156 IF ST%=1 THEN II%«7: GOSUB 2000 158 RETURN

177 *

178 * ***** LIST INDIVIDUAL RECORD

179 '

180 INPUT "SOCIAL SECURITY NUMBER";A$: IF A$*"END" THEN 190 rvTeTI(

182 II%*5: GOSUB 2000: IF RC%<>0 THEN PRINT"**ERROR - KEY DOES NOT EXIST

GOTO 180

183 PRINT

184 PRINT

185 PRINT

PRINT "** ERROR - KEY DOES NOT EXIST"

RESTORE POINTERS IF RECORD DELETED

"; NM$

•i .

"1LEFT$(BD$,2);"/";MID$(BD$,3,2);"/":RIGHT$(BD$.2) ";A1$

PAUSE

NAME:

JOB CODE:

18$ PRINT "BIRTH DATE:

187 PRINT " ADDRESS:

188 PRINT TAB(13);A2$:PRINT

189 GOTO 180

190 RETURN

197 '

198 • ***** LIST RANGE OF RECORDS

199 ’

200 NXX-0: IIX-6: KX-0 202 NXX-NXX+1: GOSUB 2000

204 IF RCXO0 THEN 210

205 PRINT KY$,NM$

206 KX-KX+1: IF KX<10 THEN 202 ELSE INPUT ">";Q$

207 IF Q$<>"END" THEN KX-0: GOTO 202 210 RETURN

247 '

248 ’ ***** UPDATE RECORD

249 *

250 INPUT "SS#";A$: IF A$-"END" THEN 270

252 IIX-5:G0SUB 2000 * .. FETCH RECORD TO BE UPDATED

254 IF RCX-1 THEN PRINT "** ERROR - RECORD DOES NOT EXIST":GOTO 250

255 PRINT "NAME- /";NM$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET NM$«F$

Ilf Sint "BIRTH DATE: /" ;BD$INPUT F$: IF LEN(F$)<>0 THEN LSET BD$-F$ 258 PRINT "SEX: /";SX$;"/";: INPUT F$:

260 PRINT "JOB CODE: /";JC$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET JC$=F$

262 PRINT "STREET: /";A1$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET A1$=F$

263 PRINT "CITY-STATE- /";A2$INPUT F$: IF LEN(F$)<>0 THEN LSET A2$—F$

III PRIUJ "ZIP CODE:/";ZP$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET ZP$=F$ 266 IIX-3: GOSUB 2000 ’ .. RESTORE UPDATED RECORD

268 PRINT “ ": GOTO 250 270 RETURN

1995 * _

1996

1997 ' - FILE MANAGEMENT SUBROUTINES (IIX,MXX,F1$.A$,PTX.PT$, NXX.RCX)

1998 ’

1999 *

2000 RC%«0: IF II%<1 OR II%>8 THEN RCX-1: RETURN

2001 IF II%*1 THEN 2006: ’ ELSE STORE VARIABLES USED BY SUBROUTINES

2004 ZZ%(1)-J%: ZZ%(2)-JJ%: ZZ%(3)«K%:ZZ%(4)«L0%: ZZ%(5)»HI%: ZZ%(6)=Z%

2005 *

2006 ON 11% GOSUB 2035,2080,2090,2100,2150,2200,2250,2280

2007 1

2008 IF IIX-1 THEN 2010: * ELSE RESTORE VARIABLES USED BY SUBROUTINES

2009 JX-ZZX(1): JJX-ZZX(2): KX-ZZX(3): L0X-ZZX(4): HIX-ZZX(5): ZX-ZZX(6)

2010 RETURN

2034 REM - (1) SUBROUTINE (MXX.F1$) - INPUT POINTERS AND KEYS

2035 IF MXX<1 THEN RCX-1: RETURN 2037 MRX-(INT((MXX+2)/64)+1)*64

[continued )

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 289

2038 DIM PT$(64),PTX(MRX),KE$(MX%),ZZX(8)

2040 OPEN "R",#1,UA$+":"+F1$,128 ' INDEX FILE

ns ^oMSe/MS* -1 ’* 2 As “*■ 2 as pt,(j,): next j *

2051 FOR JX-1 TO INT(MRX/64)

2052 GET 1,JX • .. INPUT RECORD CONTAINING 64 POINTERS

to 64: KX “ KX+1: PT*(KX)-CVI(PT$(JJX)): NEXT JJX

2055 NEXT JX

2056 ’

2057 IF PTX(MRX)-0 THEN 2062

2058 FOR JX-1 TO PTX(MRX)+PTX(MRX-1)

2059 GET 2. JX: KE$(JX)-KY$

2060 NEXT JX 2062 RETURN

2079 REM - (2) SUBROUTINE (MRX.A$. RCX) — ADD RECORD TO FILE

2080 GOSUB 2500 : IF KX>0 THEN RCX-1: GOTO 2088 2083 GOSUB 2520 : IF ZX>MRX-1 THEN RCX-2: GOTO 2088

2086 ISgjSg* " INSERT P ° INTER • PTX ( KX )- ZX

2087 PUT 2.ZX •

2088 RETURN

2089 REM — (3) SUBROUTINE - REWRITE RECORD

ip KXC0 THEN RCX-1: GOTO 2098

.. STORE RECORD

STORE NEW RECORD

2090 GOSUB 2500: ..

2092 PUT 2,PTX(KX)

2098 RETURN

2099 REM - (4) SUBROUTINE (MRX,A$,RCX) - DELETE A RECORD

2100 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2110 2102 ZX-PTX(KX): IF KX-PTX(MRX) THEN 2107

ne * t «

2110 RETURN* MR *^ =0: PTX ( MRX )“ PTX ( MRX ) -1: PTX(MRX-1)-JJX+1:PTX(MRX-2-JJX)-ZX

2149 REM - (5) SUBROUTINE (MRX,A$,NXX,RCX) - READ RECORD BY KEY

2150 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2155

2152 GET 2,PTX(KX) INPUT RECORD

2153 NXX-KX 2155 RETURN

2!!! REM - (6) SUBROUTINE (MRX.NXX.RCX) - READ RECORD BY SEQUENCE

2200 IF NXX<0 OR NXX>PTX(MRX) THEN RCX-1: GOTO 2205 2203 GET 2. PTX(NXX)

2205 RETURN

2249 REM - (7) SUBROUTINE (MRX) - RESTORE POINTERS

2250 KX-0: ZX-INT((PTX(MRX)-1)/64)+1 2252 FOR JX-1 TO ZX

oof? T0 64: K%-KX+1:LSET PT$(JJX)«MKI$(PTX(KX)): NEXT JJX: PUT 1,JX

2254 NEXT J%

2255 KX-INT(MRX/64): IF ZX-KX THEN 2259

22 INT(MRX/64) F ° R J%=1 T ° 641 LSET PT$ ( JX )“ MKI ^( PTX ( JX+K *)):NEXT JX:PUT 2259 RETURN

(8) SUBROUTINE — DISPLAY FILE STATISTICS

" : IF PTX(MRX)-0 THEN PRINT “*« NO RECORDS IN FILE": GOTO 2290 ** FILE STATISTICS **": PRINT " "

1. RECORDS IN FILE: ";PTX(MRX)

2. DELETED RECORDS: ";PTX(MRX-1)

3. LOWEST KEY: ";KE$(PTX(1))

4. HIGHEST KEY: ";KE$(PTX(PTX(MRX)))

BINARY SEARCH

2279 REM

2280 PRINT

2282 PRINT

2283 PRINT

2284 PRINT

2285 PRINT

2286 PRINT

2287 PRINT 2290 RETURN

2498 *

2499 REM - SUBROUTINE (MRX,A$, KX) —

2500 IF PTX(MRX)«0 THEN KX—1: RETURN 2502 LOX-0: HIX«PTX(MRX)+1

2504 MX-INT((LOX+HIX)/2)

2505 IF A$-KE$fPTX(MX)) THEN KX-MX: GOTO 2510

2506 IF A$>KE$(PTX(MX)) THEN LOX-MX: ELSE HIX-MX 2508 IF LOX+1 <> HIX THEN 2504 ELSE KX—HIX 2510 RETURN

2518 *

ofo« R | M ~,^® R ^ TINE (MRS.PTX.ZX) - LOCATE FREE RECORD IN DATA FILE 2520 IF PTX(MRX-1)-0 THEN ZX-PTX(MRX)+1: GOTO 2530 2522 JX-PTX(MRX):JJX=PTX(MRX-1)

o?i« ptx ( mpx -1)*PTX(MRX-1)-1: PTX(MRX-1-JJX)=0

2550 RETURN

2538 *

” ,NSERT P0INTER INT0 P0,N,ER VECI0R

290 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

2542 FOR JX«PTX(MRX)+1 TO KX+1 STEP -1

2544 PTX(JX)«PTX(JX-1)

2545 NEXT JX

2548 PTX(KX)«ZX: PTX(MRX)-PTX(MRX)+1 2550 RETURN

2997 ’

2998 • - PROGRAM TO INITIALIZE INDEX FILE

0999 *--------—-—-—

3000 PRINT " “-.PRINT TAB(5); "** INITIALIZE INDEX FILE **"-.PRINT " "

3001 INPUT "> DRIVE TO CONTAIN DATA";UA$

3002 INPUT "> FILE NAME";F$

3004 INPUT "> MAXIMUM NUMBER OF RECORDS FILE WILL HOLD";MXX 3006 MRX=(INT((MXX+2)/64)+1)*64

300 I -OPEN FILE AND SET POINTERS TO 0

111 ! *-.)* AS DUS,2 AS PTS(«) ; «XT 0*

H\t P*** 1 *^ ™ JX " T0 - 8 *- sf^fffi'w’zETOjoWTERS

3016 FOR JX-1 TO MRX/64 3018 PUT 1,JX

3022 PRINT" ": PRINT " INITIALIZATION COMPLETE ON DRIVE";UA$ 3025 END

skomi.bas

"Keyed File Access In BASIC," by Stephen C. Perry. September, page 137. Also see skam.bos.

SAMPLE PROGRAM USING KEYED ACCESS ROUTINES

1 1

2 ’

3 -

5 UA$-"A" * .. DRIVE CONTAINING DATA

16 OPEN "R“,#2.UA$+":DATA.EMP",84 *.. OPEN DATA FILE

17 FIELD #2, 9 AS KY$, 20 AS NM$, 6 AS BD$, 1 AS SX$, 3 AS JC$, 20 AS A1$, 20 AS A2$, 5 AS ZP$

18

19

20 21 22 23

KY$ - ZIP CODE (KEY) JC$ - JOB CODE

NM$ - NAME A1$ - STREET ADDR.

BD$ - BIRTH DATE A2$ - CITY-STATE

SX$ - SEX ZP$ - ZIP CODE

25 MXX-150: F1$-"PTR.EMP"

30 IIX-1: GOSUB 2000

31 ’

32 INPUT "OPERATION (D,A,L,S,LA.U.Q)";Q$

33 IF Q$-"D" THEN GOSUB 150: GOTO 32

34 IF Q$-"L" THEN GOSUB 180:

GOTO 32 * LIST INDIVIDUAL DATA

35 IF Q$«"A" THEN GOSUB 100: GOTO 32

36 IF Q$«*"S“ THEN IIX-8: GOSUB 2000:

GOTO 32 * DISPLAY STATISTICS

.INDEX FILE NAME .INITIALIZE DATA STRUCTURE

DELETE

ADD

37 IF Q$«"LA"THEN GOSUB 200:

GOTO 32 * LIST ALL RECORDS

38 IF Q$-"U" THEN GOSUB 250: GOTO 32 ' UPDATE RECORD

40 IF Q$o"Q" THEN 32

50 CLOSE: END

97 ’

98 ' ***** ADD RECORD

99 *

100 INPUT "SS#";A$ : IF A$»"END" THEN 120 ELSE IF

LEN(A$)<>9 THEN 100 _ „

101 IIX«5:G0SUB 2000: IF RCX<>0 THEN LSET KY$«A$: GOTO 102 ELSE PRINT"** ERROR - KEY ALREADY EXISTS": GOTO 100

102 INPUT "NAME";F$: LSET NM$-F$

105 INPUT "BIRTH DATE";F$: LSET BD$-F$

107 INPUT "SEX";F$: LSET SX$-F$

109 INPUT "JOB CODE";F$: LSET JC$-F$

110 INPUT "STREET";F$: LSET A1$-F$

111 INPUT “CITY-STATE":F$: LSET A2$-F$

112 INPUT "ZIP CODE";F$: LSET ZP$-F$

115 IIX-2: GOSUB 2000 ADD RECORD

[continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 291

116 IF RCX-0 THEN 100 ELSE PRINT"** ERROR - RECORD CANNOT BE STORED": GOTO 100

120 IIX-7: GOSUB 2000 STORE POINTERS

122 RETURN

147 *

148 * ***** DELETE RECORD

149 ’

150 STX-0

151 INPUT "CODE TO DELETE";A$: IF A$-"END" THEN 156

152 IIX-4: GOSUB 2000

154 IF RCX-0 THEN STX-1 ELSE PRINT "** ERROR - KEY DOES NOT

155 G0T0 T 151

156 IF STX-1 THEN IIX-7: GOSUB 2000 * RESTORE POINTERS

IF RECORD DELETED

158 RETURN

177 *

178 * ***** LIST INDIVIDUAL RECORD

179 *

180 INPUT "SOCIAL SECURITY NUMBER";A$: IF A$«"END" THEN 190

182 IIX-5: GOSUB 2000: IF RCX<>0 THEN PRINT"**ERROR - KEY DOES NOT EXIST": GOTO 180

183 PRINT " "

184 PRINT " NAME: ";NM$

185 PRINT " JOB CODE: “;JC$

186 PRINT "BIRTH DATE: ":LEFT$(BD$ > 2) : "/" : MID$(BD$.3.2);

"/";RIGHT$(BD$,2)

187 PRINT " ADDRESS: ";A1$

188 PRINT TAB(13);A2$:PRINT ""

189 GOTO 180

190 RETURN

197 *

198 * ***** LIST RANGE OF RECORDS

199 ’

200 NXX-0: IIX-6: KX-0 202 NXX-NXX+1: GOSUB 2000

204 IF RCXO0 THEN 210

205 PRINT KY$,NM$

206 KX-KX+1: IF KX<10 THEN 202 ELSE INPUT ">";Q$ * .. PAUSE

207 IF Q$o"END" THEN KX-0: GOTO 202 210 RETURN

247 '

248 • ***** UPDATE RECORD

249 '

250 INPUT "SS#";A$: IF A$-"END" THEN 270

252 IIX-5:GOSUB 2000 * .. FETCH RECORD TO BE UPDATED

254 IF RCX-1 THEN PRINT "** ERROR - RECORD DOES NOT EXIST"

GOTO 250 *

255 PRINT "NAME: /":NM$:"/" : : INPUT F$: IF LEN(F$)<>0

THEN LSET NM$-F$ J

257 PRINT "BIRTH DATE: /";BD$;"/";: INPUT F$: IF LEN(F$)<>0

THEN LSET BD$«F$ V '

258 PRINT "SEX: /";SX$;"/";: INPUT F$: IF LEN(F$)<>0

THEN LSET SX$-F$ '

260 PRINT "JOB CODE: /";JC$INPUT F$: IF LEN(F$)<>0 THEN LSET JC$-F$ '

262 PRINT "STREET: /";A1$ : "/";: INPUT F$: IF LEN(F$)<>0

THEN LSET A1$-F$ V '

263 PRINT "CITY-STATE: /“:A2$:"/" : : INPUT F$: IF LEN(F$)<>0

THEN LSET A2$-F$ ^ '

265 PRINT "ZIP CODE: /“;ZP$;"/";: INPUT F$: IF LEN(F$)<>0

THEN LSET ZP$-F$ V '

266 IIX-3: GOSUB 2000 * .. RESTORE UPDATED RECORD

268 PRINT " ": GOTO 250

270 RETURN

1995 ’

1996 ’

1997 '

FILE MANAGEMENT SUBROUTINES (IIX,MXX,F1$,A$,PTX.PT$, NXX.RCX)

1998 ’

1999 *

2000 RCX-0: IF IIX<1 OR IIX>8 THEN RCX-1: RETURN

2001 IF IIX—1 THEN 2006: * ELSE STORE VARIABLES

USED BY SUBROUTINES

2004 ZZXm-JX: ZZX(2)-JJX: ZZX(3)-KX:ZZX(4)-L0X: ZZX(5)-HIX: ZZX(6)-ZX

2005 *

292 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

2006 ON IIX GOSUB 2035,2080.2090.2100,2150.2200.2250,2280

2007 *

2008 IF IIX—1 THEN 2010: ’ ELSE RESTORE VARIABLES

USED BY SUBROUTINES

2009 JX-ZZX(I): JJX-ZZX(2): KX«ZZX(3): L0X-ZZX(4): HIX-ZZX(5): ZX-ZZX(6)

2010 RETURN

2034 REM - (1) SUBROUTINE (MXX,F1$) - INPUT POINTERS

AND KEYS

2035 IF MXX<1 THEN RCX-1: RETURN

2037 MRX-(INT((MXX+2)/64)+1)*64

2038 DIM PT$(64).PTX(MRX),KE$(MXX),ZZX(8)

2040 OPEN "R",#1,UA$+":"+F1$,128 * INDEX FILE

2042 FOR JX-1 TO 64: FIELD #1,(J%-1)*2 AS DU$,

2 AS PT$(JX): NEXT JX

2050 KX-0: IF LOF(1)-0 THEN 2062

2051 FOR JX-1 TO INT(MRX/64)

2052 GET 1,JX * INPUT RECORD CONTAINING 64 POINTERS 2054 FOR JJX-1 TO 64: KX-KX+1: PTX(KX)-CVI(PT$(JJX)):

NEXT JJX

2055 NEXT JX

2056 *

2057 IF PTX(MRX)-0 THEN 2062

2058 FOR JX-1 TO PTX(MRX)+PTX(MRX-1)

2059 GET 2, JX: KE$(JX)-KY$

2060 NEXT JX 2062 RETURN

2079 REM - (2) SUBROUTINE (MRX,A$, RCX) — ADO

RECORD TO FILE

2080 GOSUB 2500 : IF KX>0 THEN RCX-1: GOTO 2088

2083 GOSUB 2520 : IF ZX>MRX-1 THEN RCX-2: GOTO 20:5

2085 KX—KX:GOSUB 2540 ' .. INSERT POINTER . ?~X<X)-ZX

2086 KE$(ZX)-A$

2087 PUT 2.ZX ' STORE NEW RECORO

2088 RETURN

2089 REM — (3) SUBROUTINE - REWRITE RECORO

2090 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2098 2092 PUT 2,PTX(KX) * .. STORE RECORD

2098 RETURN

2099 REM - (4) SUBROUTINE (MRX,A$.RCX) - DELETE

A RECORD

2100 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2110 2102 ZX-PTX(KX): IF KX-PTX(MRX) THEN 2107

2104 FOR JX-KX TO PTX(MRX)-1: PTX(JX)-PTX(JX+1): NEXT JX

2107 JJX-PTX(MRX-I)

2108 PTX(PTX(MRX))-0: PTX(MRX)-PTX(MRX)-1:

PTX(MRX-1)-JJX+1:PTX(MRX-2-JJX)*ZX

2110 RETURN

2149 REM - (5) SUBROUTINE (MRX.AS.NXX.RCX) - READ

RECORD BY KEY

2150 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2155

2152 GET 2,PTX(KX) INPUT RECORO

2153 NXX-KX 2155 RETURN

2199 REM - (6) SUBROUTINE (MRX.NXX.RCX) - READ

RECORD BY SEQUENCE

2200 IF NXX<0 OR NXX>PTX(MRX) THEN RCX-1: GOTO 2205 2203 GET 2, PTX(NXX)

2205 RETURN

2249 REM - (7) SUBROUTINE (MRX) - RESTORE POINTERS

2250 KX-0: ZX-INT((PTX(MRX)-1)/64)+1

2252 FOR JX-1 TO ZX

2253 FOR JJX-1 TO 64: KX-KX+1:LSET PT$(JJX)-MKI$(PTX(KX)): NEXT JJX: PUT 1.JX

2254 NEXT JX

2255 KX-INT(MRX/64): IF ZX-KX THEN 2259 2257 KX-(KX-1)*64: FOR JX-1 TO 64:

LSET PT$(JX)-MKI$(PTX(JX+KX)):

NEXT JX:PUT 1.INT(MRX/64)

2259 RETURN

2279 REM - (8) SUBROUTINE -- DISPLAY FILE STATISTICS

2280 PRINT " “:IF PTX(MRX)-0 THEN PRINT "** NO RECORDS IN FILE": GOTO 2290

2282 PRINT " ** FILE STATISTICS **": PRINT " "

2283 PRINT " 1. RECORDS IN FILE: ";PTX(MRX)

2284 PRINT " 2. DELETED RECORDS: ";PTX(MRX-1)

(< continued I

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 293

2285 PRINT “ 3. LOWEST KEY: ";KE$(PTX(1))

2286 PRINT « 4. HIGHEST KEY: ";KE$(PTX(PTX(MRX)))

2287 PRINT - 2290 RETURN

2498 '

2499 REM - SUBROUTINE (MRX,A$, KX) — BINARY SEAI

2500 IF PTX(MRX)-0 THEN KX—1: RETURN 2502 LOX-0: HIX-PTX(MRX)+1

2504 MX-INT((LOX+HIX)/2)

2505 IF A$-KE$(PTX(MX)) THEN KX-MX: GOTO 2510

2506 IF A$>KE$(PTX(MX)) THEN LOX-MX: ELSE HIX-MX 2508 IF LOX+1 <> HIX THEN 2504 ELSE KX—HIX 2510 RETURN

2518 *

2519 REM — SUBROUTINE (MRX.PTX.ZX) — LOCATE FREE RECORO IN DATA FILE

PTX(MRX-1-JJX)-0 2530 RETURN

2538 *

2539 REM — SUBROUTINE (MRX.KX.ZX) — INSERT POINTER INTO POINTER VECTOR

2540 IF KX-PTX(MRX)+1 THEN 2548

2542 FOR JX-PTX(MRX)+1 TO KX+1 STEP -1

2544 PTX(JX)-PTX(JX-1)

2545 NEXT JX

2548 PTX(KX)-ZX: PTX(MRX)-PTX(MRX)+1 2550 RETURN

2997 ’

2998 *

2999 ’

PROGRAM TO INITIALIZE INDEX FILE

3000 PRINT * ":PRINT TAB(5);"** INITIALIZE INDEX FILE **":PRINT " "

3001 INPUT "> DRIVE TO CONTAIN DATA";UA$

3002 INPUT "> FILE NAME";F$

3004 INPUT "> MAXIMUM NUMBER OF RECORDS FILE WILL HOLD";MXX 3006 MRX-(INT((MXX+2)/64)+1)* 64

3008 DIM PT$(64)

3009 *-OPEN FILE AND SET

POINTERS TO 0

3010 OPEN "R",#1,UA$+":"+F$,128

3012 FOR JX-1 TO 64: FIELD #1,(JX-1)*2 AS DU$,2 AS PT$(JX):NEXT JX

3014 ZR$-MKI$(0): FOR JX-1 TO 64: LSET PT$(JX)-ZR$: NEXT JX

3015 *-STORE BLOCKS OF

ZERO POINTERS

3016 FOR JX-1 TO MRX/64 3018 PUT 1.JX

3020 NEXT JX

3022 PRINT " “: PRINT " INITIALIZATION COMPLETE ON DRIVE";UA$

3025 END

tbprolog.tst

"Turbo Prolog," by Namfr Clement Shammas. September, page 293.

Listing 1. Turbo Prolog List Reversal Test Program /* Turbo Prolog List Reversal Test Program */ domains

list * integer* predicates

append(11st,11st,I 1st) wrltestrlng(l 1st)

IIps(11st)

IIpshort(I 1st) rev(l1st,I? s t S cycle(lnteger)

294 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

goal

time(0,0,0,0),

write("Enter cycle length "), readlnt(N), eye Ie(N), time(H,M,S,F),

write("Tlme - ",H,":",M,":",S,".",F),nI. cIauses

append( [], L, L ).

append( [ZjLI], L2, [Z|L3] ) append( LI, L2, L3 ). writestr!ng( N ).

wr I testring( [H|T] ) wrlte( H ), writestrlng( T ).

I Ips(L) rev( [1,2,3,4,5,6.7,8,9,10,11.12,13,14,15.16,17,18,19,20,

21,22,23,24,25,26,27,28,29,30.31,32.33,34,35,36,37,38,39,40,41,42,43,44,45.46, 47,48,49,50], L ).

lipshort(L) rev( [1,2,3,4,5,6,7,8,9,10], L ).

append( Z, [H], L ).

N1 ■ N - 1, Iips(_), cycle(NI).

Listing 2. Turbo Prolog Floating Point Test Program

/* Turbo Prolog Floating Point Test Program */

predicates

caIc(reaI,reaI)

cycle(Integer, real,real)

goal

tlme(0,0,0,0),

A - 2.71828,

B « 3.14159,

cycle(5000,A,B),

tIme(H.M,S,F),

wrIte("Time - -,H,-:-,M,-:-,$.".■,F),nI.

cIauses

calc(A,B)

C « 1.0,

Cl » C * A,

C2 * Cl * B.

C3 - C2 / A,

C « C3 / B,

BOUND(C).

cycle(0,A,B)

C = 1.0,

Cl ■ C * A,

C2 - Cl * B,

C3 - C2 / A,

C - C3 / B,

wrIte("C - ”,C),nI.

cycle(N.A.B)

Ie(N,A,B) caIc(A,B),

N1 - N - 1 , eye I e (N 1 ,A,B).

{continued)

BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 295

Listing 3. Turbo Prolog Sieve Test Program. /* Turbo Prolog Sieve test program */ domains

11st - Integer* predicates

IntegersCInteger,integer,I 1st) prImes(Integer,11st)

8 I ft(I 1st, I 1st)

remove(integer,I 1st,I 1st)

cycle(Integer)

goal

tlme(0,0,0,0), cycle(10), t Ime(H,M,S,F),

wrIte( M TIme - ",H,-:-,M,«:-,S.«.-,F),nI. clauses

prlmes( Limit, Ps )

Integers^ 2, Limit, Is ), slft( Is, Ps ).

Integers( Low, High, [Low|Rest] )

Low <- High, I, M ■ Low + 1, lntegers(M, High, Rest ).

Integers( ).

slft( New, Ps ).

removed,[]»[]). remove(P,[IjIs],[I|NIsl) not( 0-1 mod P ),!, remove(P, Is, NIs). remove(P,[I|Is],NIs)

0-1 mod P, remove(P, Is, Nit).

cycle(0}.

cycle(N)

N1 - N - 1, primes(100,_), cycle(NI).

Listing 4. Turbo Prolog Math Functions Test Program.

/* Turbo Prolog Math Functions Test Program */ predicates

eye Iesqrt(Integer, real) eyeleln(Integer,real) eye Ieexp(Integer.real) eye Ieatan(Integer.real) eye Iesln(Integer,real)

goal

time(0,0,0,0), cyclesqrt(1000,_), time(0,0,0,0), eye IeIn(1000,_), time(0,0,0,0), eye Ieexp(1000,_), tlme(0,0,0,0), cycleatan(l000,_), tlme(0,0,0,0), eyclesln(l000,_).

296 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

cIauses

eye Iesqrt(0,R) R - sqrt(100.0), time(H,M,S,F),

write("SQRT : ",H,":",M,": M ,S, M .",F),nI,!. cyclesqrt(N, R) s

N > 0, N1 - N - 1, R - sqrt(100.0), eye Iesqrt(N1,R).

cycleln(0,R) R * ln(100.0), time(H,M,S,F),

wrIte("LN : M ,H,":-,M, H :",S, M . M ,F),nI.

cycleln(N, R)

N > 0, N1 - N - 1, R - ln(100.0), eye IeIn(N1,R).

cycleexp(0,R) R » exp(10.0), time(H,M,S,F),

wrlte("EXP : ",H, M : M ,M, M :",S,".",F),nI.

cycleexp(N, R)

N > 0, N1 - N - 1. R - exp(10.0), eye Ieexp(N1,R).

cycleatan(0,R) R * atan(10.0), tlme(H,M,S,F),

wrIte( M ATAN : M ,H, M :■,M,": M ,S,".",F),nI. cycleatan(N, R) s

N > 0, N1 « N - 1, R « atan(10.0), eye Ieatan(N1,R).

cyclesin(0,R) s- R « sin(10.0), tlme(H,M,S,F),

wr t te("SIN : M ,H, M : M ,M,": M ,S,". M ,F),nI.

cyclesin(N, R)

N > 0. N1 - N - 1, R - sln(10.0) # eye Iesin(N1,R).

Listing 5. Turbo Prolog Factorial Test Program. /* Turbo Prolog Factorial Benchmark Test */ predicates

factorial(reaI,reaI ) repeat(Integer,real)

goa I

cIearwindow,

wrlte("Enter number of iterations ")*

readlnt(Iter),nl,

write("Enter factorial number "),

readreaI(NumJ.nl,nI,

tlme(0,0,0,0;,

repeat(Iter,Num),

time(H,M,$,F),nI,

wr I te("Tlme - " ,H. ": " ,M. ": •' ,S, ". M ,F) ,n I. clauses

factor I a I(1.1) 1.

factor I a I(N.Resu11)

N1 - N - 1,

factorial(N1, Temporary),

Result - N * Temporary.

repeat(0,R) factor la I(R,X), wrlte(X),nI.

repeat(N.R)

factorial(R,_) t N1 - N - 1, repeat(N1,R).

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 297

Listing 6. Turbo Prolog Towsr of Hanoi Test Program. /* Turbo Prolog Towsr of Hanoi Test Program */ domains

list ■ Integer*

predicates hand (Integer)

move(integer.symbol.symbol.symbol) move2(symboI,symboI,symboI)

goa I

wr Ite( M Enter tower height M ), readint(Hlgh), time(0,0,0,0), hanol(High). time(H.M.S.F),

wrIte("Tlme : .

CIOU S 68

hanol(N) move(N. left, center, right). move(0, _):-!.

move(N, A. B, C)

M - N - 1. move(M, A. C, B). move2(bottom, A. B), move(M, C. B. A). move2(bottom, A, B)

wr lte("Move the disk on "),

wr Ite(A),

write(" to M ),

wrlte(B),

nl.

Listing 7. Turbo Prolog Disk Write Test Program. /* Turbo Prolog Disk write benchmark */ domains

file- textfile

predicates

send_text(integer)

goal

openwr11 e(text f1 1 e. M a:tempo.dat"),

wrItedevice(textfIle),

t!me(0,0.0.0),

send_text(512),

tlme(H.M.S.F),

closeFiIe(textflie),

writedevIce(screen),

wr i te("Time « ” ,H, ": ” ,M, ": M ,S ,".\F), nl. write("DONE"),n 1.

cIauses

Listing 8. Turbo Prolog Disk Read Program. /* Turbo Prolog Disk Write Program */

298 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986

domains

file- textfIle

predicates

get_text(Integer)

goal

openread(textfIle,"a:tempo.dat"). readdevlce(textfIle),

11 me(0,0,0,0), get_text(512), tlme(H,M,S,F), closeFIIe(textf1I e),

wr I te("TIme - ”,H, ":'\M, M : M ,S, M ,F), nl, wrIte("DONE"),nI.

clauses

get_text(0). get_text(N) :Readln(Str), not (lsname(Str)), Nl = N - 1, get_text(Nl).

xmodem.asm

Programming Project:"CaIcuI ating CRCs by Bits and Bytes,” by Greg Morse. September, page 114. Also see xmodem.c, sdlc.asm, and ccltt.c.

Table caption* .... omitted lines same as for SDLC version

Table caption♦

♦ Note

changed order of these next

four statements

♦

Temp

rmb

1 ; ;keep

CRCReg

equ

. ;; these

CRCHI

rmb

1 ;; statements

CRCLo

rmb

i ;;

together

stakbot

rmb

200-.

CRCMem

equ

•

*

*.... omitted

calling code same as

for SDLC version

* part B: Calculation subroutine

* XCRC - 28 AUG 85

* PUBLIC DOMAIN SOFTWARE DONATED BY:

* GREG MORSE Richmond B.C. CANADA

*

CRCRtn equ * begin BYTE-wise XMODEM-CRC *; +

* Calculate the XMODEM-CRC value for a block of data

* Polynomial used - X**16 + X**12 +X**5 +1

* on entry:

* X points to data buffer

* D contains number of chars In buffer <- 32767

* mem locations Temp, CRCHI, CRCLo are don’t care

* They must be adjacent locations with Temp at the

* low address.

* On Exit

* X point past last char In buffer

* D new CRC value for block

* CRCHI,CRCLO new CRC for block

* Temp destroyed

*

* DOC NOTES:

* T - Data eor CRCHI

* U « (T7 T6 T5 T4 0 0 0 0) eor (T3 T2 T1 T0 0 0 0 0)

* During calcs CrcHI not needed so is used as

* scratch area.

* The Inner loop from CRC.10 takes 90 cycles

(continued)

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 299

* The routine

* 2 bytes for

pshs leay pshs I dd std oByt equ *

y

d,x

y

#0

CRCReg *

requires 1 byte of scratch the result, and 6 bytes of stack

save users y

•tart addr + byte count equals ending address plus 1

In It CRC to all 0’s InitialIze CRC area at entry point for 1 byte CRC calc

T Ad rArum

Ida

CRCHI

CRC.10 equ

eora

*X 4

tfr

o,b

andb

#$F0

anda

#$0F

std

Isrb

Isrb

Isrb

1 srb

Temp

eorb

Temp

eorb

CRCHI

stb cl ra

1 s 1 b ro 1 a Is lb rola Is lb rola Islb ro 1 a

Temp

stb

Islb

rola

CRCHI

eora

CRCHI

eora

CRCLo

eorb

std

CRC.99

equ

B a 2{5 T6 n T5 T4°T3°T2 T1 # ~ P? - byt# ° YCLE5 A-T7 T6 T5 T4 T3 T2 T1

B-T7 T6 T5 T4 0 0 0

A- 0 0 0 0 T3 T2 T1

8av« A->temp; B->CRCHI B- 0 T7 T6 T5 T4 0 0 0

B- 0 0 T7 T6 T5 T4 0 0

B- 0 0 0 T7 T6 T5 T4 0

B- 0 0 0 0 T7 T6 T5 T4

B- 0 0 0 0 U7 U6 U5 U4

B“ T7 T6 T5 T4 U7 U6 U5 U4

temp- T7 T6 T5 T4 U7 U6

A- 0 0 0 0 0

A- 0 0 0 0 0

A- 0 0 0 0 0

B- U7 U6 U5 U4 0 „ „ „

A- 0 0 0 0 T7 T6 T5 T4

B= U6 U5 U4 0 0 0 0 0

A- 0 0 0 T7 T6 T5 T4 U7

Table captionTemp

Table captionCRCReg

Table caption*

cmpx bio

A still leas 2,s

CRC.10 CRCHI

A» new CRCHI

B« new CRCLo K , OJ

one data byte all done (83) make RTS If doing only 1 byte x past end of buffer? (87) If not repeat Inner loop Note:

*

FoxMsg

puls y,pc

pop topaddr restore y and return

FoxSIz

equ fee

equ . . .

USE shoregs.src emod

CRCSIz equ *

/THE.QUICK, BROWN.FOX .0123456789/ ♦-FoxMsg '

os9 CRC bytes

Programming Project:"CaIcuI at Ing CRCs by Greg Morse. September, page 114. Al sale.asm, and Xmodem.asm.

by Bits and Bytes, so see ccltt.c,

!r P I a J b ! t " 0rientad CRC routine */

/* Adopted from YMODEM protocol reference

/* Co leu I ate CRC on o block of data */

/* Ptr points to block of characters.*/ count gives size of buffer. */

'* If ♦k Pr 22£°? r ? turns th * CRC with the LSB*/ of the CRC in the high bit of the*/ '

result Integer.*/ '

thIt 0 ?f M H d * V,at ! S fr0m CCITT standard in*/

that It does not use */ '

* inif! S n° f Ju® data f,r8t » nor does It*/ initialize the CRC to all */ '

*/

300 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986

September

/• ones as specified by the standard. */

int calcrc(ptr, count) char *ptr;

Int count;

unsigned Int crc;

Int !;

crc - 0; /* note not OxFFFF */

while (—count >* 0) { , t . #

I » (Int) *ptr++; /* convert data char to int */

I = | « 8; /* shift char to high byte */

crc - crc * I; /* add current data to current */

/* remainder modifies only least */

/* sIg 8 bits (high byte) of CRC */ for (1*0; I<8; ++I) /* loop for each bit */ if (crc k 0x8000) | /* test D XOR R0 */ crc - (crc « 1); /* discard LSB of CRC and */

/* append zero */

crc * crc * 0x1021; /* XOR with low 16 bits */

/* of CCITT polynomial */

/* because CRC is stored LSB 1st */ /* polynomial written MSB first •/

{ /* end if */

else ^ .

crc - crc « 1; /* discard LSB & append 0 •/

j /♦ end while */ return (crc k 0xFFFF);*/

/* 16-bit result for whole block */

| /* end calcrc */

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 301

DISKS AND DOWNLOADS

Ordering Disks of byte Listings

Listings that accompany BYTE articles are sva: abie in a variety of disk formats and on Cauz - f: ~r.ro. Each disk package (which sometimes corrs ss of more than one disk) contains an e~: -e s listings. If you want to order a disk cir-age from a previous month, please call (6031 :: : rd

out how many disks it includes To order (for noncommercial use only), fill cu: r s form, and send a check or money order in the c:~er: amount to:

BYTE Listings

One Phoenix Mill Lane

Peterborough. NH 03458

All prices include postage Program Ssdags can also be downloaded via BYTEnet . at (617) 861-9764.

BYTE issue: __

COMMON 514-INCH FORMATS

All cost $8.95. $10.95 outsics -rrsal

subscription is $69.95. $89 : _*a oe . 5 1

□ Apple II 514-inch DOS 3.3

□ Apple II 514-inch ProDOS

□ Hewlett-Packard 125

□ IBM PC

□ Kaypro 2 CP/M

□ Texas Instruments Profess :*a

□ TRS-80 Model III

□ TRS-80 Model 4

□ Zenith Z-100

COMMON 3'/HNCH FORMATS All cost $9.95. $11.95 outside . subscription is $79.95 $=v ce .5 A

□ Apple Macintosh

□ Atari 520ST

□ Commodore Amiga

□ Data General/One

□ Hewlett-Packard 150

CP/M STANDARD ft-MCH FORMAT

All cost $9 95. $11.95 oxsa de USA Annual

subscription is S79.95. 999.95 outside USA

□ Single-s:ded src-e-oe^sr.

□ Double-scoec aouDe-dersty

OTHER FORMATS

Due to the diversity of requests and the custom work involved, there will be some delay in fu-£ these requests. All cost $9.95. $11.95 outside USA Annual subscription is $79.95. $99.95 outside US. A.

Size □ 8-inch □ 514-inch □314-inch Machine_

SEND TO:

Name_

Street__

City_State or Province_

Postal Code_Country_

Check or money order enclosed for $_

Bulletin Boards in Canada

Listed below are some computer bulletin boards that carry program listings from BYTE. Programs are for noncommercial use in connection with BYTE articles only. Some BBSs may charge an annual maintenance fee. and you must pay your own telephone charges.

Western Canadian Distribution Center (3420 48th St.. Edmonton. Alberta T6L 3R5i will be supplying listings to its member bulletin board systems. Edmonton. Alberta. (403) 454-6093 Meadowlark. Alberta. (403) 435-6579 Montreal. Quebec. PComm Systems. (514) 989-9450 Prince George. British Columbia. (604) 562-9519 Regina. Saskatchewan. (306) 586-5585 Canadian Remote Systems. Toronto

Toronto. Ontario. Epson Club of Toronto (EPCOT). (416) 635-9600

Winnipeg. Manitoba. (204) 452-5529

In addition, arrangements for BYTEnet Listings have been made with one or more system operators in the following nations: Australia Austria, Brazil, Denmark. France. Hong Kong. Indonesia Italy, lapan. Malaysia. The Netherlands. Niger-.a Norway. Saudi Arabia. Singapore. Sweden. Switzerland. United Kingdom, and West Germany Contact us at (603) 924-9281 for an up-to-date list ■

BYTE LISTINGS SUPPLEMENT • "EMBER 1986 303

EDITORIAL CALENDAR

1987

MAY — DESKTOP PUBLISHING: An exploration of the hardware and software needed for desktop publishing, from page description languages to high-resolution printers and typesetting back ends.

June — Computer-Aided Design: The anatomy of computer-aided design/drafting software, the graphics display devices needed for CAD. and the data structures used by CAD programs to export data to other applications.

July — Local Area Networks: The technology of linking personal computers together to share data files, programs, and peripheral devices.

AUGUST — PROLOG: A look at logic programming with articles on tips and techniques and explorations of the tasks Prolog is best suited for.

SEPTEMBER — PRINTER TECHNOLOGIES: An examination of the state of the art in printer technologies, including laser, liquid-crystal shutter, and ink-jet technologies.

OCTOBER — HEURISTIC ALGORITHMS: Artificial intelligence techniques for giving computers the ability

to learn from experience.

November — High-Performance Workstations: a tour of the technology underlying the workstations used by scientists and engineers in computer-aided engineering/design.

December — Natural Language Processing: The technology of getting computers to understand the natural language of man.

January — Managing Megabytes: Looking at the ways computers store and retrieve data in situations where disk space is measured in gigabytes and memory is measured in megabytes. Also a look at the new applications that mega-memory and storage will permit.

FEBRUARY — LISP: A BYTE reexamination of the original language of artificial intelligence research.

March — Floating-Point Processors: a look at the processors that speed the computation of mathematical operations in personal computers, including coprocessors and array processors.

April — Memory Management The hardware and software issues in managing a personal computer's memory space.

MAY — CPU ARCHITECTURES: An exploration of the latest 32-bit microprocessors, including digital signal processors and programmable graphics processors.

Six great reasons

• Over 140 microcomputer related c onf er e n c es:

loin only those subjects that in a eica 90a and change selections at any time Take part when it's M| for you. Share information, opi n io ns and ideas in focused discussions with other BOC u ser s who s ha re your interests. Easy commands and co nfere nce cfigests help you quickly locate important Monnafion.

• Monthly conference specials:

BIX specials connect you with invited experts in leading-edge topics—CD-ROM MID! OS - arc ~ :~t They're all part of your BIX members* :

• Microbytes daily:

Get up-to-the-minute industry news arc re* r-: c.r information by joining Microbytes Da: ., arc 5 New Hardware and Software.

• Public domain software:

Yours for the downloading, including programs ; *:~ BYTE articles and a growing library of PD listings

• Electronic mail:

Exchange private messages with BYTE ecr.zs a~r authors and other BIX users.

to join BIX today

BIX User's Manual and Subscriber Agreement - otm as We've Processed Your Registration. JOIN THE EXCITING WORLD OF BIX TODAY!

• Vendor support:

A growing number of microcompute' manufacturers use BIX to answer your questions about re - products and how to use them for peak perforrarce

What BIX Costs. .How You Pay

Join BIX Right Now:

Set your computer's telecommunications program for full duplex. 8-bit characters, even parity. 1 stop bit OR 7-bit characters, even parity. 1 stop using 300 or 1200 baud.

Call your local Tymnet number and respond as follows

ONE-TIME REGISTRATION FEE S25

Hourly

Charges:

(Your Time of Access)

Off-Peak

6PM-7AM

Weekdays Plus Weekends & Holidays

Peak

7AM-6PM

Weekdays

Tymnet Prompt

You Enter

Garble or "terminal identifier"

login:

password:

mhis login:

BIX Logo—Name:

a

byteneti <CR> mgh <CR> bix <CR> new <CR>

BIX $9 $12

Tymnet* $2 $6

TOTAL $ ll/hr. SI 8/hr.**

* Continental US. BIX is accessible via Tymnet from throughout the US. at charges much less than regular long distance. Call the BIX helpline number listed below for the Tymnet number near you or Tymnet at 1-800-336-0149 •* User is billed for time on system lie.. Vt Hr Off-Peak wfTymnet - $5.50 charge.)

BIX and Tymnet charges billed by Visa or Mastercard only.

BIX Helpline

(8:30 AM-11:30 PM Eastern Weekdays)

U.S. (except NH)-1-800-227-BYTE Elsewhere (603) 924-7681

After you register on-line, you're immediately taken to the BIX learn conference and can start using the system right away.

Foreign Access:

To access BIX from foreign countries, you must have an account with your local Postal Telephone & Telegraph (PTT) company. From your PTT enter 310600157878. Then enter bix <CR > and new <CR > at the prompts. Call or write us for PTT contact information.

EIX

One Phoenix Mill Lane Peterborough. NH 03458 (603) 924-9281

Announcing BYTE’s New Subscriber Benefits

Y

^OU

Program

our BYTE subscription brings you a complete diet of the latest in microcomputer technology every 30 days. The kind of broad-based objective coverage you read in every issue. In addition, your subscription carries a wealth of other benefits. Check the check list:

DISCOUNTS

13 issues instead of 12 if you send payment with subscription order.

yf One-year subscription at $21 (50% off cover price).

vf Two-year subscription at $38.

Vf Three-year subscription at $55.

Ef One-year GROUP subscription for ten or more at $17.50 each. (Call or write for details.)

SERVICES

33 BIX: BYTE’s Information Exchange puts you on-line 24 hours a day with your peers via computer conferencing and electronic mail. All you need to sign up is a microcomputer, a modem, and telecomm software.

Reader Service: For information on products advertised in BYTE, circle the numbers on the Reader Service card enclosed in each issue that correspond to the numbers for the advertisers you select. Drop it in the mail and we’ll get your inquiries to the advertisers.

ii TIPS: BYTE’s Telephone Inquiry System is available to

BITE

THE SMALL SYSTEMS JOURNAL

subscribers who need fast response. After obtaining your Subscriber I.D. Card, dial TIPS and enter your inquiries. You’ll save as much as ten days over the response to Reader Service cards.

V Disks and Downloads:

Listings of programs that accompany BYTE articles are now available free on the BYTEnet bulletin board, and on disk or in quarterly printed supplements.

Sj Microform: BYTE is available in microform from University Microfilm International in the U.S. and Europe.

2 BYTE’s BOMB: BYTE’s Ongoing Monitor Box is your direct line to the editor’s desk. Each month, you can rate the articles via the Reader Service card. Your feedback helps us

keep up to date on your information needs.

if Customer Service: If you have a problem with, or a question about, your subscription, you may phone us during regular business hours (Eastern time) at our toll-free number: 800258-5485. You can also use Customer Service to obtain back issues and editorial indexes.

BONUSES

}/ Annual Separate Issues: In addition to BYTE’s 12 monthly issues, subscribers also receive our annual IBM PC issue free of charge, as well as any other annual issues BYTE may produce.

0 BYTE Deck: Subscribers receive five BYTE postcard deck mailings each year—a direct response system for you to obtain information on advertised products through return mail.

To be on the leading edge of microcomputer technology and receive all the aforementioned benefits, make a career decision today. Call toll-free weekdays, 8:30am to 4:30pm Eastern time: 800-258-5485.

And. . . welcome to BYTE country!

EVU

THE SMALL SYSTEMS JOURNAL

ith