Trailing-Edge
-
PDP-10 Archives
-
decuslib10-12
-
43,50547/setsym.for
There is 1 other file named setsym.for in the archive. Click here to see a list.
SUBROUTINE SETSYM(IFUNC,IARG,IANS)
* See SETSYM portion of SYMBOL.MAC for documentation
INTEGER IFUNC,IARG,IANS(3) !3 words for 'NAME'
INTEGER IUNIT,ITEMP(0:127),I,J !Local variables
INTEGER IPOS,MASK,IREC,INDEX
PARAMETER (ISETSZ=12*128-1) !Size of entire buffer
PARAMETER (ISTRSZ=ISETSZ-16-128) !Size of strokes table
COMMON /SYMB0L/BUFFER(0:ISETSZ) !Data from SYMBOL.DAT
EQUIVALENCE (NPENUP,BUFFER(0)) !Pen up code for NORMAL
EQUIVALENCE (HITEN, BUFFER(1)) !Height for NORMAL
EQUIVALENCE (NMINC, BUFFER(2)) !Min ASCII char for NORMAL
EQUIVALENCE (NMAXC, BUFFER(3)) !Number of chars for NORMAL
EQUIVALENCE (KPENUP,BUFFER(4)) !Pen up code for CENTER
EQUIVALENCE (HITEK, BUFFER(5)) !Height for CENTER
EQUIVALENCE (KMINC, BUFFER(6)) !Min index for CENTER
EQUIVALENCE (KMAXC, BUFFER(7)) !Number of symbols for CENTER
INTEGER UNUSED(4),INAME(3)
EQUIVALENCE (UNUSED,BUFFER(8)) !4 words reserved for future
EQUIVALENCE (INAME, BUFFER(12)) !Name of table CHARACTER*15
EQUIVALENCE (NTABLE,BUFFER(15)) !Table number
INTEGER POINTR(0:127),STROKS(0:ISTRSZ)
EQUIVALENCE (POINTR,BUFFER(16)) !Pointers to strokes
EQUIVALENCE (STROKS,BUFFER(144)) !Data for SYMBOL
DATA IUNIT /0/ !Use OPEN(UNIT=0) by default)
*******************************************************************************
DATA (BUFFER(I),I=0,3) /"37,8.0,"40,"140/ !Normal
DATA (BUFFER(I),I=4,7) /"07,6.0,"00,"032/ !Centered
DATA (BUFFER(I),I=8,11) /"0,"0,"0,"0/ !Reserved for future
DATA (BUFFER(I),I=12,15)/'CSM Standard ',1/ !Table name & number
* Start of POINTR - pointer to table of strokes, indexed by character-"40
DATA (BUFFER(I),I= 16, 31) ! !"#$%&'()*+,-./
& / "440500010000, "250500060000, "370500060002, "060500140003
& , "010500210006, "130500250013, "130500140021, "320500030025
& , "320500050026, "060500050027, "250500140031, "200500060034
& , "320500070036, "250500030040, "250500060041, "320500030043/
DATA (BUFFER(I),I= 32, 47) !0123456789:;<=>?
& / "320500150044, "010500040047, "320500120051, "320500140054
& , "060500050057, "250500130061, "130500130064, "010500040067
& , "320500210071, "320500130076, "200500140101, "010500150104
& , "130500040110, "010500060111, "130500040113, "010500130114/
DATA (BUFFER(I),I= 48, 63) !@ABCDEFGHIJKLMNO
& / "370500240120, "060500070125, "060500160127, "060500110133
& , "200500100136, "010500120140, "130500070143, "130500130145
& , "010500110150, "250500110153, "060500110155, "250500110160
& , "060500060162, "200500060164, "250500050166, "010500120167/
DATA (BUFFER(I),I= 64, 79) !PQRSTUVWXYZ[\]^_
& / "010500100172, "250500150175, "370500130201, "320500130204
& , "200500060207, "320500070211, "250500040213, "130500060214
& , "200500060216, "320500070220, "320500050222, "060500050223
& , "250500030225, "250500050226, "010500070227, "010500070231/
DATA (BUFFER(I),I= 80, 95) !`abcdefghijklmno
& / "010500030233, "010500170234, "320500140241, "130500110244
& , "250500150247, "370500130253, "250500110256, "010500170260
& , "320500110265, "060500100267, "370500100272, "250500110274
& , "060500030276, "060500170277, "010500110303, "200500120306/
DATA (BUFFER(I),I= 96, 111) !pqrstuvwxyz{|}~
& / "200500140311, "010500140314, "250500100320, "130500130322
& , "010500110325, "200500100330, "010500040332, "320500060334
& , "370500060336, "060500070337, "060500050341, "250500100343
& , "060500030345, "060500100346, "320500050351, "060500040352/
DATA (BUFFER(I),I= 112, 127) !16 centered symbols
& / "370300100354, "170300140355, "140300060357, "110300070360
& , "000300070361, "330300070363, "220300070364, "110300060365
& , "060300070366, "000300070367, "330300160371, "140300150373
& , "030300070375, "360300040377, "030300110377, "250300040401/
DATA (BUFFER(I),I= 128, 143) !Centered digits 0-9
& / "360300140402, "360300100404, "220300130405, "300300200407
& , "000300110411, "250300140413, "250300170415, "030300110417
& , "250300240421, "110300170424, "000000000000, "000000000000
& , "000000000000, "000000000000, "000000000000, "000000000000/
* Start of STROKS table
DATA (BUFFER(I),I= 144, 159)
& / "200062000604, "141077611004, "324001411404, "357443421420
& , "003021611576, "106441774622, "004770054626, "200060040214
& , "103062021204, "240140470434, "146371070414, "761060471000
& , "140061460130, "005402405104, "221520654230, "762110640316/
DATA (BUFFER(I),I= 160, 175)
& / "103051430714, "202511045000, "143060254132, "047033421500
& , "220070230314, "124100030230, "107100030214, "004003011620
& , "003001411004, "300162000600, "202147611404, "217442001476
& , "005042440014, "043422774022, "104500030314, "063421610606/
DATA (BUFFER(I),I= 176, 191)
& / "141052000600, "222112000604, "141460634216, "043100030014
& , "146100030016, "146771460434, "047003001004, "142061440630
& , "200060260334, "063100030030, "006413425614, "323130034014
& , "143100030032, "027053431514, "302121440616, "123011400720/
DATA (BUFFER(I),I= 192, 207)
& / "003051425600, "223112000600, "160461030620, "144452405200
& , "220161471000, "140110250524, "144461624602, "140070050434
& , "200060070634, "023100030124, "004401604612, "143071444524
& , "145463225602, "340150054124, "125100030214, "145063225602/
DATA (BUFFER(I),I= 208, 223)
& / "340150054124, "125062640014, "043031414704, "161067611206
& , "241530454224, "200060630316, "043421414604, "137422415206
& , "261130451000, "141470050332, "200060040620, "763120051000
& , "140070650032, "200060264234, "107053225406, "241507614706/
DATA (BUFFER(I),I= 224, 239)
& / "144001404600, "160130260530, "145462024710, "202137621206
& , "261130250122, "044032021120, "003001415614, "157412225120
& , "003001401612, "343151454524, "005371250622, "143451400620
& , "003063225604, "340140040214, "123061640014, "003003421614/
DATA (BUFFER(I),I= 240, 255)
& / "303101030014, "200060030034, "147371050024, "760061431000
& , "140060070634, "762120051000, "143151270234, "006002010610
& , "143101450424, "200060030034, "763161433700, "243122000602
& , "142467614606, "357413425620, "003011610606, "142071073704/
DATA (BUFFER(I),I= 256, 271)
& / "343162000602, "140567605212, "357412424620, "003001401676
& , "003061440014, "003003415314, "343062000600, "140161430634
& , "200060040030, "047043431414, "202060430020, "200060030034
& , "127063231312, "240122000600, "200140470434, "146062020604/
DATA (BUFFER(I),I= 272, 287)
& / "140107621014, "144001400600, "342561464626, "125002574224
& , "143100030020, "043041431010, "241120060234, "107063040014
& , "063033574034, "147100030034, "003411424614, "163162000600
& , "341461471000, "140160030322, "143063440014, "003063574034/
DATA (BUFFER(I),I= 288, 303)
& / "143100030034, "065463574326, "063100030034, "147001430620
& , "003031000400, "341562000600, "303062000606, "103041470334
& , "200060054334, "145770670314, "200060634024, "066770050624
& , "200060470430, "200060044124, "065042220676, "104032205100/
DATA (BUFFER(I),I= 304, 319)
& / "200070230314, "103500030014, "006770044124, "065042220706
& , "140460035000, "142110650124, "004401604606, "142072000600
& , "160110250324, "104441614602, "140077620610, "324001420706
& , "140460034022, "025032421110, "200102000604, "141140664432/
DATA (BUFFER(I),I= 320, 335)
& / "126370054426, "200061044324, "025002200702, "141461037710
& , "242050620110, "002500030014, "006770044124, "065042220620
& , "003033015376, "065031620612, "144001415406, "277432414504
& , "100442000600, "140157601004, "257402010620, "003021411520/
DATA (BUFFER(I),I= 336, 351)
& / "003001401276, "004412411206, "221467615110, "242521444614
& , "200060030024, "760110250224, "064431440014, "003402205206
& , "242111034314, "023001640014, "002002574022, "025032421110
& , "161460230016, "200061044324, "025002200702, "141461037710/
DATA (BUFFER(I),I= 352, 367)
& / "242042000600, "140127601102, "241521045000, "140070230314
& , "103432005000, "220520650422, "200060464216, "063041424776
& , "025432640014, "005001604606, "142071050414, "200060050214
& , "105100030024, "003022020610, "244001400610, "257402420620/
DATA (BUFFER(I),I= 368, 383)
& / "003002410676, "105011000420, "003002421200, "142062000606
& , "341150454022, "043421214420, "003021011620, "003003405502
& , "261510234112, "002000030240, "070444026100, "003014022010
& , "366667333222, "115353333335, "455452412112, "142535333333/
DATA (BUFFER(I),I= 384, 399)
& / "551113533333, "353133135333, "333551133155, "133333355331
& , "133533333313, "553133533333, "115515513333, "315551151733
& , "333153355333, "133333554424, "152422112242, "514244333333
& , "531335511335, "313335115333, "333355155111, "333333531333/
DATA (BUFFER(I),I= 400, 415)
& / "333651145411, "367333331353, "333332040515, "546261511207
& , "333332536302, "040733333152, "646555411105, "073333315264
& , "655544323435, "251402011733, "333161353746, "407333331120
& , "405152431316, "567333335546, "261511204051, "524323127333/
DATA (BUFFER(I),I= 416, 431)
& / "331516565531, "307333331526, "465554432343, "525140201112
& , "231415733333, "112040515546, "261514234354, "733000000000
& , "000000000000, "000000000000, "000000000000, "000000000000
& , "000000000000, "000000000000, "000000000000, "000000000000/
* The remainder of BUFFER for SETSYM table #1 is filled with zeros
DATA (BUFFER(I),I=432,1535) /1104*"000000000000/
******************************************************************************
IF(IFUNC.EQ.'UNIT') GOTO 100
IF(IFUNC.EQ.'NUMBE') GOTO 200
IF(IFUNC.EQ.'NAME ') GOTO 300
IF(IFUNC.EQ.'TABLE') GOTO 400
IF(IFUNC.EQ.'WIDTH') GOTO 500
* Here if none of the above
CALL PLOT(0.0,0.0,999) !Turn off all plotting
TYPE 50,IFUNC
50 FORMAT(' ?SETSYM - Unknown function ',A5)
RETURN
***** 'UNIT' - Declare which FORTRAN I/O unit to use
100 IANS(1) = IUNIT !Return old value
IUNIT = IARG !Set new value
RETURN
***** 'NUMBE' - Return current table number
200 IANS(1) = NTABLE !IARG is ignored
RETURN
***** 'NAME ' - Return current table name
300 IF(IARG.NE.0) GOTO 350 !Zero means current table
IANS(1)=INAME(1) ; IANS(2)=INAME(2) ; IANS(3)=INAME(3)
IF(IANS(1).NE.0) RETURN
IANS(1)='Unkno' ; IANS(2)='n tab' ; IANS(3)='le '
350 RETURN
***** 'TABLE' - Read SYS:SYMBOL.DAT or SYMBOL:SYMBOL.DAT
400 IF(IARG.EQ.0) GOTO 200 !Return current table if zero
IF(IARG.GT.0) OPEN (UNIT=IUNIT, NAME='SYS:SYMBOL.DAT',
& MODE='IMAGE', ACCESS='RANDIN', RECORDSIZE=128, ERR=499)
IF(IARG.LT.0) OPEN (UNIT=IUNIT, NAME='SYMBOL:SYMBOL.DAT',
& MODE='IMAGE', ACCESS='RANDIN', RECORDSIZE=128, ERR=499)
READ (IUNIT'1) ITEMP !Read index block
IREC = ITEMP(IABS(IARG)-1) !Get record number
IF(IREC.LE.0) GOTO 499 !Zero means no such table
DO 410 I = 0,11 !Read in 12 records
410 READ(IUNIT'IREC+I) (BUFFER(J),J=I*128,I*128+127)
CLOSE (UNIT=IUNIT)
IANS(1) = 0 !Clear error flag
RETURN
499 IANS(1) = -1 !Errors were detected
RETURN
***** 'WIDTH' - Return width of character, 1000 means width=height
500 I = IARG !Get character number
* Convert A1 format to R1 format so that I is between 0 and 127
IF(I.LT.0) I = ((I/"004000000000)-1).AND."177
IF((I.AND."774000000000).NE.0) I = I/"004000000000
I = I - NMINC !Subtract off offset
IANS(1) = 0 !In case out of range
IF((I.GT.NMAXC) .OR. POINTR(I).EQ.0) RETURN
I = POINTR(I).AND."777700007777 !Get byte pointer
INDEX = I.AND."7777 !Index into STROKS array
* Fake an ILDB instruction
J = (I.AND."007700000000)/"000100000000 !Get byte size
MASK = (2**J)-1 !Byte mask
IPOS = I/"010000000000 !Byte position
IF(I.LE.0) IPOS = (IPOS-1).AND."77 !Undo 2's complement
IPOS = IPOS - J !Increment byte pointer
IF(IPOS.LT.0) INDEX = INDEX +1 !If past end of word,
IF(IPOS.LT.0) IPOS = 36 - J ! increment to next word
I = STROKS(INDEX)/(2**IPOS) !Get byte
IF(I.GT.0) I = I.AND.MASK !I gets integer width
IF(I.LT.0) I = (I-1).AND.MASK !Undo 2's complement
IANS(1) = 1000.0 * FLOAT(I)/HITEN !Ratio of width/height * 1000
RETURN
END