Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0141/fasp.for
There is 1 other file named fasp.for in the archive. Click here to see a list.
SUBROUTINE TEXT1
CRENBR(RENBRSTART)(TEXT1/LETTERS 9 WIDE BY 5 HIGH)
COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
1LETTER(96),LENGTH(96),IPACKD( 672)
DIMENSION JLETTR(47),JLETT1(47)
DIMENSION JLNGTH(47),JLNGT1(47)
DIMENSION JPACKD(235),JPACK1( 80),JPAC81( 80),
1 JPA161( 75)
EQUIVALENCE (LETTER(1),JLETTR(1)),
1(LENGTH(1),JLNGTH(1)),(IPACKD(1),JPACKD(1))
EQUIVALENCE (JLETT1(1),JLETTR(1))
EQUIVALENCE (JLNGT1(1),JLNGTH(1))
EQUIVALENCE (JPACK1(1),JPACKD( 1)),
1 (JPAC81(1),JPACKD( 81)),
2 (JPA161(1),JPACKD(161))
DATA JLETT1/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
2 1HU,1HV,1HW,1HX,1HY,1HZ,1H0,1H1,1H2,1H3,
3 1H4,1H5,1H6,1H7,1H8,1H9,1H(,1H*,1H/,1H+,
4 1H-,1H=,1H),1H:,1H',1H.,1H,/
DATA JLNGT1/ 9, 9, 9, 9, 9, 9, 9, 9, 7, 9, 9, 9,11,
1 9, 9, 9,11, 9, 9, 9, 9, 9,11, 9, 9, 9,
2 9, 5, 9, 9, 9, 9, 9, 9, 9, 9, 5, 9, 7,
3 9, 9, 9, 5, 2, 2, 2, 2/
DATA JPACK1/ 56, 238, 455, 511, 455, 511, 455, 508,
1 455, 511, 511, 448, 448, 448, 511, 508,
2 455, 455, 455, 508, 511, 448, 504, 448,
3 511, 511, 448, 504, 448, 448, 511, 448,
4 463, 455, 511, 455, 455, 511, 455, 455,
5 127, 28, 28, 28, 127, 7, 7, 7,
6 455, 511, 455, 462, 508, 462, 455, 448,
7 448, 448, 448, 511,1799,1935,1879,1831,
8 1799, 455, 487, 471, 463, 455, 511, 455,
9 455, 455, 511, 511, 455, 511, 448, 448/
DATA JPAC81/2044,1820,1820,1820,2047, 511, 455, 508,
1 462, 455, 254, 448, 254, 7, 510, 511,
2 56, 56, 56, 56, 455, 455, 455, 455,
3 511, 455, 455, 238, 124, 56,1799,1831,
4 1879,1935,1799, 455, 238, 56, 238, 455,
5 455, 238, 56, 56, 56, 511, 14, 56,
6 224, 511, 511, 455, 455, 455, 511, 7,
7 31, 7, 7, 7, 511, 7, 127, 448,
8 511, 511, 7, 28, 7, 511, 119, 231,
9 511, 7, 7, 511, 448, 508, 7, 511/
DATA JPA161/ 112, 224, 511, 455, 511, 511, 14, 28,
1 56, 112, 511, 455, 124, 455, 511, 511,
2 455, 511, 14, 28, 7, 28, 28, 28,
3 7, 238, 56, 511, 56, 238, 7, 14,
4 28, 56, 112, 56, 56, 511, 56, 56,
5 0, 0, 511, 0, 0, 0, 511, 0,
6 511, 0, 28, 7, 7, 7, 28, 3,
7 3, 0, 3, 3, 3, 3, 1, 0,
8 0, 0, 0, 0, 3, 3, 0, 0,
9 3, 3, 1/
DATA KNTLTR,IHIGH,IWIDE,JWIDE,LOCK/ 47, 5, 9,11,999/
RETURN
C767780423690:'
END
SUBROUTINE TEXT2
CRENBR(RENBRSTART)(TEXT2/LETTERS 5 WIDE BY 5 HIGH)
COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
1LETTER(96),LENGTH(96),IPACKD( 672)
DIMENSION JLETTR(58),JLETT1(58)
DIMENSION JLNGTH(58),JLNGT1(58)
DIMENSION JPACKD(290),JPACK1(130),JPA131(130),
1 JPA261( 30)
EQUIVALENCE (LETTER(1),JLETTR(1)),
1(LENGTH(1),JLNGTH(1)),(IPACKD(1),JPACKD(1))
EQUIVALENCE (JLETT1(1),JLETTR(1))
EQUIVALENCE (JLNGT1(1),JLNGTH(1))
EQUIVALENCE (JPACK1(1),JPACKD( 1)),
1 (JPA131(1),JPACKD(131)),
2 (JPA261(1),JPACKD(261))
DATA JLETT1/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
2 1HU,1HV,1HW,1HX,1HY,1HZ,1H0,1H1,1H2,1H3,
3 1H4,1H5,1H6,1H7,1H8,1H9,1H(,1H),1H+,1H-,
4 1H*,1H/,1H.,1H,,1H',1H:,1H^,1H",1H#,1H$,
5 1H%,1H&,1H=,1H<,1H>,1H?,1H@,1H!/
DATA JLNGT1/5,5,5,5,5,5,5,5,3,5,5,5,5,5,5,5,5,5,5,5,
1 5,5,5,5,5,5,5,3,5,5,5,5,5,5,5,5,3,3,5,5,
2 5,5,2,2,2,2,5,5,5,5,5,5,5,3,3,5,5,1/
DATA JPACK1/ 4,10,17,31,17,30,17,30,17,30,15,16,16,
1 16,15,30,17,17,17,30,31,16,30,16,31,31,
2 16,30,16,16,15,16,19,17,15,17,17,31,17,
3 17, 7, 2, 2, 2, 7, 1, 1, 1,17,14,17,18,
4 28,18,17,16,16,16,16,31,17,27,21,17,17,
5 17,25,21,19,17,14,17,17,17,14,30,17,30,
6 16,16,14,17,21,18,13,30,17,30,18,17,15,
7 16,14, 1,30,31, 4, 4, 4, 4,17,17,17,17,
8 14,17,17,17,10, 4,17,17,21,27,17,17,10,
9 4,10,17,17,10, 4, 4, 4,31, 2, 4, 8,31/
DATA JPA131/14,17,17,17,14, 6, 2, 2, 2, 7,30, 1,14,
1 16,31,30, 1, 6, 1,30,17,17,31, 1, 1,31,
2 16,30, 1,30, 4, 8,30,17,14,31, 2, 4, 8,
3 16,14,17,14,17,14,14,17,15, 2, 4, 3, 4,
4 4, 4, 3, 6, 1, 1, 1, 6, 0, 4,31, 4, 0,
5 0, 0,31, 0, 0, 0,14,31,14, 0, 1, 2, 4,
6 8,16, 0, 0, 0, 3, 3, 0, 0, 3, 3, 1, 3,
7 3, 1, 0, 0, 3, 3, 0, 3, 3, 4,10,17, 0,
8 0,27,27, 9, 0, 0,10,27, 0,27,10,15,20,
9 14, 5,30,25,26, 4,11,19,28, 8,21,18,13/
DATA JPA261/ 0,31, 0,31, 0, 1, 2, 4, 2, 1, 4, 2, 1,
1 2, 4,30, 1, 6, 0, 4,14,17,19,19, 8, 1,
2 1, 1, 0, 1/
DATA KNTLTR,IHIGH,IWIDE,JWIDE,LOCK/ 58, 5, 5, 5,999/
RETURN
C750874299490':^"#$%&<>?@!
END
SUBROUTINE TEXT3
CRENBR(RENBRSTART)(TEXT3/LETTERS 12 WIDE BY 11 HIGH)
COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
1LETTER(96),LENGTH(96),IPACKD( 672)
DIMENSION JLETTR(59),JLETT1(59)
DIMENSION JLNGTH(59),JLNGT1(59)
DIMENSION JPACKD(649),JPACK1( 80),JPAC81( 80),
1 JPA161( 80),JPA241( 80),JPA321( 80),
2 JPA401( 80),JPA481( 80),JPA561( 80),
3 JPA641( 9)
EQUIVALENCE (LETTER(1),JLETTR(1)),
1(LENGTH(1),JLNGTH(1)),(IPACKD(1),JPACKD(1))
EQUIVALENCE (JLETT1(1),JLETTR(1))
EQUIVALENCE (JLNGT1(1),JLNGTH(1))
EQUIVALENCE (JPACK1(1),JPACKD( 1)),
1 (JPAC81(1),JPACKD( 81)),
2 (JPA161(1),JPACKD(161)),
3 (JPA241(1),JPACKD(241)),
4 (JPA321(1),JPACKD(321)),
5 (JPA401(1),JPACKD(401)),
6 (JPA481(1),JPACKD(481)),
7 (JPA561(1),JPACKD(561)),
8 (JPA641(1),JPACKD(641))
DATA JLETT1/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
2 1HU,1HV,1HW,1HX,1HY,1HZ,1H0,1H1,1H2,1H3,
3 1H4,1H5,1H6,1H7,1H8,1H9,1H<,1H>,1H%,1H$,
4 1H?,1H^,1H!,1H#,1H&,1H@,1H/,1H+,1H*,1H-,
5 1H=,1H(,1H',1H:,1H",1H;,1H.,1H,,1H)/
DATA JLNGT1/12,12,12,12,12,12,12,12, 6,12,12,12,12,
1 12,12,12,12,12,12,12,12,12,12,12,12,12,
2 12, 6,12,12,12,12,12,12,12,12,10,10,12,
3 12,12,12, 4,12,12,12,12,12,12,12,12, 8,
4 3, 4, 9, 4, 4, 3, 8/
DATA JPACK1/ 96, 240, 408, 780,1542,3075,3075,4095,
1 3075,3075,3075,4088,3078,3075,3075,3078,
2 4088,3078,3075,3075,3078,4088, 504,1542,
3 3075,3072,3072,3072,3072,3072,3075,1542,
4 504,4080,3084,3078,3075,3075,3075,3075,
5 3075,3078,3084,4080,4095,3072,3072,3072,
6 3072,4080,3072,3072,3072,3072,4095,4095,
7 3072,3072,3072,3072,4080,3072,3072,3072,
8 3072,3072, 504,1542,3075,3072,3072,3072,
9 3103,3075,3075,1539, 511,3075,3075,3075/
DATA JPAC81/3075,3075,4095,3075,3075,3075,3075,3075,
1 63, 12, 12, 12, 12, 12, 12, 12,
2 12, 12, 63, 3, 3, 3, 3, 3,
3 3, 3, 3,3075,1542, 504,3084,3096,
4 3120,3168,3264,3552,3888,3608,3084,3078,
5 3075,3072,3072,3072,3072,3072,3072,3072,
6 3072,3072,3072,4095,3075,3591,3855,3483,
7 3315,3171,3075,3075,3075,3075,3075,3075,
8 3587,3843,3459,3267,3171,3123,3099,3087,
9 3079,3075, 504,1542,3075,3075,3075,3075/
DATA JPA161/3075,3075,3075,1542, 504,4088,3078,3075,
1 3075,3078,4088,3072,3072,3072,3072,3072,
2 504,1542,3075,3075,3075,3075,3075,3097,
3 3084,1542, 499,4088,3078,3075,3075,3078,
4 4088,3120,3096,3084,3078,3075, 504,1542,
5 3075,3072,1536, 504, 6, 3,3075,1542,
6 504,4095, 96, 96, 96, 96, 96, 96,
7 96, 96, 96, 96,3075,3075,3075,3075,
8 3075,3075,3075,3075,3075,1542, 504,3075,
9 3075,3075,3075,3075,3075,1542, 780, 408/
DATA JPA241/ 240, 96,3075,3075,3075,3075,3075,3171,
1 3315,3483,3855,3591,3075,3075,1542, 780,
2 408, 240, 96, 240, 408, 780,1542,3075,
3 3075,1542, 780, 408, 240, 96, 96, 96,
4 96, 96, 96,4095, 6, 12, 24, 48,
5 96, 192, 384, 768,1536,4095, 504,1542,
6 3075,3075,3075,3075,3075,3075,3075,1542,
7 504, 12, 28, 60, 12, 12, 12, 12,
8 12, 12, 12, 63, 504,1542,3075, 3,
9 6, 24, 96, 384,1536,3072,4095, 504/
DATA JPA321/1542,3075, 3, 6, 248, 6, 3,3075,
1 1542, 504, 48, 96, 192, 387, 771,1539,
2 4095, 3, 3, 3, 3,4095,3072,3072,
3 3072,3072,4088, 6, 3, 3, 6,4088,
4 24, 48, 96, 192, 384,1016,1542,3075,
5 3075,1542, 504,4095, 6, 12, 24, 48,
6 96, 96, 96, 96, 96, 96, 504,1542,
7 3075,3075,1542, 504,1542,3075,3075,1542,
8 504, 504,1542,3075,3075,1542, 508, 24,
9 48, 96, 192, 384, 0, 3, 12, 48/
DATA JPA401/ 192, 768, 192, 48, 12, 3, 0, 0,
1 768, 192, 48, 12, 3, 12, 48, 192,
2 768, 0,1795,2182,2188,1816, 48, 96,
3 192, 398, 785,1553,3086, 96, 96,1023,
4 3168,3168,1020, 99, 99,4092, 96, 96,
5 4088, 6, 3, 3, 6, 504, 384, 0,
6 384, 960, 384, 96, 240, 408, 780,1542,
7 3075, 0, 0, 0, 0, 0, 6, 6,
8 6, 6, 6, 6, 6, 0, 6, 15,
9 6, 408, 408, 408,3999, 0, 0, 0/
DATA JPA481/3999, 408, 408, 408, 480, 816, 816, 480,
1 192, 480, 816,1563,3084,3126,1987, 504,
2 1542,3075,3171,3219,3219,3219,3198,3072,
3 1536, 511, 3, 6, 12, 24, 48, 96,
4 192, 384, 768,1536,3072, 0, 0, 96,
5 96, 96,4095, 96, 96, 96, 0, 0,
6 0, 0, 780, 408, 240,4095, 240, 408,
7 780, 0, 0, 0, 0, 0, 0, 0,
8 4095, 0, 0, 0, 0, 0, 0, 0,
9 0,4095, 0, 0, 0,4095, 0, 0/
DATA JPA561/ 0, 15, 56, 96, 192, 192, 192, 192,
1 192, 96, 56, 15, 6, 7, 3, 6,
2 0, 0, 0, 0, 0, 0, 0, 6,
3 15, 6, 0, 0, 0, 0, 0, 6,
4 15, 6, 390, 455, 195, 390, 0, 0,
5 0, 0, 0, 0, 0, 6, 15, 6,
6 0, 0, 0, 0, 6, 7, 3, 6,
7 0, 0, 0, 0, 0, 0, 0, 0,
8 6, 15, 6, 0, 0, 0, 0, 0,
9 0, 0, 6, 7, 3, 6, 240, 28/
DATA JPA641/ 6, 3, 3, 3, 3, 3, 6, 28,
1 240/
DATA KNTLTR,IHIGH,IWIDE,JWIDE,LOCK/ 59,11,12,12,999/
RETURN
C330359958028<>%$?^!#&@':";
END
SUBROUTINE TEXT4
CRENBR(RENBRSTART)(TEXT4/LETTERS 7 HIGH BY 9 WIDE)
COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
1LETTER(96),LENGTH(96),IPACKD( 672)
DIMENSION JLETTR(54),JLETT1(54)
DIMENSION JLNGTH(54),JLNGT1(54)
DIMENSION JPACKD(378),JPACK1(100),JPA101(100),
1 JPA201(100),JPA301( 78)
EQUIVALENCE (LETTER(1),JLETTR(1)),
1(LENGTH(1),JLNGTH(1)),(IPACKD(1),JPACKD(1))
EQUIVALENCE (JLETT1(1),JLETTR(1))
EQUIVALENCE (JLNGT1(1),JLNGTH(1))
EQUIVALENCE (JPACK1(1),JPACKD( 1)),
1 (JPA101(1),JPACKD(101)),
2 (JPA201(1),JPACKD(201)),
3 (JPA301(1),JPACKD(301))
DATA JLETT1/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
2 1HU,1HV,1HW,1HY,1HX,1HZ,1H0,1H1,1H2,1H3,
3 1H4,1H5,1H6,1H7,1H8,1H9,1H(,1H+,1H-,1H*,
4 1H/,1H=,1H.,1H,,1H',1H),1H^,1H?,1H<,1H>,
5 1H#,1H:,1H;,1H!/
DATA JLNGT1/ 9, 8, 8, 8, 8, 8, 8, 8, 6, 8, 8, 8,10,
1 8, 9, 8, 9, 8, 8, 8, 8, 8,10, 8, 8, 8,
2 8, 4, 8, 8, 8, 8, 8, 8, 8, 8, 5, 8, 8,
3 8, 8, 8, 2, 3, 3, 5, 8, 8, 6, 6, 8, 2,
4 3, 2/
DATA JPACK1/ 7, 15, 27, 51,127,195,387,252,195,195,
1 252,195,195,252, 31, 96,192,192,192, 96,
2 31,248,198,195,195,195,198,248,255,192,
3 192,248,192,192,255,255,192,192,248,192,
4 192,192, 31, 96,192,207,195, 99, 31,195,
5 195,195,255,195,195,195, 63, 12, 12, 12,
6 12, 12, 63, 3, 3, 3, 3,195,102, 60,
7 198,204,216,248,236,198,195,192,192,192,
8 192,192,192,255,771,903,975,891,819,771,
9 771,195,227,243,219,207,199,195,124,198/
DATA JPA101/387,387,387,198,124,252,195,195,252,192,
1 192,192,124,198,387,411,397,198,123,252,
2 195,195,252,204,198,195, 63,192,192, 60,
3 3, 3,252,255, 24, 24, 24, 24, 24, 24,
4 195,195,195,195,195,102, 60,195,198,204,
5 216,240,224,192,771,771,819,891,975,903,
6 771,195,102, 60, 24, 24, 24, 24,195,102,
7 60, 24, 60,102,195,255, 6, 12, 24, 48,
8 96,255, 60,102,195,195,195,102, 60, 3,
9 15, 3, 3, 3, 3, 3,252, 3, 3, 60/
DATA JPA201/192,192,255,252, 3, 3, 60, 3, 3,252,
1 15, 27, 51, 99,255, 3, 3,255,192,192,
2 252, 3, 3,252, 12, 24, 48,124,195,195,
3 60,255, 3, 6, 12, 24, 24, 24, 60,195,
4 195, 60,195,195, 60, 60,195,195, 62, 12,
5 24, 48, 3, 12, 24, 24, 24, 12, 3, 0,
6 24, 24,255, 24, 24, 0, 0, 0, 0,255,
7 0, 0, 0, 0,102, 60,255, 60,102, 0,
8 3, 6, 12, 24, 48, 96,192, 0, 0,255,
9 0,255, 0, 0, 0, 0, 0, 0, 0, 3/
DATA JPA301/ 3, 0, 0, 0, 0, 7, 3, 6, 7, 3,
1 6, 0, 0, 0, 0, 24, 6, 3, 3, 3,
2 6, 24, 24, 60,102,195, 0, 0, 0,252,
3 3, 3, 28, 0, 24, 24, 0, 3, 12, 48,
4 12, 3, 0, 0, 48, 12, 3, 12, 48, 0,
5 102,102,231, 0,231,102,102, 3, 3, 0,
6 0, 0, 3, 3, 3, 3, 0, 0, 7, 3,
7 6, 3, 3, 3, 3, 0, 3, 3/
DATA KNTLTR,IHIGH,IWIDE,JWIDE,LOCK/ 54, 7, 8,10,999/
RETURN
C383688310881'^?<>#:;!
END
SUBROUTINE TEXT5
CRENBR(TEXT5/LETTERS 14 WIDE BY 9 HIGH)
COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
1LETTER(96),LENGTH(96),IPACKD(1020)
DIMENSION JLETTR(85),JLETT1(85)
DIMENSION JLNGTH(85),JLNGT1(85)
DIMENSION JPACKD(1020),JPACK1( 50),JPAC51( 50),
1 JPA101( 50),JPA151( 50),JPA201( 50),
2 JPA251( 50),JPA301( 50),JPA351( 50),
3 JPA401( 50),JPA451( 50),JPA501( 50),
4 JPA551( 50),JPA601( 50),JPA651( 50),
5 JPA701( 50),JPA751( 50),JPA801( 50),
6 JPA851( 50),JPA901( 50),JPA951( 50),
7 JP1001( 20)
EQUIVALENCE (LETTER(1),JLETTR(1)),
1(LENGTH(1),JLNGTH(1)),(IPACKD(1),JPACKD(1))
EQUIVALENCE (JLETT1(1),JLETTR(1))
EQUIVALENCE (JLNGT1(1),JLNGTH(1))
EQUIVALENCE (JPACK1(1),JPACKD( 1)),
1 (JPAC51(1),JPACKD( 51)),
2 (JPA101(1),JPACKD( 101)),
3 (JPA151(1),JPACKD( 151)),
4 (JPA201(1),JPACKD( 201)),
5 (JPA251(1),JPACKD( 251)),
6 (JPA301(1),JPACKD( 301)),
7 (JPA351(1),JPACKD( 351)),
8 (JPA401(1),JPACKD( 401)),
9 (JPA451(1),JPACKD( 451))
EQUIVALENCE (JPA501(1),JPACKD( 501)),
1 (JPA551(1),JPACKD( 551)),
2 (JPA601(1),JPACKD( 601)),
3 (JPA651(1),JPACKD( 651)),
4 (JPA701(1),JPACKD( 701)),
5 (JPA751(1),JPACKD( 751)),
6 (JPA801(1),JPACKD( 801)),
7 (JPA851(1),JPACKD( 851)),
8 (JPA901(1),JPACKD( 901)),
9 (JPA951(1),JPACKD( 951))
EQUIVALENCE (JP1001(1),JPACKD(1001))
DATA JLETT1/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
2 1HU,1HV,1HW,1HX,1HY,1HZ,1HA,1HB,1HC,1HD,
3 1HE,1HF,1HG,1HH,1HI,1HJ,1HK,1HL,1HM,1HN,
4 1HO,1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,1HX,
5 1HY,1HZ,1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,
6 1H8,1H9,1H;,1H.,1H:,1H!,1H,,1H",1H/,1H+,
7 1H*,1H-,1H',1H),1H(,1H=,1H#,1H^,1H<,1H>,
8 1H?,1H&,1H%,1H$,1H@/
DATA JLNGT1/14,14,14,14,14,14,14,14, 8,14,14,14,14,
1 14,14,14,14,14,14,14,14,14,14,14,14,14,
2 12,12,12,12,12,12,12,12, 4, 8,12, 4,20,
3 12,12,12,12,12,12,12,12,12,20,12,12,12,
4 14, 7,14,14,14,14,14,14,14,14, 4, 4, 4,
5 4, 3,10,12,14,14,14, 3,10,10,14,14,14,
6 10,10,14,14,14,14,14/
DATA JPACK1/ 192, 480, 1008, 1656, 3132,
1 6174, 16383, 12303, 12303, 0,
2 0, 0, 16368, 15422, 15375,
3 15422, 16368, 15422, 15375, 15422,
4 16368, 0, 0, 0, 1023,
5 7936, 15360, 15360, 15360, 15360,
6 15360, 7936, 1023, 0, 0,
7 0, 16320, 15608, 15390, 15375,
8 15375, 15375, 15390, 15608, 16320,
9 0, 0, 0, 16383, 15360/
DATA JPAC51/ 15360, 15360, 16352, 15360, 15360,
1 15360, 16383, 0, 0, 0,
2 16383, 15360, 15360, 15360, 16352,
3 15360, 15360, 15360, 15360, 0,
4 0, 0, 1023, 7936, 15360,
5 15360, 15360, 15423, 15375, 7951,
6 1023, 0, 0, 0, 15375,
7 15375, 15375, 15375, 16383, 15375,
8 15375, 15375, 15375, 0, 0,
9 0, 255, 60, 60, 60/
DATA JPA101/ 60, 60, 60, 60, 255,
1 0, 0, 0, 15, 15,
2 15, 15, 15, 15375, 15375,
3 7998, 1016, 0, 0, 0,
4 15367, 15388, 15472, 15808, 16128,
5 16320, 15600, 15420, 15375, 0,
6 0, 0, 15360, 15360, 15360,
7 15360, 15360, 15360, 15360, 15360,
8 16383, 0, 0, 0, 12303,
9 14367, 15423, 15983, 14287, 13199/
DATA JPA151/ 12559, 12303, 12303, 0, 0,
1 0, 15875, 16131, 14211, 13251,
2 12771, 12531, 12411, 12351, 12319,
3 0, 0, 0, 1008, 7998,
4 15375, 15375, 15375, 15375, 15375,
5 7998, 1008, 0, 0, 0,
6 16368, 15422, 15375, 15375, 15422,
7 16368, 15360, 15360, 15360, 0,
8 0, 0, 1008, 7998, 15375,
9 15375, 15375, 15815, 15473, 7964/
DATA JPA201/ 1991, 0, 0, 0, 16368,
1 15422, 15375, 15375, 15422, 16376,
2 15420, 15390, 15375, 0, 0,
3 0, 1023, 7936, 15360, 7936,
4 1008, 62, 15, 62, 16368,
5 0, 0, 0, 16383, 480,
6 480, 480, 480, 480, 480,
7 480, 480, 0, 0, 0,
8 15363, 15363, 15363, 15363, 15363,
9 15363, 15363, 7966, 1016, 0/
DATA JPA251/ 0, 0, 15363, 15363, 15363,
1 7686, 3852, 1944, 1008, 480,
2 192, 0, 0, 0, 15363,
3 15363, 15395, 15475, 15611, 15775,
4 16143, 15879, 15363, 0, 0,
5 0, 15366, 7692, 3864, 1968,
6 1008, 888, 1596, 3102, 6159,
7 0, 0, 0, 15363, 7686,
8 3852, 1944, 1008, 480, 480,
9 480, 480, 0, 0, 0/
DATA JPA301/ 16383, 60, 120, 240, 480,
1 960, 1920, 3840, 16383, 0,
2 0, 0, 0, 0, 0,
3 2044, 15, 1023, 3855, 3855,
4 1023, 0, 0, 0, 3840,
5 3840, 3840, 4088, 3870, 3855,
6 3855, 3870, 4088, 0, 0,
7 0, 0, 0, 0, 511,
8 1920, 3840, 3840, 1920, 511,
9 0, 0, 0, 15, 15/
DATA JPA351/ 15, 511, 1935, 3855, 3855,
1 1935, 511, 0, 0, 0,
2 0, 0, 0, 504, 1950,
3 3855, 4095, 1920, 511, 0,
4 0, 0, 31, 120, 240,
5 4095, 240, 240, 240, 240,
6 240, 0, 0, 0, 0,
7 0, 0, 511, 1935, 3855,
8 3855, 1935, 511, 15, 30,
9 2040, 3840, 3840, 3840, 3900/
DATA JPA401/ 3966, 4047, 3983, 3855, 3855,
1 0, 0, 0, 6, 15,
2 6, 0, 15, 15, 15,
3 15, 15, 0, 0, 0,
4 6, 15, 6, 0, 15,
5 15, 15, 15, 15, 15,
6 30, 248, 3840, 3840, 3840,
7 3868, 3952, 4032, 4080, 3900,
8 3855, 0, 0, 0, 15,
9 15, 15, 15, 15, 15/
DATA JPA451/ 15, 15, 15, 0, 0,
1 0, 0, 0, 0, 998460,
2 1015422,1036239,1019791, 986895, 986895,
3 0, 0, 0, 0, 0,
4 0, 3900, 3966, 4047, 3983,
5 3855, 3855, 0, 0, 0,
6 0, 0, 0, 504, 1950,
7 3855, 3855, 1950, 504, 0,
8 0, 0, 0, 0, 0,
9 4088, 3870, 3855, 3855, 3870/
DATA JPA501/ 4088, 3840, 3840, 3840, 0,
1 0, 0, 511, 1935, 3855,
2 3855, 1935, 511, 15, 15,
3 15, 0, 0, 0, 3871,
4 3960, 4032, 3840, 3840, 3840,
5 0, 0, 0, 0, 0,
6 0, 1023, 3840, 2032, 254,
7 15, 4092, 0, 0, 0,
8 240, 240, 240, 4095, 240,
9 240, 240, 240, 240, 0/
DATA JPA551/ 0, 0, 0, 0, 0,
1 3855, 3855, 3871, 3903, 2031,
2 975, 0, 0, 0, 0,
3 0, 0, 3843, 1926, 972,
4 504, 240, 96, 0, 0,
5 0, 0, 0, 0, 983811,
6 493446, 249804, 129528, 61680, 24672,
7 0, 0, 0, 0, 0,
8 0, 3847, 1948, 496, 248,
9 926, 3599, 0, 0, 0/
DATA JPA601/ 0, 0, 0, 3843, 1926,
1 972, 504, 240, 96, 192,
2 896, 3584, 0, 0, 0,
3 4095, 30, 120, 480, 1920,
4 4095, 0, 0, 0, 1008,
5 7998, 15375, 15375, 15375, 15375,
6 15375, 7998, 1008, 0, 0,
7 0, 3, 15, 127, 15,
8 15, 15, 15, 15, 15,
9 0, 0, 0, 16368, 62/
DATA JPA651/ 15, 62, 1008, 7936, 15360,
1 15360, 16383, 0, 0, 0,
2 16368, 62, 15, 62, 1008,
3 62, 15, 62, 16368, 0,
4 0, 0, 508, 828, 1596,
5 3132, 6204, 16383, 16383, 60,
6 60, 0, 0, 0, 16383,
7 15360, 15360, 16368, 62, 15,
8 15, 62, 16368, 0, 0,
9 0, 60, 480, 1920, 7680/
DATA JPA701/ 16368, 15422, 15375, 7998, 1008,
1 0, 0, 0, 16383, 15,
2 15, 30, 60, 120, 240,
3 480, 960, 0, 0, 0,
4 2040, 7694, 15367, 7950, 1008,
5 7228, 14351, 7198, 2040, 0,
6 0, 0, 1008, 7998, 15375,
7 7951, 1023, 30, 120, 480,
8 3840, 0, 0, 0, 6,
9 15, 6, 0, 0, 6/
DATA JPA751/ 7, 3, 6, 0, 0,
1 0, 0, 0, 0, 0,
2 0, 0, 6, 15, 6,
3 0, 0, 0, 6, 15,
4 6, 0, 0, 0, 6,
5 15, 6, 0, 0, 0,
6 15, 15, 15, 15, 15,
7 0, 6, 15, 6, 0,
8 0, 0, 0, 0, 0,
9 0, 0, 6, 7, 3/
DATA JPA801/ 6, 0, 0, 0, 774,
1 903, 387, 774, 0, 0,
2 0, 0, 0, 0, 0,
3 0, 15, 30, 60, 120,
4 240, 480, 960, 1920, 3840,
5 0, 0, 0, 0, 480,
6 480, 480, 16383, 16383, 480,
7 480, 480, 0, 0, 0,
8 0, 3612, 1848, 1008, 16383,
9 16383, 1008, 1848, 3612, 0/
DATA JPA851/ 0, 0, 0, 0, 0,
1 0, 16383, 16383, 0, 0,
2 0, 0, 0, 0, 6,
3 7, 3, 6, 0, 0,
4 0, 0, 0, 0, 0,
5 0, 992, 124, 30, 15,
6 15, 15, 30, 124, 992,
7 0, 0, 0, 31, 248,
8 480, 960, 960, 960, 480,
9 248, 31, 0, 0, 0/
DATA JPA901/ 0, 16383, 16383, 0, 0,
1 0, 16383, 16383, 0, 0,
2 0, 0, 3612, 3612, 16383,
3 3612, 3612, 3612, 16383, 3612,
4 3612, 0, 0, 0, 192,
5 1008, 3900, 15375, 0, 0,
6 0, 0, 0, 0, 0,
7 0, 0, 15, 60, 240,
8 960, 240, 60, 15, 0,
9 0, 0, 0, 0, 960/
DATA JPA951/ 240, 60, 15, 60, 240,
1 960, 0, 0, 0, 0,
2 16368, 62, 15, 62, 2032,
3 0, 768, 1920, 768, 0,
4 0, 0, 1016, 7680, 7680,
5 2016, 7680, 15423, 15374, 7708,
6 2032, 0, 0, 0, 7198,
7 13884, 13944, 7408, 480, 974,
8 1947, 3867, 7694, 0, 0,
9 0, 192, 192, 4095, 15360/
DATA JP1001/ 4092, 15, 16380, 192, 192,
1 0, 0, 0, 2040, 7182,
2 12771, 13107, 13107, 13107, 12798,
3 7168, 2047, 0, 0, 0/
DATA KNTLTR,IHIGH,IWIDE,JWIDE,LOCK/ 85,12,14,20,999/
RETURN
C974371065670;:!"'#^<>?&%$@
END
SUBROUTINE GETWRD(IPACKD,IBUFFR,MAXBFR,LOWBFR,KIND )
C RENBR(/GET NEXT WORD IN SINGLE LINE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TAKING AS INPUT LIST OF POSSIBLE WORDS
C SUPPLIED IN MULTIPLE OF A5 FORMAT, AND MATCHES NEXT
C WORD IN LINE OF TEXT READ WITH MULTIPLE OF A1 FORMAT
C
C IPACKD = STRING OF WORDS SIMILAR TO '/YES NO/'
C WHERE INITIAL CHARACTER WITHIN STRING
C (HERE SLASH) ALSO MARKS END OF STRING.
C STRING CAN CONTAIN AT MOST 20 WORDS FORMED
C FROM TOTAL OF NO MORE THAN 100 CHARACTERS.
C IBUFFR = TEXT TYPED BY USER READ BY MULTIPLE OF A1
C FORMAT
C MAXBFR = NUMBER OF CHARACTERS IN IBUFFR
C LOWBFR = INITIALLY SHOULD BE INPUT CONTAINING ZERO
C TO ALLOW INITIAL COMMA TO INDICATE MISSING
C ITEM. THEREAFTER SHOULD BE INPUT CONTAINING
C SUBSCRIPT OF NEXT LOCATION IN IBUFFR ARRAY
C WHICH IS TO BE EXAMINED.
C = RETURNED POINTING TO NEXT CHARACTER NOT YET
C EXAMINED.
C KIND = SEQUENCE NUMBER OF MATCHED WORD PLUS 3.
C = 1, LINE IS EMPTY
C = 2, ERROR MESSAGE TYPE TO USER
C = 3, MISSING ITEM INDICATED BY EXTRA COMMA
C
DIMENSION IPACKD(100),IBUFFR(MAXBFR),KNTLTR(20),
1IWORD(100)
DATA ITTY,LMTWRD,LMTKNT/5,100,20/
DATA IWHAT/1H?/
C
C CONSTRUCT A1 FORMAT DICTIONARY
MAXWRD=0
MAXKNT=0
CALL A5TOA1(IPACKD,100,LMTWRD,LMTKNT,MAXWRD,MAXKNT,
1IWORD,KNTLTR)
C
C MATCH USER TYPED TEXT AGAINST A1 FORMAT DICTIONARY
MANY=1
IF(LOWBFR.GT.0)GO TO 1
LOWBFR=1
MANY=0
1 LOCK=MANY
CALL DALOSS(1,MAXWRD,IWORD,1,MAXKNT,
1KNTLTR,IBUFFR,MAXBFR,LOWBFR,KIND,MATCH,LCNWRD,
2LCNKNT,LCNBFR,MANY,LCNERR)
GO TO(5,6,12,12,6,6,6,6,2,4,11),KIND
C
C TREAT SEMICOLON LIKE COMMA
2 IF(LOCK.EQ.0)GO TO 3
MANY=-1
GO TO 1
3 LOWBFR=LOWBFR-1
GO TO 11
C
C BUFFER IS EMPTY
4 IF(MANY.LT.0)GO TO 11
5 KIND=1
GO TO 13
C
C UNKNOWN INITIAL CHARACTER
6 LOWBFR=LCNERR
LCNERR=LCNERR-1
KIND=2
WRITE(ITTY,7)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
7 FORMAT(' ILLEGAL RESPONSE ',132A1)
WRITE(ITTY,8)
8 FORMAT(' RESPOND WITH ONE OF FOLLOWING')
LTREND=0
KNTEND=0
9 KNTEND=KNTEND+1
IF(KNTEND.GT.MAXKNT)GO TO 13
LTRBGN=LTREND+1
LTREND=LTREND+KNTLTR(KNTEND)
WRITE(ITTY,10)(IWORD(I),I=LTRBGN,LTREND)
10 FORMAT(3X,132A1)
GO TO 9
C
C MISSING WORD
11 KIND=3
GO TO 13
C
C CORRECT MATCH FOUND
12 KIND=MATCH+3
C
C RETURN TO CALLING PROGRAM
13 RETURN
C377634367196?'
END
SUBROUTINE GETNUM(KONTRL,IBUFFR,MAXBFR,LOWBFR,KIND ,
1 IVALUE,VALUE )
C RENBR(/GET NEXT NUMBER IN SINGLE LINE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C KONTRL = 0, RETURN INTEGER AS ARGUMENT IVALUE
C = 1, RETURN REAL NUMBER IN ARGUMENT VALUE
C IBUFFR = TEXT TYPED BY USER READ WITH MULTIPLE OF A1
C FORMAT
C MAXBFR = NUMBER OF CHARACTERS IN IBUFFR
C LOWBFR = INITIALLY SHOULD BE INPUT CONTAINING ZERO
C TO ALLOW INITIAL COMMA TO INDICATE MISSING
C ITEM. THEREAFTER SHOULD BE INPUT CONTAINING
C SUBSCRIPT OF NEXT LOCATION IN IBUFFR ARRAY
C WHICH IS TO BE EXAMINED.
C = RETURNED POINTING TO NEXT CHARACTER NOT YET
C EXAMINED.
C KIND = 1, LINE IS EMPTY
C = 2, ERROR MESSAGE TYPED TO USER
C = 3, MISSING NUMBER
C = 4, A NUMBER HAS BEEN EVALUATED
C IVALUE = RETURNED CONTAINING INTEGER VALUE IF
C KONTRL=0
C VALUE = RETURNED CONTAINING REAL VALUE IF KONTRL=1
C
DIMENSION IBUFFR(MAXBFR)
DATA IWHAT/1H?/
DATA ITTY/5/
C
C OBTAIN NEXT ITEM IN TEXT BUFFER
MANY=1
IF(LOWBFR.GT.0)GO TO 1
LOWBFR=1
MANY=0
1 LOCK=MANY
CALL DAMISS(KONTRL,1,0,IBUFFR,MAXBFR,
1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2VALUE,MANY,LCNBFR,LCNERR)
GO TO(5,12,6,6,2,4,14),KIND
C
C TREAT SEMICOLON LIKE COMMA
2 IF(LOCK.EQ.0)GO TO 3
MANY=-1
GO TO 1
3 LOWBFR=LOWBFR-1
GO TO 14
C
C BUFFER IS EMPTY
4 IF(MANY.LT.0)GO TO 14
5 KIND=1
GO TO 15
C
C NUMBER FOUND
6 IF(LSHIFT.LT.0)GO TO 8
IF(KONTRL.GT.0)GO TO 7
IF(KSHIFT.LT.0)GO TO 10
7 KIND=4
GO TO 15
C
C ILLEGAL NUMBER REPRESENTATION
8 LOWBFR=LCNERR
LCNERR=LCNERR-1
WRITE(ITTY,9)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
9 FORMAT(' NUMBER REQUIRED BUT NO VALUE DIGITS IN ',
1132A1)
KIND=2
GO TO 15
10 LOWBFR=LCNERR
LCNERR=LCNERR-1
WRITE(ITTY,11)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
11 FORMAT(' INTEGER REQUIRED BUT TENTHS SPECIFIED IN ',
1132A1)
KIND=2
GO TO 15
C
C UNKNOWN INITIAL CHARACTER
12 LOWBFR=LCNERR
LCNERR=LCNERR-1
WRITE(ITTY,13)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
13 FORMAT(' NUMBER EXPECTED BUT INSTEAD FOUND ',132A1)
KIND=2
GO TO 15
C
C MISSING NUMBER
14 KIND=3
C
C RETURN TO CALLING PROGRAM
15 RETURN
C372999423353?'
END
SUBROUTINE A5TOA1(IPACKD,LMTPKD,LMTWRD,LMTKNT,MAXWRD,
1 MAXKNT,IWORD ,KNTLTR)
C RENBR(/CONVERT A5 DEFINED ARRAY TO A1)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO RESTRUCTURE DICTIONARY, SPECIFIED AS WORDS
C SEPARATED BY SPACES CONTAINED IN SINGLE LONG
C HOLLERITH STRING OR IN SINGLE LONG TEXT STRING QUOTED
C WITH APOSTROPHES, INTO IWORD ARRAY OF SINGLE
C CHARACTERS AND INTO KNTLTR ARRAY OF CHARACTER COUNTS
C PER WORD NEEDED BY DAVERB. SECOND APPEARANCE OF
C FIRST PRINTING CHARACTER MARKS END OF STRING.
C
C INEACH IS NUMBER OF CHARACTERS IN EACH HOLLERITH WORD
DIMENSION IPACKD(LMTPKD),KNTLTR(LMTKNT),IWORD(LMTWRD)
DATA INEACH/5/,IBLANK/1H /
KNTPKD=0
LOCAL=-1
LIMIT=LMTPKD
C
C GET NEXT GROUP OF CHARACTERS
1 NEEDED=LMTWRD-MAXWRD
IF(NEEDED.GT.INEACH)NEEDED=INEACH
IF(NEEDED.GT.LIMIT)NEEDED=LIMIT
IF(NEEDED.LE.0)GO TO 8
KNTPKD=KNTPKD+1
ISTART=MAXWRD+1
IEND=MAXWRD+NEEDED
LIMIT=LIMIT-NEEDED
C
C READ ALPHAMERIC INFORMATION FROM IPACKD(KNTPKD) INTO
C IWORD(ISTART) THROUGH IWORD(IEND) VIA THE INDICATED
C FORMAT. NEEDED IS THE NUMBER OF CHARACTERS TO READ.
DECODE(NEEDED,2,IPACKD(KNTPKD))
1(IWORD(I),I=ISTART,IEND)
2 FORMAT(100A1)
C
C FIND WORDS OR DELIMITER CHARACTERS
3 IF(ISTART.GT.IEND)GO TO 1
IF(LOCAL.LT.0)GO TO 5
IF(IWORD(ISTART).EQ.IFINAL)GO TO 8
IF(IWORD(ISTART).EQ.IBLANK)GO TO 6
IF(LOCAL.GT.0)GO TO 4
IF(MAXKNT.GE.LMTKNT)GO TO 8
MAXKNT=MAXKNT+1
KNTLTR(MAXKNT)=0
LOCAL=1
4 KNTLTR(MAXKNT)=KNTLTR(MAXKNT)+1
MAXWRD=MAXWRD+1
IWORD(MAXWRD)=IWORD(ISTART)
GO TO 7
5 IF(IWORD(ISTART).EQ.IBLANK)GO TO 7
IFINAL=IWORD(ISTART)
6 LOCAL=0
7 ISTART=ISTART+1
GO TO 3
8 RETURN
C283250238701
END
SUBROUTINE DAHELP(IBUFFR,MAXBFR,LOWBFR,IQUERY)
C RENBR(/DETERMINE NUMBER OF LEADING QUESTION MARKS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C IBUFFR = ARRAY CONTAINING CHARACTERS READ BY MULTIPLE
C OF A1 FORMAT.
C MAXBFR = SUBSCRIPT OF IBUFFR ARRAY LOCATION
C CONTAINING RIGHTMOST CHARACTER.
C LOWBFR = SUBSCRIPT OF FIRST LOCATION IN IBUFFR ARRAY
C TO BE TESTED. LOWBFR IS RETURNED POINTING
C TO THE FIRST NON-QUESTION MARK PRINTING
C CHARACTER IN BUFFER OR BEYOND END OF BUFFER
C IF NO OTHER PRINTING CHARACTERS APPEAR IN
C BUFFER.
C IQUERY = 0, RETURNED IF NO QUESTION MARKS APPEAR AT
C START OF TEXT IN IBUFFR ARRAY.
C = GREATER THAN ZERO, IQUERY IS NUMBER OF
C QUESTION MARKS FOUND AT START OF TEXT IN
C IBUFFR ARRAY.
C
DIMENSION IBUFFR(MAXBFR)
DATA IQUEST,ISPACE,ITAB/1H?,1H ,1H /
IQUERY=0
1 IF(LOWBFR.GT.MAXBFR)GO TO 3
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.ISPACE)GO TO 2
IF(LETTER.EQ.ITAB)GO TO 2
IF(LETTER.NE.IQUEST)GO TO 3
IQUERY=IQUERY+1
2 LOWBFR=LOWBFR+1
GO TO 1
3 RETURN
C098245027474?
END
SUBROUTINE DACASE(MINBFR,MAXBFR,IBUFFR)
C RENBR(/CONVERT LOWER CASE LETTERS TO UPPER)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C MINBFR = SUBSCRIPT OF FIRST LOCATION IN IBUFFR ARRAY
C CONTAINING CHARACTER TO BE CONVERTED TO
C UPPER CASE. MINBFR IS RETURNED UNCHANGED.
C MAXBFR = SUBSCRIPT OF FINAL LOCATION IN IBUFFR ARRAY
C CONTAINING CHARACTER TO BE CONVERTED TO
C UPPER CASE. MAXBFR IS RETURNED UNCHANGED.
C IBUFFR = ARRAY CONTAINING IN LOCATIONS HAVING
C SUBSCRIPTS MINBFR THROUGH MAXBFR CHARACTERS
C READ BY MULTPLE OF 1A FORMAT WHICH ARE TO BE
C CONVERTED TO UPPER CASE IF INPUT IN LOWER
C CASE.
C
DIMENSION IBUFFR(MAXBFR),KAPITL(26),LOWER(26)
C
C CCCC AAA UU UU TTTTTTTT IIII OOOO NN NN
C CC AAAA UU UU TT II OO OO NNN NN
C CC AA AA UU UU TT II OO OO NNNN NN
C CC AA AA UU UU TT II OO OO NN NN NN
C CC AAAAAAA UU UU TT II OO OO NN NNNN
C CC AA AA UU UU TT II OO OO NN NNN
C CCCC AA AA UUU TT IIII OOOO NN NN
C
C TO CONVERT LOWER CASE LETTERS IN THE INPUT TEXT
C BUFFER INTO UPPER CASE LETTERS, THIS ROUTINE COMPARES
C THE CHARACTERS IN THE INPUT TEXT BUFFER AGAINST THE
C LOWER CASE LETTERS IN THE LOWER ARRAY. THE LETTERS
C IN THE LOWER ARRAY MUST BE ARRANGED IN INCREASING
C NUMERICAL ORDER. IF THE NUMERICAL ORDER IS NOT THE
C SAME AS THE ALPHABETICAL ORDER, THEN THE DATA
C STATEMENTS APPEARING BELOW MUST BE CHANGED OR ELSE
C SOME OR ALL LOWER CASE LETTERS IN THE INPUT TEXT
C BUFFER WILL NOT BE CONVERTED INTO THE CORRESPONDING
C UPPER CASE LETTERS. ONCE THE LETTERS IN THE LOWER
C ARRAY ARE SORTED INTO INCREASING NUMERICAL ORDER, THE
C UPPER CASE LETTERS IN THE KAPITL ARRAY SHOULD BE
C REARRANGED SO THAT LOWER AND UPPER CASE VERSIONS OF
C EACH LETTER APPEAR IN LOCATIONS IN THE LOWER AND
C KAPITL ARRAYS HAVING THE SAME SUBSCRIPTS.
C
C IF THE COMPUTER UPON WHICH THIS ROUTINE IS USED DOES
C NOT SUPPORT LOWER CASE LETTERS, THEN BOTH THE LOWER
C AND KAPITL ARRAYS CAN CONTAIN THE LETTERS 1HA THROUGH
C 1HZ IN ALPHABETICAL ORDER (EVEN IF THIS IS NOT THE
C NUMERICALLY SORTED ORDER).
C
C KAPITL = UPPER CASE LETTERS A THROUGH Z SORTED ON
C LOWER ARRAY
DATA KAPITL/
11HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
21HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
31HU,1HV,1HW,1HX,1HY,1HZ/
C
C LOWER = LOWER CASE LETTERS A THROUGH Z SORTED INTO
C NUMERICALLY INCREASING ORDER
DATA LOWER/
11Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,
21Hk,1Hl,1Hm,1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,
31Hu,1Hv,1Hw,1Hx,1Hy,1Hz/
C
C THIS IS A TERNARY SEARCH TAKING ADVANTAGE OF THE SIZE
C OF ALPHABET BEING NEARLY 3**3. THE 3RD OF THE ARRAY
C CONTAINING THE DESIRED LETTER IS FIRST LOCATED, THEN
C THE 3RD OF THIS 3RD, AND FINALLY EACH OF THE
C REMAINING 3 LETTERS ARE TESTED INDIVIDUALLY. TO
C PREVENT TESTING AGAINST THE 27TH LETTER WHICH DOES
C NOT EXIST, UPPER 3RD IS TAKEN AS UPPER 9 SORTED
C LETTERS, RATHER THAN FROM 19TH THROUGH 27TH LETTERS,
C SO THAT LOWER(18) IS TESTED AGAINST IN UPPER 3RD EVEN
C THOUGH LETTER BEING MATCHED HAS ALREADY BEEN FOUND TO
C BE LARGER THAN THIS.
INDEX=MINBFR
1 IF(INDEX.GT.MAXBFR)GO TO 8
LETTER=IBUFFR(INDEX)
IF(LETTER.GT.LOWER(18))GO TO 3
IF(LETTER.GT.LOWER(9))GO TO 2
IF(LETTER.LT.LOWER(1))GO TO 7
J=3
GO TO 4
2 J=12
GO TO 4
3 IF(LETTER.GT.LOWER(26))GO TO 7
J=20
4 IF(LETTER.LE.LOWER(J))GO TO 5
J=J+3
IF(LETTER.GT.LOWER(J))J=J+3
5 IF(LETTER.EQ.LOWER(J))GO TO 6
J=J-1
IF(LETTER.EQ.LOWER(J))GO TO 6
J=J-1
IF(LETTER.NE.LOWER(J))GO TO 7
6 IBUFFR(INDEX)=KAPITL(J)
7 INDEX=INDEX+1
GO TO 1
8 RETURN
C
C THE FOLLOWING BINARY SEARCH COULD BE USED AS A MODEL
C IF A LARGER ALPHABET HAD TO BE CONVERTED
C INDEX=MINBFR
C GO TO 3
C 1 IBUFFR(INDEX)=KAPITL(NOWTST)
C 2 INDEX=INDEX+1
C 3 IF(INDEX.GT.MAXBFR)GO TO 7
C LETTER=IBUFFR(INDEX)
C IF(LETTER.LT.LOWER(1))GO TO 2
C IF(LETTER.GT.LOWER(26))GO TO 2
C MAXTST=26
C MINTST=1
C NOWTST=MINTST
C GO TO 5
C 4 MAXTST=NOWTST
C 5 LNGTST=(MAXTST-MINTST)/2
C NOWTST=MAXTST-LNGTST
C IF(LETTER.EQ.LOWER(NOWTST))GO TO 1
C IF(LETTER.GT.LOWER(NOWTST))GO TO 6
C IF(LNGTST.GT.0)GO TO 4
C IF(MAXTST.LE.MINTST)GO TO 2
C NOWTST=MINTST
C GO TO 4
C 6 IF(LNGTST.LE.0)GO TO 2
C MINTST=NOWTST
C GO TO 5
C 7 RETURN
C349007223700abcdefghijklmnopqrstuvwxyz
END
SUBROUTINE DATREE(KLIMB ,KOMPAR,ITYPE ,MINNOD,MAXNOD,
1 NODES ,MINCLM,MAXCLM,NOWCLM,KOLUMN,INITAL,KIND ,
2 NEWCLM)
C RENBR(/NODES IN NEXT LINE OF TREE REPRESENTATION)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO RETURN THE NODES WHICH WOULD BE IN NEXT
C LINE OF THE REPRESENTATION OF A SIMPLE TREE
C STRUCTURE. THE NODES ARE IDENTIFIED TO CALLING
C PROGRAM BY SUBSCRIPTS, AND ARE NOT REPRESENTED IN A
C FORM WHICH CAN BE DIRECTLY WRITTEN WITH A MULTIPLE OF
C AN A1 FORMAT.
C
C KLIMB = 0, ENTIRE TREE IS TO BE REPRESENTED
C = 1, ONLY PORTION OF TREE STARTING AT NODE
C HAVING IDENTIFICATION NUMBER IN NODES ARRAY
C EQUAL TO INPUT VALUE OF KOMPAR IS TO BE
C REPRESENTED
C KOMPAR = IF KLIMB=1, THEN KOMPAR IS EQUAL TO NUMBER
C IN NODES ARRAY WHICH IDENTIFIES NODE AT BASE
C OF TREE. PORTION OF TREE BELOW THIS NODE
C WILL NOT BE REPRESENTED.
C ITYPE = 0, EACH GROUP IN NODES ARRAY CONSISTS OF
C NUMBER OF ITEMS WHICH ARE IDENTIFIED IN
C GROUP FOLLOWED BY IDENTIFICATION OF CALLING
C ITEM AND THEN BY IDENTIFICATIONS OR SOME OR
C ALL OF ITEMS WHICH IT CALLS. NODES ARRAY IS
C TERMINATED BY GROUP CONTAINING ONLY SINGLE
C ZERO. IF ITEM 10 CALLS 11 AND 12, AND ITEM
C 11 CALLS 12 AND 13, THEN NODES ARRAY WOULD
C CONTAIN
C 3, 10, 11, 12, 3, 11, 12, 13 AND 0
C = 1, EACH GROUP IN NODES ARRAY CONSISTS OF
C NUMBER OF ITEMS IDENTIFIED IN GROUP FOLLOWED
C BY IDENTIFICATION OF ITEM CALLED AND THEN BY
C IDENTIFICATIONS OF SOME OR ALL OF ITEMS
C CALLING IT. NODES ARRAY IS TERMINATED BY
C GROUP CONTAINING ONLY SINGLE ZERO. FOR
C ABOVE EXAMPLE IN WHICH 12 IS CALLED BY BOTH
C 10 AND 11, IN WHICH 11 IS CALLED BY 10 AND
C IN WHICH 13 IS CALLED BY 11, NODES ARRAY
C WOULD CONTAIN
C 3, 12, 10, 11, 2, 11, 10, 2, 13, 11 AND 0
C MINNOD = LOWEST SUBSCRIPT TO USE IN NODES ARRAY
C MAXNOD = DIMENSION OF NODES ARRAY
C NODES = ARRAY CONTAINING NODE IDENTIFIERS
C MINCLM = SUBSCRIPT OF FIRST LOCATION IN KOLUMN ARRAY
C MAXCLM = SUBSCRIPT OF FINAL LOCATION IN KOLUMN ARRAY
C WHICH IS AVAILABLE FOR USE
C NOWCLM = MUST BE SET TO MINCLM-1 BEFORE THIS ROUTINE
C IS FIRST CALLED TO REPRESENT PARTICULAR
C TREE. RETURNED CONTAINING HIGHEST SUBSCRIPT
C USED IN KOLUMN ARRAY TO REPRESENT CURRENT
C LINE AND MUST BE SENT TO SUBSEQUENT CALL OF
C THIS ROUTINE UNCHANGED
C KOLUMN = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C NODES ARRAY OF THOSE NODES ON CURRENT LINE.
C CONTENTS OF KOLUMN ARRAY MUST BE SENT TO
C SUBSEQUENT CALL OF THIS ROUTINE UNCHANGED.
C CONTENTS OF KOLUMN ARRAY ARE IGNORED WHEN
C THIS ROUTINE IS CALLED WITH NOWCLM LESS THAN
C MINCLM
C INITAL = ARRAY DIMENSIONED SAME AS KOLUMN ARRAY, BUT
C WHICH IS USED ONLY FOR TRANSFER OF VALUES
C FROM ONE CALL OF THIS ROUTINE TO NEXT.
C CONTENTS OF THIS ARRAY MUST NOT BE CHANGED
C BETWEEN CALLS TO THIS ROUTINE UNTIL KIND IS
C RETURNED CONTAINING 1 INDICATING THAT TREE
C HAS BEEN COMPLETED.
C KIND = 1, RETURNED IF REPRESENTATION OF TREE HAD
C BEEN FINISHED BY PREVIOUS CALL
C = 2, LINE IN REPRESENTATION IS BEING RETURNED
C IN KOLUMN(MINCLM) THROUGH AND INCLUDING
C KOLUMN(NOWCLM)
C = 3, SAME AS KIND=2 EXCEPT THAT REPRESENTATION
C IS TERMINATED AT LOOP END
C = 4, SAME AS KIND=2 EXCEPT THAT NOT ALL NODES
C COULD BE REPRESENTED DUE TO TOO LITTLE ROOM
C IN KOLUMN ARRAY
C = 5, KLIMB WAS INPUT CONTAINING 1 AND NOWCLM
C CONTAINING MINCLM-1 INDICATING THAT PARTIAL
C TREE WAS DESIRED, BUT NODE IDENTIFIED BY
C KOMPAR COULD NOT BE FOUND IN NODES ARRAY.
C NO NODES ARE BEING RETURNED IN KOLUMN ARRAY,
C AND NOWCLM IS RETURNED CONTAINING MINCLM-1.
C NEWCLM = RETURNED CONTAINING LOWEST SUSCRIPT OF
C KOLUMN ARRAY WHICH HAS BEEN RETURNED
C CHANGED. INPUT VALUE IS IGNORED
C
DIMENSION NODES(MAXNOD),KOLUMN(MAXCLM),INITAL(MAXCLM)
C
KIND=1
IF(NOWCLM.GE.MINCLM)GO TO 21
NOWCLM=MINCLM-1
NEWCLM=MINCLM
LIMIT=MINNOD
IF(KLIMB.EQ.0)GO TO 3
C
C FIND ROOT IF SPECIFIED BY CALLING PROGRAM
1 ISIZE=NODES(LIMIT)
IF(ISIZE.LE.0)GO TO 25
JTEST=LIMIT
LOWER=LIMIT
LIMIT=LIMIT+ISIZE+1
IF(LIMIT.GT.MAXNOD)GO TO 25
2 LOWER=LOWER+1
IF(LOWER.GE.LIMIT)GO TO 1
IF(NODES(LOWER).NE.KOMPAR)GO TO 2
GO TO 14
C
C FIND NEXT ROOT IF NOT SPECIFIED BY CALLING PROGRAM
3 ISIZE=NODES(LIMIT)
IF(ISIZE.LE.0)GO TO 26
JTEST=LIMIT
LOWER=LIMIT+1
LIMIT=LOWER+ISIZE
IF(LIMIT.GT.MAXNOD)GO TO 26
IF(ITYPE.EQ.0)GO TO 9
IF(ISIZE.LE.1)GO TO 5
4 LOWER=LOWER+1
IF(LOWER.GE.LIMIT)GO TO 3
5 IDNTFY=NODES(LOWER)
6 NODTST=MINNOD
7 ISIZE=NODES(NODTST)
IF(ISIZE.LE.0)GO TO 10
ITEST=NODTST+1
NODTST=ITEST+ISIZE
IF(NODTST.GT.MAXNOD)GO TO 10
IF(ITYPE.EQ.0)GO TO 8
IF(ISIZE.LE.1)GO TO 7
8 IF(NODES(ITEST).NE.IDNTFY)GO TO 7
IF(ITYPE.NE.0)GO TO 4
IF(ITEST.LT.LOWER)GO TO 3
GO TO 14
9 IDNTFY=NODES(LOWER)
10 NODTST=MINNOD
11 ISIZE=NODES(NODTST)
IF(ISIZE.LE.0)GO TO 6
ITEST=NODTST+1
NODTST=ITEST+ISIZE
IF(NODTST.GT.MAXNOD)GO TO 6
IF(ITYPE.EQ.0)GO TO 12
IF(ISIZE.LE.1)GO TO 13
12 ITEST=ITEST+1
IF(ITEST.GE.NODTST)GO TO 11
13 IF(NODES(ITEST).NE.IDNTFY)GO TO 12
IF(ITYPE.EQ.0)GO TO 3
IF(ITEST.LT.LOWER)GO TO 4
C
C INSERT NEW NODE ONTO BRANCH
14 IF(NOWCLM.GE.MAXCLM)GO TO 24
NOWCLM=NOWCLM+1
KOLUMN(NOWCLM)=LOWER
INITAL(NOWCLM)=JTEST
IDNTFY=NODES(LOWER)
LIMIT=MINNOD
KIND=2
C
C CHECK THAT BRANCH DOES NOT CONTAIN A LOOP
J=MINCLM
15 IF(J.GE.NOWCLM)GO TO 16
I=KOLUMN(J)
IF(NODES(I).EQ.NODES(LOWER))GO TO 23
J=J+1
GO TO 15
C
C SEARCH FOR NEXT NODE ALONG BRANCH
16 ISIZE=NODES(LIMIT)
IF(ISIZE.LE.0)GO TO 20
JTEST=LIMIT
LOWER=LIMIT+1
LIMIT=LOWER+ISIZE
IF(LIMIT.GT.MAXNOD)GO TO 20
IF(ITYPE.EQ.0)GO TO 18
ITEST=LOWER
17 ITEST=ITEST+1
IF(ITEST.GE.LIMIT)GO TO 16
IF(NODES(ITEST).NE.IDNTFY)GO TO 17
GO TO 14
18 IF(NODES(LOWER).NE.IDNTFY)GO TO 16
19 LOWER=LOWER+1
IF(LOWER.GE.LIMIT)GO TO 16
GO TO 14
C
C BACK UP TO PREVIOUS NODE IF CURRENT NODE COMPLETED
20 IF(KIND.NE.1)GO TO 26
21 LOWER=KOLUMN(NOWCLM)
JTEST=INITAL(NOWCLM)
LIMIT=JTEST+NODES(JTEST)+1
NEWCLM=NOWCLM
NOWCLM=NOWCLM-1
IF(NOWCLM.LT.MINCLM)GO TO 22
I=KOLUMN(NOWCLM)
IDNTFY=NODES(I)
IF(ITYPE.EQ.0)GO TO 19
GO TO 16
22 IF(KLIMB.NE.0)GO TO 26
IF(ITYPE.EQ.0)GO TO 3
GO TO 4
C
C RETURN TO CALLING PROGRAM
23 KIND=3
GO TO 26
24 KIND=4
GO TO 26
25 KIND=5
26 RETURN
C660045846000
END
SUBROUTINE OPNFIL( ITTY, JTTY,KMDNUM,KMDDVC,KMDNAM,
1 KMDEXT,ID1NUM,ID1DVC,ID1EXT,ID2NUM,ID2DVC,ID2EXT,
2 ID3NUM,ID3DVC,ID3EXT,MAXTTL,MAXBFR, KIND,KNDFLG,
3 NUMFLG,LTRTTL,ID1OPN,ID2OPN,IBUFFR)
C RENBR(/OPEN FILES FOR FILE,FILE=FILE,FILE COMMAND)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE OPENS THE FILES SPECIFIED BY THE USER IN
C A COMMAND IN WHICH UP TO 2 OUTPUT FILE NAMES ARE
C FOLLOWED BY AN EQUAL SIGN AND THEN BY ANY NUMBER OF
C INPUT FILE NAMES. THE FIRST CALL TO THIS ROUTINE
C OPENS THE FIRST INPUT FILE AND ALL THE OUTPUT FILES.
C SUBSEQUENT CALLS TO THIS ROUTINE OPEN SUBSEQUENT
C INPUT FILES. OUTPUT FILES ARE IDENTIFIED AS BEING OF
C EITHER TYPE ONE OR TYPE TWO BY THE SWITCHES WHICH
C APPEAR WITH THE FILE SPECIFICATIONS. IF NO MORE THAN
C A SINGLE OUTPUT FILE IS SUPPLIED AND NO SWITCHES
C IMPLY ITS TYPE, THEN IT IS ASSUMED TO BE OF TYPE ONE.
C
C OPNFIL ARGUMENTS NAMED ITTY, JTTY, KMDNUM, KMDDVC,
C KMDNAM, KMDEXT, MAXBFR AND IBUFFR ARE IDENTICAL TO
C GETFIL ARGUMENTS HAVING SAME NAMES AND HAVE ALREADY
C BEEN DESCRIBED. FOLLOWING ARGUMENTS, TOGETHER WITH
C ITTY, JTTY, KMDNUM, KMDDVC, KMDNAM, KMDEXT AND
C MAXBFR, ARE USED ONLY FOR INPUT AND ARE RETURNED
C UNCHANGED.
C
C ID1NUM = NUMBER OF UNIT UPON WHICH THIS ROUTINE IS TO
C OPEN OUTPUT FILE WHICH IS TO BE OF TYPE ONE.
C OUTPUT FILE WILL BE OF TYPE ONE IF ITS FILE
C SPECIFICATION IS ASSOCIATED WITH SWITCH FOR
C WHICH CORRESPONDING VALUE IN KNDFLG ARRAY IS
C 1.
C ID1DVC = NAME IN 5H FORM OF DEVICE UPON WHICH TYPE
C ONE OUTPUT FILE IS TO BE WRITTEN IF USER
C DOES NOT SUPPLY DEVICE NAME FOLLOWED BY
C COLON AT START OF SPECIFICATION OF TYPE ONE
C OUTPUT FILE.
C ID1EXT = NAME IN 3H FORM WHICH IS TO BE USED AS
C SECOND COMPONENT (FILE NAME EXTENSION) OF
C NAME OF TYPE ONE OUTPUT FILE IF NO SECOND
C COMPONENT OF NAME OF TYPE ONE OUTPUT FILE IS
C SUPPLIED BY USER. IF USER DOES NOT SPECIFY
C FIRST COMPONENT OF NAME OF OUTPUT FILE, THEN
C FIRST COMPONENT OF NAME OF FIRST INPUT FILE
C IS USED AS FIRST COMPONENT OF NAME OF THIS
C OUTPUT FILE.
C ID2NUM, ID2DVC AND ID2EXT = SIMILAR TO ID1NUM, ID1DVC
C AND ID1EXT RESPECTIVELY, EXCEPT THAT ID2NUM,
C ID2DVC AND ID2EXT REFER TO OUTPUT FILE WHICH
C IS TO BE OF TYPE TWO. OUTPUT FILE WILL BE
C OF TYPE TWO IF ITS FILE SPECIFICATION IS
C ASSOCIATED WITH SWITCH FOR WHICH
C CORRESPONDING VALUE IN KNDFLG ARRAY IS 2.
C ID3NUM = NUMBER OF UNIT UPON WHICH THIS ROUTINE IS TO
C OPEN NEXT INPUT FILE SPECIFIED BY USER.
C ID3DVC = NAME IN 5H FORM OF DEVICE UPON WHICH NEXT
C INPUT FILE IS TO BE OPENED IF NO DEVICE NAME
C HAS BEEN SPECIFIED BY USER FOR ANY PREVIOUS
C INPUT FILE AND IF NO DEVICE NAME IS
C SPECIFIED BY USER FOR THIS NEW INPUT FILE.
C ID3EXT = NAME IN 3H FORM WHICH IS TO BE USED AS
C SECOND COMPONENT (FILE NAME EXTENSION) OF
C NAME OF EACH INPUT FILE FOR WHICH NO SECOND
C COMPONENT OF FILE NAME IS SUPPLIED BY USER.
C MAXTTL = DIMENSION OF LTRTTL ARRAY AND MAXIMUM NUMBER
C OF CHARACTERS WHICH CAN BE RETURNED IN
C LTRTTL ARRAY.
C
C FOLLOWING ARGUMENT MUST BE ZEROED BY CALLING PROGRAM
C BEFORE THIS ROUTINE IS FIRST CALLED, BUT THEN VALUE
C RETURNED BY THIS ROUTINE SHOULD BE SENT TO FOLLOWING
C CALL OF THIS ROUTINE UNCHANGED.
C
C KIND = DEFINED SIMILARLY TO ARGUMENT OF SAME NAME
C IN ARGUMENT LIST OF GETFIL ROUTINE, EXCEPT
C THAT OPNFIL ROUTINE DOES NOT RETURN KIND=5.
C KIND SHOULD BE SET TO ZERO (OR TO 1) BEFORE
C THIS ROUTINE IS FIRST CALLED, OR WHENEVER
C INTERPRETATION OF CURRENT SET OF FILE
C SPECIFICATIONS IS TO BE ABANDONED.
C = 1, RETURNED IF PREVIOUS CALL TO THIS ROUTINE
C OPENED FINAL INPUT FILE SPECIFIED BY USER.
C = 2, RETURNED IF PREVIOUS CALL TO THIS ROUTINE
C OPENED FINAL INPUT FILE SPECIFIED TO LEFT OF
C SEMICOLON. IF THIS ROUTINE IS CALLED AGAIN
C WITHOUT KIND HAVING FIRST BEEN ZEROED, THEN
C EVALUATION OF NEW SET OF FILE SPECIFICATIONS
C WILL BE BEGUN IN TEXT APPEARING TO RIGHT OF
C SEMICOLON.
C = 3, CURRENT CALL TO THIS ROUTINE HAS OPENED
C OUTPUT FILE OR FILES AND HAS OPENED FIRST
C INPUT FILE.
C = 4, CURRENT CALL TO THIS ROUTINE HAS OPENED
C SECOND OR SUBSEQUENT INPUT FILE.
C
C FOLLOWING ARGUMENT IS USED BOTH FOR SENDING
C INFORMATION TO THIS ROUTINE, AND FOR RETURNING
C INFORMATION TO CALLING PROGRAM. CALLING PROGRAM MUST
C DEFINE CONTENTS OF THIS ARRAY BEFORE THIS ROUTINE IS
C FIRST CALLED.
C
C KNDFLG = ARRAY DIMENSIONED AT 27 WHICH MUST INITIALLY
C INDICATE OUTPUT FILE TYPES TO BE ASSOCIATED
C WITH EACH OF SINGLE LETTER SWITCHES /A
C THROUGH /Z AND /' (OR LONE ') RESPECTIVELY.
C IF THIS ROUTINE IS CALLED WITH KIND SET TO 2
C OR LESS, THEN THIS ROUTINE REDEFINES KNDFLG
C ARRAY TO CONTAIN ABSOLUTE VALUES OF ITS
C ORIGINAL CONTENTS. IF CURRENT CALL TO THIS
C ROUTINE BEGINS PROCESSING OF NEW COMMAND
C SUCH THAT KIND IS RETURNED CONTAINING VALUE
C 3, THEN THOSE LOCATIONS WITHIN KNDFLG ARRAY
C HAVING AS THEIR SUBSCRIPTS SERIAL LOCATIONS
C WITHIN ALPHABET OF LETTERS WHICH ARE FOUND
C AS SWITCHES (ASSUMING APOSTROPHE TO BE 27TH
C LETTER OF ALPHABET) ARE THEN RETURNED
C CONTAINING NEGATIVES OF THEIR ABSOLUTE
C VALUES. CONTENTS OF KNDFLG ARRAY ARE
C RETURNED UNCHANGED IF KIND IS RETURNED SET
C TO 4.
C
C IF VALUE IN KNDFLG ARRAY CORRESPONDING TO
C SWITCH IS EITHER -1 OR 1, THEN FILE WITH
C WHICH SWITCH IS ASSOCIATED WILL BE OF TYPE
C ONE. IF VALUE IN KNDFLG ARRAY CORRESPONDING
C TO SWITCH IS EITHER -2 OR 2, THEN FILE WITH
C WHICH SWITCH IS ASSOCIATED WILL BE OF TYPE
C TWO. IF VALUE IN KNDFLG ARRAY CORRESPONDING
C TO SWITCH IS ZERO, THEN ROUTINE NAMED HLPFIL
C IS CALLED TO DISPLAY HELP MESSAGE TO USER
C AND USER IS THEN ASKED TO SUPPLY NEW SET OF
C FILE SPECIFICATIONS. SWITCHES FOR WHICH
C CORRESPONDING LOCATIONS IN KNDFLG ARRAY DO
C NOT CONTAIN ONE OF VALUES -2 THROUGH 2 CAN
C APPEAR WITH EITHER OUTPUT FILE SPECIFICATION
C OR WITH LEFTMOST INPUT FILE SPECIFICATION
C BUT DO NOT IDENTIFY TYPE OF OUTPUT FILES.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR RETURNING
C INFORMATION TO CALLING PROGRAM WHEN KIND IS RETURNED
C SET TO 3. THESE ARGUMENTS ARE RETURNED UNCHANGED IF
C KIND IS RETURNED SET TO VALUE OTHER THAN 3.
C
C NUMFLG = ARRAY DIMENSIONED AT 27 WHICH IS USED FOR
C RETURNING VALUES WHICH APPEARED WITH
C SEPARATING COLONS AFTER SWITCHES IN FILE
C SPECIFICATIONS. NUMFLG ARRAY LOCATIONS IN
C WHICH THESE VALUES ARE RETURNED HAVE AS
C THEIR SUBSCRIPTS SERIAL LOCATIONS WITHIN
C ALPHABET OF LETTERS WHICH ARE USED AS
C SWITCHES. SUCH NUMBERS MUST BE SPECIFIED AS
C DECIMAL INTEGERS, BUT CANNOT CONTAIN
C EXPONENTS. NUMFLG(27) IS RETURNED
C CONTAINING NUMBER OF CHARACTERS RETURNED IN
C LTRTTL ARRAY WHICH WERE FOUND TO RIGHT OF
C LEADING APOSTROPHE.
C LTRTTL = ARRAY IN WHICH AT MOST MAXTTL CHARACTERS
C APPEARING TO RIGHT OF APOSTROPHE CAN BE
C RETURNED. NUMFLG(27) IS RETURNED CONTAINING
C NUMBER OF CHARACTERS RETURNED IN LTRTTL
C ARRAY.
C ID1OPN = 0, RETURNED IF TYPE ONE OUTPUT FILE WAS NOT
C OPENED.
C = 1, RETURNED IF TYPE ONE OUTPUT FILE WAS
C OPENED.
C ID2OPN = 0, RETURNED IF TYPE TWO OUTPUT FILE WAS NOT
C OPENED.
C = 1, RETURNED IF TYPE TWO OUTPUT FILE WAS
C OPENED.
C
COMMON/FASPY/NEWNUL(3),NEWDSK(3),NEWNAM(3),
1NEWPTH(3,3),LCNRIT
DIMENSION KNDFLG(27),NUMFLG(27),LTRTTL(MAXTTL),
1IBUFFR(MAXBFR),LTRABC(27),LWRABC(27),LTRDGT(10),
2INILTR(6),KNTLTR(6)
DOUBLE PRECISION KMDNAM,NEWNAM,NEWPTH,PTHONE(3),
1PTHTWO(3),PTHTHR(3),FILONE,FILTWO,FILTHR,FILNAM
DATA LTRABC/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
2 1HU,1HV,1HW,1HX,1HY,1HZ,1H'/
DATA LWRABC/1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,
1 1Hk,1Hl,1Hm,1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,
2 1Hu,1Hv,1Hw,1Hx,1Hy,1Hz,1H'/
DATA LTRDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA LTRPLS,LTRMNS,IBLANK/1H+,1H-,5H /
C
C INITIALIZE STORAGE OF COMMAND
INITAL=KIND-2
IF(INITAL.GT.0)GO TO 4
GO TO 2
1 KIND=0
2 ID1OPN=0
ID2OPN=0
DO 3 I=1,27
IF(KNDFLG(I).LT.0)KNDFLG(I)=-KNDFLG(I)
3 NUMFLG(I)=0
KNDONE=0
KNDTWO=0
KNDTHR=0
C
C GET NEXT COMPONENT OF COMMAND TYPED BY USER
4 CALL GETFIL(3,ITTY,JTTY,KMDNUM,KMDDVC,
1KMDNAM,KMDEXT,6,MAXBFR,KIND,NEWNUL,NEWDSK,
2NEWNAM,NEWPTH,LCNRIT,IBUFFR,MAXFLG,INILTR,KNTLTR,
3LCNOWN)
GO TO(45,45,23,31,5),KIND
C
C DECIDE WHICH SWITCH WAS GIVEN
5 IF(MAXFLG.LE.0)GO TO 4
IF(KNTLTR(1).LE.0)GO TO 4
IF(INITAL.GT.0)GO TO 4
LOCLTR=INILTR(1)
LTRNOW=IBUFFR(LOCLTR)
NEWFLG=0
6 NEWFLG=NEWFLG+1
IF(NEWFLG.GT.27)GO TO 4
IF(LTRABC(NEWFLG).EQ.LTRNOW)GO TO 7
IF(LWRABC(NEWFLG).NE.LTRNOW)GO TO 6
7 IF(KNDFLG(NEWFLG).EQ.0)GO TO 35
IF(KNDFLG(NEWFLG).GT.0)KNDFLG(NEWFLG)=-KNDFLG(NEWFLG)
IF(KNDFLG(NEWFLG).EQ.-2)GO TO 11
IF(KNDFLG(NEWFLG).NE.-1)GO TO 15
C
C MARK THAT FILE BEARS TYPE ONE SWITCH
ID1OPN=1
GO TO(8,9,10),LCNOWN
8 IF(KNDONE.EQ.1)GO TO 15
IF(KNDONE.NE.3)KNDONE=KNDONE+1
GO TO 15
9 IF(KNDTWO.EQ.1)GO TO 15
IF(KNDTWO.NE.3)KNDTWO=KNDTWO+1
GO TO 15
10 IF(KNDTHR.EQ.1)GO TO 15
IF(KNDTHR.NE.3)KNDTHR=KNDTHR+1
GO TO 15
C
C MARK THAT FILE BEARS TYPE TWO SWITCH
11 ID2OPN=1
GO TO(12,13,14),LCNOWN
12 IF(KNDONE.LE.1)KNDONE=KNDONE+2
GO TO 15
13 IF(KNDTWO.LE.1)KNDTWO=KNDTWO+2
GO TO 15
14 IF(KNDTHR.LE.1)KNDTHR=KNDTHR+2
C
C STORE QUOTED TEXT STRING
15 IVALUE=0
IF(NEWFLG.LT.27)GO TO 17
LMTLTR=LOCLTR+KNTLTR(1)
16 IF(IVALUE.GE.MAXTTL)GO TO 22
LOCLTR=LOCLTR+1
IF(LOCLTR.GE.LMTLTR)GO TO 22
IVALUE=IVALUE+1
LTRTTL(IVALUE)=IBUFFR(LOCLTR)
GO TO 16
C
C EVALUATE NUMBERS IN RANGE OF SWITCH
17 IF(MAXFLG.LE.1)GO TO 22
IF(KNTLTR(2).LE.0)GO TO 22
LOCLTR=INILTR(2)
LMTLTR=LOCLTR+KNTLTR(2)
I=0
IF(IBUFFR(LOCLTR).EQ.LTRPLS)GO TO 18
IF(IBUFFR(LOCLTR).NE.LTRMNS)GO TO 19
I=1
18 LOCLTR=LOCLTR+1
19 IF(LOCLTR.GE.LMTLTR)GO TO 21
LTRNOW=IBUFFR(LOCLTR)
DO 20 L=1,10
IF(LTRDGT(L).NE.LTRNOW)GO TO 20
IVALUE=(10*IVALUE)+L-1
GO TO 18
20 CONTINUE
21 IF(I.NE.0)IVALUE=-IVALUE
22 NUMFLG(NEWFLG)=IVALUE
GO TO 4
C
C SET DEFAULT OUPUT DEVICE NAMES AND PATHS
23 IF(NEWNUL(LCNRIT).LE.1)GO TO 38
IF(NEWNUL(LCNRIT).EQ.4)GO TO 38
IF(ID1OPN.EQ.ID2OPN)ID1OPN=1
FILONE=NEWNAM(LCNRIT)
FILTWO=FILONE
MORONE=ID1EXT
MORTWO=ID2EXT
PTHONE(1)=0
PTHTWO(1)=0
LOCONE=ID1DVC
LOCTWO=ID2DVC
GO TO(31,24,25),LCNRIT
C
C SINGLE FILE LEFT OF EQUAL SIGN
24 IF(NEWNUL(1).EQ.0)GO TO 31
IF(ID1OPN.EQ.ID2OPN)GO TO 36
KNDONE=1
KNDTWO=1
GO TO 26
C
C TWO FILES LEFT OF EQUAL SIGN
25 IF(KNDONE.GE.3)GO TO 36
IF(KNDTWO.GE.3)GO TO 36
IF(KNDONE.EQ.KNDTWO)GO TO 36
ID1OPN=1
ID2OPN=1
IF(KNDONE.EQ.0)KNDONE=3-KNDTWO
IF(KNDTWO.EQ.0)KNDTWO=3-KNDONE
26 IF(NEWNUL(KNDONE).EQ.0)GO TO 29
IF(NEWDSK(KNDONE).NE.IBLANK)LOCONE=NEWDSK(KNDONE)
DO 27 I=1,3
27 PTHONE(I)=NEWPTH(I,KNDONE)
IF(NEWNUL(KNDONE).LE.1)GO TO 29
FILNAM=NEWNAM(KNDONE)
IF(NEWNUL(KNDONE).LE.3)FILONE=FILNAM
IF(NEWNUL(KNDONE).GE.3)DECODE(10,28,FILNAM)MORONE
28 FORMAT(7X,1A3)
29 IF(NEWNUL(KNDTWO).EQ.0)GO TO 31
IF(NEWDSK(KNDTWO).NE.IBLANK)LOCTWO=NEWDSK(KNDTWO)
DO 30 I=1,3
30 PTHTWO(I)=NEWPTH(I,KNDTWO)
IF(NEWNUL(KNDTWO).LE.1)GO TO 31
FILNAM=NEWNAM(KNDTWO)
IF(NEWNUL(KNDTWO).LE.3)FILTWO=FILNAM
IF(NEWNUL(KNDTWO).GE.3)DECODE(10,28,FILNAM)MORTWO
C
C OPEN INPUT FILE
31 IF(NEWNUL(LCNRIT).EQ.0)GO TO 4
FILTHR=NEWNAM(LCNRIT)
MORTHR=ID3EXT
IF(NEWNUL(LCNRIT).GE.3)DECODE(10,28,FILTHR)MORTHR
LOCTHR=NEWDSK(LCNRIT)
IF(LOCTHR.EQ.IBLANK)LOCTHR=ID3DVC
DO 32 I=1,3
32 PTHTHR(I)=NEWPTH(I,LCNRIT)
ENCODE(10,33,FILNAM)FILTHR,MORTHR
33 FORMAT(1A6,1H.,1A3)
OPEN(UNIT=ID3NUM,FILE=FILNAM,DIRECTORY=PTHTHR,
1DEVICE=LOCTHR,ACCESS='SEQIN',ERR=43)
IF(INITAL.GT.0)GO TO 47
C
C OPEN OUTPUT FILES
IF(ID1OPN.EQ.0)GO TO 34
ENCODE(10,33,FILNAM)FILONE,MORONE
OPEN(UNIT=ID1NUM,FILE=FILNAM,DIRECTORY=PTHONE,
1DEVICE=LOCONE,ACCESS='SEQOUT',ERR=40)
IF(ID2OPN.EQ.0)GO TO 46
34 ENCODE(10,33,FILNAM)FILTWO,MORTWO
OPEN(UNIT=ID2NUM,FILE=FILNAM,DIRECTORY=PTHTWO,
1DEVICE=LOCTWO,ACCESS='SEQOUT',ERR=42)
GO TO 46
C
C ISSUE HELP MESSAGE AND THEN CLEAR COMMAND IF ANY
35 CALL HLPFIL(JTTY)
GO TO 1
C
C ERROR IN COMMAND TYPED BY USER
36 WRITE(JTTY,37)
37 FORMAT(31H AMBIGUOUS OUTPUT SPECIFICATION)
GO TO 1
38 WRITE(JTTY,39)
39 FORMAT(34H 1ST SOURCE FILE MUST BE SPECIFIED)
GO TO 1
40 WRITE(JTTY,41)LOCONE,FILNAM
41 FORMAT(26H CANNOT WRITE OUTPUT FILE ,1A5,1H:,1A10)
GO TO 1
42 WRITE(JTTY,41),LOCTWO,FILNAM
GO TO 1
43 WRITE(JTTY,44)LOCTHR,FILNAM
44 FORMAT(25H CANNOT READ SOURCE FILE ,1A5,1H:,1A10)
GO TO 4
C
C RETURN TO CALLING PROGRAM
45 IF(INITAL.LE.0)GO TO 2
GO TO 47
46 KIND=3
47 RETURN
C024147266970'abcdefghijklmnopqrstuvwxyz:
END
SUBROUTINE GETFIL(MAXFIL, ITTY, JTTY,KMDNUM,KMDDVC,
1 KMDNAM,KMDEXT,MAXSTR,MAXBFR, KIND,NEWNUL,NEWDSK,
2 NEWNAM,NEWPTH,LCNRIT,IBUFFR,MAXFLG,INILTR,KNTLTR,
3 LCNOWN)
C RENBR(/EVALUATE FORM FILE,FILE=FILE,FILE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAFLAG LOCATES COMPONENTS OF SINGLE FILE
C SPECIFICATION, BUT DOES NOT PACK CHARACTERS WHICH
C FORM THESE COMPONENTS INTO SINGLE OR DOUBLE PRECISION
C COMPUTER LOCATIONS WHICH CAN BE USED AS ARGUMENTS IN
C SYSTEM SUBROUTINE CALLS OR FORTRAN OPEN STATEMENTS
C WHICH ARE NECESSARY TO PREPARE FOR READING OR WRITING
C OF DESIRED FILE. LISTED ON FOLLOWING PAGES IS
C WRAPPER FOR DAFLAG ROUTINE WHICH PACKS COMPONENTS OF
C FILE SPECIFICATION INTO FORM REQUIRED FOR
C DECSYSTEM-10 FORTRAN OPEN STATEMENTS. WRAPPER
C ROUTINE, NAMED GETFIL, SUPPORTS MULTIPLE FILE
C SPECIFICATION OF FORM
C LIST OF OUTPUT FILES=LIST OF INPUT FILES
C OR
C LIST OF INPUT FILES
C AND SO MUST SCAN COMMAND FROM LEFT TO RIGHT UNTIL ONE
C MORE THAN NUMBER OF FILES WHICH CAN APPEAR IN LIST OF
C OUTPUT FILES HAS BEEN FOUND. IF USER DESIRES TO
C INPUT SEVERAL LINES, ALL BUT LAST LINE CAN BE
C TERMINATED BY AMPERSAND, OR, IF COMMAND CONSISTS OF
C LIST OF FILE SPECIFICATIONS, ALL BUT LAST LINE CAN BE
C TERMINATED BY RIGHTMOST COMMA. ALTHOUGH GETFIL
C INITIALLY INTERACTS WITH USER, USER CAN AT ANY POINT
C SPECIFY THAT REMAINDER OF COMMAND IS TO BE READ FROM
C FILE BY GIVING ITS NAME ALONG WITH AT (@) SIGN. IF
C COMMAND IS BEING READ FROM FILE, THEN CONTINUATION
C INDICATIONS ARE NOT NECESSARY SINCE ENTIRE COMMAND
C FILE WILL BE READ UNTIL END OF FILE IS ENCOUNTERED.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR INPUT AND ARE
C RETURNED UNCHANGED.
C
C MAXFIL = 1 MORE THAN NUMBER OF FILES WHICH CAN APPEAR
C TO LEFT OF EQUAL SIGN. SINGLE PRECISION
C ARRAYS NEWNUL AND NEWDSK, AND DOUBLE
C PRECISION ARRAY NEWNAM MUST BE DIMENSIONED
C TO AT LEAST VALUE OF MAXFIL, AND DOUBLE
C PRECISION AND DOUBLY DIMENSIONED ARRAY
C NEWPTH MUST HAVE 3 AS ITS FIRST DIMENSION
C AND MAXFIL AS ITS SECOND DIMENSION.
C SWITCHES ARE ALWAYS RETURNED TO CALLING
C PROGRAM PRIOR TO FILE SPECIFICATIONS WITH
C WHICH THEY ARE ASSOCIATED. ALL SWITCHES
C LEFT OF EQUAL SIGN AND SWITCHES ASSOCIATED
C WITH FIRST FILE SPECIFICATION RIGHT OF EQUAL
C SIGN WILL HAVE BEEN RETURNED TO CALLING
C PROGRAM BEFORE ANY FILE SPECIFICATIONS ARE
C RETURNED. FIRST CALL TO THIS ROUTINE WHICH
C RETURNS FILE SPECIFICATIONS CAN RETURN UP TO
C MAXFIL FILE SPECIFICATIONS, OF WHICH ONLY
C FILE SPECIFICATION WHICH IS RETURNED IN
C LOCATION IN EACH ARRAY HAVING VALUE OF
C LCNRIT AS ITS SUBSCRIPT IS TO RIGHT OF EQUAL
C SIGN. SUBSEQUENT CALLS TO THIS ROUTINE WILL
C RETURN EITHER SINGLE SWITCH SPECIFICATION OR
C SINGLE FILE SPECIFICATION. EQUAL SIGN FOUND
C AFTER MORE THAN MAXFIL FILE SPECIFICATIONS
C HAVE BEEN FOUND IS TAKEN AS EQUIVALENT TO
C COMMA.
C ITTY = NUMBER OF UNIT FROM WHICH TERMINAL INPUT IS
C TO BE READ.
C JTTY = NUMBER OF UNIT TO WHICH TERMINAL OUTPUT IS
C TO BE WRITTEN.
C KMDNUM = NUMBER OF UNIT FROM WHICH COMMAND FILE
C INDICATED BY AT SIGN IS TO BE READ.
C KMDDVC = DEFAULT NAME IN 5H FORM OF DEVICE FROM WHICH
C COMMAND FILE IS TO BE READ IF USER FAILS TO
C SUPPLY DEVICE NAME FOLLOWED BY COLON.
C KMDNAM = DEFAULT FIRST NAME IN A6 FORM TO BE USED IN
C NAME OF COMMAND FILE IF NONE IS SUPPLIED BY
C USER. THIS MUST BE A DOUBLE PRECISION
C VARIABLE ON PDP10 COMPUTER.
C KMDEXT = DEFAULT EXTENSION IN 3H FORM TO BE USED IN
C NAME OF COMMAND FILE IF NONE IS SUPPLIED BY
C USER. IF COMMAND FILE NAME IS NOT TO HAVE
C EXTENSION, THEN USER MUST TYPE PERIOD
C FOLLOWING FIRST PART OF NAME.
C MAXSTR = DIMENSION OF INILTR AND KNTLTR ARRAYS IN
C WHICH DESCRIPTIONS OF COMPONENTS OF SWITCHS
C ARE RETURNED AND WHICH ARE USED INTERNALLY
C WITHIN THIS ROUTINE FOR STORAGE OF
C DESCRIPTIONS OF COMPONENTS OF EACH FILE
C SPECIFICATION. MAXSTR SHOULD HAVE VALUE OF
C AT LEAST 6.
C MAXBFR = DIMENSION OF IBUFFR ARRAY INTO WHICH EACH
C LINE OF COMMANDS TYPED BY USER OR READ FROM
C COMMAND FILE ARE STORED IN MULTIPLE OF A1
C FORMAT. MAXBFR IS MAXIMUM NUMBER OF
C CHARACTERS WHICH CAN APPEAR IN SINGLE
C COMMAND LINE. MAXBFR MUST NOT EXCEED 132.
C
C FOLLOWING ARGUMENT MUST BE SET BEFORE THIS ROUTINE IS
C FIRST CALLED, BUT THEN VALUE RETURNED BY THIS ROUTINE
C SHOULD BE SENT TO FOLLOWING CALL OF THIS ROUTINE
C UNCHANGED.
C
C KIND = SHOULD BE INPUT SET TO ZERO WHEN THIS
C ROUTINE IS FIRST CALLED, OR WHENEVER
C INTERPRETATION OF PREVIOUS SET OF COMMANDS
C IS TO BE ABANDONED. KIND IS RETURNED
C DESCRIBING REASON WHY CONTROL HAS BEEN
C TRANSFERRED BACK TO CALLING PROGRAM, AND
C SHOULD NOT BE CHANGED BY CALLING PROGRAM IF
C THIS ROUTINE IS TO BE CALLED AGAIN TO
C CONTINUE INTERPRETATION OF SAME SEQUENCE OF
C COMMANDS.
C = 1, RETURNED IF NO MORE FILE SPECIFICATIONS
C REMAIN TO BE EVALUATED.
C = 2, RETURNED IF SEMICOLON WAS FOUND. IF THIS
C ROUTINE IS CALLED AGAIN WITHOUT KIND HAVING
C FIRST BEEN ZEROED, THEN EVALUATION OF NEW
C SET OF FILE SPECIFICATIONS WILL BE BEGUN IN
C TEXT APPEARING TO RIGHT OF SEMICOLON.
C APPEARANCE OF SEMICOLON WHEN FILE
C SPECIFICATION IS KNOWN BY THIS ROUTINE TO BE
C INCOMPLETE WILL NOT BE REPORTED SINCE TEXT
C TO RIGHT OF SEMICOLON IS TREATED AS IF IT
C CONTINUED FILE SPECIFICATIONS ON SUBSEQUENT
C LINE OF INPUT.
C = 3, RETURNED IF THIS ROUTINE IS REPORTING ALL
C OF FILE SPECIFICATIONS APPEARING TO LEFT OF
C EQUAL SIGN TOGETHER WITH FIRST FILE
C SPECIFICATION TO RIGHT OF EQUAL SIGN, OR IF
C THIS ROUTINE IS REPORTING FIRST FILE
C SPECIFICATION IN SERIES OF FILE
C SPECIFICATIONS WHICH DOES NOT INCLUDE EQUAL
C SIGN.
C = 4, RETURNED IF THIS ROUTINE IS REPORTING
C SECOND OR SUBSEQUENT FILE SPECIFICATION TO
C RIGHT OF EQUAL SIGN, OR IF THIS ROUTINE IS
C REPORTING SECOND OR SUBSEQUENT FILE
C SPECIFICATION IN SERIES OF FILE
C SPECIFICATIONS WHICH DOES NOT INCLUDE EQUAL
C SIGN.
C = 5, RETURNED IF THIS ROUTINE IS RETURNING
C DESCRIPTION OF SWITCH IN INILTR AND KNTLTR
C ARRAY LOCATIONS HAVING SUBSCRIPTS 1 THROUGH
C MAXFLG. LCNOWN IS RETURNED CONTAINING VALUE
C OF SUBSCRIPT OF LOCATIONS IN NEWNUL, NEWDSK,
C NEWNAM AND NEWPTH ARRAYS WHICH WILL DESCRIBE
C FILE SPECIFICATION WHEN KIND IS NEXT
C RETURNED SET TO EITHER 3 OR 4.
C
C FOLLOWING ARGUMENTS ARE USED BOTH FOR RETURNING
C INFORMATION TO CALLING PROGRAM AND FOR COMMUNICATING
C WITH SUBSEQUENT CALLS OF THIS ROUTINE. ORIGINAL
C CONTENTS OF THESE ARGUMENTS ARE IGNORED.
C
C NEWNUL = IF KIND IS RETURNED SET TO EITHER 3 OR 4,
C THEN LOCATIONS IN NEWNUL ARRAY HAVING
C SUBSCRIPTS 1 THROUGH LCNRIT ARE RETURNED
C DESCRIBING WHETHER FILE SPECIFICATION WAS
C FOUND, AND IF SO, WHETHER EXTENSION WAS
C SPECIFIED.
C = 0, AN EXTRA COMMA INDICATED THAT NO FILE WAS
C BEING SPECIFIED. NO FILE SPECIFICATION IS
C DESCRIBED IN NEWDSK, NEWNAM AND NEWPTH
C ARRAYS.
C = 1, EITHER DEVICE NAME OR PATH WAS SPECIFIED,
C BUT NO FILE NAME WAS SPECIFIED.
C = 2, FILE NAME BUT NOT EXTENSION WAS
C SPECIFIED.
C = 3, BOTH FILE NAME AND ITS EXTENSION WERE
C SPECIFIED.
C = 4, PERIOD AND EXTENSION WERE SPECIFIED, BUT
C NO NAME WAS SPECIFIED TO LEFT OF PERIOD.
C NEWDSK = IF KIND IS RETURNED SET TO EITHER 3 OR 4,
C THEN LOCATIONS IN NEWDSK ARRAY HAVING
C SUBSCRIPTS 1 THROUGH LCNRIT ARE RETURNED
C CONTAINING DEVICE NAME IN 5H FORM. IF NO
C DEVICE NAME IS SPECIFIED IN FILE
C SPECIFICATIONS TO LEFT OF EQUAL SIGN, THEN
C THESE LOCATIONS CONTAIN BLANKS. IF NO
C DEVICE NAME IS SPECIFIED IN FILE
C SPECIFICATIONS TO RIGHT OF EQUAL SIGN, THEN
C THESE LOCATIONS CONTAIN PREVIOUSLY SPECIFIED
C DEVICE NAME IF ANY HAS BEEN SPECIFIED TO
C RIGHT OF EQUAL SIGN, OR CONTAIN BLANKS IF
C NONE HAS YET BEEN SPECIFIED TO RIGHT OF
C EQUAL SIGN.
C NEWNAM = IF KIND IS RETURNED SET TO EITHER 3 OR 4,
C THEN LOCATIONS IN NEWNAM DOUBLE PRECISION
C ARRAY HAVING SUBSCRIPTS 1 THROUGH LCNRIT ARE
C RETURNED CONTAINING FILE NAME AND EXTENSION
C IN A10 FORM (FORMAT 1A6,1H.,1A3).
C NEWPTH = IF KIND IS RETURNED SET TO EITHER 3 OR 4,
C THEN LOCATIONS IN NEWPTH DOUBLE PRECISION
C AND DOUBLY DIMENSIONED ARRAY HAVING
C SUBSCRIPTS 1 THROUGH LCNRIT ARE RETURNED
C CONTAINING PATH UPON WHICH FILE IS LOCATED.
C IF NO PATH IS SPECIFIED IN FILE
C SPECIFICATIONS TO LEFT OF EQUAL SIGN, THEN
C THESE LOCATIONS CONTAIN ZEROES. IF NO PATH
C IS SPECIFIED IN FILE SPECIFICATIONS TO RIGHT
C OF EQUAL SIGN, THEN THESE LOCATIONS CONTAIN
C PREVIOUSLY SPECIFIED PATH IF ANY HAS BEEN
C SPECIFIED TO RIGHT OF EQUAL SIGN, OR CONTAIN
C ZEROES IF NONE HAS YET BEEN SPECIFIED TO
C RIGHT OF EQUAL SIGN. NEWPTH(1,...) CONTAINS
C IN ITS LEFT HALF PROJECT NUMBER AND IN ITS
C RIGHT HALF PROGRAMMER NUMBER, OR CONTAINS
C ZERO IF NO PATH HAS BEEN SPECIFIED.
C NEWPTH(2,...) CONTAINS SUB FILE DIRECTORY
C (SFD) NAME IN 6H FORM IF ANY HAS BEEN
C SPECIFIED, OR CONTAINS ZERO OTHERWISE.
C NEWPTH(3,...) ALWAYS CONTAINS ZERO.
C LCNRIT = IF KIND IS RETURNED SET TO EITHER 3 OR 4,
C THEN LCNRIT IS RETURNED CONTAINING VALUE OF
C SUBSCRIPT OF LOCATIONS IN NEWNUL, NEWDSK,
C NEWNAM AND NEWPTH ARRAYS WHICH DESCRIBE FILE
C SPECIFICATION WHICH APPEARS TO RIGHT OF
C EQUAL SIGN. IF KIND IS RETURNED SET TO 3
C AND IF LCNRIT IS GREATER THAN ONE, THEN
C LOWER LOCATIONS IN THESE ARRAYS DESCRIBE
C FILE SPECIFICATIONS APPEARING TO LEFT OF
C EQUAL SIGN. IF KIND IS RETURNED SET TO 4,
C THEN LOCATIONS WITHIN THESE ARRAYS HAVING
C LOWER SUBSCRIPTS SHOULD BE IGNORED.
C IBUFFR = ARRAY INTO WHICH THIS ROUTINE CAN READ
C CHARACTERS TYPED BY USER OR READ FROM
C COMMAND FILE.
C MAXFLG = IF KIND IS RETURNED SET TO 5, THEN MAXFLG IS
C RETURNED CONTAINING SUPSCRIPT OF LOCATIONS
C IN INILTR AND KNTLTR ARRAYS WHICH DESCRIBE
C RIGHTMOST COMPONENT OF SWITCH.
C INILTR = IF KIND IS RETURNED SET TO 5, THEN LOCATIONS
C IN INILTR ARRAY HAVING SUBSCRIPTS 1 THROUGH
C VALUE OF MAXFLG ARE RETURNED CONTAINING
C VALUES OF SUBSCRIPTS OF LOCATIONS WITHIN
C IBUFFR ARRAY AT WHICH EACH OF COMPONENTS OF
C SWITCH START.
C KNTLTR = IF KIND IS RETURNED SET TO 5, THEN LOCATIONS
C IN INILTR ARRAY HAVING SUBSCRIPTS 1 THROUGH
C VALUE OF MAXFLG ARE RETURNED CONTAINING
C NUMBER OF CHARACTERS WITHIN EACH OF
C COMPONENTS OF SWITCH. MISSING COMPONENT OF
C SWITCH IS INDICATED BY ZERO VALUE IN KNTLTR
C ARRAY.
C LCNOWN = IF KIND IS RETURNED SET TO 5, THEN LCNOWN IS
C RETURNED CONTAINING VALUE OF SUBSCRIPT OF
C LOCATIONS IN NEWNUL, NEWDSK, NEWNAM AND
C NEWPTH ARRAYS WHICH WILL DESCRIBE FILE
C SPECIFICATION WHEN KIND IS NEXT RETURNED SET
C TO EITHER 3 OR 4.
C
COMMON/FASPZ/KNTFIL,MANY,IEOF,IAFTER,LSTPTH,LSTDSK,
1LOWBFR
DIMENSION INILTR(MAXSTR),KNTLTR(MAXSTR),
1IBUFFR(MAXBFR),NEWNUL(MAXFIL),NEWDSK(MAXFIL),
2LETTER(8),KOLECT(10),NUMTWO(2)
DOUBLE PRECISION NEWNAM(MAXFIL),NEWPTH(3,MAXFIL),
1KOMAND,ONEPTH(3),LSTPTH(3),TWONUM,KMDNAM
EQUIVALENCE (TWONUM,NUMTWO),(NEWPRJ,NUMTWO(1)),
1(NEWUSR,NUMTWO(2))
DATA LETTER/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7/
DATA IBLANK,JBLANK,IDOT/1H ,5H ,1H./
C
C DECIDE WHETHER ARE STARTING OR CONTINUING EVALUATION
IF(KIND.EQ.5)GO TO 9
IF(KIND.GE.3)GO TO 30
LCNRIT=0
KNTFIL=0
IAFTER=0
MANY=0
IF(KIND.EQ.2)GO TO 9
C
C READ CONTENTS OF NEXT LINE
WRITE(JTTY,1)
1 FORMAT(2H *,$)
GO TO 4
2 WRITE(JTTY,3)
3 FORMAT(2H &,$)
4 READ(ITTY,5,END=10)IBUFFR
5 FORMAT(132A1)
IEOF=0
GO TO 7
6 READ(KMDNUM,5,END=10)IBUFFR
IEOF=1
7 LOWBFR=1
GO TO 9
8 LCNRIT=1
KNTFIL=0
C
C LOCATE NEXT FILE SPECIFICATION
9 CALL DAFLAG(1,1,MAXSTR,MAXBFR,IBUFFR,
1LOWBFR,MANY,KIND,INILTR,KNTLTR,MAXDSK,MAXNAM,
2MAXNUM,MAXFLG,KONTNT,MINPRT,MAXPRT)
GO TO(11,11,13,15,16,17,17,17),KIND
C
C END OF LINE, END OF FILE OR SEMICOLON FOUND
10 KIND=1
IEOF=0
11 IF(IAFTER.LT.0)GO TO 14
IF(IAFTER.EQ.1)GO TO 14
IF(KNTFIL.GT.0)GO TO 12
IF(LCNRIT.EQ.0)GO TO 15
IF(KIND.EQ.2)GO TO 37
IF(IEOF.EQ.0)GO TO 37
GO TO 6
12 IF(KIND.EQ.2)LOWBFR=LOWBFR-1
GO TO 29
C
C EQUAL SIGN FOUND
13 IF(IAFTER.GT.0)GO TO 27
MANY=-1
IAFTER=0
LCNRIT=-1
GO TO 9
C
C AMPERSAND FOUND OR MORE FILES NEEDED
14 KNTFIL=KNTFIL-1
MANY=-1
IAFTER=0
15 IF(KIND.EQ.2)GO TO 9
IF(IEOF.NE.0)GO TO 6
GO TO 2
C
C EXTRA COMMA FOUND
16 IF(IAFTER.GT.0)GO TO 27
KNTFIL=KNTFIL+1
NEWNUL(KNTFIL)=0
IAFTER=1
GO TO 19
C
C EVALUATE LOCATION AND REPACK DEVICE AND FILE NAME
17 IF(KONTNT.EQ.0)GO TO 20
IF(IAFTER.GT.0)GO TO 28
NXTFIL=KNTFIL+1
GO TO 38
18 IF(KONTNT.GE.16)GO TO 21
KNTFIL=NXTFIL
IAFTER=2
19 IF(LCNRIT.NE.0)GO TO 9
IF(KNTFIL.LT.MAXFIL)IAFTER=IAFTER-2
GO TO 9
C
C ALLOW CALLING PROGRAM TO EVALUATE SWITCH
20 LCNOWN=KNTFIL
KIND=5
IF(MANY.GT.0)GO TO 37
IF(IAFTER.GT.0)GO TO 28
MANY=-1
LCNOWN=LCNOWN+1
GO TO 37
C
C OPEN COMMAND FILE SPECIFIED BY USER
21 KOMAND=NEWNAM(NXTFIL)
IF(NEWNUL(NXTFIL).LE.1)ENCODE(10,22,KOMAND)
1KMDNAM,KMDEXT
IF(NEWNUL(NXTFIL).EQ.2)ENCODE(10,22,KOMAND)
1NEWNAM(NXTFIL),KMDEXT
22 FORMAT(1A6,1H.,1A3)
IF(NEWNUL(NXTFIL).EQ.4)ENCODE(10,23,KOMAND)
1KMDNAM,(KOLECT(I),I=8,10)
23 FORMAT(1A6,1H.,3A1)
INDISK=NEWDSK(NXTFIL)
IF(INDISK.EQ.JBLANK)INDISK=KMDDVC
DO 24 I=1,3
24 ONEPTH(I)=NEWPTH(I,NXTFIL)
OPEN(UNIT=KMDNUM,DEVICE=INDISK,FILE=KOMAND,
1DIRECTORY=ONEPTH,ACCESS=5HSEQIN,ERR=25)
GO TO 6
25 WRITE(JTTY,26)(IBUFFR(I),I=MINPRT,MAXPRT)
26 FORMAT(26H CANNOT READ COMMAND FROM ,100A1)
GO TO 2
C
C PREPARE TO RETURN RESULTS TO CALLING PROGRAM
27 MANY=-1
GO TO 29
28 LOWBFR=MINPRT
29 IAFTER=0
IF(LCNRIT.GT.0)GO TO 31
KIND=3
IF(LCNRIT.LT.0)GO TO 33
LCNRIT=1
GO TO 34
30 LCNRIT=LCNRIT+1
31 IF(LCNRIT.GT.KNTFIL)GO TO 8
KIND=4
IF(NEWNUL(LCNRIT).EQ.0)GO TO 37
IF(NEWDSK(LCNRIT).EQ.JBLANK)NEWDSK(LCNRIT)=LSTDSK
IF(NEWPTH(1,LCNRIT).NE.0)GO TO 34
DO 32 I=1,3
32 NEWPTH(I,LCNRIT)=LSTPTH(I)
GO TO 36
33 LCNRIT=KNTFIL
34 DO 35 I=1,3
35 LSTPTH(I)=NEWPTH(I,LCNRIT)
36 LSTDSK=NEWDSK(LCNRIT)
C
C RETURN TO CALLING PROGRAM
37 RETURN
C
C *****************************************************
C * *
C * A10 PACK NAME, A5 PACK DEVICE, EVALUATE NUMBERS *
C * *
C *****************************************************
C
C SET SWITCHES WHICH STATE IF ANYTHING WAS FOUND
38 NEWPRJ=0
NEWUSR=0
DO 39 I=1,3
39 NEWPTH(I,NXTFIL)=TWONUM
NEWNUL(NXTFIL)=0
NEWDSK(NXTFIL)=JBLANK
C
C PACK DEVICE NAME INTO A5 FORM
IF(MAXDSK.LT.1)GO TO 42
KOUNT=KNTLTR(1)
IF(KOUNT.LE.0)GO TO 42
IBGN=INILTR(1)
DO 40 I=1,5
KOLECT(I)=IBLANK
IF(KOUNT.GT.0)KOLECT(I)=IBUFFR(IBGN)
IBGN=IBGN+1
40 KOUNT=KOUNT-1
ENCODE(5,41,NEWDSK(NXTFIL))(KOLECT(I),I=1,5)
41 FORMAT(5A1)
NEWNUL(NXTFIL)=1
C
C EVALUATE OCTAL PROJECT, PROGRAMMER NUMBERS
42 INDEX=MAXNAM+1
IF(INDEX.GE.MAXNUM)GO TO 48
43 KOUNT=KNTLTR(INDEX)
IF(KOUNT.LE.0)GO TO 48
IBGN=INILTR(INDEX)
IEND=IBGN+KOUNT-1
NEWPRJ=NEWUSR
NEWUSR=0
DO 45 I=IBGN,IEND
LTRNOW=IBUFFR(I)
NEWUSR=8*NEWUSR
DO 44 J=1,8
IF(LETTER(J).NE.LTRNOW)GO TO 44
NEWUSR=NEWUSR+J-1
GO TO 45
44 CONTINUE
45 CONTINUE
IF(NEWUSR.LE.0)GO TO 48
INDEX=INDEX+1
IF(INDEX.LE.(MAXNAM+2))GO TO 43
NEWPTH(1,NXTFIL)=TWONUM
NEWNUL(NXTFIL)=1
C
C PACK SUB FILE DIRECTORY NAME
IF(MAXNUM.LE.(MAXNAM+2))GO TO 48
KOUNT=KNTLTR(MAXNAM+3)
IF(KOUNT.LE.0)GO TO 48
IBGN=INILTR(MAXNAM+3)
DO 46 I=1,6
KOLECT(I)=IBLANK
IF(KOUNT.GT.0)KOLECT(I)=IBUFFR(IBGN)
IBGN=IBGN+1
46 KOUNT=KOUNT-1
ENCODE(10,47,NEWPTH(2,NXTFIL))(KOLECT(I),I=1,6)
47 FORMAT(6A1,4X)
C
C PACK FILE NAME AND ITS EXTENSION INTO A10 FORM
48 DO 49 I=1,10
49 KOLECT(I)=IBLANK
IF(MAXNAM.LE.MAXDSK)GO TO 55
KOUNT=KNTLTR(MAXDSK+1)
IF(KOUNT.LE.0)GO TO 51
NEWNUL(NXTFIL)=2
IBGN=INILTR(MAXDSK+1)
IF(KOUNT.GT.6)KOUNT=6
DO 50 I=1,KOUNT
KOLECT(I)=IBUFFR(IBGN)
50 IBGN=IBGN+1
IF(MAXNAM.LE.(MAXDSK+1))GO TO 54
NEWNUL(NXTFIL)=3
KOUNT=KNTLTR(MAXDSK+2)
GO TO 52
51 IF(MAXNAM.LE.(MAXDSK+1))GO TO 55
KOUNT=KNTLTR(MAXDSK+2)
IF(KOUNT.LE.0)GO TO 55
NEWNUL(NXTFIL)=4
52 IBGN=INILTR(MAXDSK+2)
IF(KOUNT.GT.3)KOUNT=3
DO 53 I=8,10
IF(KOUNT.GT.0)KOLECT(I)=IBUFFR(IBGN)
IBGN=IBGN+1
53 KOUNT=KOUNT-1
54 KOLECT(7)=IDOT
55 ENCODE(10,56,NEWNAM(NXTFIL))KOLECT
56 FORMAT(10A1)
GO TO 18
C610045095007$&
END
SUBROUTINE DAFLAG(KONECT,LOWSTR,MAXSTR,MAXBFR,IBUFFR,
1 LOWBFR,MANY ,KIND ,INILTR,KNTLTR,MAXDSK,MAXNAM,
2 MAXNUM,MAXFLG,KONTNT,MINPRT,MAXPRT)
C RENBR(/EVALUATE FORM DSK:NAME.EXT[NUMBER,NUMBER])
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO LOCATE COMPONENTS OF FILE SPECIFICATION OF
C FORM
C
C DSK:NAME.EXT[12,34,56]/SWITCH:ARGUMENT/SWITCH:'TEXT'
C
C ONLY ONE DEVICE FIELD, ONE NAME FIELD AND ONE
C BRACKETED FIELD CAN APPEAR IN THE FILE SPECIFICATION.
C THE DEVICE FIELD MUST APPEAR BEFORE THE NAME FIELD,
C BUT THE BRACKETED FIELD CAN BE BEFORE, BETWEEN, OR
C AFTER THESE. THE SWITCH FIELDS CAN APPEAR BEFORE
C AND/OR AFTER THE REST OF THE FILE SPECIFICATION.
C
C THE COMPONENTS OF EACH FIELD WITHIN THE FILE
C DESCRIPTION ARE IDENTIFIED TO THE CALLING PROGRAM BY
C LENGTH AND BY STARTING LOCATION WITHIN THE BUFFER.
C THIS INFORMATION IS RETURNED WITHIN THE 2 ARRAYS
C KNTLTR AND INILTR RESPECTIVELY. SINCE EACH FIELD CAN
C CONSIST OF ANY NUMBER OF COMPONENTS CONNECTED BY THE
C APPROPRIATE CHARACTER (COLON, COMMA OR PERIOD), AND
C SINCE FOR SOME APPLICATIONS A TERMINAL SEPARATOR
C CHARACTER HAS SPECIAL MEANING, A ZERO CHARACTER COUNT
C IS RETURNED IN THE KNTLTR ARRAY FOR THE FINAL
C COMPONENT OF A FIELD IN WHICH AN OPTIONAL TERMINAL
C CONNECTING CHARACTER IS FOUND. SINCE THERE IS NEVER
C ANY QUESTION ABOUT WHETHER AN ITEM IN THE DEVICE
C FIELD WAS FOLLOWED BY THE CONNECTING CHARACTER, THE
C DESCRIPTION OF THE DEVICE FIELD DOES NOT INCLUDE A
C FINAL ZERO CHARACTER COUNT.
C
C A TEXT STRING DELIMITED BY APOSTROPHES IS TREATED AS
C A SWITCH EVEN IF NOT PRECEDED BY A SLASH. THE
C LOCATION OF A TEXT STRING IS THAT OF THE INITIAL
C APOSTROPHE, AND THE LENGTH INCLUDES THE INITIAL, BUT
C NOT THE FINAL, APOSTROPHE. IF THE FINAL APOSTROPHE
C IS MISSING, THEN THE TEXT STRING IS ASSUMED TO EXTEND
C THROUGH THE RIGHTMOST PRINTING CHARACTER IN THE
C BUFFER. WITHIN A TEXT STRING, TWO ADJACENT
C APOSTROPHES INDICATE A SINGLE APOSTROPHE WHICH IS TO
C BE INCLUDED WITHIN THE STRING. IF 2 ADJACENT
C APOSTROPHES ARE ENCOUNTERED WITHIN THE TEXT STRING,
C THEN THE REMAINDER OF THE STRING IS MOVED 1 CHARACTER
C TO THE LEFT SO THAT THE RETURNED CONTENTS OF THE
C BUFFER AND THE RETURNED LENGTH IN THE KNTLTR ARRAY DO
C NOT INCLUDE THE EXTRA APOSTROPHE.
C
C AN ASTERISK WHICH IS FOLLOWED IMMEDIATELY BY A
C PRINTING CHARACTER OTHER THAN A PUNCTUATION MARK IS
C TREATED AS THOUGH SEPARATED FROM THIS FOLLOWING
C CHARACTER BY A PERIOD IF IN THE NAME FIELD, BY A
C COMMA IF IN THE BRACKETED FIELD OR BY A COLON IF IN
C THE SWITCH FIELD.
C
C FOR EXAMPLE, IF THE CONTENTS OF THE BUFFER ARE
C
C DSK:DAFLAG.F4[6001,56,FASP]/LINE:60:/TITLE:'JAN 76'
C
C THEN THE FOLLOWING INFORMATION WOULD BE RETURNED BY 3
C CONSECUTIVE CALLS TO THIS ROUTINE
C
C FIELD KNTLTR CONTENTS INILTR CONTENTS
C
C BY THE FIRST CALL TO THIS ROUTINE
C
C DEVICE 3 1
C
C NAME 6 5
C 2 12
C
C BRACKETED 4 15
C 2 20
C 4 23
C
C BY THE SECOND CALL TO THIS ROUTINE
C
C SWITCH 4 29
C 2 34
C 0 UNDEFINED
C
C BY THE THIRD CALL TO THIS ROUTINE
C
C SWITCH 5 38
C 7 44
C
C THE FOLLOWING ARGUMENTS ARE USED ONLY FOR INPUT.
C
C KONECT = -1, SPACES AND/OR TAB CHARACTERS CAN APPEAR
C BETWEEN COMPONENTS OF ANY FIELD, AND CAN
C REPLACE SEPARATING PERIODS AND COMMAS IN THE
C NAME AND BRACKETED FIELDS RESPECTIVELY.
C SUCH SPACES AND/OR TABS MARK END OF A
C PARTICULAR COMPONENT OF FIELD, BUT DO NOT
C SIGNAL EITHER END OF FIELD OR END OF FILE
C SPECIFICATION. COMPONENTS OF FILE
C SPECIFICATION WILL BE LOCATED THROUGH END OF
C BUFFER, OR UP TO FOLLOWING EXCLAMATION
C POINT, AMPERSAND OR SEMICOLON, OR UP TO
C FOLLOWING COMMA WHICH IS NOT IN BRACKETED
C FIELD. SINGLE CALL TO THIS ROUTINE WILL
C REPORT EITHER CONTENTS OF SINGLE SWITCH
C FIELD OR COMBINATION OF DEVICE FIELD, NAME
C FIELD AND BRACKETED FIELD WHETHER OR NOT
C THESE ARE SEPARATED BY SPACES AND/OR TABS.
C = 0, SIMILAR TO KONECT=-1 EXCEPT THAT SPACES
C AND TAB CHARACTERS CANNOT APPEAR BETWEEN
C FIELDS AND CANNOT APPEAR BETWEEN COMPONENTS
C OF DEVICE AND NAME FIELDS. FILE
C SPECIFICATION WILL BEGIN WITH FIRST PRINTING
C CHARACTER OTHER THAN PUNCTUATION CHARACTERS
C COMMA, AMPERSAND, EQUALS SIGN, SEMICOLON OR
C EXCLAMATION POINT, THEN EXTEND THROUGH END
C OF BUFFER, OR UP TO FIRST SPACE OR TAB
C CHARACTER WHICH WHICH IS NEITHER WITHIN
C BRACKETED FIELD NOR WITHIN SWITCH FIELD NOR
C WITHIN TEXT STRING DELIMITED BY APOSTROPHES,
C OR UP TO FOLLOWING EXCLAMATION POINT,
C AMPERSAND OR SEMICOLON, OR UP TO FOLLOWING
C COMMA WHICH IS NOT IN BRACKETED FIELD.
C SINGLE CALL TO THIS ROUTINE WILL REPORT
C EITHER CONTENTS OF SINGLE SWITCH FIELD OR
C COMBINATION OF DEVICE FIELD, NAME FIELD AND
C BRACKETED FIELD PROVIDING THESE ARE
C CONTIGUOUS.
C = 1, SIMILAR TO KONECT=-1 EXCEPT THAT SPACES
C AND TAB CHARACTERS CANNOT APPEAR BETWEEN
C COMPONENTS OF DEVICE AND NAME FIELDS.
C LOWSTR = SUBSCRIPT OF FIRST LOCATION WITHIN INILTR
C AND KNTLTR ARRAYS WHICH CAN BE USED TO HOLD
C DESCRIPTION OF COMPONENTS OF FILE
C SPECIFICATION.
C MAXSTR = SUBSCRIPT OF FINAL LOCATION WITHIN INILTR
C AND KNTLTR ARRAYS WHICH CAN BE USED TO HOLD
C DESCRIPTION OF COMPONENTS OF FILE
C SPECIFICATION.
C MAXBFR = SUBSCRIPT OF FINAL (RIGHTMOST) LOCATION
C WITHIN IBUFFR ARRAY WHICH CONTAINS CHARACTER
C WHICH CAN BE PART OF FILE SPECIFICATION.
C
C FOLLOWING ARGUMENTS ARE USED FOR BOTH INPUT TO, AND
C OUTPUT FROM THIS ROUTINE.
C
C IBUFFR = ARRAY CONTAINING IN LOCATIONS IBUFFR(LOWBFR)
C THROUGH IBUFFR(MAXBFR) CHARACTERS READ BY
C CALLING PROGRAM WITH MULTIPLE OF A1 FORMAT
C AND WHICH CAN FORM FILE SPECIFICATION.
C CONTENTS OF IBUFFR ARRAY ARE RETURNED
C UNCHANGED, WITH EXCEPTION THAT PORTION OF
C TEXT STRING TO RIGHT OF ADJACENT APOSTROPHES
C IN TEXT STRING IN SWITCH FIELD IS MOVED 1
C CHARACTER TO LEFT.
C LOWBFR = SUBSCRIPT OF FIRST (LEFTMOST) LOCATION
C WITHIN IBUFFR ARRAY WHICH CONTAINS CHARACTER
C WHICH CAN BE PART OF FILE SPECIFICATION.
C LOWBFR IS RETURNED POINTING TO FIRST
C CHARACTER WHICH SHOULD BE EVALUATED BY
C SUBSEQUENT CALL TO THIS ROUTINE, OR ELSE IS
C RETURNED POINTING BEYOND END OF BUFFER IF
C BUFFER IS EMPTY OR IF BUFFER CONTAINS MERELY
C COMMENT.
C MANY = SHOULD BE INPUT CONTAINING ZERO EACH TIME
C THIS ROUTINE IS CALLED TO BEGIN PROCESSING
C OF A NEW LOGICAL SECTION OF TEXT, AS FOR
C EXAMPLE WHEN BEGINNING PROCESSING OF A LINE
C OF TEXT NOT TIED TO THE PREVIOUS LINE BY AN
C AMPERSAND AT THE END OF THE PREVIOUS LINE,
C OR WHEN PROCESSING THE TEXT TO THE RIGHT OF
C A SEMICOLON OR TO THE RIGHT OF AN EQUALS
C SIGN.
C = RETURNED CONTAINING THE VALUE WHICH MANY
C SHOULD HAVE WHEN THIS ROUTINE OR ANY OTHER
C IN THE FASP PACKAGE HAVING MANY AS AN
C ARGUMENT IS NEXT CALLED. THE RETURNED VALUE
C OF MANY SHOULD NOT BE CHANGED BY THE CALLING
C PROGRAM UNLESS THE INTERPRETATION OF THE
C CONTENTS OF THE BUFFER IS BEING ABANDONED
C PREMATURELY, IN WHICH CASE MANY SHOULD BE
C RESET TO HAVE A ZERO VALUE.
C = -1, RETURNED IF A MISSING ITEM IS TO BE
C INDICATED IF THE NEXT ROUTINE ENCOUNTERS A
C LEADING COMMA OR FINDS THAT THE BUFFER
C CONTAINS NOTHING OTHER THAN A POSSIBLE
C COMMENT. MANY IS RETURNED CONTAINING -1 IF
C A COMMA PRECEDES EITHER AN AMPERSAND OR A
C SWITCH FIELD.
C = 0, RETURNED IF A MISSING ITEM IS TO BE
C INDICATED IF THE NEXT ROUTINE ENCOUNTERS A
C LEADING COMMA, BUT A MISSING ITEM IS NOT
C INDICATED IF THE BUFFER CONTAINS NOTHING
C OTHER THAN A POSSIBLE COMMENT. MANY IS
C RETURNED CONTAINING ZERO IF BUFFER IS FOUND
C TO BE EMPTY, OR IF FIRST PRINTING CHARACTER
C AT OR TO RIGHT OF IBUFFR(LOWBFR) IS FOUND TO
C BE EXCLAMATION POINT, SEMICOLON OR EQUALS
C SIGN. THESE ARE ALL CONDITIONS UNDER WHICH
C NEXT CALL TO THIS ROUTINE WOULD EVALUATE
C START OF NEW GROUP OF FILE SPECIFICATIONS.
C MANY IS RETURNED UNCHANGED IF A SWITCH FIELD
C IS FOUND AT THE START OF THE CONTENTS OF THE
C BUFFER.
C = 1, RETURNED IF A MISSING ITEM IS NOT TO BE
C INDICATED IF THE NEXT ROUTINE ENCOUNTERS A
C LEADING COMMA OR FINDS THAT THE BUFFER
C CONTAINS NOTHING OTHER THAN A POSSIBLE
C COMMENT. MANY IS RETURNED CONTAINING ONE IF
C A FILE SPECIFICATION CONSISTING OF MORE THAN
C JUST A SWITCH FIELD IS FOUND, OR IF A
C MISSING ITEM IS BEING INDICATED.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT. THEIR
C INPUT VALUES ARE IGNORED.
C
C KIND = RETURNED DESCRIBING TYPE OF ITEM
C ENCOUNTERED.
C = 1, NOTHING, EXCEPT POSSIBLY COMMENT
C INDICATED BY LEADING EXCLAMATION POINT, WAS
C FOUND AT OR TO RIGHT OF IBUFFR(LOWBFR).
C LOWBFR IS RETURNED POINTING BEYOND END OF
C BUFFER.
C = 2, FIRST PRINTING CHARACTER AT OR TO RIGHT
C OF IBUFFR(LOWBFR) IS SEMICOLON. LOWBFR IS
C RETURNED POINTING TO CHARACTER TO RIGHT OF
C SEMICOLON. IT IS SUGGESTED THAT CALLING
C PROGRAM TREAT THIS AS INDICATION BY USER
C THAT PRECEDING COMMAND HAS BEEN COMPLETED
C AND THAT SUBSEQUENT COMMAND WILL FOLLOW ON
C SAME LINE.
C = 3, FIRST PRINTING CHARACTER AT OR TO RIGHT
C OF IBUFFR(LOWBFR) IS EQUALS SIGN. LOWBFR IS
C RETURNED POINTING TO CHARACTER TO RIGHT OF
C EQUALS SIGN. ON PDP10 COMPUTER, EQUALS SIGN
C IS USED TO SEPARATE DESTINATION AND SOURCE
C FILE SPECIFICATIONS.
C = 4, FIRST PRINTING CHARACTER AT OR TO RIGHT
C OF IBUFFR(LOWBFR) IS AMPERSAND. CHARACTERS
C TO RIGHT OF AMPERSAND ARE TAKEN TO BE
C COMMENT. LOWBFR IS RETURNED POINTING BEYOND
C END OF BUFFER. IT IS SUGGESTED THAT CALLING
C PROGRAM TREAT THIS AS REQUEST BY USER THAT
C COMMAND BE CONTINUED ON FOLLOWING LINE.
C EFFECT IS NOT QUITE SAME AS IF USER HAD
C TYPED ALL OF FILE SPECIFICATIONS ON SINGLE
C LINE SINCE FILE SPECIFICATION CANNOT BE
C SPLIT ACROSS LINE BOUNDARY.
C = 5, MISSING FILE SPECIFICATION WAS INDICATED
C BY AN EXTRA COMMA.
C = 6, PARTIAL FILE SPECIFICATION WAS FOUND
C WHICH WILL BE CONTINUED BY SUBSEQUENT CALL
C TO THIS ROUTINE. MANY WILL NOT BE
C INCREMENTED UNTIL FINAL SECTION OF FILE
C SPECIFICATION (KIND BEING RETURNED
C CONTAINING 7 OR 8) IS LOCATED. IF FILE NAME
C AND/OR DEVICE AND/OR BRACKETED FIELD HAS
C BEEN FOUND BY CURRENT CALL TO THIS ROUTINE,
C THEN PORTION TO RIGHT OF THAT EVALUATED
C CONTAINS SWITCH. IF SWITCH HAS BEEN FOUND
C BY CURRENT CALL TO THIS ROUTINE, THEN
C PORTION RIGHT OF THAT EVALUATED COULD
C CONTAIN ANY ITEM.
C = 7, FILE SPECIFICATION AND/OR SWITCHES WERE
C FOUND. IF PREVIOUS CALL TO THIS ROUTINE
C RETURNED KIND=6 INDICATING PARTIAL
C SPECIFICATION, THEN INFORMATION RETURNED BY
C CURRENT CALL TO THIS ROUTINE COMPLETES FILE
C SPECIFICATION.
C = 8, FILE SPECIFICATION AND/OR SWITCHES WERE
C FOUND, BUT THESE WERE FOLLOWED BY UNEXPECTED
C CHARACTER POINTED TO BY RETURNED VALUE OF
C LOWBFR. FOR EXAMPLE, TEXT
C DEVICE:NAME.EXTENSION: WOULD BE EVALUATED
C AS THOUGH BUFFER TERMINATED PRIOR TO SECOND
C COLON, AND LOWBFR WILL BE RETURNED POINTING
C TO THIS SECOND COLON. TEXT
C DEVICE:NAME.EXTENSION[6001,56][22,56] WOULD
C BE EVALUATED AS THOUGH BUFFER TERMINATED
C PRIOR TO SECOND BRACKETED FIELD, AND LOWBFR
C WOULD BE RETURNED POINTING TO SECOND LEFT
C BRACKET.
C INILTR = ARRAY RETURNED CONTAINING SUBSCRIPTS WITHIN
C IBUFFR ARRAY OF INITIAL CHARACTERS OF WORDS
C FORMING FILE SPECIFICATION. LOCATIONS
C INILTR(LOWSTR) THROUGH INILTR(MAXDSK)
C CONTAIN LOCATIONS IN BUFFER OF INITIAL
C CHARACTERS OF DEVICE NAMES. LOCATIONS
C INILTR(MAXDSK+1) THROUGH INILTR(MAXNAM)
C CONTAIN LOCATIONS IN BUFFER OF INITIAL
C CHARACTERS OF WORDS IN NAME FIELD.
C LOCATIONS INITLR(MAXNAM+1) THROUGH
C INILTR(MAXNUM) CONTAIN LOCATIONS IN BUFFER
C OF INITIAL CHARACTERS OF WORDS IN BRACKETED
C FIELD. LOCATIONS INILTR(LOWSTR) THROUGH
C INILTR(MAXFLG) CONTAIN LOCATIONS IN BUFFER
C OF INITIAL CHARACTERS OF WORDS AND TEXT
C STRINGS APPEARING IN SWITCH FIELDS. IF TEXT
C STRING APPEARS IN SWITCH FIELD, LOCATION IN
C IBUFFR ARRAY INDICATED BY INILTR ARRAY WILL
C CONTAIN APOSTROPHE.
C KNTLTR = ARRAY RETURNED CONTAINING NUMBERS OF
C CHARACTERS IN EACH OF WORDS FOR WHICH FIRST
C CHARACTERS ARE IN BUFFER LOCATIONS INDICATED
C BY VALUES IN INILTR ARRAY. SUBSCRIPTS OF
C INILTR ARRAY AND KNTLTR ARRAY LOCATIONS
C DESCRIBING PARTICULAR WORD ARE IDENTICAL.
C MAXDSK = RETURNED CONTAINING SUBSCRIPT OF INILTR AND
C KNTLTR ARRAY LOCATIONS DESCRIBING RIGHTMOST
C WORD IN DEVICE FIELD OF FILE SPECIFICATION.
C IF DEVICE FIELD IS NOT FOUND, THEN MAXDSK
C WILL BE RETURNED CONTAINING LOWSTR-1.
C MAXNAM = RETURNED CONTAINING SUBSCRIPT OF INILTR AND
C KNTLTR ARRAY LOCATIONS DESCRIBING RIGHTMOST
C WORD IN NAME FIELD OF FILE SPECIFICATION.
C IF NAME FIELD IS NOT FOUND, THEN MAXNAM WILL
C BE RETURNED EQUAL TO MAXDSK.
C MAXNUM = RETURNED CONTAINING SUBSCRIPT OF INILTR AND
C KNTLTR ARRAY LOCATIONS DESCRIBING RIGHTMOST
C WORD IN BRACKETED FIELD OF FILE
C SPECIFICATION. IF BRACKETED FIELD IS NOT
C FOUND, THEN MAXNUM WILL BE RETURNED EQUAL TO
C MAXNAM.
C MAXFLG = RETURNED CONTAINING SUBSCRIPT OF INILTR AND
C KNTLTR ARRAY LOCATIONS DESCRIBING RIGHTMOST
C WORD OF SWITCH FIELD. IF SWITCH FIELD IS
C NOT FOUND, THEN MAXFLG IS RETURNED EQUAL TO
C LOWSTR-1.
C KONTNT = BIT CODED NUMBER RETURNED DESCRIBING
C LOCATION OF BRACKETED FIELD RELATIVE TO
C DEVICE AND NAME FIELDS. RIGHT BIT IS ONE IF
C AND ONLY IF NAME FIELD IS FOUND. SECOND BIT
C FROM RIGHT IS ONE IF AND ONLY IF DEVICE
C FIELD IS FOUND. FOURTH AND THIRD BITS FROM
C RIGHT ARE 00 IF NO BRACKETED FIELD IS FOUND,
C 01 IF BRACKETED FIELD APPEARS FIRST, 10 IF
C BRACKETED FIELD FOLLOWS DEVICE FIELD, AND 11
C IF BRACKETED FIELD FOLLOWS NAME FIELD.
C FOLLOWING TABLE PRESENTS VALUES OF KONTNT
C RETURNED FOR ALL POSSIBLE COMBINATIONS OF
C DEVICE, NAME AND BRACKETED FIELDS. MINUS
C SIGNS REPRESENT VALUES OF KONTNT WHICH
C CANNOT BE RETURNED. VALUE ZERO INDICATES
C THAT NEITHER DEVICE, NOR NAME NOR BRACKETED
C FIELDS WERE FOUND, BUT DOES NOT INDICATE
C WHETHER SWITCH FIELD WAS FOUND.
C
C DECIMAL BINARY DECIMAL BINARY
C 0 0 NOTHING 8 1000 ------
C 1 1 NAME 9 1001 ------
C 2 10 DEVICE: 10 1010 DEVICE:[]
C 3 11 DEVICE:NAME 11 1011 DEVICE:[]NAME
C 4 100 [] 12 1100 ------
C 5 101 []NAME 13 1101 NAME[]
C 6 110 []DEVICE: 14 1110 ------
C 7 111 []DEVICE:NAME 15 1111 DEVICE:NAME[]
C
C 16 IS ADDED TO KONTNT IF AT SIGN @ IS FOUND
C ANYWHERE IN FILE SPECIFICATION OTHER THAN
C WITHIN A SWITCH FIELD.
C MINPRT = SUBSCRIPT OF IBUFFR ARRAY LOCATION WHICH
C CONTAINS FIRST CHARACTER OF FILE
C SPECIFICATION OR SWITCH IF KIND IS RETURNED
C CONTAINING VALUE OF 6 OR GREATER. MINPRT
C AND MAXPRT CAN BE USED AS LIMITS OF IBUFFR
C ARRAY SUBSCRIPTS IF TEXT MUST BE DISPLAYED
C TO USER. MINPRT AND MAXPRT ARE RETURNED
C UNDEFINED IF KIND IS RETURNED CONTAINING
C VALUE LESS THAN 6.
C MAXPRT = SUBSCRIPT OF IBUFFR ARRAY LOCATION WHICH
C CONTAINS FINAL CHARACTER OF FILE
C SPECIFICATION OR SWITCH IF KIND IS RETURNED
C CONTAINING VALUE OF 6 OR GREATER.
C
DIMENSION KNTLTR(MAXSTR),INILTR(MAXSTR),
1IBUFFR(MAXBFR)
C
C CCCC AAA UU UU TTTTTTTT IIII OOOO NN NN
C CC AAAA UU UU TT II OO OO NNN NN
C CC AA AA UU UU TT II OO OO NNNN NN
C CC AA AA UU UU TT II OO OO NN NN NN
C CC AAAAAAA UU UU TT II OO OO NN NNNN
C CC AA AA UU UU TT II OO OO NN NNN
C CCCC AA AA UUU TT IIII OOOO NN NN
C
C LEFT AND RIGHT SQUARE BRACKETS MUST BE DEFINED USING
C OCTAL NOTATION FOR PDP10 F40 COMPILER. LET FOLLOWING
C COMMENT BE THE COMPILED DATA STATEMENT IF F40 IS USED
C DATA ILEFT,IRIGHT/"555004020100,"565004020100/
DATA ILEFT,IRIGHT/1H[,1H]/
C
DATA ISTAR,ICOLON,IDOT,ICOMMA,ISLASH,IQUOTE,IEND,
1IAND,KOMENT,IEQUAL,KOMAND,IBLANK,ITAB/1H*,1H:,1H.,
21H,,1H/,1H',1H;,1H&,1H!,1H=,1H@,1H ,1H /
C
C MAJOR = -1, PROCESSING NAME SECTION
C = 0, PROCESSING CONTENTS OF BRACKETS
C = 1, PROCESSING SWITCH
C = 2, IN TEXT STRING
C
NEWSPC=1
MAXDSK=LOWSTR-1
MAXNAM=MAXDSK
MAXNUM=MAXDSK
MAXFLG=MAXDSK
NONDSK=0
NONNAM=0
NONNUM=0
KONTNT=0
LOCATN=4
KIND=1
LOWBFR=LOWBFR-1
MIDPRT=LOWBFR
IF(MANY.GE.0)GO TO 46
KIND=5
MANY=1
GO TO 46
1 LOWBFR=LOWBFR+1
MAXPRT=MIDPRT
IF(LOWBFR.GT.MAXBFR)GO TO 32
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.IBLANK)GO TO 24
IF(LETTER.EQ.ITAB)GO TO 24
IF(KIND.NE.7)MINPRT=LOWBFR
MIDPRT=LOWBFR
LSTSPC=NEWSPC
NEWSPC=0
C
C CHECK FOR GENERAL PUNCTUATION CHARACTERS
IF(LETTER.EQ.IEND)GO TO 26
IF(LETTER.EQ.IAND)GO TO 20
IF(LETTER.EQ.KOMENT)GO TO 21
IF(LETTER.EQ.IEQUAL)GO TO 27
IF(LETTER.EQ.ISLASH)GO TO 10
IF(LETTER.EQ.IQUOTE)GO TO 11
IF(LETTER.EQ.ICOMMA)GO TO 22
IF(MAJOR.GT.0)GO TO 3
IF(LETTER.EQ.KOMAND)GO TO 19
IF(MAJOR.EQ.0)GO TO 4
C
C CHECK FOR KEY CHARACTERS IN NAME FIELD
IF(KIND.EQ.7)GO TO 2
INDRCT=MANY
IF(KIND.EQ.5)INDRCT=-1
MANY=1
KIND=7
2 IF(LETTER.EQ.ICOLON)GO TO 30
IF(LETTER.EQ.ILEFT)GO TO 9
IF(NONNAM.GT.0)GO TO 31
IF(LETTER.EQ.IDOT)GO TO 23
GO TO 5
C
C CHECK FOR KEY CHARACTERS IN SWITCH SECTION
3 IF(KOUNT.LT.0)GO TO 29
I=MAJOR
MAJOR=1
IF(LETTER.EQ.ICOLON)GO TO 23
IF(I.NE.2)GO TO 5
GO TO 29
C
C CHECK FOR KEY CHARACTERS IN BRACKET FIELD
4 IF(LETTER.EQ.ILEFT)GO TO 31
IF(LETTER.EQ.IRIGHT)GO TO 25
IF(LETTER.EQ.IDOT)GO TO 23
IF(LETTER.EQ.ICOLON)GO TO 23
C
C EXTEND NAME OR NUMBER OR SWITCH
5 IF(KOUNT.GT.0)GO TO 6
LTRLFT=LOWBFR
KOUNT=1
GO TO 1
6 IF(LSTSPC.NE.0)GO TO 7
IF(IBUFFR(MAXPRT).EQ.ISTAR)GO TO 8
KOUNT=KOUNT+1
GO TO 1
7 IF(MAJOR.GT.0)GO TO 29
8 LOWBFR=LOWBFR-1
GO TO 23
C
C LEFT BRACKET OTHER THAN IN SWITCH FIELD
9 IF(NONNUM.NE.0)GO TO 31
NEXT=4
GO TO 33
C
C INITIAL SLASH FOUND
10 IF(KIND.EQ.7)GO TO 29
IF(KIND.EQ.5)MANY=-1
KIND=7
MAJOR=1
GO TO 44
C
C APOSTROPHE STARTS TEXT STRING
11 IF(MAJOR.LE.0)GO TO 12
IF(KOUNT.EQ.0)GO TO 13
IF(KOUNT.NE.1)GO TO 29
IF(LSTSPC.NE.0)GO TO 29
IF(IBUFFR(MAXPRT).EQ.ISTAR)GO TO 8
GO TO 29
12 IF(KIND.EQ.7)GO TO 29
IF(KIND.EQ.5)MANY=-1
KIND=7
MAJOR=2
13 LTRLFT=LOWBFR
I=LOWBFR
MIDPRT=LOWBFR
14 IF(I.GE.MAXBFR)GO TO 16
I=I+1
LOWBFR=LOWBFR+1
IBUFFR(LOWBFR)=IBUFFR(I)
IF(IBUFFR(I).EQ.IBLANK)GO TO 14
IF(IBUFFR(I).EQ.ITAB)GO TO 14
MIDPRT=LOWBFR
IF(IBUFFR(I).NE.IQUOTE)GO TO 14
IF(I.GE.MAXBFR)GO TO 15
IF(IBUFFR(I+1).NE.IQUOTE)GO TO 15
I=I+1
GO TO 14
15 MIDPRT=MIDPRT-1
16 KOUNT=MIDPRT-LTRLFT+1
17 IF(LOWBFR.EQ.I)GO TO 18
LOWBFR=LOWBFR+1
IBUFFR(LOWBFR)=IBLANK
GO TO 17
18 IF(MAJOR.EQ.2)GO TO 25
MAJOR=2
GO TO 1
C
C AT SIGN
19 IF(KONTNT.GT.15)GO TO 31
IF(KIND.EQ.7)MANY=INDRCT
IF(KIND.EQ.5)MANY=-1
KIND=7
KONTNT=KONTNT+16
GO TO 25
C
C AMPERSAND FOUND
20 IF(KIND.EQ.7)GO TO 32
IF(KIND.EQ.5)MANY=-1
KIND=4
C
C EXCLAMATION POINT FOUND
21 LOWBFR=MAXBFR+1
GO TO 32
C
C COMMA FOUND OTHER THAN IN NUMBER SECTION
22 IF(MAJOR.EQ.0)GO TO 23
IF(KIND.NE.1)GO TO 32
KIND=5
IF(MANY.GT.0)GO TO 1
GO TO 32
C
C COMMA IN BRACKET SECTION OR COLON IN SWITCH SECTION
23 NEXT=3
IF(KOUNT.LT.0)KOUNT=0
GO TO 33
C
C SPACE OR TAB FOUND
24 IF(NEWSPC.NE.0)GO TO 1
NEWSPC=1
IF(KONECT.LT.0)GO TO 1
IF(MAJOR.GE.0)GO TO 1
IF(KIND.NE.7)GO TO 1
IF(KONECT.EQ.0)GO TO 32
25 NEXT=5
GO TO 33
C
C SEMICOLON FOUND
26 IF(KIND.NE.1)GO TO 32
KIND=2
GO TO 28
C
C EQUALS SIGN FOUND
27 IF(KIND.NE.1)GO TO 32
KIND=3
28 LOWBFR=LOWBFR+1
GO TO 32
C
C CURRENT CALL CANNOT RETURN ALL INFORMATION
29 KIND=6
GO TO 32
C
C COLON FOUND IN NAME FIELD
30 IF(NONDSK.LE.0)GO TO 35
C
C ILLEGAL CHARACTER, BUT MUST CLEAN UP BEFORE EXIT
31 KIND=8
C
C PREPARE TO EXIT TO CALLING PROGRAM
32 NEXT=1
C
C TERMINATE GROUP OF NAMES OR NUMBERS
33 IF(KOUNT.LT.0)GO TO 42
IF(MAJOR.GT.0)GO TO 40
IF(MAJOR.EQ.0)GO TO 34
LOCAL=MAXNAM
IF(NONNAM.EQ.0)KONTNT=KONTNT+1
LOCATN=12
NONNAM=-1
NONDSK=1
GO TO 36
34 LOCAL=MAXNUM
IF(NONNUM.EQ.0)KONTNT=KONTNT+LOCATN
NONNUM=-1
GO TO 37
35 IF(KOUNT.LT.0)KOUNT=0
NEXT=2
LOCAL=MAXDSK
IF(NONDSK.EQ.0)KONTNT=KONTNT+2
LOCATN=8
NONDSK=-1
IF(MAXDSK.LT.MAXSTR)MAXDSK=MAXDSK+1
36 IF(MAXNAM.LT.MAXSTR)MAXNAM=MAXNAM+1
37 IF(MAXNUM.LT.MAXSTR)MAXNUM=MAXNUM+1
INDEX=MAXNUM
LOCAL=LOCAL+1
38 IF(INDEX.LE.LOCAL)GO TO 41
IF(INDEX.GT.MAXSTR)GO TO 39
INILTR(INDEX)=INILTR(INDEX-1)
KNTLTR(INDEX)=KNTLTR(INDEX-1)
39 INDEX=INDEX-1
GO TO 38
40 IF(MAXFLG.GE.MAXSTR)GO TO 42
MAXFLG=MAXFLG+1
LOCAL=MAXFLG
41 IF(LOCAL.GT.MAXSTR)GO TO 42
KNTLTR(LOCAL)=KOUNT
INILTR(LOCAL)=LTRLFT
C
C NEXT = 1, EXIT
C = 2, AFTER COLON OF DEVICE FIELD
C = 3, AFTER PERIOD IN NAME OR COMMA IN
C BRACKETED SECTION OR COLON IN SWITCH SECTION
C = 4, MARK THAT ARE IN BRACKETED SECTION
C = 5, TERMINATE CURRENT SECTION SO ITS TYPE
C WILL NOT BE PERMITTED
42 GO TO(49,47,44,43,45),NEXT
C
C MARK THAT ARE IN BRACKET SECTION
43 MAJOR=0
44 KOUNT=0
GO TO 48
C
C TERMINATE CURRENT SECTION
45 IF(MAJOR.GT.0)GO TO 47
IF(NONDSK.LT.0)NONDSK=1
IF(NONNAM.LT.0)NONNAM=1
IF(NONNUM.LT.0)NONNUM=1
46 MAJOR=-1
C
C PREPARE FOR NEXT ITEM IN LIST
47 KOUNT=-1
48 LTRLFT=LOWBFR+1
GO TO 1
C
C RETURN TO CALLING PROGRAM
49 IF(KIND.EQ.5)MANY=1
IF(KIND.LT.4)MANY=0
RETURN
C264038073645[]:';&!@
END
SUBROUTINE DATEXT(LINE ,JSTIFY,IFILL ,INTRVL,MOVE ,
1 ISPACE,LTTR ,LTRBGN,LTREND,LFTCOL,IWIDTH,MAXBFR,
2 IBUFFR,MAXUSD,MAXLIN,LTRNXT)
C RENBR(/CONSTRUCT LARGE MULTI-LINE LETTERING)
C
C DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERSITY
C DEVELOPED AT AIKEN COMPUTER LABORATORY
C
C DDDDD AAA TTTTTTTT EEEEEEEE XX XX TTTTTTTT
C DD DD AAAA TT EE XX XX TT
C DD DD AA AA TT EE XXXX TT
C DD DD AA AA TT EEEEE XX TT
C DD DD AAAAAAA TT EE XXXX TT
C DD DD AA AA TT EE XX XX TT
C DDDDD AA AA TT EEEEEEEE XX XX TT
C
C ROUTINE TO PRODUCE MULTIPLE LINE PRINTED LETTERING
C SIMILAR TO THAT USED FOR THE ABOVE TITLE.
C
C THIS ROUTINE MUST BE USED WITH A BLOCK DATA FONT
C CREATED BY THE PROGRAM DAFONT.
C
C LINE = THE LINE WITHIN THE LETTER REPRESENTATION
C WHICH IS TO BE PLACED INTO IBUFFR.
C CHARACTERS ARE A TOTAL OF IHIGH LINES HIGH.
C TO PRINT A LETTER OR LETTERS, IT IS
C NECESSARY TO CALL DATEXT IHIGH TIMES WITH
C LINE VALUES 1 THROUGH IHIGH, WITH THE
C CALLING PROGRAM PRINTING IBUFFR ARRAY AFTER
C EACH RETURN FROM DATEXT. THIS ALLOWS THE
C INSERTION OF THE CONSTRUCTED LETTERS INTO
C OTHER TEXT OR OTHER FORMS.
C = 0, REPRESENT HIGHEST VALUED LINE. LINE MUST
C BE SET TO MAXLIN-1 BEFORE THIS ROUTINE IS
C AGAIN CALLED.
C JSTIFY = -1, LEFT JUSTIFY THE LETTER REPRESENTATIONS
C IN A FIELD OF WIDTH IWIDTH.
C = 0, CENTER THE LETTER REPRESENTATIONS IN A
C FIELD OF WIDTH IWIDTH.
C = 1, RIGHT JUSTIFY THE LETTER REPRESENTATIONS
C IN A FIELD OF WIDTH IWIDTH.
C IFILL = 0, IF LEFT JUSITIFYING OR CENTERING THE
C LETTERING, DO NOT FILL THE UNUSED PORTION OF
C THE FIELD RIGHT OF LETTER REPRESENTATIONS
C WITH SPACES. MAXUSD WILL BE LEFT POINTING TO
C RIGHT END OF RIGHTMOST LETTER REPESENTATION.
C = 1, IF LEFT JUSIFYING OR CENTERING THE LETTER
C REPRESENTATIONS, DO FILL THE UNUSED PORTION
C OF FIELD RIGHT OF LETTER REPRESENTATIONS
C WITH SPACES. MAXUSD WILL BE LEFT POINTING
C LFTCOL+IWIDTH.
C INTRVL = THE NUMBER OF SPACE (BLANK) CHARACTERS TO BE
C INSERTED BETWEEN REPRESENTED CHARACTERS
C MOVE = -2, CHARACTERS WHICH ARE NARROWER THAN THE
C WIDEST CHARACTER ARE CENTERED WITHIN WIDTH
C OF WIDEST CHARACTER. NO WHITE SPACE ADJUST-
C MENT OF POSITIONS IS TO BE MADE. SPACES
C WILL ALSO BE WIDTH OF THE WIDEST CHARACTER.
C = -1, CHARACTERS WHICH ARE NARROWER THAN MOST
C COMMON WIDTH WILL BE CENTERED WITHIN MOST
C COMMON WIDTH. NO WHITE SPACE ADJUSTMENT OF
C POSITIONS IS TO BE MADE. SPACES WILL ALSO
C BE WIDTH WHICH IS MOST COMMON.
C = 0, NORMAL INTER-CHARACTER SPACING IS ACCEPT-
C ABLE WITHOUT WHITE SPACE ADJUSTMENT.
C = 1, ADJUST SPACE BETWEEN CHARACTERS TO EQUAL-
C IZE WHITE SPACES.
C ISPACE = -1, REPRESENT BOTH INITIAL AND FINAL SPACES
C IN LTTR ARRAY.
C = 0, REPRESENT INITIAL SPACES IN LTTR ARRAY.
C SUPPRESS FINAL SPACES IN LTTR ARRAY.
C = 1, SUPPRESS BOTH INITIAL AND FINAL SPACES IN
C LTTR ARRAY.
C LTTR = ARRAY CONTAINING LETTERS TO BE REPRESENTED,
C 1 LETTER PER WORD, AS READ BY MULTIPLE OF A1
C FORMAT. SINCE THE LETTERING PRODUCED BY
C THIS ROUTINE IS LARGE, TERMINAL SPACES ARE
C IGNORED UNLESS ISPACE=-1. NOTE THAT MAXUSD
C EQUALS LFTCOL IF LTTR CONTAINS ONLY SPACES,
C AND ISPACE IS GREATER THAN OR EQUAL TO ZERO,
C AND IFILL IS EQUAL TO ZERO.
C LTRBGN = SEQUENCE NUMBER WITHIN LTTR ARRAY OF FIRST
C LETTER TO BE REPRESENTED (THIS IS THE
C SUBSCRIPT OF THE LTTR ARRAY AT WHICH THE
C FIRST LETTER IS TO BE FOUND)
C LTREND = SEQUENCE NUMBER WITHIN LTTR ARRAY OF FINAL
C LETTER TO BE REPRESENTED (THIS IS THE
C SUBSCRIPT OF THE LTTR ARRAY AT WHICH THE
C FINAL LETTER IS TO BE FOUND)
C LFTCOL = SUBSCRIPT OF OUTPUT BUFFER ARRAY LOCATION TO
C LEFT OF 1ST LOCATION INTO WHICH THIS ROUTINE
C CAN PLACE REPRESENTATION OF CONTENTS OF LTTR
C ARRAY.
C IWIDTH = THE WIDTH OF THE FIELD INTO WHICH THE LETTER
C REPRESENTATIONS CAN BE PLACED. THE MAXIMUM
C VALUE WITH WHICH MAXUSD CAN THEN BE RETURNED
C IS LFTCOL+IWIDTH OR MAXBFR, WHICHEVER IS THE
C SMALLER.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY LOCATION
C INTO WHICH CAN BE PLACED REPRESENTATION
C OF CONTENTS OF LTTR ARRAY.
C
C THE FOLLOWING ARGUMENTS ARE USED FOR OUTPUT.
C
C IBUFFR = THE ARRAY INTO WHICH IS TO BE PLACED THE
C REPRESENTATION OF THE LETTERS IN LTTR.
C MAXUSD = RETURNED BY DATEXT CONTAINING THE NEW NUMBER
C OF LOCATIONS IN USE AFTER THE LETTERS IN
C LTTR HAVE BEEN REPRESENTED IN IBUFFR.
C MAXLIN = RETURNED CONTAINING THE MAXIMUM VALUE WHICH
C LINE CAN ATTAIN (IHIGH). THIS WILL DEPEND
C ON WHICH FONT HAS BEEN LOADED. MAXLIN IS
C RETURNED AS ZERO IF FONT HAS NOT BEEN LOADED
C LTRNXT = RETURNED CONTAINING THE SUBSCRIPT WITHIN THE
C LTTR ARRAY OF THE FIRST LETTER WHICH WAS NOT
C REPRESENTED. IF ALL LETTERS REQUESTED WERE
C REPRESENTED THEN LTRNXT WILL EQUAL LTREND+1.
C IF NOT ALL LETTERS COULD BE REPRESENTED DUE
C TO THE VALUE OF IWIDTH BEING TOO SMALL, THEN
C LTRNXT WILL POINT TO THE FIRST LETTER WHICH
C WOULD NOT FIT.
C
COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
1LETTER(96),LENGTH(96),IPACKD(672)
C
DIMENSION LTTR(LTREND),IBUFFR(MAXBFR),IDIGIT(10)
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA KOMAND,IVRTCL,IHRZNT,IEQUAL,IEND,IUPPER,
1LOWER,NARROW,IFIXED,IADJST,NWIDE,IBLANK/
21H$,1HV,1HH,1H=,1HE,1HU,1HL,1HN,1HF,1HA,1HW,1H /
C
LTRNXT=LTRBGN
MAXUSD=LFTCOL
IF(LOCK.NE.999)GO TO 61
MAXLIN=IHIGH
NOWLIN=LINE
IF(NOWLIN.LE.0)NOWLIN=IHIGH
IF(NOWLIN.GT.IHIGH)GO TO 62
IUSED=LFTCOL
IWHITE=MOVE
KWIDE=IWIDE
IF(IWHITE.LE.-2)KWIDE=JWIDE
JSPACE=INTRVL
IF(JSPACE.LT.0)JSPACE=0
LAST=0
KSPACE=0
NEED=0
MAXKNT=IUSED+IWIDTH
IF(MAXKNT.GT.MAXBFR)MAXKNT=MAXBFR
IFCASE=1
NOWVRT=1
NOWHRZ=1
KASATO=0
LWIDE=KWIDE
NOWTST=0
GO TO 3
C
C FIND OUT IF CAN REPRESENT THE LETTER
1 KSPACE=JSPACE
LAST=MATCH
LSTVRT=NOWVRT
LSTHRZ=NOWHRZ
LSTLNG=NOWLNG
2 LTRNXT=LTRNXT+1
3 IF(LTRNXT.GT.LTREND)GO TO 57
NOWLTR=LTTR(LTRNXT)
IF(NOWLTR.EQ.IBLANK)GO TO 7
IF(NOWLTR.EQ.KOMAND)GO TO 13
4 MATCH=0
KNTKAS=0
5 MATCH=MATCH+1
IF(MATCH.GT.KNTLTR)GO TO 6
IF(NOWLTR.NE.LETTER(MATCH))GO TO 5
KNTKAS=KNTKAS+1
IF(KNTKAS.GE.IFCASE)GO TO 26
LSTKAS=MATCH
GO TO 5
6 IF(KNTKAS.GT.0)GO TO 25
GO TO 8
C
C REPRESENT SPACE OR UNKNOWN CHARACTER
7 IF(KASATO.GE.0)GO TO 8
KASATO=-KASATO
IFCASE=KASATO-IFCASE
8 IF(ISPACE.LE.0)GO TO 9
IF(LAST.EQ.0)GO TO 2
9 KSPACE=KSPACE+LWIDE
IF(ISPACE.GE.0)GO TO 12
I=KSPACE
IF(IWHITE.LE.0)GO TO 10
IF(LAST.NE.0)I=I-JSPACE
10 IF((IUSED+I).GT.MAXKNT)GO TO 57
11 IF(I.LE.0)GO TO 12
I=I-1
KSPACE=KSPACE-1
IUSED=IUSED+1
IBUFFR(IUSED)=IBLANK
GO TO 11
12 IF(IWHITE.LE.0)KSPACE=KSPACE+JSPACE
GO TO 2
C
C DOLLAR CONTROL CHARACTER FOUND
13 LTRNXT=LTRNXT+1
IF(LTRNXT.GT.LTREND)GO TO 57
NOWLTR=LTTR(LTRNXT)
IF(NOWLTR.EQ.KOMAND)GO TO 4
IF(NOWLTR.EQ.IVRTCL)GO TO 16
IF(NOWLTR.EQ.IHRZNT)GO TO 17
IF(NOWLTR.EQ.IEQUAL)GO TO 15
IF(NOWLTR.EQ.IFIXED)GO TO 18
IF(NOWLTR.EQ.IADJST)GO TO 19
IF(NOWLTR.EQ.NARROW)GO TO 20
IF(NOWLTR.EQ.NWIDE)GO TO 21
IF(NOWLTR.EQ.IEND)GO TO 22
IF(NOWLTR.EQ.IUPPER)GO TO 23
IF(NOWLTR.EQ.LOWER)GO TO 24
DO 14 I=2,10
IF(NOWLTR.NE.IDIGIT(I))GO TO 14
IFCASE=I-1
KASATO=0
GO TO 2
14 CONTINUE
GO TO 2
15 NOWVRT=1
NOWHRZ=1
IFCASE=1
KASATO=0
LWIDE=KWIDE
IWHITE=MOVE
GO TO 2
16 NOWVRT=-1
GO TO 2
17 NOWHRZ=-1
GO TO 2
18 IF(IWHITE.GT.0)IWHITE=0
GO TO 2
19 IF(IWHITE.EQ.0)IWHITE=1
GO TO 2
20 LWIDE=KWIDE/2
GO TO 2
21 LWIDE=(3*KWIDE)/2
GO TO 2
22 IF(KASATO.LT.0)IFCASE=-KASATO-IFCASE
KASATO=0
GO TO 2
23 IF(KASATO.EQ.0)KASATO=(4*((IFCASE+1)/2))-1
IF(KASATO.GT.0)GO TO 2
KASATO=-KASATO
IFCASE=KASATO-IFCASE
GO TO 2
24 IF(KASATO.LT.0)GO TO 2
IF(KASATO.EQ.0)KASATO=(4*((IFCASE+1)/2))-1
IFCASE=KASATO-IFCASE
KASATO=-KASATO
GO TO 2
C
C PREPARE TO PLOT CHARACTER
25 MATCH=LSTKAS
26 IF(KASATO.LE.0)GO TO 27
IFCASE=KASATO-IFCASE
KASATO=-KASATO
27 NOWLNG=LENGTH(MATCH)
C
C DETERMINE OPTIMUM SPACING
C
C SKIP AROUND THIS CODE IF NORMAL
C INTER-CHARACTER SPACING IS ACCEPTABLE
C WITHOUT WHITE AREA ADJUSTMENT.
C THE CALCULATIONS ARE DESIGNED TO PRODUCE
C DISTANCES OF THE SORT
C
C 4
C 34
C 234
C 1234
C 01234
C X01234
C 01234
C 1234
C 234
C 34
C 4
C
C THE FIRST LOOP CATCHES THE MOST COMMON CASE OF
C 2 CHARACTERS TOUCHING ON THE SAME LINE. THE
C SECOND LONGER LOOP CATCHES THIS CASE AND ALL
C OTHERS AND COULD BE USED BY ITSELF.
IF(IWHITE.LT.0)GO TO 46
IF(JSPACE.EQ.0)GO TO 47
LSTTST=NOWTST
NOWTST=2**(NOWLNG-1)
IF(LAST.EQ.0)GO TO 47
IF(IWHITE.EQ.0)GO TO 47
MIN=JSPACE
ISTART=IHIGH*(LAST-1)
JSTART=IHIGH*(MATCH-1)
IF(LSTVRT.EQ.NOWVRT)GO TO 28
LSTVRT=-1
ISTART=ISTART+IHIGH+1
GO TO 29
28 LSTVRT=1
29 IINDEX=ISTART
JINDEX=JSTART
DO 33 I=1,IHIGH
IINDEX=IINDEX+LSTVRT
JINDEX=JINDEX+1
K=IPACKD(IINDEX)
IF(LSTHRZ.LT.0)GO TO 30
IF(K.EQ.(2*(K/2)))GO TO 33
GO TO 31
30 IF(K.LT.LSTTST)GO TO 33
31 K=IPACKD(JINDEX)
IF(NOWHRZ.GT.0)GO TO 32
IF(K.EQ.(2*(K/2)))GO TO 33
GO TO 47
32 IF(K.GE.NOWTST)GO TO 47
33 CONTINUE
DO 45 I=1,IHIGH
ISTART=ISTART+LSTVRT
K=IPACKD(ISTART)
IF(K.EQ.0)GO TO 45
IF(LSTHRZ.GT.0)GO TO 35
IDIST=LSTLNG
34 K=K/2
IDIST=IDIST-1
IF(K.NE.0)GO TO 34
GO TO 37
35 IDIST=0
36 L=K/2
IF((L+L).NE.K)GO TO 37
K=L
IDIST=IDIST+1
GO TO 36
37 N=JSTART
DO 44 J=1,IHIGH
N=N+1
K=IPACKD(N)
IF(K.EQ.0)GO TO 44
IF(NOWHRZ.GT.0)GO TO 39
JDIST=IDIST
38 L=K/2
IF((L+L).NE.K)GO TO 41
K=L
JDIST=JDIST+1
GO TO 38
39 JDIST=IDIST+NOWLNG
40 K=K/2
JDIST=JDIST-1
IF(K.NE.0)GO TO 40
41 IF(I.GT.J)GO TO 42
IF(I.EQ.J)GO TO 43
JDIST=JDIST+J-I-1
GO TO 43
42 JDIST=JDIST+I-J-1
43 IF(MIN.LE.JDIST)GO TO 44
IF(JDIST.LE.0)GO TO 47
MIN=JDIST
44 CONTINUE
45 CONTINUE
KSPACE=KSPACE-MIN
GO TO 47
C
C ADJUST CENTERING OF NARROW CHARACTERS IF NEEDED
46 IF(NOWLNG.GE.KWIDE)GO TO 47
IF((IUSED+KSPACE+KWIDE).GT.MAXKNT)GO TO 57
NEED=(KWIDE-NOWLNG)/2
KSPACE=KSPACE+NEED
NEED=KWIDE-NEED-NOWLNG
C
C CONSTRUCT LETTER
47 IF((IUSED+KSPACE+NOWLNG).GT.MAXKNT)GO TO 57
48 IF(KSPACE.LE.0)GO TO 49
KSPACE=KSPACE-1
IUSED=IUSED+1
IBUFFR(IUSED)=IBLANK
GO TO 48
49 I=(IHIGH*(MATCH-1))+NOWLIN
IF(NOWVRT.LT.0)I=(IHIGH*MATCH)-NOWLIN+1
I=IPACKD(I)
LIMIT=NOWLNG
IF(NOWHRZ.LT.0)GO TO 53
IUSED=IUSED+NOWLNG
J=IUSED
50 IF(LIMIT.LE.0)GO TO 56
LIMIT=LIMIT-1
K=I/2
IF((K+K).EQ.I)GO TO 51
IBUFFR(J)=NOWLTR
GO TO 52
51 IBUFFR(J)=IBLANK
52 J=J-1
I=K
GO TO 50
53 IF(LIMIT.LE.0)GO TO 56
LIMIT=LIMIT-1
IUSED=IUSED+1
K=I/2
IF((K+K).EQ.I)GO TO 54
IBUFFR(IUSED)=NOWLTR
GO TO 55
54 IBUFFR(IUSED)=IBLANK
55 I=K
GO TO 53
56 IF(NEED.LE.0)GO TO 1
NEED=NEED-1
IUSED=IUSED+1
IBUFFR(IUSED)=IBLANK
GO TO 56
C
C ALL LETTERS REPRESENTED, JUSTIFY AND FILL
57 NEED=0
IF(JSTIFY.GE.0)NEED=MAXKNT-IUSED
IF(JSTIFY.EQ.0)NEED=NEED/2
NEED=IUSED+NEED
INIKNT=MAXUSD
MAXUSD=NEED
IF(IFILL.GT.0)MAXUSD=MAXKNT
I=MAXUSD
58 IF(I.LE.NEED)GO TO 59
IBUFFR(I)=IBLANK
I=I-1
GO TO 58
59 IF(IUSED.LE.INIKNT)GO TO 60
IBUFFR(I)=IBUFFR(IUSED)
I=I-1
IUSED=IUSED-1
GO TO 59
60 IF(I.LE.INIKNT)GO TO 62
IBUFFR(I)=IBLANK
I=I-1
GO TO 60
C
C RETURN TO CALLING PROGRAM
61 MAXLIN=0
62 RETURN
C545790969953$
END
SUBROUTINE DATURN(INTRVL,MOVE ,ISPACE,LTTR ,LTRBGN,
1 LTREND,LFTCOL,MAXBFR,IBUFFR,MAXUSD,MAGNFY,INISTR,
2 MAXSTR,KIND ,ISTORE)
C RENBR(/CONSTRUCT LARGE LETTERING TURNED 90 DEGREES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO PRODUCE LARGE LETTERING EXTENDING ACROSS
C FANFOLDS. EACH CALL TO DATURN CONSTRUCTS A SINGLE
C LINE IN THE REPRESENTATION OF A SINGLE CHARACTER.
C DATURN SIGNALS TO THE CALLING PROGRAM WHEN THE FINAL
C CHARACTER HAS BEEN COMPLETELY REPRESENTATED. THIS
C ROUTINE MUST BE USED WITH A BLOCK DATA FONT CREATED
C BY THE PROGRAM DAFONT.
C
C INTRVL, MOVE, ISPACE, LTTR, LTRBGN, LTREND, LFTCOL,
C MAXBFR, MAGNFY, INISTR AND MAXSTR ARE USED ONLY FOR
C INPUT AND ARE RETURNED UNCHANGED. KIND AND ISTORE
C ARE USED BOTH FOR INPUT AND FOR RETURNING INFORMATION
C TO CALLING PROGRAM AND TO SUBSEQUENT CALLS TO THIS
C ROUTINE. IBUFFR AND MAXUSD ARE USED ONLY FOR OUTPUT.
C
C INTRVL = NUMBER OF BLANK LINES TO BE INSERTED BETWEEN
C REPRESENTED CHARACTERS
C MOVE = -2, CHARACTERS WHICH ARE NARROWER THAN THE
C WIDEST CHARACTER ARE CENTERED WITHIN WIDTH
C OF WIDEST CHARACTER. NO WHITE SPACE ADJUST-
C MENT OF POSITIONS IS TO BE MADE. SPACES
C WILL ALSO BE WIDTH OF WIDEST CHARACTER.
C = -1, CHARACTERS WHICH ARE NARROWER THAN MOST
C COMMON WIDTH WILL BE CENTERED WITHIN MOST
C COMMON WIDTH. NO WHITE SPACE ADJUSTMENT OF
C POSITIONS IS TO BE MADE. SPACES WILL ALSO
C BE WIDTH WHICH IS MOST COMMON.
C = 0, NORMAL INTER-CHARACTER SPACING IS ACCEPT-
C ABLE WITHOUT WHITE SPACE ADJUSTMENT.
C = 1, ADJUST SPACE BETWEEN CHARACTERS TO EQUAL-
C IZE WHITE SPACES.
C ISPACE = -1 OR 0, REPRESENT INITIAL SPACES IN LTTR
C ARRAY. SUPPRESS FINAL SPACES IN LTTR ARRAY.
C = 1, SUPPRESS BOTH INITIAL AND FINAL SPACES IN
C LTTR ARRAY.
C LTTR = ARRAY CONTAINING LETTERS TO BE REPRESENTED,
C 1 LETTER PER WORD, AS READ BY MULTIPLE OF A1
C FORMAT. SINCE LETTERING PRODUCED BY THIS
C ROUTINE IS LARGE, TERMINAL SPACES ARE
C IGNORED BUT BLANK LINES WILL BE GENERATED IF
C DATURN IS CALLED TO CONTINUE THE LETTERING
C REPRESENTATION ONCE ALL PRINTING CHARACTERS
C IN LTTR HAVE BEEN REPRESENTED.
C LTRBGN = SEQUENCE NUMBER WITHIN LTTR ARRAY OF FIRST
C LETTER TO BE REPRESENTED (THIS IS THE
C SUBSCRIPT OF LTTR ARRAY AT WHICH THE FIRST
C LETTER IS TO BE FOUND)
C LTREND = SEQUENCE NUMBER WITHIN LTTR ARRAY OF FINAL
C LETTER TO BE REPRESENTED (THIS IS THE
C SUBSCRIPT OF LTTR ARRAY AT WHICH THE FINAL
C LETTER IS TO BE FOUND)
C LFTCOL = SUBSCRIPT OF OUTPUT BUFFER ARRAY LOCATION TO
C LEFT OF 1ST LOCATION INTO WHICH THIS ROUTINE
C CAN PLACE REPRESENTATION OF CONTENTS OF LTTR
C ARRAY.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY LOCATION
C INTO WHICH CAN BE PLACED REPRESENTATION OF
C CONTENTS OF LTTR ARRAY.
C IBUFFR = ARRAY INTO WHICH IS TO BE PLACED THE
C REPRESENTATION OF LETTERS IN LTTR.
C MAXUSD = RETURNED BY DATURN CONTAINING NEW NUMBER OF
C LOCATIONS IN USE AFTER NEXT SECTION OF
C CHARACTER IN LTTR ARRAY HAS BEEN
C REPRESENTED.
C MAGNFY = INPUT CONTAINING MAGNIFICATION FACTOR WHICH
C IS APPLIED TO HEIGHT OF LETTERING. IF
C MAGNFY HAS VALUE 2, THEN EACH CHARACTER
C WHICH WOULD BE GENERATED TO FORM SHAPE IS
C REPEATED TWICE. SINCE FONTS ARE DESIGNED
C FOR 6 LINES PER INCH AND 10 CHARACTERS PER
C INCH FORMAT, LETTERING, WHEN TURNED 90
C DEGREES, WILL APPEAR EXTREMELY ELONGATED
C UNLESS HEIGHT IS MAGNIFIED. MAGNFY VALUE OF
C 3 WOULD PRODUCE APPROXIMATELY NORMALLY
C PROPORTIONED LETTERING. IF EACH LINE
C RETURNED BY DATURN IS PRINTED TWICE, THEN
C EXTREMELY LARGE LETTERING CAN BE PRODUCED BY
C SETTING MAGNFY TO 5. IT IS OF COURSE
C NECESSARY THAT IBUFFR ARRAY BE LARGE ENOUGH
C TO CONTAIN MAGNIFIED IMAGE OF LETTERING.
C INISTR = INPUT CONTAINING SUBSCRIPT OF FIRST LOCATION
C IN ISTORE ARRAY WHICH CAN BE USED TO
C TRANSFER INFORMATION ABOUT CURRENT STATE OF
C LETTERING PROCESS TO SUBSEQUENT CALL OF THIS
C ROUTINE WHICH IS TO CONTINUE REPRESENTATION
C OF SAME LINE OF TEXT.
C MAXSTR = INPUT CONTAINING SUBSCRIPT OF FINAL LOCATION
C IN ISTORE ARRAY WHICH CAN BE USED TO
C TRANSFER INFORMATION ABOUT CURRENT STATE OF
C LETTERING PROCESS TO SUBSEQUENT CALL OF THIS
C ROUTINE WHICH IS TO CONTINUE REPRESENTATION
C OF SAME LINE OF TEXT. AT LEAST 18 LOCATIONS
C IN ISTORE ARRAY ARE NEEDED FOR THIS PURPOSE,
C BUT IT IS REQUESTED THAT AT LEAST 24
C LOCATIONS BE RESERVED TO ALLOW FOR FUTURE
C ENHANCEMENT OF ROUTINE.
C KIND = MUST BE INPUT CONTAINING ZERO WHEN THIS
C ROUTINE IS FIRST CALLED TO REPRESENT
C PARTICULAR LINE OF TEXT. THEREAFTER, VALUE
C OF KIND RETURNED BY THIS ROUTINE SHOULD BE
C SUPPLIED TO SUBSEQUENT CALL WHICH IS
C CONTINUING REPRESENTATION OF SAME LINE OF
C TEXT. KIND IS RETURNED CONTAINING ONE OF
C FOLLOWING VALUES.
C = 1, RETURNED IF LINE OF TEXT HAS BEEN
C COMPLETELY REPRESENTED. IBUFFR(LFTCOL+1)
C THROUGH AND INCLUDING IBUFFR(MAXUSD) IS
C RETURNED CONTAINING SPACES. THIS PORTION OF
C IBUFFR ARRAY WILL AGAIN BE RETURNED
C CONTAINING SPACES IF DATURN IS SUBSEQUENTLY
C CALLED WITH VALUE OF KIND BEING UNCHANGED.
C = 2, RETURNED IF IBUFFR(LFTCOL+1) THROUGH AND
C INCLUDING IBUFFR(MAXUSD) IS RETURNED
C CONTAINING PORTION OF REPRESENTATION OF
C SINGLE CHARACTER.
C = 3, RETURNED IF AVAILABLE PORTION OF IBUFFR
C ARRAY WAS INSUFFICIENT TO CONTAIN
C REPRESENTATION OF LETTERING. MAXBFR-LFTCOL
C IS LESS THAN MAGNFY TIMES CHARACTER HEIGHT.
C = 4, RETURNED IF AVAILABLE PORTION OF ISTORE
C ARRAY WAS INSUFFICIENT TO CONTAIN
C DESCRIPTION OF CURRENT STATE OF LETTERING
C PROCESS FOR TRANSFER TO SUBSEQUENT CALL TO
C THIS ROUTINE WHICH IS TO CONTINUE LETTERING
C OF SAME LINE OF TEXT.
C = 5, RETURNED IF FONT WAS NOT LOADED.
C ISTORE = ARRAY USED TO TRANSFER DESCRIPTION OF
C CURRENT STATE OF LETTERING PROCESS TO
C SUBSEQUENT CALL OF THIS ROUTINE WHICH IS TO
C CONTINUE REPRESENTATION OF SAME LINE OF
C TEXT. THE ORIGINAL CONTENTS OF ISTORE ARRAY
C ARE IGNORED AND ARE DESTROYED.
C
COMMON/FASPG/KNTLTR,IHIGH,IWIDE,JWIDE,LOCK,
1LETTER(96),LENGTH(96),IPACKD(672)
C
DIMENSION LTTR(LTREND),IBUFFR(MAXBFR),ISTORE(MAXSTR),
1IDIGIT(10)
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA KOMAND,IVRTCL,IHRZNT,IEQUAL,IEND,IUPPER,
1LOWER,NARROW,IFIXED,IADJST,NWIDE,IBLANK/
21H$,1HV,1HH,1H=,1HE,1HU,1HL,1HN,1HF,1HA,1HW,1H /
C
MAXUSD=LFTCOL
IF(LOCK.NE.999)GO TO 56
IF((MAXSTR-INISTR).LT.17)GO TO 55
MULTPL=MAGNFY
IF(MULTPL.LE.0)MULTPL=1
IF((LFTCOL+(MULTPL*IHIGH)).GT.MAXBFR)GO TO 54
JSPACE=INTRVL
IF(JSPACE.LT.0)JSPACE=0
KWIDE=IWIDE
IF(MOVE.LE.-2)KWIDE=JWIDE
IF(KIND.GT.0)GO TO 44
KIND=2
LTRNXT=LTRBGN
IWHITE=MOVE
LAST=0
KSPACE=0
NEED=0
IFCASE=1
NOWVRT=1
NOWHRZ=1
KASATO=0
LWIDE=KWIDE
NOWTST=0
GO TO 3
C
C FIND OUT IF CAN REPRESENT THE LETTER
1 KSPACE=JSPACE+NEED
NEED=0
LAST=MATCH
LSTVRT=NOWVRT
LSTHRZ=NOWHRZ
LSTLNG=NOWLNG
2 LTRNXT=LTRNXT+1
3 IF(LTRNXT.GT.LTREND)GO TO 50
NOWLTR=LTTR(LTRNXT)
IF(NOWLTR.EQ.IBLANK)GO TO 7
IF(NOWLTR.EQ.KOMAND)GO TO 10
4 MATCH=0
KNTKAS=0
5 MATCH=MATCH+1
IF(MATCH.GT.KNTLTR)GO TO 6
IF(NOWLTR.NE.LETTER(MATCH))GO TO 5
KNTKAS=KNTKAS+1
IF(KNTKAS.GE.IFCASE)GO TO 23
LSTKAS=MATCH
GO TO 5
6 IF(KNTKAS.GT.0)GO TO 22
GO TO 8
C
C REPRESENT SPACE OR UNKNOWN CHARACTER
7 IF(KASATO.GE.0)GO TO 8
KASATO=-KASATO
IFCASE=KASATO-IFCASE
8 IF(ISPACE.LE.0)GO TO 9
IF(LAST.EQ.0)GO TO 2
9 KSPACE=KSPACE+LWIDE
IF(IWHITE.LE.0)KSPACE=KSPACE+JSPACE
GO TO 2
C
C DOLLAR CONTROL CHARACTER FOUND
10 LTRNXT=LTRNXT+1
IF(LTRNXT.GT.LTREND)GO TO 57
NOWLTR=LTTR(LTRNXT)
IF(NOWLTR.EQ.KOMAND)GO TO 4
IF(NOWLTR.EQ.IVRTCL)GO TO 13
IF(NOWLTR.EQ.IHRZNT)GO TO 14
IF(NOWLTR.EQ.IEQUAL)GO TO 12
IF(NOWLTR.EQ.IFIXED)GO TO 15
IF(NOWLTR.EQ.IADJST)GO TO 16
IF(NOWLTR.EQ.NARROW)GO TO 17
IF(NOWLTR.EQ.NWIDE)GO TO 18
IF(NOWLTR.EQ.IEND)GO TO 19
IF(NOWLTR.EQ.IUPPER)GO TO 20
IF(NOWLTR.EQ.LOWER)GO TO 21
DO 11 I=2,10
IF(NOWLTR.NE.IDIGIT(I))GO TO 11
IFCASE=I-1
KASATO=0
GO TO 2
11 CONTINUE
GO TO 2
12 NOWVRT=1
NOWHRZ=1
IFCASE=1
KASATO=0
LWIDE=KWIDE
IWHITE=MOVE
GO TO 2
13 NOWVRT=-1
GO TO 2
14 NOWHRZ=-1
GO TO 2
15 IF(IWHITE.GT.0)IWHITE=0
GO TO 2
16 IF(IWHITE.EQ.0)IWHITE=1
GO TO 2
17 LWIDE=KWIDE/2
GO TO 2
18 LWIDE=(3*KWIDE)/2
GO TO 2
19 IF(KASATO.LT.0)IFCASE=-KASATO-IFCASE
KASATO=0
GO TO 2
20 IF(KASATO.EQ.0)KASATO=(4*((IFCASE+1)/2))-1
IF(KASATO.GT.0)GO TO 2
KASATO=-KASATO
IFCASE=KASATO-IFCASE
GO TO 2
21 IF(KASATO.LT.0)GO TO 2
IF(KASATO.EQ.0)KASATO=(4*((IFCASE+1)/2))-1
IFCASE=KASATO-IFCASE
KASATO=-KASATO
GO TO 2
C
C PREPARE TO PLOT CHARACTER
22 MATCH=LSTKAS
23 IF(KASATO.LE.0)GO TO 24
IFCASE=KASATO-IFCASE
KASATO=-KASATO
24 NOWLNG=LENGTH(MATCH)
LSTTST=NOWTST
NOWTST=2**(NOWLNG-1)
C
C DETERMINE OPTIMUM SPACING
C
C SKIP AROUND THIS CODE IF NORMAL
C INTER-CHARACTER SPACING IS ACCEPTABLE
C WITHOUT WHITE AREA ADJUSTMENT.
C THE CALCULATIONS ARE DESIGNED TO PRODUCE
C DISTANCES OF THE SORT
C
C 4
C 34
C 234
C 1234
C 01234
C X01234
C 01234
C 1234
C 234
C 34
C 4
C
C THE FIRST LOOP CATCHES THE MOST COMMON CASE OF
C 2 CHARACTERS TOUCHING ON THE SAME LINE. THE
C SECOND LONGER LOOP CATCHES THIS CASE AND ALL
C OTHERS AND COULD BE USED BY ITSELF.
IF(IWHITE.LT.0)GO TO 43
IF(JSPACE.EQ.0)GO TO 45
IF(LAST.EQ.0)GO TO 45
IF(IWHITE.EQ.0)GO TO 45
MIN=JSPACE
ISTART=IHIGH*(LAST-1)
JSTART=IHIGH*(MATCH-1)
IF(LSTVRT.EQ.NOWVRT)GO TO 25
LSTVRT=-1
ISTART=ISTART+IHIGH+1
GO TO 26
25 LSTVRT=1
26 IINDEX=ISTART
JINDEX=JSTART
DO 30 I=1,IHIGH
IINDEX=IINDEX+LSTVRT
JINDEX=JINDEX+1
K=IPACKD(IINDEX)
IF(LSTHRZ.LT.0)GO TO 27
IF(K.EQ.(2*(K/2)))GO TO 30
GO TO 28
27 IF(K.LT.LSTTST)GO TO 30
28 K=IPACKD(JINDEX)
IF(NOWHRZ.GT.0)GO TO 29
IF(K.EQ.(2*(K/2)))GO TO 30
GO TO 45
29 IF(K.GE.NOWTST)GO TO 45
30 CONTINUE
DO 42 I=1,IHIGH
ISTART=ISTART+LSTVRT
K=IPACKD(ISTART)
IF(K.EQ.0)GO TO 42
IF(LSTHRZ.GT.0)GO TO 32
IDIST=LSTLNG
31 K=K/2
IDIST=IDIST-1
IF(K.NE.0)GO TO 31
GO TO 34
32 IDIST=0
33 L=K/2
IF((L+L).NE.K)GO TO 34
K=L
IDIST=IDIST+1
GO TO 33
34 N=JSTART
DO 41 J=1,IHIGH
N=N+1
K=IPACKD(N)
IF(K.EQ.0)GO TO 41
IF(NOWHRZ.GT.0)GO TO 36
JDIST=IDIST
35 L=K/2
IF((L+L).NE.K)GO TO 38
K=L
JDIST=JDIST+1
GO TO 35
36 JDIST=IDIST+NOWLNG
37 K=K/2
JDIST=JDIST-1
IF(K.NE.0)GO TO 37
38 IF(I.GT.J)GO TO 39
IF(I.EQ.J)GO TO 40
JDIST=JDIST+J-I-1
GO TO 40
39 JDIST=JDIST+I-J-1
40 IF(MIN.LE.JDIST)GO TO 41
IF(JDIST.LE.0)GO TO 45
MIN=JDIST
41 CONTINUE
42 CONTINUE
KSPACE=KSPACE-MIN
GO TO 45
C
C ADJUST CENTERING OF NARROW CHARACTERS IF NEEDED
43 IF(NOWLNG.GE.KWIDE)GO TO 45
NEED=(KWIDE-NOWLNG)/2
KSPACE=KSPACE+NEED
NEED=KWIDE-NEED-NOWLNG
GO TO 45
C
C SECOND OR SUBSEQUENT LINE
44 IF(KIND.NE.2)GO TO 50
IFCASE=ISTORE(INISTR)
IWHITE=ISTORE(INISTR+1)
KASATO=ISTORE(INISTR+2)
KSPACE=ISTORE(INISTR+3)
LAST =ISTORE(INISTR+4)
LSTHRZ=ISTORE(INISTR+5)
LSTKAS=ISTORE(INISTR+6)
LSTLNG=ISTORE(INISTR+7)
LSTTST=ISTORE(INISTR+8)
LSTVRT=ISTORE(INISTR+9)
LTRNXT=ISTORE(INISTR+10)
LWIDE =ISTORE(INISTR+11)
MATCH =ISTORE(INISTR+12)
NEED =ISTORE(INISTR+13)
NOWHRZ=ISTORE(INISTR+14)
NOWLNG=ISTORE(INISTR+15)
NOWTST=ISTORE(INISTR+16)
NOWVRT=ISTORE(INISTR+17)
IF(KSPACE.LE.0)GO TO 46
KSPACE=KSPACE-1
C
C CONSTRUCT LETTER
45 IF(KSPACE.GT.0)GO TO 51
LSTTST=1
IF(NOWHRZ.GT.0)LSTTST=NOWTST
LSTLNG=NOWLNG
46 IF(LSTLNG.LE.0)GO TO 1
INITAL=IHIGH*(MATCH-1)
IF(NOWVRT.GT.0)INITAL=INITAL+IHIGH+1
NOWLTR=LTTR(LTRNXT)
DO 48 I=1,IHIGH
INITAL=INITAL-NOWVRT
K=IPACKD(INITAL)/LSTTST
K=K-(2*(K/2))
DO 47 J=1,MULTPL
MAXUSD=MAXUSD+1
IBUFFR(MAXUSD)=IBLANK
IF(K.NE.0)IBUFFR(MAXUSD)=NOWLTR
47 CONTINUE
48 CONTINUE
LSTLNG=LSTLNG-1
IF(NOWHRZ.LT.0)GO TO 49
LSTTST=LSTTST/2
GO TO 53
49 LSTTST=2*LSTTST
GO TO 53
C
C CONSTRUCT LINE OF BLANKS
50 KIND=1
51 I=LFTCOL+(MULTPL*IHIGH)
52 MAXUSD=MAXUSD+1
IBUFFR(MAXUSD)=IBLANK
IF(MAXUSD.LT.I)GO TO 52
IF(KIND.NE.2)GO TO 57
C
C STORE VARIABLES NEEDED TO PRODUCE NEXT LINE
53 ISTORE(INISTR)=IFCASE
ISTORE(INISTR+1)=IWHITE
ISTORE(INISTR+2)=KASATO
ISTORE(INISTR+3)=KSPACE
ISTORE(INISTR+4)=LAST
ISTORE(INISTR+5)=LSTHRZ
ISTORE(INISTR+6)=LSTKAS
ISTORE(INISTR+7)=LSTLNG
ISTORE(INISTR+8)=LSTTST
ISTORE(INISTR+9)=LSTVRT
ISTORE(INISTR+10)=LTRNXT
ISTORE(INISTR+11)=LWIDE
ISTORE(INISTR+12)=MATCH
ISTORE(INISTR+13)=NEED
ISTORE(INISTR+14)=NOWHRZ
ISTORE(INISTR+15)=NOWLNG
ISTORE(INISTR+16)=NOWTST
ISTORE(INISTR+17)=NOWVRT
GO TO 57
C
C RETURN TO CALLING PROGRAM
54 KIND=3
GO TO 57
55 KIND=4
GO TO 57
56 KIND=5
57 RETURN
C736047020160$
END
SUBROUTINE DATALL(LSTLIN,MRKLIN,MAXWID,IFLTTR,LETTER,
1 IFCNCT,KONECT,XPOINT,MINSUB,MAXSUB, XLEFT,YVALUE,
2 XRIGHT, IGRID, IEDGE,MARGIN,MSHWID,MSHHIH,LTROFF,
3 LINPRT, IDISK,IRESET,LSTORE,XSTORE)
C RENBR(/TIME SERIES PLOT ROUTINE FOR PRINTER)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DATALL IS A FORTRAN SUBROUTINE WHICH CONSTRUCTS
C PRINTABLE PLOTS WITH A VERTICAL TIME (OR OTHER
C CONSTANT INCREMENT UNIT) AXIS EXTENDING ONTO AS MANY
C LINES AND PAGES AS ARE NECESSARY TO REPRESENT THE
C DATA. THE POINTS WHICH REPRESENT A PARTICULAR DATA
C ITEM IN CONSECUTIVE TIME PERIODS CAN BE CONNECTED
C WITH LINE SEGMENTS TO FORM A CURVE. A CURVE DOES NOT
C NEED TO EXTEND ACROSS ALL TIME PERIODS. THE SECTIONS
C OF A CURVE WHICH ARE OUTSIDE THE PLOT AREA ARE NOT
C REPRESENTED. A MAXIMUM OF 26 CURVES ARE
C DISTINGUISHABLE BY BEING PLOTTED WITH DIFFERENT
C CHARACTERS, BUT THERE IS NO LIMIT TO THE TOTAL NUMBER
C OF CURVES WHICH CAN BE INCLUDED IN THE PLOT OF A
C PARTICULAR TIME PERIOD OR IN THE PLOT OF ALL TIME
C PERIODS. OVERLAPPING SECTIONS OF CURVES REPRESENTED
C BY DIFFERENT CHARACTERS ARE INDICATED BY AMPERSANDS.
C
C DATALL IS CALLED ONCE FOR EACH TIME PERIOD TO APPEND
C A REPRESENTATION OF THE DATA FOR THAT TIME PERIOD TO
C THE PLOT OF THE DATA FOR THE PREVIOUS TIME PERIOD.
C ARRAYS INPUT TO DATALL SPECIFY THE HORIZONTAL OR
C NON-TIME COORDINATE OF EACH POINT FOR THE TIME
C PERIOD, THE LETTERS WITH WHICH THESE POINTS ARE TO BE
C PLOTTED, AND THE LETTERS WITH WHICH THE POINTS ARE TO
C BE CONNECTED WITH THE POINTS FOR THE PREVIOUS TIME
C PERIOD. THE SEGMENT OF THE PLOT REPRESENTING A
C SINGLE TIME PERIOD CAN CONTAIN SEVERAL POINTS AND/OR
C LINES. IT IS OPTIONAL WHETHER THE PLOT SEGMENT
C REPRESENTING A TIME PERIOD IS RULED WITH A GRID LINE
C AND IS IDENTIFIED BY A SCALE NUMBER.
C
C DATALL IS A RELATIVELY SHORT ROUTINE WHICH RELIES
C UPON DAPLAT FOR ITS PLOTTING CAPABILITIES. THE
C ROUTINES DARITE AND PLTCUT MUST ALSO BE LOADED AS
C THESE ARE CALLED BY DAPLAT. DAPLAT MUST NOT BE
C CALLED BY ANY OTHER PROGRAM UNTIL THE PLOTTING OF ALL
C TIME PERIODS HAS BEEN COMPLETED SINCE DAPLAT HAS
C INTERNAL STORAGE WHICH IS USED BY DATALL. IF THE
C USER'S PROGRAM CALLS DAPLAT TO DO OTHER PLOTTING
C AFTER THE PLOTTING OF THE DATA FOR ALL TIME PERIODS
C HAS BEEN COMPLETED, THEN THIS SUBSEQUENT CALL TO
C DAPLAT MUST USE NON-ZERO VALUES FOR THE ARGUMENTS
C MAXWID, MAXHIH, MSHWID AND MSHHIH SINCE THE DEFAULT
C VALUES OF THESE DAPLAT ARGUMENTS ARE CHANGED BY
C DATALL. THE CHARACTER SET USED FOR PLOTS PRODUCED BY
C DATALL CAN BE MANIPULATED AS DESCRIBED IN THE
C INSTRUCTION MANUAL FOR DAPLAT. THE MAXIMUM PLOT SIZE
C LIMITATION FOR DAPLAT APPLIES TO EACH TIME PERIOD,
C NOT TO THE ENTIRE PLOT OF ALL TIME PERIODS, AND SO
C SHOULD BE OF NO CONCERN TO THE USER.
C
C ARGUMENTS USED TO INPUT VALUES TO DATALL.
C
C LSTLIN = 0, CURRENT TIME PERIOD IS FINAL TIME PERIOD
C TO BE REPRESENTED IN PLOT. SCALE NUMBERS
C RANGING IN VALUE FROM THAT OF XLEFT THROUGH
C THAT OF XRIGHT ARE TO BE WRITTEN BELOW
C REPRESENTATION OF CURRENT TIME PERIOD, AND
C INTERNAL STORAGE IN DATALL AND DAPLAT IS
C THEN TO BE CLEARED.
C = GREATER THAN ZERO, CURRENT TIME PERIOD IS
C NOT FINAL TIME PERIOD IN PLOT. SUBSEQUENT
C CALLS TO DATALL WILL ADD ADDITIONAL SEGMENTS
C TO CURRENT PLOT. VALUE OF LSTLIN IS IGNORED
C OTHER THAN TO DETERIMINE WHETHER IT IS
C GREATER THAN ZERO. IF MAIN PROGRAM KNOWS
C TOTAL NUMBER OF TIME PERIODS, IT CAN COUNT
C LSTLIN DOWN TO ZERO. IF MAIN PROGRAM DOES
C NOT KNOW TOTAL NUMBER OF TIME PERIODS, IT IS
C SUFFICIENT TO SET LSTLIN TO 1 UNTIL FINAL
C TIME PERIOD.
C MRKLIN = 0, CURRENT VALUE OF ARGUMENT YVALUE IS TO BE
C PRINTED TO LEFT OF BOTTOM LINE IN
C REPRESENTATION OF CURRENT TIME PERIOD AND
C SCALE LINE CAN BE DRAWN THROUGH THIS BOTTOM
C LINE.
C = GREATER THAN ZERO, SCALE NUMBER IS NOT BE BE
C PLACED BESIDE BOTTOM LINE IN REPRESENTATION
C OF CURRENT TIME PERIOD AND THIS BOTTOM LINE
C CANNOT BE RULED AS GRID LINE. VALUE OF
C MRKLIN IS IGNORED OTHER THAN TO DETERIMINE
C WHETHER IT IS GREATER THAN ZERO. IF VALUE
C OF ARGUMENT YVALUE IS NOT TO BE PRINTED
C BESIDE EACH TIME PERIOD, THEN MRKLIN CAN BE
C COUNTED DOWN TO ZERO BY MAIN PROGRAM.
C MAXWID = WIDTH OF PLOT STATED AS NUMBER OF COLUMNS OF
C CHARACTERS FORMING PLOTTING AREA UPON WHICH
C DATA CAN BE PLOTTED. MAXWID IS NORMALLY 1
C PLUS MULTIPLE OF MSHWID. MAXIMUM EFFECTIVE
C VALUE OF MAXWID IS 131. IT SHOULD BE NOTED
C THAT PLOT HAS ADDITIONAL MARGIN OF 12
C CHARACTERS ALONG LEFT SIDE IN WHICH SCALE
C NUMBERS AND CARRIAGE CONTROL ARE PRINTED.
C = 0, USE THE LAST NONZERO VALUE SPECIFIED FOR
C MAXWID AS THE WIDTH OF THE PLOT, OR USE THE
C VALUE 101 IF A NONZERO VALUE OF MAXWID HAS
C NOT BEEN SPECIFIED.
C IFLTTR = SELECTS WHETHER CHARACTERS TO BE PLOTTED AT
C POINTS ARE TO BE IDENTIFIED BY LETTER ARRAY
C OR BY LOCATION OF THEIR COORDINATES IN
C XPOINT ARRAY.
C = 0, LETTER ARRAY IDENTIFIES CHARACTERS TO BE
C PLOTTED AT POINTS.
C = 1, POINTS ARE PLOTTED USING LETTERS HAVING
C SAME SEQUENCE NUMBER IN ALPHABET AS
C SUBSCRIPTS OF LOCATION IN XPOINT ARRAY
C CONTAINING COORDINATES. POINT HAVING ITS
C NON-TIME COORDINATE IN XPOINT(3) WOULD BE
C REPRESENTED BY LETTER C, 3RD LETTER IN
C ALPHABET. POINTS HAVING SUBSCRIPTS EQUAL TO
C OR GREATER THAN 27 ARE REPRESENTED BY
C ASTERISKS. CONTENTS OF LETTER ARRAY ARE
C IGNORED.
C LETTER = ARRAY IDENTIFYING CHARACTERS WITH WHICH TO
C REPRESENT POINTS HAVING AS THEIR HORIZONTAL
C OR NON-TIME COORDINATES VALUES IN XPOINT
C ARRAY WITH SAME SUBSCRIPTS. LETTER ARRAY
C VALUES OF -1 INDICATE THAT CORRESPONDING
C POINTS ARE NOT TO BE PLOTTED. LETTER ARRAY
C VALUES OF ZERO INDICATE THAT CORRESPONDING
C POINTS ARE TO BE PLOTTED WITH ASTERISKS.
C VALUES GREATER THAN ZERO ARE SEQUENCE
C NUMBERS WITHIN ALPHABET OF LETTERS TO BE
C USED TO REPRESENT POINTS. IF ASTERISK AND
C LETTER ARE TO OCCUPY SAME PRINTING CHARACTER
C POSITION ON PLOT, THEN LETTER APPEARS. IF
C DIFFERENT LETTERS ARE TO OCCUPY SAME
C PRINTING CHARACTER POSITION ON PLOT, THEN
C AMPERSAND APPEARS INSTEAD. IF IFLTTR IS
C NON-ZERO, THEN LETTER ARRAY IS NOT USED AND
C NEED NOT BE DIMENSIONED.
C IFCNCT = SELECTS WHETHER CHARACTERS TO BE PLOTTED
C ALONG LINE SEGMENTS CONNECTING POINTS ARE TO
C BE IDENTIFIED BY KONECT ARRAY OR ARE TO BE
C SAME AS THOSE USED TO REPRESENT POINTS.
C = -1, POINTS IN CURRENT TIME PERIOD ARE NOT TO
C BE CONNECTED TO POINTS OF PREVIOUS TIME
C PERIOD. CONTENTS OF KONECT ARRAY ARE
C IGNORED.
C = 0, KONECT ARRAY IDENTIFIES CHARACTERS TO BE
C PLOTTED ALONG LINE SEGMENTS.
C = 1, LINE SEGMENTS ARE TO BE FORMED OF SAME
C CHARACTERS AS ARE USED TO PLOT POINTS IN
C CURRENT PERIOD. CONTENTS OF KONECT ARRAY
C ARE IGNORED.
C KONECT = ARRAY IDENTIFYING CHARACTERS WITH WHICH TO
C CONNECT POINTS OF CURRENT TIME PERIOD WITH
C POINTS OF PREVIOUS TIME PERIOD WHICH HAD
C SAME SUBSCRIPTS. IF POINTS HAVING SAME
C SUBSCRIPT WERE NOT PLOTTED IN BOTH CURRENT
C TIME PERIOD AND PREVIOUS TIME PERIOD, THEN
C VALUE IN KONECT ARRAY IS IGNORED. LETTERS
C ARE SELECTED BY KONECT ARRAY IN SAME MANNER
C AS BY LETTER ARRAY, WITH EXCEPTION THAT
C KONECT ARRAY VALUE OF -1 CAUSES
C CORRESPONDING POINTS, IF ANY, TO NOT BE
C CONNECTED. IF IFCNCT IS NON-ZERO, THEN
C KONECT ARRAY IS NOT USED AND NEED NOT BE
C DIMENSIONED.
C XPOINT = ARRAY CONTAINING HORIZONTAL OR NON-TIME
C COORDINATES OF POINTS TO BE PLOTTED FOR
C CURRENT TIME PERIOD. COORDINATE SYSTEM USED
C FOR XPOINT ARRAY MUST BE SAME AS THAT USED
C FOR ARGUMENTS XLEFT AND XRIGHT WHICH SELECT
C COORDINATES TO BE PLACED AT LEFT EDGE AND AT
C RIGHT EDGE OF PLOT RESPECTIVELY. ONLY
C VALUES OF LETTER, KONECT AND XPOINT HAVING
C SUBSCRIPTS IN RANGE STARTING WITH MINSUB AND
C EXTENDING THROUGH MAXSUB ARE USED.
C MINSUB = LOWEST VALUED SUBSCRIPT TO BE PLOTTED USING
C INFORMATION IN LETTER, KONECT AND XPOINT
C ARRAYS. SUBSCRIPT RANGE CAN VARY FROM ONE
C TIME PERIOD TO NEXT.
C MAXSUB = HIGHEST VALUED SUBSCRIPT TO BE PLOTTED USING
C INFORMATION IN LETTER, KONECT AND XPOINT
C ARRAYS. SUBSCRIPT RANGE CAN VARY FROM ONE
C TIME PERIOD TO NEXT. IF NO DATA IS TO BE
C PLOTTED FOR CURRENT TIME PERIOD, THEN MAXSUB
C CAN BE LESS THAN MINSUB. IT SHOULD BE NOTED
C THAT EMPTY TIME PERIODS AT START OF TIME
C SERIES PLOT ARE DISCARDED, BUT THAT ONCE
C NON-EMPTY TIME PERIOD HAS BEEN ENCOUNTERED,
C THEN ALL REMAINING TIME PERIODS ARE PLOTTED
C WHETHER EMPTY OR NOT. ARRAYS XSTORE AND
C LSTORE MUST ALSO BE DIMENSIONED TO AT LEAST
C MAXIMUM VALUE OF MAXSUB.
C XLEFT = HORIZONTAL OR NON-TIME DATA COORDINATE TO BE
C PLACED AT LEFT EDGE OF PLOT. ONLY PORTION
C OF CURVES HAVING VALUES BETWEEN XLEFT AND
C XRIGHT WILL BE SHOWN ON PLOT. IF LINE
C SEGMENT CROSSES PLOT, PORTION OF LINE
C SEGMENT WHICH IS OUTSIDE PLOT AREA WILL NOT
C BE REPRESENTED. DATA COORDINATES CAN EITHER
C INCREASE OR DECREASE FROM LEFT TO RIGHT.
C YVALUE = NUMBER IDENTIFYING CURRENT TIME PERIOD.
C THIS VALUE MUST CHANGE FROM ONE CALL TO
C DATALL TO NEXT, BUT CAN EITHER INCREASE OR
C DECREASE. IF CURRENT VALUE OF MRKLIN IS
C ZERO, THEN VALUE OF YVALUE WILL BE PRINTED
C TO LEFT OF LOWEST LINE OF CURRENT PLOT
C SEGMENT.
C XRIGHT = HORIZONTAL OR NON-TIME DATA COORDINATE TO BE
C PLACED AT RIGHT EDGE OF PLOT.
C IGRID = 0, PLOT WILL SHOW INTERNAL GRID. THIS
C INTERNAL GRID WILL BE RULED VERTICALLY EVERY
C MSHWID CHARACTERS AND, IF MRKLIN IS EQUAL TO
C ZERO, HORIZONTALLY EVERY MHSHIH LINES.
C = 1, PLOT WILL SHOW INTERSECTIONS OF LINES OF
C INTERNAL GRID, BUT WILL NOT SHOW GRID LINES
C THEMSELVES. INTERNAL GRID WOULD, IF SHOWN,
C HAVE VERTICAL LINES EVERY MSHWID CHARACTERS
C ACROSS WIDTH OF PLOT AND WOULD, IF MRKLIN IS
C EQUAL TO ZERO, HAVE HORIZONTAL LINES ON
C BOTTOM LINE OF EACH PLOT SEGMENT. EACH PLOT
C SEGMENT CONSISTS OF MSHHIH LINES, SO
C HORIZONTAL LINES CAN BE RULED EVERY MSHHIH
C LINES IF MRKLIN IS ALWAYS ZERO.
C = 2, PLOT WILL NOT SHOW INTERNAL GRID.
C IEDGE = 0, IF MRKLIN IS EQUAL TO ZERO THEN PLACE
C SCALE NUMBER TO LEFT OF LINE DISPLAYING
C CURRENT POINTS. IF LSTLIN IS EQUAL TO ZERO,
C THEN PLACE SCALE NUMBERS BELOW PLOT.
C = 1, IF MRKLIN IS EQUAL TO ZERO THEN PLACE
C SCALE NUMBER TO LEFT OF LINE DISPLAYING
C CURRENT POINTS. DO NOT PLACE SCALE NUMBERS
C BELOW PLOT.
C = 2, IF LSTLIN IS EQUAL TO ZERO, THEN PLACE
C SCALE NUMBERS BELOW PLOT. DO NOT PLACE
C SCALE NUMBERS TO LEFT OF PLOT.
C = 3, DO NOT PLACE SCALE NUMBERS EITHER TO LEFT
C OF OR BELOW PLOT.
C MARGIN = MINIMUM NUMBER OF CHARACTERS BETWEEN
C CARRIAGE CONTROL CHARACTER IN COLUMN 1 OF
C OUTPUT AND LEFT EDGE OF PLOT. THIS MARGIN
C INCLUDES LEFT SCALE NUMBERS AND SPACES TO
C THEIR LEFT.
C MSHWID = WIDTH OF GRID DIVISIONS STATED AS NUMBER OF
C COLUMNS OF CHARACTERS. MSHWID=10 WOULD GIVE
C VERTICAL GRID LINES EVERY 10 CHARACTERS
C ACROSS WIDTH OF PLOT AREA.
C = 0, USE THE LAST NONZERO VALUE SPECIFIED FOR
C MSHWID AS THE GRID DIVISION WIDTH, OR USE
C THE VALUE 10 IF A NONZERO VALUE OF MSHWID
C HAS NOT BEEN SPECIFIED BY A PREVIOUS CALL TO
C THIS ROUTINE.
C MSHHIH = NUMBER OF LINES OF PRINTING TO BE INCLUDED
C IN PLOT SEGMENT REPRESENTING CURRENT TIME
C PERIOD. IF POINTS FOR SUCCESSIVE TIME
C PERIODS ARE BEING CONNECTED BY LINE
C SEGMENTS, THEN THESE LINE SEGMENTS WILL
C EXTEND ACROSS THESE LINES OF PRINTING.
C POINTS THEMSELVES ARE REPRESENTED IN BOTTOM
C LINE OF PLOT SEGMENT.
C = 0, ASSUME THAT MSHHIH=1 IS MEANT. EACH TIME
C PERIOD WILL BE REPRESENTED BY SINGLE LINE OF
C TIME SERIES PLOT.
C LTROFF = DISTANCE STATED AS NUMBER OF CHARACTERS
C BETWEEN LEFT EDGE OF PLOT AND LEFT SCALE
C LINE. IF LTROFF=0, THEN LEFT SCALE LINE
C WILL BE AT LEFT EDGE OF PLOT.
C LINPRT = -1, THE PLOT IS NOT TO INCLUDE ANY CARRIAGE
C CONTROL CHARACTER AT LEFT END OF EACH LINE.
C = 0, PLOT WILL BE VIEWED BY USER ON TERMINAL,
C EITHER TYPED DIRECTLY WITH IDISK BEING GIVEN
C TERMINAL UNIT NUMBER, OR TYPED BY USER AFTER
C THIS ROUTINE HAS WRITTEN PLOT INTO FILE ON
C UNIT NUMBER OF WHICH IS CONTAINED IN IDISK.
C BLANK OR SPACE WILL BE USED AS CARRIAGE
C CONTROL CHARACTER TO GIVE SINGLE SPACING.
C = 1, PLOT WILL BE PRINTED ON LINE PRINTER BY
C USER AFTER PROGRAM HAS WRITTEN PLOT INTO
C FILE. ASTERISK WILL BE USED AS CARRIAGE
C CONTROL CHARACTER TO GIVE SINGLE SPACING
C WITH SUPPRESSION OF SKIPPING EXTRA LINES AT
C PAGE BOUNDARIES. ON PDP-10, ASTERISK AS
C CARRIAGE CONTROL CHARACTER GIVES
C OVERPRINTING ON TERMINAL AS OPPOSED TO
C SINGLE SPACING.
C IDISK = UNIT NUMBER OF DEVICE ONTO WHICH PLOTS ARE
C TO BE WRITTEN. THIS ROUTINE WILL ONLY
C GENERATE PLOT. IT IS RESPONSIBLITY OF
C CALLING PROGRAM TO OPEN OUTPUT FILE AND TO
C WRITE CAPTIONS, FORM FEEDS AND/OR SEPARATING
C LINES.
C
C FOLLOWING ARGUMENT IS USED BOTH FOR INPUT AND OUTPUT.
C
C IRESET = 1 (OR GREATER), NEITHER DATALL NOR DAPLAT
C HAVE BEEN CALLED BEFORE. INTERNAL STORAGES
C IN BOTH DATALL AND DAPLAT ARE TO BE
C INITIALIZED. IRESET CAN BE GIVEN VALUE
C GREATER THAN ONE TO SELECTIVELY INITIALIZE
C STORAGE IN DAPLAT. CONSULT DAPLAT
C DOCUMENTATION FOR THESE VALUES. IRESET IS
C RETURNED SET TO -1.
C = 0, DAPLAT HAS ALREADY BEEN CALLED, BUT
C DATALL HAS NOT BEEN CALLED. IRESET IS
C RETURNED SET TO -1.
C = -1, DATALL HAS BEEN PREVIOUSLY CALLED.
C
C ARGUMENTS USED ONLY FOR INTERMEDIATE DATA STORAGE
C
C VALUES INITIALLY IN ARRAY ARGUMENTS XSTORE AND LSTORE
C ARE IGNORED AND ARE DESTROYED. THESE ARRAYS ARE USED
C BY DATALL TO STORE COORDINATES OF POINTS AND TO STORE
C LETTERS USED TO PLOT THESE POINTS SO THAT SUBSEQUENT
C CALL TO DATALL CAN EXTEND LINE SEGMENTS FROM POINTS
C OF TIME PERIOD PREVIOUS TO IT. CALLING PROGRAM MUST
C NOT MODIFY CONTENTS OF THESE ARRAYS WHILE TIME SERIES
C PLOT IS BEING GENERATED. BOTH ARRAYS MUST BE
C DIMENSIONED TO AT LEAST MAXIMUM VALUE OF MAXSUB.
C THIS ARRAY SPACE CAN BE USED FOR OTHER PURPOSES BY
C CALLING PROGRAM AFTER DATALL HAS BEEN CALLED WITH
C LSTLIN EQUAL TO ZERO.
C
C LSTORE = USED TO STORE CONTENTS OF LETTER ARRAY.
C DIMENSION OF LSTORE ARRAY MUST BE MAXIMUM
C VALUE OF MAXSUB ENCOUNTERED WHILE IFLTTR IS
C ZERO. IF IFLTTR IS ALWAYS 1, THEN LSTORE IS
C NEVER USED AND NEED NOT BE DIMENSIONED.
C XSTORE = USED TO STORE CONTENTS OF XPOINT ARRAY.
C
C THE ITEMS IN COMMON/FASPF/ STORE INFORMATION ABOUT
C PREVIOUS CALL TO DAHIST AND MUST BE PRESERVED BETWEEN
C CALLS
COMMON/FASPF/KRESET,LINKNT,JRESET,MRKSTR,IFLSTR,
1 MINSTR,MAXSTR,YVASTR,LTRERR,LINERR
C
DIMENSION LETTER(MAXSUB),KONECT(MAXSUB),
1XPOINT(MAXSUB),LSTORE(MAXSUB),XSTORE(MAXSUB)
DIMENSION XDOUBL(2),YDOUBL(2)
C
C DETERMINE WHETHER THIS IS FIRST PANEL OF PLOT
IF(IRESET.GE.0)GO TO 23
IF(KRESET.NE.999)GO TO 23
C
C GET CURRENT HEIGHT
JHIGH=2
IF(MSHHIH.GT.0)JHIGH=MSHHIH+1
C
C MASK OUT THE HUNDREDS DIGIT OF IGRID
JGRID=IGRID
IF(JGRID.LT.0)JGRID=0
KGRID=JGRID/100
JGRID=JGRID-(100*KGRID)
C
C MASK OUT THE HUNDREDS DIGIT OF IEDGE
JEDGE=IEDGE
IF(JEDGE.LT.0)JEDGE=0
KEDGE=JEDGE/100
JEDGE=JEDGE-(100*KEDGE)+300
C
C DETERMINE PLACEMENT OF EDGE LINES
IF(LINKNT.GT.1)GO TO 1
IF(KEDGE.EQ.0)JEDGE=JEDGE-100
IF(KEDGE.EQ.2)JEDGE=JEDGE-100
1 IF(LSTLIN.GT.0)GO TO 2
IF(KEDGE.LE.1)JEDGE=JEDGE-200
C
C DETERMINE PLACEMENT OF GRID LINES
2 LINOFF=0
IHIGH=JHIGH
IF(MRKSTR.EQ.0)GO TO 3
IF(MRKLIN.EQ.0)GO TO 5
IHIGH=IHIGH+1
GO TO 6
3 IF(MRKLIN.EQ.0)GO TO 4
LINOFF=-1
IF(LINKNT.GT.1)GO TO 6
IF(KGRID.EQ.1)GO TO 6
IF(KGRID.GE.3)GO TO 6
JGRID=JGRID+200
GO TO 7
4 IHIGH=IHIGH-1
IF(LINKNT.GT.1)GO TO 5
IF(KGRID.GT.3)GO TO 6
JGRID=IGRID
GO TO 7
5 IF(LSTLIN.GT.0)GO TO 6
IF(KGRID.GE.2)GO TO 6
JGRID=JGRID+100
GO TO 7
6 JGRID=JGRID+300
C
C IF SECOND LINE, ADD FIRST SEQUENCE OF POINTS TO PLOT.
C SOME OF THESE MIGHT NOT BE INCLUDED IN SECOND LINE.
7 IF(LSTLIN.GT.0)JGRID=-JGRID-1
IPLOT=-1
IF(LINKNT.GT.1)GO TO 12
IPASS=1
YDOUBL(1)=YVASTR
INDEX=MINSTR
KOUNT=1
8 IF(INDEX.GT.MAXSTR)GO TO 12
IF(IFLSTR.NE.0)GO TO 9
IF(LSTORE(INDEX).LT.0)GO TO 11
ILTTR=LSTORE(INDEX)
GO TO 10
9 ILTTR=INDEX
10 XDOUBL(1)=XSTORE(INDEX)
GO TO 19
11 INDEX=INDEX+1
GO TO 8
C
C ADD CURRENT LINE SEGMENT TO THE PLOT
12 YDOUBL(1)=YVALUE
YDOUBL(2)=YVASTR
IPASS=0
INDEX=MINSUB
13 IF(INDEX.GT.MAXSUB)GO TO 21
IF(IFLTTR.NE.0)GO TO 14
IF(LETTER(INDEX).LT.0)GO TO 20
ILTTR=LETTER(INDEX)
GO TO 15
14 ILTTR=INDEX
15 XDOUBL(1)=XPOINT(INDEX)
KOUNT=1
IF(IFCNCT.LT.0)GO TO 19
IF(IFCNCT.GT.0)GO TO 16
IF(KONECT(INDEX).LT.0)GO TO 19
16 IF(INDEX.LT.MINSTR)GO TO 19
IF(INDEX.GT.MAXSTR)GO TO 19
IF(IFLSTR.NE.0)GO TO 17
IF(LSTORE(INDEX).LT.0)GO TO 19
IKNCT=KONECT(INDEX)
GO TO 18
17 IKNCT=ILTTR
18 KOUNT=2
XDOUBL(2)=XSTORE(INDEX)
19 CALL DAPLAT(IPLOT,MAXWID,JHIGH,ILTTR,IKNCT,
1XDOUBL,YDOUBL,1,KOUNT,XLEFT,YVALUE,XRIGHT,
2YVASTR,JGRID,JEDGE,MARGIN,MSHWID,IHIGH,LTROFF,
3LINOFF,LINPRT,IDISK,JRESET,LTRERR,LINERR)
IF(IPLOT.EQ.0)GO TO 22
IF(IPASS.NE.0)GO TO 11
XSTORE(INDEX)=XPOINT(INDEX)
20 IF(IFLTTR.EQ.0)LSTORE(INDEX)=LETTER(INDEX)
INDEX=INDEX+1
GO TO 13
C
C CONSTRUCT THE PLOT
21 KOUNT=0
IPLOT=0
GO TO 19
C
C STORE INFORMATION NEEDED BY SUBSEQUENT CALL TO DATALL
22 IF(LSTLIN.GT.0)GO TO 25
KRESET=0
GO TO 26
23 KRESET=999
LINKNT=0
LTRERR=0
LINERR=0
JRESET=0
IF(IRESET.GT.0)JRESET=IRESET
IRESET=-1
INDEX=MINSUB
24 IF(INDEX.GT.MAXSUB)GO TO 25
XSTORE(INDEX)=XPOINT(INDEX)
IF(IFLTTR.EQ.0)LSTORE(INDEX)=LETTER(INDEX)
INDEX=INDEX+1
GO TO 24
25 LINKNT=LINKNT+1
MINSTR=MINSUB
MAXSTR=MAXSUB
YVASTR=YVALUE
MRKSTR=MRKLIN
IFLSTR=IFLTTR
26 RETURN
C922140683991
END
SUBROUTINE DAPLAT( IPLOT,MAXWID,MAXHIH,LETTER,KONECT,
1 XPOINT,YPOINT,MINSUB,MAXSUB, XLEFT,YLOWER,XRIGHT,
2 YUPPER, IGRID, IEDGE,MARGIN,MSHWID,MSHHIH,LTROFF,
3 LINOFF,LINPRT, IDISK,IRESET,LTRERR,LINERR)
C RENBR(/POINT, CURVE AND PIN MAP PLOTTER FOR PRINTER)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO CONSTRUCT A PLOT OF USER SELECTED
C PROPORTIONS AND WHICH CAN CONTAIN ONE OR MORE CURVES,
C EACH CURVE BEING REPRESENTED BY ITS OWN ALPHABETIC
C LETTER. POINTS ON A CURVE CAN OPTIONALLY BE
C CONNECTED EITHER BY ASTERISKS OR BY SOME ALPHABETIC
C LETTER WHICH NEED NOT BE THE SAME AS THAT USED TO
C REPRESENT THE POINTS THEMSELVES. IF PLOTTING POINTS
C NOT CONNECTED BY LINES, A PIN MAP CAN BE SIMULATED BY
C USING THE CLOSEST EMPTY LOCATION IF THE LOCATION
C REPRESENTING THE POINT IS ALREADY USED. THE PLOT CAN
C BE RULED WITH GRID LINES EVERY 10 CHARACTERS ACROSS
C ITS WIDTH AND EVERY 5 LINES ACROSS ITS HEIGHT. THESE
C GRID DIVISION WIDTHS AND HEIGHTS ARE ALSO UNDER THE
C USER'S CONTROL. NUMBERS PRINTED ALONGSIDE THE PLOT
C ARE REPRESENTED WITH 5 SIGNIFICANT DIGITS, BUT WITH
C SUPPRESSION OF RIGHTHAND ZEROES TO THE RIGHT OF THE
C DECIMAL POINT. IF THE NUMBER CANNOT BE PRINTED IN
C FLOATING POINT FORM, THEN THE NUMBER IS REPRESENTED
C IN SCIENTIFIC NOTATION INSTEAD.
C
C IF TWO OR MORE DIFFERENT ALPHABETIC LETTERS ARE TO
C APPEAR IN THE SAME LOCATION IN THE PRINTED PLOT, AN
C AMPERSAND WILL APPEAR INSTEAD. HOWEVER, IF THE
C POINTS AND THE LINES OPTIONALLY CONNECTING THESE
C POINTS ARE TO APPEAR AS DIFFERENT LETTERS, THEN THESE
C LETTERS, WHERE USED FOR PREVIOUS CURVES OR WHERE USED
C ELSEWHERE ON THE CURRENT CURVE, ARE NOT CHANGED TO
C AMPERSANDS BY COINCIDENCE WITH THE PRESENT CURVE.
C
C THIS ROUTINE CALLS THE WINDOWING ROUTINE PLTCUT AND
C THE GENERALIZED FLOATING POINT OUTPUT ROUTINE DARITE.
C
C THE FOLLOWING INPUT ARGUMENTS ARE USED BY EACH CALL
C TO DAPLAT WHETHER OR NOT A PLOT IS GENERATED
C
C IPLOT = -1, ADD THE POINTS AND/OR LINES REPRESENTED
C BY THE COORDINATES IN THE XPOINT AND YPOINT
C ARRAYS TO THE PLOT STORAGE, THEN RETURN TO
C THE CALLING PROGRAM WITHOUT GENERATING THE
C PLOT. ADDITIONAL DAPLAT CALLS WILL BE
C EXECUTED BEFORE THE PLOT IS TO BE PRINTED.
C = 0, ADD THE POINTS AND/OR LINES IN THE XPOINT
C AND YPOINT ARRAYS TO THE PLOT STORAGE, THEN
C GENERATE THE PLOT AND CLEAR THE PLOT
C STORAGE. ADDITIONAL CALLS TO DAPLAT, IF
C ANY, WILL STORE UPON A BLANK PLOT SURFACE.
C = 1, ADD THE POINTS AND/OR LINES IN THE XPOINT
C AND YPOINT ARRAYS TO THE PLOT STORAGE, THEN
C GENERATE THE PLOT BUT DO NOT CLEAR THE PLOT
C STORAGE. THE CURRENTLY STORED PLOT WILL BE
C ADDED TO BY ADDITIONAL CALLS TO DAPLAT.
C MAXWID = WIDTH OF THE PLOT STATED AS THE NUMBER OF
C COLUMNS OF CHARACTERS FORMING THE PLOTTING
C AREA UPON WHICH DATA CAN BE PLOTTED. MAXWID
C IS NORMALLY 1 PLUS A MULTIPLE OF MSHWID.
C MAXIMUM RECOMMENDED VALUE OF MAXWID IS 101.
C NOTE THAT THE PLOT HAS AN ADDITIONAL MARGIN
C OF 12 CHARACTERS ALONG THE LEFT SIDE IN
C WHICH SCALE NUMBERS ARE PRINTED. AN ADDI-
C TIONAL 4 CHARACTERS CAN APPEAR TO THE RIGHT
C OF THE PLOT IN THE LOWER-RIGHT SCALE NUMBER.
C THE LARGEST ACCEPTED VALUE OF MAXWID IS 131,
C WHICH CAN LEAD TO LOWER SCALE 147 CHARACTERS
C WIDE WHICH IS TOO LARGE TO OUTPUT ON MOST
C LINE-PRINTERS. IF THE VALUE OF IGRID TURNS
C OFF BOTH LEFT SCALE NUMBERS AND LOWER SCALE
C NUMBERS, THEN ONLY 1 CHARACTER (EITHER AN
C ASTERISK OR A SPACE) WILL APPEAR TO THE LEFT
C OF THE PLOT SO MAXIMUM WIDTH OF A PRINTED
C WOULD THEN BE MERELY 1 PLUS MAXWID.
C = 0, USE THE LAST NONZERO VALUE SPECIFIED FOR
C MAXWID AS THE WIDTH OF THE PLOT, OR USE THE
C VALUE 101 IF A NONZERO VALUE OF MAXWID HAS
C NOT BEEN SPECIFIED.
C MAXHIH = HEIGHT OF THE PLOT STATED AS THE NUMBER OF
C LINES FORMING THE PLOTTING AREA UPON WHICH
C DATA CAN BE PLOTTED. NORMALLY MAXHIH WOULD
C BE 1 PLUS A MULTIPLE OF MSHHIH. THE PLOT
C HAS AN ADDITIONAL LOWER MARGIN OF 2 LINES
C (OR 3 LINES IF THE SCALE NUMBERS ARE IN
C SCIENTIFIC NOTATION).
C = 0, USE THE LAST NONZERO VALUE SPECIFIED FOR
C MAXHIH AS THE HEIGHT OF THE PLOT, OR USE THE
C VALUE 51 IF A NONZERO VALUE OF MAXHIH HAS
C NOT BEEN SPECIFIED.
C LETTER = 0, PLOT THE POINTS HAVING COORDINATES IN THE
C XPOINT AND YPOINT ARRAYS WITH ASTERISKS. IF
C ONE (OR MORE) OF THESE POINTS IS TO APPEAR
C AT THE SAME LOCATION ON THE PLOT AS SOME
C OTHER POINT OR PORTION OF A LINE SEGMENT,
C THE OTHER POINT OR PORTION OF A LINE SEGMENT
C IS SHOWN INSTEAD OF THE CURRENT POINT.
C = 1 THRU 26, IDENTIFIES ALPHABETIC LETTER USED
C TO PLOT THE POINTS HAVING COORDINATES IN THE
C XPOINT AND YPOINT ARRAYS. LETTER IS THE
C SERIAL NUMBER OF THE LETTER IN THE ALPHABET.
C LETTER=3 WOULD CAUSE THE PLOTTED POINTS TO
C BE REPRESENTED WITH C'S.
C = 27, PLOT THE POINTS HAVING COORDINATES IN
C THE XPOINT AND YPOINT ARRAYS WITH ASTERISKS.
C IF ONE (OR MORE) OF THESE POINTS IS TO
C APPEAR AT THE SAME LOCATION ON THE PLOT AS
C SOME OTHER POINT OR PORTION OF A LINE
C SEGMENT, THEN THE ASTERISK APPEARS INSTEAD
C OF THE OTHER POINT OR PORTION OF A LINE
C SEGMENT.
C KONECT = .LT.-1, SIMULATE PIN MAP. STORE POINTS
C HAVING COORDINATES IN XPOINT AND YPOINT
C ARRAYS FOR PLOTTING (EITHER BY CURRENT CALL
C TO DAPLAT IF IPLOT.GE.0 OR BY SUBSEQUENT
C CALL TO DAPLAT IF IPLOT.NE.0). IF LETTER IS
C GREATER THAN ZERO, AND IF LOCATION
C REPRESENTING POINT ALREADY CONTAINS PRINTING
C CHARACTER OTHER THAN NONDOMINANT ASTERISK,
C THEN SEARCH FOR CLOSEST LOCATION WHICH IS
C EMPTY OR WHICH CONTAINS NONDOMINANT
C ASTERISK. IF LETTER IS ZERO AND LOCATION
C REPRESENTING POINT ALREADY CONTAINS PRINTING
C CHARACTER, THEN SEARCH FOR CLOSEST LOCATION
C WHICH CONTAINS SPACE. IF, AFTER HAVING
C SEARCHED NUMBER OF CONCENTRIC BOXES EQUAL TO
C ABSOLUTE VALUE OF KONECT, NO AVAILABLE
C LOCATION HAS YET BEEN FOUND, THEN ABANDON
C ATTEMPT. NOTE THAT IF SEVERAL POINTS
C COINCIDE, IT IS MUCH MORE EFFICIENT TO HAVE
C THEM ADJACENT IN XPOINT AND YPOINT ARRAYS IF
C PIN MAP OPTION IS USED. FOLLOWING ARE
C EXAMPLES OF SIZES OF PIN GROUPS POSSIBLE FOR
C VARIOUS VALUES OF KONECT.
C
C KONECT=-2 KONECT=-3 KONECT=-4 KONECT=-5
C
C 555555555
C 4444444 544444445
C 33333 4333334 543333345
C 222 32223 4322234 543222345
C 212 32123 4321234 543212345
C 222 32223 4322234 543222345
C 33333 4333334 543333345
C 4444444 544444445
C 555555555
C
C = -1, STORE POINTS HAVING COORDINATES IN
C XPOINT AND YPOINT ARRAYS FOR PLOTTING
C (EITHER BY CURRENT CALL TO DAPLAT IF
C IPLOT.GE.0 OR BY SUBSEQUENT CALL TO DAPLAT
C IF IPLOT.NE.0). IF LETTER IS IN RANGE 1
C THROUGH 26, AND IF THERE ALREADY IS
C CHARACTER OTHER THAN SPACE OR ASTERISK AT
C LOCATION REPRESENTING POINT, THEN PLACE
C AMPERSAND AT LOCATION INSTEAD.
C = 0, STORE POINTS HAVING COORDINATES IN XPOINT
C AND YPOINT ARRAYS FOR PLOTTING, AND CONNECT
C THESE WITH LINES FORMED FROM NONDOMINANT
C ASTERISKS. IF SOME OTHER CHARACTER ALREADY
C IS IN PLOT, OR IS LATER ADDED TO PLOT AT
C LOCATIONS ALONG LINE, THEN THIS OTHER
C CHARACTER IS SEEN INSTEAD OF ASTERISK.
C = 1 THRU 26, CONNECT POINTS WITH LINES FORMED
C OF ALPHABETIC LETTER WHICH HAS KONECT AS ITS
C SERIAL NUMBER IN ALPHABET.
C = 27, SAME AS KONECT=0, EXCEPT THAT ASTERISKS
C ARE DOMINANT OVER ALL OTHER CHARACTERS. IF
C SOME OTHER CHARACTER ALREADY IS IN PLOT, OR
C IS LATER ADDED TO PLOT AT LOCATIONS ALONG
C LINE, THEN IT IS ASTERISK WHICH IS SEEN.
C XPOINT = THE ARRAY OF X (HORIZONTAL) COORDINATES OF
C THE DATA POINTS TO BE PLOTTED.
C YPOINT = THE ARRAY OF Y (VERTICAL) COORDINATES OF THE
C DATA POINTS TO BE PLOTTED.
C MINSUB = THE SUBSCRIPT IN XPOINT AND YPOINT ARRAYS OF
C THE COORDINATES OF THE FIRST POINT TO BE
C PLOTTED
C MAXSUB = THE SUBSCRIPT IN XPOINT AND YPOINT ARRAYS OF
C THE COORDINATES OF THE FINAL POINT TO BE
C PLOTTED
C XLEFT = THE HORIZONTAL DATA COORDINATE TO BE PLACED
C AT THE LEFT EDGE OF THE PLOT. ONLY THE
C PORTION OF THE CURVE INSIDE THE WINDOW
C DEFINED BY XLEFT, YLOWER, XRIGHT AND YUPPER
C WILL BE SHOWN IN THE PLOT. IF A LINE
C SEGMENT CROSSES THE WINDOW, THE PORTION OF
C THE LINE SEGMENT WHICH IS OUTSIDE THE WINDOW
C WILL NOT BE REPRESENTED. THE DATA
C COORDINATES CAN EITHER INCREASE OR DECREASE
C FROM LEFT TO RIGHT OR FROM BOTTOM TO TOP.
C IF MULTIPLE CURVES ARE BEING SUPERIMPOSED ON
C A SINGLE PLOT, THE CURVES NEED NOT ALL HAVE
C THE SAME DATA COORDINATE LIMITS, HOWEVER,
C THE SCALE NUMBERS ON THE PLOT ITSELF WILL
C CORRESPOND TO THE DATA COORDINATE LIMITS OF
C THE FINAL CURVE.
C YLOWER = THE VERTICAL DATA COORDINATE TO BE PLACED AT
C THE LOWER EDGE OF THE PLOT
C XRIGHT = THE HORIZONTAL DATA COORDINATE TO BE PLACED
C AT THE RIGHT EDGE OF THE PLOT
C YUPPER = THE VERTICAL DATA COORDINATE TO BE PLACED AT
C THE UPPER EDGE OF THE PLOT
C
C THE FOLLOWING ARGUMENTS ARE IGNORED UNLESS A PLOT IS
C GENERATED BY THE CURRENT CALL TO DAPLAT
C
C IGRID = 0, IF THE PLOT IS GENERATED, THE PLOT WILL
C SHOW AN INTERNAL GRID. THIS INTERNAL GRID
C WILL BE RULED VERTICALLY EVERY MSHWID
C CHARACTERS ACROSS THE WIDTH OF THE PLOT AND
C WILL BE RULED HORIZONTALLY EVERY MSHHIH
C LINES ACROSS THE HEIGHT OF THE PLOT.
C = 1, IF THE PLOT IS GENERATED, THE PLOT WILL
C SHOW THE INTERSECTIONS OF THE LINES OF AN
C INTERNAL GRID, BUT WILL NOT SHOW GRID LINES
C THEMSELVES. THE INTERNAL GRID WOULD, IF
C SHOWN, HAVE VERTICAL LINES EVERY MSHWID
C CHARACTERS ACROSS THE WIDTH OF THE PLOT AND
C HORIZONTAL LINES EVERY MSHHIH LINES ACROSS
C THE HEIGHT OF THE PLOT.
C = 2, IF THE PLOT IS GENERATED, THE PLOT WILL
C NOT SHOW AN INTERNAL GRID. HOWEVER,
C REGARDLESS OF THE VALUE OF IGRID, SCALE
C NUMBERS WILL BE PRINTED ALONG THE SCALES AT
C THE INTERVALS INDICATED BY MSHWID AND
C MSHHIH.
C IEDGE = PLACE NUMBERS BOTH TO LEFT OF AND BELOW PLOT
C TO IDENTIFY COORDINATE RANGES.
C = 1, PLACE NUMBERS TO LEFT OF PLOT, BUT DO NOT
C PLACE NUMBERS BELOW PLOT.
C = 2, PLACE NUMBERS BELOW PLOT, BUT NOT TO LEFT
C OF PLOT. UNLESS PREVENTED BY VALUE OF
C MARGIN, THE DISTANCE BETWEEN CARRIAGE
C CONTROL CHARACTER IN COLUMN 1 AND LEFT EDGE
C OF PLOT WILL BE JUST LARGE ENOUGH TO ALLOW
C SCALE NUMBER IMMEDIATELY BELOW LEFT EDGE OF
C PLOT.
C = 3, DO NOT PLACE NUMBERS EITHER TO LEFT OF OR
C BELOW PLOT. UNLESS PREVENTED BY VALUE OF
C MARGIN, NO CHARACTERS WILL APPEAR BETWEEN
C CARRIAGE CONTROL CHARACTER IN COLUMN 1 AND
C LEFT EDGE OF PLOT.
C MARGIN = MINIMUM NUMBER OF CHARACTERS BETWEEN
C CARRIAGE CONTROL CHARACTER IN COLUMN 1 OF
C OUTPUT AND LEFT EDGE OF PLOT. THIS MARGIN
C INCLUDES LEFT SCALE NUMBERS AND SPACES TO
C THEIR LEFT.
C MSHWID = WIDTH OF THE GRID DIVISIONS STATED AS THE
C NUMBER OF COLUMNS OF CHARACTERS. MSHWID=10
C WOULD GIVE THE VERTICAL GRID LINES EVERY 10
C CHARACTERS ACROSS THE WIDTH OF THE PLOT
C AREA.
C = 0, USE THE LAST NONZERO VALUE SPECIFIED FOR
C MSHWID AS THE GRID DIVISION WIDTH, OR USE
C THE VALUE 10 IF A NONZERO VALUE OF MSHWID
C HAS NOT BEEN SPECIFIED BY A PREVIOUS CALL TO
C THIS ROUTINE.
C MSHHIH = HEIGHT OF THE GRID DIVISIONS STATED AS THE
C NUMBER OF LINES. MSHHIH=5 WOULD GIVE THE
C HORIZONTAL GRID LINES EVERY 5 LINES ACROSS
C THE HEIGHT OF THE PLOT AREA.
C = 0, USE THE LAST NONZERO VALUE SPECIFIED FOR
C MSHHIH AS THE GRID DIVISION HEIGHT, OR USE
C THE VALUE 5 IF A NONZERO VALUE OF MSHHIH
C HAS NOT BEEN SPECIFIED BY A PREVIOUS CALL TO
C THIS ROUTINE.
C LTROFF = DISTANCE STATED AS NUMBER OF CHARACTERS
C BETWEEN LEFT EDGE OF PLOT AND LEFT SCALE
C LINE. IF LTROFF=0, THEN LEFT SCALE LINE
C WILL BE AT LEFT EDGE OF PLOT.
C LINOFF = DISTANCE STATED AS NUMBER OF LINES BETWEEN
C LOWER EDGE OF THE PLOT AND THE LOWER SCALE
C LINE. IF LINOFF=0, THEN LOWER SCALE LINE
C WILL BE AT LOWER EDGE OF PLOT.
C LINPRT = -1, THE PLOT IS NOT TO INCLUDE ANY CARRIAGE
C CONTROL CHARACTER AT LEFT END OF EACH LINE.
C = 0, THE PLOT WILL BE VIEWED BY THE USER ON A
C TERMINAL, EITHER TYPED DIRECTLY WITH IDISK
C BEING GIVEN THE TERMINAL UNIT NUMBER, OR
C TYPED BY THE USER AFTER THIS ROUTINE HAS
C WRITTEN THE PLOT INTO A FILE ON THE UNIT
C THE NUMBER OF WHICH IS CONTAINED IN IDISK.
C A BLANK OR SPACE WILL BE USED AS CARRIAGE
C CONTROL CHARACTER TO GIVE SINGLE SPACING.
C = 1, THE PLOT WILL BE PRINTED ON THE LINE
C PRINTER BY THE USER AFTER THE PROGRAM HAS
C WRITTEN THE PLOT INTO A FILE. AN ASTERISK
C WILL BE USED AS CARRIAGE CONTROL CHARACTER
C TO GIVE SINGLE SPACING WITH SUPPRESSION OF
C SKIPPING EXTRA LINES AT THE PAGE BOUNDARIES.
C ON THE PDP-10, AN ASTERISK AS THE CARRIAGE
C CONTROL CHARACTER GIVES OVERPRINTING ON THE
C TERMINAL AS OPPOSED TO SINGLE SPACING.
C IDISK = THE UNIT NUMBER OF THE DEVICE ONTO WHICH THE
C PLOTS ARE TO BE WRITTEN. THIS ROUTINE WILL
C ONLY GENERATE THE PLOT. IT IS THE
C RESPONSIBLITY OF THE CALLING PROGRAM TO OPEN
C THE OUTPUT FILE AND TO WRITE THE CAPTIONS,
C THE FORM FEEDS AND/OR THE SEPARATING LINES.
C IDISK SHOULD ALWAYS BE GIVEN A LEGAL UNIT
C NUMBER SINCE DAPLAT WILL GENERATE THE STORED
C PLOT, IF ANY, USING THE NEW VALUE OF IDISK
C BEFORE STORING THE NEW CURVE IF THE NEW PLOT
C SIZE DIFFERS FROM THAT USED TO STORE THE
C PREVIOUS CURVES EVEN IF IPLOT=-1.
C
C FOLLOWING ARGUMENT IS USED BOTH FOR INPUT AND OUTPUT.
C
C IRESET = SHOULD BE INPUT GREATER THAN ZERO THE FIRST
C TIME THIS ROUTINE IS CALLED. IRESET IS THEN
C RETURNED SET TO ZERO AND SHOULD RETAIN THIS
C VALUE FOR ALL SUBSEQUENT CALLS TO THIS
C ROUTINE.
C = 0, CHARACTER TEMPLATE AND PLOT STORAGE HAVE
C ALREADY BEEN INITIALIZED.
C = 1, INITIALIZE CHARACTER TEMPLATE AND ALL OF
C PLOT STORAGE.
C = 2, INITIALIZE CHARACTER TEMPLATE AND ALL
C EXCEPT FIRST 3 LOCATIONS IN PLOT STORAGE.
C = 3, INITIALIZE CHARACTER TEMPLATE.
C = 4, INITIALIZE ALL OF PLOT STORAGE.
C = 5, INITIALIZE ALL OF PLOT STORAGE EXCEPT
C FIRST 3 LOCATIONS.
C
C THE FOLLOWING ARGUMENTS ARE RETURNED AS OUTPUT
C
C LTRERR = RETURNED CONTAINING NUMBER OF POINTS WHICH
C WERE OUTSIDE THE CURRENT PLOT.
C LINERR = RETURNED CONTAINING NUMBER OF LINE SEGMENTS
C WHICH WERE COMPLETELY OUTSIDE THE CURRENT
C PLOT. ALSO CONTAINS NUMBER OF POINTS IN A
C PIN MAP WHICH WERE NOT SHOWN DUE TO THERE
C BEING NO EMPTY LOCATION WITHIN THE ALLOWED
C DISTANCE.
C
C
C AS AN EXAMPLE OF THE USAGE OF THIS ROUTINE, THE
C FOLLOWING PROGRAM WAS USED TO GENERATE THE PLOT SHOWN
C BELOW THE PROGRAM (ALONG WITH 2 NOT SHOWN).
C
C DIMENSION XPOINT(10),YPOINT(10)
C DATA XPOINT/0. ,1. ,2. ,3. ,4. ,0. ,1. ,2. ,3. ,4. /
C DATA YPOINT/1. ,1.5,2.5,2.5,1.5,2. ,2.3,3. ,2.5,2. /
C DATA IRESET,IDISK/1,1/
C DO 2 JGRID=1,3
C IGRID=JGRID-1
C WRITE(IDISK,1)IGRID
C 1 FORMAT(7H IGRID=,I2)
CC
CC IPLOT=-1 MAXWID=41 MAXHIH=16 LETTER=1 KONECT=2
CC MINSUB=1 MAXSUB=5 XLEFT=0 YLOWER=.5 XRIGHT=4
CC YUPPER=3.5 IEDGE=0 MARGIN=0 MSHWID=0 MSHHIH=0LTROFF=0
CC LINOFF=0 LINPRT=1
C CALL DAPLAT(-1,41,16,1,2,
C 1XPOINT,YPOINT,1,5,0.,.5,4.,
C 23.5,IGRID,0,0,0,0,0,
C 30,1,IDISK,IRESET,LTRERR,LINERR)
CCHANGING IPLOT=0, LETTER=3, KONECT=4, MINSUB=6, MAXSUB=10
C CALL DAPLAT(0,41,16,3,4,
C 1XPOINT,YPOINT,6,10,0.,.5,4.,
C 23.5,IGRID,0,0,0,0,0,
C 30,1,IDISK,IRESET,LTRERR,LINERR)
C 2 WRITE(IDISK,3)
C 3 FORMAT(//)
C STOP
C END
C
C IGRID= 0
C* 3.5 -+---------+---------+---------+---------+
C* ! ! ! ! !
C* ! ! ! ! !
C* ! ! DCDD ! !
C* ! ! DDD ! DDDDD ! !
C* 2.5 -+---------+-DDDD----ABBBBBBB&&&D--------+
C* ! DDCD BB! !B&DD !
C* ! DDDDD ! BB ! ! BBDDDD !
C* CDD ! BB ! ! BB DC
C* ! ! BB ! ! BB !
C* 1.5 -+--------BAB--------+---------+--------BA
C* ! BBB ! ! ! !
C* ! BBBB ! ! ! !
C* AB ! ! ! !
C* ! ! ! ! !
C* 0.5 -+---------+---------+---------+---------+
C* ! ! ! ! !
C* 0 1 2 3 4
C
C AS SUPPLIED, DAPLAT CONTAINS A STORAGE ARRAY LARGE
C ENOUGH TO HOLD 5151 CHARACTERS, THIS BEING THE NUMBER
C OF CHARACTERS NEEDED FOR A PLOT OF THE DEFAULT SIZE
C OF 51 LINES EACH OF 101 CHARACTERS. THIS PLOT
C STORAGE IS CONTAINED IN THE LABELED BLOCK
C COMMON/FASPA/ WHICH MUST CONTAIN AT LEAST 20 WORDS
C MORE THAN THE WORDS NEEDED TO STORE MAXWID*MAXHIH
C CHARACTERS, SIX CHARACTERS BEING HELD IN THE RIGHT 30
C BITS OF EACH WORD. THE 20 ADDITIONAL WORDS
C STORE INFORMATION ABOUT PLOT SIZE AND SCALING. THE
C LABELED COMMON BLOCK CAN BE MADE LARGER THAN THE 879
C LOCATIONS (CALCULATED AS 20+(((51*101)+5)/6) WORDS)
C PROVIDED IN THIS ROUTINE IF THE LABELED COMMON BLOCK
C IS LOADED FIRST BY THE USER'S PROGRAM, IF THE USER'S
C PROGRAM DEFINES THE 1ST 3 LOCATIONS IN THIS ARRAY
C BEFORE THIS ROUTINE IS FIRST CALLED, AND IF IRESET
C HAS EITHER OF THE VALUES 2 OR 5 WHEN THIS ROUTINE IS
C FIRST CALLED. THE 3 LOCATIONS WHICH MUST BE DEFINED
C IN COMMON/FASPA/ ARE DEFINED AS FOLLOW
C KDMNSN = 15 LESS THAN THE NUMBER OF LOCATIONS IN
C COMMON/FASPA/
C LRGBYT = NUMBER OF DIFFERENT CHARACTER CODES,
C INCLUDING 0 FOR BLANK AND 1 FOR AMPERSAND,
C THAT MUST BE STORED IN EACH BYTE OF THE
C ARRAY WHICH IS DIMENSIONED AT KDMNSN. THE
C MASTER ARRAY MUST BE DIMENSIONED TO AT LEAST
C LRGBYT-1.
C MAXBYT = NUMBER OF BYTES WHICH CAN BE STORED IN A
C SINGLE COMPUTER WORD. (LRGBYT**MAXBYT)-1
C MUST BE SMALL ENOUGH TO BE REPRESENTED AS A
C POSITIVE NUMBER. THE ISHIFT ARRAY MUST BE
C DIMENSIONED TO AT LEAST MAXBYT.
C IF A PLOT IS REQUESTED WHICH IS LARGER THAN CAN BE
C HELD IN THE LABELED COMMON BLOCK, THEN THE EFFECTIVE
C VALUE OF MAXHIH IS REDUCED SO THAT THE PLOT WILL FIT.
C
C THE LABELED COMMON BLOCK COMMON/FASPA/ CONTAINS ALL
C THE INFORMATION NECESSARY TO GENERATE THE PLOT, WITH
C THE EXCEPTION OF THE ARGUMENTS LINPRT AND IDISK AND
C THE CHARACTER LIST. IF A LATER EXECUTION OF THE
C PROGRAM IS TO ADD TO THE CURRENT PLOT, THE CONTENTS
C OF THE LABELED COMMON BLOCK CAN BE WRITTEN INTO A
C BINARY FILE, THEN BE RESTORED WHEN NEEDED PROVIDED
C THAT DAPLAT HAS BEEN CALLED WITH A NONZERO VALUE OF
C IPLOT WHICH WOULD NOT CLEAR THE PLOT STORAGE.
C
C COMMON USED TO STORE THE INTERMEDIATE PLOTS
COMMON/FASPA/ KDMNSN,LRGBYT,MAXBYT,JRESET,KONTNT,
1 KWIDE, KHIGH,XFIRST,YFIRST,XFINAL,YFINAL, MGRID,
2 MEDGE, MMRGN, IWIDE, IHIGH, IOVER, IUP, IERR,
3 JERR,ISTORE(859)
C
C COMMON CONTAINING CHARACTERS CORRESPONDING TO VALUES
COMMON/FASPB/LTRALL(35)
C
C COMMON CONTAINING DOMINANCE RULES
COMMON/FASPC/MASTER(29)
C
C COMMON CONTAINING DESCRIPTION OF BYTE PACKING
COMMON/FASPD/ISHIFT(22)
C
C COMMON CONTAINING PRINT BUFFER FOR 1 LINE
COMMON/FASPE/LTRBUF(146)
C
C NONARRAY ITEMS IN COMMON/FASPB/
EQUIVALENCE (JSPACE,LTRALL(1)),(ISTAR ,LTRALL(2)),
1 (IVRTCL,LTRALL(3)),(IHRZNT,LTRALL(4)),
2 (ICORNR,LTRALL(5)),(ISPACE,LTRALL(6))
C
C ARRAYS NOT IN COMMON
DIMENSION XPOINT(MAXSUB),YPOINT(MAXSUB),LTRBGN(35)
C
C NUMBER OF CHARACTERS IN COMMON/FASPE/ BUFFER
DATA MAXBFR/146/
C
C INITIAL DEFINITION OF CHARACTERS IN COMMON/FASPB/
DATA LTRBGN/1H ,1H*,1H!,1H-,1H+,1H ,1H&,1H*,1HA,1HB,
1 1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,1HK,1HL,
2 1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,1HU,1HV,
3 1HW,1HX,1HY,1HZ,1H*/
DATA KSPACE/1H /
C
C ****************************************
C * *
C * FIND SIZE AND CHECK IF HAS CHANGED *
C * *
C ****************************************
C
IF(IRESET.NE.0)GO TO 1
IF(JRESET.EQ.999)GO TO 9
1 IF(IRESET.NE.3)GO TO 2
IF(JRESET.EQ.999)GO TO 5
2 JRESET=999
IF(IRESET.EQ.2)GO TO 3
IF(IRESET.EQ.5)GO TO 3
C
C INITIALIZE FIRST 3 LOCATIONS IN PLOT STORAGE
KDMNSN=859
LRGBYT=30
MAXBYT=6
C
C INITIALIZE REST OF PLOT STORAGE
3 IWIDE=10
IHIGH=5
KWIDE=MAXBFR-15
IF(KWIDE.GT.101)KWIDE=101
KHIGH=51
KONTNT=0
DO 4 I=1,KDMNSN
4 ISTORE(I)=0
IF(IRESET.GE.4)GO TO 8
C
C INITIALIZE CHARACTERS AND DOMINANCE RULES
5 DO 6 I=1,35
6 LTRALL(I)=LTRBGN(I)
MASTER(1)=1
MASTER(2)=-1
DO 7 I=3,28
7 MASTER(I)=0
MASTER(29)=2
8 IRESET=0
C
C ESTABLISH THE SHIFTING ARRAY. MUST DO EACH TIME
C SINCE NOT HELD IN COMMON AND USER MIGHT HAVE
C REESTABLISHED COMMON WITHOUT EVER CALLING DAPLAT.
9 I=1
J=1
10 ISHIFT(I)=J
IF(I.GE.MAXBYT)GO TO 11
I=I+1
J=J*LRGBYT
GO TO 10
C
C FIND SIZE REQUESTED FOR THIS PLOT
11 JWIDE=KWIDE
IF(MAXWID.GT.0)JWIDE=MAXWID
IF(JWIDE.GT.(MAXBFR-15))JWIDE=MAXBFR-15
JHIGH=KHIGH
IF(MAXHIH.GT.0)JHIGH=MAXHIH
I=(MAXBYT*KDMNSN)/JWIDE
IF(JHIGH.GT.I)JHIGH=I
C
C PLOT CURRENT STORAGE IF NEW SIZE REQUESTED
IPASS=0
IF(KONTNT.EQ.0)GO TO 12
IF(JWIDE.NE.KWIDE)GO TO 40
IF(JHIGH.NE.KHIGH)GO TO 40
GO TO 13
C
C ZERO OUT ERROR COUNTS IF PLOT IS EMPTY
12 IERR=0
JERR=0
C
C GET THE VARIOUS ITEMS NEEDED TO STORE CURVE
13 XFIRST=XLEFT
XFINAL=XRIGHT
YFIRST=YLOWER
YFINAL=YUPPER
IF(MSHWID.GT.0)IWIDE=MSHWID
IF(MSHHIH.GT.0)IHIGH=MSHHIH
IOVER=LTROFF
IUP=LINOFF
MGRID=IGRID
MEDGE=IEDGE
MMRGN=MARGIN
KWIDE=JWIDE
KHIGH=JHIGH
WIDE=KWIDE-1
HIGH=KHIGH-1
LTRPNT=0
IF(LETTER.GE.0)LTRPNT=LETTER+2
IF(LTRPNT.GE.LRGBYT)LTRPNT=LRGBYT-1
LTRLIN=0
IF(LTRPNT.GT.0)LTRLIN=KONECT+2
IF(LTRLIN.GE.LRGBYT)LTRLIN=LRGBYT-1
C
C **********************
C * *
C * STORE THE POINTS *
C * *
C **********************
C
IF(MAXSUB.LT.MINSUB)GO TO 39
XSCALE=WIDE/(XFINAL-XFIRST)
YSCALE=HIGH/(YFINAL-YFIRST)
INSERT=LTRPNT
KONTNT=1
KRD=MINSUB
MAXSQR=1
14 IX=1.5+(XSCALE*(XPOINT(KRD)-XFIRST))
IY=1.5+HIGH-(YSCALE*(YPOINT(KRD)-YFIRST))
IF(IPASS.GT.0)GO TO 16
C
C IF PLOT POINTS, CHECK IF POINT IS INSIDE WINDOW
IF(IX.LE.0)GO TO 15
IF(IX.GT.KWIDE)GO TO 15
IF(IY.LE.0)GO TO 15
IF(IY.GT.KHIGH)GO TO 15
IF(KONECT.GE.-1)GO TO 29
GO TO 22
15 IERR=IERR+1
GO TO 38
C
C IF PLOT LINES, FIND PART OF LINE INSIDE WINDOW
16 NEWX=IX
NEWY=IY
CALL PLTCUT(IPLCUT,IX,IY,LASTX,LASTY,1,1,KWIDE,KHIGH)
IF(IPLCUT.NE.0)GO TO 17
JERR=JERR+1
GO TO 37
C
C PROVIDE FOR INTEGER ROUNDING ALONG LINE SEGMENT
17 IF(IY.GE.LASTY)GO TO 18
I=IX
IX=LASTX
LASTX=I
I=IY
IY=LASTY
LASTY=I
18 MOVEX=IX-LASTX
MOVEY=IY-LASTY
LAGX=0
LAGY=0
IUSED=0
IF(MOVEX.NE.0)GO TO 19
IF(MOVEY.NE.0)GO TO 20
MULT=0
GO TO 29
19 MULT=MOVEX
IF(MULT.LT.0)MULT=-MULT
IF(MOVEY.EQ.0)GO TO 21
LAGX=MOVEY/2
LAGY=MULT/2
IF(MULT.GT.MOVEY)GO TO 21
20 MULT=MOVEY
C
C GET NEXT POINT ALONG THE LINE SEGMENT
21 IF(MOVEX.LT.0)IX=LASTX-((LAGX-(IUSED*MOVEX))/MULT)
IF(MOVEX.GT.0)IX=LASTX+((LAGX+(IUSED*MOVEX))/MULT)
IY=LASTY+(((IUSED*MOVEY)+LAGY)/MULT)
GO TO 29
C
C TEST IF ALREADY WITHIN PROPER SET OF TERRACES
22 IF(MAXSQR.GT.0)GO TO 23
IF(KEEPX.NE.IX)GO TO 23
IF(KEEPY.NE.IY)GO TO 23
IF(MAXSQR.EQ.0)GO TO 28
IX=LASTX
IY=LASTY
GO TO 25
C
C PREPARE FOR TERRACE ZERO
23 MAXSQR=KONECT
KEEPX=IX
KEEPY=IY
MOVEX=0
MOVEY=1
MAXPIN=0
KNTPIN=1
IF(LETTER.NE.-1)GO TO 24
C
C IF ERASING, MOVE DIRECTLY TO OUTER TERRACE
MOVEY=0
MOVEX=1
MAXSQR=-1
MAXPIN=-KONECT-KONECT-2
KNTPIN=MAXPIN+1
IX=IX+KONECT+1
IY=IY-KONECT-1
C
C TEST IF POINT ON TERRACE IS AVAILABLE FOR USE
24 KNTPIN=KNTPIN-1
IF(IX.LE.0)GO TO 25
IF(IX.GT.KWIDE)GO TO 25
IF(IY.LE.0)GO TO 25
IF(IY.LE.KHIGH)GO TO 29
25 IF(KNTPIN.GT.0)GO TO 26
C
C TURN AT CORNER OF TERRACE
I=MOVEX
MOVEX=MOVEY
MOVEY=-I
IF(MOVEX.GT.0)GO TO 27
KNTPIN=MAXPIN
C
C TRAVEL ALONG SIDE OF TERRACE
26 IX=IX+MOVEX
IY=IY+MOVEY
GO TO 24
C
C EXPAND OUT TO NEXT TERRACE
27 MAXSQR=MAXSQR+1
IF(MAXSQR.GE.0)GO TO 28
MAXPIN=MAXPIN+2
IY=IY+1
KNTPIN=MAXPIN
GO TO 24
28 IF(INSERT.NE.0)JERR=JERR+1
GO TO 38
C
C CALCULATE WORD COUNT AND BYTE COUNT IN WORD
29 IBYTE=IX-1+(KWIDE*(IY-1))
IWORD=IBYTE/MAXBYT
IBYTE=IBYTE-(MAXBYT*IWORD)+1
IWORD=IWORD+1
C
C GET CURRENT CONTENTS OF BYTE.
IRIGHT=ISTORE(IWORD)
IF(IBYTE.GE.MAXBYT)GO TO 30
ILEFT=IRIGHT/ISHIFT(IBYTE+1)
IRIGHT=IRIGHT-(ISHIFT(IBYTE+1)*ILEFT)
30 KOMPAR=IRIGHT/ISHIFT(IBYTE)
I=INSERT
IF(KONECT.GE.-1)GO TO 32
C
C DECIDE CHARACTER TO INSERT ON TERRACE
IF(INSERT.GT.0)GO TO 31
IF(KOMPAR.EQ.0)GO TO 25
GO TO 35
31 IF(KOMPAR.EQ.0)GO TO 35
IF(MASTER(KOMPAR).LT.MASTER(INSERT))GO TO 35
GO TO 25
C
C DECIDE CHARACTER TO INSERT AT POINT OR LINE SEGMENT
32 IF(KOMPAR.EQ.INSERT)GO TO 36
IF(KOMPAR.EQ.0)GO TO 35
IF(INSERT.EQ.0)GO TO 35
IF(IPASS.GT.0)GO TO 33
IF(KOMPAR.EQ.LTRLIN)GO TO 35
GO TO 34
33 IF(KOMPAR.EQ.LTRPNT)GO TO 36
34 IF(MASTER(KOMPAR).GT.MASTER(INSERT))GO TO 36
IF(MASTER(KOMPAR).EQ.MASTER(INSERT))I=1
C
C INSERT THE NEW CHARACTER
35 IRIGHT=IRIGHT-(ISHIFT(IBYTE)*KOMPAR)
ISTORE(IWORD)=(I*ISHIFT(IBYTE))+IRIGHT
IF(IBYTE.LT.MAXBYT)ISTORE(IWORD)=
1ISTORE(IWORD)+(ILEFT*ISHIFT(IBYTE+1))
C
C IF CLEARING OUT A SET OF TERRACES, RETURN FOR NEXT
IF(KONECT.GE.-1)GO TO 36
LASTX=IX
LASTY=IY
IF(INSERT.EQ.0)GO TO 25
GO TO 38
C
C CHECK IF LINE SEGMENT IS DONE
36 IF(IPASS.LE.0)GO TO 38
IUSED=IUSED+1
IF(IUSED.LE.MULT)GO TO 21
C
C NEW END OF THIS LINE BECOMES OLD END FOR NEXT LINE
37 LASTX=NEWX
LASTY=NEWY
38 KRD=KRD+1
IF(KRD.LE.MAXSUB)GO TO 14
C
C DONE WITH THIS PASS, CHECK IF MUST MAKE LINE SEGMENTS
IF(IPASS.GT.0)GO TO 39
IPASS=1
IF(KONECT.LT.0)GO TO 39
LASTX=1.5+(XSCALE*(XPOINT(MINSUB)-XFIRST))
LASTY=1.5+HIGH-(YSCALE*(YPOINT(MINSUB)-YFIRST))
INSERT=LTRLIN
KRD=MINSUB
GO TO 38
C
C ************************
C * *
C * CONSTRUCT THE PLOT *
C * *
C ************************
C
39 LTRERR=IERR
LINERR=JERR
IF(IPLOT.LT.0)GO TO 93
IF(KONTNT.EQ.0)GO TO 93
IPASS=1
IF(IPLOT.GT.0)GO TO 41
C
C MARK THAT PLOT AREA IS EMPTY
40 KONTNT=0
C
C GET SWITCHES SET BY IGRID
C JGRID = ONES DIGIT
C KGRID = TENS DIGIT
C LGRID = HUNDREDS DIGIT
41 LGRID=MGRID
IF(LGRID.LT.0)LGRID=-LGRID-1
KGRID=LGRID/10
JGRID=LGRID-10*KGRID
LGRID=LGRID/100
KGRID=KGRID-10*LGRID
C
C GET SWITCHES SET BY IEDGE
C JEDGE = ONES DIGIT
C KEDGE = TENS DIGIT
C LEDGE = HUNDREDS DIGIT
LEDGE=MEDGE
IF(LEDGE.LT.0)LEDGE=-LEDGE-1
KEDGE=LEDGE/10
JEDGE=LEDGE-10*KEDGE
LEDGE=LEDGE/100
KEDGE=KEDGE-10*LEDGE
C
C DETERMINE LOCATIONS OF LEFT AND RIGHT PLOT EDGES
IWIDTH=10
IF(IWIDTH.GT.IWIDE)IWIDTH=IWIDE
JWIDTH=IWIDTH/2
IF(JEDGE.LE.1)GO TO 42
IFIRST=1
IF(JEDGE.EQ.2)IFIRST=JWIDTH+1
GO TO 43
42 IFIRST=12
43 IF(IFIRST.LE.MMRGN)IFIRST=MMRGN+1
C THIS LINE PROTECT AGAINST OVERRUN OF BUFFER
C TEST IS AGAINST LENGTH OF BUFFER MINUS 4 CHARACTERS
C WHICH COULD APPEAR RIGHT OF PLOT IN SCALE NUMBERS
IF(IFIRST.GT.(MAXBFR-3-KWIDE))IFIRST=MAXBFR-3-KWIDE
LEAVE=IFIRST-3
IFINAL=IFIRST+KWIDE-1
C
C DETERMINE LOCATIONS OF LEFT AND RIGHT GRID LINES
IF(IWIDE.GT.KWIDE)GO TO 48
LOSSX=IOVER
IF(LOSSX.LE.-KWIDE)GO TO 48
IF(LOSSX.GE.KWIDE)GO TO 48
44 IF(LOSSX.GE.0)GO TO 45
LOSSX=LOSSX+IWIDE
GO TO 44
45 IF(LOSSX.LT.IWIDE)GO TO 46
LOSSX=LOSSX-IWIDE
GO TO 45
46 LTRLFT=IFIRST+LOSSX
LTRRIT=LTRLFT
47 LTRRIT=LTRRIT+IWIDE
IF(LTRRIT.LE.IFINAL)GO TO 47
LTRRIT=LTRRIT-IWIDE
GO TO 49
48 LTRLFT=IFIRST-1
LTRRIT=IFINAL+1
LOSSX=KWIDE
IF(JEDGE.EQ.0)JEDGE=1
IF(JEDGE.EQ.2)JEDGE=3
49 IF(IHIGH.GT.KHIGH)GO TO 54
LOSSY=IUP
IF(LOSSY.LE.-KHIGH)GO TO 54
IF(LOSSY.GE.KHIGH)GO TO 54
50 IF(LOSSY.GE.0)GO TO 51
LOSSY=LOSSY+IHIGH
GO TO 50
51 IF(LOSSY.LT.IHIGH)GO TO 52
LOSSY=LOSSY-IHIGH
GO TO 51
52 LINLOW=KHIGH-LOSSY
LOSSY=LINLOW-1
53 LOSSY=LOSSY-IHIGH
IF(LOSSY.GE.0)GO TO 53
LOSSY=IHIGH+LOSSY
LINHIH=LOSSY+1
GO TO 55
54 LINHIH=0
LINLOW=KHIGH+1
LOSSY=KHIGH
C
C RESET LIMITS WHICH PREVENT CERTAIN BORDER LINES
55 IF(JGRID.EQ.0)GO TO 56
IF(KGRID.LE.1)GO TO 57
56 LTRLFT=IFIRST
IF(KEDGE.GT.1)LTRLFT=LTRLFT-1
57 IF(JGRID.EQ.0)GO TO 58
IF(KGRID.EQ.0)GO TO 59
IF(KGRID.EQ.2)GO TO 59
58 LTRRIT=IFINAL
IF(KEDGE.EQ.0)GO TO 59
IF(KEDGE.NE.2)LTRRIT=LTRRIT+1
59 IF(JGRID.EQ.0)GO TO 60
IF(LGRID.LE.1)GO TO 61
60 LINLOW=KHIGH
IF(LEDGE.GT.1)LINLOW=LINLOW+1
61 IF(JGRID.EQ.0)GO TO 62
IF(LGRID.EQ.0)GO TO 63
IF(LGRID.EQ.2)GO TO 63
62 LINHIH=1
IF(LEDGE.EQ.0)GO TO 63
IF(LEDGE.NE.2)LINHIH=0
63 JGRID=JGRID-1
C
C FLOATING POINT WIDTH OF PLOT
WIDE=KWIDE-1
HIGH=KHIGH-1
C
C DEFINE HEIGHT OF REGION CONSIDERED TO CONTAIN ZERO
IF(KHIGH.LE.1)GO TO 64
ZERO=0.25*((YFINAL-YFIRST)/HIGH)
IF(ZERO.LT.0.0)ZERO=-ZERO
C
C DEFINE VALUE IN CASE PLOT IS ONLY 1 LINE HIGH
64 VALUE=YFINAL
C
C SET CARRIAGE CONTROL CHARACTER
KONTRL=JSPACE
IF(LINPRT.GT.0)KONTRL=ISTAR
C
C DEFINE THE STARTING INDEXES
C KNTLIN = CURRENT LINE NUMBER
C KNTWRD = SUBSCRIPT IN STORAGE ARRAY OF WORD BEING
C UNPACKED
C KNTBYT = BYTE COUNT IN THE WORD BEING UNPACKED
C LOSSX AND LOSSY ARE USED TO PLACE GRIDS ON PLOT
C LOSSX = FROM NOW IS INITIAL VALUE OF COLUMN COUNT
C RELATIVE TO NEXT COLUMN TO BEAR GRID LINE
C LOSSY = FROM NOW IS VALUE OF LINE COUNT RELATIVE
C TO NEXT LINE TO BEAR A GRID LINE.
KNTLIN=1
KNTWRD=0
KNTBYT=MAXBYT
C
C HIDDEN SWITCH FOR TIME SERIES PLOT CONSTRUCTION
C
C IEDGE.LT.0 DO NOT PLOT BOTTOM LINE OF PLOT. DO NOT
C PLOT SCALE NUMBERS BELOW PLOT. BOTTOM
C LINE IS ROLLED INTO TOP LINE AND REST OF
C PLOT STORAGE IS LEFT EMPTY.
C
C IKNTBY = BYTE INTO WHICH TO SAVE NEXT UNPACKED BYTE
C IF ROLLING LAST LINE INTO FIRST
C IKNTWR = WORD INTO WHICH TO SAVE NEXT UNPACKED BYTE
C IF ROLLING LAST LINE INTO FIRST
C
IF(MGRID.GE.0)GO TO 65
IKNTWR=0
IKNTBY=MAXBYT
KONTNT=0
C
C CONSTANTS RESET AT START OF EACH LINE
65 KNTLTR=IFIRST
KNTCLM=LOSSX
IF(LOSSY.NE.0)GO TO 67
IF(JEDGE.GT.1)GO TO 67
C
C CONSTRUCT SCALE NUMBER ON LINE WHICH CAN BE GRID
IF(KNTLIN.LE.1)GO TO 66
VALUE=(YFINAL*(FLOAT(KHIGH-KNTLIN)/HIGH))+
1(YFIRST*(FLOAT(KNTLIN-1)/HIGH))
IF(VALUE.GE.ZERO)GO TO 66
IF(VALUE.GT.(-ZERO))VALUE=0.0
66 CALL DARITE(VALUE,1,0,0,1,-3,0,LEAVE,-2,7,
15,5,0,0,4,0,0,-1,0,MAXBFR,LTRBUF,I,KERR)
IUSED=LEAVE+2
LTRBUF(LEAVE+1)=KSPACE
LTRBUF(IUSED)=IHRZNT
GO TO 69
C
C FILL SPACE TO LEFT WITH SPACES IF NO SCALE NUMBER
67 IUSED=1
I=0
68 I=I+1
IF(I.GE.IFIRST)GO TO 69
LTRBUF(I)=KSPACE
GO TO 68
C
C UNPACK NEXT BYTE
69 KNTBYT=KNTBYT+1
IF(KNTBYT.LE.MAXBYT)GO TO 70
KNTWRD=KNTWRD+1
KNTBYT=1
IVALUE=ISTORE(KNTWRD)
IF(KONTNT.EQ.0)ISTORE(KNTWRD)=0
70 JVALUE=IVALUE
IVALUE=IVALUE/LRGBYT
JVALUE=JVALUE-(LRGBYT*IVALUE)
C
C IF ROLLING LAST LINE INTO FIRST, SAVE BYTE
IF(MGRID.GE.0)GO TO 72
IF(KNTLIN.LT.KHIGH)GO TO 72
IKNTBY=IKNTBY+1
IF(IKNTBY.LE.MAXBYT)GO TO 71
IKNTBY=1
IKNTWR=IKNTWR+1
71 ISTORE(IKNTWR)=ISTORE(IKNTWR)+(JVALUE*ISHIFT(IKNTBY))
C
C DECIDE WHAT CHARACTER TO PLACE INTO OUTPUT BUFFER
72 IF(JVALUE.GT.0)GO TO 79
IF(KNTLIN.EQ.LINLOW)GO TO 74
IF(KNTLIN.EQ.LINHIH)GO TO 74
IF(LOSSY.EQ.0)GO TO 75
IF(KNTLTR.EQ.LTRLFT)GO TO 73
IF(KNTLTR.EQ.LTRRIT)GO TO 73
IF(JGRID.GE.0)GO TO 81
IF(KNTCLM.GT.0)GO TO 81
73 LTRBUF(KNTLTR)=IVRTCL
GO TO 80
74 IF(KNTLTR.EQ.LTRLFT)GO TO 78
IF(KNTLTR.EQ.LTRRIT)GO TO 78
GO TO 76
75 IF(KNTLTR.EQ.LTRLFT)GO TO 78
IF(KNTLTR.EQ.LTRRIT)GO TO 78
IF(JGRID.GE.0)GO TO 77
76 IF(KNTCLM.LE.0)GO TO 78
LTRBUF(KNTLTR)=IHRZNT
GO TO 80
77 IF(JGRID.GT.0)GO TO 81
IF(KNTCLM.GT.0)GO TO 81
78 LTRBUF(KNTLTR)=ICORNR
GO TO 80
79 LTRBUF(KNTLTR)=LTRALL(JVALUE+6)
80 IUSED=KNTLTR
GO TO 82
81 LTRBUF(KNTLTR)=ISPACE
82 IF(KNTCLM.LE.0)KNTCLM=IWIDE
KNTCLM=KNTCLM-1
KNTLTR=KNTLTR+1
IF(KNTLTR.LE.IFINAL)GO TO 69
C
C OUTPUT THE COMPLETED LINE
KNTLIN=KNTLIN+1
IF(KNTLIN.LE.KHIGH)GO TO 83
IF(MGRID.GE.0)GO TO 83
KONTNT=1
GO TO 92
83 IF(LINPRT.LT.0)WRITE(IDISK,84)(LTRBUF(I),I=1,IUSED)
IF(LINPRT.GE.0)WRITE(IDISK,84)KONTRL,
1(LTRBUF(I),I=1,IUSED)
84 FORMAT(147A1)
IF(LOSSY.LE.0)LOSSY=IHIGH
LOSSY=LOSSY-1
IF(KNTLIN.LE.KHIGH)GO TO 65
C
C PRINT GRID LINE EXTENSIONS BELOW PLOT
IF(JEDGE.EQ.1)GO TO 92
IF(JEDGE.GE.3)GO TO 92
IF(IWIDE.GT.KWIDE)GO TO 92
IFIRST=IFIRST+LOSSX
KNTLTR=0
I=IFIRST
85 KNTLTR=KNTLTR+1
IF(KNTLTR.GE.I)GO TO 86
LTRBUF(KNTLTR)=KSPACE
GO TO 85
86 LTRBUF(KNTLTR)=IVRTCL
I=I+IWIDE
IF(I.LE.IFINAL)GO TO 85
IF(LINPRT.LT.0)WRITE(IDISK,84)(LTRBUF(I),I=1,KNTLTR)
IF(LINPRT.GE.0)WRITE(IDISK,84)KONTRL,
1(LTRBUF(I),I=1,KNTLTR)
C
C PRINT SCALE NUMBERS BELOW GRID LINE EXTENSIONS
LERR=-1
MINSIG=5
IF(MINSIG.GT.(IWIDTH-2))MINSIG=IWIDTH-2
IF(MINSIG.LE.0)MINSIG=1
IF(KWIDE.LE.1)GO TO 87
ZERO=0.25*((XFINAL-XFIRST)/WIDE)
IF(ZERO.LT.0.0)ZERO=-ZERO
87 KIND=LERR
KNTLTR=IFIRST-JWIDTH-1
I=LOSSX+1
VALUE=XFIRST
88 NEED=KNTLTR+IWIDE
IF(I.LE.1)GO TO 89
VALUE=(XFIRST*(FLOAT(KWIDE-I)/WIDE))+
1(XFINAL*(FLOAT(I-1)/WIDE))
IF(VALUE.GE.ZERO)GO TO 89
IF(VALUE.GT.(-ZERO))VALUE=0.0
89 CALL DARITE(VALUE,0,0,KIND,1,-3,0,IWIDTH,-2,-2,
1MINSIG,5,0,0,4,0,0,-1,KNTLTR,MAXBFR,LTRBUF,KNTOUT,
2KERR)
KNTLTR=KNTOUT
IF(KERR.GT.0)LERR=1
I=I+IWIDE
IF(I.GT.KWIDE)GO TO 91
90 IF(NEED.LE.KNTLTR)GO TO 88
KNTLTR=KNTLTR+1
LTRBUF(KNTLTR)=KSPACE
GO TO 90
91 IF(LINPRT.LT.0)WRITE(IDISK,84)(LTRBUF(I),I=1,KNTLTR)
IF(LINPRT.GE.0)WRITE(IDISK,84)KONTRL,
1(LTRBUF(I),I=1,KNTLTR)
IF(KIND.NE.LERR)GO TO 87
92 IF(IPASS.LE.0)GO TO 12
93 RETURN
C581314532331!&
END
SUBROUTINE DAGRID(JSTIFY,MAXWID,XLEFT,XRIGHT,MSHWID,
1 LTROFF)
C RENBR(/RATIONALIZE SCALE OF PRINTER PLOT)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C PROPORTIONS OF GRID SUPERIMPOSED UPON PLOT AREA BY
C DAPLAT ROUTINE MUST BE SPECIFIED BY CALLING PROGRAM.
C NUMBERS WHICH ARE PRINTED BESIDE AND BELOW PLOT
C MERELY REPRESENT DATA UNIT COORDINATES PLOTTED AT
C CENTERS OF COLUMNS AND LINES WHICH BEAR GRID LINES.
C RANGE OF DATA UNIT COORDINATES REPRESENTED BY THESE
C SCALES CAN BE DIFFICULT TO INTERPRET IF CALLING
C PROGRAM HOLDS GRID PROPORTIONS CONSTANT WHILE
C ATTEMPTING TO OBTAIN MAXIMUM RESOLUTION BY ADJUSTING
C MINIMUM AND MAXIMUM COORDINATES TO SPREAD CURVES
C ACROSS FULL WIDTH OR HEIGHT OF PLOT. DAPLAT CANNOT
C ITSELF CALCULATE GRID PROPORTIONS WHICH WOULD PRODUCE
C MINIMUM NUMBER OF NONZERO DIGITS IN EACH SCALE
C NUMBER. IF PREDETERMINED GRID SPACINGS AND OFFSETS
C ARE NOT NECESSARY, THEN ROUTINE DAGRID CAN BE CALLED
C ONCE FOR EACH SCALE BEFORE DATA IS PLOTTED TO SELECT
C GRID PROPORTIONS AND TO EXPAND COORDINATE RANGES
C SLIGHTLY TO GIVE NEATER SCALE NUMBERS.
C
C JSTIFY = -2, LEFT JUSTIFY LEFT GRID LINE
C = -1, LEFT JUSTIFY XLEFT
C = 0, CENTER RANGE
C = 1, RIGHT JUSTIFY XRIGHT
C = 2, RIGHT JUSTIFY RIGHT GRID LINE
C MAXWID = WIDTH (OR HEIGHT) OF PLOT STATED AS NUMBER
C OF COLUMNS (OR LINES).
C XLEFT = INPUT CONTAINING DATA UNIT COORDINATE TO BE
C REPRESENTED BY CENTER OF LEFT COLUMN (OR OF
C LOWER LINE) OF PLOT.
C = RETURNED CONTAINING DATA UNIT COORDINATE
C WHICH WOULD GIVE RATIONAL SCALE IF USED AS
C DATA UNIT COORDINATE REPRESENTED BY CENTER
C OF LEFT COLUMN (OR OF LOWER LINE) OF PLOT.
C XRIGHT = INPUT CONTAINING DATA UNIT COORDINATE TO BE
C REPRESENTED BY CENTER OF RIGHT COLUMN (OR OF
C UPPER LINE) OF PLOT.
C = RETURNED CONTAINING DATA UNIT COORDINATE
C WHICH WOULD GIVE RATIONAL SCALE IF USED AS
C DATA UNIT COORDINATE REPRESENTED BY CENTER
C OF RIGHT COLUMN (OR OF UPPER LINE) OF PLOT.
C MSHWID = RETURNED CONTAINING THE GRID DIVISION WIDTH
C STATED AS THE NUMBER OF COLUMNS (OR HEIGHT
C STATED AS NUMBER OF LINES). INPUT VALUE OF
C MSHWID IS IGNORED. A LINE SHOULD BE RULED
C EVERY MSHWID CHARACTERS ACROSS THE WIDTH (OR
C HEIGHT) OF THE PLOT. IF MSHWID IS RETURNED
C CONTAINING 10, THEN 9 COLUMNS (OR LINES)
C SHOULD APPEAR BETWEEN THE COLUMNS (OR LINES)
C BEARING GRID LINES.
C = 0, RETURNED IF THIS ROUTINE COULD NOT
C RATIONALIZE THE SCALE, AS FOR EXAMPLE IF
C XLEFT IS INPUT CONTAINING THE SAME VALUE AS
C XRIGHT, OR IF MAXWID IS INPUT TOO SMALL.
C LTROFF = RETURNED CONTAINING THE NUMBER OF COLUMNS
C (OR LINES) BY WHICH THE LEFT (OR LOWER) GRID
C LINE IS TO BE OFFSET FROM THE LEFT (OR
C LOWER) EDGE OF THE PLOT. INPUT VALUE OF
C LTROFF IS IGNORED. IF LTROFF IS RETURNED
C CONTAINING ZERO, THEN THE LEFT (OR LOWER)
C GRID LINE SHOULD APPEAR IN THE LEFT (OR
C LOWER) COLUMN OF THE PLOT. IF LTROFF IS
C RETURNED CONTAINING 5, THEN 5 COLUMNS (OR
C LINES) OF THE PLOT AREA SHOULD APPEAR TO THE
C LEFT OF (OR BELOW) THE LEFTMOST (OR LOWEST)
C GRID LINE.
C
C SCALE RANGE TO BE BETWEEN 1.0 AND 9.999...
IF(MAXWID.LE.0)GO TO 19
KNTJST=0
IF(JSTIFY.LE.0)GO TO 1
FORMER=XLEFT
XLEFT=XRIGHT
XRIGHT=FORMER
1 RANGE=XRIGHT-XLEFT
IF(RANGE.LT.0.0)RANGE=-RANGE
IF(RANGE.LE.0.0)GO TO 19
SHIFTD=RANGE
IPOWER=0
2 IF(SHIFTD.GE.10.0)GO TO 3
IF(SHIFTD.GE.1.0)GO TO 4
IF(IPOWER.LT.-99)GO TO 19
IF(IPOWER.GT.0)GO TO 4
IPOWER=IPOWER-1
SHIFTD=10.0*SHIFTD
GO TO 2
3 IF(IPOWER.GT.99)GO TO 19
IF(IPOWER.LT.0)GO TO 4
IPOWER=IPOWER+1
SHIFTD=SHIFTD/10.0
GO TO 2
C
C CALCULATE WIDTH OF EACH GRID DIVISION
4 STEP=0.25
IF(SHIFTD.GT.2.5)STEP=0.5
IF(SHIFTD.GT.5.0)STEP=1.0
STEP=STEP*(10.0**IPOWER)
MSHWID=FLOAT(MAXWID-1)*(STEP/RANGE)
IF(MSHWID.LE.0)GO TO 19
IF(JSTIFY.NE.0)GO TO 5
HLFWID=0.5*STEP*(FLOAT(MAXWID-1)/FLOAT(MSHWID))
IF(XLEFT.GT.XRIGHT)HLFWID=-HLFWID
CENTER=(XLEFT+XRIGHT)/2.0
XLEFT=CENTER-HLFWID
XRIGHT=CENTER+HLFWID
C
C GET INTEGRAL MULTIPLE OF STEP WHICH IS JUST GREATER
C THAN OR EQUAL TO ABSOLUTE VALUE OF LEFT EDGE OF PLOT
5 ORIGIN=STEP
KOUNT=0
COMPAR=XLEFT
IF(COMPAR.LT.0.0)COMPAR=-COMPAR
6 IF(ORIGIN.GE.COMPAR)GO TO 7
IF(KOUNT.GE.10)GO TO 19
KOUNT=KOUNT+1
ORIGIN=10.0*ORIGIN
GO TO 6
7 SEARCH=ORIGIN
8 LIMIT=10
9 FORMER=ORIGIN
ORIGIN=ORIGIN-SEARCH
IF(ORIGIN.LT.COMPAR)GO TO 10
LIMIT=LIMIT-1
IF(LIMIT.GT.0)GO TO 9
GO TO 11
10 ORIGIN=FORMER
11 IF(KOUNT.LE.0)GO TO 12
SEARCH=SEARCH/10.0
KOUNT=KOUNT-1
GO TO 8
C
C ADJUST ORIGIN FOR DIRECTION AND SIGN OF LEFT EDGE
12 IF(XLEFT.LE.XRIGHT)GO TO 14
STEP=-STEP
IF(XLEFT.LT.0.0)GO TO 13
ORIGIN=ORIGIN+STEP
GO TO 15
13 ORIGIN=-ORIGIN
GO TO 15
14 IF(XLEFT.GE.0.0)GO TO 15
ORIGIN=-ORIGIN+STEP
C
C CALCULATE GRID PROPORTIONS
15 LTROFF=0.5+(FLOAT(MSHWID)*((ORIGIN-XLEFT)/STEP))
IF(LTROFF.LT.MSHWID)GO TO 16
LTROFF=LTROFF-MSHWID
ORIGIN=ORIGIN-STEP
16 IF(LTROFF.LE.0)GO TO 17
IF(JSTIFY.LT.-1)GO TO 18
IF(JSTIFY.GT.1)GO TO 18
17 XLEFT=ORIGIN-(STEP*(FLOAT(LTROFF)/FLOAT(MSHWID)))
XRIGHT=ORIGIN+(STEP*(FLOAT(MAXWID-1-LTROFF)/
1FLOAT(MSHWID)))
IF(JSTIFY.LE.0)GO TO 20
FORMER=XLEFT
XLEFT=XRIGHT
XRIGHT=FORMER
LTROFF=MAXWID-LTROFF-1
LTROFF=LTROFF-(MSHWID*(LTROFF/MSHWID))
GO TO 20
C
C LOOP BACK IF NEED TO JUSTIFY GRID
18 XLEFT=ORIGIN-STEP
KNTJST=KNTJST+1
IF(KNTJST.LE.5)GO TO 1
C
C ERROR CONDITION
19 MSHWID=0
LTROFF=0
C
C RETURN TO CALLING PROGRAM
20 RETURN
C635919530735
END
SUBROUTINE DALINE(IGRID ,KNDBAR,LSTLIN,MARGIN,MSHLFT,
1 MSHRIT,LNGLFT,LNGRIT,XLEFT ,XRIGHT,SEGMNT,MINSEG,
2 MAXSEG,LETTER,MINLTR,MAXLTR,YVALUE,LABEL ,MINLBL,
3 MAXLBL,LINPRT,IDISK )
C RENBR(/HORIZONTAL BAR CHART PLOTTER FOR PRINTER)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DALINE CONSTRUCTS PRINTABLE PLOTS CONTAINING
C HORIZONTAL BARS FORMED OF SEGMENTS, THE LENGTHS OF
C WHICH REPRESENT MAGNITUDES OF CORRESPONDING VALUES.
C BARS CAN BE SUPERIMPOSED UPON BACKGROUND GRID AND CAN
C EXTEND TO EITHER SIDE OF CENTRAL COLUMN CORRESPONDING
C TO ZERO. NEGATIVE SEGMENTS (DEBITS) ARE ACCUMULATED
C TO ONE SIDE OF ZERO COLUMN, AND POSITIVE SEGMENTS
C (CREDITS) TO OTHER, ALTHOUGH USER HAS OPTION OF
C SUPPRESSING DISPLAY OF EITHER PORTION. DALINE IS
C CALLED AS MANY TIMES AS THERE ARE LINES IN PLOT, EACH
C SUBSEQUENT CALL GENERATING NEXT LOWER LINE OF PLOT.
C
C ARGUMENTS OF THIS ROUTINE ARE USED ONLY FOR INPUT.
C
C IGRID = SELECTS BACKGROUND CHARACTERS TO BE SHOWN
C WHERE NOT HIDDEN BY CHARACTERS USED TO
C REPRESENT BAR SEGMENTS, SELECTS CHARACTER,
C IF ANY, TO APPEAR IN CENTRAL ZERO COLUMN,
C AND SELECTS TYPE OF CAPTION, EITHER NUMERIC
C OR ALPHABETIC, TO BE SHOWN TO LEFT OF
C CURRENTLY GENERATED PANEL OF BAR CHART.
C THESE OPTIONS ARE SELECTED BY DIGITS IN
C ONES, TENS, AND HUNDREDS POSITIONS
C RESPECTIVELY IN DECIMAL INTEGER VALUE OF
C IGRID. MEANINGS ASSIGNED TO EACH POSITION
C IN VALUE OF IGRID ARE AS FOLLOW
C
C ONES DIGIT OF IGRID
C
C SELECTS CHARACTERS TO BE INCLUDED ACROSS
C WIDTH OF PLOT IN COLUMNS NOT OCCUPIED BY
C CHARACTERS USED TO REPRESENT BAR SEGMENTS,
C BUT DOES NOT DICTATE CHARACTERS APPEARING IN
C EITHER LEFT MARGIN OR IN COLUMN REPRESENTING
C ZERO.
C
C 0 SPACES WILL BE SHOWN WHERE NOT HIDDEN BY
C CHARACTERS USED TO REPRESENT BAR
C SEGMENTS.
C 1 MINUS SIGNS WILL BE SHOWN WHERE NOT
C HIDDEN BY CHARACTERS USED TO REPRESENT
C BAR SEGMENTS.
C 2 IF NOT HIDDEN BY CHARACTERS USED TO
C REPRESENT BAR SEGMENTS, THEN EXCLAMATION
C POINTS WILL BE SHOWN IN LEFTMOST COLUMN
C WHICH COULD BEAR LOWER SCALE NUMBER TO
C LEFT OF ZERO COLUMN, AND IN RIGHTMOST
C COLUMN WHICH COULD BEAR LOWER SCALE
C NUMBER TO RIGHT OF ZERO COLUMN.
C 3 SAME AS IGRID=2, EXCEPT THAT MINUS SIGNS
C ARE INCLUDED INSTEAD OF SPACES IN COLUMNS
C WHICH CONTAIN NEITHER EXCLAMATION POINTS
C NOR CHARACTERS WHICH REPRESENT BAR
C SEGMENTS.
C 4 SAME AS IGRID=2, EXCEPT THAT IF NOT
C HIDDEN BY CHARACTERS USED TO REPRESENT
C BAR SEGMENTS, THEN PLUS SIGNS WILL BE
C SHOWN IN LEFTMOST COLUMN WHICH COULD BEAR
C LOWER SCALE NUMBER TO LEFT OF ZERO
C COLUMN, AND IN RIGHTMOST COLUMN WHICH
C COULD BEAR LOWER SCALE NUMBER TO RIGHT OF
C ZERO COLUMN.
C 5 SAME AS IGRID=4, EXCEPT THAT MINUS SIGNS
C ARE INCLUDED INSTEAD OF SPACES IN COLUMNS
C WHICH CONTAIN NEITHER PLUS SIGNS NOR
C CHARACTERS WHICH REPRESENT BAR SEGMENTS.
C 6 IF NOT HIDDEN BY CHARACTERS USED TO
C REPRESENT BAR SEGMENTS, THEN EXCLAMATION
C POINTS WILL BE SHOWN IN EACH COLUMN WHICH
C COULD BEAR LOWER SCALE NUMBER.
C 7 SAME AS IGRID=6, EXCEPT THAT MINUS SIGNS
C ARE INCLUDED INSTEAD OF SPACES IN COLUMNS
C WHICH CONTAIN NEITHER EXCLAMATION POINTS
C NOR CHARACTERS WHICH REPRESENT BAR
C SEGMENTS.
C 8 SAME AS IGRID=6, EXCEPT THAT IF NOT
C HIDDEN BY CHARACTERS USED TO REPRESENT
C BAR SEGMENTS, THEN PLUS SIGNS WILL BE
C SHOWN IN EACH COLUMN WHICH COULD BEAR
C LOWER SCALE NUMBER.
C 9 SAME AS IGRID=8, EXCEPT THAT MINUS SIGNS
C ARE INCLUDED INSTEAD OF SPACES IN COLUMNS
C WHICH CONTAIN NEITHER PLUS SIGNS NOR
C CHARACTERS WHICH REPRESENT BAR SEGMENTS.
C
C FOLLOWING EXAMPLES DEMONSTRATE RESULTS
C PRODUCED BY VARIOUS VALUES OF ONES DIGIT.
C
C ONES DIGIT = 0
C = 1 --------------- ---------------
C = 2 ! !
C = 3 !-------------- --------------!
C = 4 + +
C = 5 +-------------- --------------+
C = 6 ! ! ! ! ! !
C = 7 !----!----!---- ----!----!----!
C = 8 + + + + + +
C = 9 +----+----+---- ----+----+----+
C TICK MARKS ! ! ! ! ! ! !
C SCALE NUMBERS -15.0-10.0-5.0 0 5.0 10.0 15.0
C
C TENS DIGIT OF IGRID
C
C SELECTS CHARACTER, IF ANY, TO BE SHOWN IN
C ZERO COLUMN, AND WHETHER LOWER SCALE
C NUMBERS, IF GENERATED BY CURRENT CALL TO
C THIS ROUTINE, IDENTIFY ZERO COLUMN.
C
C 0 ZERO COLUMN IS NOT REPRESENTED.
C 1, 2, 3 OR 4, ZERO COLUMN IS REPRESENTED BY
C CHARACTER INDICATED BY TENS DIGIT, BUT IS
C NOT TO BE IDENTIFIED IN LOWER SCALE
C NUMBERS WHICH MIGHT BE GENERATED BY
C CURRENT CALL TO THIS ROUTINE.
C 1 ZERO COLUMN REPRESENTED BY SPACE.
C 2 ZERO COLUMN REPRESENTED BY MINUS SIGN.
C 3 ZERO COLUMN REPRESENTED BY EXCLAMATION
C POINT.
C 4 ZERO COLUMN REPRESENTED BY PLUS SIGN.
C 5, 6, 7 OR 8, ZERO COLUMN IS REPRESENTED BY
C SAME CHARACTER AS SELECTED BY
C 1, 2, 3 OR 4 RESPECTIVELY. IF CURRENT
C CALL TO THIS ROUTINE ALSO GENERATES LOWER
C SCALE NUMBERS, THEN ZERO COLUMN WILL BE
C IDENTIFIED BY SCALE NUMBER HAVING VALUE
C ZERO.
C
C FOLLOWING EXAMPLES DEMONSTRATE RESULTS
C PRODUCED BY VARIOUS VALUES OF TENS DIGIT.
C
C TENS DIGIT = 0
C
C +-+--+-+
C ! ! ! !
C -4-2 2 4
C
C TENS DIGIT = 1 2 3 4
C
C +-+- -+-+ +-+---+-+ +-+-!-+-+ +-+-+-+-+
C ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
C -4-2 2 4 -4-2 2 4 -4-2 2 4 -4-2 2 4
C
C TENS DIGIT = 5 6 7 8
C
C +-+- -+-+ +-+---+-+ +-+-!-+-+ +-+-+-+-+
C ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
C -4-2 0 2 4 -4-2 0 2 4 -4-2 0 2 4 -4-2 0 2 4
C
C HUNDREDS DIGIT OF IGRID
C
C SELECTS TYPE OF CAPTION, EITHER NUMERIC OR
C ALPHABETIC, TO BE SHOWN TO LEFT OF CURRENTLY
C GENERATED PANEL OF BAR CHART.
C
C 0 LEFT MARGIN IS TO CONTAIN SPACES.
C 1 REPRESENTATION OF VALUE INPUT AS ARGUMENT
C NAMED YVALUE IS TO BE RIGHT JUSTIFIED IN
C MARGIN TO LEFT OF LEFT BORDER OF BAR
C CHART.
C 2 CHARACTERS INPUT IN LABEL(MINLBL) THROUGH
C AND INCLUDING LABEL(MAXLBL) ARE TO BE
C RIGHT JUSTIFIED IN MARGIN TO LEFT OF LEFT
C BORDER OF BAR CHART.
C 3 OR 4, SAME AS 1 OR 2 RESPECTIVELY, EXCEPT
C THAT SPACE CHARACTER IS PLACED BETWEEN
C RIGHT JUSTIFIED NUMBER OR WORD AND LEFT
C BORDER OF PLOT.
C 5 OR 6, SAME AS 3 OR 4 RESPECTIVELY, EXCEPT
C THAT MINUS SIGN IS TO BE PLACED INTO
C COLUMN TO IMMEDIATE LEFT OF LEFT BORDER
C OF BAR CHART.
C
C FOLLOWING EXAMPLES DEMONSTRATE RESULTS
C PRODUCED BY VARIOUS VALUES OF HUNDREDS
C DIGIT.
C
C HUNDREDS DIGIT = 0 +----+---- ----+----+
C = 1 12.34+----+---- ----+----+
C = 2 LABEL+----+---- ----+----+
C = 3 12.34 +----+---- ----+----+
C = 4 LABEL +----+---- ----+----+
C = 5 12.34-+----+---- ----+----+
C = 6 LABEL-+----+---- ----+----+
C TICK MARKS ! ! ! !
C SCALE NUMBERS -10.0-5.0 5.0 10.0
C
C KNDBAR = SPECIFIES WHICH BAR SEGMENT IS TO BE
C REPRESENTED IF MORE THAN ONE BAR SEGMENT
C APPEARS IN SINGLE COLUMN OF PLOT, AND WHICH
C COLUMNS ARE TO REPRESENT ANY BAR SEGMENT
C WHICH EXTENDS ACROSS MORE THAN SINGLE
C COLUMN.
C = -1, NO BAR SEGMENTS ARE TO BE PLOTTED IN
C CURRENT PANEL. RESULTING PANEL IS IDENTICAL
C TO THAT WHICH WOULD BE PRODUCED IF MINSEG IS
C SET GREATER THAN MAXSEG.
C = 0, EACH BAR SEGMENT IS TO BE REPRESENTED
C ONLY IN FINAL COLUMN (THAT FURTHEST FROM
C ZERO COLUMN) IN WHICH IT IS LARGEST
C COMPONENT. SPACES ARE INSERTED INTO ANY
C OTHER COLUMNS IN WHICH BAR SEGMENT IS
C DOMINANT.
C = 1, EACH BAR SEGMENT IS TO BE REPRESENTED
C ONLY IN FINAL COLUMN (THAT FURTHEST FROM
C ZERO COLUMN) IN WHICH IT IS LARGEST
C COMPONENT. GRID CHARACTERS SELECTED BY ONES
C DIGIT OF DECIMAL INTEGER VALUE OF IGRID ARE
C INSERTED INTO ANY OTHER COLUMNS IN WHICH BAR
C SEGMENT IS DOMINANT.
C = 2, EACH BAR SEGMENT IS TO BE REPRESENTED IN
C ALL COLUMNS IN WHICH IT IS LARGEST
C COMPONENT.
C = 3, 4 OR 5, SAME AS KIND=0, 1 OR 2
C RESPECTIVELY, EXCEPT THAT FINAL COLUMNS
C (THOSE FURTHEST TO LEFT AND TO RIGHT OF ZERO
C COLUMN) WHICH CONTAIN FINAL NEGATIVE AND
C FINAL POSITIVE VALUES SPECIFIED BY SEGMNT
C ARRAY INSTEAD CONTAIN GRID CHARACTERS
C SELECTED BY ONES DIGIT OF DECIMAL INTEGER
C VALUE OF IGRID IF LARGEST COMPONENTS WITHIN
C THESE COLUMNS ARE SMALLER THAN SPACE
C REMAINING IN THESE COLUMNS.
C = 6, EACH BAR SEGMENT IS TO BE REPRESENTED
C ONLY IN FINAL COLUMN (THAT FURTHEST FROM
C ZERO COLUMN) IN WHICH BAR SEGMENT APPEARS.
C IF TWO OR MORE BAR SEGMENTS TERMINATE IN
C SAME COLUMN, THEN BAR SEGMENT SPECIFIED BY
C SEGMNT ARRAY LOCATION HAVING HIGHER
C SUBSCRIPT IS REPRESENTED, AND BAR SEGMENT
C SPECIFIED BY THE SEGMENT ARRAY LOCATION
C HAVING LOWER SUBSCRIPT IS INSTEAD
C REPRESENTED IN ADJACENT COLUMN NEXT CLOSER
C TO ZERO COLUMN IF THIS LOWER BAR SEGMENT IS
C ONLY BAR SEGMENT WHICH APPEARS IN THIS
C ADJACENT COLUMN. SPACES ARE INSERTED INTO
C ANY OTHER COLUMNS ACROSS WHICH BAR SEGMENT
C EXTENDS.
C = 7, SAME AS KNDBAR=6, EXCEPT THAT GRID
C CHARACTERS SELECTED BY ONES DIGIT OF DECIMAL
C INTEGER VALUE OF IGRID ARE INSERTED INTO ANY
C OTHER COLUMNS WHICH DO NOT CONTAIN
C TERMINATION OF BAR SEGMENT.
C = 8, EACH BAR SEGMENT IS REPRESENTED IN FINAL
C COLUMN (THAT FURTHEST FROM ZERO COLUMN) IN
C WHICH BAR SEGMENT APPEARS, AND IN EACH
C COLUMN IN WHICH BAR SEGMENT IS ONLY
C COMPONENT.
C
C AS DEMONSTRATION OF PLOTTING MODIFICATIONS
C CAUSED BY VARIOUS VALUES OF KNDBAR, NUMBERS
C
C .3 .4 .2 3.5 .1 .3 3.5 .2 .1 3.5 .3 .2
C
C AND
C
C -.3 -.4 -.2 -3.5 -.1 -.3 -3.5 -.2 -.1 -3.5 -.3 -.2
C
C ARE PLOTTED BELOW REPRESENTED BY LETTERS
C THROUGH X RESPECTIVELY WITH
C LNGLFT=LNGRIT=15, XLEFT=-15 AND XRIGHT=15
C FOR ALL POSSIBLE VALUES OF KNDBAR
C
C KNDBAR =-1 +----+----+----+----+----+----+
C = 0 +-WV S P N+B D G JK-+
C = 1 +-WV-+-S--P---N+B---D--G-+-JK-+
C = 2 +-WVVVVSSSPPPPN+BDDDDGGGJJJJK-+
C = 3 +--V S P N+B D G J--+
C = 4 +--V-+-S--P---N+B---D--G-+-J--+
C = 5 +--VVVVSSSPPPPN+BDDDDGGGJJJJ--+
C = 6 +-XV US RP O+C DF GI JL-+
C = 7 +-XV-+US--RP--O+C--DF--GI+-JL-+
C = 8 +-XVVVUSSSRPPPO+CDDDFGGGIJJJL-+
C TICK MARKS ! ! ! ! ! ! !
C SCALE NUMBERS -15.0-10.0-5.0 0 5.0 10.0 15.0
C
C LETTERS WHICH APPEAR IN COLUMNS 1, 5, 9 AND
C 13 WHEN KNDBAR IS LESS THAN OR EQUAL TO 5
C ARE DIFFERENT THAN WHOSE WHICH APPEAR WHEN
C KNDBAR IS GREATER THAN OR EQUAL TO 6.
C CORRESPONDENCE OF LETTERS TO COLUMNS IS
C SHOWN IN CHART BELOW.
C
C COLUMNS COLUMNS
C COLUMN 1 ! 2 - 4 ! COLUMN 5 ! 6 - 8 !
C ! ! ! !
C .3A .4B .2C .1D ! 3.D ! .4D .1E .3F .2G ! 3.G !
C
C COLUMNS
C COLUMN 9 !10 - 12! COLUMN 13
C ! !
C .3G .2H .1I .4J ! 3.J ! .1J .3K .2L AND .4 SPACE
C
C
C LSTLIN = -1, LOWER SCALE NUMBERS ARE TO BE GENERATED,
C BUT PANEL OF BAR CHART WILL NOT BE
C GENERATED.
C = 0, CURRENT PANEL FINISHES BAR CHART. SCALE
C NUMBERS RANGING IN VALUE FROM THAT OF XLEFT
C (IF LNGLFT IS GREATER THAN ZERO) THROUGH
C THAT OF XRIGHT (IF LNGRIT IS GREATER THAN
C ZERO) ARE TO BE WRITTEN BELOW CURRENT PANEL
C OF BAR CHART.
C = GREATER THAN ZERO, CURRENT PANEL DOES NOT
C FINISH BAR CHART. SCALE NUMBERS ARE NOT
C GENERATED.
C
C MARGIN = WIDTH, STATED AS NUMBER OF CHARACTERS, IN
C MARGIN TO BE INCLUDED TO LEFT OF CURRENT
C PANEL OF BAR CHART. WIDTH OF MARGIN MUST BE
C SAME FOR ALL PANELS FORMING BAR CHART.
C MARGIN MUST INCLUDE SUFFICIENT ROOM FOR LEFT
C SCALE NUMBER OR FOR LEFT ALPHAMERIC LABEL
C REQUESTED BY NONZERO VALUE OF HUNDREDS DIGIT
C OF DECIMAL INTEGER VALUE OF IGRID, AND FOR
C EXTRA SPACE OR FOR EXTRA MINUS SIGN IF
C HUNDREDS DIGIT OF IGRID IS GREATER THAN OR
C EQUAL TO 3. IF SCALE NUMBERS ARE TO BE
C WRITTEN BELOW BAR CHART, AND IF LNGLFT IS
C GREATER THAN ZERO, THEN MARGIN SHOULD HAVE
C VALUE OF AT LEAST 5 (OR OF AT LEAST HALF OF
C MSHLFT IF MSHLFT IS LESS THAN 10) TO ALLOW
C NUMBER TO BE CENTERED BELOW LEFT BORDER
C LINE. IF LNGLFT IS NOT GREATER THAN ZERO,
C THEN ROOM DOES NOT NEED TO BE ALLOWED IN
C LEFT MARGIN FOR LOWER SCALE NUMBERS.
C
C MSHLFT = WIDTH OF GRID DIVISIONS INDICATED EITHER BY
C EXCLAMATION POINTS OR PLUS SIGNS IN PORTION
C OF BAR CHART TO LEFT OF ZERO COLUMN. IF
C MSHLFT IS EQUAL TO ZERO, THEN GRID DIVISION
C WIDTH OF 10 IS ASSUMED. MSHLFT IS EQUAL TO
C ONE MORE THAN NUMBER OF COLUMNS OF
C CHARACTERS APPEARING BETWEEN EXCLAMATION
C POINTS OR PLUS SIGNS.
C
C MSHRIT = WIDTH OF GRID DIVISIONS INDICATED EITHER BY
C EXCLAMATION POINTS OR PLUS SIGNS IN PORTION
C OF BAR CHART TO RIGHT OF ZERO COLUMN. IF
C MSHRIT IS EQUAL TO ZERO, THEN GRID DIVISION
C WIDTH OF 10 IS ASSUMED. MSHRIT IS EQUAL TO
C ONE MORE THAN NUMBER OF COLUMNS OF
C CHARACTERS APPEARING BETWEEN EXCLAMATION
C POINTS OR PLUS SIGNS.
C
C LNGLFT = 0, BAR CHART IS NOT TO INCLUDE ANY COLUMNS
C TO LEFT OF ZERO COLUMN. THIS DOES NOT
C CHANGE WIDTH OF LEFT MARGIN SPECIFIED BY
C VALUE OF MARGIN.
C = GREATER THAN ZERO, LNGLFT IS NUMBER OF
C COLUMNS OF CHARACTERS TO BE INCLUDED IN BAR
C CHART TO LEFT OF ZERO COLUMN.
C
C LNGRIT = 0, BAR CHART IS NOT TO INCLUDE ANY COLUMNS
C TO RIGHT OF ZERO COLUMN.
C = GREATER THAN ZERO, LNGRIT IS NUMBER OF
C COLUMNS OF CHARACTERS TO BE INCLUDED IN BAR
C CHART TO RIGHT OF ZERO COLUMN.
C
C XLEFT = ACCUMULATED TOTAL OF SEGMNT VALUES HAVING
C SAME SIGN AS XLEFT WHICH IS TO BE
C REPRESENTED BY LEFT BORDER OF PORTION OF BAR
C CHART TO LEFT OF ZERO COLUMN IF LNGLFT IS
C GREATER THAN ZERO. IF XLEFT IS NEGATIVE,
C THEN ONLY NEGATIVE VALUES ARE REPRESENTED TO
C LEFT OF ZERO COLUMN. IF XLEFT IS POSITIVE,
C THEN ONLY POSITIVE VALUES ARE REPRESENTED TO
C LEFT OF ZERO COLUMN.
C
C XRIGHT = ACCUMULATED TOTAL OF SEGMNT VALUES HAVING
C SAME SIGN AS XRIGHT WHICH IS TO BE
C REPRESENTED BY RIGHT BORDER OF PORTION OF
C BAR CHART TO RIGHT OF ZERO COLUMN IF LNGRIT
C IS GREATER THAN ZERO. IF XRIGHT IS
C NEGATIVE, THEN ONLY NEGATIVE VALUES ARE
C REPRESENTED TO RIGHT OF ZERO COLUMN. IF
C XRIGHT IS POSITIVE, THEN ONLY POSITIVE
C VALUES ARE REPRESENTED TO RIGHT OF ZERO
C COLUMN.
C
C SEGMNT = ARRAY CONTAINING IN ARRAY LOCATIONS
C SEGMNT(MINSEG) THROUGH AND INCLUDING
C SEGMNT(MAXSEG) LENGTHS OF BAR SEGMENTS
C SPECIFIED IN SAME COORDINATE SYSTEMS AS USED
C FOR DEFINITIONS OF XLEFT AND XRIGHT. ZERO
C VALUES IN SEGMNT ARRAY ARE IGNORED.
C
C MINSEG = SUBSCRIPT OF FIRST LOCATION IN SEGMNT ARRAY
C WHICH CAN SPECIFY LENGTH OF BAR SEGMENT. IF
C MINSEG IS GREATER THAN MAXSEG, THEN NO BAR
C SEGMENTS WILL BE REPRESENTED.
C
C MAXSEG = SUBSCRIPT OF FINAL LOCATION IN SEGMNT ARRAY
C WHICH CAN SPECIFY LENGTH OF BAR SEGMENT.
C
C LETTER = ARRAY CONTAINING IN ARRAY LOCATIONS
C LETTER(MINLTR) THROUGH AND INCLUDING
C LETTER(MAXLTR) CHARACTERS BY WHICH BAR
C SEGMENTS ARE TO BE REPRESENTED, ONE
C CHARACTER PER LETTER ARRAY LOCATION AS
C THOUGH READ BY MULTIPLE OF A1 FORMAT OR
C DEFINED BY SEVERAL 1H FIELDS IN DATA
C STATEMENT. SEGMENT HAVING ITS LENGTH
C SPECIFIED BY SEGMNT(MINSEG) WILL BE
C REPRESENTED BY CHARACTER FOUND IN
C LETTER(MINLTR), THAT HAVING ITS LENGTH IN
C SEGMNT(MINSEG+1) BY CHARACTER IN
C LETTER(MINLTR+1), AND SO ON. IF
C MAXLTR-MINLTR IS LESS THAN MAXSEG-MINSEG,
C THEN ASSIGNMENT OF CHARACTERS RECYCLES
C THROUGH LETTER ARRAY AS MANY TIMES AS ARE
C NECESSARY TO REPRESENT ALL OF BAR SEGMENTS
C SO THAT SEGMENT HAVING ITS LENGTH SPECIFIED
C BY SEGMNT(MINSEG+MAXLTR-MINLTR+1) IS
C REPRESENTED BY CHARACTER IN LETTER(MINLTR),
C THAT HAVING ITS LENGTH IN
C SEGMNT(MINSEG+MAXLTR-MINLTR+2) BY CHARACTER
C IN LETTER(MINLTR+1), AND SO ON.
C
C MINLTR = SUBSCRIPT OF LETTER ARRAY LOCATION WHICH
C SPECIFIES CHARACTER TO BE USED FOR
C REPRESENTATION OF BAR SEGMENT HAVING ITS
C LENGTH IN SEGMNT(MINSEG).
C
C MAXLTR = SUBSCRIPT OF LETTER ARRAY LOCATION WHICH
C SPECIFIES CHARACTER TO BE USED FOR
C REPRESENTATION OF BAR SEGMENT HAVING ITS
C LENGTH IN SEGMNT(MINSEG+MAXLTR-MINLTR).
C
C YVALUE = NUMBER TO BE PLACED TO LEFT OF BAR CHART IF
C HUNDREDS DIGIT OF DECIMAL INTEGER VALUE OF
C IGRID HAS VALUE 1, 3 OR 5.
C
C LABEL = ARRAY CONTAINING IN ARRAY LOCATIONS
C LABEL(MINLBL) THROUGH AND INCLUDING
C LABEL(MAXLBL) CHARACTERS TO BE SHOWN TO LEFT
C OF BAR CHART IF HUNDREDS DIGIT OF DECIMAL
C INTEGER VALUE OF IGRID HAS VALUE 2, 4 OR 6.
C CHARACTERS IN LABEL ARRAY ARE STORED ONE
C CHARACTER PER ARRAY LOCATION AS THOUGH READ
C BY MULTIPLE OF A1 FORMAT OR DEFINED BY
C SEVERAL 1H FIELDS IN DATA STATEMENT.
C
C MINLBL = SUBSCRIPT OF LABEL ARRAY LOCATION CONTAINING
C LEFTMOST CHARACTER.
C
C MAXLBL = SUBSCRIPT OF LABEL ARRAY LOCATION CONTAINING
C RIGHTMOST CHARACTER.
C
C LINPRT = -1, THE PLOT IS NOT TO INCLUDE ANY CARRIAGE
C CONTROL CHARACTER AT LEFT END OF EACH LINE.
C = 0, PLOT WILL BE VIEWED BY USER ON TERMINAL,
C EITHER TYPED DIRECTLY WITH IDISK BEING GIVEN
C TERMINAL UNIT NUMBER, OR TYPED BY USER AFTER
C THIS ROUTINE HAS WRITTEN PLOT INTO FILE ON
C UNIT NUMBER OF WHICH IS CONTAINED IN IDISK.
C BLANK OR SPACE WILL BE USED AS CARRIAGE
C CONTROL CHARACTER TO GIVE SINGLE SPACING.
C = 1, PLOT WILL BE PRINTED ON LINE PRINTER BY
C USER AFTER PROGRAM HAS WRITTEN PLOT INTO
C FILE. ASTERISK WILL BE USED AS CARRIAGE
C CONTROL CHARACTER TO GIVE SINGLE SPACING
C WITH SUPPRESSION OF SKIPPING EXTRA LINES AT
C PAGE BOUNDARIES.
C
C IDISK = UNIT NUMBER OF DEVICE ONTO WHICH PLOTS ARE
C TO BE WRITTEN.
C
DIMENSION SEGMNT(MAXSEG),LETTER(MAXLTR),LABEL(MAXLBL)
COMMON/FASPE/LTRBUF(146)
DATA MAXBFR/146/
C
C IHRZNT = CHARACTER FOR HORIZONTAL LINES
C ISPACE = SPACE OF BLANK CHARACTER
C ISTAR = USED AS CHARIAGE CONTROL TO PREVENT EXTRA
C LINES AT PAGE BOUNDARIES
C IVRTCL = CHARACTER FOR VERTICAL LINES
C IZERO = ZERO USED UNDER CENTER LINE
C KORNER = CHARACTER WHERE HORIZONTAL AND VERTICAL
C LINES MEET
C
DATA IHRZNT,IVRTCL,KORNER,ISTAR,IZERO,ISPACE/
11H-,1H!,1H+,1H*,1H0,1H /
C
C JGRID = UNITS DIGIT
C LGRID = TENS DIGIT
C NGRID = HUNDREDS DIGIT
LGRID=IGRID/10
NGRID=IGRID/100
JGRID=IGRID-(10*LGRID)
LGRID=LGRID-(10*NGRID)
C
C UNPACK INDIVIDUAL SWITCHES FROM UNITS DIGIT OF IGRID
C
C KUNITS JUNITS IUNITS KUNITS JUNITS IUNITS
C 0 -1 0 0 5 0 0 1
C 1 -1 0 1 6 1 1 0
C 2 0 1 0 7 1 1 1
C 3 0 1 1 8 1 0 0
C 4 0 0 0 9 1 0 1
C
C KUNITS = -1, NEITHER RIGHT NOR INTERNAL GIRD LINES
C = 0, RIGHT, BUT NOT INTERNAL, GRID LINES
C = 1, BOTH RIGHT AND INTERNAL GRID LINES
C JUNITS = 0, RULE GRID LINES WITH PLUS SIGNS
C = 1, RULE GRID LINES WITH EXCLAMATION POINTS
C IUNITS = 0, INSERT SPACES BETWEEN GRID LINES
C = 1, INSERT MINUS SIGNS BETWEEN GRID LINES
C
JUNITS=JGRID/2
IUNITS=JGRID-(2*JUNITS)
JUNITS=JUNITS-(2*(JUNITS/2))
C
C ***************************************
C * *
C * CONSTRUCT CONTENTS OF LEFT MARGIN *
C * *
C ***************************************
C
C INSERT LEFT GRID LINE AND/OR LEFT MINUS SIGN
MAXPRT=0
IMRGN=MARGIN
IF(IMRGN.LT.0)IMRGN=0
IF(IMRGN.GT.MAXBFR)IMRGN=MAXBFR
IF(IMRGN.LE.0)GO TO 6
JRIGHT=IMRGN
IF(NGRID.LE.2)GO TO 1
LTRBUF(IMRGN)=ISPACE
JRIGHT=JRIGHT-1
IF(NGRID.LE.4)GO TO 1
LTRBUF(IMRGN)=IHRZNT
MAXPRT=IMRGN
1 IF(JRIGHT.LE.0)GO TO 6
IF(NGRID.GT.0)GO TO 3
C
C LINE NOT BEARING SCALE NUMBER
DO 2 I=1,JRIGHT
2 LTRBUF(I)=ISPACE
GO TO 6
C
C LINE BEARING SCALE NUMBER
3 IF(NGRID.EQ.(2*(NGRID/2)))GO TO 4
IF(MAXPRT.LT.JRIGHT)MAXPRT=JRIGHT
MINSIG=JRIGHT-2
IF(MINSIG.GT.5)MINSIG=5
IF(MINSIG.LE.0)MINSIG=1
CALL DARITE(YVALUE,1,0,0,1,
1-3,0,JRIGHT,-2,7,MINSIG,5,
20,0,4,0,0,-1,0,
3MAXBFR,LTRBUF,I,KERR)
GO TO 6
C
C BAR WITH LETTERS TO ITS LEFT
4 J=MAXLBL-JRIGHT
IF(J.GE.MINLBL)J=MINLBL-1
DO 5 I=1,JRIGHT
J=J+1
LTRBUF(I)=ISPACE
IF(J.LT.MINLBL)GO TO 5
IF(MAXPRT.LT.I)MAXPRT=I
LTRBUF(I)=LABEL(J)
5 CONTINUE
C
C ************************************
C * *
C * REPRESENT DATA AS BAR SEGMENTS *
C * *
C ************************************
C
C GET THE PLOT WIDTH AND MESH LINE WIDTH
6 LSTSET=KNDBAR-(3*(KNDBAR/3))-1
KNTLTR=IMRGN
INCR=-1
NWIDE=0
IWIDE=MSHLFT
IF(IWIDE.LE.0)IWIDE=10
LWIDE=LNGLFT
IF(LWIDE.LT.0)LWIDE=0
IF(LWIDE.GT.(MAXBFR-KNTLTR))LWIDE=MAXBFR-KNTLTR
JWIDE=IWIDE
MWIDE=LWIDE
IF(LWIDE.LE.0)GO TO 32
ARIGHT=XLEFT
KNTLTR=KNTLTR+LWIDE+1
GO TO 8
7 INCR=1
IWIDE=MSHRIT
IF(IWIDE.LE.0)IWIDE=10
LWIDE=LNGRIT
IF(LWIDE.LT.0)LWIDE=0
IF(LWIDE.GT.(MAXBFR-KNTLTR))LWIDE=MAXBFR-KNTLTR
IF(LWIDE.LE.0)GO TO 33
ARIGHT=XRIGHT
C
C INITIAL VALUES
8 WIDE=LWIDE
SCALE=WIDE/ARIGHT
TOTAL=0.0
COMPAR=0.0
BIGEST=0.0
KNTCLM=0
IBEGIN=0
NOWSEG=MINSEG
IF(KNDBAR.LT.0)GO TO 9
IF(LSTLIN.GE.0)GO TO 10
9 NOWSEG=MAXSEG+1
10 IF(JGRID.GT.5)GO TO 12
IF(JGRID.GT.1)GO TO 11
MRGLTR=LWIDE+1
GO TO 13
11 MRGLTR=IWIDE*(LWIDE/IWIDE)
GO TO 13
12 MRGLTR=0
C
C LOOP THROUGH ALL SEGMENTS IN THE BAR
13 NOWLTR=MINLTR
14 LSTONE=1
IF(NOWSEG.GT.MAXSEG)GO TO 24
ADDING=SCALE*SEGMNT(NOWSEG)
IF(ADDING.LE.0.0)GO TO 23
FORMER=TOTAL
TOTAL=TOTAL+ADDING
C
C TEST IF PRESENT BAR IS DOMINANT AT ITS LEFT END
FRACTN=TOTAL
IF(FRACTN.GT.COMPAR)FRACTN=COMPAR
FRACTN=FRACTN-FORMER
IF(IBEGIN.EQ.0)GO TO 17
IF(KNDBAR.LE.5)GO TO 15
IF(TOTAL.GT.COMPAR)GO TO 18
GO TO 16
15 IF(FRACTN.LE.BIGEST)GO TO 17
16 I=KNTLTR-INCR
IF(IREPLC.NE.0)LTRBUF(I)=LETTER(JREPLC)
IREPLC=0
GO TO 20
C
C INSERT LETTERS ALONG BAR
17 IF(TOTAL.LE.COMPAR)GO TO 22
18 FORMER=COMPAR
COMPAR=COMPAR+1.0
IF(IBEGIN.GE.LWIDE)GO TO 32
IF(LSTONE.LE.0)GO TO 21
IREPLC=0
19 KNTLTR=KNTLTR+INCR
IBEGIN=IBEGIN+1
IF(MAXPRT.LT.KNTLTR)MAXPRT=KNTLTR
IF(KNTCLM.LE.0)KNTCLM=IWIDE
KNTCLM=KNTCLM-1
BIGEST=0.0
20 LTRBUF(KNTLTR)=LETTER(NOWLTR)
LSTONE=LSTSET
JREPLC=NOWLTR
GO TO 17
21 IREPLC=1
IF(LSTONE.EQ.0)GO TO 27
LTRBUF(KNTLTR)=ISPACE
GO TO 19
C
C ALL DONE WITH THIS SEGMENT OF THE BAR
22 FRACTN=TOTAL-FORMER
IF(BIGEST.LT.FRACTN)BIGEST=FRACTN
23 NOWSEG=NOWSEG+1
NOWLTR=NOWLTR+1
IF(NOWLTR.LE.MAXLTR)GO TO 14
GO TO 13
C
C TEST IF FINAL CHARACTER IS TO BE ALLOWED
24 IF(KNDBAR.LE.2)GO TO 26
IF(KNDBAR.GT.5)GO TO 26
IF(IBEGIN.EQ.0)GO TO 26
IF(BIGEST.GE.(COMPAR-TOTAL))GO TO 26
I=KNTLTR-INCR
IF(IREPLC.NE.0)LTRBUF(I)=LETTER(JREPLC)
GO TO 27
C
C ******************************************
C * *
C * CONSTRUCT GRID LINES TO RIGHT OF BAR *
C * *
C ******************************************
C
25 IF(LSTONE.EQ.0)GO TO 19
26 IF(KNTCLM.LE.0)KNTCLM=IWIDE
KNTCLM=KNTCLM-1
IF(IBEGIN.GE.LWIDE)GO TO 32
KNTLTR=KNTLTR+INCR
IBEGIN=IBEGIN+1
27 IF(KNTCLM.GT.0)GO TO 29
IF(IBEGIN.LT.MRGLTR)GO TO 29
IF(JUNITS.EQ.0)GO TO 28
LTRBUF(KNTLTR)=IVRTCL
GO TO 30
28 LTRBUF(KNTLTR)=KORNER
GO TO 30
29 IF(IUNITS.EQ.0)GO TO 31
LTRBUF(KNTLTR)=IHRZNT
30 IF(MAXPRT.LT.KNTLTR)MAXPRT=KNTLTR
GO TO 25
31 LTRBUF(KNTLTR)=ISPACE
GO TO 25
C
C REVERSE DIRECTION FOR SECOND HALF
32 IF(INCR.GT.0)GO TO 33
KNTLTR=IMRGN+LWIDE
IF(KNTLTR.GE.MAXBFR)GO TO 7
IF(LGRID.LE.0)GO TO 7
KNTLTR=KNTLTR+1
NWIDE=1
LTRBUF(KNTLTR)=ISPACE
I=LGRID
IF(I.GT.4)I=I-4
IF(I.LE.1)GO TO 7
MAXPRT=KNTLTR
IF(I.EQ.2)LTRBUF(KNTLTR)=IHRZNT
IF(I.EQ.3)LTRBUF(KNTLTR)=IVRTCL
IF(I.GE.4)LTRBUF(KNTLTR)=KORNER
GO TO 7
C
C OUTPUT THE COMPLETED BAR
33 KONTRL=ISPACE
IF(LINPRT.GT.0)KONTRL=ISTAR
IF(LSTLIN.LT.0)GO TO 37
IF(LINPRT.GE.0)GO TO 34
IF(MAXPRT.LE.0)WRITE(IDISK,35)ISPACE
IF(MAXPRT.GT.0)WRITE(IDISK,35)(LTRBUF(I),I=1,MAXPRT)
GO TO 36
34 IF(MAXPRT.LE.0)WRITE(IDISK,35)KONTRL,ISPACE
IF(MAXPRT.GT.0)WRITE(IDISK,35)KONTRL,
1(LTRBUF(I),I=1,MAXPRT)
35 FORMAT(147A1)
C
C *****************************************************
C * *
C * CONSTRUCT AND PRINT NUMBERS FORMING LOWER SCALE *
C * *
C *****************************************************
C
C CONSTRUCT LINE CONTAINING TICK MARKS
36 IF(LSTLIN.GT.0)GO TO 57
37 IFINAL=IMRGN+MWIDE+LWIDE+NWIDE
IF(IFINAL.LE.IMRGN)GO TO 57
DO 38 I=1,IFINAL
38 LTRBUF(I)=ISPACE
KNTLTR=IMRGN+MWIDE+1
IF(NWIDE.EQ.0)GO TO 40
IF(LGRID.LE.4)GO TO 40
39 LTRBUF(KNTLTR)=IVRTCL
40 KNTLTR=KNTLTR-JWIDE
IF(KNTLTR.GT.IMRGN)GO TO 39
KNTLTR=IMRGN+MWIDE+NWIDE
41 KNTLTR=KNTLTR+IWIDE
IF(KNTLTR.GT.IFINAL)GO TO 42
LTRBUF(KNTLTR)=IVRTCL
GO TO 41
42 IF(LINPRT.LT.0)WRITE(IDISK,35)(LTRBUF(I),I=1,IFINAL)
IF(LINPRT.GE.0)WRITE(IDISK,35)KONTRL,
1(LTRBUF(I),I=1,IFINAL)
C
C CONSTRUCT LINE CONTAINING LOWER SCALE NUMBERS
LERR=-1
MAXPRT=0
IF(NWIDE.EQ.0)GO TO 43
IF(LGRID.LE.4)GO TO 43
MAXPRT=IMRGN+MWIDE+1
LTRBUF(MAXPRT)=IZERO
43 KIND=LERR
INCR=-1
IWIDTH=JWIDE
KNTLTR=1
WIDE=MWIDE
GO TO 45
44 INCR=1
IWIDTH=IWIDE
KNTLTR=NWIDE
WIDE=LWIDE
45 KNTLTR=KNTLTR+IWIDTH+IMRGN+MWIDE-1
IF(IWIDTH.GT.10)IWIDTH=10
JWIDTH=IWIDTH/2
KNTLTR=KNTLTR-JWIDTH
MINSIG=IWIDTH-2
IF(MINSIG.GT.5)MINSIG=5
IF(MINSIG.LE.0)MINSIG=1
I=0
NEED=KNTLTR
GO TO 48
46 IF(KNTLTR.LT.0)KNTLTR=0
CALL DARITE(VALUE,0,0,KIND,1,
1-3,0,IWIDTH,-2,-2,MINSIG,5,
20,0,4,0,0,-1,KNTLTR,
3MAXBFR,LTRBUF,KNTOUT,KERR)
IF(KERR.GT.0)LERR=1
KNTLTR=KNTOUT
IF(KIND.LE.0)GO TO 47
IF(KERR.EQ.0)GO TO 48
47 IF(MAXPRT.LT.KNTLTR)MAXPRT=KNTLTR
48 IF(INCR.GT.0)GO TO 51
I=I+JWIDE
49 IF(NEED.LE.KNTLTR)GO TO 50
KNTLTR=KNTLTR+1
LTRBUF(KNTLTR)=ISPACE
GO TO 49
50 IF(I.GT.MWIDE)GO TO 44
VALUE=XLEFT*FLOAT(I)/WIDE
KNTLTR=KNTLTR-JWIDE-JWIDE
NEED=KNTLTR+JWIDE
GO TO 46
51 I=I+IWIDE
IF(I.GT.LWIDE)GO TO 54
VALUE=XRIGHT*(FLOAT(I)/WIDE)
52 IF(NEED.LE.KNTLTR)GO TO 53
KNTLTR=KNTLTR+1
LTRBUF(KNTLTR)=ISPACE
GO TO 52
53 NEED=KNTLTR+IWIDE
GO TO 46
54 IF(MAXPRT.LE.0)GO TO 55
IF(LINPRT.LT.0)WRITE(IDISK,35)(LTRBUF(I),I=1,MAXPRT)
IF(LINPRT.GE.0)WRITE(IDISK,35)KONTRL,
1(LTRBUF(I),I=1,MAXPRT)
MAXPRT=0
55 IF(NWIDE.EQ.0)GO TO 56
I=IMRGN+MWIDE+1
LTRBUF(I)=ISPACE
56 IF(KIND.NE.LERR)GO TO 43
C
C ALL DONE WITH THIS LINE OF THE PLOT
57 RETURN
C922171101196!
END
SUBROUTINE DAHEST(KMDTYP,LSTTYP,NAMLOW,NAMMAX,MRKLOW,
1 MRKMAX,NUMLOW,NUMMAX,INTRVL,LOWWRD,MAXWRD,IWORD ,
2 LOWKNT,MAXKNT,KNTLTR,LEGAL ,MAXBFR,IBUFFR,LOWBFR,
3 KIND ,KOMAND,LCNWRD,LCNKNT,INIPRT,MIDPRT,LMTPRT,
4 NAMKNT,NAMLFT,NAMRIT,MRKKNT,MRKLFT,MRKRIT,NUMKNT,
5 NUMSIN,NUMVAL,VALNUM,IFLOAT)
C RENBR(/PARSER OF SIMPLE COMMANDS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAHEST AND DAIHST INTERPRET SIMPLE COMMANDS TYPED BY
C THE USER AND READ INTO A BUFFER ARRAY WITH A MULTIPLE
C OF AN A1 FORMAT. THE COMMANDS CONSIST OF A COMMAND
C WORD, OR UNIQUE ABREVIATION THEREOF, FOLLOWED BY AN
C ARGUMENT LIST FORMED OF NUMBERS, ALPHABETIC WORDS AND
C QUOTED TEXT STRINGS. THE LINE OF TEXT BEING
C EVALUATED CAN CONTAIN SEVERAL STATEMENTS IF THESE
C STATEMENTS ARE SEPARATED BY THE SEMICOLON CHARACTER.
C THE BUFFER CAN ALSO CONTAIN A COMMENT INDICATED BY AN
C EXCLAMATION POINT TO THE LEFT OF THE COMMENT.
C
C DAHEST OR DAIHST IS CALLED ONCE TO EVALUATE EACH
C STATEMENT. THE CALLING PROGRAM INDICATES TO THE
C ROUTINE THE POSITION IN THE BUFFER OF THE LEFTMOST
C CHARACTER WHICH HAS NOT YET BEEN EVALUATED. THE
C ROUTINE MOVES THIS POINTER THROUGH THE BUFFER AND
C RETURNS IT TO THE CALLING PROGRAM SPECIFYING THE
C LEFTMOST CHARACTER TO BE EVALUATED BY THE NEXT CALL
C TO THE ROUTINE. AFTER THIS ROUTINE HAS FINALLY
C INDICATED THAT NOTHING MORE REMAINS TO BE PROCESSED
C IN THE LINE OF TEXT CONTAINED IN THE BUFFER, THEN THE
C CALLING PROGRAM MUST READ ANOTHER LINE WHICH IS TO BE
C INTERPRETED, AND MUST RESET THE POINTER TO INDICATE
C THE START OF THE BUFFER BEFORE THE NEXT CALL TO THE
C ROUTINE.
C
C DAHEST CAN EVALUATE BOTH REAL NUMBERS AND INTEGERS.
C EITHER FORM CAN BE SPECIFIED IN FLOATING POINT FORMAT
C WITH FOLLOWING E EXPONENT OR WITH FOLLOWING %, K OR M
C TO INDICATE E-2, E3 AND E6 RESPECTIVELY. IF THE
C PROGRAM WHICH CALLS DAHEST DOES NOT REQUIRE THE
C EVALUATION OF REAL NUMBERS AND DOES NOT OTHERWISE
C CALL DAHEFT, AND IF THE SPECIFICATION OF INTEGERS IN
C EXPONENT FORM IS NOT NECESSARY, THEN THE ROUTINE
C DAIHST SHOULD BE CALLED INSTEAD OF DAHEST. ALTHOUGH
C THE ROUTINES ARE OF APPROXIMATELY THE SAME LENGTH,
C DAIHST DOES NOT CALL DAHEFT FOR NUMERIC EVALUATION.
C NUMBERS EVALUATED BY DAIHST MUST CONSIST ONLY OF
C DIGITS FOLLOWING THE OPTIONAL SIGN. NUMBERS CAN BE
C SEPARATED BY SLASHES (OR BY COLONS, THESE TWO
C CHARACTERS BEING EQUIVALENT) IF THEY ARE TO BE
C ASSOCIATED IN SOME MANNER, SUCH AS SPECIFYING A RANGE
C AND INCREMENT. BOTH THE SIGN AND THE SIGNED VALUE
C ARE RETURNED TO THE CALLING PROGRAM.
C
C TEXT STRINGS ARE PRECEDED AND FOLLOWED BY THE
C APOSTROPHE. IF AN APOSTROPHE MUST APPEAR IN THE TEXT
C STRING ITSELF, THEN AN EXTRA APPEARANCE OF THE
C APOSTROPHE MUST PRECEDE THE ONE WHICH IS TO BE
C TREATED MERELY AS TEXT. THE LOCATIONS OF THE START
C AND END OF THE TEXT INSIDE THE DELIMITING APOSTROPHES
C ARE RETURNED TO THE CALLING PROGRAM, AND THE EXTRA
C APOSTROPHES WITHIN THE TEXT STRING ARE EXPUNGED FROM
C THE INPUT BUFFER.
C
C TEXT STRINGS CAN ALSO BE DELIMITED BY PARENTHESES.
C IF THE TEXT STRING STARTS WITH A LEADING LEFT
C PARENTHESIS, THEN IT WILL BE TERMINATED BY A MATCHING
C TRAILING RIGHT PARENTHESIS. IF THE TEXT STRING
C STARTS WITH A LEADING RIGHT PARENTHESIS, THEN IT WILL
C BE TERMINATED BY A MATCHING TRAILING LEFT
C PARENTHESIS. WITHIN THE PARENTHESES, AN APOSTROPHE
C CAN APPEAR IN FRONT OF ANY CHARACTER, INCLUDING A
C PARENTHESIS OR ANOTHER APOSTROPHE, TO INDICATE THAT
C THIS FOLLOWING CHARACTER IS TO HAVE NO SPECIAL
C MEANING. IF FOUND, THE APOSTROPHE IS LEFT IN THE
C TEXT STRING. IF THE TYPE OF TEXT STRING HAS MEANING
C TO THE PROGRAM, THEN THE PROGRAM SHOULD TEST THE
C CHARACTER WHICH IS IMMEDIATELY TO THE LEFT OF THE
C CONTENTS OF THE TEXT STRING TO DETERIMINE WHETHER
C THIS IS AN APOSTROPHE OR A LEFT OR A RIGHT
C PARENTHESIS.
C
C A WORD APPEARING AS AN ARGUMENT OF A COMMAND MUST
C BEGIN WITH A CHARACTER WHICH CANNOT START A NUMBER
C AND WHICH IS NOT ONE OF THE DELIMITER CHARACTERS SUCH
C AS THE SPACE, TAB, SLASH, COLON, SEMICOLON,
C EXCLAMATION POINT, COMMA OR APOSTROPHE. DIGITS CAN
C APPEAR ANYWHERE TO THE RIGHT OF THE LEADING CHARACTER
C OF THE WORD, BUT THE OTHER PROHIBITED CHARACTERS
C WILL, IF ENCOUNTERED, TERMINATE THE WORD. THE
C LOCATIONS OF THE START AND END OF THE WORD ARE
C RETURNED TO THE CALLING PROGRAM.
C
C ONE, BUT ONLY ONE, OF THE THREE TYPES OF ARGUMENTS
C CAN BE USED MORE THAN ONCE AS AN ARGUMENT. IF THE
C TYPE OF ARGUMENT WHICH CAN BE REPEATED IS SPECIFIED
C BEFORE THE FIRST ARGUMENT IS FOUND, EITHER BEING THE
C SAME FOR ALL COMMANDS, OR ELSE BEING SPECIFIED
C SEPARATELY IN THE DICTIONARY FOR EACH COMMAND, THEN
C ARGUMENTS OF THE OTHER TWO TYPES CAN APPEAR AT MOST
C ONCE IN THE ARGUMENT LIST. IF THE REPEATABLE TYPE IS
C WORD OR TEXT STRING, THEN A SET OF NUMBERS INDICATING
C A RANGE CAN STILL BE SUPPLIED. IF THE REPEATABLE
C TYPE IS NUMERIC, THEN MORE THAN ONE SET OF NUMBERS
C INDICATING RANGES WILL BE ACCEPTED. ALTERNATIVELY,
C THE TYPE OF ARGUMENT WHICH CAN BE REPEATED CAN BE THE
C TYPE OF THE FIRST ARGUMENT ENCOUNTERED, IN WHICH CASE
C ARGUMENTS OF THE OTHER TWO TYPES ARE NOT ALLOWED IN
C THE ARGUMENT LIST.
C
C ANY NUMBER OF SPACES AND/OR TAB CHARACTERS CAN APPEAR
C BEFORE THE COMMAND WORD AND BETWEEN THE COMMAND WORD
C AND ITS FIRST ARGUMENT. SUCCESSIVE ARGUMENTS CAN BE
C SEPARATED BY A SINGLE COMMA AND/OR BY ANY NUMBER OF
C SPACES AND/OR TAB CHARACTERS. NO SEPARATING
C CHARACTERS ARE NECESSARY IF THE LEADING CHARACTER OF
C AN ARGUMENT INDICATES THAT IT CANNOT CONTINUE THE
C PRECEDING COMMAND WORD OR PRECEDING ARGUMENT. A
C SINGLE COMMA APPEARING BETWEEN 2 ARGUMENTS OF EITHER
C THE SAME OR OF DIFFERENT TYPES MERELY INDICATES THE
C SEPARATION BETWEEN THE ARGUMENTS, AND IS ENTIRELY
C EQUIVALENT TO ONE OR MORE SPACES AND/OR TAB
C CHARACTERS. TWO COMMAS, POSSIBLY SEPARATED BY SPACES
C AND/OR BY TAB CHARACTERS, INDICATE A MISSING ARGUMENT
C OF THE REPEATABLE TYPE. A COMMA BETWEEN THE COMMAND
C WORD AND THE FIRST ARGUMENT IS TAKEN TO INDICATE THAT
C THE FIRST ARGUMENT OF THE REPEATABLE TYPE IS MISSING.
C FOR EXAMPLE, IN THE STATEMENTS
C
C OPAQUE'=',,'*';INVISIBLE,'$'
C
C THE QUOTED TEXT CHARACTER * IS THE THIRD ARGUMENT OF
C THE COMMAND WORD OPAQUE, THE SECOND ARGUMENT BEING
C MISSING, AND THE QUOTED TEXT CHARACTER $ IS THE
C SECOND ARGUMENT OF THE COMMAND WORD INVISIBLE, THE
C FIRST ARGUMENT BEING MISSING.
C
C THE ARGUMENTS OF THE REPEATABLE TYPE ARE RETURNED TO
C THE CALLING PROGRAM IN THE ORDER IN WHICH THEY APPEAR
C IN THE STATEMENT, AND, IN PARTICULAR, THE CALLING
C PROGRAM IS ABLE TO DETERMINE WHETHER ANY ARE MISSING.
C NO INFORMATION REGARDING ORDERING BETWEEN ARGUMENTS
C OF DIFFERENT TYPES IS RETURNED TO THE CALLING
C PROGRAM.
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY, AND ARE
C RETURNED UNCHANGED.
C
C KMDTYP = 0, STATEMENT MUST START WITH COMMAND WORD.
C = 1, STATEMENT CAN START WITH COMMAND WORD OR
C INTEGER. IF INTEGER IS FOUND, RETURN VALUE
C AS NUMVAL AND LOCATIONS OF LEFT AND RIGHT
C ENDS OF FOLLOWING TEXT AS MIDPRT AND LMTPRT.
C = 2, STATEMENT CAN START WITH COMMAND WORD OR
C REAL NUMBER. IF REAL NUMBER IS FOUND,
C RETURN VALUE AS VALNUM AND LOCATIONS OF LEFT
C AND RIGHT ENDS OF FOLLOWING TEXT AS MIDPRT
C AND LMTPRT.
C = -1, DO NOT LOOK FOR COMMAND WORD. CONTENTS
C OF STATEMENT ARE EVALUATED AS ARGUMENT LIST
C OF TYPE INDICATED BY LSTTYP.
C LSTTYP = SPECIFIES TYPE OF ARGUMENT WHICH CAN APPEAR
C MORE THAN ONCE IN ARGUMENT LIST.
C = -1, TYPE OF ARGUMENT LIST IS SPECIFIED FOR
C EACH COMMAND BY LEGAL ARRAY VALUE PARALLEL
C TO CHARACTER COUNT IN KNTLTR ARRAY.
C = 0, NO ARGUMENTS ARE ALLOWED.
C = 1, TYPE OF ARGUMENT WHICH CAN BE REPEATED IS
C TYPE OF FIRST ARGUMENT ENCOUNTERED, WHETHER
C OR NOT THIS IS PRECEDED BY COMMAS. COMMAS
C DO, HOWEVER, INDICATE MISSING ARGUMENTS OF
C SAME TYPE AS THAT EVENTUALLY FOUND.
C ADDITIONAL ARGUMENTS OF TYPES OTHER THAN
C THAT OF FIRST ARGUMENT ENCOUNTERED ARE NOT
C ALLOWED. IF AN ADDITIONAL ARGUMENT OF
C ANOTHER TYPE IS FOUND, THEN EVALUATION OF
C ARGUMENT LIST WILL BE TERMINATED EXCEPT
C INSOFAR AS IS NECESSARY TO DETECT END OF
C STATEMENT, AND KIND WILL BE RETURNED
C CONTAINING ONE OF VALUES 8, 9 OR 10
C INDICATING TYPE OF ILLEGAL ARGUMENT. IF A
C SET OF NUMBERS IS FOUND, IT IS EVALUATED AS
C A SET OF INTEGERS.
C = 2, ALLOW SERIES OF WORDS. TEXT STRING OR
C SET OF INTEGERS CAN APPEAR AT MOST ONCE.
C = 3, ALLOW SERIES OF SETS OF INTEGERS. TEXT
C STRING OR WORD CAN APPEAR AT MOST ONCE.
C = 4, ALLOW SERIES OF TEXT STRINGS. WORD OR
C SET OF INTEGERS CAN APPEAR AT MOST ONCE.
C = 5, 6, 7 AND 8, SAME AS LSTTYP VALUES OF 1,
C 2, 3 AND 4 RESPECTIVELY, EXCEPT THAT IF A
C NUMBER IS FOUND, IT IS EVALUATED AS REAL
C NUMBER AND ITS VALUE IS RETURNED IN VALNUM
C ARRAY, RATHER THAN IN NUMVAL ARRAY.
C = 9, ONLY TYPE OF ARGUMENT ACCEPTED WILL BE
C PARENTHETICAL TEXT STRINGS, NOT TEXT STRINGS
C DELIMITED BY APOSTROPHES. PRINTING
C CHARACTERS IMMEDIATELY TO LEFT OF
C PARENTHETICAL EXPRESSION WILL BE TAKEN TO BE
C PART OF THAT EXPRESSION, AND MRKLFT WILL
C POINT TO LEFTMOST OF THESE. UNLIKE TEXT
C STRINGS ALLOWED BY ANY OTHER VALUE OF
C LSTTYP, LEADING PARENTHESIS IS POINTED TO BY
C MRKLFT IF NO PRINTING CHARACTERS APPEAR TO
C ITS LEFT. MRKRIT WILL STILL BE RETURNED
C POINTING TO CHARACTER TO LEFT OF TRAILING
C PARENTHESIS.
C NAMLOW = SUBSCRIPT OF NAMLFT AND NAMRIT ARRAY
C LOCATIONS TO BE RETURNED WITH DESCRIPTION OF
C FIRST WORD IN ARGUMENT LIST.
C NAMMAX = MAXIMUM SUBSCRIPT OF NAMLFT AND NAMRIT
C ARRAYS.
C MRKLOW = SUBSCRIPT OF MRKLFT AND MRKRIT ARRAY
C LOCATIONS TO BE RETURNED WITH DESCRIPTION OF
C FIRST TEXT STRING IN ARGUMENT LIST.
C MRKMAX = MAXIMUM SUBSCRIPT OF MRKLFT AND MRKRIT
C ARRAYS.
C NUMLOW = SUBSCRIPT OF NUMSIN, NUMVAL AND VALNUM ARRAY
C LOCATIONS TO BE RETURNED WITH DESCRIPTION OF
C FIRST NUMBER IN ARGUMENT LIST.
C NUMMAX = MAXIMUM SUBSCRIPT OF NUMSIN, NUMVAL AND
C VALNUM ARRAYS.
C INTRVL = MAXIMUM NUMBER OF NUMBERS IN SET OF NUMBERS
C SEPARATED BY SLASHES. IF 2 NUMERIC
C ARGUMENTS ARE SEPARATED BY SOMETHING OTHER
C THAN SLASH, THEN THESE ARGUMENTS ARE PART OF
C SERIES OF SETS OF NUMBERS, AND DESCRIPTION
C OF SECOND NUMBER IS PLACED INTO NUMSIN,
C NUMVAL AND VALNUM ARRAYS AT LOCATION HAVING
C SUBSCRIPT GREATER BY VALUE OF INTRVL THAN
C SUBSCRIPT OF LOCATION INTO WHICH WAS PLACED
C DESCRIPTION OF FIRST NUMBER OF PREVIOUS SET.
C LOWWRD = SUBSCRIPT OF LOCATION IN IWORD ARRAY WHICH
C CONTAINS 1ST LETTER OF 1ST WORD. NOTE THAT
C IF KNTLTR(LOWKNT) IS NEGATIVE, THEN THE 1ST
C LETTER OF 1ST WORD WILL BE FOUND IN ARRAY
C LOCATION IWORD(LOWWRD-KNTLTR(LOWKNT)).
C MAXWRD = DIMENSION OF IWORD ARRAY.
C IWORD = DICTIONARY ARRAY CONTAINING CHARACTERS OF
C COMMAND WORDS WHICH ARE TO BE RECOGNIZED, 1
C CHARACTER PER ARRAY LOCATION AS READ BY A1
C FORMAT OR ELSE DEFINED BY 1H FIELD. COMMAND
C WORD IN INPUT BUFFR ARRAY IBUFFR CAN BE
C SPLIT INTO 2 OR MORE PORTIONS SEPARATED BY
C SPACES AND/OR TABS AND WILL BE MATCHED
C WHETHER OR NOT SPACES OR TABS ARE PRESENT IF
C WORD IN IWORD CONTAINS A SINGLE SPACE AT
C LOCATION AT WHICH SPLIT IS ALLOWED. IN
C ORDER TO OBTAIN A MATCH, CASES OF CHARACTERS
C IN DICTIONARY AND IN INPUT BUFFER MUST BE
C IDENTICAL. NOTE ALSO, THAT LETTERS E, M AND
C K USED WITHIN NUMBERS TO INDICATE EXPONENTS
C MUST BE IN UPPER CASE IN INPUT BUFFER IN
C ORDER TO BE RECOGNIZED.
C LOWKNT = SUBSCRIPT OF KNTLTR ARRAY CONTAINING LENGTH
C OF FIRST WORD WHICH CAN BE MATCHED IN IWORD
C ARRAY. THIS FIRST WORD WILL START AT
C IWORD(LOWWRD).
C MAXKNT = SUBSCRIPT OF KNTLTR ARRAY CONTAINING LENGTH
C OF FINAL WORD WHICH CAN BE MATCHED IN IWORD
C ARRAY.
C KNTLTR = ARRAY CONTAINING NUMBERS OF CHARACTERS IN
C WORDS IN IWORD ARRAY. ZERO OR NEGATIVE
C VALUE IN KNTLTR ARRAY OFFSETS NEXT POSSIBLE
C WORD WHICH CAN BE MATCHED IN IWORD ARRAY BY
C NUMBER OF LETTERS GIVEN BY ABSOLUTE VALUE OF
C NEGATIVE NUMBER IN KNTLTR ARRAY. DIMENSION
C OF KNTLTR MUST BE AT LEAST MAXKNT. FOR
C EXAMPLE TO RECOGNIZE WORDS
C
C YES, NO, MAYBE
C
C CONTENTS OF IWORD ARRAY WOULD BE
C
C 1HY,1HE,1HS,1HN,1HO,1HM,1HA,1HY,1HB,1HE
C
C AND CONTENTS OF KNTLTR ARRAY WOULD BE
C
C 3,2,5
C
C LEGAL = IF LSTTYP=-1, THEN LEGAL IS ARRAY SPECIFYING
C FOR EACH POSSIBLE COMMAND WORD THE TYPE OF
C NUMERIC ARGUMENTS, REAL OR INTEGER, WITH CAN
C BE EVALUATED, AND TYPE OF ARGUMENT, WORD OR
C SET OF NUMBERS OR TEXT STRING, WHICH CAN BE
C PRESENT MORE THAN ONCE IN ARGUMENT LIST.
C TYPE OF ARGUMENT LIST IS AT SAME SUBSCRIPT
C IN LEGAL ARRAY AS CHARACTER COUNT IN KNTLTR
C ARRAY. IF LSTTYP IS GREATER THAN OR EQUAL
C TO ZERO, THEN CONTENTS OF LEGAL ARRAY ARE
C IGNORED.
C = 0, NO ARGUMENTS ARE ALLOWED.
C = 1, TYPE OF ARGUMENT WHICH CAN BE REPEATED IS
C TYPE OF FIRST ARGUMENT ENCOUNTERED, WHETHER
C OR NOT THIS IS PRECEDED BY COMMAS. COMMAS
C DO, HOWEVER, INDICATE MISSING ARGUMENTS OF
C SAME TYPE AS THAT EVENTUALLY FOUND.
C ADDITIONAL ARGUMENTS OF TYPES OTHER THAN
C THAT OF FIRST ARGUMENT ENCOUNTERED ARE NOT
C ALLOWED. IF AN ADDITIONAL ARGUMENT OF
C ANOTHER TYPE IS FOUND, THEN EVALUATION OF
C ARGUMENT LIST WILL BE TERMINATED EXCEPT
C INSOFAR AS IS NECESSARY TO DETECT END OF
C STATEMENT, AND KIND WILL BE RETURNED
C CONTAINING ONE OF VALUES 8, 9 OR 10
C INDICATING TYPE OF ILLEGAL ARGUMENT. IF A
C SET OF NUMBERS IS FOUND, IT IS EVALUATED AS
C A SET OF INTEGERS.
C = 2, ALLOW SERIES OF WORDS. TEXT STRING OR
C SET OF INTEGERS CAN APPEAR AT MOST ONCE.
C = 3, ALLOW SERIES OF SETS OF INTEGERS. TEXT
C STRING OR WORD CAN APPEAR AT MOST ONCE.
C = 4, ALLOW SERIES OF TEXT STRINGS. WORD OR
C SET OF INTEGERS CAN APPEAR AT MOST ONCE.
C = 5, 6, 7 AND 8, SAME AS LEGAL ARRAY VALUES OF
C 1, 2, 3 AND 4 RESPECTIVELY, EXCEPT THAT IF
C NUMBER IS FOUND, IT IS EVALUATED AS REAL
C NUMBER AND ITS VALUE IS RETURNED IN VALNUM
C ARRAY, RATHER THAN IN NUMVAL ARRAY.
C = 9, ONLY TYPE OF ARGUMENT ACCEPTED WILL BE
C PARENTHETICAL TEXT STRINGS, NOT TEXT STRINGS
C DELIMITED BY APOSTROPHES. PRINTING
C CHARACTERS IMMEDIATELY TO LEFT OF
C PARENTHETICAL EXPRESSION WILL BE TAKEN TO BE
C PART OF THAT EXPRESSION, AND MRKLFT WILL
C POINT TO LEFTMOST OF THESE. UNLIKE TEXT
C STRINGS ALLOWED BY ANY OTHER VALUE OF
C LEGAL, LEADING PARENTHESIS IS POINTED TO BY
C MRKLFT IF NO PRINTING CHARACTERS APPEAR TO
C ITS LEFT. MRKRIT WILL STILL BE RETURNED
C POINTING TO CHARACTER TO LEFT OF TRAILING
C PARENTHESIS.
C MAXBFR = SUBSCRIPT OF IBUFFR ARRAY LOCATION
C CONTAINING RIGHTMOST CHARACTER IN CURRENT
C LINE.
C
C FOLLOWING ARGUMENTS ARE USED FOR BOTH INPUT AND
C OUTPUT.
C
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS OF
C LINE BEING INTERPRETED, ONE CHARACTER PER
C ARRAY LOCATION, AS READ BY MULTIPLE OF A1
C FORMAT. IF QUOTED TEXT STRING ITSELF
C CONTAINING APOSTROPHES IS FOUND IN IBUFFR
C ARRAY, THEN EXTRA APOSTROPHES NEEDED TO MARK
C APOSTROPHES TO REMAIN IN TEXT ARE REMOVED BY
C SHIFTING TO LEFT TEXT TO THEIR RIGHT.
C LOWBFR = SUBSCRIPT IN IBUFFR ARRAY OF FIRST CHARACTER
C TO BE INTERPRETED. LOWBFR IS RETURNED
C POINTING TO FIRST CHARACTER BEYOND
C INTERPRETED STATEMENT. IF SEMICOLON APPEARS
C AT END OF STATEMENT, THEN LOWBFR IS RETURNED
C POINTING TO SEMICOLON AND WILL BE ADVANCED
C BEYOND SEMICOLON BY SUBSEQUENT CALL TO THIS
C ROUTINE. IF EXCLAMATION POINT APPEARS AT
C END OF STATEMENT, OR IF THERE ARE NO MORE
C PRINTING CHARACTERS TO RIGHT OF STATEMENT,
C THEN LOWBFR IS RETURNED CONTAINING MAXBFR+1.
C KIND = MUST BE SET TO ZERO BY CALLING PROGRAM
C BEFORE THIS ROUTINE IS FIRST CALLED TO
C EVALUATE LINE OF TEXT. KIND IS THEN
C RETURNED DESCRIBING TYPE OF STATEMENT WHICH
C WAS EVALUATED. CALLING PROGRAM SHOULD RESET
C KIND TO HAVE VALUE ZERO IF EVALUATION OF
C CONTENTS OF LINE OF TEXT IS BEING ABANDONED
C BY CALLING PROGRAM BEFORE THIS ROUTINE HAS
C INDICATED BY RETURNING KIND=1 THAT IT HAS
C COMPLETED EVALUATION OF LINE OF TEXT.
C EXCEPT FOR THIS INSTANCE IN WHICH
C INTERPRETATION IS BEING ABANDONED BY CALLING
C PROGRAM, VALUE OF KIND IS OTHERWISE PASSED
C UNCHANGED TO SUBSEQUENT CALL TO THIS
C ROUTINE.
C = 1, (PROCESSING COMPLETED) RETURNED IF
C PREVIOUS CALLS TO THIS ROUTINE HAVE
C COMPLETED EVALUATION OF CONTENTS OF LINE OF
C TEXT. CALLING PROGRAM SHOULD READ NEW LINE
C OF TEXT AND RESET LOWBFR TO POINT TO FIRST
C CHARACTER IN NEW TEXT.
C = 2, (EMPTY STATEMENT) RETURNED IF ORIGINAL
C LINE OF TEXT CONTAINED NO PRINTING
C CHARACTERS OR CONTAINED LEADING EXCLAMATION
C POINT INDICATING THAT CHARACTERS TO ITS
C RIGHT FORMED COMMENT. KIND IS ALSO RETURNED
C SET TO 2 IF EXTRA SEMICOLON INDICATES
C MISSING STATEMENT.
C = 3, (CORRECT STATEMENT) RETURNED IF STATEMENT
C WAS NOT EMPTY AND WAS EVALUATED WITHOUT
C ERRORS. IF KMDTYP IS GREATER THAN OR EQUAL
C TO ZERO, THEN KNOWN COMMAND WORD, OR ELSE
C NONAMBIGUOUS ABBREVIATION THEREOF, WAS FOUND
C AND SEQUENCE NUMBER OF THIS COMMAND WORD
C WITHIN DICTIONARY IS RETURNED AS VALUE OF
C KOMAND. IF KMDTYP IS LESS THAN ZERO, THEN
C KOMAND IS RETURNED WITH VALUE ZERO, AND
C STATEMENT CONTAINED AT LEAST COMMA, SLASH,
C COLON OR ARGUMENT.
C = 4, (INITIAL NUMBER) RETURNED IF KMDTYP IS
C GREATER THAN ZERO, AND IF NUMBER WAS FOUND
C AT START OF STATEMENT. MIDPRT IS RETURNED
C CONTAINING SUBSCRIPT WITHIN IBUFFR ARRAY OF
C CHARACTER TO IMMEDIATE RIGHT OF NUMBER.
C LMTPRT IS RETURNED CONTAINING SUBSCRIPT
C WITHIN IBUFFR ARRAY OF RIGHTMOST PRINTING
C CHARACTER WITHIN IBUFFR ARRAY.
C = 5, (MISSING COMMAND) RETURNED IF COMMAND
C WORD OR ELSE LEADING NUMBER WAS REQUIRED BUT
C NOT FOUND, BUT STATEMENT IS NOT EMPTY. NO
C ARGUMENT DESCRIPTIONS ARE RETURNED TO
C CALLING PROGRAM.
C = 6, (UNKNOWN COMMAND) RETURNED IF INITIAL
C COMMAND WORD WAS REQUIRED, BUT STATEMENT
C STARTS WITH SEQUENCE OF PRINTING CHARACTERS
C WHICH COULD FORM COMMAND WORD, BUT WHICH DO
C NOT MATCH WORD IN DICTIONARY, OR WHICH FORM
C AMBIGUOUS ABBREVIATION OF 2 OR MORE WORDS IN
C DICTIONARY, OR WHICH DO MATCH SINGLE WORD IN
C DICTIONARY BUT ARE FOLLOWED IMMEDIATELY BY
C ADDITIONAL ALPHABETIC CHARACTERS OR DIGITS.
C INIPRT AND MIDPRT ARE RETURNED POINTING TO
C LEFTMOST AND RIGHTMOST CHARACTERS IN THIS
C UNKNOWN COMMAND WORD. NO ARGUMENT
C DESCRIPTIONS ARE RETURNED TO CALLING
C PROGRAM.
C = 7, 8, 9 OR 10 RETURNED IF MAXIMUM NUMBER OF
C ARGUMENTS OF SINGLE TYPE WAS EXCEEDED IN
C ARGUMENT LIST. DESCRIPTION OF ARGUMENT
C WHICH EXCEEDED LIMIT, AS WELL AS
C DESCRIPTIONS OF ANY ARGUMENTS TO ITS RIGHT,
C ARE NOT RETURNED TO CALLING PROGRAM,
C ALTHOUGH SCANNING OF STATEMENT CONTINUES TO
C DETERMINE ITS RIGHT END.
C = 7, RETURNED IF TOO MANY SLASHES OR COLONS
C WERE ENCOUNTERED IN SET OF NUMBERS.
C = 8, RETURNED IF TOO MANY WORDS WERE FOUND.
C = 9, RETURNED IF TOO MANY SETS OF NUMBERS WERE
C FOUND.
C = 10, RETURNED IF TOO MANY TEXT STRINGS WERE
C FOUND.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT. THEIR
C INPUT VALUES ARE IGNORED.
C
C KOMAND = IF KIND IS RETURNED CONTAINING 3 OR RETURNED
C CONTAINING 7 OR GREATER, THEN KOMAND IS
C SEQUENCE NUMBER OF COMMAND WORD MATCHED IN
C IWORD ARRAY. IF SECOND COMMAND WORD IS
C MATCHED, THEN KOMAND IS RETURNED CONTAINING
C 2. SEQUENCE NUMBER DOES NOT INCLUDE LETTERS
C SKIPPED OVER BY VALUE OF LOWWRD, AND DOES
C NOT INCLUDE LETTERS SKIPPED OVER BY NEGATIVE
C VALUES IN KNTLTR ARRAY. IF COMMAND WORD IN
C IWORD ARRAY IS MATCHED, THEN KOMAND IS
C NUMBER OF VALUES IN KNTLTR ARRAY WHICH ARE
C GREATER THAN ZERO STARTING AT KNTLTR(LOWKNT)
C UP TO AND INCLUDING KNTLTR LOCATION WHICH
C CONTAINS NUMBER OF LETTERS IN COMMAND WORD
C WHICH IS SUCCESSFULLY MATCHED.
C = RETURNED CONTAINING ZERO IF A COMMAND WORD
C WAS NOT MATCHED.
C LCNWRD = IF KIND IS RETURNED CONTAINING EITHER 3 OR 7
C OR GREATER AND KOMAND BEING RETURNED GREATER
C THAN ZERO, LCNWRD IS RETURNED CONTAINING
C SUBSCRIPT OF IWORD LOCATION CONTAINING FIRST
C LETTER OF MATCHED WORD. LCNWRD IS UNDEFINED
C IF KOMAND IS RETURNED CONTAINING ZERO.
C LCNKNT = IF KIND IS RETURNED CONTAINING EITHER 3 OR 7
C OR GREATER AND KOMAND BEING RETURNED GREATER
C THAN ZERO, LNCKNT IS RETURNED CONTAINING
C SUBSCRIPT OF KNTLTR LOCATION CONTAINING WORD
C LENGTH. LCNKNT IS UNDEFINED IF KOMAND IS
C RETURNED CONTAINING ZERO.
C INIPRT = RETURNED CONTAINING SUBSCRIPT OF IBUFFR
C ARRAY LOCATION CONTAINING LEFTMOST PRINTING
C CHARACTER IN STATEMENT IF KIND IS RETURNED
C CONTAINING 3 OR GREATER. INIPRT IS RETURNED
C UNDEFINED IF KIND IS RETURNED SET TO EITHER
C 1 OR 2.
C = IF KIND IS RETURNED CONTAINING 6 INDICATING
C THAT UNKNOWN COMMAND WORD WAS FOUND AT START
C OF STATEMENT, THEN INIPRT IS RETURNED
C POINTING TO LEFT CHARACTER OF UNKNOWN
C COMMAND WORD. MIDPRT WILL THEN BE RETURNED
C POINTING TO RIGHT CHARACTER OF UNKNOWN
C COMMAND WORD.
C MIDPRT = RETURNED UNDEFINED IF KIND IS RETURNED
C CONTAINING ANY VALUE OTHER THAN 4 OR 6.
C = IF KMDTYP WAS INPUT GREATER THAN ZERO
C ALLOWING INITIAL NUMBER IN PLACE OF INITIAL
C COMMAND WORD, AND IF SUCH INITIAL NUMBER WAS
C FOUND SO THAT KIND IS RETURNED CONTAINING 4,
C THEN MIDPRT IS RETURNED POINTING TO
C CHARACTER TO IMMEDIATE RIGHT OF NUMBER.
C LMTPRT WILL THEN BE RETURNED POINTING TO
C RIGHTMOST PRINTING CHARACTER ON LINE.
C = IF KIND IS RETURNED CONTAINING 6 INDICATING
C THAT UNKNOWN COMMAND WORD WAS FOUND AT START
C OF STATEMENT, THEN MIDPRT IS RETURNED
C POINTING TO RIGHT CHARACTER OF UNKNOWN
C COMMAND WORD.
C LMTPRT = RETURNED CONTAINING SUBSCRIPT OF IBUFFR
C ARRAY LOCATION CONTAINING RIGHTMOST PRINTING
C CHARACTER IN STATEMENT IF KIND IS RETURNED
C CONTAINING 3 OR GREATER. IF STATEMENT IS
C FOLLOWED BY EITHER SEMICOLON OR EXCLAMATION
C POINT, THEN LMTPRT IS RETURNED POINTING TO
C RIGHTMOST PRINTING CHARACTER TO LEFT OF
C SEMICOLON OR EXCLAMATION POINT. LMTPRT IS
C RETURNED UNDEFINED IF KIND IS RETURNED SET
C TO EITHER 1 OR 2.
C = IF KMDTYP WAS INPUT GREATER THAN ZERO
C ALLOWING INITIAL NUMBER IN PLACE OF INITIAL
C COMMAND WORD, AND IF SUCH INITIAL NUMBER WAS
C FOUND SO THAT KIND IS RETURNED CONTAINING 4,
C THEN LMTPRT IS RETURNED POINTING TO
C RIGHTMOST PRINTING CHARACTER IN BUFFER.
C NAMKNT = RETURNED CONTAINING HIGHEST SUBSCRIPT USED
C IN NAMLFT AND NAMRIT ARRAYS TO STORE
C LOCATIONS IN BUFFER OF ENDS OF WORDS IN
C ARGUMENT LIST. IF NO WORDS ARE FOUND THEN
C NAMKNT IS RETURNED CONTAINING NAMLOW-1.
C NAMLFT = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C IBUFFR ARRAY OF LOCATIONS CONTAINING LEFT
C CHARACTERS OF WORDS IN ARGUMENT LIST. IF
C SERIES OF WORDS IS ENABLED BUT SOME ARE
C INDICATED AS MISSING BY EXTRA COMMAS IN
C ARGUMENT LIST, THEN FOR THESE MISSING WORDS
C NAMRIT ARRAY WILL CONTAIN VALUES LESS THAN
C THOSE IN NAMLFT ARRAY.
C NAMRIT = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C IBUFFR ARRAY OF LOCATIONS CONTAINING RIGHT
C CHARACTERS OF WORDS IN ARGUMENT LIST.
C MRKKNT = RETURNED CONTAINING HIGHEST SUBSCRIPT USED
C IN MRKLFT AND MRKRIT ARRAYS TO STORE
C LOCATIONS IN BUFFER OF ENDS OF QUOTED TEXT
C STRINGS IN ARGUMENT LIST. IF NO QUOTED TEXT
C STRINGS ARE FOUND THEN MRKKNT IS RETURNED
C CONTAINING MRKLOW-1.
C MRKLFT = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C IBUFFR ARRAY OF LOCATIONS CONTAINING LEFT
C CHARACTERS OF QUOTED TEXT STRINGS.
C CHARACTER POINTED TO BY MRKLFT IS CHARACTER
C TO IMMEDIATE RIGHT OF INITIAL APOSTROPHE OR
C OF INITIAL PARENTHESIS. IF LSTTYP=9, OR IF
C LSTTYP=-1 AND LEGAL=9, THEN MRKLFT POINTS TO
C LEFTMOST PRINTING CHARACTER LEFT OF OPENING
C PARENTHESIS OR TO OPENING PARENTHESIS ITSELF
C IF NOT PRECEDED BY ANY OTHER PRINTING
C CHARACTERS. IF SERIES OF TEXT STRINGS IS
C ENABLED BUT SOME ARE INDICATED AS MISSING BY
C EXTRA COMMAS IN ARGUMENT LIST, THEN FOR
C THESE MISSING TEXT STRINGS MRKRIT ARRAY WILL
C CONTAIN VALUES 2 LESS THAN THOSE IN MRKLFT.
C MRKRIT = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C IBUFFR ARRAY OF LOCATIONS CONTAINING RIGHT
C CHARACTERS OF QUOTED TEXT STRINGS IN
C ARGUMENT LIST. CHARACTER POINTED TO BY
C MRKRIT ARRAY IS CHARACTER TO IMMEDIATE LEFT
C OF FINAL APOSTROPHE OR OF FINAL PARENTHESIS
C AT RIGHT END OF QUOTED TEXT STRING, OR IS
C RIGHTMOST PRINTING CHARACTER ON LINE IF NO
C FINAL APOSTROPHE OR FINAL PARENTHESIS IS
C FOUND.
C NUMKNT = RETURNED CONTAINING HIGHEST SUBSCRIPT USED
C IN NUMSIN, NUMVAL AND VALNUM ARRAYS TO STORE
C DESCRIPTION OF NUMERIC ARGUMENTS FOUND IN
C ARGUMENT LIST. IF NO NUMERIC ARGUMENTS ARE
C FOUND IN ARGUMENT LIST, THEN NUMKNT IS
C RETURNED CONTAINING NUMLOW-1.
C NUMSIN = ARRAY RETURNED INDICATING SIGN, IF ANY,
C WHICH PRECEDED EACH NUMERIC ARGUMENT. VALUE
C OF ARGUMENT IS RETURNED IN NUMVAL OR VALNUM
C ARRAY LOCATION HAVING SAME SUBSCRIPT AS
C NUMSIN ARRAY LOCATION DESCRIBING SIGN.
C = -1, CORRESPONDING NUMERIC ARGUMENT WAS
C INDICATED AS MISSING EITHER BY ABSENCE OF
C NUMBER BEFORE SLASH OR COLON, BY ABSENCE OF
C NUMBER AFTER SLASH OR COLON, OR BY ABSENCE
C OF NUMBER BETWEEN SLASHES OR COLONS.
C CORRESPONDING VALUE IN NUMVAL OR VALNUM
C ARRAY IS RETURNED SET TO ZERO.
C = 0, RETURNED IF CORRESPONDING NUMERIC
C ARGUMENT WAS INDICATED AS MISSING BY LESS
C THAN INTRVL NUMBERS BEING INCLUDED IN SET OF
C NUMBERS, OR BY 2 ADJACENT COMMAS IN ARGUMENT
C LIST.
C = 1, NUMERIC ARGUMENT WAS EVALUATED, BUT NO
C SIGN APPEARED TO ITS LEFT.
C = 2, MINUS SIGN APPEARED TO LEFT OF NUMERIC
C ARGUMENT.
C = 3, PLUS SIGN APPEARED TO LEFT OF NUMERIC
C ARGUMENT.
C NUMVAL = ARRAY RETURNED CONTAINING VALUES OF NUMERIC
C ARGUMENTS EVALUATED AS INTEGERS. IF MINUS
C SIGN PRECEDED NUMBER, THEN VALUE IN NUMVAL
C IS NEGATIVE.
C VALNUM = ARRAY RETURNED CONTAINING VALUES OF NUMERIC
C ARGUMENTS EVALUATED AS REAL NUMBERS. IF
C MINUS SIGN PRECEDED NUMBER, THEN VALUE IN
C VALNUM IS NEGATIVE.
C IFLOAT = RETURNED DESCRIBING WHETHER NUMERIC
C ARGUMENTS WERE EVALUATED AS INTEGERS OR REAL
C NUMBERS.
C = 0, RETURNED IF NUMERIC ARGUMENTS WERE
C EVALUATED AS INTEGERS. VALUES OF NUMERIC
C ARGUMENTS ARE RETURNED IN NUMVAL ARRAY.
C = 1, RETURNED IF NUMERIC ARGUMENTS WERE
C EVALUATED AS REAL NUMBERS. VALUES OF
C NUMERIC ARGUMENTS ARE RETURNED IN VALNUM
C ARRAY.
C
DIMENSION IDIGIT(10),ISEPAR(13),IBUFFR(MAXBFR),
1IWORD(MAXWRD),KNTLTR(MAXKNT),LEGAL(MAXKNT),
2NAMLFT(NAMMAX),NAMRIT(NAMMAX),MRKLFT(MRKMAX),
3MRKRIT(MRKMAX),NUMSIN(NUMMAX),NUMVAL(NUMMAX),
4VALNUM(NUMMAX)
C
EQUIVALENCE(IBLANK,ISEPAR(1)),(ITAB,ISEPAR(2)),
1 (IQUOTE,ISEPAR(6)),(ILEFT,ISEPAR(7)),
2 (IRIGHT,ISEPAR(8)),(ISLASH,ISEPAR(9)),
3 (ICOLON,ISEPAR(10)),(IPLUS,ISEPAR(11)),
4 (IMINUS,ISEPAR(12)),(IDOT,ISEPAR(13))
C
C FIRST CHARACTER IN ISEPAR ARRAY IS SPACE. SECOND
C CHARACTER IS TAB CHARACTER. IF TAB CHARACTER IS NOT
C AVAILABLE, THEN SECOND CHARACTER SHOULD BE SPACE ALSO
DATA ISEPAR/1H ,1H ,
11H!,1H;,1H,,1H',1H(,1H),1H/,1H:,1H+,1H-,1H./
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C SET DEFAULT ARGUMENT COUNTS TO ZERO
NUMKNT=NUMLOW-1
MRKKNT=MRKLOW-1
NAMKNT=NAMLOW-1
INIKND=KIND
C
C **********************
C * *
C * SCAN FOR COMMAND *
C * *
C **********************
C
C LOOK FOR FIRST PRINTING CHARACTER
GO TO 3
1 INIKND=0
2 LOWBFR=LOWBFR+1
3 IF(LOWBFR.GT.MAXBFR)GO TO 90
IF(IBUFFR(LOWBFR).EQ.IBLANK)GO TO 2
IF(IBUFFR(LOWBFR).EQ.ITAB)GO TO 2
INIPRT=LOWBFR
MULTPL=LSTTYP
IF(KMDTYP.LT.0)GO TO 6
C
C TEST IF SEQUENCE OF PRINTING CHARACTERS IN DICTIONARY
INILTR=LOWBFR
CALL DAVERB(LOWWRD,MAXWRD,IWORD,LOWKNT,MAXKNT,
1KNTLTR,IBUFFR,MAXBFR,LOWBFR,KIND,KOMAND,LCNWRD,
2LCNKNT,LCNBFR)
LMTPRT=LOWBFR-1
C
C ENTIRE DICTIONARY HAS BEEN SEARCHED
IF(KIND.GE.3)GO TO 4
C NO COMMAND WORD, CHECK FOR LEADING NUMBER
ISTATE=-1
MULTPL=3
IF(KMDTYP.GE.2)MULTPL=7
GO TO 7
C GET ARGUMENT LIST TYPE IF IN LEGAL ARRAY
4 IF(LSTTYP.EQ.-1)MULTPL=LEGAL(LCNKNT)
IF(KIND.LE.4)GO TO 5
C AMBIGUOUS ABREVIATION, CHECK FOR REST OF WORD IF ANY
KIND=-1
GO TO 8
C COMMAND FOUND BUT IS ERROR IF ADDITIONAL CHARACTERS
5 ISTATE=0
GO TO 7
C NO COMMAND WAS TESTED FOR, SIMULATE LEADING SPACE
6 ISTATE=1
KOMAND=0
7 KIND=0
C
C MULTPL = -3, ALLOW NO ARGUMENTS
C = -2, ALLOW MULTIPLE ARGUMENTS OF 1ST TYPE
C FOUND
C = -1, ALLOW MULTIPLE WORDS
C = 0, ALLOW MULTIPLE NUMBERS
C = 1, ALLOW MULTIPLE STRINGS
C
8 JMLTPL=MULTPL-8
LIMIT=13
IF(JMLTPL.GT.0)LIMIT=8
MULTPL=MULTPL-3
IF(MULTPL.LE.1)GO TO 9
MULTPL=MULTPL-4
IFLOAT=1
GO TO 10
9 IFLOAT=0
10 IF(MULTPL.GE.-1)GO TO 11
IF(MULTPL.LE.-3)IFLOAT=1
NUMBLK=0
MRKNXT=MRKKNT
NAMNXT=NAMKNT
NUMNXT=NUMKNT
NOTYET=0
GO TO 12
11 NUMBLK=1
NUMNXT=NUMLOW
MRKNXT=MRKLOW
NAMNXT=NAMLOW
12 NUMNOW=NUMNXT
IF(KIND.LT.0)GO TO 71
GO TO 16
C
C ************************
C * *
C * SCAN FOR ARGUMENTS *
C * *
C ************************
C
C ISTATE = -1, NOTHING OR SPACE FOUND. WILL ACCEPT
C ONLY A LEADING NUMBER.
C = 0, COMMAND FOUND, BUT NOT YET ANYTHING,
C EVEN SPACES, AFTER IT.
C = 1, NO COMMAND WAS LOOKED FOR, ONLY SPACES
C HAVE YET BEEN FOUND, NOTHING ELSE
C = 2, COMMA FOUND ANYWHERE, OR ELSE COMMAND
C FOUND FOLLOWED BY SPACE. ANOTHER COMMA WILL
C INDICATE A MISSING ARGUMENT.
C = 3, TERMINATED SINGLE ITEM
C
C SPACE OR TAB CHARACTER FOUND
13 IF(ISTATE.NE.0)GO TO 15
14 ISTATE=2
C
C TEST IF NEXT CHARACTER BEGINS ARGUMENT OR PUNCTUATION
15 LOWBFR=LOWBFR+1
16 IF(LOWBFR.GT.MAXBFR)GO TO 89
KOMPAR=IBUFFR(LOWBFR)
DO 17 I=1,LIMIT
IF(KOMPAR.NE.ISEPAR(I))GO TO 17
GO TO(13,13,89,91,83,19,31,31,59,59,45,46,47),I
17 CONTINUE
IF(JMLTPL.GT.0)GO TO 70
IF(ISTATE.EQ.0)GO TO 72
DO 18 I=1,10
IF(KOMPAR.EQ.IDIGIT(I))GO TO 47
18 CONTINUE
GO TO 70
C
C ************************
C * *
C * QUOTED TEXT STRING *
C * *
C ************************
C
C APOSTROPHE STARTS TEXT STRING
19 IF(JMLTPL.GT.0)GO TO 26
INILTR=LOWBFR+1
I=LOWBFR
LMTPRT=LOWBFR
20 IF(I.GE.MAXBFR)GO TO 22
I=I+1
LOWBFR=LOWBFR+1
IBUFFR(LOWBFR)=IBUFFR(I)
IF(IBUFFR(I).EQ.IBLANK)GO TO 20
IF(IBUFFR(I).EQ.ITAB)GO TO 20
LMTPRT=LOWBFR
IF(IBUFFR(I).NE.IQUOTE)GO TO 20
IF(I.GE.MAXBFR)GO TO 21
IF(IBUFFR(I+1).NE.IQUOTE)GO TO 21
I=I+1
GO TO 20
21 NONSPC=LMTPRT-1
GO TO 23
22 NONSPC=LMTPRT
23 IF(LOWBFR.EQ.I)GO TO 39
KOPY=LOWBFR
24 IF(KOPY.GE.MAXBFR)GO TO 39
KOPY=KOPY+1
IF(I.GE.MAXBFR)GO TO 25
I=I+1
IBUFFR(KOPY)=IBUFFR(I)
GO TO 24
25 IBUFFR(KOPY)=IBLANK
GO TO 24
C
C SECTION PRIOR TO PARENTHETICAL EXPRESSION
26 INILTR=LOWBFR
27 KOMPAR=IBUFFR(LOWBFR)
DO 28 I=1,8
IF(KOMPAR.NE.ISEPAR(I))GO TO 28
IF(I.LT.6)GO TO 30
IF(I.GT.6)GO TO 32
IF(LOWBFR.LT.MAXBFR)LOWBFR=LOWBFR+1
GO TO 29
28 CONTINUE
29 LMTPRT=LOWBFR
NONSPC=LOWBFR
IF(LOWBFR.GE.MAXBFR)GO TO 39
LOWBFR=LOWBFR+1
GO TO 27
30 LOWBFR=LOWBFR-1
GO TO 39
C
C PARENTHESIS STARTS TEXT STRING
31 INILTR=LOWBFR
IF(JMLTPL.LE.0)INILTR=INILTR+1
32 LEVEL=0
GO TO 34
33 IF(LOWBFR.GE.MAXBFR)GO TO 38
LOWBFR=LOWBFR+1
34 KOMPAR=IBUFFR(LOWBFR)
IF(KOMPAR.EQ.IBLANK)GO TO 33
IF(KOMPAR.EQ.ITAB)GO TO 33
LMTPRT=LOWBFR
IF(KOMPAR.EQ.ILEFT)GO TO 35
IF(KOMPAR.EQ.IRIGHT)GO TO 36
IF(KOMPAR.NE.IQUOTE)GO TO 33
IF(LOWBFR.GE.MAXBFR)GO TO 38
LOWBFR=LOWBFR+1
LMTPRT=LOWBFR
GO TO 33
35 LEVEL=LEVEL+1
GO TO 37
36 LEVEL=LEVEL-1
37 IF(LEVEL.NE.0)GO TO 33
NONSPC=LMTPRT-1
GO TO 39
38 NONSPC=LMTPRT
C
C STORE THE TEXT STRING
39 IF(ISTATE.LT.0)KIND=5
IF(KIND.NE.0)GO TO 44
IF(MULTPL.NE.-2)GO TO 40
MULTPL=1
MRKNXT=MRKLOW+NOTYET
40 IF(MRKKNT.GE.MRKNXT)GO TO 41
IF(MRKNXT.LE.MRKMAX)GO TO 42
41 KIND=10
GO TO 44
42 MRKKNT=MRKKNT+1
IF(MRKKNT.GE.MRKNXT)GO TO 43
MRKLFT(MRKKNT)=1
MRKRIT(MRKKNT)=-1
GO TO 42
43 MRKLFT(MRKKNT)=INILTR
MRKRIT(MRKKNT)=NONSPC
IF(MULTPL.EQ.0)GO TO 44
IF(NUMKNT.GE.NUMLOW)NUMBLK=0
44 ISTATE=3
IF(MULTPL.GT.0)GO TO 86
GO TO 15
C
C ****************************
C * *
C * NUMBER OR NUMBER RANGE *
C * *
C ****************************
C
C PLUS SIGN STARTS NUMBER
45 ISIGN=3
GO TO 48
C
C MINUS SIGN STARTS NUMBER
46 ISIGN=2
GO TO 48
C
C DIGIT OR PERIOD STARTS NUMBER
47 ISIGN=1
C
C EVALUATE NUMBER
48 CALL DAHEFT(IFLOAT,1,0,IBUFFR,MAXBFR,
1LOWBFR,IDUMMY,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2VALUE)
C
C STORE EVALUATED NUMBER
IF(KIND.NE.0)GO TO 58
IF(ISTATE.GE.0)GO TO 49
IF(KMDTYP.LE.0)GO TO 52
49 IF(MULTPL.NE.-2)GO TO 50
NUMBLK=1
MULTPL=0
NUMNXT=NUMLOW+(NOTYET*INTRVL)
NUMNOW=NUMNXT
50 IF(NUMKNT.GE.NUMNOW)GO TO 51
IF(NUMNOW.LE.NUMMAX)GO TO 53
51 KIND=9
GO TO 58
52 KIND=5
GO TO 58
53 NUMKNT=NUMKNT+1
IF(NUMKNT.GE.NUMNOW)GO TO 55
NUMSIN(NUMKNT)=0
IF(NUMKNT.GE.NUMNXT)NUMSIN(NUMKNT)=-1
IF(IFLOAT.NE.0)GO TO 54
NUMVAL(NUMKNT)=0
GO TO 53
54 VALNUM(NUMKNT)=0.0
GO TO 53
55 NUMSIN(NUMKNT)=ISIGN
IF(IFLOAT.NE.0)GO TO 56
NUMVAL(NUMKNT)=IVALUE
GO TO 57
56 VALNUM(NUMKNT)=VALUE
57 IF(ISTATE.LT.0)GO TO 87
58 IF(LOWBFR.GT.MAXBFR)GO TO 69
KOMPAR=IBUFFR(LOWBFR)
IF(KOMPAR.EQ.ISLASH)GO TO 59
IF(KOMPAR.NE.ICOLON)GO TO 68
C
C SLASH FOUND
59 IF(KIND.NE.0)GO TO 62
IF(ISTATE.GE.0)GO TO 60
KIND=5
GO TO 62
60 IF(MULTPL.NE.-2)GO TO 61
NUMBLK=1
MULTPL=0
NUMNXT=NUMLOW+(NOTYET*INTRVL)
NUMNOW=NUMNXT
61 NUMNOW=NUMNOW+NUMBLK
IF(NUMNOW.GE.(NUMNXT+INTRVL))KIND=7
62 LOWBFR=LOWBFR+1
IF(LOWBFR.GT.MAXBFR)GO TO 69
KOMPAR=IBUFFR(LOWBFR)
IF(KOMPAR.EQ.IPLUS)GO TO 45
IF(KOMPAR.EQ.IMINUS)GO TO 46
IF(KOMPAR.EQ.IDOT)GO TO 47
IF(KOMPAR.EQ.ISLASH)GO TO 59
IF(KOMPAR.EQ.ICOLON)GO TO 59
DO 63 I=1,10
IF(KOMPAR.NE.IDIGIT(I))GO TO 63
NUMBER=I-1
GO TO 47
63 CONTINUE
C
C END OF RANGE SPECIFICATION
IF(KIND.NE.0)GO TO 68
IF(NUMKNT.GE.NUMNOW)GO TO 64
IF(NUMNOW.LE.NUMMAX)GO TO 65
64 KIND=9
GO TO 68
65 NUMKNT=NUMKNT+1
IF(IFLOAT.NE.0)GO TO 66
NUMVAL(NUMKNT)=0
GO TO 67
66 VALNUM(NUMKNT)=0.0
67 NUMSIN(NUMKNT)=0
IF(NUMKNT.GE.NUMNXT)NUMSIN(NUMKNT)=-1
IF(NUMKNT.LT.NUMNOW)GO TO 65
68 IF(MULTPL.NE.0)NUMBLK=0
69 LOWBFR=LOWBFR-1
LMTPRT=LOWBFR
ISTATE=3
IF(MULTPL.EQ.0)GO TO 85
GO TO 15
C
C **********
C * *
C * WORD *
C * *
C **********
C
C SEARCH FOR END OF WORD
70 IF(ISTATE.LE.0)GO TO 72
IF(JMLTPL.GT.0)GO TO 26
INILTR=LOWBFR
GO TO 73
71 LOWBFR=LOWBFR-1
72 KIND=-1
73 IF(LOWBFR.GE.MAXBFR)GO TO 76
LOWBFR=LOWBFR+1
KOMPAR=IBUFFR(LOWBFR)
DO 74 I=1,13
IF(KOMPAR.EQ.ISEPAR(I))GO TO 75
74 CONTINUE
GO TO 73
75 LOWBFR=LOWBFR-1
C
C STORE DESCRIPTION OF WORD
76 LMTPRT=LOWBFR
IF(KIND.EQ.0)GO TO 77
IF(KIND.GT.0)GO TO 82
KIND=6
MIDPRT=LMTPRT
GO TO 82
77 IF(MULTPL.NE.-2)GO TO 78
MULTPL=-1
NAMNXT=NAMLOW+NOTYET
78 IF(NAMKNT.GE.NAMNXT)GO TO 79
IF(NAMNXT.LE.NAMMAX)GO TO 80
79 KIND=8
GO TO 82
80 NAMKNT=NAMKNT+1
IF(NAMKNT.GE.NAMNXT)GO TO 81
NAMLFT(NAMKNT)=1
NAMRIT(NAMKNT)=0
GO TO 80
81 NAMLFT(NAMKNT)=INILTR
NAMRIT(NAMKNT)=LMTPRT
IF(MULTPL.EQ.0)GO TO 82
IF(NUMKNT.GE.NUMLOW)NUMBLK=0
82 ISTATE=3
IF(MULTPL.LT.0)GO TO 84
GO TO 15
C
C ***********************
C * *
C * PUNCTUATION MARKS *
C * *
C ***********************
C
C COMMA FOUND
83 LMTPRT=LOWBFR
IF(ISTATE.LT.0)KIND=5
IF(ISTATE.EQ.3)GO TO 14
ISTATE=2
IF(MULTPL.GT.0)GO TO 86
IF(MULTPL.EQ.0)GO TO 85
IF(MULTPL.EQ.-1)GO TO 84
NOTYET=NOTYET+1
GO TO 15
C
C INCREMENT SEQUENCE NUMBER OF NEXT SERIES ITEM
84 NAMNXT=NAMNXT+1
GO TO 15
85 NUMNXT=NUMNXT+INTRVL
NUMNOW=NUMNXT
GO TO 15
86 MRKNXT=MRKNXT+1
GO TO 15
C
C INITIAL NUMBER FOUND
87 KIND=4
MIDPRT=LOWBFR
LOWBFR=MAXBFR+1
LMTPRT=LOWBFR
88 LMTPRT=LMTPRT-1
IF(LMTPRT.LT.MIDPRT)GO TO 95
IF(IBUFFR(LMTPRT).EQ.IBLANK)GO TO 88
IF(IBUFFR(LMTPRT).EQ.ITAB)GO TO 88
GO TO 95
C
C COMMENT
89 LOWBFR=MAXBFR+1
IF(ISTATE.EQ.-1)GO TO 90
IF(ISTATE.NE.1)GO TO 94
90 IF(INIKND.LE.1)GO TO 93
KIND=1
GO TO 95
C
C SEMICOLON
91 IF(ISTATE.EQ.-1)GO TO 92
IF(ISTATE.NE.1)GO TO 94
92 IF(INIKND.GT.1)GO TO 1
93 KIND=2
GO TO 95
C
C RETURN TO CALLING PROGRAM
94 IF(KIND.GE.7)GO TO 96
IF(KIND.NE.0)GO TO 95
KIND=3
GO TO 96
95 KOMAND=0
96 RETURN
C395642931348!;':
END
SUBROUTINE DAIHST(KMDTYP,LSTTYP,NAMLOW,NAMMAX,MRKLOW,
1 MRKMAX,NUMLOW,NUMMAX,INTRVL,LOWWRD,MAXWRD,IWORD ,
2 LOWKNT,MAXKNT,KNTLTR,LEGAL ,MAXBFR,IBUFFR,LOWBFR,
3 KIND ,KOMAND,LCNWRD,LCNKNT,INIPRT,MIDPRT,LMTPRT,
4 NAMKNT,NAMLFT,NAMRIT,MRKKNT,MRKLFT,MRKRIT,NUMKNT,
5 NUMSIN,NUMVAL)
C RENBR(/PARSER OF SIMPLE COMMANDS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAHEST AND DAIHST INTERPRET SIMPLE COMMANDS TYPED BY
C THE USER AND READ INTO A BUFFER ARRAY WITH A MULTIPLE
C OF AN A1 FORMAT. THE COMMANDS CONSIST OF A COMMAND
C WORD, OR UNIQUE ABREVIATION THEREOF, FOLLOWED BY AN
C ARGUMENT LIST FORMED OF NUMBERS, ALPHABETIC WORDS AND
C QUOTED TEXT STRINGS. THE LINE OF TEXT BEING
C EVALUATED CAN CONTAIN SEVERAL STATEMENTS IF THESE
C STATEMENTS ARE SEPARATED BY THE SEMICOLON CHARACTER.
C THE BUFFER CAN ALSO CONTAIN A COMMENT INDICATED BY AN
C EXCLAMATION POINT TO THE LEFT OF THE COMMENT.
C
C DAHEST OR DAIHST IS CALLED ONCE TO EVALUATE EACH
C STATEMENT. THE CALLING PROGRAM INDICATES TO THE
C ROUTINE THE POSITION IN THE BUFFER OF THE LEFTMOST
C CHARACTER WHICH HAS NOT YET BEEN EVALUATED. THE
C ROUTINE MOVES THIS POINTER THROUGH THE BUFFER AND
C RETURNS IT TO THE CALLING PROGRAM SPECIFYING THE
C LEFTMOST CHARACTER TO BE EVALUATED BY THE NEXT CALL
C TO THE ROUTINE. AFTER THIS ROUTINE HAS FINALLY
C INDICATED THAT NOTHING MORE REMAINS TO BE PROCESSED
C IN THE LINE OF TEXT CONTAINED IN THE BUFFER, THEN THE
C CALLING PROGRAM MUST READ ANOTHER LINE WHICH IS TO BE
C INTERPRETED, AND MUST RESET THE POINTER TO INDICATE
C THE START OF THE BUFFER BEFORE THE NEXT CALL TO THE
C ROUTINE.
C
C DAHEST CAN EVALUATE BOTH REAL NUMBERS AND INTEGERS.
C EITHER FORM CAN BE SPECIFIED IN FLOATING POINT FORMAT
C WITH FOLLOWING E EXPONENT OR WITH FOLLOWING %, K OR M
C TO INDICATE E-2, E3 AND E6 RESPECTIVELY. IF THE
C PROGRAM WHICH CALLS DAHEST DOES NOT REQUIRE THE
C EVALUATION OF REAL NUMBERS AND DOES NOT OTHERWISE
C CALL DAHEFT, AND IF THE SPECIFICATION OF INTEGERS IN
C EXPONENT FORM IS NOT NECESSARY, THEN THE ROUTINE
C DAIHST SHOULD BE CALLED INSTEAD OF DAHEST. ALTHOUGH
C THE ROUTINES ARE OF APPROXIMATELY THE SAME LENGTH,
C DAIHST DOES NOT CALL DAHEFT FOR NUMERIC EVALUATION.
C NUMBERS EVALUATED BY DAIHST MUST CONSIST ONLY OF
C DIGITS FOLLOWING THE OPTIONAL SIGN. NUMBERS CAN BE
C SEPARATED BY SLASHES (OR BY COLONS, THESE TWO
C CHARACTERS BEING EQUIVALENT) IF THEY ARE TO BE
C ASSOCIATED IN SOME MANNER, SUCH AS SPECIFYING A RANGE
C AND INCREMENT. BOTH THE SIGN AND THE SIGNED VALUE
C ARE RETURNED TO THE CALLING PROGRAM.
C
C TEXT STRINGS ARE PRECEDED AND FOLLOWED BY THE
C APOSTROPHE. IF AN APOSTROPHE MUST APPEAR IN THE TEXT
C STRING ITSELF, THEN AN EXTRA APPEARANCE OF THE
C APOSTROPHE MUST PRECEDE THE ONE WHICH IS TO BE
C TREATED MERELY AS TEXT. THE LOCATIONS OF THE START
C AND END OF THE TEXT INSIDE THE DELIMITING APOSTROPHES
C ARE RETURNED TO THE CALLING PROGRAM, AND THE EXTRA
C APOSTROPHES WITHIN THE TEXT STRING ARE EXPUNGED FROM
C THE INPUT BUFFER.
C
C TEXT STRINGS CAN ALSO BE DELIMITED BY PARENTHESES.
C IF THE TEXT STRING STARTS WITH A LEADING LEFT
C PARENTHESIS, THEN IT WILL BE TERMINATED BY A MATCHING
C TRAILING RIGHT PARENTHESIS. IF THE TEXT STRING
C STARTS WITH A LEADING RIGHT PARENTHESIS, THEN IT WILL
C BE TERMINATED BY A MATCHING TRAILING LEFT
C PARENTHESIS. WITHIN THE PARENTHESES, AN APOSTROPHE
C CAN APPEAR IN FRONT OF ANY CHARACTER, INCLUDING A
C PARENTHESIS OR ANOTHER APOSTROPHE, TO INDICATE THAT
C THIS FOLLOWING CHARACTER IS TO HAVE NO SPECIAL
C MEANING. IF FOUND, THE APOSTROPHE IS LEFT IN THE
C TEXT STRING. IF THE TYPE OF TEXT STRING HAS MEANING
C TO THE PROGRAM, THEN THE PROGRAM SHOULD TEST THE
C CHARACTER WHICH IS IMMEDIATELY TO THE LEFT OF THE
C CONTENTS OF THE TEXT STRING TO DETERIMINE WHETHER
C THIS IS AN APOSTROPHE OR A LEFT OR A RIGHT
C PARENTHESIS.
C
C A WORD APPEARING AS AN ARGUMENT OF A COMMAND MUST
C BEGIN WITH A CHARACTER WHICH CANNOT START A NUMBER
C AND WHICH IS NOT ONE OF THE DELIMITER CHARACTERS SUCH
C AS THE SPACE, TAB, SLASH, COLON, SEMICOLON,
C EXCLAMATION POINT, COMMA OR APOSTROPHE. DIGITS CAN
C APPEAR ANYWHERE TO THE RIGHT OF THE LEADING CHARACTER
C OF THE WORD, BUT THE OTHER PROHIBITED CHARACTERS
C WILL, IF ENCOUNTERED, TERMINATE THE WORD. THE
C LOCATIONS OF THE START AND END OF THE WORD ARE
C RETURNED TO THE CALLING PROGRAM.
C
C ONE, BUT ONLY ONE, OF THE THREE TYPES OF ARGUMENTS
C CAN BE USED MORE THAN ONCE AS AN ARGUMENT. IF THE
C TYPE OF ARGUMENT WHICH CAN BE REPEATED IS SPECIFIED
C BEFORE THE FIRST ARGUMENT IS FOUND, EITHER BEING THE
C SAME FOR ALL COMMANDS, OR ELSE BEING SPECIFIED
C SEPARATELY IN THE DICTIONARY FOR EACH COMMAND, THEN
C ARGUMENTS OF THE OTHER TWO TYPES CAN APPEAR AT MOST
C ONCE IN THE ARGUMENT LIST. IF THE REPEATABLE TYPE IS
C WORD OR TEXT STRING, THEN A SET OF NUMBERS INDICATING
C A RANGE CAN STILL BE SUPPLIED. IF THE REPEATABLE
C TYPE IS NUMERIC, THEN MORE THAN ONE SET OF NUMBERS
C INDICATING RANGES WILL BE ACCEPTED. ALTERNATIVELY,
C THE TYPE OF ARGUMENT WHICH CAN BE REPEATED CAN BE THE
C TYPE OF THE FIRST ARGUMENT ENCOUNTERED, IN WHICH CASE
C ARGUMENTS OF THE OTHER TWO TYPES ARE NOT ALLOWED IN
C THE ARGUMENT LIST.
C
C ANY NUMBER OF SPACES AND/OR TAB CHARACTERS CAN APPEAR
C BEFORE THE COMMAND WORD AND BETWEEN THE COMMAND WORD
C AND ITS FIRST ARGUMENT. SUCCESSIVE ARGUMENTS CAN BE
C SEPARATED BY A SINGLE COMMA AND/OR BY ANY NUMBER OF
C SPACES AND/OR TAB CHARACTERS. NO SEPARATING
C CHARACTERS ARE NECESSARY IF THE LEADING CHARACTER OF
C AN ARGUMENT INDICATES THAT IT CANNOT CONTINUE THE
C PRECEDING COMMAND WORD OR PRECEDING ARGUMENT. A
C SINGLE COMMA APPEARING BETWEEN 2 ARGUMENTS OF EITHER
C THE SAME OR OF DIFFERENT TYPES MERELY INDICATES THE
C SEPARATION BETWEEN THE ARGUMENTS, AND IS ENTIRELY
C EQUIVALENT TO ONE OR MORE SPACES AND/OR TAB
C CHARACTERS. TWO COMMAS, POSSIBLY SEPARATED BY SPACES
C AND/OR BY TAB CHARACTERS, INDICATE A MISSING ARGUMENT
C OF THE REPEATABLE TYPE. A COMMA BETWEEN THE COMMAND
C WORD AND THE FIRST ARGUMENT IS TAKEN TO INDICATE THAT
C THE FIRST ARGUMENT OF THE REPEATABLE TYPE IS MISSING.
C FOR EXAMPLE, IN THE STATEMENTS
C
C OPAQUE'=',,'*';INVISIBLE,'$'
C
C THE QUOTED TEXT CHARACTER * IS THE THIRD ARGUMENT OF
C THE COMMAND WORD OPAQUE, THE SECOND ARGUMENT BEING
C MISSING, AND THE QUOTED TEXT CHARACTER $ IS THE
C SECOND ARGUMENT OF THE COMMAND WORD INVISIBLE, THE
C FIRST ARGUMENT BEING MISSING.
C
C THE ARGUMENTS OF THE REPEATABLE TYPE ARE RETURNED TO
C THE CALLING PROGRAM IN THE ORDER IN WHICH THEY APPEAR
C IN THE STATEMENT, AND, IN PARTICULAR, THE CALLING
C PROGRAM IS ABLE TO DETERMINE WHETHER ANY ARE MISSING.
C NO INFORMATION REGARDING ORDERING BETWEEN ARGUMENTS
C OF DIFFERENT TYPES IS RETURNED TO THE CALLING
C PROGRAM.
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY, AND ARE
C RETURNED UNCHANGED.
C
C KMDTYP = 0, STATEMENT MUST START WITH COMMAND WORD.
C = 1, STATEMENT CAN START WITH COMMAND WORD OR
C INTEGER. IF INTEGER IS FOUND, RETURN VALUE
C AS NUMVAL AND LOCATIONS OF LEFT AND RIGHT
C ENDS OF FOLLOWING TEXT AS MIDPRT AND LMTPRT.
C = 2, SAME AS KMDTYP=1.
C = -1, DO NOT LOOK FOR COMMAND WORD. CONTENTS
C OF STATEMENT ARE EVALUATED AS ARGUMENT LIST
C OF TYPE INDICATED BY LSTTYP.
C LSTTYP = SPECIFIES TYPE OF ARGUMENT WHICH CAN APPEAR
C MORE THAN ONCE IN ARGUMENT LIST.
C = -1, TYPE OF ARGUMENT LIST IS SPECIFIED FOR
C EACH COMMAND BY LEGAL ARRAY VALUE PARALLEL
C TO CHARACTER COUNT IN KNTLTR ARRAY.
C = 0, NO ARGUMENTS ARE ALLOWED.
C = 1, TYPE OF ARGUMENT WHICH CAN BE REPEATED IS
C TYPE OF FIRST ARGUMENT ENCOUNTERED, WHETHER
C OR NOT THIS IS PRECEDED BY COMMAS. COMMAS
C DO, HOWEVER, INDICATE MISSING ARGUMENTS OF
C SAME TYPE AS THAT EVENTUALLY FOUND.
C ADDITIONAL ARGUMENTS OF TYPES OTHER THAN
C THAT OF FIRST ARGUMENT ENCOUNTERED ARE NOT
C ALLOWED. IF AN ADDITIONAL ARGUMENT OF
C ANOTHER TYPE IS FOUND, THEN EVALUATION OF
C ARGUMENT LIST WILL BE TERMINATED EXCEPT
C INSOFAR AS IS NECESSARY TO DETECT END OF
C STATEMENT, AND KIND WILL BE RETURNED
C CONTAINING ONE OF VALUES 8, 9 OR 10
C INDICATING TYPE OF ILLEGAL ARGUMENT. IF A
C SET OF NUMBERS IS FOUND, IT IS EVALUATED AS
C A SET OF INTEGERS.
C = 2, ALLOW SERIES OF WORDS. TEXT STRING OR
C SET OF INTEGERS CAN APPEAR AT MOST ONCE.
C = 3, ALLOW SERIES OF SETS OF INTEGERS. TEXT
C STRING OR WORD CAN APPEAR AT MOST ONCE.
C = 4, ALLOW SERIES OF TEXT STRINGS. WORD OR
C SET OF INTEGERS CAN APPEAR AT MOST ONCE.
C = 5, 6, 7 AND 8, SAME AS LSTTYP VALUES OF 1,
C 2, 3 AND 4 RESPECTIVELY.
C = 9, ONLY TYPE OF ARGUMENT ACCEPTED WILL BE
C PARENTHETICAL TEXT STRINGS, NOT TEXT STRINGS
C DELIMITED BY APOSTROPHES. PRINTING
C CHARACTERS IMMEDIATELY TO LEFT OF
C PARENTHETICAL EXPRESSION WILL BE TAKEN TO BE
C PART OF THAT EXPRESSION, AND MRKLFT WILL
C POINT TO LEFTMOST OF THESE. UNLIKE TEXT
C STRINGS ALLOWED BY ANY OTHER VALUE OF
C LSTTYP, LEADING PARENTHESIS IS POINTED TO BY
C MRKLFT IF NO PRINTING CHARACTERS APPEAR TO
C ITS LEFT. MRKRIT WILL STILL BE RETURNED
C POINTING TO CHARACTER TO LEFT OF TRAILING
C PARENTHESIS.
C NAMLOW = SUBSCRIPT OF NAMLFT AND NAMRIT ARRAY
C LOCATIONS TO BE RETURNED WITH DESCRIPTION OF
C FIRST WORD IN ARGUMENT LIST.
C NAMMAX = MAXIMUM SUBSCRIPT OF NAMLFT AND NAMRIT
C ARRAYS.
C MRKLOW = SUBSCRIPT OF MRKLFT AND MRKRIT ARRAY
C LOCATIONS TO BE RETURNED WITH DESCRIPTION OF
C FIRST TEXT STRING IN ARGUMENT LIST.
C MRKMAX = MAXIMUM SUBSCRIPT OF MRKLFT AND MRKRIT
C ARRAYS.
C NUMLOW = SUBSCRIPT OF NUMSIN AND NUMVAL ARRAY
C LOCATIONS TO BE RETURNED WITH DESCRIPTION OF
C FIRST NUMBER IN ARGUMENT LIST.
C NUMMAX = MAXIMUM SUBSCRIPT OF NUMSIN AND NUMVAL
C ARRAYS.
C INTRVL = MAXIMUM NUMBER OF NUMBERS IN SET OF NUMBERS
C SEPARATED BY SLASHES. IF 2 NUMERIC
C ARGUMENTS ARE SEPARATED BY SOMETHING OTHER
C THAN SLASH, THEN THESE ARGUMENTS ARE PART OF
C SERIES OF SETS OF NUMBERS, AND DESCRIPTION
C OF SECOND NUMBER IS PLACED INTO NUMSIN AND
C NUMVAL ARRAYS AT LOCATION HAVING SUBSCRIPT
C GREATER BY VALUE OF INTRVL THAN SUBSCRIPT OF
C LOCATION INTO WHICH WAS PLACED DESCRIPTION
C OF FIRST NUMBER OF PREVIOUS SET.
C LOWWRD = SUBSCRIPT OF LOCATION IN IWORD ARRAY WHICH
C CONTAINS 1ST LETTER OF 1ST WORD. NOTE THAT
C IF KNTLTR(LOWKNT) IS NEGATIVE, THEN THE 1ST
C LETTER OF 1ST WORD WILL BE FOUND IN ARRAY
C LOCATION IWORD(LOWWRD-KNTLTR(LOWKNT)).
C MAXWRD = DIMENSION OF IWORD ARRAY.
C IWORD = DICTIONARY ARRAY CONTAINING CHARACTERS OF
C COMMAND WORDS WHICH ARE TO BE RECOGNIZED, 1
C CHARACTER PER ARRAY LOCATION AS READ BY A1
C FORMAT OR ELSE DEFINED BY 1H FIELD. COMMAND
C WORD IN INPUT BUFFR ARRAY IBUFFR CAN BE
C SPLIT INTO 2 OR MORE PORTIONS SEPARATED BY
C SPACES AND/OR TABS AND WILL BE MATCHED
C WHETHER OR NOT SPACES OR TABS ARE PRESENT IF
C WORD IN IWORD CONTAINS A SINGLE SPACE AT
C LOCATION AT WHICH SPLIT IS ALLOWED. IN
C ORDER TO OBTAIN A MATCH, CASES OF CHARACTERS
C IN DICTIONARY AND IN INPUT BUFFER MUST BE
C IDENTICAL. NOTE ALSO, THAT LETTERS E, M AND
C K USED WITHIN NUMBERS TO INDICATE EXPONENTS
C MUST BE IN UPPER CASE IN INPUT BUFFER IN
C ORDER TO BE RECOGNIZED.
C LOWKNT = SUBSCRIPT OF KNTLTR ARRAY CONTAINING LENGTH
C OF FIRST WORD WHICH CAN BE MATCHED IN IWORD
C ARRAY. THIS FIRST WORD WILL START AT
C IWORD(LOWWRD).
C MAXKNT = SUBSCRIPT OF KNTLTR ARRAY CONTAINING LENGTH
C OF FINAL WORD WHICH CAN BE MATCHED IN IWORD
C ARRAY.
C KNTLTR = ARRAY CONTAINING NUMBERS OF CHARACTERS IN
C WORDS IN IWORD ARRAY. ZERO OR NEGATIVE
C VALUE IN KNTLTR ARRAY OFFSETS NEXT POSSIBLE
C WORD WHICH CAN BE MATCHED IN IWORD ARRAY BY
C NUMBER OF LETTERS GIVEN BY ABSOLUTE VALUE OF
C NEGATIVE NUMBER IN KNTLTR ARRAY. DIMENSION
C OF KNTLTR MUST BE AT LEAST MAXKNT. FOR
C EXAMPLE TO RECOGNIZE WORDS
C
C YES, NO, MAYBE
C
C CONTENTS OF IWORD ARRAY WOULD BE
C
C 1HY,1HE,1HS,1HN,1HO,1HM,1HA,1HY,1HB,1HE
C
C AND CONTENTS OF KNTLTR ARRAY WOULD BE
C
C 3,2,5
C
C LEGAL = IF LSTTYP=-1, THEN LEGAL IS ARRAY SPECIFYING
C FOR EACH POSSIBLE COMMAND WORD THE TYPE OF
C ARGUMENT, WORD OR SET OF NUMBERS OR TEXT
C STRING, WHICH CAN BE PRESENT MORE THAN ONCE
C IN ARGUMENT LIST. TYPE OF ARGUMENT LIST IS
C AT SAME SUBSCRIPT IN LEGAL ARRAY AS
C CHARACTER COUNT IN KNTLTR ARRAY. IF LSTTYP
C IS GREATER THAN OR EQUAL TO ZERO, THEN
C CONTENTS OF LEGAL ARRAY ARE IGNORED.
C = 0, NO ARGUMENTS ARE ALLOWED.
C = 1, TYPE OF ARGUMENT WHICH CAN BE REPEATED IS
C TYPE OF FIRST ARGUMENT ENCOUNTERED, WHETHER
C OR NOT THIS IS PRECEDED BY COMMAS. COMMAS
C DO, HOWEVER, INDICATE MISSING ARGUMENTS OF
C SAME TYPE AS THAT EVENTUALLY FOUND.
C ADDITIONAL ARGUMENTS OF TYPES OTHER THAN
C THAT OF FIRST ARGUMENT ENCOUNTERED ARE NOT
C ALLOWED. IF AN ADDITIONAL ARGUMENT OF
C ANOTHER TYPE IS FOUND, THEN EVALUATION OF
C ARGUMENT LIST WILL BE TERMINATED EXCEPT
C INSOFAR AS IS NECESSARY TO DETECT END OF
C STATEMENT, AND KIND WILL BE RETURNED
C CONTAINING ONE OF VALUES 8, 9 OR 10
C INDICATING TYPE OF ILLEGAL ARGUMENT. IF A
C SET OF NUMBERS IS FOUND, IT IS EVALUATED AS
C A SET OF INTEGERS.
C = 2, ALLOW SERIES OF WORDS. TEXT STRING OR
C SET OF INTEGERS CAN APPEAR AT MOST ONCE.
C = 3, ALLOW SERIES OF SETS OF INTEGERS. TEXT
C STRING OR WORD CAN APPEAR AT MOST ONCE.
C = 4, ALLOW SERIES OF TEXT STRINGS. WORD OR
C SET OF INTEGERS CAN APPEAR AT MOST ONCE.
C = 5, 6, 7 AND 8, SAME AS LEGAL ARRAY VALUES OF
C 1, 2, 3 AND 4 RESPECTIVELY.
C = 9, ONLY TYPE OF ARGUMENT ACCEPTED WILL BE
C PARENTHETICAL TEXT STRINGS, NOT TEXT STRINGS
C DELIMITED BY APOSTROPHES. PRINTING
C CHARACTERS IMMEDIATELY TO LEFT OF
C PARENTHETICAL EXPRESSION WILL BE TAKEN TO BE
C PART OF THAT EXPRESSION, AND MRKLFT WILL
C POINT TO LEFTMOST OF THESE. UNLIKE TEXT
C STRINGS ALLOWED BY ANY OTHER VALUE OF
C LEGAL, LEADING PARENTHESIS IS POINTED TO BY
C MRKLFT IF NO PRINTING CHARACTERS APPEAR TO
C ITS LEFT. MRKRIT WILL STILL BE RETURNED
C POINTING TO CHARACTER TO LEFT OF TRAILING
C PARENTHESIS.
C MAXBFR = SUBSCRIPT OF IBUFFR ARRAY LOCATION
C CONTAINING RIGHTMOST CHARACTER IN CURRENT
C LINE.
C
C FOLLOWING ARGUMENTS ARE USED FOR BOTH INPUT AND
C OUTPUT.
C
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS OF
C LINE BEING INTERPRETED, ONE CHARACTER PER
C ARRAY LOCATION, AS READ BY MULTIPLE OF A1
C FORMAT. IF QUOTED TEXT STRING ITSELF
C CONTAINING APOSTROPHES IS FOUND IN IBUFFR
C ARRAY, THEN EXTRA APOSTROPHES NEEDED TO MARK
C APOSTROPHES TO REMAIN IN TEXT ARE REMOVED BY
C SHIFTING TO LEFT TEXT TO THEIR RIGHT.
C LOWBFR = SUBSCRIPT IN IBUFFR ARRAY OF FIRST CHARACTER
C TO BE INTERPRETED. LOWBFR IS RETURNED
C POINTING TO FIRST CHARACTER BEYOND
C INTERPRETED STATEMENT. IF SEMICOLON APPEARS
C AT END OF STATEMENT, THEN LOWBFR IS RETURNED
C POINTING TO SEMICOLON AND WILL BE ADVANCED
C BEYOND SEMICOLON BY SUBSEQUENT CALL TO THIS
C ROUTINE. IF EXCLAMATION POINT APPEARS AT
C END OF STATEMENT, OR IF THERE ARE NO MORE
C PRINTING CHARACTERS TO RIGHT OF STATEMENT,
C THEN LOWBFR IS RETURNED CONTAINING MAXBFR+1.
C KIND = MUST BE SET TO ZERO BY CALLING PROGRAM
C BEFORE THIS ROUTINE IS FIRST CALLED TO
C EVALUATE LINE OF TEXT. KIND IS THEN
C RETURNED DESCRIBING TYPE OF STATEMENT WHICH
C WAS EVALUATED. CALLING PROGRAM SHOULD RESET
C KIND TO HAVE VALUE ZERO IF EVALUATION OF
C CONTENTS OF LINE OF TEXT IS BEING ABANDONED
C BY CALLING PROGRAM BEFORE THIS ROUTINE HAS
C INDICATED BY RETURNING KIND=1 THAT IT HAS
C COMPLETED EVALUATION OF LINE OF TEXT.
C EXCEPT FOR THIS INSTANCE IN WHICH
C INTERPRETATION IS BEING ABANDONED BY CALLING
C PROGRAM, VALUE OF KIND IS OTHERWISE PASSED
C UNCHANGED TO SUBSEQUENT CALL TO THIS
C ROUTINE.
C = 1, (PROCESSING COMPLETED) RETURNED IF
C PREVIOUS CALLS TO THIS ROUTINE HAVE
C COMPLETED EVALUATION OF CONTENTS OF LINE OF
C TEXT. CALLING PROGRAM SHOULD READ NEW LINE
C OF TEXT AND RESET LOWBFR TO POINT TO FIRST
C CHARACTER IN NEW TEXT.
C = 2, (EMPTY STATEMENT) RETURNED IF ORIGINAL
C LINE OF TEXT CONTAINED NO PRINTING
C CHARACTERS OR CONTAINED LEADING EXCLAMATION
C POINT INDICATING THAT CHARACTERS TO ITS
C RIGHT FORMED COMMENT. KIND IS ALSO RETURNED
C SET TO 2 IF EXTRA SEMICOLON INDICATES
C MISSING STATEMENT.
C = 3, (CORRECT STATEMENT) RETURNED IF STATEMENT
C WAS NOT EMPTY AND WAS EVALUATED WITHOUT
C ERRORS. IF KMDTYP IS GREATER THAN OR EQUAL
C TO ZERO, THEN KNOWN COMMAND WORD, OR ELSE
C NONAMBIGUOUS ABBREVIATION THEREOF, WAS FOUND
C AND SEQUENCE NUMBER OF THIS COMMAND WORD
C WITHIN DICTIONARY IS RETURNED AS VALUE OF
C KOMAND. IF KMDTYP IS LESS THAN ZERO, THEN
C KOMAND IS RETURNED WITH VALUE ZERO, AND
C STATEMENT CONTAINED AT LEAST COMMA, SLASH,
C COLON OR ARGUMENT.
C = 4, (INITIAL NUMBER) RETURNED IF KMDTYP IS
C GREATER THAN ZERO, AND IF NUMBER WAS FOUND
C AT START OF STATEMENT. MIDPRT IS RETURNED
C CONTAINING SUBSCRIPT WITHIN IBUFFR ARRAY OF
C CHARACTER TO IMMEDIATE RIGHT OF NUMBER.
C LMTPRT IS RETURNED CONTAINING SUBSCRIPT
C WITHIN IBUFFR ARRAY OF RIGHTMOST PRINTING
C CHARACTER WITHIN IBUFFR ARRAY.
C = 5, (MISSING COMMAND) RETURNED IF COMMAND
C WORD OR ELSE LEADING NUMBER WAS REQUIRED BUT
C NOT FOUND, BUT STATEMENT IS NOT EMPTY. NO
C ARGUMENT DESCRIPTIONS ARE RETURNED TO
C CALLING PROGRAM.
C = 6, (UNKNOWN COMMAND) RETURNED IF INITIAL
C COMMAND WORD WAS REQUIRED, BUT STATEMENT
C STARTS WITH SEQUENCE OF PRINTING CHARACTERS
C WHICH COULD FORM COMMAND WORD, BUT WHICH DO
C NOT MATCH WORD IN DICTIONARY, OR WHICH FORM
C AMBIGUOUS ABBREVIATION OF 2 OR MORE WORDS IN
C DICTIONARY, OR WHICH DO MATCH SINGLE WORD IN
C DICTIONARY BUT ARE FOLLOWED IMMEDIATELY BY
C ADDITIONAL ALPHABETIC CHARACTERS OR DIGITS.
C INIPRT AND MIDPRT ARE RETURNED POINTING TO
C LEFTMOST AND RIGHTMOST CHARACTERS IN THIS
C UNKNOWN COMMAND WORD. NO ARGUMENT
C DESCRIPTIONS ARE RETURNED TO CALLING
C PROGRAM.
C = 7, 8, 9 OR 10 RETURNED IF MAXIMUM NUMBER OF
C ARGUMENTS OF SINGLE TYPE WAS EXCEEDED IN
C ARGUMENT LIST. DESCRIPTION OF ARGUMENT
C WHICH EXCEEDED LIMIT, AS WELL AS
C DESCRIPTIONS OF ANY ARGUMENTS TO ITS RIGHT,
C ARE NOT RETURNED TO CALLING PROGRAM,
C ALTHOUGH SCANNING OF STATEMENT CONTINUES TO
C DETERMINE ITS RIGHT END.
C = 7, RETURNED IF TOO MANY SLASHES OR COLONS
C WERE ENCOUNTERED IN SET OF NUMBERS.
C = 8, RETURNED IF TOO MANY WORDS WERE FOUND.
C = 9, RETURNED IF TOO MANY SETS OF NUMBERS WERE
C FOUND.
C = 10, RETURNED IF TOO MANY TEXT STRINGS WERE
C FOUND.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT. THEIR
C INPUT VALUES ARE IGNORED.
C
C KOMAND = IF KIND IS RETURNED CONTAINING 3 OR RETURNED
C CONTAINING 7 OR GREATER, THEN KOMAND IS
C SEQUENCE NUMBER OF COMMAND WORD MATCHED IN
C IWORD ARRAY. IF SECOND COMMAND WORD IS
C MATCHED, THEN KOMAND IS RETURNED CONTAINING
C 2. SEQUENCE NUMBER DOES NOT INCLUDE LETTERS
C SKIPPED OVER BY VALUE OF LOWWRD, AND DOES
C NOT INCLUDE LETTERS SKIPPED OVER BY NEGATIVE
C VALUES IN KNTLTR ARRAY. IF COMMAND WORD IN
C IWORD ARRAY IS MATCHED, THEN KOMAND IS
C NUMBER OF VALUES IN KNTLTR ARRAY WHICH ARE
C GREATER THAN ZERO STARTING AT KNTLTR(LOWKNT)
C UP TO AND INCLUDING KNTLTR LOCATION WHICH
C CONTAINS NUMBER OF LETTERS IN COMMAND WORD
C WHICH IS SUCCESSFULLY MATCHED.
C = RETURNED CONTAINING ZERO IF A COMMAND WORD
C WAS NOT MATCHED.
C LCNWRD = IF KIND IS RETURNED CONTAINING EITHER 3 OR 7
C OR GREATER AND KOMAND BEING RETURNED GREATER
C THAN ZERO, LCNWRD IS RETURNED CONTAINING
C SUBSCRIPT OF IWORD LOCATION CONTAINING FIRST
C LETTER OF MATCHED WORD. LCNWRD IS UNDEFINED
C IF KOMAND IS RETURNED CONTAINING ZERO.
C LCNKNT = IF KIND IS RETURNED CONTAINING EITHER 3 OR 7
C OR GREATER AND KOMAND BEING RETURNED GREATER
C THAN ZERO, LNCKNT IS RETURNED CONTAINING
C SUBSCRIPT OF KNTLTR LOCATION CONTAINING WORD
C LENGTH. LCNKNT IS UNDEFINED IF KOMAND IS
C RETURNED CONTAINING ZERO.
C INIPRT = RETURNED CONTAINING SUBSCRIPT OF IBUFFR
C ARRAY LOCATION CONTAINING LEFTMOST PRINTING
C CHARACTER IN STATEMENT IF KIND IS RETURNED
C CONTAINING 3 OR GREATER. INIPRT IS RETURNED
C UNDEFINED IF KIND IS RETURNED SET TO EITHER
C 1 OR 2.
C = IF KIND IS RETURNED CONTAINING 6 INDICATING
C THAT UNKNOWN COMMAND WORD WAS FOUND AT START
C OF STATEMENT, THEN INIPRT IS RETURNED
C POINTING TO LEFT CHARACTER OF UNKNOWN
C COMMAND WORD. MIDPRT WILL THEN BE RETURNED
C POINTING TO RIGHT CHARACTER OF UNKNOWN
C COMMAND WORD.
C MIDPRT = RETURNED UNDEFINED IF KIND IS RETURNED
C CONTAINING ANY VALUE OTHER THAN 4 OR 6.
C = IF KMDTYP WAS INPUT GREATER THAN ZERO
C ALLOWING INITIAL NUMBER IN PLACE OF INITIAL
C COMMAND WORD, AND IF SUCH INITIAL NUMBER WAS
C FOUND SO THAT KIND IS RETURNED CONTAINING 4,
C THEN MIDPRT IS RETURNED POINTING TO
C CHARACTER TO IMMEDIATE RIGHT OF NUMBER.
C LMTPRT WILL THEN BE RETURNED POINTING TO
C RIGHTMOST PRINTING CHARACTER ON LINE.
C = IF KIND IS RETURNED CONTAINING 6 INDICATING
C THAT UNKNOWN COMMAND WORD WAS FOUND AT START
C OF STATEMENT, THEN MIDPRT IS RETURNED
C POINTING TO RIGHT CHARACTER OF UNKNOWN
C COMMAND WORD.
C LMTPRT = RETURNED CONTAINING SUBSCRIPT OF IBUFFR
C ARRAY LOCATION CONTAINING RIGHTMOST PRINTING
C CHARACTER IN STATEMENT IF KIND IS RETURNED
C CONTAINING 3 OR GREATER. IF STATEMENT IS
C FOLLOWED BY EITHER SEMICOLON OR EXCLAMATION
C POINT, THEN LMTPRT IS RETURNED POINTING TO
C RIGHTMOST PRINTING CHARACTER TO LEFT OF
C SEMICOLON OR EXCLAMATION POINT. LMTPRT IS
C RETURNED UNDEFINED IF KIND IS RETURNED SET
C TO EITHER 1 OR 2.
C = IF KMDTYP WAS INPUT GREATER THAN ZERO
C ALLOWING INITIAL NUMBER IN PLACE OF INITIAL
C COMMAND WORD, AND IF SUCH INITIAL NUMBER WAS
C FOUND SO THAT KIND IS RETURNED CONTAINING 4,
C THEN LMTPRT IS RETURNED POINTING TO
C RIGHTMOST PRINTING CHARACTER IN BUFFER.
C NAMKNT = RETURNED CONTAINING HIGHEST SUBSCRIPT USED
C IN NAMLFT AND NAMRIT ARRAYS TO STORE
C LOCATIONS IN BUFFER OF ENDS OF WORDS IN
C ARGUMENT LIST. IF NO WORDS ARE FOUND THEN
C NAMKNT IS RETURNED CONTAINING NAMLOW-1.
C NAMLFT = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C IBUFFR ARRAY OF LOCATIONS CONTAINING LEFT
C CHARACTERS OF WORDS IN ARGUMENT LIST. IF
C SERIES OF WORDS IS ENABLED BUT SOME ARE
C INDICATED AS MISSING BY EXTRA COMMAS IN
C ARGUMENT LIST, THEN FOR THESE MISSING WORDS
C NAMRIT ARRAY WILL CONTAIN VALUES LESS THAN
C THOSE IN NAMLFT ARRAY.
C NAMRIT = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C IBUFFR ARRAY OF LOCATIONS CONTAINING RIGHT
C CHARACTERS OF WORDS IN ARGUMENT LIST.
C MRKKNT = RETURNED CONTAINING HIGHEST SUBSCRIPT USED
C IN MRKLFT AND MRKRIT ARRAYS TO STORE
C LOCATIONS IN BUFFER OF ENDS OF QUOTED TEXT
C STRINGS IN ARGUMENT LIST. IF NO QUOTED TEXT
C STRINGS ARE FOUND THEN MRKKNT IS RETURNED
C CONTAINING MRKLOW-1.
C MRKLFT = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C IBUFFR ARRAY OF LOCATIONS CONTAINING LEFT
C CHARACTERS OF QUOTED TEXT STRINGS.
C CHARACTER POINTED TO BY MRKLFT IS CHARACTER
C TO IMMEDIATE RIGHT OF INITIAL APOSTROPHE OR
C OF INITIAL PARENTHESIS. IF LSTTYP=9, OR IF
C LSTTYP=-1 AND LEGAL=9, THEN MRKLFT POINTS TO
C LEFTMOST PRINTING CHARACTER LEFT OF OPENING
C PARENTHESIS OR TO OPENING PARENTHESIS ITSELF
C IF NOT PRECEDED BY ANY OTHER PRINTING
C CHARACTERS. IF SERIES OF TEXT STRINGS IS
C ENABLED BUT SOME ARE INDICATED AS MISSING BY
C EXTRA COMMAS IN ARGUMENT LIST, THEN FOR
C THESE MISSING TEXT STRINGS MRKRIT ARRAY WILL
C CONTAIN VALUES 2 LESS THAN THOSE IN MRKLFT.
C MRKRIT = ARRAY RETURNED CONTAINING SUBSCRIPTS IN
C IBUFFR ARRAY OF LOCATIONS CONTAINING RIGHT
C CHARACTERS OF QUOTED TEXT STRINGS IN
C ARGUMENT LIST. CHARACTER POINTED TO BY
C MRKRIT ARRAY IS CHARACTER TO IMMEDIATE LEFT
C OF FINAL APOSTROPHE OR OF FINAL PARENTHESIS
C AT RIGHT END OF QUOTED TEXT STRING, OR IS
C RIGHTMOST PRINTING CHARACTER ON LINE IF NO
C FINAL APOSTROPHE OR FINAL PARENTHESIS IS
C FOUND.
C NUMKNT = RETURNED CONTAINING HIGHEST SUBSCRIPT USED
C IN NUMSIN AND NUMVAL ARRAYS TO STORE
C DESCRIPTION OF NUMERIC ARGUMENTS FOUND IN
C ARGUMENT LIST. IF NO NUMERIC ARGUMENTS ARE
C FOUND IN ARGUMENT LIST, THEN NUMKNT IS
C RETURNED CONTAINING NUMLOW-1.
C NUMSIN = ARRAY RETURNED INDICATING SIGN, IF ANY,
C WHICH PRECEDED EACH NUMERIC ARGUMENT. VALUE
C OF ARGUMENT IS RETURNED IN NUMVAL ARRAY
C LOCATION HAVING SAME SUBSCRIPT AS NUMSIN
C ARRAY LOCATION DESCRIBING SIGN.
C = -1, CORRESPONDING NUMERIC ARGUMENT WAS
C INDICATED AS MISSING EITHER BY ABSENCE OF
C NUMBER BEFORE SLASH OR COLON, BY ABSENCE OF
C NUMBER AFTER SLASH OR COLON, OR BY ABSENCE
C OF NUMBER BETWEEN SLASHES OR COLONS.
C CORRESPONDING VALUE IN NUMVAL ARRAY IS
C RETURNED SET TO ZERO.
C = 0, RETURNED IF CORRESPONDING NUMERIC
C ARGUMENT WAS INDICATED AS MISSING BY LESS
C THAN INTRVL NUMBERS BEING INCLUDED IN SET OF
C NUMBERS, OR BY 2 ADJACENT COMMAS IN ARGUMENT
C LIST.
C = 1, NUMERIC ARGUMENT WAS EVALUATED, BUT NO
C SIGN APPEARED TO ITS LEFT.
C = 2, MINUS SIGN APPEARED TO LEFT OF NUMERIC
C ARGUMENT.
C = 3, PLUS SIGN APPEARED TO LEFT OF NUMERIC
C ARGUMENT.
C NUMVAL = ARRAY RETURNED CONTAINING VALUES OF NUMERIC
C ARGUMENTS EVALUATED AS INTEGERS. IF MINUS
C SIGN PRECEDED NUMBER, THEN VALUE IN NUMVAL
C IS NEGATIVE.
C
DIMENSION IDIGIT(10),ISEPAR(12),IBUFFR(MAXBFR),
1IWORD(MAXWRD),KNTLTR(MAXKNT),LEGAL(MAXKNT),
2NAMLFT(NAMMAX),NAMRIT(NAMMAX),MRKLFT(MRKMAX),
3MRKRIT(MRKMAX),NUMSIN(NUMMAX),NUMVAL(NUMMAX)
C
EQUIVALENCE(IBLANK,ISEPAR(1)),(ITAB,ISEPAR(2)),
1 (IQUOTE,ISEPAR(6)),(ILEFT,ISEPAR(7)),
2 (IRIGHT,ISEPAR(8)),(ISLASH,ISEPAR(9)),
3 (ICOLON,ISEPAR(10)),(IPLUS,ISEPAR(11)),
4 (IMINUS,ISEPAR(12))
C
C FIRST CHARACTER IN ISEPAR ARRAY IS SPACE. SECOND
C CHARACTER IS TAB CHARACTER. IF TAB CHARACTER IS NOT
C AVAILABLE, THEN SECOND CHARACTER SHOULD BE SPACE ALSO
DATA ISEPAR/1H ,1H ,
11H!,1H;,1H,,1H',1H(,1H),1H/,1H:,1H+,1H-/
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C SET DEFAULT ARGUMENT COUNTS TO ZERO
NUMKNT=NUMLOW-1
MRKKNT=MRKLOW-1
NAMKNT=NAMLOW-1
INIKND=KIND
C
C **********************
C * *
C * SCAN FOR COMMAND *
C * *
C **********************
C
C LOOK FOR FIRST PRINTING CHARACTER
GO TO 3
1 INIKND=0
2 LOWBFR=LOWBFR+1
3 IF(LOWBFR.GT.MAXBFR)GO TO 86
IF(IBUFFR(LOWBFR).EQ.IBLANK)GO TO 2
IF(IBUFFR(LOWBFR).EQ.ITAB)GO TO 2
INIPRT=LOWBFR
MULTPL=LSTTYP
IF(KMDTYP.LT.0)GO TO 6
C
C TEST IF SEQUENCE OF PRINTING CHARACTERS IN DICTIONARY
INILTR=LOWBFR
CALL DAVERB(LOWWRD,MAXWRD,IWORD,LOWKNT,MAXKNT,
1KNTLTR,IBUFFR,MAXBFR,LOWBFR,KIND,KOMAND,LCNWRD,
2LCNKNT,LCNBFR)
LMTPRT=LOWBFR-1
C
C ENTIRE DICTIONARY HAS BEEN SEARCHED
IF(KIND.GE.3)GO TO 4
C NO COMMAND WORD, CHECK FOR LEADING NUMBER
ISTATE=-1
MULTPL=3
GO TO 7
C GET ARGUMENT LIST TYPE IF IN LEGAL ARRAY
4 IF(LSTTYP.EQ.-1)MULTPL=LEGAL(LCNKNT)
IF(KIND.LE.4)GO TO 5
C AMBIGUOUS ABREVIATION, CHECK FOR REST OF WORD IF ANY
KIND=-1
GO TO 8
C COMMAND FOUND BUT IS ERROR IF ADDITIONAL CHARACTERS
5 ISTATE=0
GO TO 7
C NO COMMAND WAS TESTED FOR, SIMULATE LEADING SPACE
6 ISTATE=1
KOMAND=0
7 KIND=0
C
C MULTPL = -3, ALLOW NO ARGUMENTS
C = -2, ALLOW MULTIPLE ARGUMENTS OF 1ST TYPE
C FOUND
C = -1, ALLOW MULTIPLE WORDS
C = 0, ALLOW MULTIPLE NUMBERS
C = 1, ALLOW MULTIPLE STRINGS
C
8 JMLTPL=MULTPL-8
LIMIT=12
IF(JMLTPL.GT.0)LIMIT=8
MULTPL=MULTPL-3
IF(MULTPL.GT.1)MULTPL=MULTPL-4
IF(MULTPL.GE.-1)GO TO 9
NUMBLK=0
MRKNXT=MRKKNT
NAMNXT=NAMKNT
NUMNXT=NUMKNT
NOTYET=0
GO TO 10
9 NUMBLK=1
NUMNXT=NUMLOW
MRKNXT=MRKLOW
NAMNXT=NAMLOW
10 NUMNOW=NUMNXT
IF(KIND.LT.0)GO TO 67
GO TO 14
C
C ************************
C * *
C * SCAN FOR ARGUMENTS *
C * *
C ************************
C
C ISTATE = -1, NOTHING OR SPACE FOUND. WILL ACCEPT
C ONLY A LEADING NUMBER.
C = 0, COMMAND FOUND, BUT NOT YET ANYTHING,
C EVEN SPACES, AFTER IT.
C = 1, NO COMMAND WAS LOOKED FOR, ONLY SPACES
C HAVE YET BEEN FOUND, NOTHING ELSE
C = 2, COMMA FOUND ANYWHERE, OR ELSE COMMAND
C FOUND FOLLOWED BY SPACE. ANOTHER COMMA WILL
C INDICATE A MISSING ARGUMENT.
C = 3, TERMINATED SINGLE ITEM
C
C SPACE OR TAB CHARACTER FOUND
11 IF(ISTATE.NE.0)GO TO 13
12 ISTATE=2
C
C TEST IF NEXT CHARACTER BEGINS ARGUMENT OR PUNCTUATION
13 LOWBFR=LOWBFR+1
14 IF(LOWBFR.GT.MAXBFR)GO TO 85
KOMPAR=IBUFFR(LOWBFR)
DO 15 I=1,LIMIT
IF(KOMPAR.NE.ISEPAR(I))GO TO 15
GO TO(11,11,85,87,79,17,29,29,57,57,43,44),I
15 CONTINUE
IF(JMLTPL.GT.0)GO TO 66
IF(ISTATE.EQ.0)GO TO 68
DO 16 I=1,10
IF(KOMPAR.NE.IDIGIT(I))GO TO 16
NUMBER=I-1
GO TO 46
16 CONTINUE
GO TO 66
C
C ************************
C * *
C * QUOTED TEXT STRING *
C * *
C ************************
C
C APOSTROPHE STARTS TEXT STRING
17 IF(JMLTPL.GT.0)GO TO 24
INILTR=LOWBFR+1
I=LOWBFR
LMTPRT=LOWBFR
18 IF(I.GE.MAXBFR)GO TO 20
I=I+1
LOWBFR=LOWBFR+1
IBUFFR(LOWBFR)=IBUFFR(I)
IF(IBUFFR(I).EQ.IBLANK)GO TO 18
IF(IBUFFR(I).EQ.ITAB)GO TO 18
LMTPRT=LOWBFR
IF(IBUFFR(I).NE.IQUOTE)GO TO 18
IF(I.GE.MAXBFR)GO TO 19
IF(IBUFFR(I+1).NE.IQUOTE)GO TO 19
I=I+1
GO TO 18
19 NONSPC=LMTPRT-1
GO TO 21
20 NONSPC=LMTPRT
21 IF(LOWBFR.EQ.I)GO TO 37
KOPY=LOWBFR
22 IF(KOPY.GE.MAXBFR)GO TO 37
KOPY=KOPY+1
IF(I.GE.MAXBFR)GO TO 23
I=I+1
IBUFFR(KOPY)=IBUFFR(I)
GO TO 22
23 IBUFFR(KOPY)=IBLANK
GO TO 22
C
C SECTION PRIOR TO PARENTHETICAL EXPRESSION
24 INILTR=LOWBFR
25 KOMPAR=IBUFFR(LOWBFR)
DO 26 I=1,8
IF(KOMPAR.NE.ISEPAR(I))GO TO 26
IF(I.LT.6)GO TO 28
IF(I.GT.6)GO TO 30
IF(LOWBFR.LT.MAXBFR)LOWBFR=LOWBFR+1
GO TO 27
26 CONTINUE
27 LMTPRT=LOWBFR
NONSPC=LOWBFR
IF(LOWBFR.GE.MAXBFR)GO TO 37
LOWBFR=LOWBFR+1
GO TO 25
28 LOWBFR=LOWBFR-1
GO TO 37
C
C PARENTHESIS STARTS TEXT STRING
29 INILTR=LOWBFR
IF(JMLTPL.LE.0)INILTR=INILTR+1
30 LEVEL=0
GO TO 32
31 IF(LOWBFR.GE.MAXBFR)GO TO 36
LOWBFR=LOWBFR+1
32 KOMPAR=IBUFFR(LOWBFR)
IF(KOMPAR.EQ.IBLANK)GO TO 31
IF(KOMPAR.EQ.ITAB)GO TO 31
LMTPRT=LOWBFR
IF(KOMPAR.EQ.ILEFT)GO TO 33
IF(KOMPAR.EQ.IRIGHT)GO TO 34
IF(KOMPAR.NE.IQUOTE)GO TO 31
IF(LOWBFR.GE.MAXBFR)GO TO 36
LOWBFR=LOWBFR+1
LMTPRT=LOWBFR
GO TO 31
33 LEVEL=LEVEL+1
GO TO 35
34 LEVEL=LEVEL-1
35 IF(LEVEL.NE.0)GO TO 31
NONSPC=LMTPRT-1
GO TO 37
36 NONSPC=LMTPRT
C
C STORE THE TEXT STRING
37 IF(ISTATE.LT.0)KIND=5
IF(KIND.NE.0)GO TO 42
IF(MULTPL.NE.-2)GO TO 38
MULTPL=1
MRKNXT=MRKLOW+NOTYET
38 IF(MRKKNT.GE.MRKNXT)GO TO 39
IF(MRKNXT.LE.MRKMAX)GO TO 40
39 KIND=10
GO TO 42
40 MRKKNT=MRKKNT+1
IF(MRKKNT.GE.MRKNXT)GO TO 41
MRKLFT(MRKKNT)=1
MRKRIT(MRKKNT)=-1
GO TO 40
41 MRKLFT(MRKKNT)=INILTR
MRKRIT(MRKKNT)=NONSPC
IF(MULTPL.EQ.0)GO TO 42
IF(NUMKNT.GE.NUMLOW)NUMBLK=0
42 ISTATE=3
IF(MULTPL.GT.0)GO TO 82
GO TO 13
C
C ****************************
C * *
C * NUMBER OR NUMBER RANGE *
C * *
C ****************************
C
C PLUS SIGN STARTS NUMBER
43 ISIGN=3
GO TO 45
C
C MINUS SIGN STARTS NUMBER
44 ISIGN=2
45 NUMBER=0
GO TO 47
C
C DIGIT STARTS NUMBER
46 ISIGN=1
C
C EVALUATE NUMBER
47 LOWBFR=LOWBFR+1
IF(LOWBFR.GT.MAXBFR)GO TO 49
KOMPAR=IBUFFR(LOWBFR)
DO 48 I=1,10
IF(KOMPAR.NE.IDIGIT(I))GO TO 48
NUMBER=(10*NUMBER)+I-1
GO TO 47
48 CONTINUE
49 IF(ISIGN.EQ.2)NUMBER=-NUMBER
C
C STORE EVALUATED NUMBER
IF(KIND.NE.0)GO TO 56
IF(ISTATE.GE.0)GO TO 50
IF(KMDTYP.LE.0)GO TO 53
50 IF(MULTPL.NE.-2)GO TO 51
NUMBLK=1
MULTPL=0
NUMNXT=NUMLOW+(NOTYET*INTRVL)
NUMNOW=NUMNXT
51 IF(NUMKNT.GE.NUMNOW)GO TO 52
IF(NUMNOW.LE.NUMMAX)GO TO 54
52 KIND=9
GO TO 56
53 KIND=5
GO TO 56
54 NUMKNT=NUMKNT+1
IF(NUMKNT.GE.NUMNOW)GO TO 55
NUMSIN(NUMKNT)=0
IF(NUMKNT.GE.NUMNXT)NUMSIN(NUMKNT)=-1
NUMVAL(NUMKNT)=0
GO TO 54
55 NUMSIN(NUMKNT)=ISIGN
NUMVAL(NUMKNT)=NUMBER
IF(ISTATE.LT.0)GO TO 83
56 IF(LOWBFR.GT.MAXBFR)GO TO 65
IF(KOMPAR.EQ.ISLASH)GO TO 57
IF(KOMPAR.NE.ICOLON)GO TO 64
C
C SLASH FOUND
57 IF(KIND.NE.0)GO TO 60
IF(ISTATE.GE.0)GO TO 58
KIND=5
GO TO 60
58 IF(MULTPL.NE.-2)GO TO 59
NUMBLK=1
MULTPL=0
NUMNXT=NUMLOW+(NOTYET*INTRVL)
NUMNOW=NUMNXT
59 NUMNOW=NUMNOW+NUMBLK
IF(NUMNOW.GE.(NUMNXT+INTRVL))KIND=7
60 LOWBFR=LOWBFR+1
IF(LOWBFR.GT.MAXBFR)GO TO 65
KOMPAR=IBUFFR(LOWBFR)
IF(KOMPAR.EQ.IPLUS)GO TO 43
IF(KOMPAR.EQ.IMINUS)GO TO 44
IF(KOMPAR.EQ.ISLASH)GO TO 57
IF(KOMPAR.EQ.ICOLON)GO TO 57
DO 61 I=1,10
IF(KOMPAR.NE.IDIGIT(I))GO TO 61
NUMBER=I-1
GO TO 46
61 CONTINUE
C
C END OF RANGE SPECIFICATION
IF(KIND.NE.0)GO TO 64
IF(NUMKNT.GE.NUMNOW)GO TO 62
IF(NUMNOW.LE.NUMMAX)GO TO 63
62 KIND=9
GO TO 64
63 NUMKNT=NUMKNT+1
NUMVAL(NUMKNT)=0
NUMSIN(NUMKNT)=0
IF(NUMKNT.GE.NUMNXT)NUMSIN(NUMKNT)=-1
IF(NUMKNT.LT.NUMNOW)GO TO 63
64 IF(MULTPL.NE.0)NUMBLK=0
65 LOWBFR=LOWBFR-1
LMTPRT=LOWBFR
ISTATE=3
IF(MULTPL.EQ.0)GO TO 81
GO TO 13
C
C **********
C * *
C * WORD *
C * *
C **********
C
C SEARCH FOR END OF WORD
66 IF(ISTATE.LE.0)GO TO 68
IF(JMLTPL.GT.0)GO TO 24
INILTR=LOWBFR
GO TO 69
67 LOWBFR=LOWBFR-1
68 KIND=-1
69 IF(LOWBFR.GE.MAXBFR)GO TO 72
LOWBFR=LOWBFR+1
KOMPAR=IBUFFR(LOWBFR)
DO 70 I=1,12
IF(KOMPAR.EQ.ISEPAR(I))GO TO 71
70 CONTINUE
GO TO 69
71 LOWBFR=LOWBFR-1
C
C STORE DESCRIPTION OF WORD
72 LMTPRT=LOWBFR
IF(KIND.EQ.0)GO TO 73
IF(KIND.GT.0)GO TO 78
KIND=6
MIDPRT=LMTPRT
GO TO 78
73 IF(MULTPL.NE.-2)GO TO 74
MULTPL=-1
NAMNXT=NAMLOW+NOTYET
74 IF(NAMKNT.GE.NAMNXT)GO TO 75
IF(NAMNXT.LE.NAMMAX)GO TO 76
75 KIND=8
GO TO 78
76 NAMKNT=NAMKNT+1
IF(NAMKNT.GE.NAMNXT)GO TO 77
NAMLFT(NAMKNT)=1
NAMRIT(NAMKNT)=0
GO TO 76
77 NAMLFT(NAMKNT)=INILTR
NAMRIT(NAMKNT)=LMTPRT
IF(MULTPL.EQ.0)GO TO 78
IF(NUMKNT.GE.NUMLOW)NUMBLK=0
78 ISTATE=3
IF(MULTPL.LT.0)GO TO 80
GO TO 13
C
C ***********************
C * *
C * PUNCTUATION MARKS *
C * *
C ***********************
C
C COMMA FOUND
79 LMTPRT=LOWBFR
IF(ISTATE.LT.0)KIND=5
IF(ISTATE.EQ.3)GO TO 12
ISTATE=2
IF(MULTPL.GT.0)GO TO 82
IF(MULTPL.EQ.0)GO TO 81
IF(MULTPL.EQ.-1)GO TO 80
NOTYET=NOTYET+1
GO TO 13
C
C INCREMENT SEQUENCE NUMBER OF NEXT SERIES ITEM
80 NAMNXT=NAMNXT+1
GO TO 13
81 NUMNXT=NUMNXT+INTRVL
NUMNOW=NUMNXT
GO TO 13
82 MRKNXT=MRKNXT+1
GO TO 13
C
C INITIAL NUMBER FOUND
83 KIND=4
MIDPRT=LOWBFR
LOWBFR=MAXBFR+1
LMTPRT=LOWBFR
84 LMTPRT=LMTPRT-1
IF(LMTPRT.LT.MIDPRT)GO TO 91
IF(IBUFFR(LMTPRT).EQ.IBLANK)GO TO 84
IF(IBUFFR(LMTPRT).EQ.ITAB)GO TO 84
GO TO 91
C
C COMMENT
85 LOWBFR=MAXBFR+1
IF(ISTATE.EQ.-1)GO TO 86
IF(ISTATE.NE.1)GO TO 90
86 IF(INIKND.LE.1)GO TO 89
KIND=1
GO TO 91
C
C SEMICOLON
87 IF(ISTATE.EQ.-1)GO TO 88
IF(ISTATE.NE.1)GO TO 90
88 IF(INIKND.GT.1)GO TO 1
89 KIND=2
GO TO 91
C
C RETURN TO CALLING PROGRAM
90 IF(KIND.GE.7)GO TO 92
IF(KIND.NE.0)GO TO 91
KIND=3
GO TO 92
91 KOMAND=0
92 RETURN
C282231723876!;':
END
SUBROUTINE DAIRNK(INCRES,IFTEST,MINMUM,MAXMUM,MINSTR,
1 MAXSTR,IBUFFR,MAXBFR,LOWBFR,KIND ,MAXUSD,ISTORE)
C RENBR(/RETURNS SORTED INTEGERS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAIRNK RETURNS A GROUP OF INTEGERS SORTED INTO EITHER
C INCREASING OR DECREASING ORDER. DUPLICATES ARE NOT
C RETURNED.
C
C INCRES = 1, RETURN VALUES IN ISTORE SORTED INTO
C DECREASING ORDER. IF MORE VALUES ARE FOUND
C THAN CAN BE RETURNED IN ISTORE ARRAY, THEN
C SMALLER VALUES ARE DISCARDED.
C = 2, RETURN VALUES IN ISTORE SORTED INTO
C DECREASING ORDER. IF MORE VALUES ARE FOUND
C THAN CAN BE RETURNED IN ISTORE ARRAY, THEN
C LARGER VALUES ARE DISCARDED.
C = 3, RETURN VALUES IN ISTORE SORTED INTO
C INCREASING ORDER. IF MORE VALUES ARE FOUND
C THAN CAN BE RETURNED IN ISTORE ARRAY, THEN
C SMALLER VALUES ARE DISCARDED.
C = 4, RETURN VALUES IN ISTORE SORTED INTO
C INCREASING ORDER. IF MORE VALUES ARE FOUND
C THAN CAN BE RETURNED IN ISTORE ARRAY, THEN
C LARGER VALUES ARE DISCARDED.
C IFTEST = -2 OR 2, THERE ARE NO MINIMUM AND MAXIMUM
C LIMITS TO RANGE OF LEGAL VALUES.
C = -1, REJECT VALUES LESS THAN MINMUM.
C = 0, REJECT VALUES LESS THAN MINMUM OR GREATER
C THAN MAXMUM.
C = 1, REJECT VALUES GREATER THAN MAXMUM.
C MINMUM = LOWER LIMIT OF ALLOWED VALUES IF IFTEST IS
C -1 OR 0. VALUES LESS THAN MINMUM ARE NOT
C RETURNED IN ISTORE IF IFTEST IS -1 OR 0.
C MAXMUM = UPPER LIMIT OF ALLOWED VALUES IF IFTEST IS 0
C OR 1. VALUES GREATER THAN MAXMUM ARE NOT
C RETURNED IN ISTORE IF IFTEST IS 0 OR 1.
C MINSTR = SUBSCRIPT OF LOWEST LOCATION IN ISTORE ARRAY
C INTO WHICH VALUE CAN BE PLACED.
C MAXSTR = SUBSCRIPT OF HIGHEST LOCATION IN ISTORE
C ARRAY INTO WHICH VALUE CAN BE PLACED.
C IBUFFR = INPUT TEXT BUFFER CONTAINING 1 CHARACTER PER
C ARRAY LOCATION AS READ BY MULTIPLE OF A1
C FORMAT.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY LOCATION
C TO BE SEARCHED FOR CHARACTERS.
C LOWBFR = INPUT CONTAINING SUBSCRIPT OF IBUFFR ARRAY
C LOCATION CONTAINING FIRST CHARACTER TO BE
C TESTED. LOWBFR IS RETURNED CONTAINING
C SUBSCRIPT OF IBUFFR ARRAY LOCATION
C CONTAINING NEXT CHARACTER NOT YET EVALUATED.
C KIND = SHOULD BE INPUT CONTAINING ZERO (OR ONE)
C WHENEVER THIS ROUTINE IS CALLED TO GENERATE
C NEW GROUP OF SORTED NUMBERS. KIND IS
C RETURNED DESCRIBING REASON FOR RETURN TO
C CALLING PROGRAM. IF KIND IS RETURNED
C CONTAINING VALUE OF 3 OR GREATER, AND IS
C SENT TO SUBSEQUENT CALL UNCHANGED, THEN
C MAXUSD IS NOT RESET TO MINSTR-1, AND NEW
C VALUES ARE APPENDED TO OLD CONTENTS, IF ANY,
C OF ISTORE.
C = 1, RETURNED EITHER IF NO PRINTING CHARACTERS
C ARE FOUND BEYOND NUMBERS, OR IF EXCLAMATION
C POINT IS NEXT CHARACTER BEYOND NUMBERS.
C LOWBFR IS RETURNED POINTING BEYOND END OF
C BUFFER.
C = 2, RETURNED IF SEMICOLON WAS FOUND AS NEXT
C PRINTING CHARACTER BEYOND NUMBERS. LOWBFR
C IS RETURNED POINTING TO NEXT CHARACTER
C BEYOND SEMICOLON.
C = 3, RETURNED IF AMPERSAND WAS FOUND AS NEXT
C PRINTING CHARACTER BEYOND NUMBERS. LOWBFR
C IS RETURNED POINTING BEYOND END OF BUFFER.
C = 4, RETURNED IF UNKNOWN CHARACTER WAS FOUND
C AS NEXT PRINTING CHARACTER BEYOND NUMBERS.
C LOWBFR IS RETURNED POINTING TO THIS UNKNOWN
C CHARACTER. LOWBFR MUST BE INCREMENTED BY
C CALLING PROGRAM BEFORE THIS ROUTINE IS NEXT
C CALLED.
C MAXUSD = RETURNED CONTAINING SUBSCRIPT OF HIGHEST
C LOCATION IN ISTORE USED TO RETURN SORTED
C VALUES.
C ISTORE = ARRAY USED TO RETURN SORTED VALUES IN
C ISTORE(MINSTR) THROUGH AND INCLUDING
C ISTORE(MAXUSD).
C
DIMENSION IBUFFR(MAXBFR),ISTORE(MAXSTR)
JNCRES=INCRES-2
MANY=0
MINTST=IFTEST
IF(MINTST.LT.-1)MINTST=1
MAXTST=IFTEST
IF(MAXTST.GT.1)MAXTST=-1
IF(KIND.LT.3)MAXUSD=MINSTR-1
1 CALL DAMISS(0,1,0,IBUFFR,MAXBFR,
1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,NEWVAL,
2VALUE,MANY,LCNBFR,LCNERR)
GO TO(23,22,2,2,20,21,1),KIND
C
C TEST IF NEW VALUE IS IN REGION BEING DISCARDED
2 IF(MINTST.GT.0)GO TO 3
IF(NEWVAL.LT.MINMUM)GO TO 1
3 IF(MAXTST.LT.0)GO TO 4
IF(NEWVAL.GT.MAXMUM)GO TO 1
C
C TEST IF NEW VALUE IS ALREADY KNOWN
4 MIDDLE=MINSTR-1
IF(MAXUSD.LT.MINSTR)GO TO 11
IUPPER=MAXUSD
5 ILOWER=MIDDLE+1
GO TO 7
6 IUPPER=MIDDLE-1
7 IHALF=(IUPPER-ILOWER)/2
MIDDLE=IUPPER-IHALF
IF(NEWVAL.EQ.ISTORE(MIDDLE))GO TO 1
IF(JNCRES.GT.0)GO TO 8
IF(NEWVAL.LT.ISTORE(MIDDLE))GO TO 10
GO TO 9
8 IF(NEWVAL.GT.ISTORE(MIDDLE))GO TO 10
9 IF(IHALF.GT.0)GO TO 6
IF(IUPPER.LE.ILOWER)GO TO 12
IUPPER=ILOWER
GO TO 7
10 IF(IHALF.GT.0)GO TO 5
C
C SHIFT REST OF ARRAY AND INSERT NEW VALUE
11 MIDDLE=MIDDLE+1
12 IF(MAXUSD.LT.MAXSTR)GO TO 14
GO TO(13,17,17,13),INCRES
13 IF(MIDDLE.GT.MAXSTR)GO TO 1
GO TO 15
14 MAXUSD=MAXUSD+1
15 I=MAXUSD
16 IF(I.LE.MIDDLE)GO TO 19
ISTORE(I)=ISTORE(I-1)
I=I-1
GO TO 16
17 IF(MIDDLE.LE.MINSTR)GO TO 1
MIDDLE=MIDDLE-1
I=MINSTR
18 IF(I.GE.MIDDLE)GO TO 19
ISTORE(I)=ISTORE(I+1)
I=I+1
GO TO 18
19 ISTORE(MIDDLE)=NEWVAL
GO TO 1
20 KIND=2
GO TO 23
21 KIND=3
GO TO 23
22 KIND=4
23 RETURN
C445263597068
END
SUBROUTINE DAINXT (IBUFFR,MAXBFR,LOWBFR,
1 MANY ,KIND ,NEWVAL,INCVAL,LMTVAL)
C RENBR(/RETURNS NEXT NUMBER IN SERIES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DANEXT RETURNS TO THE CALLING PROGRAM THE NEXT NUMBER
C REPRESENTED BY THE CHARACTERS IN AN INPUT BUFFER READ
C BY THE CALLING PROGRAM WITH A MULTIPLE OF AN A1
C FORMAT. IF A SERIES SPECIFICATION IS ENCOUNTERED IN
C THE INPUT BUFFER, THEN THE INDIVIDUAL NUMBERS OF THE
C SERIES ARE RETURNED BY THE CALLS TO THIS ROUTINE.
C WHEN ALL OF THE NUMBERS FORMING THE SERIES HAVE BEEN
C RETURNED, THEN THE SUBSEQUENT NUMBER OR SERIES OF
C NUMBERS SPECIFIED BY THE CONTENTS OF THE BUFFER ARE
C EVALUATED.
C
C A SERIES EVALUATED BY THIS ROUTINE CAN BE WRITTEN AS
C A LOWER BOUND, INCREMENT AND UPPER BOUND SEPARATED BY
C SLASHES. IF THE INCREMENT IS TO BE ONE, THEN THE
C LOWER AND UPPER BOUNDS NEED BE SEPARATED ONLY BY A
C SINGLE SLASH. IF EITHER BOUND IS MISSING, IT IS
C ASSUMED TO BE ZERO. THE LOWER BOUND IS THE FIRST
C NUMBER OF THE SERIES REPORTED TO THE CALLING PROGRAM.
C THE SERIES CAN THEN EITHER INCREASE OR DECREASE
C DEPENDING UPON WHETHER THE UPPER BOUND IS LESS THAN,
C EQUAL TO, OR GREATER THAN THE LOWER BOUND. THE SIGN
C OF THE INCREMENT IS CHANGED IF IT DOES NOT CONFORM TO
C THE RELATIVE VALUES OF THE BOUNDS.
C
C IF THE SERIES IS TO CONSIST OF SEVERAL REPETITIONS OF
C THE SAME VALUE, THEN THE SERIES IS INSTEAD WRITTEN AS
C THE NUMBER OF TIMES THE VALUE IS TO BE USED FOLLOWED
C IMMEDIATELY BY AN ASTERISK AND THE VALUE ITSELF. THE
C VALUE TO BE REPEATED IS ASSUMED TO BE NULL IF IT IS
C MISSING.
C
C TWO VERSIONS OF THE ROUTINE ARE SUPPLIED. DANEXT CAN
C EVALUATE REAL NUMBERS AS WELL AS INTEGERS INCLUDING
C E, K AND M NOTATIONS FOR SPECIFYING EITHER OF THESE.
C IF THE CALLING PROGRAM DOES NOT OTHERWISE REFERENCE
C THE FREE FORMAT INPUT ROUTINE DAREAD, IF THE
C EVALUATION OF REAL NUMBERS IS NOT NEEDED, AND IF
C INTEGERS CAN BE SPECIFIED WITHOUT RESORTING TO THE E,
C K AND M NOTATIONS, THEN THE ROUTINE DAINXT SHOULD BE
C USED INSTEAD OF DANEXT. NUMBERS EVALUATED BY DAINXT
C MUST CONSIST ONLY OF DIGITS FOLLOWING THE OPTIONAL
C SIGN. DAINXT TREATS THE CHARACTERS ., %, K AND M THE
C SAME AS ANY OTHER DELIMITER CHARACTER.
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY AND ARE
C RETURNED UNCHANGED.
C
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY A MULTIPLE OF AN A1
C FORMAT, WHICH IS TO BE SEARCHED FOR SERIES
C SPECIFICATIONS. IBUFFR THEN CONTAINS ONE
C CHARACTER PER COMPUTER STORAGE LOCATION.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY TO BE
C SEARCHED
C
C FOLLOWING ARGUMENTS ARE USED AS BOTH INPUT AND OUTPUT
C
C LOWBFR = INPUT CONTAINING THE SUBSCRIPT WITHIN THE
C IBUFFR ARRAY OF THE FIRST (LEFTMOST)
C CHARACTER WHICH CAN BE SCANNED FOR A SERIES
C SPECIFICATION. LOWBFR IS RETURNED UNCHANGED
C IF THIS CALL TO THIS ROUTINE MERELY
C GENERATES THE NEXT MEMBER OF A SERIES BEGUN
C BY A PREVIOUS CALL. IF A NEW SERIES
C SPECIFICATION IS EVALUATED BY THIS CALL TO
C THIS ROUTINE, THEN LOWBFR WILL BE RETURNED
C POINTING TO THE NEXT CHARACTER BEYOND THE
C SERIES SPECIFICATION. IF A SECOND NUMBER
C IMMEDIATELY FOLLOWS A FIRST WITHOUT A
C SEPARATING SLASH OR ASTERISK, THEN LOWBFR
C WILL BE RETURNED POINTING TO THE FIRST
C CHARACTER OF THE SECOND NUMBER. IF EITHER A
C SPACE OR A TAB CHARACTER FOLLOWS A SERIES
C SPECIFICATION, THEN LOWBFR WILL BE RETURNED
C POINTING TO THE SPACE OR TAB CHARACTER. IF
C THERE IS NOTHING AT OR TO RIGHT OF LOWBFR,
C THEN LOWBFR WILL BE LEFT POINTING AT
C MAXBFR+1 AND KIND WILL BE RETURNED
C CONTAINING ONE. LOWBFR AND MANY MUST BE SET
C BY THE CALLING PROGRAM BEFORE ANYTHING IS
C PROCESSED IN THE CURRENT CONTENTS OF THE
C IBUFFR ARRAY, BUT THEN SHOULD NOT BE
C MODIFIED BY THE CALLING PROGRAM UNTIL THE
C ENTIRE CONTENTS OF THE IBUFFR ARRAY HAS BEEN
C PROCESSED.
C MANY = SHOULD BE INPUT CONTAINING ZERO EACH TIME
C THIS ROUTINE IS CALLED TO BEGIN PROCESSING
C OF A NEW LOGICAL SECTION OF TEXT, AS FOR
C EXAMPLE WHEN BEGINNING PROCESSING OF A LINE
C OF TEXT NOT TIED TO THE PREVIOUS LINE BY AN
C AMPERSAND AT THE END OF THE PREVIOUS LINE,
C OR WHEN PROCESSING THE TEXT TO THE RIGHT OF
C A SEMICOLON. MANY IS RETURNED SET TO ZERO
C WHENEVER AN END OF LINE (KIND=1) IS FOUND
C WHICH IS NOT TIED TO THE FOLLOWING LINE BY
C AN AMPERSAND, AND WHENEVER A SEMICOLON IS
C FOUND (KIND=2). MANY IS RETURNED INCREMENTED
C BY 1 EACH TIME A NEW SPECIFICATION OF EITHER
C A SINGLE NUMBER OR OF A SERIES IS FOUND,
C EACH TIME AN ERRONEOUS SERIES SPECIFICATION
C IS FOUND, OR EACH TIME AN INDICATION OF A
C MISSING SERIES SPECIFICATION IS FOUND. MANY
C IS RETURNED UNCHANGED IF THIS CALL TO THIS
C ROUTINE MERELY GENERATES THE NEXT MEMBER OF
C A SERIES ALREADY BEGUN BY A PREVIOUS CALL TO
C THIS ROUTINE. KIND IS RETURNED CONTAINING
C THE VALUE 3 AND MANY IS RETURNED CONTAINING
C THE NEGATIVE OF THE NUMBER OF ITEMS FOUND IF
C THE NEXT PRINTING CHARACTER FOLLOWING A
C COMMA IS AN AMPERSAND. MANY SHOULD NOT BE
C CHANGED BY THE CALLING PROGRAM IF AN
C AMPERSAND (KIND BEING RETURNED=3) IS FOUND
C INDICATING THAT THE SUBSEQUENT CALL TO THIS
C ROUTINE IS TO PROCESS TEXT WHICH IS TO BE
C TREATED AS THOUGH IT APPEARED IN PLACE OF
C THE AMPERSAND AND THE CHARACTERS TO ITS
C RIGHT. THE EFFECT IS NOT QUITE THE SAME AS
C IF THE USER HAD TYPED ALL OF THE TEXT ON A
C SINGLE LINE SINCE A SINGLE SERIES
C SPECIFICATION CANNOT BE SPLIT ACROSS THE
C LINE BOUNDARY.
C
C IF MANY IS INPUT CONTAINING ZERO, THEN AN
C INITIAL COMMA IN THE INPUT TEXT BUFFER IS
C TAKEN TO INDICATE AN INITIAL MISSING ITEM,
C AND MANY IS THEN RETURNED CONTAINING 1. IF
C MANY IS INPUT GREATER THAN ZERO, THEN AN
C INITIAL COMMA IS IGNORED IF FOLLOWED BY A
C SERIES SPECIFICATION. IF MANY IS INPUT
C GREATER THAN ZERO, THEN AN INITIAL COMMA
C FOLLOWED BY NO OTHER PRINTING CHARACTERS, BY
C A SEMICOLON, OR BY AN EXCLAMATION POINT
C INDICATES A MISSING ITEM. IF MANY IS INPUT
C GREATER THAN ZERO, THEN AN INITIAL COMMA
C FOLLOWED BY AN AMPERSAND WILL CAUSE THE
C REMAINING CHARACTERS IN THE BUFFER TO BE
C IGNORED, AND MANY WILL BE RETURNED
C CONTAINING THE NEGATIVE OF ITS INPUT VALUE.
C IF MANY IS INPUT NEGATIVE, THEN IT IS
C ASSUMED THAT THE CONTENTS OF THE CURRENT
C BUFFER CONTINUE A PREVIOUS LINE WHICH
C TERMINATED WITH A COMMA FOLLOWED BY AN
C AMPERSAND, AND MANY IS RETURNED GREATER THAN
C ZERO.
C KIND = SHOULD BE INPUT CONTAINING ZERO THE FIRST
C TIME THIS ROUTINE IS CALLED, OR TO ABANDON
C GENERATATION OF VALUES WITHIN A PARTICULAR
C SERIES. KIND IS RETURNED DESCRIBING THE
C KIND OF ITEM LOCATED IN THE IBUFFR ARRAY.
C = 1, NOTHING, EXCEPT PERHAPS COMMENT INDICATED
C BY A LEADING EXCLAMATION POINT, WAS FOUND AT
C OR TO RIGHT OF LOWBFR. THE CALLING PROGRAM
C SHOULD READ A NEW LINE INTO IBUFFR. MANY IS
C RETURNED SET TO ZERO.
C = 2, A SEMICOLON WAS FOUND AS THE FIRST
C PRINTING CHARACTER AT OR TO THE RIGHT OF
C LOWBFR. LOWBFR IS RETURNED POINTING TO THE
C NEXT CHARACTER BEYOND THE LOCATION OF THE
C SEMICOLON. IT IS ASSUMED THE CALLING
C PROGRAM WILL TREAT THE APPEARANCE OF THE
C SEMICOLON AS MARKING THE END OF A STATEMENT.
C MANY IS RETURNED SET TO ZERO.
C = 3, AN AMPERSAND WAS FOUND AS THE FIRST
C PRINTING CHARACTER AT OR TO THE RIGHT OF
C LOWBFR. THE TEXT TO THE RIGHT OF THE
C AMPERSAND IS TAKEN AS A COMMENT SO LOWBFR IS
C RETURNED POINTING BEYOND THE RIGHT END OF
C THE BUFFER. IT IS ASSUMED THAT THE CALLING
C PROGRAM WILL READ IN THE CONTENTS OF A NEW
C BUFFER, THEN AGAIN REQUEST A NEW SERIES
C EVALUATION FROM THIS ROUTINE. THE VALUE OF
C MANY MUST NOT BE CHANGED BY CALLING PROGRAM
C PRIOR TO THIS FOLLOWING CALL. THE EFFECT IS
C NOT QUITE THE SAME AS IF THE USER HAD TYPED
C ALL OF THE TEXT ON A SINGLE LINE SINCE A
C SERIES SPECIFICATION CANNOT BE SPLIT ACROSS
C A LINE BOUNDARY.
C = 4, A NUMBER OR SERIES SPECIFICATION WAS NOT
C FOUND, BUT A COMMA WAS FOUND INDICATING
C A MISSING SERIES SPECIFICATION. NEWVAL IS
C SET TO ZERO SO KIND=4 CAN BE CONSIDERED
C EQUIVALENT TO KIND=5 IF SUCH IS APPROPRIATE
C TO THE APPLICATION FOR WHICH THIS ROUTINE IS
C BEING USED.
C = 5, THE NEXT NUMBER SPECIFIED BY THE CONTENTS
C OF THE INPUT BUFFER IS BEING RETURNED AS THE
C VALUE OF NEWVAL.
C = 6, A SERIES WAS SPECIFIED IN ASTERISK
C NOTATION, BUT NO NUMBER APPEARED TO RIGHT OF
C ASTERISK. NEWVAL IS RETURNED SET TO ZERO.
C NOTE THAT IF A NUMBER DOES NOT PRECEDE THE
C ASTERISK, THEN KIND IS RETURNED WITH THE
C VALUE 7 WHETHER OR NOT A NUMBER FOLLOWS THE
C ASTERISK.
C = 7, A SERIES WAS SPECIFIED IN ASTERISK
C NOTATION, BUT NO NUMBER APPEARED TO THE LEFT
C OF THE ASTERISK OR THE NUMBER TO LEFT OF THE
C ASTERISK WAS LESS THAN 1. A NUMBER MAY OR
C MAY NOT HAVE APPEARED TO RIGHT OF ASTERISK.
C = 8, A SERIES SPECIFICATION WAS FOUND WHICH
C CONTAINED TOO MANY NUMBERS, TOO MANY
C ASTERISKS OR TOO MANY SLASHES.
C = 9, FIRST PRINTING CHARACTER IN OR TO RIGHT
C OF LOWBFR WAS NOT A CHARACTER WHICH COULD
C APPEAR IN A NUMBER OR NUMBER RANGE, AND WAS
C NOT A COMMA, SEMICOLON OR EXCLAMATION POINT.
C LOWBFR IS RETURNED POINTING TO THE NEXT
C CHARACTER BEYOND THIS CHARACTER.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT
C
C NEWVAL = RETURNED CONTAINING NEXT NUMBER SPECIFIED
C BY INPUT BUFFER.
C
C INCVAL AND LMTVAL MUST BE PRESERVED FROM ONE CALL TO
C NEXT BUT NOT USED BY CALLING PROGRAM
C
DIMENSION IBUFFR(MAXBFR)
C
IF(KIND.EQ.6)GO TO 2
IF(KIND.NE.5)GO TO 3
IF(INCVAL.EQ.0)GO TO 2
C
C GET NEXT NUMBER EXPRESSED IN SLASH NOTATION
NEWVAL=NEWVAL+INCVAL
IF(INCVAL.GT.0)GO TO 1
IF(NEWVAL.GE.LMTVAL)GO TO 11
GO TO 3
1 IF(NEWVAL.LE.LMTVAL)GO TO 11
GO TO 3
C
C GET NEXT NUMBER EXPRESSED IN ASTERISK NOTATION
2 LMTVAL=LMTVAL-1
IF(LMTVAL.GT.0)GO TO 11
C
C GET NEW RANGE SPECIFICATION
3 CALL DAISPN(-1,IBUFFR,MAXBFR,LOWBFR,
1MANY,KIND,INIGOT,INCGOT,LMTGOT,NEWVAL,INCVAL,
2LMTVAL)
GO TO(5,5,5,5,6,6,7,10,4,4),KIND
C
C INCORRECT SPECIFICATION
4 KIND=KIND-1
C
C SINGLE NUMBER WITHOUT SLASH OR ASTERISK
5 NEWVAL=0
6 INCVAL=0
LMTVAL=0
GO TO 11
C
C SERIES CONTAINING SLASH
7 KIND=5
IF(INIGOT.LE.0)NEWVAL=0
IF(INCGOT.LE.0)INCVAL=1
IF(INCVAL.EQ.0)INCVAL=1
IF(LMTGOT.LE.0)LMTVAL=0
IF(NEWVAL.GT.LMTVAL)GO TO 8
IF(INCVAL.GT.0)GO TO 11
GO TO 9
8 IF(INCVAL.LT.0)GO TO 11
9 INCVAL=-INCVAL
GO TO 11
C
C SERIES CONTAINING ASTERISK
10 KIND=5
IF(LMTGOT.LE.0)KIND=6
IF(INIGOT.LE.0)NEWVAL=0
IF(NEWVAL.LE.0)KIND=7
IF(LMTGOT.LE.0)LMTVAL=0
INCVAL=NEWVAL
NEWVAL=LMTVAL
LMTVAL=INCVAL
INCVAL=0
C
C RETURN TO CALLING PROGRAM
11 RETURN
C287488307054
END
SUBROUTINE DAISPN (KONECT,IBUFFR,MAXBFR,LOWBFR,
1 MANY ,KIND ,INIGOT,INCGOT,LMTGOT,INIVAL,INCVAL,
2 LMTVAL)
C RENBR(/INTERPRETS FREE FORMAT RANGE SPECIFICATIONS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DASPAN EVALUATES RANGE SPECIFICATIONS TYPED BY THE
C USER AND READ BY THE CALLING PROGRAM WITH A MULTIPLE
C OF AN A1 FORMAT. SUCH RANGE SPECIFICATIONS CAN
C CONSIST OF A SINGLE NUMBER, OR OF 2 NUMBERS SEPARATED
C BY AN ASTERISK, OR OF EITHER 2 OR 3 NUMBERS SEPARATED
C BY SLASHES OR BY COLONS WHICH ARE TAKEN AS EQUIVALENT
C TO SLASHES. THE ASTERISK NOTATION IS MEANT TO
C INDICATE THAT THE VALUE TO THE RIGHT OF THE ASTERISK
C IS TO BE REPEATED THE NUMBER OF TIMES INDICATED BY
C THE NUMBER TO THE LEFT OF THE ASTERISK. NUMBERS
C SPECIFIED IN THE SLASH NOTATION CAN BE INTERPRETED AS
C THE LOWER AND UPPER BOUNDS OF A RANGE IF 2 NUMBERS
C ARE PRESENT, OR AS THE LOWER BOUND, THE INCREMENT,
C AND THE UPPER BOUND, IF 3 NUMBERS ARE INCLUDED.
C
C DASPAN REPORTS TO THE CALLING PROGRAM WHETHER THE
C NUMBERS ARE PRESENT IN THE SERIES SPECIFICATION, AS
C WELL AS THE VALUES OF THOSE NUMBERS WHICH ARE
C PRESENT. THE CALLING PROGRAM WILL HAVE TO ASSIGN
C DEFAULT VALUES FOR ANY NUMBERS WHICH ARE MISSING.
C THE RANGE SPECIFICATION /2/10 INDICATES THAT THE
C RANGE IS TO EXTEND FROM THE DEFAULT LOWER BOUND WITH
C AN INCRMENT OF 2 THROUGH THE UPPER BOUND OF 10.
C EITHER RANGE SPECIFICATION 1/10 OR 1//10 IS TAKEN TO
C MEAN THAT THE RANGE IS TO EXTEND FROM 1 THROUGH 10
C WITH THE DEFAULT INCREMENT. IF THE NUMBERS SPECIFY
C THE VALUES OF A SUBSCRIPT OF AN ARRAY, THEN A MISSING
C LOWER BOUND MIGHT BE TAKEN TO INDICATE THAT THE
C SUBSCRIPT BEING VARIED STARTS AT ITS MINIMUM POSSIBLE
C VALUE (USUALLY 1), WHILE A MISSING UPPER BOUND MIGHT
C INDICATE THAT THE SUBSCRIPT IS TO TERMINATE AT ITS
C MAXIMUM POSSIBLE VALUE.
C
C TWO VERSIONS OF THE ROUTINE ARE SUPPLIED. DASPAN CAN
C EVALUATE REAL NUMBERS AS WELL AS INTEGERS INCLUDING
C E, K AND M NOTATIONS FOR SPECIFYING EITHER OF THESE.
C IF THE CALLING PROGRAM DOES NOT OTHERWISE REFERENCE
C THE FREE FORMAT INPUT ROUTINE DAREAD, IF THE
C EVALUATION OF REAL NUMBERS IS NOT NEEDED, AND IF
C INTEGERS CAN BE SPECIFIED WITHOUT RESORTING TO THE E,
C K AND M NOTATIONS, THEN THE ROUTINE DAISPN SHOULD BE
C USED INSTEAD OF DASPAN. NUMBERS EVALUATED BY DAISPN
C MUST CONSIST ONLY OF DIGITS FOLLOWING THE OPTIONAL
C SIGN. DAISPN TREATS THE CHARACTERS ., %, K AND M THE
C SAME AS ANY OTHER DELIMITER CHARACTER.
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY AND ARE
C RETURNED UNCHANGED.
C
C KONECT = -1, ONCE A SLASH, AN ASTERISK OR A NUMBER IS
C FOUND IN THE IBUFFR ARRAY, THE SERIES
C SPECIFICATION WILL EXTEND TO THE NEXT SPACE
C OR TAB CHARACTER, OR TO ANY CHARACTER OTHER
C THAN A SLASH OR AN ASTERISK WHICH IMMEDITELY
C FOLLOWS A NUMBER IN THE SERIES
C SPECIFICATION. IF KONECT=-1, THEN THE TEXT
C 1/2+3/4 5/6+7/+8
C WOULD CONTAIN THE RANGE SPECIFICATIONS 1 TO
C 2, 3 TO 4, 5 TO 6, AND 7 TO 8.
C = 0, SPACES CAN APPEAR BETWEEN THE NUMBERS OF
C A SERIES IN ADDITION TO SLASHES OR ASTERISK.
C THE SLASHES OR THE ASTERISK ARE, HOWEVER,
C REQUIRED.
C = 1, SPACES AND/OR TAB CHARACTERS CAN APPEAR
C BETWEEN THE NUMBERS OF A SERIES IN ADDITION
C TO OR IN PLACE OF SLASHES OR ASTERISKS. IF
C KONECT=1, THEN THE TEXT
C 1 2 3,4/5 6,7 8/9,10 / 11 12
C IS EXACTLY EQUIVALENT, EXCEPT FOR THE VALUE
C OF KIND RETURNED FOR THE FIRST SERIES, TO
C THE TEXT
C 1/2/3,4/5/6,7/8/9,10/11/12
C THE FIRST SERIES (1 2 3) IN THE FIRST
C EXAMPLE WOULD RETURN KIND=6 INDICATING A
C SERIES IN WHICH NEITHER A SLASH NOR AN
C ASTERISK APPEARED, WHILE THE CORRESPONDING
C SERIES SPECIFICATION IN THE SECOND EXAMPLE
C WOULD RETURN KIND=7 INDICATING THAT AT LEAST
C 1 SLASH WAS ENCOUNTERED IN THE SERIES
C SPECIFICATION.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY A MULTIPLE OF AN A1
C FORMAT, WHICH IS TO BE SEARCHED FOR SERIES
C SPECIFICATIONS. IBUFFR THEN CONTAINS ONE
C CHARACTER PER COMPUTER STORAGE LOCATION.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY TO BE
C SEARCHED
C
C FOLLOWING ARGUMENTS ARE USED AS BOTH INPUT AND OUTPUT
C
C LOWBFR = INPUT CONTAINING THE SUBSCRIPT WITHIN THE
C IBUFFR ARRAY OF THE FIRST (LEFTMOST)
C CHARACTER WHICH CAN BE SCANNED FOR A SERIES
C SPECIFICATION. LOWBFR WILL BE RETURNED
C POINTING TO THE NEXT CHARACTER BEYOND THE
C SERIES SPECIFICATION. IF KONECT IS .LE.0
C FORCING A SERIES SPECIFICATION TO CONTAIN
C EITHER A SLASH OR AN ASTERISK BETWEEN THE
C NUMBERS OF A SERIES, AND IF A SECOND NUMBER
C IMMEDIATELY FOLLOWS A FIRST WITHOUT A
C SEPARATING SLASH OR ASTERISK, THEN LOWBFR
C WILL BE RETURNED POINTING TO THE FIRST
C CHARACTER OF THE SECOND NUMBER. IF KONECT
C IS -1 AND IF EITHER A SPACE OR A TAB
C CHARACTER FOLLOWS A SERIES SPECIFICATION,
C THEN LOWBFR WILL BE RETURNED POINTING TO THE
C SPACE OR TAB CHARACTER. IF KONECT IS .GE.0,
C ALLOWING SPACES AND TAB CHARACTERS TO APPEAR
C WITHIN A SERIES SPECIFICATION, THEN LOWBFR
C WILL BE RETURNED POINTING TO THE FIRST
C CHARACTER TO THE RIGHT OF THE SERIES AND
C WHICH IS NOT ITSELF A SPACE, A TAB CHRACTER,
C A SLASH OR AN ASTERISK AND WHICH CANNOT
C APPEAR WITHIN A NUMBER. IF THERE IS NOTHING
C AT OR TO RIGHT OF LOWBFR, THEN LOWBFR WILL
C BE LEFT POINTING AT MAXBFR+1 AND KIND WILL
C BE RETURNED CONTAINING ONE. LOWBFR AND MANY
C MUST BE SET BY THE CALLING PROGRAM BEFORE
C ANYTHING IS PROCESSED IN THE CURRENT
C CONTENTS OF THE IBUFFR ARRAY, BUT THEN
C SHOULD NOT BE MODIFIED BY THE CALLING
C PROGRAM UNTIL THE ENTIRE CONTENTS OF THE
C IBUFFR ARRAY HAS BEEN PROCESSED.
C MANY = SHOULD BE INPUT CONTAINING ZERO EACH TIME
C THIS ROUTINE IS CALLED TO BEGIN PROCESSING
C OF A NEW LOGICAL SECTION OF TEXT, AS FOR
C EXAMPLE WHEN BEGINNING PROCESSING OF A LINE
C OF TEXT NOT TIED TO THE PREVIOUS LINE BY AN
C AMPERSAND AT THE END OF THE PREVIOUS LINE,
C OR WHEN PROCESSING THE TEXT TO THE RIGHT OF
C A SEMICOLON. MANY IS RETURNED SET TO ZERO
C WHENEVER AN END OF LINE (KIND=1) IS FOUND
C WHICH IS NOT TIED TO THE FOLLOWING LINE BY
C AN AMPERSAND, AND WHENEVER A SEMICOLON IS
C FOUND (KIND=2). MANY IS RETURNED INCREMENTED
C BY 1 EACH TIME A DESCRIPTION OF A SERIES
C SPECIFICATION IS RETURNED BY THIS ROUTINE,
C EACH TIME AN ERRONEOUS SERIES SPECIFICATION
C IS FOUND, OR EACH TIME AN INDICATION OF A
C MISSING SERIES SPECIFICATION IS FOUND. KIND
C IS RETURNED CONTAINING THE VALUE 3 AND MANY
C IS RETURNED CONTAINING THE NEGATIVE OF THE
C NUMBER OF ITEMS FOUND IF THE NEXT PRINTING
C CHARACTER FOLLOWING A COMMA IS AN AMPERSAND.
C MANY SHOULD NOT BE CHANGED BY THE CALLING
C PROGRAM IF AN AMPERSAND (KIND BEING
C RETURNED=3) IS FOUND INDICATING THAT THE
C SUBSEQUENT CALL TO THIS ROUTINE IS TO
C PROCESS TEXT WHICH IS TO BE TREATED AS
C THOUGH IT APPEARED IN PLACE OF THE AMPERSAND
C AND THE CHARACTERS TO ITS RIGHT. THE EFFECT
C IS NOT QUITE THE SAME AS IF THE USER HAD
C TYPED ALL OF THE TEXT ON A SINGLE LINE SINCE
C A SINGLE SERIES SPECIFICATION CANNOT BE
C SPLIT ACROSS THE LINE BOUNDARY.
C
C IF MANY IS INPUT CONTAINING ZERO, THEN AN
C INITIAL COMMA IN THE INPUT TEXT BUFFER IS
C TAKEN TO INDICATE AN INITIAL MISSING ITEM,
C AND MANY IS THEN RETURNED CONTAINING 1. IF
C MANY IS INPUT GREATER THAN ZERO, THEN AN
C INITIAL COMMA IS IGNORED IF FOLLOWED BY A
C SERIES SPECIFICATION. IF MANY IS INPUT
C GREATER THAN ZERO, THEN AN INITIAL COMMA
C FOLLOWED BY NO OTHER PRINTING CHARACTERS, BY
C A SEMICOLON, OR BY AN EXCLAMATION POINT
C INDICATES A MISSING ITEM. IF MANY IS INPUT
C GREATER THAN ZERO, THEN AN INITIAL COMMA
C FOLLOWED BY AN AMPERSAND WILL CAUSE THE
C REMAINING CHARACTERS IN THE BUFFER TO BE
C IGNORED, AND MANY WILL BE RETURNED
C CONTAINING THE NEGATIVE OF ITS INPUT VALUE.
C IF MANY IS INPUT NEGATIVE, THEN IT IS
C ASSUMED THAT THE CONTENTS OF THE CURRENT
C BUFFER CONTINUE A PREVIOUS LINE WHICH
C TERMINATED WITH A COMMA FOLLOWED BY AN
C AMPERSAND, AND MANY IS RETURNED GREATER THAN
C ZERO.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT
C
C KIND = RETURNED DESCRIBING THE KIND OF ITEM LOCATED
C IN THE IBUFFR ARRAY.
C = 1, EITHER NO PRINTING CHARACTERS OR ELSE AN
C EXCLAMATION POINT AS THE FIRST PRINTING
C CHARACTER (MARKING THE REST OF THE LINE AS A
C COMMENT) WAS FOUND AT OR TO THE RIGHT OF
C LOWBFR. THE CALLING PROGRAM SHOULD READ A
C NEW LINE INTO IBUFFR. MANY, INIGOT, INCGOT
C AND LMTGOT ARE ALL RETURNED WITH VALUE ZERO.
C = 2, A SEMICOLON WAS FOUND AS THE FIRST
C PRINTING CHARACTER AT OR TO THE RIGHT OF
C LOWBFR. LOWBFR IS RETURNED POINTING TO THE
C NEXT CHARACTER BEYOND THE LOCATION OF THE
C SEMICOLON. IT IS ASSUMED THE CALLING
C PROGRAM WILL TREAT THE APPEARANCE OF THE
C SEMICOLON AS MARKING THE END OF A STATEMENT.
C MANY IS RETURNED WITH THE VALUE ZERO.
C = 3, AN AMPERSAND WAS FOUND AS THE FIRST
C PRINTING CHARACTER AT OR TO THE RIGHT OF
C LOWBFR. THE TEXT TO THE RIGHT OF THE
C AMPERSAND IS TAKEN AS A COMMENT SO LOWBFR IS
C RETURNED POINTING BEYOND THE RIGHT END OF
C THE BUFFER. IT IS ASSUMED THAT THE CALLING
C PROGRAM WILL READ IN THE CONTENTS OF A NEW
C BUFFER, THEN AGAIN REQUEST A NEW SERIES
C EVALUATION FROM THIS ROUTINE. THE VALUE OF
C MANY MUST NOT BE CHANGED BY CALLING PROGRAM
C PRIOR TO THIS FOLLOWING CALL. THE EFFECT IS
C NOT QUITE THE SAME AS IF THE USER HAD TYPED
C ALL OF THE TEXT ON A SINGLE LINE SINCE A
C SERIES SPECIFICATION CANNOT BE SPLIT ACROSS
C A LINE BOUNDARY.
C = 4, A NUMBER OR SERIES SPECIFICATION WAS NOT
C FOUND BUT INITIAL COMMA WAS FOUND INDICATING
C A MISSING SERIES SPECIFICATION. INIGOT,
C INCGOT AND LMTGOT ARE EACH RETURNED WITH THE
C VALUE ZERO SO KIND=4 CAN BE CONSIDERED
C EQUIVALENT TO KIND=5 IF SUCH IS APPROPRIATE
C TO THE APPLICATION FOR WHICH THIS ROUTINE IS
C BEING USED.
C = 5, A SINGLE NUMBER WITH NEITHER A SLASH NOR
C AN ASTERISK WAS FOUND IN THE INPUT BUFFER.
C BOTH INIGOT AND LMTGOT ARE RETURNED
C CONTAINING 1, AND THE VALUE OF THE NUMBER IS
C RETURNED IN BOTH INIVAL AND LMTVAL. INCGOT
C IS RETURNED CONTAINING ZERO.
C = 6, EITHER 2 OR 3 NUMBERS WERE FOUND, BUT
C WITHOUT SLASHES OR ASTERISKS. THE VALUE OF
C THE LEFT NUMBER IS RETURNED IN INIVAL,
C OF THE RIGHT IN LMTVAL, AND OF THE MIDDLE,
C IF PRESENT, IN INCVAL. INIGOT AND LMTGOT
C ARE EACH RETURNED CONTAINING 1. INCGOT IS
C RETURNED CONTAINING 1 ONLY IF 3 NUMBERS WERE
C FOUND. KONECT WOULD HAVE TO BE INPUT AS 1
C FOR KIND TO BE RETURNED AS 6.
C = 7, A SERIES SPECIFICATION CONTAINING ONE OR
C MORE SLASHES WAS FOUND. THE LOCATION OF THE
C SLASH OR SLASHES RELATIVE TO THE NUMBERS, IF
C ANY, IN THE SERIES SPECIFICATION IS
C INDICATED BY THE RETURNED VALUES OF INIGOT,
C INCGOT AND LMTGOT.
C = 8, A SERIES SPECIFICATION CONTAINING A
C SINGLE ASTERISK WAS FOUND. INCGOT IS
C RETURNED CONTAINING ZERO. THE LOCATION OF
C THE ASTERISK RELATIVE TO THE NUMBERS, IF
C ANY, IN THE SERIES SPECIFICATION IS
C INDICATED BY THE RETURNED VALUES OF INIGOT
C AND LMTGOT.
C = 9, A SERIES SPECIFICATION WAS FOUND WHICH
C INCLUDED TOO MANY NUMBERS, TOO MANY SLASHES
C OR TOO MANY ASTERISKS. INIGOT, INCGOT AND
C LMTGOT ARE EACH RETURNED CONTAINING ZERO.
C = 10, FIRST PRINTING CHARACTER IN OR TO RIGHT
C OF LOWBFR WAS NOT A CHARACTER WHICH COULD
C APPEAR IN A NUMBER OR NUMBER RANGE, AND WAS
C NOT A COMMA, SEMICOLON OR EXCLAMATION POINT.
C LOWBFR IS RETURNED POINTING TO THE NEXT
C CHARACTER BEYOND THIS CHARACTER.
C INIGOT = 0, RETURNED IF THE CONTENTS OF THE BUFFER DO
C NOT SPECIFY THE START OF THE RANGE. INIVAL
C IS RETURNED UNDEFINED, BUT PROBABLY CHANGED.
C = 1, RETURNED IF THE CONTENTS OF THE BUFFER
C SPECIFY THE START OF THE RANGE. INIVAL IS
C RETURNED CONTAINING THIS STARTING NUMBER.
C INCGOT = 0, RETURNED IF THE CONTENTS OF THE BUFFER DO
C NOT SPECIFY AN INCREMENT BY WHICH THE
C STARTING VALUE IS TO BE VARIED UNTIL IT
C REACHES THE ENDING VALUE. INCVAL IS
C RETURNED UNDEFINED, BUT PROBABLY CHANGED.
C = 1, RETURNED IF THE CONTENTS OF THE BUFFER
C SPECIFY AN INCREMENT BY WHICH THE STARTING
C VALUE IS TO BE VARIED UNTIL IT REACHES THE
C ENDING VALUE. INCVAL IS RETURNED CONTAINING
C THIS INCREMENT.
C LMTGOT = 0, RETURNED IF THE CONTENTS OF THE BUFFER DO
C NOT SPECIFY A NUMBER AT WHICH THE RANGE IS
C TO END. LMTVAL IS RETURNED UNDEFINED, BUT
C PROBABLY CHANGED.
C = 1, RETURNED IF THE CONTENTS OF THE BUFFER
C SPECIFY A NUMBER AT WHICH THE RANGE IS TO
C END. LMTVAL IS RETURNED CONTAINING THIS
C ENDING VALUE.
C INIVAL = RETURNED CONTAINING THE START OF THE RANGE
C IF THIS IS SPECIFIED (INIGOT RETURNED=1).
C INCVAL = RETURNED CONTAINING THE INCREMENT IF THIS IS
C SPECIFIED (INCGOT RETURNED=1).
C LMTVAL = RETURNED CONTAINING THE END OF THE RANGE IF
C THIS IS SPECIFIED (LMTGOT RETURNED=1).
C
C EVALUATION OF RANGE SPECIFICATIONS LMTVAL
C SHOWN BELOW WOULD PRODUCE ARGUMENT INCVAL !
C VALUES TO THEIR RIGHT. "U" INDICATES INIVAL ! !
C THAT THE ARGUMENT IS UNDEFINED. LMTGOT ! ! !
C INCGOT ! ! ! !
C INIGOT ! ! ! ! !
C EMPTY OR / OR // OR * 0 0 0 U U U
C /// OR 5///9 OR 5 2 2 9 0 0 0 U U U
C /9 OR //9 OR *9 0 0 1 U U 9
C /2/ 0 1 0 U 2 U
C /2/9 OR /2 9 0 1 1 U 2 9
C 5/ OR 5// OR 5* 1 0 0 5 U U
C 5 1 0 1 5 U 5
C 5/9 OR 5//9 OR 5 9 OR 5*9 1 0 1 5 U 9
C 5/2/ OR 5 2/ 1 1 0 5 2 U
C 5/2/9 OR 5 2/9 OR 5/2 9 OR 5 2 9 1 1 1 5 2 9
C
DIMENSION IBUFFR(MAXBFR),IDIGIT(10)
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA ISLASH,ICOLON,ISTAR,KOMENT,IEND,IAND,KOMMA,
1IPLUS,IMINUS,ISPACE,ITAB/
21H/,1H:,1H*,1H!,1H;,1H&,1H,,1H+,1H-,1H ,1H /
ISTATE=0
KOUNT=0
INIGOT=1
KNTSEP=0
LMTGOT=1
KIND=1
ITEST=2
INCVAL=0
LMTVAL=0
IF(MANY.GE.0)GO TO 2
KIND=4
MANY=-MANY
GO TO 2
C
C TEST IF NEXT CHARACTER CAN BE IN SERIES SPECIFICATION
1 LOWBFR=LOWBFR+1
2 IF(LOWBFR.GT.MAXBFR)GO TO 23
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.ISPACE)GO TO 10
IF(LETTER.EQ.ITAB)GO TO 10
IF(LETTER.EQ.ISLASH)GO TO 8
IF(LETTER.EQ.ICOLON)GO TO 8
IF(LETTER.EQ.ISTAR)GO TO 7
IF(LETTER.EQ.KOMENT)GO TO 21
IF(LETTER.EQ.IEND)GO TO 11
IF(LETTER.EQ.KOMMA)GO TO 6
IF(LETTER.EQ.IAND)GO TO 12
IF(KONECT.GT.0)GO TO 3
IF(ISTATE.GT.0)GO TO 23
3 IF(LETTER.EQ.IMINUS)GO TO 14
IF(LETTER.EQ.IPLUS)GO TO 15
DO 4 I=1,10
IF(LETTER.NE.IDIGIT(I))GO TO 4
IVALUE=I-1
ISIGN=0
GO TO 17
4 CONTINUE
IF(KIND.EQ.4)GO TO 5
IF(KIND.NE.1)GO TO 23
5 LOWBFR=LOWBFR+1
KIND=10
GO TO 23
C
C TEST IF DELIMITER CHARACTER CAN PRECEDE A SERIES
6 IF(KIND.NE.1)GO TO 23
KIND=4
IF(MANY.EQ.0)GO TO 24
GO TO 1
C
C ASTERISK FOUND
7 IF(KIND.EQ.7)ITEST=0
IF(ITEST.GT.0)ITEST=1
KIND=8
GO TO 9
C
C SLASH FOUND
8 IF(KIND.EQ.8)ITEST=0
KIND=7
9 IF(KOUNT.EQ.0)INIGOT=0
LMTGOT=0
KNTSEP=KNTSEP+1
ISTATE=-1
GO TO 1
C
C SPACE FOUND
10 IF(ISTATE.EQ.0)GO TO 1
IF(KONECT.GE.0)GO TO 1
GO TO 23
C
C SEMICOLON FOUND
11 IF(KIND.NE.1)GO TO 23
LOWBFR=LOWBFR+1
KIND=2
GO TO 23
C
C AMPERSAND FOUND
12 IF(KIND.EQ.1)GO TO 13
IF(KIND.NE.4)GO TO 23
MANY=-MANY
13 KIND=3
GO TO 22
C
C MINUS SIGN FOUND
14 ISIGN=-1
GO TO 16
C
C PLUS SIGN FOUND
15 ISIGN=1
16 IVALUE=0
C
C EVALUATE NUMBER AND PLACE INTO PUSH-DOWN STACK
17 IF(KIND.LE.5)KIND=KOUNT+5
KOUNT=KOUNT+1
IF(ISTATE.LT.0)KNTSEP=KNTSEP-1
ISTATE=1
LMTGOT=1
INIVAL=INCVAL
INCVAL=LMTVAL
18 LOWBFR=LOWBFR+1
IF(LOWBFR.GT.MAXBFR)GO TO 20
LETTER=IBUFFR(LOWBFR)
DO 19 I=1,10
IF(LETTER.NE.IDIGIT(I))GO TO 19
IVALUE=(10*IVALUE)+I-1
GO TO 18
19 CONTINUE
20 IF(ISIGN.LT.0)IVALUE=-IVALUE
LMTVAL=IVALUE
GO TO 2
C
C TEST IF TOO MANY ITEMS WERE FOUND IN SPECIFICATION
21 IF(KIND.NE.1)GO TO 23
22 LOWBFR=MAXBFR+1
23 IF((KOUNT+KNTSEP-INIGOT).LE.ITEST)GO TO 24
KIND=9
GO TO 25
C
C CONVERT PUSH-DOWN STACK INTO RANGE DESCRIPTION
24 IF(KOUNT.GE.3)GO TO 29
IF(KOUNT.EQ.2)GO TO 26
IF(KOUNT.EQ.1)GO TO 27
25 INIGOT=0
LMTGOT=0
GO TO 31
26 IF(INIGOT.EQ.0)GO TO 29
INIVAL=INCVAL
GO TO 28
27 IF(INIGOT.NE.0)GO TO 30
28 IF(LMTGOT.NE.0)GO TO 31
INCVAL=LMTVAL
29 INCGOT=1
GO TO 32
30 INIVAL=LMTVAL
31 INCGOT=0
C
C EVERYTHING IS IN ITS PLACE, RETURN TO CALLING ROUTINE
32 IF(KIND.GT.3)MANY=MANY+1
IF(KIND.LT.3)MANY=0
33 RETURN
C
C KNTSEP = NUMBER OF SLASHES AND ASTERISKS NOT FOLLOWED
C BY A NUMBER.
C ISTATE = 1, WITHIN NUMBER
C = 0, SPACE
C = -1, SLASH FOUND
C ITEST = MAXIMUM NUMBER OF SLASHES OR ASTERISKS
C ALLOWED IN A SINGLE SERIES SPECIFICATION.
C JSIGN = -1, MINUS SIGN AT START OF NUMBER
C = 0, NO SIGN AT START OF NUMBER
C = 1, PLUS SIGN AT START OF NUMBER
C KOUNT = NUMBER OF NUMBERS ALREADY FOUND
C
C713940183127:!;&
END
SUBROUTINE DALOAD(IDSK ,LTRMAX,NUMMAX,MAXBFR,LTRUSD,
1NUMUSD,LTRSTR,NUMSTR,IBUFFR,IFULL )
C RENBR(/CONSTRUCT DESCRIPTION OF FORTRAN ARRAYS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE IS USED ALONG WITH SEVERAL OTHERS IN
C FASP, THE FORTRAN ALPHAMERIC SUBROUTINE PACKAGE, FOR
C THE PURPOSE OF SELECTING BY NAME AND SUBSCRIPTS,
C EXAMINING AND MODIFYING THE VALUES IN ARRAY LOCATIONS
C KNOWN TO THE CALLING PROGRAM. PLEASE CONSULT THE
C FASP DOCUMENTATION FOR DESCRIPTIONS OF THESE ROUTINES
C
DIMENSION LTRSTR(LTRMAX),NUMSTR(NUMMAX),
1IBUFFR(MAXBFR),IDIGIT(10),LETTER(26),ITYPE(26),
2IWORD(42),KNTLTR(8)
DATA KNTLTR/5,7,4,6,9,8,3,0/
DATA IWORD/
11HO,1HC,1HT,1HA,1HL,
21HI,1HN,1HT,1HE,1HG,1HE,1HR,
31HR,1HE,1HA,1HL,
41HC,1HO,1HM,1HM,1HO,1HN,
51HD,1HI,1HM,1HE,1HN,1HS,1HI,1HO,1HN,
61HI,1HM,1HP,1HL,1HI,1HC,1HI,1HT,
71HE,1HN,1HD/
DATA IDIGIT/
11H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA LETTER/
11HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
21HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
31HU,1HV,1HW,1HX,1HY,1HZ/
DATA ICOMNT,ILEFT,IRIGHT,IPLUS,IMINUS,ICOMMA,ISLASH,
1ICOLON,IBLANK,ITAB/
21HC,1H(,1H),1H+,1H-,1H,,1H/,1H:,1H ,1H /
C
C DEFINE DEFAULT TYPES BASED ON LEADING LETTERS OF NAME
DO 1 I=1,26
ITYPE(I)=1
1 CONTINUE
DO 2 I=9,14
ITYPE(I)=0
2 CONTINUE
C
C CLEAR OTHER INTERNAL STORAGE
JSLASH=-1
KOUNT=0
IWHERE=0
3 KONTNU=0
C
C READ IN NEXT LINE
4 READ(IDSK,5,END=15)IBUFFR
5 FORMAT(100A1)
IF(IBUFFR(1).EQ.ICOMNT)GO TO 4
C
C FIND RIGHT END OF TEXT
IEND=MAXBFR
GO TO 7
6 IEND=IEND-1
IF(IEND.LE.0)GO TO 4
7 IF(IBUFFR(IEND).EQ.IBLANK)GO TO 6
IF(IBUFFR(IEND).EQ.ITAB)GO TO 6
C
C TEST IF THE LINE IS A CONTINUATION
IF(IBUFFR(1).EQ.IBLANK)GO TO 10
IF(IBUFFR(1).NE.ITAB)GO TO 10
IBGN=1
8 IBGN=IBGN+1
IF(IBUFFR(IBGN).EQ.IBLANK)GO TO 8
IF(IBUFFR(IBGN).EQ.ITAB)GO TO 8
DO 9 I=2,10
IF(IBUFFR(IBGN).EQ.IDIGIT(I))GO TO 16
9 CONTINUE
IF(IBUFFR(IBGN).NE.IDIGIT(1))IBGN=IBGN-1
GO TO 11
10 IF(IEND.LT.6)GO TO 4
IBGN=6
IF(IBUFFR(6).EQ.IBLANK)GO TO 11
IF(IBUFFR(6).EQ.IDIGIT(1))GO TO 11
GO TO 16
C
C START OF NEW STATEMENT, LOOK FOR KNOWN LEADING WORDS
11 IF(KOUNT.NE.0)GO TO 36
12 KONTNU=0
KOUNT=0
IWHERE=0
LAST=0
IF(JSLASH.GT.0)JSLASH=JSLASH-2
13 KONTNU=KONTNU+1
IF(KNTLTR(KONTNU).LE.0)GO TO 3
INIT=LAST+1
LAST=LAST+KNTLTR(KONTNU)
JBGN=IBGN
14 JBGN=JBGN+1
IF(JBGN.GT.IEND)GO TO 13
IF(IBUFFR(JBGN).EQ.IBLANK)GO TO 14
IF(IBUFFR(JBGN).EQ.ITAB)GO TO 14
IF(IBUFFR(JBGN).NE.IWORD(INIT))GO TO 13
INIT=INIT+1
IF(INIT.LE.LAST)GO TO 14
IBGN=JBGN
IF(KONTNU.LT.6)GO TO 17
IF(KONTNU.EQ.6)GO TO 48
IF(JBGN.NE.IEND)GO TO 3
IFULL=1
GO TO 67
C
C END-OF-FILE READ
15 IFULL=2
IF(KONTNU.LE.0)GO TO 67
IF(KOUNT.EQ.0)GO TO 67
IWHERE=-1
GO TO 36
C
C FIND THE NAME IF ANY
16 IF(KONTNU.EQ.0)GO TO 4
I=IWHERE
IWHERE=0
IF(I.EQ.1)GO TO 18
IF(I.EQ.2)GO TO 28
IF(I.EQ.3)GO TO 51
17 KOUNT=0
NUMBGN=NUMUSD
LTRBGN=LTRUSD
INIGOT=0
LMTGOT=0
KBREAK=1
18 IBGN=IBGN+1
IF(IBGN.GT.IEND)GO TO 61
IF(IBUFFR(IBGN).EQ.ISLASH)GO TO 22
IF(IBUFFR(IBGN).EQ.ILEFT)GO TO 25
IF(JSLASH.EQ.2)GO TO 18
IF(IBUFFR(IBGN).EQ.IBLANK)GO TO 18
IF(IBUFFR(IBGN).EQ.ITAB)GO TO 18
DO 19 I=1,26
IF(IBUFFR(IBGN).NE.LETTER(I))GO TO 19
IF(KOUNT.NE.0)GO TO 21
NUMUSD=NUMUSD+3
IF(NUMUSD.GT.NUMMAX)GO TO 64
J=KONTNU-2
IF(J.GT.1)J=ITYPE(I)
NUMSTR(NUMUSD-1)=J
GO TO 21
19 CONTINUE
IF(KOUNT.EQ.0)GO TO 18
DO 20 I=1,10
IF(IBUFFR(IBGN).EQ.IDIGIT(I))GO TO 21
20 CONTINUE
GO TO 36
21 LTRUSD=LTRUSD+1
IF(LTRUSD.GT.LTRMAX)GO TO 65
LTRSTR(LTRUSD)=IBUFFR(IBGN)
KOUNT=KOUNT+1
GO TO 18
C
C SLASH FOUND
22 IF(KOUNT.EQ.0)GO TO 23
IBGN=IBGN-1
GO TO 42
23 IF(JSLASH.LE.0)GO TO 24
JSLASH=JSLASH-2
GO TO 18
24 JSLASH=1
GO TO 18
C
C LEFT PARENTHESIS FOUND
25 IF(KOUNT.NE.0)GO TO 26
IF(JSLASH.EQ.2)GO TO 26
IF(JSLASH.EQ.0)GO TO 26
KOUNT=-1
NUMUSD=NUMUSD+3
IF(NUMUSD.GT.NUMMAX)GO TO 64
C
C EVALUATE SUBSCRIPT RANGES
26 IDONE=0
INIVAL=0
INIGOT=0
LMTGOT=0
27 ISIGN=1
28 IBGN=IBGN+1
IF(IBGN.GT.IEND)GO TO 62
IF(IBUFFR(IBGN).EQ.IBLANK)GO TO 28
IF(IBUFFR(IBGN).EQ.ITAB)GO TO 28
IF(IBUFFR(IBGN).EQ.IRIGHT)GO TO 37
IF(KOUNT.EQ.0)GO TO 28
IF(IBUFFR(IBGN).EQ.ISLASH)GO TO 35
IF(IBUFFR(IBGN).EQ.ICOLON)GO TO 35
IF(IBUFFR(IBGN).EQ.IPLUS)GO TO 32
IF(IBUFFR(IBGN).EQ.IMINUS)GO TO 31
IF(IBUFFR(IBGN).EQ.ICOMMA)GO TO 38
DO 30 I=1,10
IF(IBUFFR(IBGN).NE.IDIGIT(I))GO TO 30
IF(LMTGOT.NE.0)GO TO 29
INIVAL=(10*INIVAL)+I-1
INIGOT=ISIGN
GO TO 28
29 LMTVAL=(10*LMTVAL)+I-1
LMTGOT=ISIGN
GO TO 28
30 CONTINUE
GO TO 28
31 ISIGN=-1
GO TO 33
32 ISIGN=1
33 IF(LMTGOT.NE.0)GO TO 34
IF(INIGOT.NE.0)GO TO 34
INIGOT=ISIGN
GO TO 28
34 LMTGOT=ISIGN
LMTVAL=0
GO TO 28
35 LMTGOT=2
LMTVAL=0
GO TO 27
36 IF(INIGOT.EQ.0)GO TO 42
37 IDONE=1
C
C STORE THE EVALUATED SUBSCRIPT RANGE
38 IF(KOUNT.EQ.0)GO TO 41
IF(INIGOT.EQ.0)INIVAL=1
IF(INIGOT.LT.0)INIVAL=-INIVAL
IF(LMTGOT.NE.0)GO TO 39
LMTVAL=INIVAL
INIVAL=1
GO TO 40
39 IF(LMTGOT.GT.1)LMTVAL=1
IF(LMTGOT.LT.0)LMTVAL=-LMTVAL
40 NUMUSD=NUMUSD+2
IF(NUMUSD.GT.NUMMAX)GO TO 64
NUMSTR(NUMUSD-1)=INIVAL
NUMSTR(NUMUSD)=LMTVAL
LMTVAL=LMTVAL-INIVAL
IF(LMTVAL.LT.0)LMTVAL=-LMTVAL
KBREAK=KBREAK*(LMTVAL+1)
41 IF(IDONE.EQ.0)GO TO 26
C
C DONE WITH THIS SPECIFICATION
42 IF(KOUNT.EQ.0)GO TO 18
J=KOUNT
IF(KOUNT.LT.0)J=0
IF(JSLASH.NE.0)J=-J
NUMSTR(NUMBGN+1)=J
NUMSTR(NUMBGN+3)=(NUMUSD-NUMBGN-3)/2
IF(JSLASH.EQ.0)GO TO 46
IBREAK=NUMBGN+2
IF(JSLASH.GT.0)GO TO 44
JSLASH=0
IF(KOUNT.LT.0)GO TO 45
I=NUMUSD
NUMUSD=NUMUSD+3
IF(NUMUSD.GT.NUMMAX)GO TO 64
43 NUMSTR(I+3)=NUMSTR(I)
I=I-1
IF(I.GT.NUMBGN)GO TO 43
NUMSTR(NUMBGN+1)=0
NUMSTR(NUMBGN+3)=0
NUMSTR(NUMBGN+4)=KOUNT
NUMSTR(IBREAK)=KBREAK
GO TO 47
44 JSLASH=2
45 NUMSTR(IBREAK)=0
GO TO 47
46 NUMSTR(IBREAK)=NUMSTR(IBREAK)+KBREAK
47 IF(IWHERE.EQ.0)GO TO 17
IF(IWHERE.GT.0)GO TO 12
GO TO 67
C
C CHECK FOR LETTERS IN PARENTHESES AFTER IMPLICT
C INIGOT = -3, NEITHER PARENTHESIS NOR TYPE NAME FOUND
C = -2, TYPE NAME BUT NOT PARENTHESIS FOUND
C = -1, PARENTHESIS BUT NOT TYPE NAME FOUND
C = 0, BOTH PARENTHESIS AND TYPE NAME FOUND
C = .GT.0, LOCATION IN ALPHABET OF LETTER IN
C PARENTHESIS AFTER TYPE NAME
48 INIGOT=-3
GO TO 51
49 INIGOT=-2
GO TO 51
50 INIGOT=0
51 IBGN=IBGN+1
IF(IBGN.GT.IEND)GO TO 63
IF(IBUFFR(IBGN).EQ.IBLANK)GO TO 51
IF(IBUFFR(IBGN).EQ.ITAB)GO TO 51
IF(INIGOT.GE.-1)GO TO 52
IF(IBUFFR(IBGN).EQ.ICOMMA)GO TO 51
IF(IBUFFR(IBGN).NE.ILEFT)GO TO 57
INIGOT=INIGOT+2
GO TO 51
52 IF(INIGOT.GE.0)GO TO 53
IF(IBUFFR(IBGN).EQ.IRIGHT)GO TO 48
GO TO 51
53 IF(IBUFFR(IBGN).EQ.IRIGHT)GO TO 49
IF(IBUFFR(IBGN).EQ.ICOMMA)GO TO 50
DO 56 I=1,26
IF(IBUFFR(IBGN).NE.LETTER(I))GO TO 56
IF(INIGOT.NE.0)GO TO 55
INIGOT=I
54 ITYPE(INIGOT)=JTYPE-2
55 IF(INIGOT.GE.I)GO TO 51
INIGOT=INIGOT+1
GO TO 54
56 CONTINUE
GO TO 51
C
C CHECK FOR TYPE NAMES IN IMPLICIT STATEMENT
57 LAST=0
JTYPE=0
58 JTYPE=JTYPE+1
IF(JTYPE.GT.3)GO TO 48
INIT=LAST+1
LAST=LAST+KNTLTR(JTYPE)
JBGN=IBGN
GO TO 60
59 JBGN=JBGN+1
60 IF(JBGN.GT.IEND)GO TO 58
IF(IBUFFR(JBGN).EQ.IBLANK)GO TO 59
IF(IBUFFR(JBGN).EQ.ITAB)GO TO 59
IF(IBUFFR(JBGN).NE.IWORD(INIT))GO TO 58
INIT=INIT+1
IF(INIT.LE.LAST)GO TO 59
IBGN=JBGN
GO TO 49
C
C END OF LINE FOUND WHILE PROCESSING
61 IWHERE=1
GO TO 4
62 IWHERE=2
GO TO 4
63 IWHERE=3
C TYPE 999,LETTER,ITYPE
C 999 FORMAT(2X,26A2/1X,26I2/)
GO TO 4
C
C NUMBER OR CHARACTER STORAGE OVERFLOW
64 IFULL=3
GO TO 66
65 IFULL=4
66 NUMUSD=NUMBGN
LTRUSD=LTRBGN
C
C RETURN TO CALLING PROGRAM
67 RETURN
C JSLASH = -1, PLACE NULL HEADER BEFORE NEXT ITEM
C = 0, BEYOND SLASH PAIR CONTAINING SOMETHING
C = 1, WITHIN A SLASH PAIR BUT NOTHING FOUND
C = 2, WITHIN SLASH PAIR AND SOMTHING FOUND
C IWHERE = 0, END OF LINE AT NONCRITICAL POINT
C = 1, END OF LINE IN FINDING ARRAY NAME
C = 2, END OF LINE IN FINDING SUBSCRIPTS
C = 3, END OF LINE IN IMPLICIT STATEMENT
C903487431491:
END
SUBROUTINE DAPICK(MAXBFR,IBUFFR,LTRLOW,LTRUSD,LTRSTR,
1 NUMLOW,NUMUSD,NUMSTR,MAXSUB,LOWBFR,KIND ,LRGLTR,
2 LRGNUM,LRGKNT,INITAL,KOUNT ,LTRINI,NUMINI,KNTSUB,
3 INISUB,LMTSUB)
C RENBR(/IDENTIFY ARRAY NAME AND SUBSCRIPT RANGE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE IS USED ALONG WITH SEVERAL OTHERS IN
C FASP, THE FORTRAN ALPHAMERIC SUBROUTINE PACKAGE, FOR
C THE PURPOSE OF SELECTING BY NAME AND SUBSCRIPTS,
C EXAMINING AND MODIFYING THE VALUES IN ARRAY LOCATIONS
C KNOWN TO THE CALLING PROGRAM. PLEASE CONSULT THE
C FASP DOCUMENTATION FOR DESCRIPTIONS OF THESE ROUTINES
C
DIMENSION IBUFFR(MAXBFR),LTRSTR(LTRUSD),
1NUMSTR(NUMUSD),INISUB(MAXSUB),LMTSUB(MAXSUB),
2IDIGIT(10)
DATA IEQUAL,ILEFT,IRIGHT,IPLUS,IMINUS,ICOMMA,ISLASH,
1ICOLON,KOMENT,IAND,IEND,IBLANK,ITAB/1H=,1H(,1H),1H+,
21H-,1H,,1H/,1H:,1H!,1H&,1H;,1H ,1H /
DATA IDIGIT/
11H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C FIND FIRST AND FINAL NON-BLANK CHARACTERS READ
KNTSUB=0
LTREND=LOWBFR
NEEDED=KIND
KONTNU=KIND
GO TO 2
1 LTREND=LTREND+1
2 IF(LTREND.GT.MAXBFR)GO TO 5
IF(IBUFFR(LTREND).EQ.KOMENT)GO TO 5
IF(IBUFFR(LTREND).NE.IAND)GO TO 1
KONTNU=0
GO TO 5
3 NEEDED=0
4 LOWBFR=LOWBFR+1
5 IF(LOWBFR.GE.LTREND)GO TO 47
IF(IBUFFR(LOWBFR).EQ.IBLANK)GO TO 4
IF(IBUFFR(LOWBFR).EQ.ITAB)GO TO 4
IF(IBUFFR(LOWBFR).EQ.IEND)GO TO 3
IF(NEEDED.GT.0)GO TO 52
6 LTREND=LTREND-1
IF(LTREND.LE.LOWBFR)GO TO 7
IF(IBUFFR(LTREND).EQ.IBLANK)GO TO 6
IF(IBUFFR(LTREND).EQ.ITAB)GO TO 6
C
C TEST IF ARRAY NAME APPEARS IN DICTIONARY
7 NUMNXT=NUMLOW
LTRNXT=LTRLOW
LRGKNT=0
8 NUMINI=NUMNXT
LTRINI=LTRNXT
IF(NUMINI.GT.NUMUSD)GO TO 51
LTRKNT=NUMSTR(NUMINI)
NEEDED=NUMSTR(NUMINI+2)
NUMNXT=NUMNXT+3+NEEDED+NEEDED
IF(LTRKNT.GT.0)GO TO 9
LTRNXT=LTRNXT-LTRKNT
INITAL=1
KOUNT=0
LRGKNT=LRGKNT+1
LRGNUM=NUMINI
LRGLTR=LTRINI
GO TO 8
9 LTRNXT=LTRNXT+LTRKNT
IF(LRGKNT.LE.0)GO TO 8
NXTBFR=LOWBFR
LTRLOC=LTRINI
KOUNT=KOUNT+1
10 IF(LTRSTR(LTRLOC).NE.IBUFFR(NXTBFR))GO TO 13
LTRLOC=LTRLOC+1
11 NXTBFR=NXTBFR+1
IF(NXTBFR.GT.LTREND)GO TO 12
IF(IBUFFR(NXTBFR).EQ.IBLANK)GO TO 11
IF(IBUFFR(NXTBFR).EQ.ITAB)GO TO 11
IF(LTRLOC.LT.LTRNXT)GO TO 10
IF(IBUFFR(NXTBFR).EQ.IEND)GO TO 43
IF(IBUFFR(NXTBFR).EQ.IEQUAL)GO TO 44
IF(IBUFFR(NXTBFR).EQ.ILEFT)GO TO 16
GO TO 13
12 IF(LTRLOC.GE.LTRNXT)GO TO 43
C
C COMPUTE ARRAY SIZE AND ADD TO OFFSET IF NOMATCH
13 ISIZE=1
NUMINI=NUMINI+1
14 IF(NEEDED.LE.0)GO TO 15
NUMINI=NUMINI+2
I=NUMSTR(NUMINI+1)-NUMSTR(NUMINI)
IF(I.LT.0)I=-I
ISIZE=ISIZE*(I+1)
NEEDED=NEEDED-1
GO TO 14
15 INITAL=INITAL+ISIZE
GO TO 8
C
C FIND USER INDICATED SUBSCRIPTS
16 KIND=1
LOWBFR=NXTBFR
IDONE=0
INDEX=NUMINI+1
17 INIVAL=0
INIGOT=0
LMTGOT=0
18 ISIGN=1
19 IF(LOWBFR.GE.LTREND)GO TO 28
LOWBFR=LOWBFR+1
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.IBLANK)GO TO 19
IF(LETTER.EQ.ITAB)GO TO 19
IF(LETTER.EQ.IRIGHT)GO TO 28
IF(LETTER.EQ.ISLASH)GO TO 26
IF(LETTER.EQ.ICOLON)GO TO 26
IF(LETTER.EQ.IPLUS)GO TO 23
IF(LETTER.EQ.IMINUS)GO TO 22
IF(LETTER.EQ.ICOMMA)GO TO 29
IF(LETTER.EQ.IEQUAL)GO TO 27
IF(LETTER.EQ.IEND)GO TO 27
DO 21 I=1,10
IF(LETTER.NE.IDIGIT(I))GO TO 21
IF(LMTGOT.NE.0)GO TO 20
INIVAL=(10*INIVAL)+I-1
INIGOT=ISIGN
GO TO 19
20 LMTVAL=(10*LMTVAL)+I-1
LMTGOT=ISIGN
GO TO 19
21 CONTINUE
GO TO 19
22 ISIGN=-1
GO TO 24
23 ISIGN=1
24 IF(LMTGOT.NE.0)GO TO 25
IF(INIGOT.NE.0)GO TO 25
INIGOT=ISIGN
GO TO 19
25 LMTGOT=ISIGN
LMTVAL=0
GO TO 19
26 LMTGOT=2
LMTVAL=0
GO TO 18
27 LOWBFR=LOWBFR-1
28 IDONE=1
C
C STORE THE EVALUATED SUBSCRIPT RANGE
29 IF(KNTSUB.GE.MAXSUB)GO TO 37
INDEX=INDEX+2
IF(INIGOT.NE.0)GO TO 32
IF(INDEX.GE.NUMNXT)GO TO 30
INIVAL=NUMSTR(INDEX)
GO TO 31
30 INIVAL=1
31 IF(LMTGOT.NE.0)GO TO 33
GO TO 34
32 IF(INIGOT.LT.0)INIVAL=-INIVAL
IF(LMTGOT.NE.0)GO TO 33
LMTVAL=INIVAL
GO TO 36
33 IF(LMTGOT.GT.1)GO TO 34
IF(LMTGOT.LT.0)LMTVAL=-LMTVAL
GO TO 36
34 IF(INDEX.GE.NUMNXT)GO TO 35
LMTVAL=NUMSTR(INDEX+1)
GO TO 36
35 LMTVAL=1
36 KNTSUB=KNTSUB+1
INISUB(KNTSUB)=INIVAL
LMTSUB(KNTSUB)=LMTVAL
37 IF(IDONE.EQ.0)GO TO 17
C
C CHECK FOR EQUALS SIGN RIGHT OF SUBSCRIPTS
38 LOWBFR=LOWBFR+1
IF(LOWBFR.GT.LTREND)GO TO 39
IF(IBUFFR(LOWBFR).EQ.IBLANK)GO TO 38
IF(IBUFFR(LOWBFR).EQ.ITAB)GO TO 38
IF(IBUFFR(LOWBFR).NE.IEQUAL)GO TO 39
KIND=2
LOWBFR=LOWBFR+1
C
C CHECK SUBSCRIPT RANGES
39 IF(NEEDED.NE.KNTSUB)GO TO 42
IF(NEEDED.EQ.0)GO TO 53
INDEX=NUMINI+1
DO 41 I=1,NEEDED
INDEX=INDEX+2
IF(NUMSTR(INDEX).GT.NUMSTR(INDEX+1))GO TO 40
IF(INISUB(I).LT.NUMSTR(INDEX))GO TO 50
IF(INISUB(I).GT.NUMSTR(INDEX+1))GO TO 50
IF(LMTSUB(I).LT.NUMSTR(INDEX))GO TO 50
IF(LMTSUB(I).GT.NUMSTR(INDEX+1))GO TO 50
GO TO 41
40 IF(INISUB(I).GT.NUMSTR(INDEX))GO TO 50
IF(INISUB(I).LT.NUMSTR(INDEX+1))GO TO 50
IF(LMTSUB(I).GT.NUMSTR(INDEX))GO TO 50
IF(LMTSUB(I).LT.NUMSTR(INDEX+1))GO TO 50
41 CONTINUE
GO TO 53
C
C UNEQUAL NUMBER OF SUBSCRIPTS
42 IF(NEEDED.NE.0)GO TO 49
IF(KNTSUB.NE.1)GO TO 49
IF(INISUB(1).NE.1)GO TO 49
IF(LMTSUB(1).NE.1)GO TO 49
GO TO 53
C
C NO SUBSCRIPTS TYPED BY USER, CHECK IF UNDIMENSIONED
43 KIND=1
LOWBFR=NXTBFR
GO TO 45
44 KIND=2
LOWBFR=NXTBFR+1
45 IF(NEEDED.EQ.0)GO TO 46
IF(NEEDED.GT.1)GO TO 49
IF(NUMSTR(NUMINI+3).NE.1)GO TO 49
IF(NUMSTR(NUMINI+4).NE.1)GO TO 49
46 KNTSUB=1
INISUB(1)=1
LMTSUB(1)=1
GO TO 53
C
C RETURN TO CALLING PROGRAM
47 LOWBFR=MAXBFR+1
IF(KONTNU.GE.0)GO TO 48
KIND=3
GO TO 53
48 KIND=4
GO TO 53
49 KIND=5
GO TO 53
50 KIND=6
GO TO 53
51 KIND=7
GO TO 53
52 KIND=8
53 RETURN
C502952324441:!&;
END
SUBROUTINE DALIST(JTTY ,LTRLOW,LTRUSD,LTRSTR,NUMLOW,
1NUMUSD,NUMSTR,NAMMAX,NAME)
C RENBR(/LIST ARRAY MANIPULATION DICTIONARY)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE IS USED ALONG WITH SEVERAL OTHERS IN
C FASP, THE FORTRAN ALPHAMERIC SUBROUTINE PACKAGE, FOR
C THE PURPOSE OF SELECTING BY NAME AND SUBSCRIPTS,
C EXAMINING AND MODIFYING THE VALUES IN ARRAY LOCATIONS
C KNOWN TO THE CALLING PROGRAM. PLEASE CONSULT THE
C FASP DOCUMENTATION FOR DESCRIPTIONS OF THESE ROUTINES
C
DIMENSION LTRSTR(LTRUSD),NUMSTR(NUMUSD),NAME(NAMMAX)
DATA ISPACE/1H /
C
C LOCATIONS OF INITIAL NUMBER AND INITIAL CHARACTER
NUMNXT=NUMLOW
LTRNXT=LTRLOW
NAMUSD=0
C
C GET INFORMATION ABOUT NEXT ARRAY
1 NUMINI=NUMNXT
IF(NUMINI.GT.NUMUSD)GO TO 3
LTRINI=LTRNXT
LTRKNT=NUMSTR(NUMINI)
KNTSUB=NUMSTR(NUMINI+2)
IF(KNTSUB.LT.0)GO TO 8
NUMNXT=NUMINI+3+KNTSUB+KNTSUB
IF(NUMNXT.GT.(NUMUSD+1))GO TO 8
IF(LTRKNT.GT.0)GO TO 2
C
C START OF RECORD DESCRIPTION
LTRNXT=LTRNXT-LTRKNT
GO TO 3
C
C PRINT PREVIOUS LINE OF DESCRIPTIONS IF LINE FULL
2 LTRNXT=LTRINI+LTRKNT
IF(LMTTYP.EQ.-2)GO TO 3
IF(LSTTYP.NE.NUMSTR(NUMINI+1))GO TO 3
IF(NAMUSD.LE.0)GO TO 5
IF(NAMUSD.LT.NAMMAX)GO TO 6
3 IF(NAMUSD.GT.0)WRITE(JTTY,4)(NAME(I),I=1,NAMUSD)
4 FORMAT(1X,100A1)
IF(NUMINI.GT.NUMUSD)GO TO 10
NAMUSD=0
5 LMTTYP=-2
GO TO 7
C
C INSERT NEXT DESCRIPTION INTO LINE
6 NAMUSD=NAMUSD+1
NAME(NAMUSD)=ISPACE
7 LSTBFR=NAMUSD
CALL DALONE(LMTTYP,LTRINI,LTRUSD,LTRSTR,NUMINI,
1NUMUSD,NUMSTR,1,NUMSTR,NAMMAX,NAME,NAMUSD)
IF(NAMUSD.LE.0)GO TO 8
IF(NAMUSD.LE.LSTBFR)GO TO 3
LMTTYP=-1
LSTTYP=NUMSTR(NUMINI+1)
IF(NUMSTR(NUMINI).LE.0)LMTTYP=-2
GO TO 1
C
C RETURN TO CALLING PROGRAM
8 WRITE(JTTY,9)
9 FORMAT(' DALIST - ARRAY DESCRIPTION ERROR')
10 RETURN
C400023395953'
END
SUBROUTINE DALONE(LMTTYP,LTRINI,LTRUSD,LTRSTR,NUMINI,
1 NUMUSD,NUMSTR,KNTSUB,NOWSUB,NAMMAX,NAME ,NAMUSD)
C RENBR(/REPRESENT ARRAY NAME AND SUBSCRIPT LIMITS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE IS USED ALONG WITH SEVERAL OTHERS IN
C FASP, THE FORTRAN ALPHAMERIC SUBROUTINE PACKAGE, FOR
C THE PURPOSE OF SELECTING BY NAME AND SUBSCRIPTS,
C EXAMINING AND MODIFYING THE VALUES IN ARRAY LOCATIONS
C KNOWN TO THE CALLING PROGRAM. PLEASE CONSULT THE
C FASP DOCUMENTATION FOR DESCRIPTIONS OF THESE ROUTINES
C
DIMENSION LTRSTR(LTRUSD),NUMSTR(NUMUSD),
1NAME(NAMMAX),NOWSUB(KNTSUB),ITYPE(16),LTRBGN(4)
DATA LTRBGN/1,6,13,18/
DATA ITYPE/
11HO,1HC,1HT,1HA,1HL,
21HI,1HN,1HT,1HE,1HG,1HE,1HR,
31HR,1HE,1HA,1HL/
DATA ILEFT,IRIGHT,ICOMMA,ISLASH,ISPACE/
11H(,1H),1H,,1H/,1H /
C
INITAL=NAMUSD
LTRGET=LTRINI
NUMGET=NUMINI+1
LTRKNT=NUMSTR(NUMINI)
C
C INSERT NUMBER TYPE OR SIZE OF RECORD
IF(LMTTYP.GE.-1)GO TO 3
IVALUE=NUMSTR(NUMINI+1)
IPART=-1
IF(LTRKNT.LE.0)GO TO 15
IVALUE=IVALUE+2
J=LTRBGN(IVALUE)
K=LTRBGN(IVALUE+1)-1
DO 1 I=J,K
IF(NAMUSD.GE.NAMMAX)GO TO 17
NAMUSD=NAMUSD+1
NAME(NAMUSD)=ITYPE(I)
1 CONTINUE
2 IF(NAMUSD.GE.NAMMAX)GO TO 17
NAMUSD=NAMUSD+1
NAME(NAMUSD)=ISPACE
C
C INSERT ARRAY NAME INTO OUTPUT BUFFER
3 IF(LTRKNT.LT.0)LTRKNT=-LTRKNT
4 IF(LTRKNT.LE.0)GO TO 5
IF(NAMUSD.GE.NAMMAX)GO TO 17
NAMUSD=NAMUSD+1
IF(LTRGET.GT.LTRUSD)GO TO 17
NAME(NAMUSD)=LTRSTR(LTRGET)
LTRGET=LTRGET+1
LTRKNT=LTRKNT-1
GO TO 4
C
C INSERT SUBSCRIPT LIMITS INTO OUTPUT BUFFER
5 IF(LMTTYP.LE.0)GO TO 6
MAXSUB=1
GO TO 7
6 MAXSUB=NUMSTR(NUMINI+2)
IF(MAXSUB.LE.0)GO TO 18
7 IF(NAMUSD.GE.NAMMAX)GO TO 17
NAMUSD=NAMUSD+1
NAME(NAMUSD)=ILEFT
NEWSUB=0
8 NEWSUB=NEWSUB+1
IF(NEWSUB.GT.MAXSUB)GO TO 16
IF(LMTTYP.LT.0)GO TO 10
IF(LMTTYP.EQ.0)GO TO 9
IVALUE=LMTTYP
GO TO 14
9 IVALUE=NOWSUB(NEWSUB)
GO TO 14
10 NUMGET=NUMGET+2
IF(NUMSTR(NUMGET+1).LE.0)GO TO 11
IF(NUMSTR(NUMGET).EQ.1)GO TO 13
11 IVALUE=NUMSTR(NUMGET)
IPART=0
GO TO 15
12 IF(NAMUSD.GE.NAMMAX)GO TO 17
NAMUSD=NAMUSD+1
NAME(NAMUSD)=ISLASH
13 IVALUE=NUMSTR(NUMGET+1)
14 IPART=1
15 LFTCOL=NAMUSD
CALL DANUMB(0,IVALUE,10,NAME,NAMUSD,LFTCOL,NAMMAX)
IF(NAMUSD.EQ.LFTCOL)GO TO 17
IF(NAMUSD.GE.NAMMAX)GO TO 17
IF(IPART.EQ.0)GO TO 12
IF(IPART.LT.0)GO TO 2
NAMUSD=NAMUSD+1
NAME(NAMUSD)=ICOMMA
GO TO 8
16 NAME(NAMUSD)=IRIGHT
GO TO 18
C
C RETURN TO CALLING PROGRAM
17 NAMUSD=INITAL
18 RETURN
C590391099687
END
SUBROUTINE DAVARY(KONTRL,ITTY ,JTTY ,LOCATN,NAMUSD,
1 NAMMAX,MAXBFR,NOTATN,MINDEC,MAXDEC,MINSIG,MAXSIG,
2 IDECML,AARRAY,IARRAY,NAME ,IBUFFR,LOWBFR,KIND ,
3 MODIFY)
C RENBR(/TYPE CURRENT VALUE AND ACCEPT NEW VALUE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE IS USED ALONG WITH SEVERAL OTHERS IN
C FASP, THE FORTRAN ALPHAMERIC SUBROUTINE PACKAGE, FOR
C THE PURPOSE OF SELECTING BY NAME AND SUBSCRIPTS,
C EXAMINING AND MODIFYING THE VALUES IN ARRAY LOCATIONS
C KNOWN TO THE CALLING PROGRAM. PLEASE CONSULT THE
C FASP DOCUMENTATION FOR DESCRIPTIONS OF THESE ROUTINES
C
C CONTENTS OF THE FASPH COMMON BLOCK MUST BE
C MAINTAINED FROM ONE CALL OF THIS ROUTINE TO NEXT
COMMON/FASPH/INIVAL,INCVAL,LMTVAL,
1VALINI,VALINC,VALLMT
C
DIMENSION NAME(NAMMAX),AARRAY(LOCATN),IARRAY(LOCATN),
1IBUFFR(MAXBFR)
DATA IEQUAL,ISPACE/1H=,1H /
C
C REPRESENT THE FORMER VALUE
MANY=KIND-2
LOCAL=0
KOUNT=NAMUSD
NAMINI=NAMUSD+1
1 IF((KOUNT+3).GT.NAMMAX)GO TO 3
NAME(KOUNT+1)=ISPACE
NAME(KOUNT+2)=IEQUAL
NAME(KOUNT+3)=ISPACE
KOUNT=KOUNT+3
LFTCOL=KOUNT
IF(KONTRL.GT.0)GO TO 2
IRADIX=10
IF(KONTRL.LT.0)IRADIX=8
CALL DANUMB(0,IARRAY(LOCATN),IRADIX,NAME,KOUNT,
1LFTCOL,NAMMAX)
GO TO 3
2 CALL DARITE(AARRAY(LOCATN),-1,NOTATN,0,0,
1-3,0,20,MINDEC,MAXDEC,MINSIG,MAXSIG,
2-1,0,IDECML,0,0,-1,LFTCOL,
3NAMMAX,NAME,KOUNT,IERR)
3 IF(MANY.LT.0)GO TO 19
IF(LOCAL.NE.0)GO TO 20
C
C GET NEXT VALUE SPECIFIED BY USER
4 CALL DANEXT(KONTRL,0.01,IBUFFR,MAXBFR,LOWBFR,
1MANY,KIND,INIVAL,INCVAL,LMTVAL,VALINI,VALINC,
2VALLMT)
GO TO(14,22,16,23,5,23,8,10,12),KIND
C
C STORE NEW VALUE AND REPORT IT IF FROM FORMER LINE
5 MODIFY=MODIFY+1
IF(KONTRL.GT.0)GO TO 6
IARRAY(LOCATN)=INIVAL
GO TO 7
6 AARRAY(LOCATN)=VALINI
7 IF(LOCAL.NE.0)GO TO 23
LOCAL=1
GO TO 1
C
C ILLEGAL ANSWER, CANCEL REST OF BUFFER
8 WRITE(JTTY,9)
9 FORMAT(' POSITIVE NUMBER REQUIRED LEFT OF ASTERISK')
GO TO 15
10 WRITE(JTTY,11)
11 FORMAT(' ILLEGAL RANGE SPECIFICATION')
GO TO 15
12 WRITE(JTTY,13)IBUFFR(LOWBFR-1)
13 FORMAT(' ILLEGAL CHARACTER ',1A1)
GO TO 15
C
C INPUT BUFFER IS EMPTY
14 KIND=3
IF(LOCAL.NE.0)GO TO 23
C
C ASK USER FOR VALUE IF NOTHING IN INPUT BUFFER
15 MANY=0
16 WRITE(JTTY,17)(NAME(I),I=1,KOUNT),ISPACE,IEQUAL,
1ISPACE
17 FORMAT(1X,$,100A1)
READ(ITTY,18)IBUFFR
18 FORMAT(100A1)
LOCAL=1
LOWBFR=1
GO TO 4
C
C TELL USER THE NEW VALUE IF BASED ON FORMER ANSWER
C OR IF THE VALUE IS NOT BEING CHANGED
19 KIND=1
20 WRITE(JTTY,21)(NAME(I),I=1,KOUNT)
21 FORMAT(1X,100A1)
GO TO 23
C
C TERMINATE LOOP IF SEMICOLON FOUND
22 KIND=0
C
C RETURN TO CALLING PROGRAM
23 RETURN
C594944882435'$
END
SUBROUTINE DAROLL(IRAPID,LOWSUB,KNTSUB,INISUB,LMTSUB,
1 INCSUB,INLOOP,NOWSUB)
C RENBR(/OBTAIN NEXT LOOP DESCRIPTION)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO VARY A SET OF LOOP CONTROL PARAMETERS
C BETWEEN A SET OF LOWER AND UPPER BOUNDS.
C
C ***************************************************
C * CAUTION, DAROLL MUST BE CALLED INITIALLY TO *
C * DEFINE LOOP STRUCTURE, THEN AT EACH LOOP END. *
C * NONE OF THE CALLING ARGUMENTS CAN BE CHANGED *
C * BY CALLING PROGRAM UNTIL ALL LOOPS ARE DONE. *
C ***************************************************
C
C THE FOLLOWING ARGUMENTS ARE USED AS INPUT ONLY
C
C IRAPID = 0, THE INNERMOST LOOP (ONE DONE THE MOST
C RAPIDLY) IS THAT WITH THE SMALLEST
C SUBSCRIPT.
C = 1, THE INNERMOST LOOP IS THAT WITH THE
C LARGEST SUBSCRIPT.
C LOWSUB = THE INITIAL SUBSCRIPT OF THE ARRAYS WHICH
C ARE TO BE USED AS THE LOOP DESCRIPTORS.
C KNTSUB = THE FINAL SUBSCRIPT OF THE ARRAYS WHICH
C ARE TO BE USED AS THE LOOP DESCRIPTORS.
C KNTSUB MUST BE GREATER THAN OR EQUAL TO
C LOWSUB.
C INISUB = ARRAY CONTAINING THE STARTING VALUES OF THE
C INDIVIDUAL LOOP LIMITS.
C LMTSUB = ARRAY CONTAINING ENDING VALUES OF THE
C INDIVIDUAL LOOP LIMITS. AN INDIVIDUAL ITEM
C IN THE LMTSUB ARRAY CAN BE EITHER LESS THAN,
C EQUAL TO, OR GREATER THAN THE CORRESPONDING
C ITEM IN THE INISUB ARRAY.
C INCSUB = ARRAY CONTAINING THE INCREMENT BY WHICH THE
C NOWSUB ARRAY IS VARIED BETWEEN THE STARTING
C VALUES IN INISUB ARRAY, AND THE ENDING
C VALUES IN LMTSUB ARRAY. IF THE INCREMENT
C IS ZERO, IT IS CHANGED TO 1. IF THE
C INCREMENT HAS THE WRONG SIGN, ITS SIGN IS
C CHANGED.
C
C THE FOLLOWING ARGUMENT IS USED AS INPUT, THEN IS
C RETURNED CHANGED FOR USE BY BOTH THE CALLING PROGRAM
C AND BY SUBSEQUENT CALLS TO DAROLL
C
C INLOOP = MUST BE SET TO ZERO BEFORE INITIAL CALL TO
C DAROLL. THIS INITIAL CALL WILL SET INLOOP
C NONZERO, AND WILL COPY THE INISUB ARRAY
C INTO THE NOWSUB ARRAY FOR USE AS THE LOOP
C PARAMETERS. EACH SUBSEQUENT CALL TO DAROLL
C WILL EITHER LOAD THE PARAMETERS FOR THE
C NEXT SET OF LOOPS INTO THE NOWSUB ARRAY OR
C SET INLOOP TO ZERO IF THE LOOP STRUCTURE
C HAS BEEN COMPLETED.
C
C THE FOLLOWING ARGUMENT IS RETURNED CHANGED FOR USE
C BY BOTH THE CALLING PROGRAM AND SUBSEQUENT CALLS TO
C DAROLL. THE ORIGINAL CONTENTS ARE IGNORED.
C
C NOWSUB = ARRAY RETURNED CONTAINING THE LOOP CONTROL
C PARAMETERS FOR THE NEXT LOOP STRUCTURE.
C THE CONTENTS OF NOWSUB(LOWSUB) THROUGH
C NOWSUB(KNTSUB) ARE USED IN THE SAME MANNER
C AS THE INDEXES OF FORTRAN DO LOOPS.
C THE VALUES UPON INPUT TO THE INITIAL CALL
C TO DAROLL ARE IGNORED.
C
DIMENSION NOWSUB(KNTSUB),INISUB(KNTSUB),
1LMTSUB(KNTSUB),INCSUB(KNTSUB)
IF(INLOOP.GT.0)GO TO 5
C
C OBTAIN STARTING VALUES
IF(LOWSUB.GT.KNTSUB)GO TO 14
INLOOP=1
INDEX=LOWSUB
1 IF(INDEX.GT.KNTSUB)GO TO 15
NOWSUB(INDEX)=INISUB(INDEX)
IF(INCSUB(INDEX).EQ.0)INCSUB(INDEX)=1
IF(INISUB(INDEX).GT.LMTSUB(INDEX))GO TO 2
IF(INCSUB(INDEX).GE.0)GO TO 4
GO TO 3
2 IF(INCSUB(INDEX).LE.0)GO TO 4
3 INCSUB(INDEX)=-INCSUB(INDEX)
4 INDEX=INDEX+1
GO TO 1
C
C IF ALREADY INITIALIZED, FIND NEXT VALUES
5 IF(IRAPID.LE.0)GO TO 6
INDEX=KNTSUB
GO TO 8
6 INDEX=LOWSUB
GO TO 10
7 IF(IRAPID.LE.0)GO TO 9
INDEX=INDEX-1
8 IF(INDEX.LT.LOWSUB)GO TO 14
GO TO 11
9 INDEX=INDEX+1
10 IF(INDEX.GT.KNTSUB)GO TO 14
11 NOWSUB(INDEX)=NOWSUB(INDEX)+INCSUB(INDEX)
IF(INISUB(INDEX).GT.LMTSUB(INDEX))GO TO 12
IF(NOWSUB(INDEX).LE.LMTSUB(INDEX))GO TO 15
GO TO 13
12 IF(NOWSUB(INDEX).GE.LMTSUB(INDEX))GO TO 15
13 NOWSUB(INDEX)=INISUB(INDEX)
GO TO 7
C
C ALL DONE
14 INLOOP=0
15 RETURN
C340913287832
END
SUBROUTINE DABELT(KOLUMN,INTRVL,JSTIFY,LINE ,ILEFT ,
1 IRIGHT,LFTCOL,MAXBFR,IBUFFR,MAXLIN,MAXPRT,MAXUSD)
C RENBR(/IDENTIFY COLUMN NUMBERS)
C
C DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C JAN 2, 1970 / LOGICAL IF VERSION JUL 26, 1975
C
C WHEN A PROGRAM NEEDS TO DISPLAY TO THE USER A LINE OF
C CHARACTERS IN WHICH THE CHARACTERS ARE ORIENTED BY
C COLUMNS, A BAND OF NUMBERS IDENTIFYING THE COLUMNS
C CAN BE PRINTED, EITHER ABOVE OR BELOW THE MAIN
C DISPLAY, BY CALLING THE DABELT ROUTINE TO GENERATE
C EACH LINE OF THE REPRESENTATION OF THE COLUMN NUMBERS
C IN A BUFFER ARRAY WHICH THE CALLING PROGRAM CAN THEN
C PRINT WITH A MULTIPLE OF AN A1 FORMAT. DABELT IS
C CALLED AS MANY TIMES AS THERE ARE LINES IN THE
C REPRESENTATION OF THE COLUMN NUMBERS, THE CALLING
C PROGRAM PRINTING THE RETURNED CHARACTERS BEFORE AGAIN
C ASKING DABELT TO GENERATE THE NEXT LINE.
C
C NUMBERS CAN BE GENERATED WITH EACH LINE CONTAINING
C DIGITS CORRESPONDING TO SAME POWER OF 10 AS IN
C FOLLOWING EXAMPLE
C
C 5432109876543210123456789012345
C 111111--------- 111111
C ------
C
C OR WITH EACH LINE CONTAINING DIGITS OF SAME
C SIGNIFICANCE AS IN FOLLOWING EXAMPLE.
C
C ---------------0123456789111111
C 111111987654321 012345
C 543210
C
C NUMBERS CAN DECREASE FROM LEFT TO RIGHT AS IN
C FOLLOWING EXAMPLE
C
C 5432109876543210123456789012345
C 111111 ---------111111
C ------
C
C AND CAN HAVE ANY DESIRED SPACING AND INCREMENT
C BETWEEN ADJACENT NUMBERS AS IN FOLLOWING EXAMPLE.
C
C - - 0 1 2 3 4 5 6 7 8 9 1 1 1 1 1 1 1 1 1 1 2
C 2 1 0 0 0 0 0 0 0 0 0 0 1 2 3 4 5 6 7 8 9 0
C 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
C 0 0 0 0 0 0 0 0 0 0 0 0 0
C
C FOLLOWING ARE INPUT ARGUMENTS LEFT UNCHANGED.
C
C KOLUMN = NUMBER OF COLUMNS TO BE USED FOR SINGLE
C NUMBER. IF KOLUMN IS GREATER THAN 1, THEN
C KOLUMN-1 COLUMNS OF SPACES WILL BE INSERTED
C BETWEEN NUMBERS. NO EXTRA SPACES WILL
C APPEAR TO RIGHT OF RIGHT NUMBER EVEN IF
C KOLUMN IS GREATER THAN 1. EFFECTIVE VALUE
C OF KOLUMN IS 1 IF KOLUMN IS INPUT LESS THAN
C OR EQUAL TO ZERO.
C
C INTRVL = DIFFERENCE BETWEEN ADJACENT NUMBERS WHICH
C ARE TO BE REPRESENTED IN IBUFFR ARRAY. IF
C SIGN OF INTRVL IS WRONG TO PROCEED FROM
C ILEFT TO IRIGHT, THEN SIGN OF EFFECTIVE
C VALUE OF INTRVL IS REVERSED, BUT SIGN AND
C VALUE OF ARGUMENT SUPPLIED BY CALLING
C PROGRAM ARE LEFT UNCHANGED. EFFECTIVE VALUE
C OF INTRVL IS 1 IF INTRVL IS INPUT EQUAL TO
C ZERO.
C
C JSTIFY = 0, EACH LINE IS TO CONTAIN DIGITS
C CORRESPONDING TO SAME POWER OF 10 AS IN
C FIRST EXAMPLE AT START OF DOCUMENTATION OF
C THIS ROUTINE. LINE EQUAL TO 1 SELECTS
C DIGITS OF LOWEST SIGNIFICANCE IN NUMBERS.
C LINE EQUAL TO MAXLIN WILL SELECT EITHER
C MINUS SIGN OR DIGITS OF HIGHEST SIGNIFICANCE
C IF POSITIVE IN NUMBER OR NUMBERS REQUIRING
C MOST CHARACTERS TO REPRESENT.
C = 1, EACH LINE IS TO CONTAIN DIGITS OF SAME
C SIGNIFICANCE AS IN SECOND EXAMPLE AT START
C OF DOCUMENTATION OF THIS ROUTINE. LINE
C EQUAL 1 SELECTS EITHER MINUS SIGNS OR DIGITS
C OF HIGHEST SIGNIFICANCE IF POSITIVE IN
C NUMBERS. LINE EQUAL TO MAXLIN WILL SELECT
C DIGITS OF LOWEST SIGNIFICANCE IN NUMBER OR
C NUMBERS REQUIRING MOST CHARACTERS TO
C REPRESENT.
C
C LINE = SELECTS WHICH LINE OF REPRESENTATION OF
C NUMBERS IS TO BE CONSTRUCTED. LINE EQUAL 1
C WILL SELECT DIGITS OF LOWEST SIGNIFICANCE IF
C JSTIFY IS ZERO, OR MINUS SIGNS OR DIGITS OF
C HIGHEST SIGNIFICANCE OF POSITIVE NUMBERS IF
C JUSTIFY EQUALS 1. LINE EQUAL TO MAXLIN WILL
C SELECT MINUS SIGNS OR DIGITS OF HIGHEST
C SIGNIFICANCE IF POSITIVE OF NUMBER OR
C NUMBERS REQUIRING MOST CHARACTERS TO
C REPRESENT IF JSTIFY IS ZERO, OR DIGITS OF
C LOWEST SIGNIFICANCE OF NUMBER OR NUMBERS
C REQUIRING MOST CHARACTERS TO REPRESENT IF
C JSTIFY EQUALS 1. MAXPRT AND MAXUSD ARE BOTH
C RETURNED EQUAL TO INPUT VALUE OF LFTCOL IF
C LINE IS INPUT GREATER THAN MAXLIN.
C
C FOLLOWING EXAMPLES ILLUSTRATE DEFINITION OF
C LINE FOR JSTIFY EQUAL TO BOTH ZERO AND ONE.
C
C KOLUMN= 2, INTRVL=75, JSTIFY= 0, ILEFT=-1052
C LINE=1 2 7 2 7 2 7 2 7 2 7 2 7 2 7 2 3 8 3
C LINE=2 5 7 0 2 5 7 0 2 5 7 0 2 5 7 - 7 4 2
C LINE=3 0 9 9 8 7 6 6 5 4 3 3 2 1 - 1 2
C LINE=4 1 - - - - - - - - - - - -
C LINE=5 -
C LINE=6
C
C KOLUMN= 2, INTRVL=75, JSTIFY= 1, ILEFT=-1052
C LINE=1 - - - - - - - - - - - - - - - 7 1 2
C LINE=2 1 9 9 8 7 6 6 5 4 3 3 2 1 7 2 3 4 2
C LINE=3 0 7 0 2 5 7 0 2 5 7 0 2 5 7 8 3
C LINE=4 5 7 2 7 2 7 2 7 2 7 2 7 2
C LINE=5 2
C LINE=6
C
C SINCE EFFECTIVE VALUE OF MAXLIN IS NOT KNOWN
C PRIOR TO FIRST CALL TO THIS ROUTINE, LINE
C CAN BE SET TO ZERO TO REPRESENT SAME LINE AS
C IF LINE WAS INPUT EQUAL TO RETURNED VALUE OF
C MAXLIN. LINE IS RETURNED UNCHANGED, SO
C CALLING PROGRAM WOULD IN THIS CASE HAVE TO
C SET LINE EQUAL TO RETURNED VALUE OF MAXLIN-1
C PRIOR TO SECOND CALL TO THIS ROUTINE.
C
C ILEFT = THE LEFT OR FIRST NUMBER TO BE REPRESENTED.
C
C IRIGHT = THE RIGHT OR FINAL LIMIT OF NUMBERS TO BE
C REPRESENTED. UNLIKE ILEFT WHICH IS ALWAYS
C REPRESENTED, IRIGHT IS REPRESENTED ONLY IF
C BUFFER IS LARGE ENOUGH TO INCLUDE NUMBERS
C THROUGH IRIGHT PLUS EXTRA SPACES IF KOLUMN
C IS GREATER THAN 1, AND IF IRIGHT-ILEFT IS
C EXACTLY WHOLE NUMBER MULTIPLE OF INTRVL. IF
C IRIGHT-ILEFT IS NOT EXACTLY WHOLE NUMBER
C MULTIPLE OF INTRVL, THEN RIGHTMOST NUMBER
C WHICH COULD BE REPRESENTED IF BUFFER IS
C LARGE ENOUGH IS NUMBER WHICH IS NEXT SMALLER
C WHOLE NUMBER MULTIPLE TO RIGHT OF ILEFT.
C
C LFTCOL = THE SUBSCRIPT OF IBUFFR ARRAY LOCATION TO
C IMMEDIATE LEFT OF LOCATION INTO WHICH IS TO
C BE PLACED DIGIT OR SIGN FORMING
C REPRESENTATION UPON CURRENT LINE OF LEFT
C NUMBER.
C
C MAXBFR = SUBSCRIPT OF HIGHEST LOCATION IN IBUFFR
C ARRAY INTO WHICH CAN BE PLACED
C REPRESENTATIONS OF NUMBERS FROM ILEFT
C THROUGH IRIGHT. THIS WOULD NORMALLY BE
C DIMENSION OF IBUFFR ARRAY.
C
C FOLLOWING ARGUMENTS ARE USED FOR OUTPUT. THEIR INPUT
C VALUES ARE IGNORED.
C
C IBUFFR = ARRAY IN WHICH NUMBERS ARE TO BE REPRESENTED
C AND WHICH CAN THEN BE PRINTED BY CALLING
C PROGRAM USING MULTIPLE OF A1 FORMAT.
C
C MAXLIN = RETURNED CONTAINING NUMBER OF LINES NEEDED
C TO REPRESENT NUMBERS ILEFT THROUGH IRIGHT.
C ACTUAL NUMBER OF LINES WHICH WOULD INCLUDE
C PRINTING CHARACTERS MAY BE LESS SINCE RIGHT
C NUMBER ACTUALLY DISPLAYED CAN REQUIRE FEWER
C CHARACTERS FOR ITS REPRESENTATION THAN WOULD
C IRIGHT.
C
C MAXPRT = RETURNED CONTAINING SUBSCRIPT OF RIGHT
C LOCATION IN IBUFFR ARRAY CONTAINING PRINTING
C CHARACTER GENERATED BY THIS ROUTINE. IF
C CURRENT CALL TO THIS ROUTINE HAS NOT ADDED
C ANY PRINTING CHARACTERS TO IBUFFR, THEN
C MAXPRT WILL BE RETURNED EQUAL TO LFTCOL.
C
C MAXUSD = RETURNED CONTAINING SUBSCRIPT OF RIGHT
C LOCATION IN IBUFFR ARRAY CONTAINING ANY
C CHARACTER GENERATED BY THIS ROUTINE. IF
C LINE IS LESS THAN OR EQUAL TO MAXLIN, THEN
C MAXUSD WILL BE RETURNED EQUAL TO VALUE OF
C MAXPRT WHICH WOULD BE RETURNED IF LINE WAS
C INPUT AS 1. SINCE RIGHTMOST PRINTING
C CHARACTER GENERATED BY CURRENT CALL TO THIS
C ROUTINE CAN BE TO LEFT OF THAT GENERATED IF
C LINE IS 1, ARRAY LOCATIONS STARTING AT
C IBUFFR(MAXPRT+1) THROUGH IBUFFR(MAXUSD) WILL
C CONTAIN SPACES. IF LINE IS GREATER THAN
C RETURNED VALUE OF MAXLIN, THEN MAXUSD IS
C RETURNED EQUAL TO LFTCOL.
C
DIMENSION IBUFFR(MAXBFR),IDGT(10)
DATA IDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA ISPACE,IMINUS/1H ,1H-/
C
C FIND OUT WHICH DIRECTION TO TRAVEL
MAXUSD=LFTCOL
MAXPRT=LFTCOL
JNCRMT=INTRVL
IF(JNCRMT.LT.0)JNCRMT=-JNCRMT
IF(JNCRMT.EQ.0)JNCRMT=1
IF(ILEFT.GT.IRIGHT)JNCRMT=-JNCRMT
INCRMT=INTRVL
IF(INCRMT.LT.0)INCRMT=-INCRMT
IF(INCRMT.LE.0)INCRMT=1
C
C FIND LIMITING VALUE OF INTERVAL
IF(ILEFT.LE.IRIGHT)GO TO 2
IF(IRIGHT.GE.0)GO TO 1
ITEST=-10*IRIGHT
IF(ILEFT.LE.ITEST)GO TO 4
1 ITEST=ILEFT
GO TO 4
2 IF(ILEFT.GE.0)GO TO 3
ITEST=-10*ILEFT
IF(IRIGHT.LE.ITEST)GO TO 4
3 ITEST=IRIGHT
C
C FIND INTERVAL CORRESPONDING TO LINE NUMBER
4 IPWR10=1
MAXLIN=0
5 MAXLIN=MAXLIN+1
IF(LINE.EQ.MAXLIN)IUSE=IPWR10
IPWR10=10*IPWR10
IF(IPWR10.LE.ITEST)GO TO 5
C
C DETERMINE IF LINE NUMBER IS IN PROPER RANGE
IF(LINE.GT.MAXLIN)GO TO 38
C
C INITIAL CONDITIONS
ITOTAL=ILEFT
IPOSN=LFTCOL
LEVEL=LINE
IF(LINE.GT.0)GO TO 6
IUSE=IPWR10/10
LEVEL=MAXLIN
6 IF(JSTIFY.GT.0)GO TO 26
C
C DETERMINE HOW MANY TIMES FIRST DIGIT APPEARS
7 LIMIT=ITOTAL
IF(LIMIT.LT.0)LIMIT=-LIMIT
LIMIT=LIMIT/IUSE
IF(ILEFT.GT.IRIGHT)GO TO 8
JUSE=IUSE
IF(ITOTAL.LT.0)GO TO 10
LIMIT=(JUSE*LIMIT)+IUSE-1
GO TO 9
8 JUSE=-IUSE
IF(ITOTAL.GT.0)GO TO 10
LIMIT=(JUSE*LIMIT)-IUSE+1
9 JDRCTN=1
GO TO 11
10 LIMIT=-(JUSE*LIMIT)
JDRCTN=-1
11 IADD=1
IF(IUSE.LE.INCRMT)IADD=INCRMT/IUSE
IADD=JUSE*IADD
GO TO 33
C
C PUT IN DIGITS OR SPACES OR MINUS SIGNS
12 IF(ILEFT.LE.IRIGHT)GO TO 13
IF(LIMIT.LT.IRIGHT)LIMIT=IRIGHT
GO TO 14
13 IF(LIMIT.GT.IRIGHT)LIMIT=IRIGHT
14 IF(ILEFT.LE.IRIGHT)GO TO 15
IF(ITOTAL.GE.LIMIT)GO TO 16
IF(ITOTAL.LT.IRIGHT)GO TO 38
GO TO 27
15 IF(ITOTAL.LE.LIMIT)GO TO 16
IF(ITOTAL.GT.IRIGHT)GO TO 38
GO TO 27
16 IF(IPOSN.GE.MAXBFR)GO TO 38
IPOSN=IPOSN+1
IF(JSTIFY.LE.0)GO TO 18
IF(LEVEL.NE.1)GO TO 17
IF(ITOTAL.LT.0)GO TO 19
IF(ITOTAL.EQ.0)INDEX=1
GO TO 22
17 IF(IUSE.LE.0)GO TO 21
GO TO 22
18 IF(IUSE.EQ.1)GO TO 22
IF(ITOTAL.GE.0)GO TO 20
IF(ITOTAL.LE.-IUSE)GO TO 22
IF(ITOTAL.GT.-(IUSE/10))GO TO 21
19 IBUFFR(IPOSN)=IMINUS
GO TO 23
20 IF(ITOTAL.GE.IUSE)GO TO 22
21 IBUFFR(IPOSN)=ISPACE
GO TO 24
22 IBUFFR(IPOSN)=IDGT(INDEX)
23 MAXPRT=IPOSN
24 MAXUSD=IPOSN
JSPACE=KOLUMN
ITOTAL=ITOTAL+JNCRMT
25 IF(IPOSN.GE.MAXBFR)GO TO 38
JSPACE=JSPACE-1
IF(JSPACE.LE.0)GO TO 14
IPOSN=IPOSN+1
IBUFFR(IPOSN)=ISPACE
GO TO 25
C
C FIND NEXT POWER OF 10 IF JSTIFY IS GREATER THAN ZERO
26 LUSE=10*IUSE
KUSE=IUSE
GO TO 28
27 IF(JSTIFY.LE.0)GO TO 31
28 ITEST=ITOTAL
IF(ITEST.LT.0)ITEST=-10*ITEST
IF(ITEST.LT.KUSE)GO TO 30
ITEST=ITEST/LUSE
IUSE=1
29 IF(IUSE.GT.ITEST)GO TO 7
IUSE=10*IUSE
GO TO 29
30 IUSE=0
LIMIT=ITOTAL
GO TO 12
C
C GET LIMIT IF JSTIFY EQUALS ZERO
31 LIMIT=LIMIT+IADD
IF(JDRCTN.GE.0)GO TO 33
IF(ILEFT.LE.IRIGHT)GO TO 32
IF(ITOTAL.GT.0)GO TO 35
IF(IADD.NE.-1)LIMIT=LIMIT+1
JDRCTN=1
GO TO 34
32 IF(ITOTAL.LT.0)GO TO 34
IF(IADD.NE.1)LIMIT=LIMIT-1
JDRCTN=1
GO TO 35
C
C GET NEXT DIGIT TO DISPLAY
33 IF(ITOTAL.GE.0)GO TO 35
34 INDEX=-ITOTAL/IUSE
GO TO 36
35 INDEX=ITOTAL/IUSE
36 IF(INDEX.LE.9)GO TO 37
I=INDEX/10
INDEX=INDEX-(10*I)
37 INDEX=INDEX+1
GO TO 12
C
C RETURN TO CALLING PROGRAM
38 RETURN
C830889848930
END
SUBROUTINE DAIBLT( LINE ,ILEFT ,
1 IRIGHT,LFTCOL,MAXBFR,IBUFFR,MAXLIN,MAXPRT,MAXUSD)
C RENBR(/IDENTIFY COLUMN NUMBERS)
C
C DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C JAN 2, 1970
C
C WHEN A PROGRAM NEEDS TO DISPLAY TO THE USER A LINE OF
C CHARACTERS IN WHICH THE CHARACTERS ARE ORIENTED BY
C COLUMNS, A BAND OF NUMBERS IDENTIFYING THE COLUMNS
C CAN BE PRINTED, EITHER ABOVE OR BELOW THE MAIN
C DISPLAY, BY CALLING THE DAIBLT ROUTINE TO GENERATE
C EACH LINE OF THE REPRESENTATION OF THE COLUMN NUMBERS
C IN A BUFFER ARRAY WHICH THE CALLING PROGRAM CAN THEN
C PRINT WITH A MULTIPLE OF AN A1 FORMAT. DAIBLT IS
C CALLED AS MANY TIMES AS THERE ARE LINES IN THE
C REPRESENTATION OF THE COLUMN NUMBERS, THE CALLING
C PROGRAM PRINTING THE RETURNED CHARACTERS BEFORE AGAIN
C ASKING DAIBLT TO GENERATE THE NEXT LINE.
C
C EACH LINE OF THE NUMBER REPRESENTATION GENERATED BY
C THIS ROUTINE CONTAINS DIGITS CORRESPONDING TO THE
C SAME POWER OF 10 AS IN THE FOLLOWING EXAMPLE.
C
C 5432109876543210123456789012345
C 111111--------- 111111
C ------
C
C THE FOLLOWING ARE INPUT ARGUMENTS LEFT UNCHANGED.
C
C LINE = SELECTS WHICH LINE OF REPRESENTATION OF
C NUMBERS IS TO BE CONSTRUCTED. LINE EQUAL 1
C WILL SELECT DIGITS OF LOWEST SIGNIFICANCE.
C LINE SET EQUAL TO MAXLIN (OR TO ZERO) WILL
C SELECT MINUS SIGNS OR DIGITS OF HIGHEST
C SIGNIFICANCE IF POSITIVE OF NUMBER OR
C NUMBERS REQUIRING MOST CHARACTERS TO
C REPRESENT. MAXPRT AND MAXUSD ARE BOTH
C RETURNED EQUAL TO INPUT VALUE OF LFTCOL IF
C LINE IS INPUT GREATER THAN MAXLIN.
C
C SINCE EFFECTIVE VALUE OF MAXLIN IS NOT KNOWN
C PRIOR TO FIRST CALL TO THIS ROUTINE, LINE
C CAN BE SET TO ZERO TO REPRESENT SAME LINE AS
C IF LINE WAS INPUT EQUAL TO RETURNED VALUE OF
C MAXLIN. LINE IS RETURNED UNCHANGED, SO
C CALLING PROGRAM WOULD IN THIS CASE HAVE TO
C SET LINE EQUAL TO RETURNED VALUE OF MAXLIN-1
C PRIOR TO SECOND CALL TO THIS ROUTINE.
C
C ILEFT = THE LEFT OR FIRST NUMBER TO BE REPRESENTED.
C
C IRIGHT = THE RIGHT OR FINAL LIMIT OF NUMBERS TO BE
C REPRESENTED. UNLIKE ILEFT WHICH IS ALWAYS
C REPRESENTED, IRIGHT IS REPRESENTED ONLY IF
C BUFFER IS LARGE ENOUGH TO INCLUDE NUMBERS
C THROUGH IRIGHT. IRIGHT MUST BE EQUAL TO OR
C GREATER THAN ILEFT.
C
C LFTCOL = THE SUBSCRIPT OF IBUFFR ARRAY LOCATION TO
C IMMEDIATE LEFT OF LOCATION INTO WHICH IS TO
C BE PLACED DIGIT OR SIGN FORMING
C REPRESENTATION UPON CURRENT LINE OF LEFT
C NUMBER.
C
C MAXBFR = SUBSCRIPT OF HIGHEST LOCATION IN IBUFFR
C ARRAY INTO WHICH CAN BE PLACED
C REPRESENTATIONS OF NUMBERS FROM ILEFT
C THROUGH IRIGHT. THIS WOULD NORMALLY BE
C DIMENSION OF IBUFFR ARRAY.
C
C FOLLOWING ARGUMENTS ARE USED FOR OUTPUT. THEIR INPUT
C VALUES ARE IGNORED.
C
C IBUFFR = ARRAY IN WHICH NUMBERS ARE TO BE REPRESENTED
C AND WHICH CAN THEN BE PRINTED BY CALLING
C PROGRAM USING MULTIPLE OF A1 FORMAT.
C
C MAXLIN = RETURNED CONTAINING NUMBER OF LINES NEEDED
C TO REPRESENT NUMBERS ILEFT THROUGH IRIGHT.
C ACTUAL NUMBER OF LINES WHICH WOULD INCLUDE
C PRINTING CHARACTERS MAY BE LESS SINCE RIGHT
C NUMBER ACTUALLY DISPLAYED CAN REQUIRE FEWER
C CHARACTERS FOR ITS REPRESENTATION THAN WOULD
C IRIGHT.
C
C MAXPRT = RETURNED CONTAINING SUBSCRIPT OF RIGHT
C LOCATION IN IBUFFR ARRAY CONTAINING PRINTING
C CHARACTER GENERATED BY THIS ROUTINE. IF
C CURRENT CALL TO THIS ROUTINE HAS NOT ADDED
C ANY PRINTING CHARACTERS TO IBUFFR, THEN
C MAXPRT WILL BE RETURNED EQUAL TO LFTCOL.
C
C MAXUSD = RETURNED CONTAINING SUBSCRIPT OF RIGHT
C LOCATION IN IBUFFR ARRAY CONTAINING ANY
C CHARACTER GENERATED BY THIS ROUTINE. IF
C LINE IS LESS THAN OR EQUAL TO MAXLIN, THEN
C MAXUSD WILL BE RETURNED EQUAL TO VALUE OF
C MAXPRT WHICH WOULD BE RETURNED IF LINE WAS
C INPUT AS 1. SINCE RIGHTMOST PRINTING
C CHARACTER GENERATED BY CURRENT CALL TO THIS
C ROUTINE CAN BE TO LEFT OF THAT GENERATED IF
C LINE IS 1, ARRAY LOCATIONS STARTING AT
C IBUFFR(MAXPRT+1) THROUGH IBUFFR(MAXUSD) WILL
C CONTAIN SPACES. IF LINE IS GREATER THAN
C RETURNED VALUE OF MAXLIN, THEN MAXUSD IS
C RETURNED EQUAL TO LFTCOL.
C
DIMENSION IBUFFR(MAXBFR),IDGT(10)
DATA IDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA IBLANK,IMINUS/1H ,1H-/
C
MAXPRT=LFTCOL
MAXUSD=LFTCOL
MAXLIN=0
IF(ILEFT.GT.IRIGHT)GO TO 13
IF(LFTCOL.GE.MAXBFR)GO TO 13
IZERO=LFTCOL-ILEFT+1
MOST=IRIGHT+IZERO
IF(MOST.GT.MAXBFR)MOST=MAXBFR
INTRVL=1
LIMIT=ILEFT
IF(LIMIT.LT.0)LIMIT=-10*LIMIT
IF(LIMIT.LT.IRIGHT)LIMIT=IRIGHT
IPWR10=1
1 MAXLIN=MAXLIN+1
IF(LINE.EQ.MAXLIN)INTRVL=IPWR10
IPWR10=10*IPWR10
IF(IPWR10.LE.LIMIT)GO TO 1
IF(LINE.GT.MAXLIN)GO TO 13
C
C DETERMINE LEFT DIGIT
LIMIT=ILEFT
IF(ILEFT.LT.0)LIMIT=-LIMIT
LIMIT=LIMIT/INTRVL
INDEX=LIMIT-(10*(LIMIT/10))+1
IF(ILEFT.GE.0)GO TO 2
LIMIT=IZERO-(INTRVL*LIMIT)-INTRVL
GO TO 3
2 LIMIT=IZERO+(INTRVL*LIMIT)-1
3 IF(MAXUSD.GE.IZERO)GO TO 4
IF(MAXUSD.LT.(IZERO-1))GO TO 5
IF(INTRVL.LE.1)GO TO 9
GO TO 7
4 IF(MAXUSD.LT.(IZERO+INTRVL-1))GO TO 7
GO TO 9
5 IF(MAXUSD.LT.(IZERO-INTRVL))GO TO 9
C
C PUT IN MINUS SIGNS IF NECESSARY
LIMIT=IZERO-(INTRVL/10)
IF(LIMIT.GT.MOST)LIMIT=MOST
6 MAXUSD=MAXUSD+1
IBUFFR(MAXUSD)=IMINUS
IF(MAXUSD.LT.LIMIT)GO TO 6
MAXPRT=MAXUSD
IF(MAXUSD.GE.MOST)GO TO 13
C
C PUT IN BLANKS IF NECESSARY
7 LIMIT=IZERO+INTRVL-1
IF(LIMIT.GT.MOST)LIMIT=MOST
8 MAXUSD=MAXUSD+1
IBUFFR(MAXUSD)=IBLANK
IF(MAXUSD.LT.LIMIT)GO TO 8
GO TO 11
C
C PUT IN DIGITS
9 LIMIT=LIMIT+INTRVL
IF(LIMIT.GT.MOST)LIMIT=MOST
10 MAXUSD=MAXUSD+1
IBUFFR(MAXUSD)=IDGT(INDEX)
IF(MAXUSD.LT.LIMIT)GO TO 10
MAXPRT=MAXUSD
11 IF(MAXUSD.GE.MOST)GO TO 13
C
C INCREMENT THE DIGIT
IF(MAXUSD.GE.IZERO)GO TO 12
INDEX=INDEX-1
IF(INDEX.LE.0)INDEX=10
GO TO 3
12 INDEX=INDEX+1
IF(INDEX.GT.10)INDEX=1
GO TO 3
C
C RETURN TO CALLING PROGRAM
13 RETURN
C INDEX = DIGIT PRESENTLY BEING PUT INTO ARRAY.
C INTRVL = REPETITIONS OF DIGIT BEFORE INCREMENT.
C IZERO = SUBSCRIPT CORRESPONDING TO ZERO (0).
C MAXUSD = NUMBER OF CHARACTERS IN IBUFFR ARRAY.
C LIMIT = SUBSCRIPT CORRESPONDING TO RIGHT
C APPEARANCE OF PRESENTLY ADDED DIGIT.
C MOST = SUBSCRIPT CORRESPONDING TO IRIGHT.
C536160823302
END
SUBROUTINE DABASE(LOCATE,LTRLFT,LTRRIT,LTRNAM,IVALUE,
1 LTRLOW,LTRUSD,LTRSTR,NUMLOW,NUMUSD,NUMSTR,LRGLTR,
2 LRGNUM,LRGKNT)
C RENBR(/LOCATE START OF LOGICAL GROUP DESCRIPTION)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE IS USED ALONG WITH SEVERAL OTHERS IN
C FASP, THE FORTRAN ALPHAMERIC SUBROUTINE PACKAGE, FOR
C THE PURPOSE OF SELECTING BY NAME AND SUBSCRIPTS,
C EXAMINING AND MODIFYING THE VALUES IN ARRAY LOCATIONS
C KNOWN TO THE CALLING PROGRAM. PLEASE CONSULT THE
C FASP DOCUMENTATION FOR DESCRIPTIONS OF THESE ROUTINES
C
DIMENSION LTRNAM(LTRRIT),LTRSTR(LTRUSD),
1NUMSTR(NUMUSD)
C
LRGLTR=LTRLOW
LRGNUM=NUMLOW
LRGKNT=0
IF(LOCATE.GE.0)GO TO 1
LTRSIZ=LTRRIT-LTRLFT+1
IF(LTRSIZ.EQ.0)LTRSIZ=-1
C
C OBTAIN NUMBER OF LETTERS AND NUMBERS IN ITEM STORAGE
1 IF(LRGNUM.GE.NUMUSD)GO TO 6
IF(NUMSTR(LRGNUM+2).LT.0)GO TO 6
KNTLTR=NUMSTR(LRGNUM)
KNTNUM=3+(2*NUMSTR(LRGNUM+2))
IF(KNTLTR.GT.0)GO TO 5
C
C START OF LOGICAL GROUP FOUND
LRGKNT=LRGKNT+1
KNTLTR=-KNTLTR
IF(LOCATE.GT.0)GO TO 3
IF(LOCATE.EQ.0)GO TO 4
C
C TEST IF NAME MATCHES THAT OF LOGICAL GROUP
IF(KNTLTR.NE.LTRSIZ)GO TO 5
ITEST=LRGLTR
JTEST=LTRLFT
2 IF(LTRSTR(ITEST).NE.LTRNAM(JTEST))GO TO 5
ITEST=ITEST+1
JTEST=JTEST+1
IF(JTEST.LE.LTRRIT)GO TO 2
GO TO 7
C
C TEST IF SUBSCRIPT BOUND HAS PROPER VALUE
3 IF(KNTNUM.LT.(LOCATE+3))GO TO 5
ITEST=LRGNUM+2+LOCATE
IF(NUMSTR(ITEST).EQ.IVALUE)GO TO 7
GO TO 5
C
C CHECK FOR LRGKNT EQUAL TO IVALUE
4 IF(LRGKNT.EQ.IVALUE)GO TO 7
C
C ADVANCE BEYOND CURRENT ITEM IN DICTIONARY
5 LRGLTR=LRGLTR+KNTLTR
LRGNUM=LRGNUM+KNTNUM
GO TO 1
C
C NO MATCH FOUND
6 LRGKNT=0
C
C RETURN TO CALLING PROGRAM
7 RETURN
C317478262830
END
SUBROUTINE DAPAIR(SLACK ,KNDBGN,KNDEND,KONECT,IBUFFR,
1 MAXBFR,LOWBFR,KIND ,NEWBGN,NEWEND,BGNNEW,ENDNEW,
2 IWHERE,INCBGN,LMTBGN,BGNINC,BGNLMT,INCEND,LMTEND,
3 ENDINC,ENDLMT)
C RENBR(/INTERPRET PAIR OF ASSOCIATED VALUES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY, AND ARE
C RETURNED UNCHANGED.
C
C SLACK = FRACTION OF INCREMENT OF REAL NUMBER (NOT
C INTEGER) RANGE EXPRESSED IN SLASH NOTATION,
C BY WHICH RETURNED VALUE CAN EXCEED FINAL
C BOUND AND STILL BE CONSIDERED TO BE WITHIN
C RANGE.
C KNDBGN = SPECIFIES WHETHER INDEX IS RETURNED AS
C INTEGER ARGUMENT NEWBGN OR AS REAL ARGUMENT
C BGNNEW. NUMBER CAN BE TYPED WITH DECIMAL
C POINT AND/OR EXPONENT REGARDLESS OF VALUE OF
C KNDBGN.
C = -1, INDEX IS CALCULATED AS OCTAL INTEGER AND
C IS RETURNED AS ARGUMENT NEWBGN. HOWEVER,
C NUMBER FOLLOWING LETTER E OF EXPONENT IS
C EVALUATED IN DECIMAL.
C = 0, INDEX IS CALCULATED AS DECIMAL INTEGER
C AND IS RETURNED AS ARGUMENT NEWBGN.
C = 1 OR GREATER, INDEX IS RETURNED AS REAL
C ARGUMENT BGNNEW. IF POSSIBLE, REAL NUMBER
C WILL BE ACCUMULATED AS INTEGER, THEN BE
C CONVERTED TO REAL AND SHIFTED AS NECESSARY.
C KNDBGN IS MAXIMUM NUMBER OF DIGITS IN
C INTEGER.
C KNDEND = SPECIFIES WHETHER ASSOCIATED VALUE IS
C RETURNED AS INTEGER ARGUMENT NEWEND OR AS
C REAL ARGUMENT ENDNEW. NUMBER CAN BE TYPED
C WITH DECIMAL POINT AND/OR EXPONENT
C REGARDLESS OF VALUE OF KNDEND.
C = -1, ASSOCIATED VALUE IS CALCULATED AS OCTAL
C INTEGER AND IS RETURNED AS ARGUMENT NEWEND.
C HOWEVER, NUMBER FOLLOWING LETTER E OF
C EXPONENT IS EVALUATED IN DECIMAL.
C = 0, ASSOCIATED VALUE IS CALCULATED AS DECIMAL
C INTEGER AND IS RETURNED AS ARGUMENT NEWEND.
C = 1 OR GREATER, ASSOCIATED VALUE IS RETURNED
C AS REAL ARGUMENT ENDNEW. IF POSSIBLE, REAL
C NUMBER WILL BE ACCUMULATED AS INTEGER, THEN
C BE CONVERTED TO REAL AND SHIFTED AS
C NECESSARY. KNDEND IS MAXIMUM NUMBER OF
C DIGITS IN INTEGER.
C
C KONECT = SPECIFIES MANNER OF INTERPRETATION OF
C FOLLOWING NUMBER WHEN RANGE OF INDEXES AND
C RANGE OF ASSOCIATED VALUES HAVE BOTH BEEN
C EXHAUSTED. KONECT ALSO SPECIFIES WHETHER
C COMMAS ARE TO INDICATE THAT FOLLOWING
C NUMBER, IF ANY, IS TO BE INDEX OF SUBSEQUENT
C PAIR, OR WHETHER COMMAS ARE ALLOWED BETWEEN
C SUBSEQUENT VALUES ASSOCIATED WITH SAME INDEX
C OR RANGE OF INDEXES. REGARDLESS OF VALUE OF
C KONECT, ALL COMMAS APPEARING TO LEFT OF
C INDEX ARE IGNORED.
C = -1, 0 OR 1, COMMAS CANNOT APPEAR BETWEEN
C SPECIFICATION OF INDEX AND OF ITS ASSOCIATED
C VALUE AND CANNOT APPEAR BETWEEN
C REPRESENTATIONS OF SUBSEQUENT ASSOCIATED
C VALUES. IF COMMA IS FOUND, THEN FOLLOWING
C NUMBER, IF ANY, IS TAKEN TO BE INDEX OF
C SUBSEQUENT PAIR OF NUMBERS.
C = -1, WHEN RANGE OF INDEXES AND RANGE OF
C ASSOCIATED VALUES HAVE BOTH BEEN EXHAUSTED,
C FOLLOWING REPRESENTATION OF NUMBER OR OF
C RANGE OF NUMBERS ON SAME LINE IS TAKEN TO
C SPECIFY ADDITIONAL ASSOCIATED VALUES.
C
C IF END OF LINE IS FOUND BEFORE RANGE OF
C INDEXES HAS BEEN EXHAUSTED, THEN CALLING
C PROGRAM CAN REQUEST (BY SETTING KIND=4 TO
C SIMULATE FINDING OF AMPERSAND) THAT
C EVALUATION OF ASSOCIATED VALUES IS TO BE
C CONTINUED BY NEXT CALL TO THIS ROUTINE IN
C NEW TEXT READ INTO INPUT BUFFER. IF END OF
C LINE IS FOUND BEFORE RANGE OF INDEXES HAS
C BEEN EXHAUSTED, BUT CALLING PROGRAM LEAVES
C KIND UNCHANGED BEFORE AGAIN CALLING THIS
C ROUTINE, THEN REMAINING INDEX VALUES WILL BE
C RETURNED WITHOUT ASSOCIATED VALUES,
C FOLLOWING WHICH FIRST NUMBER IN NEW CONTENTS
C OF TEXT BUFFER WILL BE INTERPRETED AS INDEX
C OF NEW PAIR.
C
C IF AMPERSAND IS FOUND TO RIGHT OF INDEX
C SPECIFICATION, REGARDLESS OF WHETHER RANGE
C OF INDEXES HAS BEEN EXHAUSTED, THEN
C EVALUATION OF ASSOCIATED VALUES WILL BE
C CONTINUED BY NEXT CALL TO THIS ROUTINE IN
C NEW TEXT READ INTO INPUT BUFFER. IF
C AMPERSAND IS FOUND PRIOR TO EXHAUSTION OF
C RANGE OF INDEXES, BUT NEXT LINE READ INTO
C INPUT BUFFER IS TO START NEW PAIR, THEN KIND
C SHOULD BE SET TO 6 BY CALLING PROGRAM
C CAUSING REMAINING INDEXES TO BE GENERATED
C FIRST BUT MARKED AS HAVING MISSING
C ASSOCIATED VALUES. IF AMPERSAND IS FOUND
C AFTER EXHAUSTION OF RANGE OF INDEXES, BUT
C NEXT LINE READ INTO INPUT BUFFER IS TO START
C NEW PAIR, THEN KIND SHOULD BE SET TO ONE.
C
C = 0, WHEN RANGE OF INDEXES AND RANGE OF
C ASSOCIATED VALUES HAVE BOTH BEEN EXHAUSTED,
C FOLLOWING REPRESENTATION OF NUMBER OR OF
C RANGE OF NUMBERS ON SAME LINE CAUSES THIS
C ROUTINE TO REPORT MISSING COMMA, AND
C SUBSEQUENT CALL TO THIS ROUTINE THEN BEGINS
C EVALUATION OF THIS FOLLOWING NUMBER AS INDEX
C OR RANGE OF INDEXES OF SUBSEQUENT PAIR.
C
C IF END OF LINE IS FOUND BEFORE RANGE OF
C INDEXES HAS BEEN EXHAUSTED, THEN CALLING
C PROGRAM CAN REQUEST (BY SETTING KIND=4 TO
C SIMULATE FINDING OF AMPERSAND) THAT
C EVALUATION OF ASSOCIATED VALUES IS TO BE
C CONTINUED BY NEXT CALL TO THIS ROUTINE IN
C NEW TEXT READ INTO INPUT BUFFER. IF END OF
C LINE IS FOUND BEFORE RANGE OF INDEXES HAS
C BEEN EXHAUSTED, BUT CALLING PROGRAM LEAVES
C KIND UNCHANGED BEFORE AGAIN CALLING THIS
C ROUTINE, THEN REMAINING INDEX VALUES WILL BE
C RETURNED WITHOUT ASSOCIATED VALUES,
C FOLLOWING WHICH FIRST NUMBER IN NEW CONTENTS
C OF TEXT BUFFER WILL BE INTERPRETED AS INDEX
C OF SUBSEQUENT PAIR.
C
C IF AMPERSAND IS FOUND PRIOR TO EXHAUSTION OF
C RANGE OF INDEXES, THEN EVALUATION OF
C ASSOCIATED VALUES WILL BE CONTINUED BY NEXT
C CALL TO THIS ROUTINE IN NEW TEXT READ INTO
C INPUT BUFFER UNLESS CALLING PROGRAM SETS
C KIND TO 6 PRIOR TO SUBSEQUENT CALL TO THIS
C ROUTINE, CAUSING REMAINING INDEXES TO BE
C GENERATED BUT MARKED AS HAVING MISSING
C ASSOCIATED VALUES. IF AMPERSAND IS FOUND
C AFTER RANGE OF INDEXES AND RANGE OF
C ASSOCIATED VALUES HAVE BOTH BEEN EXHAUSTED,
C THEN FIRST NUMBER EVALUATED BY SUBSEQUENT
C CALL TO THIS ROUTINE IN NEW TEXT READ INTO
C INPUT BUFFER IS ASSUMED TO BE INDEX OF NEW
C PAIR OF VALUES.
C
C = 1, WHEN RANGE OF INDEXES AND RANGE OF
C ASSOCIATED VALUES HAVE BOTH BEEN EXHAUSTED,
C FOLLOWING REPRESENTATION OF NUMBER OR OF
C RANGE OF NUMBERS ON SAME LINE IS TAKEN TO
C SPECIFY ADDITIONAL ASSOCIATED VALUES.
C
C IF EITHER AMPERSAND OR END OF LINE IS FOUND
C BEFORE RANGE OF INDEXES HAS BEEN EXHAUSTED,
C THEN REMAINING INDEX VALUES WILL BE RETURNED
C WITHOUT ASSOCIATED VALUES, FOLLOWING WHICH
C CALLING PROGRAM WILL BE INFORMED THAT END OF
C LINE OR AMPERSAND HAS BEEN REACHED.
C
C = 2, 3 OR 4, SAME AS WHEN KONECT=-1, 0 OR 1
C RESPECTIVELY, EXCEPT THAT COMMAS CAN APPEAR
C (BUT ARE NOT REQUIRED) BETWEEN
C REPRESENTATIONS OF INDEX AND FIRST
C ASSOCIATED VALUE AND BETWEEN REPRESENTATIONS
C OF SUBSEQUENT ASSOCIATED VALUES. EXTRA
C COMMA INDICATES MISSING ASSOCIATED VALUE.
C IF KONECT=3, AND IF RANGE OF INDEXES AND
C RANGE OF ASSOCIATED VALUES HAVE BOTH BEEN
C EXHAUSTED, THEN KIND WILL BE RETURNED SET TO
C 10 TO INDICATE MISSING SEMICOLON IF
C FOLLOWING NUMBER IS FOUND WHETHER OR NOT
C THIS FOLLOWING NUMBER IS PRECEDED BY COMMA,
C AND SUBSEQUENT CALL TO THIS ROUTINE WILL
C BEGIN EVALUATION OF FOLLOWING NUMBER AS
C INDEX OR RANGE OF INDEXES OF SUBSEQUENT
C PAIR. UNLIKE COMMAS, SEMICOLONS ARE ALWAYS
C REPORTED TO CALLING PROGRAM REGARDLESS OF
C VALUE OF KONECT.
C
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY MULTIPLE OF A1
C FORMAT, WHICH IS TO BE SEARCHED FOR NUMBER
C SPECIFICATIONS. IBUFFR THEN CONTAINS ONE
C CHARACTER PER COMPUTER STORAGE LOCATION.
C
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY LOCATIONS
C TO BE SEARCHED.
C
C FOLLOWING ARGUMENTS ARE USED BOTH FOR INPUT TO THIS
C ROUTINE, AND FOR OUTPUT TO CALLING PROGRAM.
C
C LOWBFR = INPUT CONTAINING SUBSCRIPT WITHIN IBUFFR
C ARRAY OF FIRST (LEFTMOST) CHARACTER WHICH
C CAN BE SCANNED FOR NUMBER SPECIFICATION.
C LOWBFR IS RETURNED POINTING TO NEXT
C CHARACTER WHICH WOULD BE INTERPRETED BY
C SUBSEQUENT CALL TO THIS ROUTINE IF THIS
C SUBSEQUENT CALL NEEDS TO EVALUATE FURTHER
C NUMBER SPECIFICATIONS. LOWBFR IS RETURNED
C UNCHANGED IF THIS ROUTINE MERELY GENERATES
C NEXT ASSOCIATED VALUE WITHIN PREVIOUSLY
C DETERMINED RANGE. IF THERE ARE NO PRINTING
C CHARACTERS AT OR TO RIGHT OF IBUFFR(LOWBFR),
C BUT INTERPRETATION OF ADDITIONAL CHARACTERS
C IS ATTEMPTED, THEN LOWBFR WILL BE RETURNED
C CONTAINING MAXBFR+1. LOWBFR MUST BE RESET
C BY CALLING PROGRAM TO POINT TO FIRST
C CHARACTER IN IBUFFR ARRAY EACH TIME NEW LINE
C OF TEXT IS READ.
C
C KIND = INPUT CONTAINING -1, ERROR WAS DETECTED BY
C CALLING PROGRAM (RATHER THAN BY THIS
C ROUTINE) IN RESULTS RETURNED BY PREVIOUS
C CALL TO THIS ROUTINE AND ANY ADDITIONAL
C NUMBERS THROUGH NEXT APPEARANCE OF COMMA
C (UNLESS KONECT IS GREATER THAN 1) OR
C SEMICOLON OR AMPERSAND OR UNKNOWN CHARACTER
C OR END OF LINE ARE TO BE IGNORED. NEXT
C NUMBER TO RIGHT OF COMMA OR ON LINE
C FOLLOWING AMPERSAND OR END OF LINE IS TO BE
C INTERPRETED AS INDEX OF NEXT PAIR. UNKNOWN
C CHARACTER OR SEMICOLON IS REPORTED TO
C CALLING PROGRAM IF IT IS FOUND INSTEAD.
C = INPUT CONTAINING 0, THIS ROUTINE HAS NOT YET
C BEEN CALLED DURING EXECUTION OF CURRENT
C LOGICAL SECTION OF CALLING PROGRAM. THIS
C ROUTINE IS TO BEGIN EVALUATION OF CONTENTS
C OF INPUT TEXT BUFFER, NOT CONTINUE
C GENERATION OF RANGES EVALUATED BY PREVIOUS
C CALLS TO THIS ROUTINE. LOWBFR SHOULD POINT
C TO FIRST CHARACTER IN IBUFFR ARRAY TO BE
C INTERPRETED.
C = INPUT GREATER THAN ZERO, VALUE OF KIND
C INDICATES CONDITION RETURNED BY PREVIOUS
C CALL TO THIS ROUTINE AND IN MOST CASES HAS
C NOT BEEN MODIFIED BY CALLING PROGRAM. KIND
C BEING RETURNED WITH ONE OF VALUES 7, 8, 9,
C 10 (IF KONECT IS 2 OR 4), 13 AND 14
C INDICATES THAT PAIR OF VALUES IS BEING
C RETURNED, ALTHOUGH EITHER OR BOTH MEMBERS OF
C PAIR COULD BE MISSING. OTHER VALUES OF KIND
C INDICATE SPECIAL CONDITIONS FOR WHICH PAIR
C OF NUMBERS IS NOT RETURNED.
C = 1, NOTHING, EXCEPT PERHAPS LEADING COMMAS OR
C ELSE COMMENT INDICATED BY LEADING
C EXCLAMATION POINT, WAS FOUND AT OR TO RIGHT
C OF IBUFFR(LOWBFR). CALLING PROGRAM SHOULD
C READ NEW LINE OF TEXT INTO IBUFFR.
C = 2, SEMICOLON WAS FOUND AS FIRST PRINTING
C CHARACTER AT OR TO RIGHT OF IBUFFR(LOWBFR).
C IF RANGE OF INDEXES HAS NOT BEEN EXHAUSTED
C WHEN SEMICOLON IS FOUND, THEN REMAINING
C MEMBERS OF RANGE ARE REPORTED TO CALLING
C PROGRAM BEFORE SEMICOLON IS REPORTED. IT IS
C ASSUMED THAT CALLING PROGRAM WILL TREAT
C SEMICOLON AS MARKING END OF LOGICAL GROUP OF
C PAIR SPECIFICATIONS IF KONECT IS NOT GREATER
C THAN 1, OR END OF SINGLE PAIR SPECIFICATION
C IF KONECT IS GREATER THAN 1.
C = 3, AMPERSAND WAS FOUND WHILE SEARCHING FOR
C NEXT RANGE OF INDEXES. LOWBFR IS RETURNED
C POINTING BEYOND END OF BUFFER. CALLING
C PROGRAM SHOULD READ NEW LINE OF TEXT INTO
C INPUT BUFFER BEFORE AGAIN CALLING THIS
C ROUTINE. THIS VALUE OF KIND IS NOT RETURNED
C IF AMPERSAND IS FOUND WHILE SEARCHING FOR
C RANGE OF ASSOCIATED VALUES.
C = 4, RANGE OF INDEXES WAS NOT EXHAUSTED, BUT
C AMPERSAND WAS FOUND INSTEAD OF RANGE OF
C ASSOCIATED VALUES. CALLING PROGRAM SHOULD
C READ NEW LINE OF TEXT INTO BUFFER BEFORE
C AGAIN CALLING THIS ROUTINE. SUBSEQUENT CALL
C TO THIS ROUTINE WILL CONTINUE EVALUATION OF
C ASSOCIATED RANGES IN NEW CONTENTS OF BUFFER.
C IF SEMICOLON (OR COMMA IF KONECT IS NOT
C GREATER THAN 1) IS FOUND AT START OF NEW
C CONTENTS OF BUFFER, THEN REMAINING INDEX
C VALUES WILL BE RETURNED TO CALLING PROGRAM
C BUT CALLING PROGRAM WILL BE INFORMED THAT
C ASSOCIATED VALUES ARE MISSING. IF
C SUBSEQUENT CALL TO THIS ROUTINE IS INSTEAD
C TO BEGIN EVALUATION OF NEW SET OF LEADING
C INDEXES AND ASSOCIATED VALUES, THEN CALLING
C PROGRAM SHOULD SET KIND TO 6 TO SIMULATE
C LACK OF AMPERSAND, CAUSING REMAINING INDEXES
C TO BE GENERATED, BUT MARKED AS HAVING
C MISSING ASSOCIATED VALUES. IF REMAINING
C INDEXES ARE NOT WANTED, THEN KIND SHOULD BE
C SET TO ONE.
C = 5, RANGE OF INDEXES WAS EXHAUSTED, BUT
C AMPERSAND WAS FOUND INSTEAD OF RANGE OF
C ASSOCIATED VALUES. CALLING PROGRAM SHOULD
C READ NEW LINE OF TEXT INTO BUFFER BEFORE
C AGAIN CALLING THIS ROUTINE. SUBSEQUENT CALL
C TO THIS ROUTINE WILL CONTINUE EVALUATION OF
C ASSOCIATED RANGES IN NEW CONTENTS OF BUFFER.
C SINCE RANGE OF INDEXES HAS BEEN EXHAUSTED,
C NO ADDITIONAL MISSING VALUES WILL BE
C REPORTED IF SEMICOLON (OR COMMA IF KONECT IS
C NOT GREATER THAN 1) IS FOUND AT START OF NEW
C CONTENTS OF BUFFER. IF SUBSEQUENT CALL TO
C THIS ROUTINE IS ALWAYS TO BEGIN EVALUATION
C OF NEW SET OF LEADING INDEXES AND ASSOCIATED
C VALUES, THEN CALLING PROGRAM SHOULD SET KIND
C TO ONE.
C = 6, END OF LINE WAS FOUND BUT RANGE OF
C INDEXES WAS NOT EXHAUSTED. IF KIND IS SENT
C UNCHANGED TO SUBSEQUENT CALL OF THIS
C ROUTINE, THEN REMAINING INDEXES WILL BE
C RETURNED TO CALLING PROGRAM, BUT CALLING
C PROGRAM WILL BE INFORMED THAT ASSOCIATED
C VALUES ARE MISSING. IF SUBSEQUENT CALL TO
C THIS ROUTINE IS INSTEAD TO CONTINUE
C EVALUATION OF ASSOCIATED RANGES IN NEW
C CONTENTS OF BUFFER READ BY CALLING PROGRAM
C BEFORE THIS ROUTINE IS AGAIN CALLED, THEN
C KIND SHOULD BE SET TO 4 TO SIMULATE
C APPEARANCE OF AMPERSAND AT END OF PRECEDING
C LINE. IF REMAINING INDEXES ARE NOT WANTED,
C THEN KIND SHOULD BE SET TO ONE.
C = 7, BOTH INDEX AND ASSOCIATED VALUE ARE BEING
C RETURNED TO CALLING PROGRAM.
C = 8, INDEX IS BEING RETURNED TO CALLING
C PROGRAM, BUT ASSOCIATED VALUE IS MISSING.
C NEWEND AND ENDNEW ARE RETURNED UNDEFINED.
C = 9, ASSOCIATED VALUE IS BEING RETURNED TO
C CALLING PROGRAM, BUT RANGE OF INDEXES HAS
C BEEN EXHAUSTED. NEWBGN OR BGNNEW, WHICHEVER
C IS APPROPRIATE, IS RETURNED UNCHANGED (BUT
C CAN BE MODIFIED AS DESIRED BY CALLING
C PROGRAM).
C = 10, RANGES OF BOTH INDEXES AND ASSOCIATED
C VALUES HAVE BEEN EXHAUSTED. THIS VALUE IS
C NEVER RETURNED IF KONECT=-1 OR 1.
C
C IF KONECT HAS EITHER OF VALUES 2 OR 4, THEN
C RANGES OF BOTH INDEXES AND ASSOCIATED VALUES
C HAVE BEEN EXHAUSTED, BUT EXTRA COMMA WAS
C FOUND INDICATING MISSING ASSOCIATED VALUE.
C NEWBGN OR BGNNEW, WHICHEVER IS APPROPRIATE,
C IS RETURNED UNCHANGED (BUT CAN BE MODIFIED
C AS DESIRED BY CALLING PROGRAM).
C
C IF KONECT=0, THEN RANGES OF BOTH INDEXES AND
C ASSOCIATED VALUES HAVE BEEN EXHAUSTED, BUT
C FOLLOWING NUMBER WAS FOUND WHICH WAS NOT
C PRECEDED BY COMMA. KIND SHOULD BE SET TO -1
C BY CALLING PROGRAM BEFORE THIS ROUTINE IS
C CALLED NEXT IF LACK OF COMMA INDICATES
C SERIOUS ENOUGH ERROR THAT ALL NUMBERS SHOULD
C BE IGNORED UNTIL NEXT COMMA IS FOUND. IF
C KONECT=3, THEN RANGES OF BOTH INDEXES AND
C ASSOCIATED VALUES HAVE BEEN EXHAUSTED, BUT
C FOLLOWING NUMBER WAS FOUND WHICH WAS NOT
C PRECEDED BY SEMICOLON, BUT WHICH MAY OR MAY
C NOT HAVE BEEN PRECEDED BY ONE OR MORE
C COMMAS. KIND SHOULD BE SET TO -1 BY CALLING
C PROGRAM BEFORE THIS ROUTINE IS CALLED NEXT
C IF LACK OF SEMICOLON INDICATES SERIOUS
C ENOUGH ERROR THAT ALL NUMBERS SHOULD BE
C IGNORED UNTIL NEXT SEMICOLON IS FOUND. IF
C KONECT IS 0 OR 3, THEN LOWBFR IS RETURNED
C POINTING TO FIRST CHARACTER OF NUMBER
C SPECIFICATION, AND NUMBER WILL BE EVALUATED
C AS INDEX IF THIS ROUTINE IS CALLED AGAIN
C WITHOUT KIND HAVING BEEN CHANGED.
C = 11, UNKNOWN CHARACTER WAS FOUND. IF RANGE
C OF INDEXES HAS NOT BEEN EXHAUSTED WHEN
C UNKNOWN CHARACTER IS FOUND, THEN REMAINING
C MEMBERS OF RANGE ARE REPORTED TO CALLING
C PROGRAM BEFORE UNKNOWN CHARACTER IS
C REPORTED. LOWBFR IS RETURNED POINTING TO
C NEXT CHARACTER TO RIGHT OF UNKNOWN
C CHARACTER. IF THIS ROUTINE IS CALLED
C WITHOUT CHANGING VALUE OF KIND, THEN NUMBER
C TO RIGHT OF UNKNOWN CHARACTER WILL BE
C INTERPRETED AS INDEX OF NEXT PAIR.
C = 12, ERROR WAS FOUND WITHIN RANGE
C SPECIFICATION. FINDING OF SUCH ERROR
C TERMINATES GENERATION OF RANGE OF INDEXES.
C IWHERE IS RETURNED POINTING TO CHARACTER AT
C START OF SPECIFICATION CONTAINING ERROR.
C LOWBFR IS RETURNED POINTING TO CHARACTER TO
C RIGHT OF SPECIFICATION CONTAINING ERROR. IF
C THIS ROUTINE IS CALLED WITHOUT CHANGING
C VALUE OF KIND, THEN NUMBER TO RIGHT OF
C UNKNOWN CHARACTER WILL BE INTERPRETED AS
C INDEX OF NEXT PAIR.
C = 13, INDEX AND ASSOCIATED VALUE ZERO ARE
C BEING RETURNED TO CALLING PROGRAM. ZERO WAS
C INDICATED BY LACK OF NUMBER TO RIGHT OF
C ASTERISK. MISSING NUMBER TO RIGHT OF
C ASTERISK IN SPECIFICATION OF RANGE OF
C INDEXES IS NOT ALLOWED AND WOULD RETURN KIND
C CONTAINING VALUE 12.
C = 14, SAME AS KIND=13 EXCEPT THAT RANGE OF
C INDEXES WAS EXHAUSTED. NEWBGN OR BGNNEW,
C WHICHEVER IS APPROPRIATE, IS RETURNED
C UNCHANGED (BUT CAN BE MODIFIED AS DESIRED BY
C CALLING PROGRAM).
C
C NEWBGN = RETURNED CONTAINING NEXT VALUE OF INTEGER
C INDEX IF KIND IS RETURNED CONTAINING ONE OF
C VALUES 7, 8 OR 13 AND IF KNDBGN IS LESS THAN
C OR EQUAL TO ZERO. NEWBGN SHOULD NOT BE
C CHANGED BY CALLING PROGRAM UNLESS KIND IS
C RETURNED CONTAINING ONE OF VALUES 9, 10 OR
C 14 INDICATING THAT RANGE OF INDEXES HAS BEEN
C EXHAUSTED.
C
C NEWEND = RETURNED CONTAINING NEXT ASSOCIATED INTEGER
C VALUE IF KIND IS RETURNED WITH ONE OF VALUES
C 7, 9, 13 OR 14 AND IF KNDEND IS LESS THAN OR
C EQUAL TO ZERO. NEWEND CAN BE RETURNED
C CHANGED BY THIS ROUTINE EVEN IF ASSOCIATED
C VALUE IS NOT FOUND BUT THEN MUST NOT BE
C CHANGED BY CALLING PROGRAM. IF RANGE OF
C ASSOCIATED VALUES HAS BEEN EXHAUSTED, OR IF
C ASSOCIATED VALUE IS INDICATED BY EXTRA COMMA
C TO BE MISSING, THEN NEWEND DOES NOT CONTAIN
C ASSOCIATED INTEGER VALUE BUT INSTEAD
C INDICATES TO SUBSEQUENT CALL TO THIS ROUTINE
C REASON WHY VALUE COULD NOT BE RETURNED.
C
C BGNNEW = RETURNED CONTAINING NEXT VALUE OF REAL INDEX
C IF KIND IS RETURNED CONTAINING ONE OF VALUES
C 7, 8 OR 13 AND IF KNDBGN IS GREATER THAN
C ZERO. BGNNEW SHOULD NOT BE CHANGED BY
C CALLING PROGRAM UNLESS KIND IS RETURNED
C CONTAINING ONE OF VALUES 9, 10 OR 14
C INDICATING THAT RANGE OF INDEXES HAS BEEN
C EXHAUSTED.
C
C ENDNEW = RETURNED CONTAINING NEXT ASSOCIATED REAL
C VALUE IF KIND IS RETURNED WITH ONE OF VALUES
C 7, 9, 13 OR 14 AND IF KNDEND IS GREATER THAN
C ZERO. ENDNEW SHOULD NOT BE CHANGED BY
C CALLING PROGRAM.
C
C FOLLOWING ARGUMENT IS USED FOR OUTPUT ONLY.
C
C IWHERE = RETURNED POINTING TO LEFT CHARACTER OF RANGE
C NOTATION WHICH WAS FOUND TO CONTAIN ERROR
C SUCH AS TOO MANY ASTERISKS, TOO MANY
C SLASHES, TOO MANY COLONS, OR ABSENCE OF
C NUMBER TO RIGHT OF ASTERISK IN SPECIFICATION
C OF RANGE OF LEADING INDEXES.
C
C REMAINING DAPAIR ARGUMENTS ARE USED ONLY DURING
C GENERATION OF VALUES WITHIN RANGES AND SHOULD BE SENT
C TO SUBSEQUENT DAPAIR CALL UNCHANGED. THESE ARGUMENTS
C SHOULD BE STATED BY NAME IN CALL STATEMENTS AND
C SHOULD BE IGNORED BY CALLING PROGRAM EXCEPT INSOFAR
C AS IS NECESSARY TO TRANSMIT THEIR VALUES TO
C SUBSEQUENT CALL TO THIS ROUTINE.
C
DIMENSION IBUFFR(MAXBFR)
DATA KOMENT,IEND,IAND,KOMMA,IBLANK,ITAB/
11H!,1H;,1H&,1H,,1H ,1H /
C
C TEST IF ARE CONTINUING PREVIOUSLY EVALUATED SERIES
MISSIN=0
IKNCT=KONECT
IF(IKNCT.GT.1)IKNCT=IKNCT-3
MANY=0
IPLACE=0
IF(KIND.LE.0)GO TO 31
IF(KIND.GT.14)GO TO 31
GO TO(31,31,31,13,11,43, 1, 1, 9, 5,31,31, 1, 6),KIND
C
C GET NEXT INDEX
1 ITYPE=5
LIMIT=LOWBFR-1
IF(KNDBGN.LE.0)INIBGN=NEWBGN
IF(KNDBGN.GT.0)BGNINI=BGNNEW
GO TO 32
2 IF(ITYPE.NE.5)GO TO 4
IF(KIND.EQ.7)GO TO 9
IF(KIND.EQ.8)GO TO 3
KIND=7
GO TO 7
3 IF(NEWEND.LE.0)GO TO 50
GO TO 14
C
C SERIES OF INDEXES EXHAUSTED
4 IF(KNDBGN.LE.0)NEWBGN=INIBGN
IF(KNDBGN.GT.0)BGNNEW=BGNINI
IF(KIND.EQ.7)GO TO 8
IF(KIND.NE.8)GO TO 6
IF(NEWEND.LE.0)GO TO 31
IF(IKNCT.NE.0)GO TO 12
KIND=9
GO TO 31
C
C GET NEXT ASSOCIATED VALUE
5 IF(IKNCT.EQ.0)GO TO 31
6 KIND=9
7 ITYPE=6
GO TO 10
8 KIND=9
9 ITYPE=5
10 LIMIT=LOWBFR-1
GO TO 18
C
C LOOK FOR NEXT ASSOCIATED RANGE OF VALUES
11 MISSIN=NEWEND
12 KIND=9
GO TO 17
13 MISSIN=NEWEND
14 KIND=7
GO TO 17
15 IF(KONECT.LE.1)GO TO 28
IF(MISSIN.GT.0)GO TO 42
MISSIN=1
16 LOWBFR=LOWBFR+1
17 IF(LOWBFR.GT.MAXBFR)GO TO 25
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.IBLANK)GO TO 16
IF(LETTER.EQ.ITAB)GO TO 16
IF(LETTER.EQ.KOMMA)GO TO 15
IF(LETTER.EQ.KOMENT)GO TO 24
IF(LETTER.EQ.IEND)GO TO 23
IF(LETTER.EQ.IAND)GO TO 21
C
C EVALUATE NEXT ASSOCIATED RANGE OF VALUES
ITYPE=0
LIMIT=MAXBFR
IWHERE=LOWBFR
18 CALL DANEXT(KNDEND,SLACK ,IBUFFR,LIMIT,LOWBFR,
1MANY,ITYPE,NEWEND,INCEND,LMTEND,ENDNEW,ENDINC,
2ENDLMT)
IF(ITYPE.EQ.9)GO TO 20
IF(ITYPE.GT.6)GO TO 47
IF(ITYPE.EQ.5)GO TO 50
IF(ITYPE.NE.6)GO TO 19
IF(KIND.EQ.7)GO TO 48
GO TO 49
19 IF(KIND.EQ.7)GO TO 17
IF(IKNCT.NE.0)GO TO 17
GO TO 31
20 IF(KIND.EQ.9)GO TO 46
LOWBFR=LOWBFR-1
GO TO 43
C
C AMPERSAND FOUND INSTEAD OF ADDITIONAL RANGE
21 IF(KIND.EQ.7)GO TO 22
IF(IKNCT.GT.0)GO TO 36
GO TO 38
22 IF(IKNCT.GT.0)GO TO 43
GO TO 37
C
C SEMICOLON FOUND INSTEAD OF ASSOCIATED VALUE
23 IF(KIND.EQ.7)GO TO 43
IF(MISSIN.GT.0)GO TO 45
GO TO 35
C
C NO ADDITIONAL ASSOCIATED RANGE FOUND
24 LOWBFR=MAXBFR+1
25 IF(KIND.EQ.7)GO TO 26
IF(MISSIN.GT.0)GO TO 45
GO TO 34
26 IF(IKNCT.GT.0)GO TO 43
GO TO 40
C
C COMMA FOUND INSTEAD OF NEXT ASSOCIATED RANGE
27 IF(KONECT.LE.1)GO TO 29
GO TO 30
28 IF(KIND.EQ.7)GO TO 43
29 KIND=7
C
C FIND NEXT PAIR OF SERIES
30 LOWBFR=LOWBFR+1
31 IF(LOWBFR.GT.MAXBFR)GO TO 34
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.IBLANK)GO TO 30
IF(LETTER.EQ.ITAB)GO TO 30
IF(LETTER.EQ.KOMMA)GO TO 27
IF(LETTER.EQ.KOMENT)GO TO 33
IF(LETTER.EQ.IEND)GO TO 35
IF(LETTER.EQ.IAND)GO TO 36
C
C OBTAIN FIRST LEADING RANGE
ITYPE=0
LIMIT=MAXBFR
IPLACE=1
IWHERE=LOWBFR
32 CALL DANEXT(KNDBGN,SLACK,IBUFFR,LIMIT,LOWBFR,
1MANY,ITYPE,NEWBGN,INCBGN,LMTBGN,BGNNEW,BGNINC,
2BGNLMT)
IF(IPLACE.EQ.0)GO TO 2
IF(ITYPE.EQ.9)GO TO 46
IF(KIND.LT.0)GO TO 31
IF(ITYPE.NE.5)GO TO 47
IF(KIND.NE.9)GO TO 14
LOWBFR=IWHERE
GO TO 45
C
C RETURN TO CALLING PROGRAM
33 LOWBFR=MAXBFR+1
34 KIND=1
GO TO 50
35 KIND=2
LOWBFR=LOWBFR+1
GO TO 50
36 KIND=3
LOWBFR=MAXBFR+1
GO TO 50
37 KIND=4
GO TO 39
38 KIND=5
39 LOWBFR=MAXBFR+1
GO TO 41
40 KIND=6
41 NEWEND=MISSIN
GO TO 50
42 IF(KIND.EQ.9)GO TO 45
NEWEND=1
GO TO 44
43 NEWEND=0
44 KIND=8
GO TO 50
45 KIND=10
GO TO 50
46 KIND=11
GO TO 50
47 KIND=12
GO TO 50
48 KIND=13
GO TO 50
49 KIND=14
50 RETURN
C863065281593!;&
END
SUBROUTINE DAIPAR( KNDBGN,KNDEND,KONECT,IBUFFR,
1 MAXBFR,LOWBFR,KIND ,NEWBGN,NEWEND,BGNNEW,ENDNEW)
C RENBR(/INTERPRET PAIR OF ASSOCIATED VALUES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY, AND ARE
C RETURNED UNCHANGED.
C
C KNDBGN = SPECIFIES WHETHER INDEX IS RETURNED AS
C INTEGER ARGUMENT NEWBGN OR AS REAL ARGUMENT
C BGNNEW. NUMBER CAN BE TYPED WITH DECIMAL
C POINT AND/OR EXPONENT REGARDLESS OF VALUE OF
C KNDBGN.
C = -1, INDEX IS CALCULATED AS OCTAL INTEGER AND
C IS RETURNED AS ARGUMENT NEWBGN. HOWEVER,
C NUMBER FOLLOWING LETTER E OF EXPONENT IS
C EVALUATED IN DECIMAL.
C = 0, INDEX IS CALCULATED AS DECIMAL INTEGER
C AND IS RETURNED AS ARGUMENT NEWBGN.
C = 1 OR GREATER, INDEX IS RETURNED AS REAL
C ARGUMENT BGNNEW. IF POSSIBLE, REAL NUMBER
C WILL BE ACCUMULATED AS INTEGER, THEN BE
C CONVERTED TO REAL AND SHIFTED AS NECESSARY.
C KNDBGN IS MAXIMUM NUMBER OF DIGITS IN
C INTEGER.
C KNDEND = SPECIFIES WHETHER ASSOCIATED VALUE IS
C RETURNED AS INTEGER ARGUMENT NEWEND OR AS
C REAL ARGUMENT ENDNEW. NUMBER CAN BE TYPED
C WITH DECIMAL POINT AND/OR EXPONENT
C REGARDLESS OF VALUE OF KNDEND.
C = -1, ASSOCIATED VALUE IS CALCULATED AS OCTAL
C INTEGER AND IS RETURNED AS ARGUMENT NEWEND.
C HOWEVER, NUMBER FOLLOWING LETTER E OF
C EXPONENT IS EVALUATED IN DECIMAL.
C = 0, ASSOCIATED VALUE IS CALCULATED AS DECIMAL
C INTEGER AND IS RETURNED AS ARGUMENT NEWEND.
C = 1 OR GREATER, ASSOCIATED VALUE IS RETURNED
C AS REAL ARGUMENT ENDNEW. IF POSSIBLE, REAL
C NUMBER WILL BE ACCUMULATED AS INTEGER, THEN
C BE CONVERTED TO REAL AND SHIFTED AS
C NECESSARY. KNDEND IS MAXIMUM NUMBER OF
C DIGITS IN INTEGER.
C
C
C
C KONECT = SPECIFIES MANNER OF INTERPRETATION OF
C FOLLOWING NUMBER WHEN PREVIOUS CALL HAS
C ALREADY RETURNED PAIR OF VALUES. KONECT
C ALSO SPECIFIES WHETHER COMMAS ARE TO
C INDICATE THAT FOLLOWING NUMBER, IF ANY, IS
C TO BE INDEX OF SUBSEQUENT PAIR, OR WHETHER
C COMMAS ARE ALLOWED BETWEEN SUBSEQUENT VALUES
C ASSOCIATED WITH SAME INDEX. REGARDLESS OF
C VALUE OF KONECT, ALL COMMAS APPEARING TO
C LEFT OF INDEX ARE IGNORED.
C = -1, 0 OR 1, COMMAS CANNOT APPEAR BETWEEN
C SPECIFICATION OF INDEX AND OF ITS ASSOCIATED
C VALUE AND CANNOT APPEAR BETWEEN
C REPRESENTATIONS OF SUBSEQUENT ASSOCIATED
C VALUES. IF COMMA IS FOUND, THEN FOLLOWING
C NUMBER, IF ANY, IS TAKEN TO BE INDEX OF
C SUBSEQUENT PAIR OF NUMBERS.
C = -1, WHEN PREVIOUS CALL HAS ALREADY RETURNED
C PAIR OF VALUES, FOLLOWING REPRESENTATION OF
C NUMBER ON SAME LINE IS TAKEN TO SPECIFY
C ADDITIONAL ASSOCIATED VALUE.
C
C IF END OF LINE IS FOUND INSTEAD OF FIRST
C ASSOCIATED VALUE, THEN CALLING PROGRAM CAN
C REQUEST (BY SETTING KIND=4 TO SIMULATE
C FINDING OF AMPERSAND) THAT EVALUATION OF
C ASSOCIATED VALUES IS TO BE CONTINUED BY NEXT
C CALL TO THIS ROUTINE IN NEW TEXT READ INTO
C INPUT BUFFER. IF END OF LINE IS FOUND
C BEFORE FIRST ASSOCIATED VALUE, BUT CALLING
C PROGRAM LEAVES KIND UNCHANGED BEFORE AGAIN
C CALLING THIS ROUTINE, THEN INDEX VALUE WILL
C BE RETURNED WITHOUT ASSOCIATED VALUE,
C FOLLOWING WHICH FIRST NUMBER IN NEW CONTENTS
C OF TEXT BUFFER WILL BE INTERPRETED AS INDEX
C OF NEW PAIR.
C
C IF AMPERSAND IS FOUND TO RIGHT OF INDEX
C SPECIFICATION, REGARDLESS OF WHETHER
C ASSOCIATED VALUE HAS BEEN FOUND BY PREVIOUS
C CALL, THEN EVALUATION OF ASSOCIATED VALUES
C WILL BE CONTINUED BY NEXT CALL TO THIS
C ROUTINE IN NEW TEXT READ INTO INPUT BUFFER.
C IF AMPERSAND IS FOUND PRIOR TO FIRST
C ASSOCIATED VALUE, BUT NEXT LINE READ INTO
C INPUT BUFFER IS TO START NEW PAIR, THEN KIND
C SHOULD BE SET TO 6 BY CALLING PROGRAM
C CAUSING INDEX TO BE GENERATED FIRST BUT
C MARKED AS HAVING MISSING ASSOCIATED VALUE.
C IF AMPERSAND IS FOUND AFTER ASSOCIATED VALUE
C HAS BEEN FOUND BY PREVIOUS CALL, BUT NEXT
C LINE READ INTO INPUT BUFFER IS TO START NEW
C PAIR, THEN KIND SHOULD BE SET TO ONE.
C
C = 0, WHEN PREVIOUS CALL HAS ALREADY RETURNED
C PAIR OF VALUES, FOLLOWING REPRESENTATION OF
C NUMBER ON SAME LINE CAUSES THIS ROUTINE TO
C REPORT MISSING COMMA, AND SUBSEQUENT CALL TO
C THIS ROUTINE THEN BEGINS EVALUATION OF THIS
C FOLLOWING NUMBER AS INDEX OF SUBSEQUENT
C PAIR.
C
C IF END OF LINE IS FOUND INSTEAD OF FIRST
C ASSOCIATED VALUE, THEN CALLING PROGRAM CAN
C REQUEST (BY SETTING KIND=4 TO SIMULATE
C FINDING OF AMPERSAND) THAT EVALUATION OF
C ASSOCIATED VALUE IS TO BE CONTINUED BY NEXT
C CALL TO THIS ROUTINE IN NEW TEXT READ INTO
C INPUT BUFFER. IF END OF LINE IS FOUND
C BEFORE FIRST ASSOCIATED VALUE, BUT CALLING
C PROGRAM LEAVES KIND UNCHANGED BEFORE AGAIN
C CALLING THIS ROUTINE, THEN INDEX VALUE WILL
C BE RETURNED WITHOUT ASSOCIATED VALUE,
C FOLLOWING WHICH FIRST NUMBER IN NEW CONTENTS
C OF TEXT BUFFER WILL BE INTERPRETED AS INDEX
C OF SUBSEQUENT PAIR.
C
C IF AMPERSAND IS FOUND BEFORE FIRST
C ASSOCIATED VALUE, THEN EVALUATION OF
C ASSOCIATED VALUE WILL BE CONTINUED BY NEXT
C CALL TO THIS ROUTINE IN NEW TEXT READ INTO
C INPUT BUFFER UNLESS CALLING PROGRAM SETS
C KIND TO 6 PRIOR TO SUBSEQUENT CALL TO THIS
C ROUTINE, CAUSING INDEX TO BE GENERATED BUT
C MARKED AS HAVING MISSING ASSOCIATED VALUE.
C IF AMPERSAND IS FOUND AFTER ASSOCIATED VALUE
C HAS BEEN FOUND, THEN FIRST NUMBER EVALUATED
C BY SUBSEQUENT CALL TO THIS ROUTINE IN NEW
C TEXT READ INTO INPUT BUFFER IS ASSUMED TO BE
C INDEX OF NEW PAIR OF VALUES.
C
C = 1, WHEN PREVIOUS CALL HAS ALREADY RETURNED
C PAIR OF VALUES, FOLLOWING REPRESENTATION OF
C NUMBER ON SAME LINE IS TAKEN TO SPECIFY
C ADDITIONAL ASSOCIATED VALUE.
C
C IF EITHER AMPERSAND OR END OF LINE IS FOUND
C BEFORE FIRST ASSOCIATED VALUE, THEN INDEX
C VALUE WILL BE RETURNED WITHOUT ASSOCIATED
C VALUE, FOLLOWING WHICH CALLING PROGRAM WILL
C BE INFORMED THAT END OF LINE OR AMPERSAND
C HAS BEEN REACHED.
C
C = 2, 3 OR 4, SAME AS WHEN KONECT=-1, 0 OR 1
C RESPECTIVELY, EXCEPT THAT COMMAS CAN APPEAR
C (BUT ARE NOT REQUIRED) BETWEEN
C REPRESENTATIONS OF INDEX AND FIRST
C ASSOCIATED VALUE AND BETWEEN REPRESENTATIONS
C OF SUBSEQUENT ASSOCIATED VALUES. EXTRA
C COMMA INDICATES MISSING ASSOCIATED VALUE.
C IF KONECT=3, AND IF PREVIOUS CALL RETURNED
C PAIR OF VALUES, THEN KIND WILL BE RETURNED
C SET TO 10 TO INDICATE MISSING SEMICOLON IF
C FOLLOWING NUMBER IS FOUND WHETHER OR NOT
C THIS FOLLOWING NUMBER IS PRECEDED BY COMMA,
C AND SUBSEQUENT CALL TO THIS ROUTINE WILL
C BEGIN EVALUATION OF FOLLOWING NUMBER AS
C INDEX OF SUBSEQUENT PAIR. UNLIKE COMMAS,
C SEMICOLONS ARE ALWAYS REPORTED TO CALLING
C PROGRAM REGARDLESS OF VALUE OF KONECT.
C
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY MULTIPLE OF A1
C FORMAT, WHICH IS TO BE SEARCHED FOR NUMBER
C SPECIFICATIONS. IBUFFR THEN CONTAINS ONE
C CHARACTER PER COMPUTER STORAGE LOCATION.
C
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY LOCATIONS
C TO BE SEARCHED.
C
C FOLLOWING ARGUMENTS ARE USED BOTH FOR INPUT TO THIS
C ROUTINE, AND FOR OUTPUT TO CALLING PROGRAM.
C
C LOWBFR = INPUT CONTAINING SUBSCRIPT WITHIN IBUFFR
C ARRAY OF FIRST (LEFTMOST) CHARACTER WHICH
C CAN BE SCANNED FOR NUMBER SPECIFICATION.
C LOWBFR IS RETURNED POINTING TO NEXT
C CHARACTER WHICH WOULD BE INTERPRETED BY
C SUBSEQUENT CALL TO THIS ROUTINE IF THIS
C SUBSEQUENT CALL NEEDS TO EVALUATE FURTHER
C NUMBER SPECIFICATIONS. IF THERE ARE NO
C PRINTING CHARACTERS AT OR TO RIGHT OF
C IBUFFR(LOWBFR), BUT INTERPRETATION OF
C ADDITIONAL CHARACTERS IS ATTEMPTED, THEN
C LOWBFR WILL BE RETURNED CONTAINING MAXBFR+1.
C LOWBFR MUST BE RESET BY CALLING PROGRAM TO
C POINT TO FIRST CHARACTER IN IBUFFR ARRAY
C EACH TIME NEW LINE OF TEXT IS READ.
C
C KIND = INPUT CONTAINING -1, ERROR WAS DETECTED BY
C CALLING PROGRAM (RATHER THAN BY THIS
C ROUTINE) IN RESULTS RETURNED BY PREVIOUS
C CALL TO THIS ROUTINE AND ANY ADDITIONAL
C NUMBERS THROUGH NEXT APPEARANCE OF COMMA
C (UNLESS KONECT IS GREATER THAN 1) OR
C SEMICOLON OR AMPERSAND OR UNKNOWN CHARACTER
C OR END OF LINE ARE TO BE IGNORED. NEXT
C NUMBER TO RIGHT OF COMMA OR ON LINE
C FOLLOWING AMPERSAND OR END OF LINE IS TO BE
C INTERPRETED AS INDEX OF NEXT PAIR. UNKNOWN
C CHARACTER OR SEMICOLON IS REPORTED TO
C CALLING PROGRAM IF IT IS FOUND INSTEAD.
C = INPUT CONTAINING 0, THIS ROUTINE HAS NOT YET
C BEEN CALLED DURING EXECUTION OF CURRENT
C LOGICAL SECTION OF CALLING PROGRAM. THIS
C ROUTINE IS TO BEGIN EVALUATION OF CONTENTS
C OF INPUT TEXT BUFFER, NOT CONTINUE SEARCHING
C FOR VALUES ASSOCIATED WITH INDEX FOUND BY
C PREVIOUS CALL TO THIS ROUTINE. LOWBFR
C SHOULD POINT TO FIRST CHARACTER IN IBUFFR
C ARRAY TO BE INTERPRETED.
C = INPUT GREATER THAN ZERO, VALUE OF KIND
C INDICATES CONDITION RETURNED BY PREVIOUS
C CALL TO THIS ROUTINE AND IN MOST CASES HAS
C NOT BEEN MODIFIED BY CALLING PROGRAM. KIND
C BEING RETURNED WITH ONE OF VALUES 7, 8, 9 OR
C 10 (IF KONECT IS 2 OR 4) INDICATES THAT PAIR
C OF VALUES IS BEING RETURNED, ALTHOUGH EITHER
C OR BOTH MEMBERS OF PAIR COULD BE MISSING.
C OTHER VALUES OF KIND INDICATE SPECIAL
C CONDITIONS FOR WHICH PAIR OF NUMBERS IS NOT
C RETURNED.
C = 1, NOTHING, EXCEPT PERHAPS LEADING COMMAS OR
C ELSE COMMENT INDICATED BY LEADING
C EXCLAMATION POINT, WAS FOUND AT OR TO RIGHT
C OF IBUFFR(LOWBFR). CALLING PROGRAM SHOULD
C READ NEW LINE OF TEXT INTO IBUFFR.
C = 2, SEMICOLON WAS FOUND AS FIRST PRINTING
C CHARACTER AT OR TO RIGHT OF IBUFFR(LOWBFR).
C IF INDEX BUT NOT ASSOCIATED VALUE HAS BEEN
C FOUND WHEN SEMICOLON IS ENCOUNTERED, THEN
C INDEX IS REPORTED TO CALLING PROGRAM BEFORE
C SEMICOLON IS REPORTED. IT IS ASSUMED THAT
C CALLING PROGRAM WILL TREAT SEMICOLON AS
C MARKING END OF LOGICAL GROUP OF PAIR
C SPECIFICATIONS IF KONECT IS NOT GREATER THAN
C 1, OR END OF SINGLE PAIR SPECIFICATION IF
C KONECT IS GREATER THAN 1.
C = 3, AMPERSAND WAS FOUND WHILE SEARCHING FOR
C NEXT INDEX. LOWBFR IS RETURNED POINTING
C BEYOND END OF BUFFER. CALLING PROGRAM
C SHOULD READ NEW LINE OF TEXT INTO INPUT
C BUFFER BEFORE AGAIN CALLING THIS ROUTINE.
C THIS VALUE OF KIND IS NOT RETURNED IF
C AMPERSAND IS FOUND WHILE SEARCHING FOR
C ASSOCIATED VALUES.
C = 4, AMPERSAND WAS FOUND AFTER INDEX INSTEAD
C OF FIRST ASSOCIAED VALUE. CALLING PROGRAM
C SHOULD READ NEW LINE OF TEXT INTO BUFFER
C BEFORE AGAIN CALLING THIS ROUTINE.
C SUBSEQUENT CALL TO THIS ROUTINE WILL
C CONTINUE EVALUATION OF ASSOCIATED VALUES IN
C NEW CONTENTS OF BUFFER. IF SEMICOLON (OR
C COMMA IF KONECT IS NOT GREATER THAN 1) IS
C FOUND AT START OF NEW CONTENTS OF BUFFER,
C THEN INDEX VALUE WILL BE RETURNED TO CALLING
C PROGRAM BUT CALLING PROGRAM WILL BE INFORMED
C THAT ASSOCIATED VALUE IS MISSING. IF
C SUBSEQUENT CALL TO THIS ROUTINE IS INSTEAD
C TO BEGIN EVALUATION OF NEW SET OF LEADING
C INDEX AND ASSOCIATED VALUES, THEN CALLING
C PROGRAM SHOULD SET KIND TO 6 TO SIMULATE
C LACK OF AMPERSAND, CAUSING INDEX TO BE
C GENERATED, BUT MARKED AS HAVING MISSING
C ASSOCIATED VALUE. IF INDEX IS NOT WANTED,
C THEN KIND SHOULD BE SET TO ONE.
C = 5, PREVIOUS CALL HAS ALREADY RETURNED PAIR
C OF VALUES, BUT AMPERSAND WAS FOUND INSTEAD
C OF ANOTHER ASSOCIATED VALUE. CALLING
C PROGRAM SHOULD READ NEW LINE OF TEXT INTO
C BUFFER BEFORE AGAIN CALLING THIS ROUTINE.
C SUBSEQUENT CALL TO THIS ROUTINE WILL
C CONTINUE EVALUATION OF ASSOCIATED VALUES IN
C NEW CONTENTS OF BUFFER. SINCE INDEX HAS
C ALREADY BEEN RETURNED, NO ADDITIONAL MISSING
C VALUE WILL BE REPORTED IF SEMICOLON (OR
C COMMA IF KONECT IS NOT GREATER THAN 1) IS
C FOUND AT START OF NEW CONTENTS OF BUFFER.
C IF SUBSEQUENT CALL TO THIS ROUTINE IS ALWAYS
C TO BEGIN EVALUATION OF NEW PAIR OF VALUES,
C THEN CALLING PROGRAM SHOULD SET KIND TO ONE.
C = 6, END OF LINE WAS FOUND INSTEAD OF FIRST
C ASSOCIATED VALUE. IF KIND IS SENT UNCHANGED
C TO SUBSEQUENT CALL OF THIS ROUTINE, THEN
C INDEX WILL BE RETURNED TO CALLING PROGRAM,
C BUT CALLING PROGRAM WILL BE INFORMED THAT
C ASSOCIATED VALUE IS MISSING. IF SUBSEQUENT
C CALL TO THIS ROUTINE IS INSTEAD TO CONTINUE
C EVALUATION OF ASSOCIATED VALUES IN NEW
C CONTENTS OF BUFFER READ BY CALLING PROGRAM
C BEFORE THIS ROUTINE IS AGAIN CALLED, THEN
C KIND SHOULD BE SET TO 4 TO SIMULATE
C APPEARANCE OF AMPERSAND AT END OF PRECEDING
C LINE. IF INDEX IS NOT WANTED, THEN KIND
C SHOULD BE SET TO ONE.
C = 7, BOTH INDEX AND ASSOCIATED VALUE ARE BEING
C RETURNED TO CALLING PROGRAM.
C = 8, INDEX IS BEING RETURNED TO CALLING
C PROGRAM, BUT ASSOCIATED VALUE IS MISSING.
C NEWEND AND ENDNEW ARE RETURNED UNDEFINED.
C = 9, ASSOCIATED VALUE IS BEING RETURNED TO
C CALLING PROGRAM, BUT INDEX HAS ALREADY BEEN
C RETURNED BY PREVIOUS CALL. NEWBGN OR
C BGNNEW, WHICHEVER IS APPROPRIATE, IS
C RETURNED UNCHANGED (BUT CAN BE MODIFIED AS
C DESIRED BY CALLING PROGRAM).
C = 10, NEVER RETURNED IF KONECT=-1 OR 1.
C
C IF KONECT HAS EITHER OF VALUES 2 OR 4, PAIR
C OF VALUES HAS ALREADY BEEN RETURNED BY
C PREVIOUS CALL, BUT EXTRA COMMA WAS FOUND
C INDICATING MISSING ASSOCIATED VALUE. NEWBGN
C OR BGNNEW, WHICHEVER IS APPROPRIATE, IS
C RETURNED UNCHANGED (BUT CAN BE MODIFIED AS
C DESIRED BY CALLING PROGRAM).
C
C IF KONECT=0, THEN PAIR OF VALUES HAS ALREADY
C BEEN RETURNED BY PREVIOUS CALL, BUT
C FOLLOWING NUMBER WAS FOUND WHICH WAS NOT
C PRECEDED BY COMMA. KIND SHOULD BE SET TO -1
C BY CALLING PROGRAM BEFORE THIS ROUTINE IS
C CALLED NEXT IF LACK OF COMMA INDICATES
C SERIOUS ENOUGH ERROR THAT ALL NUMBERS SHOULD
C BE IGNORED UNTIL NEXT COMMA IS FOUND. IF
C KONECT=3, THEN PAIR OF VALUES HAS ALREADY
C BEEN RETURNED BY PREVIOUS CALL, BUT
C FOLLOWING NUMBER WAS FOUND WHICH WAS NOT
C PRECEDED BY SEMICOLON, BUT WHICH MAY OR MAY
C NOT HAVE BEEN PRECEDED BY ONE OR MORE
C COMMAS. KIND SHOULD BE SET TO -1 BY CALLING
C PROGRAM BEFORE THIS ROUTINE IS CALLED NEXT
C IF LACK OF SEMICOLON INDICATES SERIOUS
C ENOUGH ERROR THAT ALL NUMBERS SHOULD BE
C IGNORED UNTIL NEXT SEMICOLON IS FOUND. IF
C KONECT IS 0 OR 3, THEN LOWBFR IS RETURNED
C POINTING TO FIRST CHARACTER OF NUMBER
C SPECIFICATION, AND NUMBER WILL BE EVALUATED
C AS INDEX IF THIS ROUTINE IS CALLED AGAIN
C WITHOUT KIND HAVING BEEN CHANGED.
C = 11, UNKNOWN CHARACTER WAS FOUND. IF THIS
C APPEARS BEFORE FIRST ASSOCIATED VALUE, THEN
C INDEX IS REPORTED TO CALLING PROGRAM BEFORE
C UNKNOWN CHARACTER IS REPORTED. LOWBFR IS
C RETURNED POINTING TO NEXT CHARACTER TO RIGHT
C OF UNKNOWN CHARACTER. IF THIS ROUTINE IS
C CALLED WITHOUT CHANGING VALUE OF KIND, THEN
C NUMBER TO RIGHT OF UNKNOWN CHARACTER WILL BE
C INTERPRETED AS INDEX OF NEXT PAIR.
C
C NEWBGN = RETURNED CONTAINING NEXT VALUE OF INTEGER
C INDEX IF KIND IS RETURNED CONTAINING EITHER
C 7 OR 8 AND IF KNDBGN IS LESS THAN OR EQUAL
C TO ZERO. NEWBGN IS NOT CHANGED IF KIND IS
C RETURNED CONTAINING EITHER 9 OR 10. NEWBGN
C CAN BE CHANGED AS REQUIRED BY THE CALLING
C PROGRAM.
C
C NEWEND = RETURNED CONTAINING NEXT ASSOCIATED INTEGER
C VALUE IF KIND IS RETURNED CONTAINING EITHER
C 7 OR 9 AND IF KNDEND IS LESS THAN OR EQUAL
C TO ZERO. NEWEND CAN BE RETURNED CHANGED BY
C THIS ROUTINE EVEN IF ASSOCIATED VALUE IS NOT
C FOUND BUT THEN MUST NOT BE CHANGED BY
C CALLING PROGRAM. IF AMPERSAND OR END OF
C LINE IS FOUND INSTEAD OF ASSOCIATED VALUE,
C THEN NEWEND INDICATES TO SUBSEQUENT CALL
C WHETHER COMMA WAS FOUND BEFORE AMPERSAND OR
C END OF LINE.
C
C BGNNEW = RETURNED CONTAINING VALUE OF REAL INDEX IF
C KIND IS RETURNED CONTAINING EITHER 7 OR 8
C AND IF KNDBGN IS GREATER THAN ZERO. BGNNEW
C IS NOT CHANGED IF KIND IS RETURNED
C CONTAINING EITHER 9 OR 10. BGNNEW CAN BE
C CHANGED AS REQUIRED BY THE CALLING PROGRAM.
C
C ENDNEW = RETURNED CONTAINING NEXT ASSOCIATED REAL
C VALUE IF KIND IS RETURNED CONTAINING EITHER
C 7 OR 9 AND IF KNDEND IS GREATER THAN ZERO.
C
DIMENSION IBUFFR(MAXBFR)
DATA KOMENT,IEND,IAND,KOMMA,IBLANK,ITAB/
11H!,1H;,1H&,1H,,1H ,1H /
C
C TEST IF ARE CONTINUING PREVIOUSLY EVALUATED VALUES
MISSIN=0
IKNCT=KONECT
IF(IKNCT.GT.1)IKNCT=IKNCT-3
IF(KIND.LE.0)GO TO 21
IF(KIND.GT.10)GO TO 21
GO TO(21,21,21, 6, 4,32, 2, 1,10, 3),KIND
1 IF(NEWEND.LE.0)GO TO 21
2 KIND=9
3 IF(IKNCT.EQ.0)GO TO 21
GO TO 5
4 MISSIN=NEWEND
5 KIND=9
GO TO 10
6 MISSIN=NEWEND
7 KIND=7
GO TO 10
8 IF(KONECT.LE.1)GO TO 18
IF(MISSIN.GT.0)GO TO 31
MISSIN=1
9 LOWBFR=LOWBFR+1
10 IF(LOWBFR.GT.MAXBFR)GO TO 15
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.IBLANK)GO TO 9
IF(LETTER.EQ.ITAB)GO TO 9
IF(LETTER.EQ.KOMMA)GO TO 8
IF(LETTER.EQ.KOMENT)GO TO 14
IF(LETTER.EQ.IEND)GO TO 13
IF(LETTER.EQ.IAND)GO TO 11
C
C EVALUATE NEXT ASSOCIATED VALUE
CALL DAHEFT(KNDEND,1,0,IBUFFR,MAXBFR,
1LOWBFR,ITYPE,ISHIFT,JSHIFT,KSHIFT,LSHIFT,NEWEND,
2ENDNEW)
IF(ITYPE.EQ.3)GO TO 36
IF(KIND.EQ.7)GO TO 32
GO TO 35
C
C AMPERSAND FOUND INSTEAD OF ASSOCIATED VALUE
11 IF(KIND.EQ.7)GO TO 12
IF(IKNCT.GT.0)GO TO 25
GO TO 27
12 IF(IKNCT.GT.0)GO TO 32
GO TO 26
C
C SEMICOLON FOUND INSTEAD OF ASSSOCIATED VALUE
13 IF(KIND.EQ.7)GO TO 32
IF(MISSIN.GT.0)GO TO 34
GO TO 24
C
C NO ASSOCIATED VALUE FOUND
14 LOWBFR=MAXBFR+1
15 IF(KIND.EQ.7)GO TO 16
IF(MISSIN.GT.0)GO TO 34
GO TO 23
16 IF(IKNCT.GT.0)GO TO 32
GO TO 29
C
C COMMA FOUND INSTEAD OF ASSOCIATED VALUE
17 IF(KONECT.LE.1)GO TO 19
GO TO 20
18 IF(KIND.EQ.7)GO TO 32
19 KIND=7
C
C FIND NEXT PAIR OF SERIES
20 LOWBFR=LOWBFR+1
21 IF(LOWBFR.GT.MAXBFR)GO TO 23
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.IBLANK)GO TO 20
IF(LETTER.EQ.ITAB)GO TO 20
IF(LETTER.EQ.KOMMA)GO TO 17
IF(LETTER.EQ.KOMENT)GO TO 22
IF(LETTER.EQ.IEND)GO TO 24
IF(LETTER.EQ.IAND)GO TO 25
C
C OBTAIN LEADING VALUE
INIBFR=LOWBFR
CALL DAHEFT(KNDBGN,1,0,IBUFFR,MAXBFR,
1LOWBFR,ITYPE,ISHIFT,JSHIFT,KSHIFT,LSHIFT,NEWBGN,
2BGNNEW)
IF(ITYPE.NE.3)GO TO 35
IF(KIND.LT.0)GO TO 21
IF(KIND.NE.9)GO TO 7
LOWBFR=INIBFR
GO TO 34
C
C RETURN TO CALLING PROGRAM
22 LOWBFR=MAXBFR+1
23 KIND=1
GO TO 36
24 KIND=2
LOWBFR=LOWBFR+1
GO TO 36
25 KIND=3
LOWBFR=MAXBFR+1
GO TO 36
26 KIND=4
GO TO 28
27 KIND=5
28 LOWBFR=MAXBFR+1
GO TO 30
29 KIND=6
30 NEWEND=MISSIN
GO TO 36
31 IF(KIND.EQ.9)GO TO 34
NEWEND=1
GO TO 33
32 NEWEND=0
33 KIND=8
GO TO 36
34 KIND=10
GO TO 36
35 LOWBFR=LOWBFR+1
KIND=11
36 RETURN
C610242504579!;&
END
SUBROUTINE DAMISS(KONTRL,ITRAIL,IEXTRA,IBUFFR,MAXBFR,
1 LOWBFR,KIND ,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2 VALUE ,MANY ,LCNBFR,LCNERR)
C RENBR(/DELIMITER WRAPPER FOR DAHEFT)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAMISS EVALUATES NUMBERS, ALLOWS COMMAS BETWEEN
C NUMBERS, IDENTIFIES MISSING ITEMS INDICATED BY EXTRA
C COMMAS, SKIPS OVER ANY TEXT WHICH IS TO RIGHT OF
C EITHER EXCLAMATION POINT OR AMPERSAND, AND REPORTS
C ANY SEMICOLONS FOUND IN TEXT BEING EVALUATED.
C
C ARGUMENT LISTS OF DAMISS AND DAHEFT ARE IDENTICAL
C EXCEPT FOR ARGUMENTS MANY, LCNBFR AND LCNERR WHICH DO
C NOT APPEAR IN DAHEFT ARGUMENT LIST, AND EXCEPT THAT
C DAMISS CAN RETURN ARGUMENT NAMED KIND CONTAINING
C ADDITIONAL VALUES 4, 5, 6 AND 7. ARGUMENT NAMED MANY
C MUST BE SET TO ZERO BY CALLING PROGRAM BEFORE CALLING
C EITHER THIS ROUTINE OR ANY OF OTHER ROUTINES IN FASP
C PACKAGE (SUCH AS DANEXT, DASPAN AND DATEST) WHICH
C DEFINE THIS ARGUMENT IN SIMILAR MANNER. ARGUMENTS
C NAMED KIND AND LCNBFR ARE USED ONLY FOR OUTPUT TO
C CALLING PROGRAM AND THEIR INPUT VALUES ARE IGNORED.
C THESE ARGUMENTS ARE DESCRIBED BELOW. DOCUMENTATION
C OF DAHEFT SHOULD BE CONSULTED FOR DESCRIPTIONS OF
C REMAINING ARGUMENTS.
C
C KIND = 1, NOTHING, EXCEPT PERHAPS COMMENT INDICATED
C BY LEADING EXCLAMATION POINT, WAS FOUND AT
C OR TO RIGHT OF IBUFFR(LOWBFR). CALLING
C PROGRAM SHOULD READ NEW LINE INTO IBUFFR
C ARRAY BEFORE AGAIN CALLING THIS ROUTINE IF
C ADDITIONAL VALUES ARE REQUIRED. LOWBFR IS
C RETURNED POINTING BEYOND END OF BUFFER.
C MANY IS RETURNED SET TO ZERO. IVALUE AND
C VALUE ARE RETURNED UNDEFINED.
C = 2, FIRST PRINTING CHARACTER (OTHER THAN
C POSSIBLE COMMA IF MANY WAS INPUT GREATER
C THAN ZERO) IN OR TO RIGHT OF IBUFFR(LOWBFR)
C WAS NOT CHARACTER WHICH COULD BEGIN
C REPRESENTATION OF NUMBER AND WAS NOT COMMA,
C SEMICOLON, AMPERSAND OR EXCLAMATION POINT.
C LOWBFR IS RETURNED POINTING TO THIS PRINTING
C CHARACTER. IT IS EXPECTED THAT CALLING
C PROGRAM WILL OTHERWISE PROCESS THIS PRINTING
C CHARACTER SINCE DAMISS WOULD RETURN SAME
C RESULTS IF CALLED AGAIN WITH SAME VALUE OF
C LOWBFR AND WITH SAME BUFFER CONTENTS. MANY
C IS RETURNED CONTAINING ONE PLUS ITS INPUT
C ABSOLUTE VALUE. IVALUE AND VALUE ARE
C RETURNED UNDEFINED.
C = 3, NUMBER WAS FOUND WHICH WAS FOLLOWED BY A
C SPACE, TAB CHARACTER, COMMA, SEMICOLON,
C EXCLAMATION POINT OR AMPERSAND. MANY IS
C RETURNED CONTAINING ONE PLUS ITS INPUT
C ABSOLUTE VALUE. LOWBFR IS RETURNED POINTING
C TO CHARACTER TO RIGHT OF NUMBER
C REPRESENTATION.
C = 4, NUMBER WAS FOUND WHICH WAS FOLLOWED BY
C CHARACTER OTHER THAN SPACE, TAB CHARACTER,
C COMMA, SEMICOLON, EXCLAMATION POINT OR
C AMPERSAND. LCNBFR IS RETURNED POINTING IN
C BUFFER TO FIRST CHARACTER OF NUMBER. LOWBFR
C IS RETURNED POINTING IN BUFFER TO CHARACTER
C TO RIGHT OF NUMBER. LCNERR IS RETURNED
C POINTING IN BUFFER TO NEXT SPACE, TAB
C CHARACTER, COMMA, SEMICOLON, EXCLAMATION
C POINT OR AMPERSAND TO RIGHT OF NUMBER, OR IS
C RETURNED POINTING BEYOND END OF BUFFER IF NO
C SPACE, TAB CHARACTER, COMMA, SEMICOLON,
C EXCLAMATION POINT OR AMPERSAND IS FOUND TO
C RIGHT OF NUMBER. MANY IS RETURNED
C CONTAINING ONE PLUS ITS INPUT ABSOLUTE
C VALUE.
C = 5, SEMICOLON WAS FOUND AS FIRST PRINTING
C CHARACTER AT OR TO RIGHT OF IBUFFR(LOWBFR).
C LOWBFR IS RETURNED POINTING TO NEXT
C CHARACTER BEYOND SEMICOLON. IT IS ASSUMED
C THAT CALLING PROGRAM WILL TREAT APPEARANCE
C OF SEMICOLON AS MARKING END OF STATEMENT.
C MANY IS RETURNED SET TO ZERO. IVALUE AND
C VALUE ARE RETURNED UNDEFINED.
C = 6, AMPERSAND WAS FOUND AS FIRST PRINTING
C CHARACTER AT OR TO RIGHT OF LOWBFR. TEXT TO
C RIGHT OF AMPERSAND IS TAKEN AS COMMENT SO
C LOWBFR IS RETURNED POINTING BEYOND RIGHT END
C OF BUFFER. IT IS ASSUMED THAT CALLING
C PROGRAM WILL READ IN CONTENTS OF NEW BUFFER,
C THEN AGAIN REQUEST NEW NUMBER EVALUATION
C FROM THIS ROUTINE. VALUE OF MANY MUST NOT
C BE CHANGED BY CALLING PROGRAM PRIOR TO THIS
C FOLLOWING CALL. EFFECT IS NOT QUITE SAME AS
C IF USER HAD TYPED ALL OF TEXT ON SINGLE LINE
C SINCE SINGLE NUMBER CANNOT BE SPLIT ACROSS
C LINE BOUNDARY. IVALUE AND VALUE ARE RETURNED
C UNDEFINED.
C = 7, NUMBER WAS NOT FOUND, BUT EXTRA COMMA WAS
C FOUND INDICATING MISSING NUMBER. MANY IS
C RETURNED CONTAINING ONE PLUS ITS INPUT
C ABSOLUTE VALUE. IVALUE OR VALUE, WHICHEVER
C IS APPROPRIATE, IS RETURNED SET TO ZERO.
C
C MANY = SHOULD BE INPUT CONTAINING ZERO EACH TIME
C THIS ROUTINE IS CALLED TO BEGIN PROCESSING
C OF NEW LOGICAL SECTION OF TEXT, AS FOR
C EXAMPLE WHEN BEGINNING PROCESSING OF LINE OF
C TEXT NOT TIED TO PREVIOUS LINE BY AMPERSAND
C AT END OF PREVIOUS LINE, OR WHEN PROCESSING
C TEXT TO RIGHT OF SEMICOLON. INITIAL ZEROING
C OF THIS ARGUMENT MUST BE DONE BY CALLING
C PROGRAM, BUT THEREAFTER VALUE RETURNED BY
C PREVIOUS CALL TO THIS ROUTINE CAN USUALLY BE
C USED. MANY IS RETURNED SET TO ZERO EACH
C TIME SEMICOLON (KIND=5) IS FOUND, AND EACH
C TIME END OF LINE NOT TIED TO FOLLOWING LINE
C BY AMPERSAND (KIND=1) IS FOUND. MANY IS
C RETURNED CONTAINING ONE PLUS ITS INPUT
C ABSOLUTE VALUE EACH TIME NUMBER IS FOUND,
C EACH TIME UNKNOWN CHARACTER IS FOUND, OR
C EACH TIME INDICATION OF MISSING NUMBER IS
C FOUND. KIND IS RETURNED CONTAINING VALUE 6
C AND MANY IS RETURNED CONTAINING NEGATIVE OF
C NUMBER OF ITEMS FOUND IF NEXT PRINTING
C CHARACTER FOLLOWING COMMA IS AMPERSAND.
C MANY SHOULD NOT BE CHANGED BY CALLING
C PROGRAM IF AMPERSAND (KIND BEING RETURNED=6)
C IS FOUND INDICATING THAT SUBSEQUENT CALL TO
C THIS ROUTINE IS TO PROCESS TEXT WHICH IS TO
C BE TREATED AS THOUGH IT APPEARED IN PLACE OF
C AMPERSAND AND CHARACTERS TO ITS RIGHT.
C EFFECT IS NOT QUITE SAME AS IF USER HAD
C TYPED ALL OF TEXT ON SINGLE LINE SINCE
C SINGLE NUMBER CANNOT BE SPLIT ACROSS LINE
C BOUNDARY.
C
C IF MANY IS INPUT CONTAINING ZERO, THEN
C INITIAL COMMA IN INPUT TEXT BUFFER IS TAKEN
C TO INDICATE INITIAL MISSING ITEM, AND MANY
C IS THEN RETURNED CONTAINING 1. IF MANY IS
C INPUT GREATER THAN ZERO, THEN INITIAL COMMA
C IS IGNORED IF FOLLOWED BY NUMBER. IF MANY
C IS INPUT GREATER THAN ZERO, THEN INITIAL
C COMMA FOLLOWED BY NO OTHER PRINTING
C CHARACTERS, BY SEMICOLON, OR BY EXCLAMATION
C POINT INDICATES MISSING ITEM. IF MANY IS
C INPUT GREATER THAN ZERO, THEN INITIAL COMMA
C FOLLOWED BY AMPERSAND WILL CAUSE REMAINING
C CHARACTERS IN BUFFER TO BE IGNORED, AND MANY
C WILL BE RETURNED CONTAINING NEGATIVE OF ITS
C INPUT VALUE. IF MANY IS INPUT NEGATIVE,
C THEN IT IS ASSUMED THAT CONTENTS OF CURRENT
C BUFFER CONTINUE PREVIOUS LINE WHICH
C TERMINATED WITH COMMA FOLLOWED BY AMPERSAND,
C AND MANY IS RETURNED GREATER THAN ZERO.
C
C LCNBFR = IF NUMBER REPRESENTATION IS FOUND, KIND
C BEING RETURNED CONTAINING EITHER 3 OR 4,
C THEN LCNBFR IS RETURNED CONTAINING SUBSCRIPT
C OF IBUFFR ARRAY LOCATION WHICH CONTAINS
C FIRST (LEFTMOST) CHARACTER OF NUMBER
C REPRESENTATION. LCNBFR IS RETURNED UNDEFINED
C IF NUMBER REPRESENTATION IS NOT FOUND.
C
C LCNERR = IF KIND IS RETURNED SET TO 4 INDICATING THAT
C NUMBER WAS FOLLOWED BY PRINTING CHARACTER
C OTHER THAN COMMA, SEMICOLON, EXCLAMATION
C POINT OR AMPERSAND, THEN LCNERR CONTAINS
C SUBSCRIPT IN IBUFFR ARRAY OF LOCATION WHICH
C CONTAINS NEXT SPACE, TAB CHARACTER, COMMA,
C SEMICOLON, EXCLAMATION POINT OR AMPERSAND OR
C IS SET TO MAXBFR+1 IF NO ALLOWED DELIMITER
C CHARACTERS APPEARS TO RIGHT OF NUMBER.
C
DIMENSION IBUFFR(MAXBFR)
DATA KOMENT,IEND,IAND,KOMMA,ISPACE,ITAB/
11H!,1H;,1H&,1H,,1H ,1H /
KIND=1
IF(MANY.GE.0)GO TO 1
KIND=7
MANY=-MANY
1 IF(KONTRL.LE.0)IVALUE=0
IF(KONTRL.GT.0)VALUE=0.0
GO TO 3
C
C IDENTIFY NEXT CHARACTER
2 LOWBFR=LOWBFR+1
3 IF(LOWBFR.GT.MAXBFR)GO TO 9
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.ISPACE)GO TO 2
IF(LETTER.EQ.ITAB)GO TO 2
IF(LETTER.EQ.KOMENT)GO TO 8
IF(LETTER.EQ.IEND)GO TO 6
IF(LETTER.EQ.KOMMA)GO TO 5
IF(LETTER.EQ.IAND)GO TO 7
C
C TEST IF CHARACTER STARTS A NUMBER
LCNBFR=LOWBFR
CALL DAHEFT(KONTRL,ITRAIL,IEXTRA,IBUFFR,MAXBFR,
1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2VALUE)
LCNERR=LOWBFR
4 IF(LCNERR.GT.MAXBFR)GO TO 11
LETTER=IBUFFR(LCNERR)
IF(LETTER.EQ.ISPACE)GO TO 11
IF(LETTER.EQ.ITAB)GO TO 11
IF(LETTER.EQ.KOMENT)GO TO 11
IF(LETTER.EQ.IEND)GO TO 11
IF(LETTER.EQ.KOMMA)GO TO 11
IF(LETTER.EQ.IAND)GO TO 11
LCNERR=LCNERR+1
IF(KIND.EQ.3)KIND=4
GO TO 4
C
C TEST IF COMMA CAN PRECEDE A VALUE
5 IF(KIND.NE.1)GO TO 11
KIND=7
IF(MANY.EQ.0)GO TO 11
GO TO 2
C
C SEMICOLON FOUND
6 IF(KIND.NE.1)GO TO 11
LOWBFR=LOWBFR+1
KIND=5
GO TO 10
C
C AMPERSAND FOUND
7 IF(KIND.NE.1)MANY=-MANY
KIND=6
LOWBFR=MAXBFR+1
GO TO 12
C
C EXCLAMATION POINT FOUND
8 IF(KIND.NE.1)GO TO 11
LOWBFR=MAXBFR+1
GO TO 10
C
C END OF LINE FOUND
9 IF(KIND.NE.1)GO TO 11
C
C RETURN TO CALLING ROUTINE
10 MANY=0
GO TO 12
11 MANY=MANY+1
12 RETURN
C404203515168!;&
END
SUBROUTINE DALOSS(LOWWRD,MAXWRD,IWORD ,LOWKNT,MAXKNT,
1 KNTLTR,IBUFFR,MAXBFR,LOWBFR,KIND ,MATCH ,LCNWRD,
2 LCNKNT,LCNBFR,MANY ,LCNERR)
C RENBR(/DELIMITER WRAPPER FOR DAVERB)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DALOSS IDENTIFIES WORDS AND ABBREVIATIONS, ALLOWS
C COMMAS BETWEEN WORDS, IDENTIFIES MISSING ITEMS
C INDICATED BY EXTRA COMMAS, SKIPS OVER ANY TEXT WHICH
C IS TO RIGHT OF EITHER EXCLAMATION POINT OR AMPERSAND,
C AND REPORTS ANY SEMICOLONS FOUND IN TEXT BEING
C EVALUATED. IN ADDITION, DALOSS REPORTS WHETHER
C CHARACTER TO RIGHT OF WORD OR ITS ABBREVIATION IS
C CHARACTER OTHER THAN SPACE, TAB CHARACTER OR ALLOWED
C PUNCTUATION CHARACTER.
C
C ARGUMENT LISTS OF DALOSS AND DAVERB ARE IDENTICAL
C EXCEPT FOR DALOSS ARGUMENTS MANY AND LCNERR WHICH DO
C NOT APPEAR IN DAVERB ARGUMENT LIST, AND EXCEPT THAT
C DALOSS CAN RETURN ARGUMENT NAMED KIND CONTAINING
C ADDITIONAL VALUES 6 THROUGH 11. ARGUMENT NAMED MANY
C MUST BE SET TO ZERO BY CALLING PROGRAM BEFORE CALLING
C EITHER THIS ROUTINE OR ANY OF OTHER ROUTINES IN FASP
C PACKAGE (SUCH AS DAMISS, DANEXT AND DASPAN) WHICH
C DEFINE THIS ARGUMENT IN SIMILAR MANNER. ARGUMENTS
C NAMED KIND AND LCNERR ARE USED ONLY FOR OUTPUT TO
C CALLING PROGRAM AND THEIR INPUT VALUES ARE IGNORED.
C THESE ARGUMENTS ARE DESCRIBED BELOW. DOCUMENTATION
C OF DAVERB SHOULD BE CONSULTED FOR DESCRIPTIONS OF
C REMAINING ARGUMENTS.
C
C KIND = 1, NOTHING, EXCEPT PERHAPS COMMENT INDICATED
C BY LEADING EXCLAMATION POINT, WAS FOUND AT
C OR TO RIGHT OF IBUFFR(LOWBFR). CALLING
C PROGRAM SHOULD READ NEW LINE INTO IBUFFR
C ARRAY BEFORE AGAIN CALLING THIS ROUTINE IF
C ADDITIONAL WORDS ARE REQUIRED. LOWBFR IS
C RETURNED POINTING BEYOND END OF BUFFER.
C MANY IS RETURNED SET TO ZERO. MATCH IS
C RETURNED UNDEFINED.
C = 2, FIRST PRINTING CHARACTER (OTHER THAN
C POSSIBLE COMMA IF MANY WAS INPUT GREATER
C THAN ZERO) IN OR TO RIGHT OF IBUFFR(LOWBFR)
C DID NOT MATCH FIRST CHARACTER OF ANY WORD IN
C DICTIONARY AND WAS NOT COMMA, SEMICOLON,
C AMPERSAND OR EXCLAMATION POINT. LOWBFR IS
C RETURNED POINTING TO THIS PRINTING
C CHARACTER. IT IS EXPECTED THAT CALLING
C PROGRAM WILL OTHERWISE PROCESS THIS PRINTING
C CHARACTER SINCE DALOSS WOULD RETURN SAME
C RESULTS IF CALLED AGAIN WITH SAME VALUE OF
C LOWBFR, WITH SAME DICTIONARY AND WITH SAME
C BUFFER CONTENTS. MANY IS RETURNED
C CONTAINING ONE PLUS ITS INPUT ABSOLUTE
C VALUE. MATCH IS RETURNED UNDEFINED.
C = 3 OR 4 OR 5, SAME AS WHEN DAVERB RETURNS
C THESE VALUES, EXCEPT THAT IF THERE ARE
C ADDITIONAL CHARACTERS TO RIGHT OF WORD OR
C ITS ABBREVIATION, THEN CHARACTER TO
C IMMEDIATE RIGHT OF WORD OR ITS ABBREVIATION
C IS EITHER SPACE, TAB CHARACTER, COMMA,
C SEMICOLON, EXCLAMATION POINT OR AMPERSAND.
C MANY IS RETURNED CONTAINING ONE PLUS ITS
C INPUT ABSOLUTE VALUE. LOWBFR IS RETURNED
C POINTING TO CHARACTER TO RIGHT OF WORD OR
C ITS ABBREVIATION.
C = 3, WORD IN IWORD ARRAY WAS MATCHED EXACTLY.
C MATCH IS RETURNED CONTAINING SEQUENCE NUMBER
C OF WORD MATCHED IN IWORD ARRAY.
C = 4, NONAMBIGUOUS ABBREVIATION OF WORD IN
C IWORD ARRAY WAS FOUND. MATCH IS RETURNED
C CONTAINING SEQUENCE NUMBER OF WORD IN IWORD
C ARRAY.
C = 5, AMBIGUOUS ABBREVIATION OF WORD WAS FOUND.
C MATCH IS RETURNED CONTAINING SEQUENCE NUMBER
C OF FIRST WORD MATCHED IN IWORD ARRAY.
C = 6 OR 7 OR 8, SAME AS KIND RETURNED
C CONTAINING 3 OR 4 OR 5 RESPECTIVELY, EXCEPT
C THAT CHARACTER OTHER THAN SPACE, TAB
C CHARACTER, COMMA, SEMICOLON, EXCLAMATION
C POINT OR AMPERSAND APPEARED TO IMMEDIATE
C RIGHT OF WORD OR ITS ABBREVIATION. LCNBFR
C IS RETURNED POINTING IN BUFFER TO FIRST
C CHARACTER OF WORD OR ITS ABBREVIATION.
C LOWBFR IS RETURNED POINTING IN BUFFER TO
C CHARACTER TO RIGHT OF WORD OR ITS
C ABBREVIATION. LCNERR IS RETURNED POINTING
C IN BUFFER TO NEXT SPACE, TAB CHARACTER,
C COMMA, SEMICOLON, EXCLAMATION POINT OR
C AMPERSAND TO RIGHT OF WORD OR ITS
C ABBREVIATION, OR IS RETURNED POINTING BEYOND
C END OF BUFFER IF NO SPACE, TAB CHARACTER,
C COMMA, SEMICOLON, EXCLAMATION POINT OR
C AMPERSAND IS FOUND TO RIGHT OF WORD OR ITS
C ABBREVIATION. MANY IS RETURNED CONTAINING
C ONE PLUS ITS INPUT ABSOLUTE VALUE.
C = 9, SEMICOLON WAS FOUND AS FIRST PRINTING
C CHARACTER AT OR TO RIGHT OF IBUFFR(LOWBFR).
C LOWBFR IS RETURNED POINTING TO NEXT
C CHARACTER BEYOND SEMICOLON. IT IS ASSUMED
C THAT CALLING PROGRAM WILL TREAT APPEARANCE
C OF SEMICOLON AS MARKING END OF STATEMENT.
C MANY IS RETURNED SET TO ZERO. MATCH IS
C RETURNED UNDEFINED.
C = 10, AMPERSAND WAS FOUND AS FIRST PRINTING
C CHARACTER AT OR TO RIGHT OF LOWBFR. TEXT TO
C RIGHT OF AMPERSAND IS TAKEN AS COMMENT SO
C LOWBFR IS RETURNED POINTING BEYOND RIGHT END
C OF BUFFER. IT IS ASSUMED THAT CALLING
C PROGRAM WILL READ IN CONTENTS OF NEW BUFFER,
C THEN AGAIN REQUEST NEW WORD IDENTIFICATION
C FROM THIS ROUTINE. VALUE OF MANY MUST NOT
C BE CHANGED BY CALLING PROGRAM PRIOR TO THIS
C FOLLOWING CALL. EFFECT IS NOT QUITE SAME AS
C IF USER HAD TYPED ALL OF TEXT ON SINGLE LINE
C SINCE SINGLE WORD CANNOT BE SPLIT ACROSS
C LINE BOUNDARY. MATCH IS RETURNED UNDEFINED.
C = 11, WORD WAS NOT FOUND, BUT EXTRA COMMA WAS
C FOUND INDICATING MISSING WORD. MANY IS
C RETURNED CONTAINING ONE PLUS ITS INPUT
C ABSOLUTE VALUE. MATCH IS RETURNED
C UNDEFINED.
C
C MANY = SHOULD BE INPUT CONTAINING ZERO EACH TIME
C THIS ROUTINE IS CALLED TO BEGIN PROCESSING
C OF NEW LOGICAL SECTION OF TEXT, AS FOR
C EXAMPLE WHEN BEGINNING PROCESSING OF LINE OF
C TEXT NOT TIED TO PREVIOUS LINE BY AMPERSAND
C AT END OF PREVIOUS LINE, OR WHEN PROCESSING
C TEXT TO RIGHT OF SEMICOLON. INITIAL ZEROING
C OF THIS ARGUMENT MUST BE DONE BY CALLING
C PROGRAM, BUT THEREAFTER VALUE RETURNED BY
C PREVIOUS CALL TO THIS ROUTINE CAN USUALLY BE
C USED. MANY IS RETURNED SET TO ZERO EACH
C TIME SEMICOLON (KIND=9) IS FOUND, AND EACH
C TIME END OF LINE NOT TIED TO FOLLOWING LINE
C BY AMPERSAND (KIND=1) IS FOUND. MANY IS
C RETURNED CONTAINING ONE PLUS ITS INPUT
C ABSOLUTE VALUE EACH TIME WORD IS FOUND, EACH
C TIME UNKNOWN CHARACTER IS FOUND, OR EACH
C TIME INDICATION OF MISSING WORD IS FOUND.
C KIND IS RETURNED CONTAINING VALUE 10 AND
C MANY IS RETURNED CONTAINING NEGATIVE OF
C NUMBER OF ITEMS FOUND IF NEXT PRINTING
C CHARACTER FOLLOWING COMMA IS AMPERSAND.
C MANY SHOULD NOT BE CHANGED BY CALLING
C PROGRAM IF AMPERSAND (KIND BEING
C RETURNED=10) IS FOUND INDICATING THAT
C SUBSEQUENT CALL TO THIS ROUTINE IS TO
C PROCESS TEXT WHICH IS TO BE TREATED AS
C THOUGH IT APPEARED IN PLACE OF AMPERSAND AND
C CHARACTERS TO ITS RIGHT. EFFECT IS NOT
C QUITE SAME AS IF USER HAD TYPED ALL OF TEXT
C ON SINGLE LINE SINCE SINGLE WORD CANNOT BE
C SPLIT ACROSS LINE BOUNDARY.
C
C IF MANY IS INPUT CONTAINING ZERO, THEN
C INITIAL COMMA IN INPUT TEXT BUFFER IS TAKEN
C TO INDICATE INITIAL MISSING ITEM, AND MANY
C IS THEN RETURNED CONTAINING 1. IF MANY IS
C INPUT GREATER THAN ZERO, THEN INITIAL COMMA
C IS IGNORED IF FOLLOWED BY WORD. IF MANY IS
C INPUT GREATER THAN ZERO, THEN INITIAL COMMA
C FOLLOWED BY NO OTHER PRINTING CHARACTERS, BY
C SEMICOLON, OR BY EXCLAMATION POINT INDICATES
C MISSING ITEM. IF MANY IS INPUT GREATER THAN
C ZERO, THEN INITIAL COMMA FOLLOWED BY
C AMPERSAND WILL CAUSE REMAINING CHARACTERS IN
C BUFFER TO BE IGNORED, AND MANY WILL BE
C RETURNED CONTAINING NEGATIVE OF ITS INPUT
C VALUE. IF MANY IS INPUT NEGATIVE, THEN IT
C IS ASSUMED THAT CONTENTS OF CURRENT BUFFER
C CONTINUE PREVIOUS LINE WHICH TERMINATED WITH
C COMMA FOLLOWED BY AMPERSAND, AND MANY IS
C RETURNED GREATER THAN ZERO.
C
C LCNERR = IF KIND IS RETURNED SET TO 6, 7 OR 8
C INDICATING THAT WORD OR ITS ABBREVIATION WAS
C FOLLOWED BY PRINTING CHARACTER OTHER THAN
C COMMA, SEMICOLON, EXCLAMATION POINT OR
C AMPERSAND, THEN LCNERR CONTAINS SUBSCRIPT IN
C IBUFFR ARRAY OF LOCATION WHICH CONTAINS NEXT
C SPACE, TAB CHARACTER, COMMA, SEMICOLON,
C EXCLAMATION POINT OR AMPERSAND OR IS SET TO
C MAXBFR+1 IF NO ALLOWED DELIMITER CHARACTER
C APPEARS TO RIGHT OF WORD OR ITS ABBREVIATION
C
DIMENSION IBUFFR(MAXBFR),IWORD(MAXWRD),
1KNTLTR(MAXKNT)
DATA KOMENT,IEND,IAND,KOMMA,ISPACE,ITAB/
11H!,1H;,1H&,1H,,1H ,1H /
INIMNY=MANY
IF(MANY.LT.0)MANY=-MANY
C
C TEST IF CHARACTER STARTS A WORD
1 CALL DAVERB(LOWWRD,MAXWRD,IWORD ,LOWKNT,MAXKNT,
1 KNTLTR,IBUFFR,MAXBFR,LOWBFR,KIND ,MATCH ,LCNWRD,
2 LCNKNT,LCNBFR)
LCNERR=LOWBFR
IF(KIND.GT.2)GO TO 3
IF(KIND.EQ.1)GO TO 8
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.KOMENT)GO TO 7
IF(LETTER.EQ.IEND)GO TO 5
IF(LETTER.EQ.KOMMA)GO TO 4
IF(LETTER.EQ.IAND)GO TO 6
C
C IF MATCH FOUND, CHECK IF FOLLOWING CHARACTER IS LEGAL
2 LCNERR=LCNERR+1
IF(KIND.LE.2)GO TO 3
IF(KIND.LE.5)KIND=KIND+3
3 IF(LCNERR.GT.MAXBFR)GO TO 11
LETTER=IBUFFR(LCNERR)
IF(LETTER.EQ.ISPACE)GO TO 11
IF(LETTER.EQ.ITAB)GO TO 11
IF(LETTER.EQ.KOMENT)GO TO 11
IF(LETTER.EQ.IEND)GO TO 11
IF(LETTER.EQ.KOMMA)GO TO 11
IF(LETTER.EQ.IAND)GO TO 11
GO TO 2
C
C TEST IF COMMA CAN PRECEDE A VALUE
4 IF(INIMNY.LE.0)GO TO 10
INIMNY=-INIMNY
LOWBFR=LOWBFR+1
GO TO 1
C
C SEMICOLON FOUND
5 IF(INIMNY.LT.0)GO TO 10
LOWBFR=LOWBFR+1
KIND=9
GO TO 9
C
C AMPERSAND FOUND
6 IF(INIMNY.LT.0)MANY=INIMNY
KIND=10
LOWBFR=MAXBFR+1
GO TO 12
C
C EXCLAMATION POINT FOUND
7 IF(INIMNY.LT.0)GO TO 10
LOWBFR=MAXBFR+1
KIND=1
GO TO 9
C
C END OF LINE FOUND
8 IF(INIMNY.LT.0)GO TO 10
C
C RETURN TO CALLING ROUTINE
9 MANY=0
GO TO 12
10 KIND=11
11 MANY=MANY+1
12 RETURN
C408421442172!;&
END
SUBROUTINE DARANK(INCRES,IFTEST,MINMUM,MAXMUM,MINSTR,
1 MAXSTR,IBUFFR,MAXBFR,LOWBFR,KIND ,MAXUSD,ISTORE)
C RENBR(/RETURNS SORTED INTEGERS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DARANK RETURNS A GROUP OF INTEGERS SORTED INTO EITHER
C INCREASING OR DECREASING ORDER. DUPLICATES ARE NOT
C RETURNED. NUMBERS CAN BE SPECIFIED IN SLASH
C NOTATION.
C
C INCRES = 1, RETURN VALUES IN ISTORE SORTED INTO
C DECREASING ORDER. IF MORE VALUES ARE FOUND
C THAN CAN BE RETURNED IN ISTORE ARRAY, THEN
C SMALLER VALUES ARE DISCARDED.
C = 2, RETURN VALUES IN ISTORE SORTED INTO
C DECREASING ORDER. IF MORE VALUES ARE FOUND
C THAN CAN BE RETURNED IN ISTORE ARRAY, THEN
C LARGER VALUES ARE DISCARDED.
C = 3, RETURN VALUES IN ISTORE SORTED INTO
C INCREASING ORDER. IF MORE VALUES ARE FOUND
C THAN CAN BE RETURNED IN ISTORE ARRAY, THEN
C SMALLER VALUES ARE DISCARDED.
C = 4, RETURN VALUES IN ISTORE SORTED INTO
C INCREASING ORDER. IF MORE VALUES ARE FOUND
C THAN CAN BE RETURNED IN ISTORE ARRAY, THEN
C LARGER VALUES ARE DISCARDED.
C IFTEST = -2 OR 2, THERE ARE NO MINIMUM AND MAXIMUM
C LIMITS TO RANGE OF LEGAL VALUES.
C = -1, REJECT VALUES LESS THAN MINMUM.
C = 0, REJECT VALUES LESS THAN MINMUM OR GREATER
C THAN MAXMUM.
C = 1, REJECT VALUES GREATER THAN MAXMUM.
C MINMUM = LOWER LIMIT OF ALLOWED VALUES IF IFTEST IS
C -1 OR 0. VALUES LESS THAN MINMUM ARE NOT
C RETURNED IN ISTORE IF IFTEST IS -1 OR 0.
C MAXMUM = UPPER LIMIT OF ALLOWED VALUES IF IFTEST IS 0
C OR 1. VALUES GREATER THAN MAXMUM ARE NOT
C RETURNED IN ISTORE IF IFTEST IS 0 OR 1.
C MINSTR = SUBSCRIPT OF LOWEST LOCATION IN ISTORE ARRAY
C INTO WHICH VALUE CAN BE PLACED.
C MAXSTR = SUBSCRIPT OF HIGHEST LOCATION IN ISTORE
C ARRAY INTO WHICH VALUE CAN BE PLACED.
C IBUFFR = INPUT TEXT BUFFER CONTAINING 1 CHARACTER PER
C ARRAY LOCATION AS READ BY MULTIPLE OF A1
C FORMAT.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY LOCATION
C TO BE SEARCHED FOR CHARACTERS.
C LOWBFR = INPUT CONTAINING SUBSCRIPT OF IBUFFR ARRAY
C LOCATION CONTAINING FIRST CHARACTER TO BE
C TESTED. LOWBFR IS RETURNED CONTAINING
C SUBSCRIPT OF IBUFFR ARRAY LOCATION
C CONTAINING NEXT CHARACTER NOT YET EVALUATED.
C KIND = SHOULD BE INPUT CONTAINING ZERO (OR ONE)
C WHENEVER THIS ROUTINE IS CALLED TO GENERATE
C NEW GROUP OF SORTED NUMBERS. KIND IS
C RETURNED DESCRIBING REASON FOR RETURN TO
C CALLING PROGRAM. IF KIND IS RETURNED
C CONTAINING VALUE OF 3 OR GREATER, AND IS
C SENT TO SUBSEQUENT CALL UNCHANGED, THEN
C MAXUSD IS NOT RESET TO MINSTR-1, AND NEW
C VALUES ARE APPENDED TO OLD CONTENTS, IF ANY,
C OF ISTORE.
C = 1, RETURNED EITHER IF NO PRINTING CHARACTERS
C ARE FOUND BEYOND NUMBERS, OR IF EXCLAMATION
C POINT IS NEXT CHARACTER BEYOND NUMBERS.
C LOWBFR IS RETURNED POINTING BEYOND END OF
C BUFFER.
C = 2, RETURNED IF SEMICOLON WAS FOUND AS NEXT
C PRINTING CHARACTER BEYOND NUMBERS. LOWBFR
C IS RETURNED POINTING TO NEXT CHARACTER
C BEYOND SEMICOLON.
C = 3, RETURNED IF AMPERSAND WAS FOUND AS NEXT
C PRINTING CHARACTER BEYOND NUMBERS. LOWBFR
C IS RETURNED POINTING BEYOND END OF BUFFER.
C = 4, RETURNED IF UNKNOWN CHARACTER WAS FOUND
C AS NEXT PRINTING CHARACTER BEYOND NUMBERS.
C LOWBFR IS RETURNED POINTING TO THIS UNKNOWN
C CHARACTER. LOWBFR MUST BE INCREMENTED BY
C CALLING PROGRAM BEFORE THIS ROUTINE IS NEXT
C CALLED.
C = 5, ILLEGAL SERIES SPECIFICATION WAS FOUND.
C LOWBFR IS RETURNED POINTING TO NEXT
C CHARACTER BEYOND SERIES SPECIFICATION.
C MAXUSD = RETURNED CONTAINING SUBSCRIPT OF HIGHEST
C LOCATION IN ISTORE USED TO RETURN SORTED
C VALUES.
C ISTORE = ARRAY USED TO RETURN SORTED VALUES IN
C ISTORE(MINSTR) THROUGH AND INCLUDING
C ISTORE(MAXUSD).
C
DIMENSION IBUFFR(MAXBFR),ISTORE(MAXSTR)
JNCRES=INCRES-2
MANY=0
MINTST=IFTEST
IF(MINTST.LT.-1)MINTST=1
MAXTST=IFTEST
IF(MAXTST.GT.1)MAXTST=-1
IF(KIND.LT.3)MAXUSD=MINSTR-1
1 KIND=0
2 CALL DANEXT(0,0.0,IBUFFR,MAXBFR,LOWBFR,
1MANY,KIND,NEWVAL,INCVAL,LMTVAL,VALNEW,VALINC,
2VALLMT)
GO TO(34,34,34,2,3,1,1,33,32),KIND
C
C TEST IF NEW VALUE IS IN REGION BEING DISCARDED
3 GO TO(5,4,5,4),INCRES
4 IF(INCVAL.GE.0)GO TO 7
LEFT=(NEWVAL-LMTVAL)/(-INCVAL)
GO TO 6
5 IF(INCVAL.LE.0)GO TO 7
LEFT=(LMTVAL-NEWVAL)/INCVAL
6 IF(LEFT.LE.0)GO TO 7
LMTVAL=NEWVAL
NEWVAL=NEWVAL+LEFT*INCVAL
INCVAL=-INCVAL
7 IF(MINTST.GT.0)GO TO 8
IF(NEWVAL.GE.MINMUM)GO TO 8
IF(INCVAL.LE.0)GO TO 1
LEFT=(MINMUM-NEWVAL-1)/INCVAL
GO TO 9
8 IF(MAXTST.LT.0)GO TO 10
IF(NEWVAL.LE.MAXMUM)GO TO 10
IF(INCVAL.GE.0)GO TO 1
LEFT=(NEWVAL-MAXMUM-1)/(-INCVAL)
9 IF(LEFT.GT.0)NEWVAL=NEWVAL+(LEFT*INCVAL)
GO TO 2
10 IF(MAXUSD.LT.MAXSTR)GO TO 15
IF(MAXSTR.LT.MINSTR)GO TO 1
GO TO(11,12,13,14),INCRES
11 IF(NEWVAL.LE.ISTORE(MAXUSD))GO TO 1
GO TO 15
12 IF(NEWVAL.GE.ISTORE(MINSTR))GO TO 1
GO TO 15
13 IF(NEWVAL.LE.ISTORE(MINSTR))GO TO 1
GO TO 15
14 IF(NEWVAL.GE.ISTORE(MAXUSD))GO TO 1
C
C TEST IF NEW VALUE IS ALREADY KNOWN
15 MIDDLE=MINSTR-1
IF(MAXUSD.LT.MINSTR)GO TO 22
IUPPER=MAXUSD
16 ILOWER=MIDDLE+1
GO TO 18
17 IUPPER=MIDDLE-1
18 IHALF=(IUPPER-ILOWER)/2
MIDDLE=IUPPER-IHALF
IF(NEWVAL.EQ.ISTORE(MIDDLE))GO TO 31
IF(JNCRES.GT.0)GO TO 19
IF(NEWVAL.LT.ISTORE(MIDDLE))GO TO 21
GO TO 20
19 IF(NEWVAL.GT.ISTORE(MIDDLE))GO TO 21
20 IF(IHALF.GT.0)GO TO 17
IF(IUPPER.LE.ILOWER)GO TO 23
IUPPER=ILOWER
GO TO 18
21 IF(IHALF.GT.0)GO TO 16
C
C SHIFT REST OF ARRAY AND INSERT NEW VALUE
22 MIDDLE=MIDDLE+1
23 IF(MAXUSD.LT.MAXSTR)GO TO 25
GO TO(24,28,28,24),INCRES
24 IF(MIDDLE.GT.MAXSTR)GO TO 31
GO TO 26
25 MAXUSD=MAXUSD+1
26 I=MAXUSD
27 IF(I.LE.MIDDLE)GO TO 30
ISTORE(I)=ISTORE(I-1)
I=I-1
GO TO 27
28 IF(MIDDLE.LE.MINSTR)GO TO 31
MIDDLE=MIDDLE-1
I=MINSTR
29 IF(I.GE.MIDDLE)GO TO 30
ISTORE(I)=ISTORE(I+1)
I=I+1
GO TO 29
30 ISTORE(MIDDLE)=NEWVAL
31 IF(INCVAL.EQ.0)GO TO 1
GO TO 2
32 KIND=4
LOWBFR=LOWBFR-1
GO TO 34
33 KIND=5
34 RETURN
C689599426999
END
SUBROUTINE DANEXT(KONTRL,SLACK ,IBUFFR,MAXBFR,LOWBFR,
1 MANY ,KIND ,NEWVAL,INCVAL,LMTVAL,VALNEW,VALINC,
2 VALLMT)
C RENBR(/RETURNS NEXT NUMBER IN SERIES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DANEXT RETURNS TO THE CALLING PROGRAM THE NEXT NUMBER
C REPRESENTED BY THE CHARACTERS IN AN INPUT BUFFER READ
C BY THE CALLING PROGRAM WITH A MULTIPLE OF AN A1
C FORMAT. IF A SERIES SPECIFICATION IS ENCOUNTERED IN
C THE INPUT BUFFER, THEN THE INDIVIDUAL NUMBERS OF THE
C SERIES ARE RETURNED BY THE CALLS TO THIS ROUTINE.
C WHEN ALL OF THE NUMBERS FORMING THE SERIES HAVE BEEN
C RETURNED, THEN THE SUBSEQUENT NUMBER OR SERIES OF
C NUMBERS SPECIFIED BY THE CONTENTS OF THE BUFFER ARE
C EVALUATED.
C
C A SERIES EVALUATED BY THIS ROUTINE CAN BE WRITTEN AS
C A LOWER BOUND, INCREMENT AND UPPER BOUND SEPARATED BY
C SLASHES. IF THE INCREMENT IS TO BE ONE, THEN THE
C LOWER AND UPPER BOUNDS NEED BE SEPARATED ONLY BY A
C SINGLE SLASH. IF EITHER BOUND IS MISSING, IT IS
C ASSUMED TO BE ZERO. THE LOWER BOUND IS THE FIRST
C NUMBER OF THE SERIES REPORTED TO THE CALLING PROGRAM.
C THE SERIES CAN THEN EITHER INCREASE OR DECREASE
C DEPENDING UPON WHETHER THE UPPER BOUND IS LESS THAN,
C EQUAL TO, OR GREATER THAN THE LOWER BOUND. THE SIGN
C OF THE INCREMENT IS CHANGED IF IT DOES NOT CONFORM TO
C THE RELATIVE VALUES OF THE BOUNDS.
C
C IF THE SERIES IS TO CONSIST OF SEVERAL REPETITIONS OF
C THE SAME VALUE, THEN THE SERIES IS INSTEAD WRITTEN AS
C THE NUMBER OF TIMES THE VALUE IS TO BE USED FOLLOWED
C IMMEDIATELY BY AN ASTERISK AND THE VALUE ITSELF. THE
C VALUE TO BE REPEATED IS ASSUMED TO BE NULL IF IT IS
C MISSING.
C
C TWO VERSIONS OF THE ROUTINE ARE SUPPLIED. DANEXT CAN
C EVALUATE REAL NUMBERS AS WELL AS INTEGERS INCLUDING
C E, K AND M NOTATIONS FOR SPECIFYING EITHER OF THESE.
C IF THE CALLING PROGRAM DOES NOT OTHERWISE REFERENCE
C THE FREE FORMAT INPUT ROUTINE DAREAD, IF THE
C EVALUATION OF REAL NUMBERS IS NOT NEEDED, AND IF
C INTEGERS CAN BE SPECIFIED WITHOUT RESORTING TO THE E,
C K AND M NOTATIONS, THEN THE ROUTINE DAINXT SHOULD BE
C USED INSTEAD OF DANEXT. NUMBERS EVALUATED BY DAINXT
C MUST CONSIST ONLY OF DIGITS FOLLOWING THE OPTIONAL
C SIGN. DAINXT TREATS THE CHARACTERS ., %, K AND M THE
C SAME AS ANY OTHER DELIMITER CHARACTER.
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY AND ARE
C RETURNED UNCHANGED.
C
C KONTRL = 1 OR GREATER, ITEM IN IBUFFR ARRAY IS
C FLOATING POINT. IF POSSIBLE, THE FLOATING
C POINT NUMBER WILL BE ACCUMULATED AS AN
C INTEGER, THEN BE CONVERTED TO FLOATING POINT
C AND SHIFTED IF NECESSARY. KONTRL IS THEN
C THE MAXIMUM NUMBER OF DIGITS IN THE INTEGER.
C THE VALUE IS OUTPUT AS THE ARGUMENT VALNEW.
C IF THE ITEM HAS MORE THAN KONTRL DIGITS,
C THEN THE ENTIRE EVALUATION IS DONE IN
C FLOATING POINT. THE ADVANTAGE OF
C CALCULATING THE FLOATING POINT VALUES IN
C INTEGER AS LONG AS THE PRECISION OF THE
C COMPUTER IS NOT OVERFLOWED IS THAT THE
C CALCULATION OF THE PORTION OF THE NUMBER
C RIGHT OF THE DECIMAL POINT IS MORE EXACT.
C AS AN EXAMPLE, IF KONTRL IS GREATER THAN OR
C EQUAL TO 4, THEN THE NUMBER 33.33 CAN BE
C STORED AS THE INTEGER 3333, THEN BE
C CONVERTED TO FLOATING POINT VALUE 3333.0 AND
C DIVIDED BY 100.0 TO OBTAIN THE FINAL
C ANSWER. IF IT MAKES NO DIFFERENCE WHETHER
C THE NUMBER TYPED AS 33.33 HAS VALUE 33.33 OR
C 33.32999... THEN KONTRL CAN BE GIVEN THE
C VALUE 1.
C = 0, ITEM IN IBUFFR ARRAY IS INTEGER DECIMAL.
C THE NUMBER CAN BE TYPED WITH A DECIMAL POINT
C (FOR EXAMPLE 1.23K OR 1.23E3 EQUALS 1230),
C BUT IS STORED AS AN INTEGER IN DAREAD, AND
C IS OUTPUT AS ARGUMENT NEWVAL. ANY DECIMAL
C INTEGER WHICH THE COMPUTER CAN REPRESENT CAN
C BE EVALUATED. THIS INCLUDES, ON TWOS
C COMPLEMENT COMPUTERS, THE LARGEST NEGATIVE
C NUMBER THE ABSOLUTE VALUE OF WHICH CANNOT BE
C STORED. ON THE PDP10, A 36 BIT COMPUTER
C WITH TWOS COMPLEMENT NOTATION, THE RANGE OF
C DECIMAL INTEGERS IS -34359738368 THROUGH
C 34359738367 (OCTAL NOTATION OF BIT PATTERNS
C BEING 400000000000 THROUGH 377777777777).
C = -1, ITEM IN IBUFFR ARRAY IS OCTAL. THE
C NUMBER CAN BE TYPED WITH A DECIMAL POINT
C AND/OR WITH AN EXPONENT. HOWEVER, THE
C NUMBER FOLLOWING THE LETTER E OF THE
C EXPONENT IS EVALUATED IN DECIMAL. THE VALUE
C OF THE OCTAL NUMBER IS RETURNED AS THE
C ARGUMENT NEWVAL. IT MUST BE NOTED THAT
C NUMBERS EVALUATED AS NEGATIVE OCTAL INTEGERS
C HAVE THE NEGATIVE OCTAL INTEGER AS THEIR
C VALUE, NOT AS THEIR BIT REPRESENTATION IN
C COMPUTER STORAGE. FOR EXAMPLE, ON A 36 BIT
C TWOS COMPLEMENT COMPUTER, THE OCTAL NUMBER
C -400000000000 (WHICH COULD ALSO BE TYPED AS
C -4E11 OR -4E+11 WHERE THE 11 AFTER THE E IS
C IN DECIMAL) IS REPRESENTED AS BIT PATTERN
C HAVING OCTAL NOTATION 400000000000 AND THE
C OCTAL NUMBER -377777777777 IS REPRESENTED BY
C THE BIT PATTERN 400000000001.
C SLACK = THE FRACTION OF THE INCREMENT, IF
C KONTRL.GT.0, BY WHICH THE RETURNED VALUE OF
C THE ARGUMENT NAMED VALNEW CAN EXCEED THE
C UPPPER BOUND AND STILL BE CONSIDERED TO BE
C WITHIN THE SERIES. SLACK IS NECESSARY
C BECAUSE OF THE IMPRECISION OF CALCULATIONS
C INVOLVING REAL NUMBERS. FOR EXAMPLE, IF THE
C USER WISHED TO HAVE THE INCREMENT BE
C 0.666.... BETWEEN A LOWER BOUND OF 3.0 AND
C AN UPPER BOUND OF 5.0, HE MIGHT TYPE
C 3/.667/5 AND EXPECT THAT THE NUMBERS 3.000,
C 3.667, 4.333, AND 5.000 WOULD BE INCLUDED
C WITHIN THE SERIES, WHILE, ACTUALLY, THE
C NUMBER NEAR 5.00 WOULD BE CALCULATED TO BE
C 5.001 AND WOULD THEREFORE BE OUTSIDE THE
C SERIES. ALTHOUGH SLACK CAN BE SET TO ZERO,
C A VALUE OF ABOUT 0.01 IS RECOMMENDED. IN
C THE ABOVE EXAMPLE, SLACK=0.01 WOULD CAUSE
C THE ACTUAL UPPER BOUND TO BE 5.00667 SO THAT
C THE NUMBER CALCULATED NEAR THE UPPER BOUND
C WOULD BE INCLUDED WITHIN THE SERIES. SLACK
C SHOULD ALMOST CERTAINLY NEVER EXCEED 0.5
C SINCE LARGER VALUES WOULD OFTEN LEAD TO THE
C INCLUSION OF VALUES NOT MEANT BY THE USER.
C SLACK IS IGNORED IF KONTRL.LE.0.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY A MULTIPLE OF AN A1
C FORMAT, WHICH IS TO BE SEARCHED FOR SERIES
C SPECIFICATIONS. IBUFFR THEN CONTAINS ONE
C CHARACTER PER COMPUTER STORAGE LOCATION.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY TO BE
C SEARCHED
C
C FOLLOWING ARGUMENTS ARE USED AS BOTH INPUT AND OUTPUT
C
C LOWBFR = INPUT CONTAINING THE SUBSCRIPT WITHIN THE
C IBUFFR ARRAY OF THE FIRST (LEFTMOST)
C CHARACTER WHICH CAN BE SCANNED FOR A SERIES
C SPECIFICATION. LOWBFR IS RETURNED UNCHANGED
C IF THIS CALL TO THIS ROUTINE MERELY
C GENERATES THE NEXT MEMBER OF A SERIES BEGUN
C BY A PREVIOUS CALL. IF A NEW SERIES
C SPECIFICATION IS EVALUATED BY THIS CALL TO
C THIS ROUTINE, THEN LOWBFR WILL BE RETURNED
C POINTING TO THE NEXT CHARACTER BEYOND THE
C SERIES SPECIFICATION. IF A SECOND NUMBER
C IMMEDIATELY FOLLOWS A FIRST WITHOUT A
C SEPARATING SLASH OR ASTERISK, THEN LOWBFR
C WILL BE RETURNED POINTING TO THE FIRST
C CHARACTER OF THE SECOND NUMBER. IF EITHER A
C SPACE OR A TAB CHARACTER FOLLOWS A SERIES
C SPECIFICATION, THEN LOWBFR WILL BE RETURNED
C POINTING TO THE SPACE OR TAB CHARACTER. IF
C THERE IS NOTHING AT OR TO RIGHT OF LOWBFR,
C THEN LOWBFR WILL BE LEFT POINTING AT
C MAXBFR+1 AND KIND WILL BE RETURNED
C CONTAINING ONE. LOWBFR AND MANY MUST BE SET
C BY THE CALLING PROGRAM BEFORE ANYTHING IS
C PROCESSED IN THE CURRENT CONTENTS OF THE
C IBUFFR ARRAY, BUT THEN SHOULD NOT BE
C MODIFIED BY THE CALLING PROGRAM UNTIL THE
C ENTIRE CONTENTS OF THE IBUFFR ARRAY HAS BEEN
C PROCESSED.
C MANY = SHOULD BE INPUT CONTAINING ZERO EACH TIME
C THIS ROUTINE IS CALLED TO BEGIN PROCESSING
C OF A NEW LOGICAL SECTION OF TEXT, AS FOR
C EXAMPLE WHEN BEGINNING PROCESSING OF A LINE
C OF TEXT NOT TIED TO THE PREVIOUS LINE BY AN
C AMPERSAND AT THE END OF THE PREVIOUS LINE,
C OR WHEN PROCESSING THE TEXT TO THE RIGHT OF
C A SEMICOLON. MANY IS RETURNED SET TO ZERO
C WHENEVER AN END OF LINE (KIND=1) IS FOUND
C WHICH IS NOT TIED TO THE FOLLOWING LINE BY
C AN AMPERSAND, AND WHENEVER A SEMICOLON IS
C FOUND (KIND=2). MANY IS RETURNED INCREMENTED
C BY 1 EACH TIME A NEW SPECIFICATION OF EITHER
C A SINGLE NUMBER OR OF A SERIES IS FOUND,
C EACH TIME AN ERRONEOUS SERIES SPECIFICATION
C IS FOUND, OR EACH TIME AN INDICATION OF A
C MISSING SERIES SPECIFICATION IS FOUND. MANY
C IS RETURNED UNCHANGED IF THIS CALL TO THIS
C ROUTINE MERELY GENERATES THE NEXT MEMBER OF
C A SERIES ALREADY BEGUN BY A PREVIOUS CALL TO
C THIS ROUTINE. KIND IS RETURNED CONTAINING
C THE VALUE 3 AND MANY IS RETURNED CONTAINING
C THE NEGATIVE OF THE NUMBER OF ITEMS FOUND IF
C THE NEXT PRINTING CHARACTER FOLLOWING A
C COMMA IS AN AMPERSAND. MANY SHOULD NOT BE
C CHANGED BY THE CALLING PROGRAM IF AN
C AMPERSAND (KIND BEING RETURNED=3) IS FOUND
C INDICATING THAT THE SUBSEQUENT CALL TO THIS
C ROUTINE IS TO PROCESS TEXT WHICH IS TO BE
C TREATED AS THOUGH IT APPEARED IN PLACE OF
C THE AMPERSAND AND THE CHARACTERS TO ITS
C RIGHT. THE EFFECT IS NOT QUITE THE SAME AS
C IF THE USER HAD TYPED ALL OF THE TEXT ON A
C SINGLE LINE SINCE A SINGLE SERIES
C SPECIFICATION CANNOT BE SPLIT ACROSS THE
C LINE BOUNDARY.
C
C IF MANY IS INPUT CONTAINING ZERO, THEN AN
C INITIAL COMMA IN THE INPUT TEXT BUFFER IS
C TAKEN TO INDICATE AN INITIAL MISSING ITEM,
C AND MANY IS THEN RETURNED CONTAINING 1. IF
C MANY IS INPUT GREATER THAN ZERO, THEN AN
C INITIAL COMMA IS IGNORED IF FOLLOWED BY A
C SERIES SPECIFICATION. IF MANY IS INPUT
C GREATER THAN ZERO, THEN AN INITIAL COMMA
C FOLLOWED BY NO OTHER PRINTING CHARACTERS, BY
C A SEMICOLON, OR BY AN EXCLAMATION POINT
C INDICATES A MISSING ITEM. IF MANY IS INPUT
C GREATER THAN ZERO, THEN AN INITIAL COMMA
C FOLLOWED BY AN AMPERSAND WILL CAUSE THE
C REMAINING CHARACTERS IN THE BUFFER TO BE
C IGNORED, AND MANY WILL BE RETURNED
C CONTAINING THE NEGATIVE OF ITS INPUT VALUE.
C IF MANY IS INPUT NEGATIVE, THEN IT IS
C ASSUMED THAT THE CONTENTS OF THE CURRENT
C BUFFER CONTINUE A PREVIOUS LINE WHICH
C TERMINATED WITH A COMMA FOLLOWED BY AN
C AMPERSAND, AND MANY IS RETURNED GREATER THAN
C ZERO.
C KIND = SHOULD BE INPUT CONTAINING ZERO THE FIRST
C TIME THIS ROUTINE IS CALLED, OR TO ABANDON
C GENERATATION OF VALUES WITHIN A PARTICULAR
C SERIES. KIND IS RETURNED DESCRIBING THE
C KIND OF ITEM LOCATED IN THE IBUFFR ARRAY.
C = 1, NOTHING, EXCEPT PERHAPS COMMENT INDICATED
C BY A LEADING EXCLAMATION POINT, WAS FOUND AT
C OR TO RIGHT OF LOWBFR. THE CALLING PROGRAM
C SHOULD READ A NEW LINE INTO IBUFFR. MANY IS
C RETURNED SET TO ZERO.
C = 2, A SEMICOLON WAS FOUND AS THE FIRST
C PRINTING CHARACTER AT OR TO THE RIGHT OF
C LOWBFR. LOWBFR IS RETURNED POINTING TO THE
C NEXT CHARACTER BEYOND THE LOCATION OF THE
C SEMICOLON. IT IS ASSUMED THE CALLING
C PROGRAM WILL TREAT THE APPEARANCE OF THE
C SEMICOLON AS MARKING THE END OF A STATEMENT.
C MANY IS RETURNED SET TO ZERO.
C = 3, AN AMPERSAND WAS FOUND AS THE FIRST
C PRINTING CHARACTER AT OR TO THE RIGHT OF
C LOWBFR. THE TEXT TO THE RIGHT OF THE
C AMPERSAND IS TAKEN AS A COMMENT SO LOWBFR IS
C RETURNED POINTING BEYOND THE RIGHT END OF
C THE BUFFER. IT IS ASSUMED THAT THE CALLING
C PROGRAM WILL READ IN THE CONTENTS OF A NEW
C BUFFER, THEN AGAIN REQUEST A NEW SERIES
C EVALUATION FROM THIS ROUTINE. THE VALUE OF
C MANY MUST NOT BE CHANGED BY CALLING PROGRAM
C PRIOR TO THIS FOLLOWING CALL. THE EFFECT IS
C NOT QUITE THE SAME AS IF THE USER HAD TYPED
C ALL OF THE TEXT ON A SINGLE LINE SINCE A
C SERIES SPECIFICATION CANNOT BE SPLIT ACROSS
C A LINE BOUNDARY.
C = 4, A NUMBER OR SERIES SPECIFICATION WAS NOT
C FOUND, BUT A COMMA WAS FOUND INDICATING
C A MISSING SERIES SPECIFICATION. EITHER
C NEWVAL OR VALNEW IS RETURNED CONTAINING THE
C VALUE ZERO SO KIND=4 CAN BE CONSIDERED
C EQUIVALENT TO KIND=5 IF SUCH IS APPROPRIATE
C TO THE APPLICATION FOR WHICH THIS ROUTINE IS
C BEING USED.
C = 5, THE NEXT NUMBER SPECIFIED BY THE CONTENTS
C OF THE INPUT BUFFER IS BEING RETURNED AS THE
C VALUE OF THE ARGUMENT NEWVAL OR VALNEW.
C = 6, A SERIES WAS SPECIFIED IN ASTERISK
C NOTATION, BUT NO NUMBER APPEARED TO RIGHT OF
C THE ASTERISK. VALNEW OR NEWVAL, WHICHEVER IS
C APPROPRIATE, IS RETURNED WITH VALUE ZERO.
C NOTE THAT IF A NUMBER DOES NOT PRECEDE THE
C ASTERISK, THEN KIND IS RETURNED WITH THE
C VALUE 7 WHETHER OR NOT A NUMBER FOLLOWS THE
C ASTERISK.
C = 7, A SERIES WAS SPECIFIED IN ASTERISK
C NOTATION, BUT NO NUMBER APPEARED TO THE LEFT
C OF THE ASTERISK OR THE NUMBER TO LEFT OF THE
C ASTERISK WAS LESS THAN 1 (OR LESS THAN 0.5
C IF EVALUATED AS A REAL NUMBER AS THIS NUMBER
C IS ROUNDED WHEN USED). A NUMBER MAY OR MAY
C NOT HAVE APPEARED TO RIGHT OF THE ASTERISK.
C = 8, A SERIES SPECIFICATION WAS FOUND WHICH
C CONTAINED TOO MANY NUMBERS, TOO MANY
C ASTERISKS OR TOO MANY SLASHES.
C = 9, FIRST PRINTING CHARACTER IN OR TO RIGHT
C OF LOWBFR WAS NOT A CHARACTER WHICH COULD
C APPEAR IN A NUMBER OR NUMBER RANGE, AND WAS
C NOT A COMMA, SEMICOLON OR EXCLAMATION POINT.
C LOWBFR IS RETURNED POINTING TO THE NEXT
C CHARACTER BEYOND THIS CHARACTER.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT
C
C NEWVAL = RETURNED CONTAINING NEW VALUE IF KONTRL.LE.0
C AND KIND RETURNED =5.
C VALNEW = RETURNED CONTAINING NEW VALUE IF KONTRL.GT.0
C AND KIND RETURNED =5.
C
C INCVAL, LMTVAL, VALINC AND VALLMT MUST BE PRESERVED
C FROM ONE CALL TO NEXT BUT NOT USED BY CALLING PROGRAM
C
DIMENSION IBUFFR(MAXBFR)
C
IF(KIND.EQ.6)GO TO 4
IF(KIND.NE.5)GO TO 6
IF(INCVAL.EQ.0)GO TO 4
C
C GET NEXT NUMBER EXPRESSED IN SLASH NOTATION
IF(KONTRL.GT.0)GO TO 2
NEWVAL=NEWVAL+INCVAL
IF(INCVAL.GT.0)GO TO 1
IF(NEWVAL.GE.LMTVAL)GO TO 22
GO TO 6
1 IF(NEWVAL.LE.LMTVAL)GO TO 22
GO TO 6
2 VALOLD=VALNEW
VALNEW=VALNEW+VALINC
IF(VALINC.GT.0.0)GO TO 3
IF(VALNEW.GE.VALOLD)GO TO 6
IF(VALNEW.GE.(VALLMT+(SLACK*VALINC)))GO TO 22
GO TO 6
3 IF(VALNEW.LE.VALOLD)GO TO 6
IF(VALNEW.LE.(VALLMT+(SLACK*VALINC)))GO TO 22
GO TO 6
C
C GET NEXT NUMBER EXPRESSED IN ASTERISK NOTATION
4 IF(KONTRL.GT.0)GO TO 5
LMTVAL=LMTVAL-1
IF(LMTVAL.GT.0)GO TO 22
GO TO 6
5 VALLMT=VALLMT-1.0
IF(VALLMT.GT.0.5)GO TO 22
C
C GET NEW RANGE SPECIFICATION
6 CALL DASPAN(KONTRL,-1,IBUFFR,MAXBFR,LOWBFR,
1MANY,KIND,INIGOT,INCGOT,LMTGOT,NEWVAL,INCVAL,
2LMTVAL,VALNEW,VALINC,VALLMT)
GO TO(9,9,9,9,7,7,13,19,8,8),KIND
C
C SINGLE NUMBER WITHOUT SLASH OR ASTERISK
7 IF(KONTRL.GT.0)GO TO 12
GO TO 10
8 KIND=KIND-1
9 IF(KONTRL.GT.0)GO TO 11
NEWVAL=0
10 LMTVAL=0
GO TO 21
11 VALNEW=0.0
12 VALINC=0.0
VALLMT=0.0
GO TO 21
C
C SERIES CONTAINING SLASH
13 KIND=5
IF(KONTRL.GT.0)GO TO 16
IF(INIGOT.LE.0)NEWVAL=0
IF(INCGOT.LE.0)INCVAL=1
IF(INCVAL.EQ.0)INCVAL=1
IF(LMTGOT.LE.0)LMTVAL=0
IF(NEWVAL.GT.LMTVAL)GO TO 14
IF(INCVAL.GT.0)GO TO 22
GO TO 15
14 IF(INCVAL.LT.0)GO TO 22
15 INCVAL=-INCVAL
GO TO 22
16 INCVAL=1
IF(INIGOT.LE.0)VALNEW=0.0
IF(INCGOT.LE.0)VALINC=1.0
IF(VALINC.EQ.0)VALINC=1.0
IF(LMTGOT.LE.0)VALLMT=0.0
IF(VALNEW.GT.VALLMT)GO TO 17
IF(VALINC.GT.0)GO TO 22
GO TO 18
17 IF(VALINC.LT.0)GO TO 22
18 VALINC=-VALINC
GO TO 22
C
C SERIES CONTAINING ASTERISK
19 KIND=5
IF(LMTGOT.LE.0)KIND=6
IF(KONTRL.GT.0)GO TO 20
IF(INIGOT.LE.0)NEWVAL=0
IF(LMTGOT.LE.0)LMTVAL=0
IF(NEWVAL.LE.0)KIND=7
INCVAL=NEWVAL
NEWVAL=LMTVAL
LMTVAL=INCVAL
GO TO 21
20 IF(INIGOT.LE.0)VALNEW=0.0
IF(LMTGOT.LE.0)VALLMT=0.0
IF(VALNEW.LE.0.5)KIND=7
VALINC=VALNEW
VALNEW=VALLMT
VALLMT=VALINC
VALINC=0.0
21 INCVAL=0
C
C RETURN TO CALLING PROGRAM
22 RETURN
C602332267874
END
SUBROUTINE DASPAN(KONTRL,KONECT,IBUFFR,MAXBFR,LOWBFR,
1 MANY ,KIND ,INIGOT,INCGOT,LMTGOT,INIVAL,INCVAL,
2 LMTVAL,VALINI,VALINC,VALLMT)
C RENBR(/INTERPRETS FREE FORMAT RANGE SPECIFICATIONS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DASPAN EVALUATES RANGE SPECIFICATIONS TYPED BY THE
C USER AND READ BY THE CALLING PROGRAM WITH A MULTIPLE
C OF AN A1 FORMAT. SUCH RANGE SPECIFICATIONS CAN
C CONSIST OF A SINGLE NUMBER, OR OF 2 NUMBERS SEPARATED
C BY AN ASTERISK, OR OF EITHER 2 OR 3 NUMBERS SEPARATED
C BY SLASHES OR BY COLONS WHICH ARE TAKEN AS EQUIVALENT
C TO SLASHES. THE ASTERISK NOTATION IS MEANT TO
C INDICATE THAT THE VALUE TO THE RIGHT OF THE ASTERISK
C IS TO BE REPEATED THE NUMBER OF TIMES INDICATED BY
C THE NUMBER TO THE LEFT OF THE ASTERISK. NUMBERS
C SPECIFIED IN THE SLASH NOTATION CAN BE INTERPRETED AS
C THE LOWER AND UPPER BOUNDS OF A RANGE IF 2 NUMBERS
C ARE PRESENT, OR AS THE LOWER BOUND, THE INCREMENT,
C AND THE UPPER BOUND, IF 3 NUMBERS ARE INCLUDED.
C
C DASPAN REPORTS TO THE CALLING PROGRAM WHETHER THE
C NUMBERS ARE PRESENT IN THE SERIES SPECIFICATION, AS
C WELL AS THE VALUES OF THOSE NUMBERS WHICH ARE
C PRESENT. THE CALLING PROGRAM WILL HAVE TO ASSIGN
C DEFAULT VALUES FOR ANY NUMBERS WHICH ARE MISSING.
C THE RANGE SPECIFICATION /2/10 INDICATES THAT THE
C RANGE IS TO EXTEND FROM THE DEFAULT LOWER BOUND WITH
C AN INCRMENT OF 2 THROUGH THE UPPER BOUND OF 10.
C EITHER RANGE SPECIFICATION 1/10 OR 1//10 IS TAKEN TO
C MEAN THAT THE RANGE IS TO EXTEND FROM 1 THROUGH 10
C WITH THE DEFAULT INCREMENT. IF THE NUMBERS SPECIFY
C THE VALUES OF A SUBSCRIPT OF AN ARRAY, THEN A MISSING
C LOWER BOUND MIGHT BE TAKEN TO INDICATE THAT THE
C SUBSCRIPT BEING VARIED STARTS AT ITS MINIMUM POSSIBLE
C VALUE (USUALLY 1), WHILE A MISSING UPPER BOUND MIGHT
C INDICATE THAT THE SUBSCRIPT IS TO TERMINATE AT ITS
C MAXIMUM POSSIBLE VALUE.
C
C TWO VERSIONS OF THE ROUTINE ARE SUPPLIED. DASPAN CAN
C EVALUATE REAL NUMBERS AS WELL AS INTEGERS INCLUDING
C E, K AND M NOTATIONS FOR SPECIFYING EITHER OF THESE.
C IF THE CALLING PROGRAM DOES NOT OTHERWISE REFERENCE
C THE FREE FORMAT INPUT ROUTINE DAHEFT, IF THE
C EVALUATION OF REAL NUMBERS IS NOT NEEDED, AND IF
C INTEGERS CAN BE SPECIFIED WITHOUT RESORTING TO THE E,
C K AND M NOTATIONS, THEN THE ROUTINE DAISPN SHOULD BE
C USED INSTEAD OF DASPAN. NUMBERS EVALUATED BY DAISPN
C MUST CONSIST ONLY OF DIGITS FOLLOWING THE OPTIONAL
C SIGN. DAISPN TREATS THE CHARACTERS ., %, K AND M THE
C SAME AS ANY OTHER DELIMITER CHARACTER.
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY AND ARE
C RETURNED UNCHANGED.
C
C KONTRL = 1 OR GREATER, ITEM IN IBUFFR ARRAY IS
C FLOATING POINT. IF POSSIBLE, THE FLOATING
C POINT NUMBER WILL BE ACCUMULATED AS AN
C INTEGER, THEN BE CONVERTED TO FLOATING POINT
C AND SHIFTED IF NECESSARY. KONTRL IS THEN
C THE MAXIMUM NUMBER OF DIGITS IN THE INTEGER.
C THE VALUE IS OUTPUT AS THE ARGUMENT VALUE.
C IF THE ITEM HAS MORE THAN KONTRL DIGITS,
C THEN THE ENTIRE EVALUATION IS DONE IN
C FLOATING POINT. THE ADVANTAGE OF
C CALCULATING THE FLOATING POINT VALUES IN
C INTEGER AS LONG AS THE PRECISION OF THE
C COMPUTER IS NOT OVERFLOWED IS THAT THE
C CALCULATION OF THE PORTION OF THE NUMBER
C RIGHT OF THE DECIMAL POINT IS MORE EXACT.
C AS AN EXAMPLE, IF KONTRL IS GREATER THAN OR
C EQUAL TO 4, THEN THE NUMBER 33.33 CAN BE
C STORED AS THE INTEGER 3333, THEN BE
C CONVERTED TO FLOATING POINT VALUE 3333.0 AND
C DIVIDED BY 100.0 TO OBTAIN THE FINAL
C ANSWER. IF IT MAKES NO DIFFERENCE WHETHER
C THE NUMBER TYPED AS 33.33 HAS VALUE 33.33 OR
C 33.32999... THEN KONTRL CAN BE GIVEN THE
C VALUE 1.
C = 0, ITEM IN IBUFFR ARRAY IS INTEGER DECIMAL.
C THE NUMBER CAN BE TYPED WITH A DECIMAL POINT
C (FOR EXAMPLE 1.23K OR 1.23E3 EQUALS 1230),
C BUT IS STORED AS AN INTEGER IN DAHEFT, AND
C IS OUTPUT AS ARGUMENT IVALUE. ANY DECIMAL
C INTEGER WHICH THE COMPUTER CAN REPRESENT CAN
C BE EVALUATED. THIS INCLUDES, ON TWOS
C COMPLEMENT COMPUTERS, THE LARGEST NEGATIVE
C NUMBER THE ABSOLUTE VALUE OF WHICH CANNOT BE
C STORED. ON THE PDP10, A 36 BIT COMPUTER
C WITH TWOS COMPLEMENT NOTATION, THE RANGE OF
C DECIMAL INTEGERS IS -34359738368 THROUGH
C 34359738367 (OCTAL NOTATION OF BIT PATTERNS
C BEING 400000000000 THROUGH 377777777777).
C = -1, ITEM IN IBUFFR ARRAY IS OCTAL. THE
C NUMBER CAN BE TYPED WITH A DECIMAL POINT
C AND/OR WITH AN EXPONENT. HOWEVER, THE
C NUMBER FOLLOWING THE LETTER E OF THE
C EXPONENT IS EVALUATED IN DECIMAL. THE VALUE
C OF THE OCTAL NUMBER IS RETURNED AS THE
C ARGUMENT IVALUE. IT MUST BE NOTED THAT
C NUMBERS EVALUATED AS NEGATIVE OCTAL INTEGERS
C HAVE THE NEGATIVE OCTAL INTEGER AS THEIR
C VALUE, NOT AS THEIR BIT REPRESENTATION IN
C COMPUTER STORAGE. FOR EXAMPLE, ON A 36 BIT
C TWOS COMPLEMENT COMPUTER, THE OCTAL NUMBER
C -400000000000 (WHICH COULD ALSO BE TYPED AS
C -4E11 OR -4E+11 WHERE THE 11 AFTER THE E IS
C IN DECIMAL) IS REPRESENTED AS BIT PATTERN
C HAVING OCTAL NOTATION 400000000000 AND THE
C OCTAL NUMBER -377777777777 IS REPRESENTED BY
C THE BIT PATTERN 400000000001.
C KONECT = -1, ONCE A SLASH, AN ASTERISK OR A NUMBER IS
C FOUND IN THE IBUFFR ARRAY, THE SERIES
C SPECIFICATION WILL EXTEND TO THE NEXT SPACE
C OR TAB CHARACTER, OR TO ANY CHARACTER OTHER
C THAN A SLASH OR AN ASTERISK WHICH IMMEDITELY
C FOLLOWS A NUMBER IN THE SERIES
C SPECIFICATION. IF KONECT=-1, THEN THE TEXT
C 1/2+3/4 5/6+7/+8
C WOULD CONTAIN THE RANGE SPECIFICATIONS 1 TO
C 2, 3 TO 4, 5 TO 6, AND 7 TO 8.
C = 0, SPACES CAN APPEAR BETWEEN THE NUMBERS OF
C A SERIES IN ADDITION TO SLASHES OR ASTERISK.
C THE SLASHES OR THE ASTERISK ARE, HOWEVER,
C REQUIRED.
C = 1, SPACES AND/OR TAB CHARACTERS CAN APPEAR
C BETWEEN THE NUMBERS OF A SERIES IN ADDITION
C TO OR IN PLACE OF SLASHES OR ASTERISKS. IF
C KONECT=1, THEN THE TEXT
C 1 2 3,4/5 6,7 8/9,10 / 11 12
C IS EXACTLY EQUIVALENT, EXCEPT FOR THE VALUE
C OF KIND RETURNED FOR THE FIRST SERIES, TO
C THE TEXT
C 1/2/3,4/5/6,7/8/9,10/11/12
C THE FIRST SERIES (1 2 3) IN THE FIRST
C EXAMPLE WOULD RETURN KIND=6 INDICATING A
C SERIES IN WHICH NEITHER A SLASH NOR AN
C ASTERISK APPEARED, WHILE THE CORRESPONDING
C SERIES SPECIFICATION IN THE SECOND EXAMPLE
C WOULD RETURN KIND=7 INDICATING THAT AT LEAST
C 1 SLASH WAS ENCOUNTERED IN THE SERIES
C SPECIFICATION.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY A MULTIPLE OF AN A1
C FORMAT, WHICH IS TO BE SEARCHED FOR SERIES
C SPECIFICATIONS. IBUFFR THEN CONTAINS ONE
C CHARACTER PER COMPUTER STORAGE LOCATION.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY TO BE
C SEARCHED
C
C FOLLOWING ARGUMENTS ARE USED AS BOTH INPUT AND OUTPUT
C
C LOWBFR = INPUT CONTAINING THE SUBSCRIPT WITHIN THE
C IBUFFR ARRAY OF THE FIRST (LEFTMOST)
C CHARACTER WHICH CAN BE SCANNED FOR A SERIES
C SPECIFICATION. LOWBFR WILL BE RETURNED
C POINTING TO THE NEXT CHARACTER BEYOND THE
C SERIES SPECIFICATION. IF KONECT IS .LE.0
C FORCING A SERIES SPECIFICATION TO CONTAIN
C EITHER A SLASH OR AN ASTERISK BETWEEN THE
C NUMBERS OF A SERIES, AND IF A SECOND NUMBER
C IMMEDIATELY FOLLOWS A FIRST WITHOUT A
C SEPARATING SLASH OR ASTERISK, THEN LOWBFR
C WILL BE RETURNED POINTING TO THE FIRST
C CHARACTER OF THE SECOND NUMBER. IF KONECT
C IS -1 AND IF EITHER A SPACE OR A TAB
C CHARACTER FOLLOWS A SERIES SPECIFICATION,
C THEN LOWBFR WILL BE RETURNED POINTING TO THE
C SPACE OR TAB CHARACTER. IF KONECT IS .GE.0,
C ALLOWING SPACES AND TAB CHARACTERS TO APPEAR
C WITHIN A SERIES SPECIFICATION, THEN LOWBFR
C WILL BE RETURNED POINTING TO THE FIRST
C CHARACTER TO THE RIGHT OF THE SERIES AND
C WHICH IS NOT ITSELF A SPACE, A TAB CHRACTER,
C A SLASH OR AN ASTERISK AND WHICH CANNOT
C APPEAR WITHIN A NUMBER. IF THERE IS NOTHING
C AT OR TO RIGHT OF LOWBFR, THEN LOWBFR WILL
C BE LEFT POINTING AT MAXBFR+1 AND KIND WILL
C BE RETURNED CONTAINING ONE. LOWBFR AND MANY
C MUST BE SET BY THE CALLING PROGRAM BEFORE
C ANYTHING IS PROCESSED IN THE CURRENT
C CONTENTS OF THE IBUFFR ARRAY, BUT THEN
C SHOULD NOT BE MODIFIED BY THE CALLING
C PROGRAM UNTIL THE ENTIRE CONTENTS OF THE
C IBUFFR ARRAY HAS BEEN PROCESSED.
C MANY = SHOULD BE INPUT CONTAINING ZERO EACH TIME
C THIS ROUTINE IS CALLED TO BEGIN PROCESSING
C OF A NEW LOGICAL SECTION OF TEXT, AS FOR
C EXAMPLE WHEN BEGINNING PROCESSING OF A LINE
C OF TEXT NOT TIED TO THE PREVIOUS LINE BY AN
C AMPERSAND AT THE END OF THE PREVIOUS LINE,
C OR WHEN PROCESSING THE TEXT TO THE RIGHT OF
C A SEMICOLON. MANY IS RETURNED SET TO ZERO
C WHENEVER AN END OF LINE (KIND=1) IS FOUND
C WHICH IS NOT TIED TO THE FOLLOWING LINE BY
C AN AMPERSAND, AND WHENEVER A SEMICOLON IS
C FOUND (KIND=2). MANY IS RETURNED INCREMENTED
C BY 1 EACH TIME A DESCRIPTION OF A SERIES
C SPECIFICATION IS RETURNED BY THIS ROUTINE,
C EACH TIME AN ERRONEOUS SERIES SPECIFICATION
C IS FOUND, OR EACH TIME AN INDICATION OF A
C MISSING SERIES SPECIFICATION IS FOUND. KIND
C IS RETURNED CONTAINING THE VALUE 3 AND MANY
C IS RETURNED CONTAINING THE NEGATIVE OF THE
C NUMBER OF ITEMS FOUND IF THE NEXT PRINTING
C CHARACTER FOLLOWING A COMMA IS AN AMPERSAND.
C MANY SHOULD NOT BE CHANGED BY THE CALLING
C PROGRAM IF AN AMPERSAND (KIND BEING
C RETURNED=3) IS FOUND INDICATING THAT THE
C SUBSEQUENT CALL TO THIS ROUTINE IS TO
C PROCESS TEXT WHICH IS TO BE TREATED AS
C THOUGH IT APPEARED IN PLACE OF THE AMPERSAND
C AND THE CHARACTERS TO ITS RIGHT. THE EFFECT
C IS NOT QUITE THE SAME AS IF THE USER HAD
C TYPED ALL OF THE TEXT ON A SINGLE LINE SINCE
C A SINGLE SERIES SPECIFICATION CANNOT BE
C SPLIT ACROSS THE LINE BOUNDARY.
C
C IF MANY IS INPUT CONTAINING ZERO, THEN AN
C INITIAL COMMA IN THE INPUT TEXT BUFFER IS
C TAKEN TO INDICATE AN INITIAL MISSING ITEM,
C AND MANY IS THEN RETURNED CONTAINING 1. IF
C MANY IS INPUT GREATER THAN ZERO, THEN AN
C INITIAL COMMA IS IGNORED IF FOLLOWED BY A
C SERIES SPECIFICATION. IF MANY IS INPUT
C GREATER THAN ZERO, THEN AN INITIAL COMMA
C FOLLOWED BY NO OTHER PRINTING CHARACTERS, BY
C A SEMICOLON, OR BY AN EXCLAMATION POINT
C INDICATES A MISSING ITEM. IF MANY IS INPUT
C GREATER THAN ZERO, THEN AN INITIAL COMMA
C FOLLOWED BY AN AMPERSAND WILL CAUSE THE
C REMAINING CHARACTERS IN THE BUFFER TO BE
C IGNORED, AND MANY WILL BE RETURNED
C CONTAINING THE NEGATIVE OF ITS INPUT VALUE.
C IF MANY IS INPUT NEGATIVE, THEN IT IS
C ASSUMED THAT THE CONTENTS OF THE CURRENT
C BUFFER CONTINUE A PREVIOUS LINE WHICH
C TERMINATED WITH A COMMA FOLLOWED BY AN
C AMPERSAND, AND MANY IS RETURNED GREATER THAN
C ZERO.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT
C
C KIND = RETURNED DESCRIBING THE KIND OF ITEM LOCATED
C IN THE IBUFFR ARRAY.
C = 1, EITHER NO PRINTING CHARACTERS OR ELSE AN
C EXCLAMATION POINT AS THE FIRST PRINTING
C CHARACTER (MARKING THE REST OF THE LINE AS A
C COMMENT) WAS FOUND AT OR TO THE RIGHT OF
C LOWBFR. THE CALLING PROGRAM SHOULD READ A
C NEW LINE INTO IBUFFR. MANY, INIGOT, INCGOT
C AND LMTGOT ARE ALL RETURNED WITH VALUE ZERO.
C = 2, A SEMICOLON WAS FOUND AS THE FIRST
C PRINTING CHARACTER AT OR TO THE RIGHT OF
C LOWBFR. LOWBFR IS RETURNED POINTING TO THE
C NEXT CHARACTER BEYOND THE LOCATION OF THE
C SEMICOLON. IT IS ASSUMED THE CALLING
C PROGRAM WILL TREAT THE APPEARANCE OF THE
C SEMICOLON AS MARKING THE END OF A STATEMENT.
C MANY IS RETURNED WITH THE VALUE ZERO.
C = 3, AN AMPERSAND WAS FOUND AS THE FIRST
C PRINTING CHARACTER AT OR TO THE RIGHT OF
C LOWBFR. THE TEXT TO THE RIGHT OF THE
C AMPERSAND IS TAKEN AS A COMMENT SO LOWBFR IS
C RETURNED POINTING BEYOND THE RIGHT END OF
C THE BUFFER. IT IS ASSUMED THAT THE CALLING
C PROGRAM WILL READ IN THE CONTENTS OF A NEW
C BUFFER, THEN AGAIN REQUEST A NEW SERIES
C EVALUATION FROM THIS ROUTINE. THE VALUE OF
C MANY MUST NOT BE CHANGED BY CALLING PROGRAM
C PRIOR TO THIS FOLLOWING CALL. THE EFFECT IS
C NOT QUITE THE SAME AS IF THE USER HAD TYPED
C ALL OF THE TEXT ON A SINGLE LINE SINCE A
C SERIES SPECIFICATION CANNOT BE SPLIT ACROSS
C A LINE BOUNDARY.
C = 4, A NUMBER OR SERIES SPECIFICATION WAS NOT
C FOUND BUT INITIAL COMMA WAS FOUND INDICATING
C A MISSING SERIES SPECIFICATION. INIGOT,
C INCGOT AND LMTGOT ARE EACH RETURNED WITH THE
C VALUE ZERO SO KIND=4 CAN BE CONSIDERED
C EQUIVALENT TO KIND=5 IF SUCH IS APPROPRIATE
C TO THE APPLICATION FOR WHICH THIS ROUTINE IS
C BEING USED.
C = 5, A SINGLE NUMBER WITH NEITHER A SLASH NOR
C AN ASTERISK WAS FOUND IN THE INPUT BUFFER.
C BOTH INIGOT AND LMTGOT ARE RETURNED
C CONTAINING 1, AND THE VALUE OF THE NUMBER IS
C RETURNED EITHER IN BOTH INIVAL AND LMTVAL OR
C IN BOTH VALINI AND VALLMT, WHICHEVER IS
C APPROPRIATE. INCGOT IS RETURNED CONTAINING
C ZERO.
C = 6, EITHER 2 OR 3 NUMBERS WERE FOUND, BUT
C WITHOUT SLASHES OR ASTERISKS. THE VALUE OF
C THE LEFT NUMBER IS RETURNED IN EITHER
C INIVAL OR VALINI, OF THE RIGHT IN EITHER
C LMTVAL OR VALLMT, AND OF THE MIDDLE, IF
C PRESENT, IN EITHER INCVAL OR VALINC,
C WHICHEVER IS APPROPRIATE. INIGOT AND LMTGOT
C ARE EACH RETURNED CONTAINING 1. INCGOT IS
C RETURNED CONTAINING 1 ONLY IF 3 NUMBERS WERE
C FOUND. KONECT WOULD HAVE TO BE INPUT AS 1
C FOR KIND TO BE RETURNED AS 6.
C = 7, A SERIES SPECIFICATION CONTAINING ONE OR
C MORE SLASHES WAS FOUND. THE LOCATION OF THE
C SLASH OR SLASHES RELATIVE TO THE NUMBERS, IF
C ANY, IN THE SERIES SPECIFICATION IS
C INDICATED BY THE RETURNED VALUES OF INIGOT,
C INCGOT AND LMTGOT.
C = 8, A SERIES SPECIFICATION CONTAINING A
C SINGLE ASTERISK WAS FOUND. INCGOT IS
C RETURNED CONTAINING ZERO. THE LOCATION OF
C THE ASTERISK RELATIVE TO THE NUMBERS, IF
C ANY, IN THE SERIES SPECIFICATION IS
C INDICATED BY THE RETURNED VALUES OF INIGOT
C AND LMTGOT.
C = 9, A SERIES SPECIFICATION WAS FOUND WHICH
C INCLUDED TOO MANY NUMBERS, TOO MANY SLASHES
C OR TOO MANY ASTERISKS. INIGOT, INCGOT AND
C LMTGOT ARE EACH RETURNED CONTAINING ZERO.
C = 10, FIRST PRINTING CHARACTER IN OR TO RIGHT
C OF LOWBFR WAS NOT A CHARACTER WHICH COULD
C APPEAR IN A NUMBER OR NUMBER RANGE, AND WAS
C NOT A COMMA, SEMICOLON OR EXCLAMATION POINT.
C LOWBFR IS RETURNED POINTING TO THE NEXT
C CHARACTER BEYOND THIS CHARACTER.
C INIGOT = 0, RETURNED IF THE CONTENTS OF THE BUFFER DO
C NOT SPECIFY THE START OF THE RANGE. INIVAL
C OR VALINI, WHICHEVER IS APPROPRIATE, IS
C RETURNED UNDEFINED, BUT PROBABLY CHANGED.
C = 1, RETURNED IF THE CONTENTS OF THE BUFFER
C SPECIFY THE START OF THE RANGE. INIVAL OR
C VALINI, WHICHEVER IS APPROPRIATE, IS
C RETURNED CONTAINING THIS STARTING NUMBER.
C INCGOT = 0, RETURNED IF THE CONTENTS OF THE BUFFER DO
C NOT SPECIFY AN INCREMENT BY WHICH THE
C STARTING VALUE IS TO BE VARIED UNTIL IT
C REACHES THE ENDING VALUE. INCVAL OR VALINC,
C WHICHEVER IS APPROPRIATE, IS RETURNED
C UNDEFINED, BUT PROBABLY CHANGED.
C = 1, RETURNED IF THE CONTENTS OF THE BUFFER
C SPECIFY AN INCREMENT BY WHICH THE STARTING
C VALUE IS TO BE VARIED UNTIL IT REACHES THE
C ENDING VALUE. INCVAL OR VALINC, WHICHEVER
C IS APPROPRIATE, IS RETURNED CONTAINING THIS
C INCREMENT.
C LMTGOT = 0, RETURNED IF THE CONTENTS OF THE BUFFER DO
C NOT SPECIFY A NUMBER AT WHICH THE RANGE IS
C TO END. LMTVAL OR VALLMT, WHICHEVER IS
C APPROPRIATE, IS RETURNED UNDEFINED, BUT
C PROBABLY CHANGED.
C = 1, RETURNED IF THE CONTENTS OF THE BUFFER
C SPECIFY A NUMBER AT WHICH THE RANGE IS TO
C END. LMTVAL OR VALLMT, WHICHEVER IS
C APPROPRIATE, IS RETURNED CONTAINING THIS
C ENDING VALUE.
C INIVAL = RETURNED CONTAINING THE START OF THE RANGE
C IF THIS IS SPECIFIED AND IF THIS IS
C EVALUATED AS AN INTEGER (KONTRL INPUT .LE.0
C AND INIGOT RETURNED = 1)
C INCVAL = RETURNED CONTAINING THE INCREMENT IF THIS IS
C SPECIFIED AND IF THIS IS EVALUATED AS AN
C INTEGER (KONTRL INPUT .LE.0 AND INCGOT
C RETURNED = 1)
C LMTVAL = RETURNED CONTAINING THE END OF THE RANGE IF
C THIS IS SPECIFIED AND IF THIS IS EVALUATED
C AS AN INTEGER (KONTRL INPUT .LE.0 AND LMTGOT
C RETURNED = 1)
C VALINI = RETURNED CONTAINING THE START OF THE RANGE
C IF THIS IS SPECIFIED AND IF THIS IS
C EVALUATED AS A FLOATING POINT NUMBER (KONTRL
C INPUT .GT.0 AND INIGOT RETURNED = 1)
C VALINC = RETURNED CONTAINING THE INCREMENT IF THIS IS
C SPECIFIED AND IF THIS IS EVALUATED AS A
C FLOATING POINT NUMBER (KONTRL INPUT .GT.0
C AND INCGOT RETURNED = 1)
C VALLMT = RETURNED CONTAINING THE END OF THE RANGE IF
C THIS IS SPECIFIED AND IF THIS IS EVALUATED
C AS A FLOATING POINT NUMBER (KONTRL INPUT
C .GT.0 AND LMTGOT RETURNED = 1)
C
C EVALUATION OF RANGE SPECIFICATIONS LMTVAL
C SHOWN BELOW WOULD PRODUCE ARGUMENT INCVAL !
C VALUES TO THEIR RIGHT. "U" INDICATES INIVAL ! !
C THAT THE ARGUMENT IS UNDEFINED. LMTGOT ! ! !
C INCGOT ! ! ! !
C INIGOT ! ! ! ! !
C EMPTY OR / OR // OR * 0 0 0 U U U
C /// OR 5///9 OR 5 2 2 9 0 0 0 U U U
C /9 OR //9 OR *9 0 0 1 U U 9
C /2/ 0 1 0 U 2 U
C /2/9 OR /2 9 0 1 1 U 2 9
C 5/ OR 5// OR 5* 1 0 0 5 U U
C 5 1 0 1 5 U 5
C 5/9 OR 5//9 OR 5 9 OR 5*9 1 0 1 5 U 9
C 5/2/ OR 5 2/ 1 1 0 5 2 U
C 5/2/9 OR 5 2/9 OR 5/2 9 OR 5 2 9 1 1 1 5 2 9
C
DIMENSION IBUFFR(MAXBFR),IDIGIT(13)
DATA IDIGIT/
11H+,1H-,1H.,1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA ISLASH,ICOLON,ISTAR,KOMENT,IEND,IAND,KOMMA,
1ISPACE,ITAB/1H/,1H:,1H*,1H!,1H;,1H&,1H,,1H ,1H /
IRADIX=13
IF(KONTRL.LT.0)IRADIX=11
ISTATE=0
KOUNT=0
INIGOT=1
KNTSEP=0
LMTGOT=1
KIND=1
ITEST=2
IF(MANY.GE.0)GO TO 1
KIND=4
MANY=-MANY
1 IF(KONTRL.GT.0)GO TO 2
INCVAL=0
LMTVAL=0
GO TO 4
2 VALINC=0.
VALLMT=0.
GO TO 4
C
C TEST IF NEXT CHARACTER CAN BE IN SERIES SPECIFICATION
3 LOWBFR=LOWBFR+1
4 IF(LOWBFR.GT.MAXBFR)GO TO 22
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.ISPACE)GO TO 13
IF(LETTER.EQ.ITAB)GO TO 13
IF(LETTER.EQ.ISLASH)GO TO 11
IF(LETTER.EQ.ICOLON)GO TO 11
IF(LETTER.EQ.ISTAR)GO TO 10
IF(LETTER.EQ.KOMENT)GO TO 20
IF(LETTER.EQ.IEND)GO TO 14
IF(LETTER.EQ.KOMMA)GO TO 9
IF(LETTER.EQ.IAND)GO TO 15
IF(KONECT.GT.0)GO TO 5
IF(ISTATE.GT.0)GO TO 22
5 IF(KONTRL.LT.-1)GO TO 7
DO 6 I=1,IRADIX
IF(LETTER.EQ.IDIGIT(I))GO TO 17
6 CONTINUE
7 IF(KIND.EQ.4)GO TO 8
IF(KIND.NE.1)GO TO 22
8 LOWBFR=LOWBFR+1
KIND=10
GO TO 22
C
C TEST IF DELIMITER CHARACTER CAN PRECEDE A SERIES
9 IF(KIND.NE.1)GO TO 22
KIND=4
IF(MANY.EQ.0)GO TO 23
GO TO 3
C
C ASTERISK FOUND
10 IF(KIND.EQ.7)ITEST=0
IF(ITEST.GT.0)ITEST=1
KIND=8
GO TO 12
C
C SLASH FOUND
11 IF(KIND.EQ.8)ITEST=0
KIND=7
12 IF(KOUNT.EQ.0)INIGOT=0
LMTGOT=0
KNTSEP=KNTSEP+1
ISTATE=-1
GO TO 3
C
C SPACE FOUND
13 IF(ISTATE.EQ.0)GO TO 3
IF(KONECT.GE.0)GO TO 3
GO TO 22
C
C SEMICOLON FOUND
14 IF(KIND.NE.1)GO TO 22
LOWBFR=LOWBFR+1
KIND=2
GO TO 22
C
C AMPERSAND FOUND
15 IF(KIND.EQ.1)GO TO 16
IF(KIND.NE.4)GO TO 22
MANY=-MANY
16 KIND=3
GO TO 21
C
C EVALUATE NUMBER AND PLACE INTO PUSH-DOWN STACK
17 IF(KIND.LE.5)KIND=KOUNT+5
KOUNT=KOUNT+1
IF(ISTATE.LT.0)KNTSEP=KNTSEP-1
ISTATE=1
LMTGOT=1
IF(KONTRL.GT.0)GO TO 18
INIVAL=INCVAL
INCVAL=LMTVAL
GO TO 19
18 VALINI=VALINC
VALINC=VALLMT
C IDUMMY PRESERVES VARIABLE LOCAL TO THIS ROUTINE
19 CALL DAHEFT(KONTRL,1,0,IBUFFR,MAXBFR,
1LOWBFR,IDUMMY,ISHIFT,JSHIFT,KSHIFT,LSHIFT,LMTVAL,
2VALLMT)
GO TO 4
C
C TEST IF TOO MANY ITEMS WERE FOUND IN SPECIFICATION
20 IF(KIND.NE.1)GO TO 22
21 LOWBFR=MAXBFR+1
22 IF((KOUNT+KNTSEP-INIGOT).LE.ITEST)GO TO 23
KIND=9
GO TO 24
C
C CONVERT PUSH-DOWN STACK INTO RANGE DESCRIPTION
23 IF(KOUNT.GE.3)GO TO 30
IF(KOUNT.EQ.2)GO TO 25
IF(KOUNT.EQ.1)GO TO 27
24 INIGOT=0
LMTGOT=0
GO TO 33
25 IF(INIGOT.EQ.0)GO TO 30
IF(KONTRL.GT.0)GO TO 26
INIVAL=INCVAL
GO TO 28
26 VALINI=VALINC
GO TO 28
27 IF(INIGOT.NE.0)GO TO 31
28 IF(LMTGOT.NE.0)GO TO 33
IF(KONTRL.GT.0)GO TO 29
INCVAL=LMTVAL
GO TO 30
29 VALINC=VALLMT
30 INCGOT=1
GO TO 34
31 IF(KONTRL.GT.0)GO TO 32
INIVAL=LMTVAL
GO TO 33
32 VALINI=VALLMT
33 INCGOT=0
C
C EVERYTHING IS IN ITS PLACE, RETURN TO CALLING ROUTINE
34 IF(KIND.GT.3)MANY=MANY+1
IF(KIND.LT.3)MANY=0
35 RETURN
C
C KNTSEP = NUMBER OF SLASHES AND ASTERISKS NOT FOLLOWED
C BY A NUMBER.
C ISTATE = 1, WITHIN NUMBER
C = 0, SPACE
C = -1, SLASH FOUND
C ITEST = MAXIMUM NUMBER OF SLASHES OR ASTERISKS
C ALLOWED IN A SINGLE SERIES SPECIFICATION.
C JSIGN = -1, MINUS SIGN AT START OF NUMBER
C = 0, NO SIGN AT START OF NUMBER
C = 1, PLUS SIGN AT START OF NUMBER
C KOUNT = NUMBER OF NUMBERS ALREADY FOUND
C
C770127366001:!;&
END
SUBROUTINE DASHOW(KONTRL,MINDEC,MAXDEC,MINSIG,MAXSIG,
1 IDECML,IVALUE,VALUE ,MAXBFR,KOUNT ,IBUFFR,IERR )
C RENBR(/REPRESENT INTEGER OR REAL NUMBER)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO REPRESENT INTEGERS OR REAL NUMBERS LEFT
C JUSTIFIED AND WITHOUT EXTRA RIGHTMOST BLANKS
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR INPUT AND ARE
C RETURNED UNCHANGED.
C
C KONTRL = -1, REPRESENT INTEGER VALUE INPUT AS
C ARGUMENT NAMED IVALUE AS OCTAL NUMBER.
C = 0, REPRESENT INTEGER VALUE INPUT AS ARGUMENT
C NAMED IVALUE AS DECIMAL NUMBER.
C = 1 OR GREATER, REPRESENT REAL VALUE INPUT AS
C ARGUMENT NAMED VALUE WITH NO MORE THAN
C MAXDEC NOR LESS THAN MINDEC DIGITS TO RIGHT
C OF DECIMAL POINT AND WITH NO MORE THAN
C MAXSIG NOR LESS THAN MINSIG SIGNIFICANT
C DIGITS. IF VALUE CANNOT BE REPRESENTED
C USING SPECIFIED NUMBERS OF DIGITS IN
C FLOATING POINT FORM (WITHOUT E EXPONENT),
C THEN VALUE IS INSTEAD REPRESENTED IN
C SCIENTIFIC NOTATION (WITH E EXPONENT) AND
C WITH IDECML DIGITS TO RIGHT OF DECIMAL POINT
C IN REPRESENTATION OF VALUE WHICH EITHER HAS
C VALUE ZERO, OR WHICH HAS BEEN MODIFIED
C THOUGH MULTIPLICATION BY POWER OF TEN SO AS
C TO FALL WITHIN RANGE 1.0 THROUGH 9.999...
C MINDEC = 0, THERE IS NO LOWER LIMIT TO NUMBER OF
C DIGITS WHICH MUST BE SHOWN TO RIGHT OF
C DECIMAL POINT OF NUMBER REPRESENTED IN
C FLOATING POINT FORM.
C = GREATER THAN ZERO, MINDEC IS MINIMUM NUMBER
C OF DIGITS WHICH CAN BE SHOWN TO RIGHT OF
C DECIMAL POINT OF NUMBER REPRESENTED IN
C FLOATING POINT FORM IF RIGHTMOST OF THESE
C DIGITS IS NONZERO. IF IT WOULD NOT BE
C POSSIBLE TO INCLUDE AT LEAST THIS NUMBER OF
C DIGITS TO RIGHT OF DECIMAL POINT, THEN VALUE
C WILL BE REPRESENTED IN SCIENTIFIC NOTATION
C INSTEAD. AFTER DETERMINING THAT IT WOULD BE
C POSSIBLE TO REPRESENT AT LEAST MINDEC DIGITS
C TO RIGHT OF DECIMAL POINT, THEN EACH DIGIT
C WHICH IS TO RIGHT OF DECIMAL POINT AND WHICH
C DOES NOT HAVE NONZERO DIGIT TO ITS RIGHT IS
C SUPPRESSED AND EVEN DECIMAL POINT WILL NOT
C BE SHOWN IF THERE ARE NO NONZERO DIGITS TO
C RIGHT OF DECIMAL POINT.
C MAXDEC = 0, REPRESENT ONLY DIGITS WHICH ARE TO LEFT
C OF DECIMAL POINT OF NUMBER REPRESENTED IN
C FLOATING POINT FORM.
C = GREATER THAN ZERO, MAXDEC IS MAXIMUM NUMBER
C OF DIGITS WHICH CAN BE SHOWN TO RIGHT OF
C DECIMAL POINT OF NUMBER REPRESENTED IN
C FLOATING POINT FORM.
C MINSIG = MINIMUM NUMBER OF SIGNIFICANT DIGITS WHICH
C CAN BE SHOWN IN NUMBER REPRESENTED IN
C FLOATING POINT FORM IF RIGHTMOST OF THESE
C DIGITS IS NONZERO. IF VALUE BEING DISPLAYED
C HAS VALUE ZERO, THEN MINSIG IS IGNORED.
C MAXSIG = 0, REPRESENT VALUE INPUT AS ARGUMENT NAMED
C VALUE IN SCIENTIFIC NOTATION (WITH E
C EXPONENT).
C = GREATER THAN ZERO, MAXSIG IS MAXIMUM NUMBER
C OF DIGITS WHICH CAN BE SHOWN IN NUMBER
C REPRESENTED IN FLOATING POINT FORM, STARTING
C WITH LEFTMOST NONZERO DIGIT, COUNTING IT AND
C ALL DIGITS TO ITS RIGHT. NUMBER OF DIGITS
C DISPLAYED TO RIGHT OF DECIMAL POINT IS
C REDUCED IF NECESSARY SO THAT NUMBER OF
C DIGITS STARTING AT LEFTMOST NONZERO
C DISPLAYED DIGIT AND COUNTING IT AND ALL
C DIGITS DISPLAYED TO ITS RIGHT DOES NOT
C EXCEED MAXSIG. IF MAXSIG WOULD BE LESS THAN
C NUMBER OF DIGITS LEFT OF DECIMAL POINT IN
C REPRESENTATION OF VALUE, THEN VALUE WILL BE
C REPRESENTED IN SCIENTIFIC NOTATION.
C IDECML = SAME AS MAXDEC EXCEPT THAT IDECML APPLIES
C ONLY TO VALUES DISPLAYED IN SCIENTIFIC
C NOTATION. NOTE THAT IF VALUE IS BEING
C REPRESENTED IN SCIENTIFIC NOTATION, THEN
C NONZERO DIGIT WILL BE USED LEFT OF DECIMAL
C POINT UNLESS VALUE IS ITSELF ZERO.
C THEREFORE, MAXIMUM NUMBER OF SIGNIFICANT
C DIGITS WHICH CAN BE DISPLAYED IN SCIENTIFIC
C NOTATION IS IDECML+1.
C IVALUE = INPUT CONTAINING INTEGER VALUE TO BE
C REPRESENTED IF KONTRL IS LESS THAN OR EQUAL
C TO ZERO.
C VALUE = INPUT CONTAINING REAL VALUE TO BE
C REPRESENTED IF KONTRL IS GREATER THAN ZERO.
C MAXBFR = SUBSCRIPT OF RIGHTMOST LOCATION IN IBUFFR
C ARRAY WHICH CAN BE USED BY THIS ROUTINE FOR
C RETURN OF CHARACTERS IN REPRESENTATION OF
C NUMBER. REPRESENTATION OF NUMBER WILL USE
C FEWER LOCATIONS IN IBUFFR ARRAY IF POSSIBLE.
C
C FOLLOWING ARGUMENT IS USED FOR BOTH INPUT AND OUTPUT.
C
C KOUNT = INPUT CONTAINING SUBSCRIPT OF RIGHTMOST
C (HIGHEST SUBSCRIPT VALUE) IBUFFR ARRAY
C LOCATION WHICH IS CURRENTLY IN USE AND WHICH
C MUST BE PRESERVED. REPRESENTATION OF NUMBER
C WILL BE RETURNED STARTING IN IBUFFR(KOUNT+1)
C AND EXTENDING THROUGH IBUFFR(MAXBFR) IF
C NECESSARY.
C = RETURNED CONTAINING SUBSCRIPT OF RIGHTMOST
C IBUFFR ARRAY LOCATION IN WHICH CHARACTER OF
C REPRESENTATION OF NUMBER IS RETURNED.
C PORTION OF IBUFFR ARRAY TO RIGHT OF
C REPRESENTATION AND EXTENDING THROUGH
C IBUFFR(MAXBFR) IS RETURNED UNDEFINED, BUT
C POSSIBLY CHANGED.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT.
C
C IBUFFR = ARRAY IN WHICH CHARACTERS WHICH FORM
C REPRESENTATION OF NUMBER ARE RETURNED AS
C THOUGH READ BY MULTIPLE OF A1 FORMAT
C SPECIFICATION OR AS THOUGH DEFINED BY
C SEVERAL 1H FIELDS. LEFTMOST CHARACTER OF
C REPRESENTATION IS RETURNED IN
C IBUFFR(KOUNT+1).
C IERR = -1, RETURNED IF FIELD WAS TOO SHORT TO
C CONTAIN REPRESENTATION OF NUMBER. FIELD IS
C RETURNED CONTAINING ASTERISKS, AND KOUNT IS
C RETURNED SET EQUAL TO MAXBFR.
C = 0, RETURNED IF KONTRL IS LESS THAN OR EQUAL
C TO ZERO AND INTEGER VALUE COULD BE SHOWN, OR
C IF KONTRL IS GREATER THAN ZERO AND REAL
C VALUE WAS REPRESENTED IN FLOATING POINT
C FORM.
C = 1 OR GREATER, RETURNED IF KONTRL IS INPUT
C GREATER THAN ZERO AND VALUE WAS REPRESENTED
C IN SCIENTIFIC NOTATION. IERR IS NUMBER OF
C DIGITS WHICH WOULD BE SHOWN TO LEFT OF
C EXPONENT IF RIGHTMOST OF THESE DIGITS IS
C NONZERO. ZEROS WHICH ARE TO RIGHT OF
C DECIMAL POINT AND WHICH DO NOT HAVE NONZERO
C DIGIT TO THEIR RIGHT ARE NOT SHOWN BUT ARE
C INCLUDED IN VALUE OF IERR.
C
DIMENSION IBUFFR(MAXBFR)
DATA ISTAR/1H*/
LFTCOL=KOUNT
IF(KONTRL.GT.0)GO TO 2
C
C REPRESENT INTEGER
IRADIX=10
IF(KONTRL.LT.0)IRADIX=8
CALL DANUMB(0,IVALUE,IRADIX,IBUFFR,KOUNT,LFTCOL,
1MAXBFR)
IERR=0
IF(KOUNT.GT.LFTCOL)GO TO 3
IERR=-1
1 IF(KOUNT.GE.MAXBFR)GO TO 3
KOUNT=KOUNT+1
IBUFFR(KOUNT)=ISTAR
GO TO 1
C
C REPRESENT REAL NUMBER
2 LOWDEC=MINDEC
IF(LOWDEC.LE.0)LOWDEC=-1
NOTATN=0
IF(MAXSIG.LE.0)NOTATN=-1
IWIDTH=MAXBFR-LFTCOL
CALL DARITE(VALUE ,-1,NOTATN,0,0,
1-3,0,IWIDTH,LOWDEC,MAXDEC,MINSIG,MAXSIG,
2-1,0,IDECML,0,0,-1,LFTCOL,
3MAXBFR,IBUFFR,KOUNT,IERR)
C
C RETURN TO CALLING PROGRAM
3 RETURN
C227857143604
END
SUBROUTINE DARITE(VALUE ,JSTIFY,NOTATN,IPART ,ISIGN ,
1 KLIP ,IFILL ,IWIDTH,MINDEC,MAXDEC,MINSIG,MAXSIG,
2 INIZRO,MARGIN,IDECML,IEXPNT,IFORMT,IZERO ,LFTCOL,
3 MAXBFR,IBUFFR,KOUNT ,IERR )
C RENBR(/FREE FORMAT NUMERIC OUTPUT ROUTINE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO REPRESENT A NUMBER SO THAT IT CAN BE
C WRITTEN WITH A FORTRAN FORMAT STATEMENT CONTAINING A
C MULTIPLE A1 ALPHAMERIC SPECIFICATION. THE NUMBER CAN
C BE REPRESENTED EITHER WITH A USER SPECIFIED NUMBER OF
C DIGITS RIGHT OF THE DECIMAL POINT AND WITH A MAXIMUM
C NUMBER OF SIGNIFICANT DIGITS, OR IN SCIENTIFIC
C NOTATION AS A NUMBER IN THE RANGE 1.000... TO
C 9.999... WITH A FOLLOWING EXPONENT. IF FLOATING
C POINT NOTATION HAS BEEN REQUESTED, BUT THE NUMBER
C CANNOT FIT INTO THE SUPPLIED FIELD WITH THE SPECIFIED
C NUMBER OF DIGITS RIGHT OF THE DECIMAL POINT, THEN THE
C NUMBER OF DIGITS RIGHT OF THE DECIMAL POINT WILL BE
C DECREASED, AND IF THE NUMBER WILL STILL NOT FIT, THEN
C SCIENTIFIC NOTATION WILL BE USED. IF THE NUMBER WILL
C NOT FIT INTO THE FIELD EVEN IN SCIENTIFIC NOTATION,
C THEN THE FIELD WILL BE FILLED WITH ASTERISKS.
C
C THE FOLLOWING ARE INPUT ARGUMENTS LEFT UNCHANGED
C
C VALUE = THE NUMBER TO BE REPRESENTED
C JSTIFY = -1, LEFT JUSTIFY NUMBER IN FIELD OF WIDTH
C IWIDTH
C = 0, CENTER NUMBER IN FIELD OF WIDTH IWIDTH.
C = 1, RIGHT JUSTIFY NUMBER IN FIELD OF WIDTH
C IWIDTH.
C NOTATN = -1, REPRESENT IN ARRAY IBUFFR THE VALUE IN
C SCIENTIFIC NOTATION. VALUE 1234 WOULD BE
C REPRESENTED IN IBUFFR AS 1.234E3
C = 0, DISPLAY IN IBUFFR THE VALUE IN FLOATING
C POINT FORM. THE VALUE 1234.56 WOULD BE
C DISPLAYED AS IT IS WRITTEN IF THE NUMBER OF
C DIGITS RIGHT OF THE DECIMAL POINT IS 2 AND
C IF AT LEAST 6 SIGNIFICANT DIGITS IN A FIELD
C OF AT LEAST 7 CHARACTERS ARE ALLOWED.
C = 1, MULTIPLY VALUE BY 100 AND INSERT PERCENT
C SIGN FOLLOWING DIGITS OF NUMBER. IWIDTH
C MUST INCLUDE ROOM FOR PERCENT SIGN. MINDEC
C AND MAXDEC REFER TO THE DISPLAYED DECIMAL
C POINT. TO PRINT TENTHS OF A PERCENT, MINDEC
C AND MAXDEC WOULD BOTH BE GIVEN THE VALUE 1
C = 2, IF NUMBER IS IN RANGE 1000 TO 1000000,
C DIVIDE VALUE BY 1000 AND INSERT K FOLLOWING
C DIGITS. IF NUMBER IS 1000000 OR GREATER,
C DIVIDE VALUE BY 1000000 AND INSERT M
C FOLLOWING DIGITS. IWIDTH MUST INCLUDE ROOM
C FOR CHARACTER K OR M. MINDEC AND MAXDEC
C REFER TO DISPLAYED DECIMAL POINT. MINDEC
C AND MAXDEC BOTH SET AT 2 WOULD REPRESENT
C VALUE 1234 AS 1.23K.
C = 3, SAME AS NOTATN=2 EXCEPT THAT MINDEC AND
C MAXDEC BOTH REFER TO THE DECIMAL POINT IN
C THE ORIGINAL VALUE, NOT TO THE DISPLAYED
C DECIMAL POINT. IF A K OR M IS DISPLAYED
C RIGHT OF THE NUMBER, THEN MINDEC AND MAXDEC
C VALUES OF -1 ARE EQUIVALENT TO VALUES OF 0.
C MINDEC=-2 INDICATES THAT THERE IS NO LOWER
C LIMIT TO THE NUMBER OF DIGITS DISPLAYED TO
C RIGHT OF THE DISPLAYED DECIMAL POINT AND IS
C PROBABLY THE APPROPRIATE VALUE UNLESS IT IS
C ABSOLUTELY NECESSARY TO DISPLAY THE DIGITS
C WHICH WOULD BE RIGHT OF THE DECIMAL POINT IN
C THE ORIGINAL VALUE, AS FOR EXAMPLE IF THE
C AMOUNTS ARE DOLLARS AND MUST BE DISPLAYED
C ALWAYS INCLUDING THE CENTS DIGITS.
C IPART = -1, IF THE VALUE IS REPRESENTED IN FLOATING
C POINT, COMPLETELY REPRESENT THIS VALUE. IF
C THE VALUE IS REPRESENTED IN SCIENTIFIC NOTA-
C TION, REPRESENT ONLY THE NORMALIZED PORTION
C OF THE VALUE WITHOUT THE EXPONENT, IT BEING
C THIS NORMALIZED VALUE (IN THE RANGE OF 1.0
C TO 9.9...) WHICH IS LEFT JUSTIFIED, CENTERED
C OR RIGHT JUSTIFIED ACCORDING TO THE VALUE OF
C JSTIFY. IWIDTH MUST, HOWEVER, CONTAIN
C SUFFICIENT ROOM FOR EITHER THE NORMALIZED
C VALUE OR THE EXPONENT, WHICHEVER REQUIRES
C THE MOST CHARACTERS TO REPRESENT.
C = 0, COMPLETELY REPRESENT THE VALUE REGARDLESS
C OF WHETHER IN FLOATING POINT OR SCIENTIFIC
C NOTATION.
C = 1, IF THE VALUE IS REPRESENTED IN FLOATING
C POINT, INSERT NOTHING (EXCEPT THE POSSIBLE
C TRAILING SPACES INDICATED BY IFILL) INTO
C IBUFFR. IF THE VALUE IS REPRESENTED IN
C SCIENTIFIC NOTATION, REPRESENT ONLY EXPONENT
C PORTION, IT BEING THIS EXPONENT PORTION
C WHICH IS LEFT JUSITIFED, CENTERED OR RIGHT
C JUSTIFIED ACCORDING TO THE VALUE OF JSTIFY.
C IWIDTH MUST, HOWEVER, CONTAIN SUFFICIENT
C ROOM FOR EITHER THE NORMALIZED VALUE OR THE
C EXPONENT, WHICHEVER REQUIRES THE MOST CHAR-
C ACTERS TO REPRESENT.
C ISIGN = -1, IF THE VALUE IS GREATER THAN ZERO, AND
C IF IPART.LE.0, THEN PLACE PLUS SIGN TO ITS
C LEFT. IF THE VALUE IS EQUAL TO ZERO, DO NOT
C ADD EXTRA SPACE WHERE THE PLUS OR MINUS SIGN
C WOULD OTHERWISE BE.
C = 0, IF THE VALUE IS GREATER THAN OR EQUAL TO
C ZERO, DO NOT ADD EXTRA SPACE WHERE THE MINUS
C SIGN WOULD OTHERWISE BE.
C = 1, IF THE VALUE IS GREATER THAN OR EQUAL TO
C ZERO, AND IF IPART.LE.0, THEN AT LEAST 1
C SPACE WILL BE PLACED AT THE LEFT END OF THE
C REPRESENTATION OF THE VALUE EVEN IF THE
C NUMBER OF DIGITS IN THE REPRESENTION MUST BE
C REDUCED TO MAKE ROOM FOR THIS SPACE.
C = 2, IF THE VALUE IS GREATER THAN ZERO, AND IF
C IPART.LE.0, THEN PLACE PLUS SIGN TO ITS
C LEFT. IF THE VALUE IS EQUAL TO ZERO, AND IF
C IPART.LE.0, THEN PLACE AT LEAST 1 SPACE AT
C THE LEFT END OF THE REPRESENTATION OF THE
C VALUE EVEN IF THE NUMBER OF DIGITS IN THE
C REPRESENTATION MUST BE REDUCED TO MAKE ROOM
C FOR THIS SPACE.
C KLIP = -3, SUPPRESS PRINTING OF ALL ZEROES TO THE
C RIGHT OF THE DECIMAL POINT AND WHICH DO NOT
C HAVE A NON-ZERO DIGIT TO THEIR RIGHT. IF
C NO NON-ZERO DIGITS APPEAR RIGHT OF DECIMAL
C POINT, THEN DO NOT REPRESENT DECIMAL POINT.
C IF CENTERING OR RIGHT JUSTIFYING, IT IS THE
C NUMBER AFTER REMOVAL OF ZEROES AND DECIMAL
C WHICH IS CENTERED OR RIGHT JUSTIFIED.
C = -2, SUPPRESS PRINTING OF ALL ZEROES TO THE
C RIGHT OF THE DECIMAL POINT AND WHICH DO NOT
C HAVE A NON-ZERO DIGIT TO THEIR RIGHT. IF
C CENTERING OR RIGHT JUSTIFYING NUMBER, IT IS
C NUMBER AFTER REMOVAL OF ZEROES WHICH IS
C CENTERED OR RIGHT JUSTIFIED.
C = -1, SUPPRESS PRINTING OF ALL ZEROES WHICH
C ARE BEYOND THE FIRST DIGIT AFTER THE DECIMAL
C POINT AND WHICH DO NOT HAVE A NON-ZERO DIGIT
C TO THEIR RIGHT. IF CENTERING OR RIGHT
C JUSTIFYING, IT IS THE NUMBER AFTER REMOVAL
C OF THE ZEROES THAT IS CENTERED OR RIGHT
C JUSTIFIED.
C = 0, REPRESENT AS ZEROES ALL ZEROES WHICH
C ARE BEYOND THE FIRST DIGIT AFTER THE DECIMAL
C POINT.
C = 1, CONVERT TO SPACES ALL ZEROES WHICH ARE
C BEYOND THE FIRST DIGIT AFTER THE DECIMAL
C POINT AND WHICH DO NOT HAVE A NON-ZERO DIGIT
C TO THEIR RIGHT. REMAINING CHARACTERS WILL
C BE IN THE SAME POSITIONS AS IF THE ZEROES
C WHERE NONZEROES. IF NOTATN.GT.0, SPACES CAN
C APPEAR BETWEEN THE NONSPACE CHARACTERS OF
C THE NUMBER AND THE FOLLOWING PERCENT SIGN OR
C K OR M SINCE THE LOCATION OF THESE PRINTING
C CHARACTERS IS NOT CHANGED BY THE CONVERSION
C OF THE TRAILING ZEROES TO SPACES.
C = 2, SAME AS KLIP=1, EXCEPT THAT ALL ZEROES TO
C THE RIGHT OF DECIMAL POINT WHICH DO NOT HAVE
C NON-ZERO DIGIT TO THEIR RIGHT ARE SUPPRESSED
C = 3, SAME AS KLIP=2, EXCEPT THAT IF THERE ARE
C NO NON-ZERO DIGITS DISPLAYED TO THE RIGHT OF
C DECIMAL POINT, THEN THE DECIMAL POINT IS NOT
C DISPLAYED.
C
C FOR EXAMPLE, THE REPRESENATIONS OF THE VALUE
C 12.34 IN FLOATING POINT WITH MAXDEC=4 AND IN
C SCIENTIFIC NOTATION WITH IDECML=5 WOULD BE
C
C FOR KLIP.LT.0 12.34 1.234E1
C KLIP=0 12.3400 1.23400E1
C KLIP.GT.0 12.34 1.234 E1
C
C IF NOTATN=2 VALUE 123E3 WOULD BE REPRESENTED
C
C FOR KLIP=-3 123K 1.23E5
C KLIP=-2 123.K 1.23E5
C KLIP=-1 123.0K 1.23E5
C KLIP=0 123.0000K 1.23000E5
C KLIP=1 123.0 K 1.23 E5
C KLIP=2 123. K 1.23 E5
C KLIP=3 123 K 1.23 E5
C
C IFILL = 0, DO NOT FILL PORTION OF FIELD RIGHT OF
C NONSPACE REPRESENTAION OF VALUE WITH SPACES.
C KOUNT WILL BE LEFT POINTING AT THE RIGHTMOST
C NONSPACE CHARACTER IN THE REPRESENATION OF
C THE VALUE. THE VALUE OF IFILL HAS NO EFFECT
C ON THE NONSPACE CHARACTERS IN THE REPRESEN-
C TATION OF THE VALUE. IF IFILL=0, AND IF
C IPART.LE.0, THEN THE CHARACTERS ORIGINALLY
C IN THE IBUFFR ARRAY TO THE RIGHT OF THE
C NONSPACE PORTION OF THE REPRESENTATION OF
C THE VALUE ARE LEFT INTACT. (THE REASON WHY
C IPART.GT.0 IS AN EXCEPTION IS THAT THE
C NORMALIZED PORTION OF THE NUMBER MUST BE
C TEMPORARILY STORED IN IBUFFR EVEN IF IT IS
C NOT GOING TO BE REPRESENTED SINCE EXPONENT
C CHANGE DUE TO ROUNDING MUST BE CHECKED FOR.)
C = 1, FILL THE FIELD RIGHT OF THE NONSPACE
C PORTION OF THE REPRESENTATION OF THE VALUE
C WITH SPACES. KOUNT WILL BE LEFT POINTING
C AT LFTCOL+IWIDTH.
C IWIDTH = THE NUMBER OF CHARACTERS TO BE IN THE FIELD
C INTO WHICH THE VALUE IS CODED. IWIDTH MUST
C INCLUDE ROOM FOR EXPONENT, SIGN AND DECIMAL
C POINT IF THESE ARE NECESSARY TO REPRESENT
C VALUE.
C LFTCOL = THE SUBSCRIPT OF THE IBUFFR ARRAY ENTRY TO
C THE IMMEDIATE LEFT OF FIELD INTO WHICH THE
C NUMBER IS TO BE CODED. USUALLY, LFTCOL WILL
C BE NUMBER OF CHARACTERS ALREADY IN IBUFFR.
C MAXBFR = DIMENSION OF IBUFFR ARRAY.
C
C THE FOLLOWING ARGUMENTS CONTROL FORMAT OF NUMBERS
C DISPLAYED IN FLOATING FORM (WITHOUT E EXPONENT), OR
C DISPLAYED WITH FOLLOWING K, M OR PERCENT SIGN. THESE
C ARGUMENTS DO NOT CONTROL THE FORMAT OF NUMBERS IN
C SCIENTIFIC NOTATION (EITHER WITH DISPLAYED EXPONENT
C OR WITH SUPPRESSED ZERO EXPONENT).
C
C MINDEC = MINIMUM NUMBER OF DIGITS RIGHT OF DISPLAYED
C DECIMAL POINT IN NUMBERS WHICH ARE DISPLAYED
C IN FLOATING FORM.
C = -1, IT IS NOT NECESSARY THAT THE DECIMAL
C POINT BE DISPLAYED. THERE IS NO MINIMUM
C LIMIT TO THE NUMBER OF DIGITS RIGHT OF THE
C DECIMAL POINT.
C = EQUAL TO OR GREATER THAN ZERO, MINDEC IS THE
C MINIMUM NUMBER OF DIGITS WHICH CAN BE
C DISPLAYED RIGHT OF THE DECIMAL POINT IN A
C FLOATING POINT NUMBER. IF LESS THAN MINDEC
C DIGITS WOULD BE DISPLAYED RIGHT OF DECIMAL
C POINT, THEN THE VALUE WILL BE REPRESENTED IN
C SCIENTIFIC NOTATION INSTEAD.
C MAXDEC = MAXIMUM NUMBER OF DIGITS RIGHT OF DISPLAYED
C DECIMAL POINT IN NUMBERS WHICH ARE DISPLAYED
C IN FLOATING FORM.
C = -2, REPRESENT AS MANY DIGITS RIGHT OF
C DECIMAL POINT AS FIELD WILL HOLD (UP THRU
C NUMBER OF DIGITS SPECIFIED BY MAXSIG).
C = -1, REPRESENT ONLY DIGITS LEFT OF DECIMAL
C POINT. THE DECIMAL POINT ITSELF WILL NOT BE
C REPRESENTED. IF MORE THAN IWIDTH OR MAXSIG
C DIGITS WOULD APPEAR LEFT OF DECIMAL POINT,
C NUMBER WILL BE REPRESENTED IN EXPONENT FORM.
C = .GE.0, REPRESENT NUMBER WITH MAXDEC DIGITS
C RIGHT OF DECIMAL POINT. IF THIS REPRESENT-
C ATION OF NUMBER WILL NOT FIT INTO FIELD SIZE
C INDICATED BY IWIDTH OR MAXSIG, THEN REDUCE
C NUMBER OF DIGITS REPRESENTED RIGHT OF
C DECIMAL POINT SO THAT NUMBER WILL FIT, OR
C REPRESENT NUMBER IN EXPONENT FORM IF THERE
C ARE MORE THAN IWIDTH OR MAXSIG DIGITS LEFT
C OF DECIMAL POINT.
C MINSIG = MINIMUM NUMBER OF SIGNIFICANT DIGITS TO BE
C REPRESENTED IN A VALUE DISPLAYED IN FLOATING
C POINT. IF LESS THAN MINSIG SIGNIFICANT
C DIGITS WOULD BE DISPLAYED, THE NUMBER WILL
C BE REPRESENTED IN SCIENTFIC NOTATION.
C MAXSIG = SELECTS MAXIMUM NUMBER OF SIGNIFICANT DIGITS
C DISPLAYED IN NUMBER REPRESENTED IN FLOATING
C POINT FORM.
C = .LE.0, ALLOW AS MANY DIGITS AS FIELD WILL
C HOLD
C = .GT.0, MAXSIG IS MAXIMUM NUMBER OF DIGITS
C WHICH CAN BE DISPLAYED STARTING WITH THE
C LEFTMOST NONZERO DIGIT, COUNTING IT AND ALL
C DIGITS TO ITS RIGHT. MAXSIG DOES NOT
C INCLUDE THE DECIMAL POINT, DOES NOT INCLUDE
C THE MINUS SIGN IF THE VALUE IS NEGATIVE, AND
C DOES NOT INCLUDE THE PERCENT SIGN, K OR M IF
C NOTATN.GT.0. THE NUMBER OF DIGITS DISPLAYED
C RIGHT OF THE DECIMAL POINT IS REDUCED IF
C NECESSARY SO THAT THE NUMBER OF DIGITS
C STARTING AT THE LEFTMOST NONZERO DISPLAYED
C DIGIT AND COUNTING IT AND ALL DIGITS
C DISPLAYED TO ITS RIGHT DOES NOT EXCEED
C MAXSIG. IF MAXSIG IS LESS THAN NUMBER OF
C DIGITS LEFT OF DECIMAL POINT IN DISPLAYED
C NUMBER, THEN NUMBER WILL BE DISPLAYED IN
C SCIENTIFIC NOTATION.
C INIZRO = 0, IF THE NUMBER IS REPRESENTED IN FLOATING
C POINT FORM AND HAS ABSOLUTE VALUE LESS THAN
C 1.0, THEN A ZERO IS DISPLAYED TO THE LEFT OF
C DECIMAL POINT.
C = 1, IF THE NUMBER IS REPRESENTED IN FLOATING
C POINT FORM AND HAS ABSOLUTE VALUE LESS THAN
C 1.0, THEN A ZERO IS NOT DISPLAYED TO LEFT OF
C DECIMAL POINT.
C = -1, SAME AS INIZRO=1 EXCEPT THAT A ZERO IS
C DISPLAYED LEFT OF THE DECIMAL POINT IF NO
C DIGITS WOULD OTHERWISE BE DISPLAYED.
C MARGIN = 0, IF THE NUMBER IS REPRESENTED IN FLOATING
C POINT FORM, AND IF A K, M OR PERCENT SIGN
C DOESN'T FOLLOW REPRESENTATION OF THE VALUE,
C THEN DO NOT ADD AN EXTRA SPACE WHERE THE K,
C M OR PERCENT SIGN WOULD OTHERWISE BE.
C = GREATER THAN ZERO, IS NUMBER OF CHARACTERS
C IN THE FIELD CONTAINING SPACES AND/OR THE K,
C M OR PERCENT SIGN TO RIGHT OF A FLOATING
C POINT NUMBER. MARGIN IS USED TO FORCE A
C FLOATING POINT NUMBER TO HAVE ITS RIGHTMOST
C DIGIT AT THE SAME POSITION AS THE RIGHTMOST
C DIGIT OF THE NORMALIZED PORTION OF A
C SCIENTIFIC NOTATION NUMBER. FOR THIS
C PURPOSE, IEXPNT WOULD BE 1 LESS THAN MARGIN.
C IF MARGIN IS GREATER THAN 1 AND A K, M OR
C PERCENT SIGN MUST BE PLACED TO RIGHT OF THE
C NUMBER, THEN THE K, M OR PERCENT SIGN IS
C PLACED AT THE LEFT OF THE FIELD OF SPACES
C WHERE THE E OF A SCIENTIFIC NOTATION NUMBER
C WOULD APPEAR AND THE FIELD THEN CONTAINS
C MARGIN-1 SPACES TO THE RIGHT OF THE K, M OR
C PERCENT SIGN. MARGIN WOULD HAVE THE VALUE 1
C IF IT IS MERELY DESIRED TO FORCE A SINGLE
C SPACE TO RIGHT OF THE NUMBER IF A K, M OR
C PERCENT SIGN DOES NOT APPEAR TO ITS RIGHT.
C
C THE FOLLOWING ARGUMENTS CONTROL FORMAT OF NUMBERS
C IN SCIENTIFIC NOTATION EITHER WITH DISPLAYED EXPONENT
C OR WITH SUPPRESSED ZERO EXPONENT (IZERO.LE.0).
C
C IDECML = SAME AS MAXDEC EXCEPT APPLIES ONLY TO
C NUMBERS DISPLAYED IN SCIENTIFIC NOTATION.
C NOTE THAT IF NUMBER IS BEING DISPLAYED IN
C SCIENTIFIC NOTATION, THEN A NONZERO DIGIT
C WILL BE USED LEFT OF THE DECIMAL POINT
C UNLESS THE VALUE IS ITSELF ZERO. THEREFORE,
C IF IDECML.GE.0, THEN THE MAXIMUM NUMBER OF
C SIGNIFICANT DIGITS WHICH CAN BE DISPLAYED IN
C SCIENTIFIC NOTATION IS IDECML+1.
C IEXPNT = MINIMUM NUMBER OF DIGITS IN THE EXPONENT IF
C VALUE IS REPRESENTED IN SCIENTIFIC NOTATION.
C IF FEWER THAN IEXPNT DIGITS ARE NEEDED IN
C EXPONENT, THESE ARE JUSTIFIED IN AN EXPONENT
C FIELD OF IEXPNT WIDTH WITH EITHER SPACES OR
C ZEROES AS FILL ACCORDING TO VALUE OF IFORMT.
C IEXPNT INCLUDES ROOM FOR SIGN (IF NEGATIVE
C EXPONENT) BUT DOES NOT INCLUDE ROOM FOR THE
C INITIAL LETTER E.
C IFORMT = 0, IF IEXPNT IS GREATER THAN THE NUMBER OF
C CHARACTERS NEEDED TO REPRESENT THE EXPONENT,
C LEFT JUSTIFY THE EXPONENT WITHIN EXPONENT
C FIELD.
C = 1, IF IEXPNT IS GREATER THAN THE NUMBER OF
C CHARACTERS NEEDED TO REPRESENT THE EXPONENT,
C RIGHT JUSTIFY THE DIGITS OF THE EXPONENT
C WITHIN THE EXPONENT FIELD. IF THE EXPONENT
C IS NEGATIVE, PLACE THE SIGN RIGHT OF THE E
C AT THE START OF THE EXPONENT. ZEROES, NOT
C SPACES, ARE USED TO FILL THE REST OF THE
C EXPONENT FIELD.
C = 2, SAME AS IFORMT=1 EXCEPT THAT SPACES, NOT
C ZEROES ARE USED TO FILL BETWEEN THE SIGN IF
C ANY AND THE DIGITS OF THE EXPONENT.
C = 3, SAME AS IFORMT=2 EXCEPT THAT THE SIGN IF
C ANY IS PLACED IMMEDIATELY TO THE LEFT OF
C THE DIGITS OF THE EXPONENT INSTEAD OF TO THE
C RIGHT OF THE E AT THE START OF THE EXPONENT.
C
C FOR EXAMPLE, IF IEXPNT IS 4, THEN THE VALUE
C 1.2E-3 WOULD BE REPRESENTED
C
C FOR IFORMT=0 1.2E-3
C IFORMT=1 1.2E-003
C IFORMT=2 1.2E- 3
C IFORMT=3 1.2E -3
C
C IZERO = -1, IF THE VALUE IS BEING REPRESENTED IN
C SCIENTIFIC NOTATION AND HAS A ZERO EXPONENT
C (VALUE OF THE NUMBER IS ZERO OR IS IN EITHER
C RANGE -9.99... TO -1.00... OR RANGE 1.00...
C TO 9.99...), THEN THE REPRESENTATION OF THE
C NUMBER WILL NOT INCLUDE AN EXPONENT FIELD.
C = 0, IF THE VALUE IS BEING REPRESENTED IN
C SCIENTIFIC NOTATION AND HAS A ZERO EXPONENT
C (VALUE OF THE NUMBER IS ZERO OR IS IN EITHER
C RANGE -9.99... TO -1.00... OR RANGE 1.00...
C TO 9.99...), THEN THE EXPONENT FIELD IS OF
C THE SAME SIZE AS IF THE EXPONENT WAS ONE BUT
C THE EXPONENT FIELD IS FILLED WITH SPACES.
C = 1, IF THE VALUE IS BEING REPRESENTED IN
C SCIENTIFIC NOTATION, THEN EXPONENT WILL BE
C DISPLAYED EVEN IF THIS EXPONENT IS ZERO.
C
C FOR EXAMPLE, IF IEXPNT IS 4, THEN THE VALUE
C 1.2 WOULD BE REPRESENTED
C
C FOR IZERO=-1 1.2
C IZERO=0 1.2
C IZERO=1 1.2E 0
C
C THE FOLLOWING ARE OUTPUT ARGUMENTS
C
C IBUFFR = ARRAY INTO WHICH THE NUMBER IS TO BE CODED
C AND WHICH CAN THEN BE PRINTED WITH MULTIPLE
C OF AN A1 FORMAT.
C KOUNT = RETURNED POINTING TO THE RIGHTMOST CHARACTER
C INSERTED INTO THE IBUFFR ARRAY. THIS WILL
C EQUAL LFTCOL+IWIDTH WHILE IFILL=1.
C IERR = -1 RETURNED IF THE FIELD WAS FILLED WITH
C ASTERISKS DUE TO FIELD OVERFLOW EVEN IN
C SCIENTIFIC NOTATION.
C = 0 RETURNED IF VALUE WAS REPRESENTED AS A
C FLOATING POINT NUMBER WITH OR WITHOUT
C FOLLOWING PERCENT SIGN, K OR M.
C = 1 OR GREATER RETURNED IF VALUE WAS
C REPRESENTED IN SCIENTIFIC NOTATION. IERR IS
C NUMBER OF DIGITS LEFT OF EXPONENT PRIOR TO
C SUPPRESSION OF RIGHTHAND ZEROES BY NONZERO
C VALUE OF KLIP.
C
DIMENSION IBUFFR(MAXBFR),IDIGIT(11),LETTER(3)
C
C 11TH NONDIGIT ITEM IN IDIGIT ACTS AS A FENCE IN CASE
C OF ROUNDING ERROR WHEN SHIFTING DIGITS OUT OF VALUE
DATA IDIGIT
1/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H*/
DATA LETTER/1H%,1HK,1HM/
DATA JEXPNT,ISTAR,IPLUS,IMINUS,IDOT,JZERO,IBLANK/
11HE,1H*,1H+,1H-,1H.,1H0,1H /
NOTE=NOTATN
IFZERO=INIZRO
JWIDTH=IWIDTH
IF(JWIDTH.GT.(MAXBFR-LFTCOL))JWIDTH=MAXBFR-LFTCOL
1 IOFSET=0
2 LTREND=LFTCOL+JWIDTH
C
C FIND ABSOLUTE VALUE OF NUMBER TO REPRESENT
ABSVLU=VALUE
MINUS=0
IF(ABSVLU.LT.0.0)GO TO 5
IF(ABSVLU.EQ.0.0)GO TO 3
IF(ISIGN.EQ.0)GO TO 7
IF(ISIGN.EQ.1)GO TO 4
MINUS=2
GO TO 6
3 MAXEXP=-1
IF(ISIGN.LE.0)GO TO 11
MINUS=1
LTREND=LTREND-1
GO TO 11
4 MINUS=1
GO TO 6
5 ABSVLU=-ABSVLU
MINUS=-1
6 LTREND=LTREND-1
C
C NORMALIZE THE ABSOLUTE VALUE
C MAXEXP = ABSULUTE VALUE OF MAXIMUM EXPONENT
C = LEFT =-1 IF UNDERFLOW OR OVERFLOW
7 MAXEXP=100
KEXPNT=IOFSET
8 IF(ABSVLU.LT.10.0)GO TO 9
ABSVLU=ABSVLU/10.0
KEXPNT=KEXPNT+1
IF(KEXPNT.LE.IOFSET)GO TO 12
GO TO 10
9 IF(ABSVLU.GE.1.0)GO TO 12
IF(KEXPNT.GT.IOFSET)GO TO 12
ABSVLU=ABSVLU*10.0
KEXPNT=KEXPNT-1
10 MAXEXP=MAXEXP-1
IF(MAXEXP.GE.0)GO TO 8
ABSVLU=0.0
11 KEXPNT=0
C
C ADJUST EXPONENT IF PERCENT, K OR M NOTATION
C INOTE = SUBSCRIPT IN LETTER ARRAY OF PERCENT SIGN,
C K OR M TO BE ADDED AT RIGHT OF NUMBER
C KDECML = NUMBER OF DIGITS TO SHIFT
12 IRIGHT=0
IF(NOTE.LT.0)GO TO 25
IMINDE=MINDEC
IMAXDE=MAXDEC
IF(NOTE.EQ.0)GO TO 16
IF(NOTE.NE.1)GO TO 13
INOTE=1
KDECML=-2
GO TO 15
13 IF(KEXPNT.LT.3)GO TO 16
IF(KEXPNT.GE.6)GO TO 14
INOTE=2
KDECML=3
GO TO 15
14 INOTE=3
KDECML=6
15 IF(MARGIN.GT.0)IRIGHT=MARGIN-1
LTREND=LTREND-1
GO TO 17
16 IF(MARGIN.LE.0)GO TO 19
INOTE=-1
IRIGHT=MARGIN
KDECML=0
17 LTREND=LTREND-IRIGHT
IF(MAXEXP.LT.0)GO TO 20
KEXPNT=KEXPNT-KDECML
IF(NOTATN.LT.3)GO TO 20
IF(KDECML.LE.0)GO TO 20
IF(IMINDE.LT.-1)GO TO 18
IMINDE=KDECML
IF(MINDEC.GE.0)IMINDE=MINDEC+IMINDE
18 IF(IMAXDE.LT.-1)GO TO 20
IMAXDE=KDECML
IF(MAXDEC.GE.0)IMAXDE=MAXDEC+IMAXDE
GO TO 20
19 INOTE=0
C
C DECIDE FORMAT IF NUMBER NOT IN SCIENTIFIC NOTATION
C JPOINT = LOCATION IN IBUFFR OF FINAL PRINTING DIGIT
C LWIDE = NUMBER OF DIGITS TO PRINT RIGHT OF DECIMAL
C POINT
C = -1, INCLUDE NEITHER DECIMAL POINT NOR DIGITS
C WHICH WOULD BE RIGHT OF DECIMAL POINT
C MWIDE = NUMBER OF CHARACTERS NEEDED FOR EXPONENT
C = 0, DON'T INCLUDE EXPONENT
20 JPOINT=LFTCOL
LEXPNT=KEXPNT+1
IF(IFZERO.EQ.0)GO TO 22
IF(MAXEXP.LT.0)GO TO 21
IF(KEXPNT.GE.0)GO TO 22
KEXPNT=KEXPNT+1
21 JPOINT=JPOINT-1
22 IF(KEXPNT.GT.0)JPOINT=JPOINT+KEXPNT
LWIDE=LTREND-JPOINT-2
IF(LWIDE.LT.-1)GO TO 44
MWIDE=0
IF(IMAXDE.LT.-1)GO TO 23
IF(LWIDE.GT.IMAXDE)LWIDE=IMAXDE
23 IF(MAXEXP.LT.0)GO TO 24
IF(MAXSIG.LE.0)GO TO 24
I=MAXSIG-LEXPNT
IF(I.LT.0)GO TO 44
IF(LWIDE.GT.I)LWIDE=I
24 IF(LWIDE.LT.IMINDE)GO TO 44
GO TO 32
C
C DECIDE FORMAT IF NUMBER IN SCIENTIFIC NOTATION
25 MWIDE=2
LWIDE=LTREND-LFTCOL-2
IF(KEXPNT.NE.0)GO TO 26
IF(IZERO.LT.0)GO TO 30
26 I=KEXPNT
IF(I.GE.0)GO TO 27
MWIDE=MWIDE+1
I=-I
27 IF(I.LT.10)GO TO 28
MWIDE=MWIDE+1
I=I/10
GO TO 27
28 NWIDE=MWIDE
IF(MWIDE.LE.IEXPNT)MWIDE=IEXPNT+1
IF(IPART.EQ.0)GO TO 29
IF(MWIDE.LE.JWIDTH)GO TO 30
29 LWIDE=LWIDE-MWIDE
30 IF(LWIDE.LT.-1)GO TO 85
JPOINT=LFTCOL
IF(IDECML.LT.-1)GO TO 31
IF(LWIDE.GT.IDECML)LWIDE=IDECML
31 IERR=LWIDE+1
IF(IERR.LE.0)IERR=1
32 IF(LWIDE.GT.0)JPOINT=JPOINT+LWIDE
JPOINT=JPOINT+1
C
C SHIFT OUT THE DIGITS
I=LFTCOL
J=IOFSET
IF(MWIDE.NE.0)GO TO 33
IF(KEXPNT.LT.0)J=J-KEXPNT
33 LAST=ABSVLU
IF(J.GT.0)LAST=0
IF(I.GE.JPOINT)GO TO 34
I=I+1
IBUFFR(I)=IDIGIT(LAST+1)
J=J-1
IF(J.GE.0)GO TO 33
ABSVLU=ABSVLU-FLOAT(LAST)
IF(ABSVLU.LT.0.0)ABSVLU=0.0
ABSVLU=10.0*ABSVLU
GO TO 33
C
C ROUND
34 I=LFTCOL
35 I=I+1
IF(I.GT.JPOINT)GO TO 36
IF(IBUFFR(I).NE.IDIGIT(11))GO TO 35
GO TO 39
36 IF(LAST.LE.4)GO TO 42
LAST=0
37 I=I-1
IF(I.LE.LFTCOL)GO TO 41
J=1
38 IF(IBUFFR(I).EQ.IDIGIT(J))GO TO 40
J=J+1
IF(J.LT.10)GO TO 38
39 IBUFFR(I)=JZERO
GO TO 37
40 IBUFFR(I)=IDIGIT(J+1)
IF((LFTCOL-KEXPNT).GE.I)LEXPNT=LEXPNT+1
GO TO 35
41 IOFSET=IOFSET+1
GO TO 2
C
C TEST IF HAVE ENOUGH SIGNIFICANT DIGITS
C (ROUNDING CAN INCREASE NUMBER SO MUST DO NOW)
42 IF(MWIDE.NE.0)GO TO 45
IF(MAXEXP.LT.0)GO TO 45
I=LEXPNT
IF(LWIDE.GT.0)I=I+LWIDE
IF(I.LT.0)I=0
IF(MAXSIG.LE.0)GO TO 43
IF(I.GT.MAXSIG)GO TO 41
43 IF(I.GE.MINSIG)GO TO 45
C
C FLOATING POINT WILL NOT FIT SO FORCE SCIENTIFIC
44 NOTE=-1
GO TO 1
C
C INSERT PERIOD AND/OR TRIM OFF RIGHTMOST ZEROES
45 JRIGHT=IRIGHT
J=JPOINT
IF(LWIDE.GE.0)JPOINT=JPOINT+1
I=JPOINT
L=KLIP
46 IF(LWIDE.GE.0)GO TO 47
IF(J.LE.LFTCOL)GO TO 57
GO TO 49
47 LWIDE=LWIDE-1
IF(LWIDE.GE.0)GO TO 48
J=J+1
IF(L.LE.-3)GO TO 53
IF(L.GE.3)GO TO 50
IBUFFR(I)=IDOT
GO TO 56
48 IF(J.LE.LFTCOL)GO TO 56
49 IF(L.EQ.0)GO TO 55
IF(IBUFFR(J).NE.JZERO)GO TO 55
IF(LWIDE.LT.0)GO TO 55
IF(KLIP.LE.-2)GO TO 53
IF(KLIP.GE.2)GO TO 50
IF(LWIDE.LE.0)GO TO 55
IF(KLIP.LT.0)GO TO 53
50 IF(MWIDE.NE.0)GO TO 51
IF(INOTE.GT.0)GO TO 54
GO TO 52
51 IF(IPART.NE.0)GO TO 52
IF(IZERO.GT.0)GO TO 54
IF(KEXPNT.NE.0)GO TO 54
52 IRIGHT=IRIGHT+1
53 JPOINT=JPOINT-1
GO TO 56
54 IBUFFR(I)=IBLANK
GO TO 56
55 IBUFFR(I)=IBUFFR(J)
IFZERO=0
L=0
56 I=I-1
J=J-1
GO TO 46
C
C INSURE THAT SHOW AT LEAST 1 DIGIT IF INIZRO.LT.0
57 IF(IFZERO.EQ.0)GO TO 58
IF(IFZERO.GT.0)GO TO 82
IFZERO=0
GO TO 1
C
C INSERT EXPONENT
58 IF(IPART.LE.0)GO TO 59
IRIGHT=JRIGHT
JPOINT=LFTCOL
INOTE=0
MINUS=0
59 LTREND=LFTCOL+JWIDTH
IF(MWIDE.EQ.0)GO TO 69
IF(IPART.LT.0)GO TO 70
IF(KEXPNT.NE.0)GO TO 60
IF(IZERO.LT.0)GO TO 70
IF(IZERO.EQ.0)GO TO 68
60 K=JPOINT+1
IBUFFR(K)=JEXPNT
L=0
IF(KEXPNT.GE.0)GO TO 62
KEXPNT=-KEXPNT
IF(IFORMT.EQ.3)GO TO 61
K=K+1
IBUFFR(K)=IMINUS
GO TO 62
61 L=1
62 IF(IFORMT.NE.0)GO TO 63
JPOINT=JPOINT+NWIDE
IRIGHT=IRIGHT+MWIDE-NWIDE
GO TO 64
63 JPOINT=JPOINT+MWIDE
64 I=JPOINT
65 J=KEXPNT
KEXPNT=KEXPNT/10
J=J-(10*KEXPNT)+1
IBUFFR(I)=IDIGIT(J)
IF(J.NE.1)GO TO 67
IF(I.EQ.JPOINT)GO TO 67
IF(KEXPNT.NE.0)GO TO 67
IF(IFORMT.EQ.1)GO TO 67
IF(L.EQ.0)GO TO 66
L=0
IBUFFR(I)=IMINUS
GO TO 67
66 IBUFFR(I)=IBLANK
67 I=I-1
IF(I.GT.K)GO TO 65
GO TO 70
C
C BLANK OUT A ZERO EXPONENT
68 IRIGHT=IRIGHT+MWIDE
GO TO 70
C
C INSERT PERCENT SIGN, K OR M
69 IERR=0
IF(INOTE.LE.0)GO TO 70
JPOINT=JPOINT+1
IBUFFR(JPOINT)=LETTER(INOTE)
C
C JUSTIFY THE NUMBER
70 IF(JPOINT.EQ.LFTCOL)GO TO 83
J=LTREND-JPOINT-IRIGHT
IF(MINUS.EQ.0)GO TO 71
IF(J.LE.1)GO TO 76
IF(JSTIFY.GE.0)GO TO 72
J=1
GO TO 76
71 IF(JSTIFY.LT.0)GO TO 83
72 IF(JSTIFY.NE.0)GO TO 75
IF(MINUS.LT.0)GO TO 73
IF(MINUS.NE.2)GO TO 74
73 J=J+1
74 IF(JWIDTH.EQ.(2*(JWIDTH/2)))J=J+1
J=J/2
75 IF(J.LE.0)GO TO 83
76 I=JPOINT
J=J+JPOINT
JPOINT=J
77 IF(I.LE.LFTCOL)GO TO 78
IBUFFR(J)=IBUFFR(I)
J=J-1
I=I-1
GO TO 77
78 IF(MINUS.LT.0)GO TO 79
IF(MINUS.NE.2)GO TO 81
IBUFFR(J)=IPLUS
GO TO 80
79 IBUFFR(J)=IMINUS
80 J=J-1
81 IF(J.LE.LFTCOL)GO TO 83
IBUFFR(J)=IBLANK
GO TO 80
C
C FILL OUT REST OF FIELD WITH BLANKS
82 JPOINT=LFTCOL
LTREND=LFTCOL+JWIDTH
83 IF(IFILL.LE.0)GO TO 87
84 IF(JPOINT.GE.LTREND)GO TO 87
JPOINT=JPOINT+1
IBUFFR(JPOINT)=IBLANK
GO TO 84
C
C FILL FIELD WITH ASTERISKS IF NUMBER CANNOT FIT
85 JPOINT=LFTCOL
LTREND=LFTCOL+JWIDTH
IERR=-1
86 IF(JPOINT.GE.LTREND)GO TO 87
JPOINT=JPOINT+1
IBUFFR(JPOINT)=ISTAR
GO TO 86
C
C RETURN TO CALLING PROGRAM
87 KOUNT=JPOINT
RETURN
C762754596768%
END
SUBROUTINE DAROME(KONTRL,NUMBER,LETTER,KOUNT,LFTCOL,
1MAX)
C RENBR(/ROMAN NUMERAL GENERATOR)
C
C DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERISTY
C
C KONTRL = 0, LEFT JUSTIFIES AT LFTCOL OR AT KOUNT+1
C IF KOUNT IS GREATER THAN LFTCOL.
C = 1, RIGHT JUSTIFIES AT LFTCOL.
C NUMBER = NUMBER TO BE REPRESENTED.
C LETTER = ARRAY TO RECIEVE ALPHAMERIC CODES.
C KOUNT = INPUT CONTAINING THE NUMBER OF LOCATIONS
C IN LETTER ARRAY ALREADY IN USE AND TO BE
C PRESERVED. OUTPUT CONTAINING NUMBER OF
C LOCATIONS IN USE INCLUDING THOSE USED
C FOR THE ROMAN NUMERAL. KOUNT IS RETURNED
C UNCHANGED IF AN ERROR TOOK PLACE
C (EITHER A NUMBER OUTSIDE RANGE WHICH CAN
C BE REPRESENTED, OR INSUFFICIENT ROOM).
C LFTCOL = LOCATION OF NEW NUMBER.
C = CHARACTERS LEFT OF NUMBER IF KONTRL = 0.
C = POSITION OF RIGHT DIGIT IF KONTRL = 1.
C MAX = DIMENSION OF LETTER ARRAY.
C
DIMENSION LETTER(MAX),IROME(7)
DATA IROME/1HI,1HV,1HX,1HL,1HC,1HD,1HM/
DATA IBLANK/1H /
C
C DISECT NUMBER
IF(NUMBER.GT.3999)GO TO 15
C REMOVE FOLLOWING STATEMENT TO SHOW ZERO AS SPACES
IF(NUMBER.LE.0)GO TO 15
N=KOUNT+1
I=NUMBER
K=-1
1 M=KOUNT
IF(I.LT.0)GO TO 15
IF(I.EQ.0)GO TO 5
J=I
I=I/10
J=J-10*I
K=K+2
L=0
IF(J.LE.3)GO TO 4
L=K+1
J=J-5
IF(J.NE.4)GO TO 2
L=L+1
J=-1
C
C INSERT INITIAL ONE'S CHARACTER
2 IF(J.NE.-1)GO TO 3
IF(KOUNT.GE.MAX)GO TO 14
KOUNT=KOUNT+1
LETTER(KOUNT)=IROME(K)
C
C INSERT FIVE'S OR TEN'S CHARACTER
3 IF(L.EQ.0)GO TO 4
IF(KOUNT.GE.MAX)GO TO 14
KOUNT=KOUNT+1
LETTER(KOUNT)=IROME(L)
C
C INSERT UP TO 3 ONE'S CHARACTERS
4 IF(J.LE.0)GO TO 9
IF(KOUNT.GE.MAX)GO TO 14
KOUNT=KOUNT+1
LETTER(KOUNT)=IROME(K)
J=J-1
GO TO 4
C
C ADJUST MARGINS AND INSERT FILLER BLANKS IF NEEDED
5 IF(KONTRL.EQ.0)GO TO 6
IF(KOUNT.GT.LFTCOL)GO TO 14
KOUNT=LFTCOL
GO TO 7
6 KOUNT=KOUNT+LFTCOL-N+1
IF(LFTCOL.LT.(N-1))KOUNT=M+1
7 IF(KOUNT.EQ.M)GO TO 15
IF(KOUNT.GT.MAX)GO TO 14
J=M+1
DO 8 I=J,KOUNT
8 LETTER(I)=IBLANK
I=-1
C
C SHIFT NEW NUMERALS INTO LEFT END OF ARRAY.
C THIS IS A GENERAL PROCEDURE TO SWAP ADJACENT
C SECTIONS WITHIN AN ARRAY. THE LOWER SECTION
C EXTENDS FROM N THROUGH M. THE UPPER SECION
C EXTENDS FROM M+1 THROUGH KOUNT.
9 IF(N.GT.M)GO TO 1
IF(M.EQ.KOUNT)GO TO 1
II=0
JJ=KOUNT
10 J=N+JJ-M-1
KK=LETTER(JJ)
11 II=II+1
L=LETTER(J)
LETTER(J)=KK
KK=L
IF(J.GT.M)GO TO 12
J=J+KOUNT-M
GO TO 11
12 IF(J.EQ.JJ)GO TO 13
J=N+J-M-1
GO TO 11
13 IF(II.EQ.(KOUNT-N+1))GO TO 1
JJ=JJ-1
GO TO 10
C
C RETURN TO CALLING PROGRAM
14 KOUNT=N-1
15 RETURN
C336670692127
END
SUBROUTINE DALEAD(INITYP,NXTTYP,ITRAIL,KWRDLO,KWRDHI,
1 KWORD ,KCNTLO,KCNTHI,KCOUNT,NUMTYP,LWRDLO,LWRDHI,
2 LWORD ,LCNTLO,LCNTHI,LCOUNT,IBUFFR,MAXBFR,LOWBFR,
3 KIND ,KOMAND,KWRDID,KCNTID,LOCAL ,LWRDID,LCNTID,
4 INITAL,IVALUE,VALUE ,IFLOAT)
C RENBR(/RETURN COMMAND AND NUMERIC OR WORD ARGUMENT)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO IDENTIFY A COMMAND WORD AND A FOLLOWING
C ASSOCIATED WORD, ASSOCIATED NUMBER OR ASSOCIATED TEXT
C STRING WHICH IS MARKED AT BOTH ENDS BY APOSTROPHES.
C
C THE FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY, AND
C ARE RETURNED UNCHANGED.
C
C INITYP = IF REPRESENTATION OF NUMBER IS FOUND OUTSIDE
C RANGE OF COMMAND, THEN INITYP SPECIFIES
C WHETHER VALUE IS TO BE RETURNED AS INTEGER
C ARGUMENT IVALUE OR AS REAL ARGUMENT VALUE.
C NUMBER CAN BE TYPED WITH DECIMAL POINT
C AND/OR EXPONENT REGARDLESS OF VALUE OF
C INITYP.
C = -2, IF REPRESENTATION OF NUMBER IS FOUND
C OUTSIDE RANGE OF COMMAND, THEN IT IS TREATED
C AS UNKNOWN SEQUENCE OF CHARACTERS, AND KIND
C IS RETURNED CONTAINING VALUE 7.
C = -1, VALUE IS CALCULATED AS OCTAL INTEGER AND
C RETURNED AS ARGUMENT IVALUE. HOWEVER,
C NUMBER FOLLOWING LETTER E OF EXPONENT IS
C EVALUATED IN DECIMAL.
C = 0, VALUE IS CALCULATED AS DECIMAL INTEGER
C AND IS RETURNED AS ARGUMENT IVALUE.
C = 1 OR GREATER, VALUE IS RETURNED AS REAL
C ARGUMENT VALUE. IF POSSIBLE, REAL NUMBER
C WILL BE ACCUMULATED AS INTEGER, THEN BE
C CONVERTED TO REAL AND SHIFTED AS NECESSARY.
C INITYP IS MAXIMUM NUMBER OF DIGITS IN
C INTEGER.
C NXTTYP = IF REPRESENTATION OF NUMBER IS FOUND WITHIN
C RANGE OF COMMAND, THEN NXTTYP SPECIFIES
C WHETHER VALUE IS TO BE RETURNED AS INTEGER
C ARGUMENT IVALUE OR AS REAL ARGUMENT VALUE.
C NUMBER CAN BE TYPED WITH DECIMAL POINT
C AND/OR EXPONENT REGARDLESS OF VALUE OF
C NXTTYP.
C = -3, WHETHER NUMBER IS INTERPRETED AS OCTAL
C INTEGER OR AS DECIMAL INTEGER OR AS DECIMAL
C REAL, AND WHETHER VALUE IS RETURNED IN
C ARGUMENT IVALUE OR VALUE IS SPECIFIED BY
C NUMTYP ARRAY ENTRY HAVING SAME SUBSCRIPT AS
C KCOUNT ARRAY ENTRY CONTAINING NUMBER OF
C CHARACTERS IN COMMAND. CALLING PROGRAM MUST
C NOT CHANGE VALUE OF KCNTID RETURNED BY
C PREVIOUS CALL TO THIS ROUTINE IF NXTTYP IS
C SET TO -3.
C = -2, IF REPRESENTATION OF NUMBER IS FOUND
C WITHIN RANGE OF COMMAND, THEN IT IS TREATED
C AS UNKNOWN SEQUENCE OF CHARACTERS, AND KIND
C IS RETURNED CONTAINING VALUE 7 OR 14
C DEPENDING UPON WHETHER COMMAND WORD WAS
C FOUND BY CURRENT CALL TO THIS ROUTINE.
C = -1, VALUE IS CALCULATED AS OCTAL INTEGER AND
C RETURNED AS ARGUMENT IVALUE. HOWEVER,
C NUMBER FOLLOWING LETTER E OF EXPONENT IS
C EVALUATED IN DECIMAL.
C = 0, VALUE IS CALCULATED AS DECIMAL INTEGER
C AND IS RETURNED AS ARGUMENT IVALUE.
C = 1 OR GREATER, VALUE IS RETURNED AS REAL
C ARGUMENT VALUE. IF POSSIBLE, REAL NUMBER
C WILL BE ACCUMULATED AS INTEGER, THEN BE
C CONVERTED TO REAL AND SHIFTED AS NECESSARY.
C NXTTYP IS MAXIMUM NUMBER OF DIGITS IN
C INTEGER.
C ITRAIL = SELECTS WHETHER EXPONENTS ARE TO BE
C RECOGNIZED. IF NOT, THEN EACH NUMBER WILL
C TERMINATE PRIOR TO EXPONENT, AND LOWBFR WILL
C BE RETURNED POINTING TO LETTER STARTING
C EXPONENT.
C = -1, EXPONENTS EXPRESSED IN E NOTATION ARE TO
C BE RECOGNIZED, BUT PERCENT SIGN AND LETTERS
C K AND M ARE TO BE TREATED SAME AS ANY OTHER
C ALPHABETIC CHARACTERS.
C = 0, NO EXPONENTS ARE TO BE RECOGNIZED.
C NUMBERS WILL BE TERMINATED PRIOR TO PERCENT
C SIGNS OR TO LETTERS E OR K OR M.
C = 1, PERCENT SIGNS, LETTERS K AND M, AND
C EXPONENTS EXPRESSED IN E NOTATION ARE ALL TO
C BE RECOGNIZED.
C KWRDLO = SUBSCRIPT OF LOCATION IN KWORD ARRAY
C CONTAINING FIRST CHARACTER OF FIRST COMMAND
C WORD WHICH CAN BE RECOGNIZED.
C KWRDHI = SUBSCRIPT OF LOCATION IN KWORD ARRAY
C CONTAINING FINAL CHARACTER OF FINAL COMMAND
C WORD WHICH CAN BE RECOGNIZED.
C KWORD = ARRAY CONTAINING CHARACTERS OF COMMAND WORDS
C WHICH CAN BE RECOGNIZED, 1 CHARACTER PER
C ARRAY LOCATION AS THOUGH READ BY MULTIPLE OF
C A1 FORMAT OR DEFINED BY SEVERAL 1H FIELDS.
C KCNTLO = SUBSCRIPT OF LOCATION IN KCOUNT ARRAY
C CONTAINING NUMBER OF CHARACTERS IN FIRST
C COMMAND WORD WHICH CAN BE RECOGNIZED. IF
C KCNTLO IS GREATER THAN KCNTHI, THEN NO
C COMMAND WORDS CAN BE RECOGNIZED, CAUSING
C KIND TO ALWAYS BE RETURNED CONTAINING 7 OR
C LESS.
C KCNTHI = SUBSCRIPT OF LOCATION IN KCOUNT ARRAY
C CONTAINING NUMBER OF CHARACTERS IN FINAL
C COMMAND WORD WHICH CAN BE RECOGNIZED.
C KCOUNT = ARRAY CONTAINING IN LOCATIONS KCOUNT(KCNTLO)
C THROUGH AND INCLUDING KCOUNT(KCNTHI) NUMBERS
C OF CHARACTERS IN EACH OF SEVERAL COMMAND
C WORDS WHICH CAN BE RECOGNIZED. NEGATIVE
C ENTRY IN KCOUNT ARRAY CAUSES NUMBER OF
C CHARACTERS INDICATED BY ABSOLUTE VALUE OF
C NEGATIVE NUMBER TO BE SKIPPED OVER IN KWORD
C ARRAY WITHOUT FORMING RECOGNIZABLE WORD.
C NUMTYP = SPECIFIES MANNER IN WHICH NUMBER IS
C EVALUATED IF NUMBER IS WITHIN RANGE OF
C COMMAND AND IF NXTTYP=-3. WHETHER NUMBER IS
C INTERPRETED AS OCTAL INTEGER OR AS DECIMAL
C INTEGER OR AS DECIMAL REAL, AND WHETHER
C VALUE IS RETURNED IN ARGUMENT IVALUE OR
C VALUE IS SPECIFIED BY NUMTYP ARRAY ENTRY
C HAVING SAME SUBSCRIPT AS KCOUNT ARRAY ENTRY
C CONTAINING NUMBER OF CHARACTERS IN COMMAND.
C IF NXTTYP IS GREATER THAN -3, THEN NUMTYP
C ARRAY IS IGNORED. VALUES OF INDIVIDUAL
C ENTRIES WITHIN NUMTYP ARRAY ARE DEFINED
C SIMILARLY TO THOSE OF NONDIMENSIONED
C ARGUMENT NXTTYP (OTHER THAN NXTTYP=-3) AND
C ARE AS FOLLOW
C = -2, IF REPRESENTATION OF NUMBER IS FOUND
C WITHIN RANGE OF COMMAND, THEN IT IS TREATED
C AS UNKNOWN SEQUENCE OF CHARACTERS, AND KIND
C IS RETURNED CONTAINING VALUE 7 OR 14
C DEPENDING UPON WHETHER COMMAND WORD WAS
C FOUND BY CURRENT CALL TO THIS ROUTINE.
C = -1, VALUE IS CALCULATED AS OCTAL INTEGER AND
C RETURNED AS ARGUMENT IVALUE. HOWEVER,
C NUMBER FOLLOWING LETTER E OF EXPONENT IS
C EVALUATED IN DECIMAL.
C = 0, VALUE IS CALCULATED AS DECIMAL INTEGER
C AND IS RETURNED AS ARGUMENT IVALUE.
C = 1 OR GREATER, VALUE IS RETURNED AS REAL
C ARGUMENT VALUE. IF POSSIBLE, REAL NUMBER
C WILL BE ACCUMULATED AS INTEGER, THEN BE
C CONVERTED TO REAL AND SHIFTED AS NECESSARY.
C NUMTYP(KCNTID) IS MAXIMUM NUMBER OF DIGITS
C IN INTEGER.
C LWRDLO = SUBSCRIPT OF LOCATION IN LWORD ARRAY
C CONTAINING FIRST CHARACTER OF FIRST
C ASSOCIATED WORD WHICH CAN BE RECOGNIZED.
C LWRDHI = SUBSCRIPT OF LOCATION IN LWORD ARRAY
C CONTAINING FINAL CHARACTER OF FINAL
C ASSOCIATED WORD WHICH CAN BE RECOGNIZED.
C LWORD = ARRAY CONTAINING CHARACTERS OF ASSOCIATED
C WORDS WHICH CAN BE RECOGNIZED, 1 CHARACTER
C PER ARRAY LOCATION AS THOUGH READ BY
C MULTIPLE OF A1 FORMAT OR DEFINED BY SEVERAL
C 1H FIELDS.
C LCNTLO = SUBSCRIPT OF LOCATION IN LCOUNT ARRAY
C CONTAINING NUMBER OF CHARACTERS IN FIRST
C ASSOCIATED WORD WHICH CAN BE RECOGNIZED. IF
C LCNTLO IS GREATER THAN LCNTHI, THEN NO
C ASSOCIATED WORDS CAN BE RECOGNIZED SO THAT
C KIND CANNOT BE RETURNED WITH EITHER OF
C VALUES 4 OR 11.
C LCNTHI = SUBSCRIPT OF LOCATION IN LCOUNT ARRAY
C CONTAINING NUMBER OF CHARACTERS IN FINAL
C ASSOCIATED WORD WHICH CAN BE RECOGNIZED.
C LCOUNT = ARRAY CONTAINING IN LOCATIONS LCOUNT(LCNTLO)
C THROUGH AND INCLUDING LCOUNT(LCNTHI) NUMBERS
C OF CHARACTERS IN EACH OF SEVERAL ASSOCIATED
C WORDS WHICH CAN BE RECOGNIZED. NEGATIVE
C ENTRY IN LCOUNT ARRAY CAUSES NUMBER OF
C CHARACTERS INDICATED BY ABSOLUTE VALUE OF
C NEGATIVE NUMBER TO BE SKIPPED OVER IN LWORD
C ARRAY WITHOUT FORMING RECOGNIZABLE WORD.
C IBUFFR = INPUT BUFFER ARRAY, CONTAINING CHARACTERS
C TYPED BY USER AND READ BY MULTIPLE OF A1
C FORMAT, WHICH IS TO BE SEARCHED FOR KNOWN
C COMMAND WORDS, KNOWN ASSOCIATED WORDS,
C NUMBERS AND QUOTED TEXT STRINGS. IBUFFR
C THEN CONTAINS 1 CHARACTER PER COMPUTER
C STORAGE LOCATION.
C MAXBFR = SUBSCRIPT OF FINAL (RIGHTMOST) LOCATION IN
C IBUFFR ARRAY WHICH CAN BE SEARCHED FOR KNOWN
C WORDS, NUMBERS AND QUOTED TEXT STRINGS.
C
C THE FOLLOWING ARGUMENTS MUST BE SET BY CALLING
C PROGRAM BEFORE THIS ROUTINE IS FIRST CALLED, THEN ARE
C RETURNED BY THIS ROUTINE CONTAINING INFORMATION TO BE
C USED BY CALLING PROGRAM AND, USUALLY, TO BE PASSED
C UNCHANGED TO SUBSEQUENT CALL TO THIS ROUTINE.
C
C LOWBFR = SHOULD BE INPUT CONTAINING SUBSCRIPT WITHIN
C IBUFFR ARRAY OF FIRST (LEFTMOST) CHARACTER
C WHICH CAN BE SCANNED FOR KNOWN WORDS AND
C NUMBERS AND QUOTED TEXT STRINGS. LOWBFR IS
C RETURNED CONTAINING SUBSCRIPT OF IBUFFR
C ARRAY LOCATION TO RIGHT OF RIGHTMOST
C CHARACTER OF RIGHTMOST IDENTIFIED ITEM.
C KIND = INPUT CONTAINING 0, THIS ROUTINE HAS NOT YET
C BEEN CALLED DURING EXECUTION OF CURRENT
C LOGICAL SECTION OF CALLING PROGRAM. THIS
C ROUTINE IS TO BEGIN EVALUATION OF CONTENTS
C OF INPUT TEXT BUFFER, NOT CONTINUE RANGE OF
C COMMAND WORD IDENTIFIED BY PREVIOUS CALL TO
C THIS ROUTINE. THE FOLLOWING VALUES OF KIND
C ARE RETURNED TO CALLING PROGRAM DESCRIBING
C TYPE OF ITEM OR ITEMS LOCATED IN IBUFFR
C ARRAY. EXCEPT WHERE MENTIONED BELOW, THESE
C VALUES ARE USUALLY PASSED UNCHANGED TO
C SUBSEQUENT CALL TO THIS ROUTINE.
C = 1, EITHER INPUT BUFFER WAS EMPTY, OR ELSE
C NEXT PRINTING CHARACTER AT OR TO RIGHT OF
C IBUFFR(LOWBFR), IGNORING COMMAS, WAS
C EXCLAMATION POINT. LOWBFR IS RETURNED
C POINTING BEYOND END OF BUFFER. IT IS
C EXPECTED THAT CALLING PROGRAM WILL READ NEW
C TEXT INTO INPUT BUFFER AND RESET LOWBFR TO
C POINT TO FIRST CHARACTER IN BUFFER BEFORE
C AGAIN CALLING THIS ROUTINE. UNLESS KIND IS
C CHANGED TO 3 BY CALLING PROGRAM, SUBSEQUENT
C CALL TO THIS ROUTINE WILL RETURN KOMAND
C ZEROED IF NEW COMMAND WORD IS NOT
C IDENTIFIED.
C = 2, NEXT PRINTING CHARACTER AT OR TO RIGHT OF
C IBUFFR(LOWBFR), IGNORING COMMAS, WAS
C SEMICOLON. LOWBFR IS RETURNED POINTING TO
C CHARACTER TO RIGHT OF SEMICOLON. THE
C SUBSEQUENT CALL TO THIS ROUTINE WILL RETURN
C KOMAND ZEROED IF NEW COMMAND WORD IS NOT
C IDENTIFIED.
C = 3, NEXT PRINTING CHARACTER AT OR TO RIGHT OF
C IBUFFR(LOWBFR), IGNORING COMMAS, WAS
C AMPERSAND. LOWBFR IS RETURNED CONTAINING
C MAXBFR+1. IT IS EXPECTED THAT CALLING
C PROGRAM WILL READ NEW TEXT INTO INPUT BUFFER
C AND RESET LOWBFR TO POINT TO FIRST CHARACTER
C IN BUFFER BEFORE AGAIN CALLING THIS ROUTINE.
C UNLESS KIND IS CHANGED TO 1 BY CALLING
C PROGRAM, SUBSEQUENT CALL TO THIS ROUTINE
C WILL RETURN VALUES OF KOMAND, KWRDID AND
C KCNTID UNCHANGED IF NEW COMMAND WORD IS NOT
C IDENTIFIED.
C = 4, NEXT PRINTING CHARACTERS AT OR TO RIGHT
C OF IBUFFR(LOWBFR), IGNORING COMMAS EXCEPT
C FOR THEIR USE AS WORD SEPARATORS, UNIQUELY
C IDENTIFIED ASSOCIATED WORD IN DICTIONARY
C CONTAINED IN LWORD AND LCOUNT ARRAYS.
C INITAL IS RETURNED CONTAINING SUBSCRIPT OF
C IBUFFR ARRAY LOCATION WHICH CONTAINS FIRST
C CHARACTER OF ASSOCIATED WORD OR ABBREVIATION
C OF ASSOCIATED WORD. LOWBFR IS RETURNED
C POINTING TO CHARACTER TO RIGHT OF WORD OR
C WORD ABBREVIATION. THE SUBSEQUENT CALL TO
C THIS ROUTINE WILL RETURN VALUES OF KOMAND,
C KWRDID AND KCNTID UNCHANGED IF NEW COMMAND
C WORD IS NOT IDENTIFIED.
C = 5, NEXT PRINTING CHARACTERS AT OR TO RIGHT
C OF IBUFFR(LOWBFR), IGNORING COMMAS EXCEPT
C FOR THEIR USE AS NUMBER SEPARATORS, FORMED
C NUMBER. THE VALUE OF NUMBER IS RETURNED IN
C ARGUMENT IVALUE IF RETURNED AS INTEGER OR IN
C ARGUMENT VALUE IF RETURNED AS REAL NUMBER.
C INITAL IS RETURNED CONTAINING SUBSCRIPT OF
C IBUFFR ARRAY LOCATION WHICH CONTAINS FIRST
C CHARACTER OF NUMBER. LOWBFR IS RETURNED
C POINTING TO CHARACTER TO RIGHT OF NUMBER.
C THE SUBSEQUENT CALL TO THIS ROUTINE WILL
C RETURN VALUES OF KOMAND, KWRDID AND KCNTID
C UNCHANGED IF NEW COMMAND WORD IS NOT
C IDENTIFIED.
C = 6, NEXT PRINTING CHARACTER AT OR TO RIGHT OF
C IBUFFR(LOWBFR), IGNORING LEADING COMMAS, WAS
C APOSTROPHE WHICH IS POINTED TO BY RETURNED
C VALUE OF INITAL. LOWBFR IS RETURNED
C POINTING TO CHARACTER TO RIGHT OF RIGHTMOST
C CHARACTER WITHIN QUOTED TEXT STRING. IF
C QUOTED TEXT STRING IS NOT TERMINATED BY
C UNPAIRED APOSTROPHE, THEN LOWBFR IS RETURNED
C POINTING TO CHARACTER TO RIGHT OF RIGHTMOST
C PRINTING CHARACTER IN BUFFER. IF QUOTED
C TEXT STRING IS TERMINATED BY UNPAIRED
C APOSTROPHE, THEN THIS APOSTROPHE IS CHANGED
C TO SPACE POINTED TO BY RETURNED VALUE OF
C LOWBFR. IF PAIR OF ADJACENT APOSTROPHES IS
C FOUND WITHIN QUOTED TEXT STRING, THEN
C PORTION OF QUOTED TEXT STRING TO RIGHT OF
C PAIR OF APOSTROPHES IS MOVED TO LEFT
C OVERWRITING SECOND APOSTROPHE OF PAIR, AND
C LOWBFR IS RETURNED POINTING TO CHARACTER TO
C RIGHT OF RIGHTMOST CHARACTER OF QUOTED TEXT
C STRING IN ITS NEW LOCATION. THE LOCATION
C VACATED BY RIGHTMOST CHARACTER IS FILLED
C WITH SPACE AFTER SHIFT IS COMPLETE.
C = 7, NEXT PRINTING CHARACTERS AT OR TO RIGHT
C OF IBUFFR(LOWBFR), IGNORING COMMAS EXCEPT
C FOR THEIR USE AS CHARACTER SEQUENCE
C SEPARATORS, FORMED UNKNOWN SEQUENCE. THIS
C VALUE OF KIND IS RETURNED ALSO IF WORD OR
C WORD ABBREVIATION IS NOT UNIQUE ACROSS BOTH
C DICTIONARIES, OR IF COMMAND WORD OR ITS
C ABBREVIATION OR ASSOCIATED WORD OR ITS
C ABBREVIATION IS FOLLOWED BY ANY CHARACTER
C OTHER THAN SPACE, TAB, COMMA, APOSTROPHE,
C SEMICOLON, EXCLAMATION POINT OR AMPERSAND.
C INITAL IS RETURNED CONTAINING SUBSCRIPT OF
C IBUFFR ARRAY LOCATION WHICH CONTAINS FIRST
C CHARACTER OF UNKNOWN SEQUENCE OR OF WORD OR
C ABBREVIATION WHICH IS FOLLOWED BY UNKNOWN
C SEQUENCE. LOWBFR IS RETURNED POINTING TO
C FOLLOWING SPACE, TAB, COMMA, APOSTROPHE,
C SEMICOLON, EXCLAMATION POINT OR AMPERSAND OR
C BEYOND END OF LINE IF UNKNOWN PRINTING
C CHARACTERS EXTEND THROUGH END OF LINE. THE
C SUBSEQUENT CALL TO THIS ROUTINE WILL RETURN
C VALUES OF KOMAND, KWRDID AND KCNTID
C UNCHANGED IF NEW COMMAND WORD IS NOT
C IDENTIFIED.
C = 8 THROUGH 14, SAME AS KIND VALUES 1 THROUGH
C 7 RESPECTIVELY EXCEPT THAT COMMAND WORD OR
C ABBREVATION WAS RECOGNIZED PRIOR TO END OF
C LINE (8), SEMICOLON (9), AMPERSAND (10),
C ASSOCIATED WORD (11), NUMBER (12), QUOTED
C TEXT STRING (13) OR UNKNOWN SEQUENCE (14).
C = 8, COMMAND WORD EXTENDED THROUGH RIGHTMOST
C PRINTING CHARACTERS IN LINE, OR ELSE NEXT
C PRINTING CHARACTER TO RIGHT OF COMMAND WORD,
C IGNORING COMMAS EXCEPT FOR THEIR USE AS WORD
C SEPARATORS, WAS EXCLAMATION POINT. UNLESS
C KIND IS CHANGED TO 10 BY CALLING PROGRAM,
C SUBSEQUENT CALL TO THIS ROUTINE WILL RETURN
C KOMAND ZEROED UNLESS NEW COMMAND IS FOUND.
C = 10, NEXT PRINTING CHARACTER TO RIGHT OF
C COMMAND WORD, IGNORING COMMAS EXCEPT FOR
C THEIR USE AS WORD SEPARATORS, WAS AMPERSAND.
C THE CALLING PROGRAM SHOULD READ NEW TEXT
C INTO INPUT BUFFER AND SUBSEQUENT CALL TO
C THIS ROUTINE IS THEN TO CONTINUE
C INTERPRETATION OF NEW TEXT AS THOUGH THIS
C COMMAND WORD APPEARED AT START OF NEW
C CONTENTS OF BUFFER. UNLESS KIND IS CHANGED
C TO 8 BY CALLING PROGRAM, SUBSEQUENT CALL TO
C THIS ROUTINE WILL RETURN KOMAND, KWRDID AND
C KCNTID UNCHANGED AND WILL RETURN KIND
C GREATER THAN 7.
C = 15, IGNORING COMMAS EXCEPT FOR THEIR USE AS
C WORD TERMINATORS, COMMAND WORD OR ITS
C ABBREVIATION WAS FOLLOWED BY SPACES AND/OR
C TABS AND/OR COMMAS AND THEN BY SECOND
C COMMAND WORD OR ITS ABBREVIATION. THE FIRST
C COMMAND IS IDENTIFIED BY RETURNED VALUES OF
C KOMAND, KWRDID AND KCNTID. LOWBFR IS
C RETURNED POINTING TO FIRST CHARACTER OF
C SECOND COMMAND WORD WHICH WILL IN TURN BE
C IDENTIFIED BY SUBSEQUENT CALL TO THIS
C ROUTINE. IF KIND WAS INPUT CONTAINING VALUE
C 10, THEN SECOND COMMAND WORD IS OF COURSE
C ACTUALLY FIRST TO APPEAR IN CURRENT CONTENTS
C OF BUFFER.
C
C THE FOLLOWING ARGUMENTS ARE RETURNED TO CALLING
C PROGRAM IDENTIFYING COMMAND WORD FOUND BY THIS
C ROUTINE OR WHICH IS STILL IN EFFECT FROM PREVIOUS
C CALL TO THIS ROUTINE.
C
C KOMAND = RETURNED CONTAINING SEQUENCE NUMBER OF
C CURRENT COMMAND WORD AMONG ALL POSSIBLE
C COMMAND WORDS. THE SEQUENCE NUMBER DOES NOT
C INCLUDE LETTERS SKIPPED OVER BY VALUE OF
C KWRDLO BEING GREATER THAN 1, AND DOES NOT
C INCLUDE LETTERS SKIPPED OVER BY NEGATIVE
C VALUES ENCOUNTERED IN KCOUNT ARRAY. KOMAND
C IS NUMBER OF VALUES IN KCOUNT ARRAY WHICH
C ARE GREATER THAN ZERO STARTING AT
C KCOUNT(KCNTLO) UP TO AND INCLUDING KCOUNT
C ARRAY LOCATION WHICH CONTAINS NUMBER OF
C LETTERS IN COMMAND WORD WHICH IS
C SUCCESSFULLY MATCHED. KOMAND IS RETURNED
C CONTAINING ZERO IF KIND IS INPUT CONTAINING
C 0, 1, 2, 8 OR 9 INDICATING THAT RANGE OF
C PREVIOUS COMMAND IS BEING TERMINATED, AND IF
C KIND IS RETURNED LESS THAN OR EQUAL TO 7
C INDICATING THAT NO NEW COMMAND WAS FOUND.
C KOMAND IS RETURNED UNCHANGED IF KIND IS
C INPUT CONTAINING VALUE OTHER THAN 0, 1, 2, 8
C OR 9, AND IF KIND IS RETURNED LESS THAN OR
C EQUAL TO 7.
C KWRDID = RETURNED CONTAINING SUBSCRIPT OF KWORD ARRAY
C LOCATION WHICH CONTAINS FIRST CHARACTER OF
C MATCHED COMMAND WORD. KWRDID IS RETURNED
C UNCHANGED IF COMMAND IDENTIFIED BY PREVIOUS
C CALL TO THIS ROUTINE IS STILL IN EFFECT.
C KCNTID = RETURNED CONTAINING SUBSCRIPT OF KCOUNT
C ARRAY LOCATION WHICH CONTAINS NUMBER OF
C CHARACTERS IN MATCHED COMMAND WORD. KCNTID
C IS RETURNED UNCHANGED IF COMMAND IDENTIFIED
C BY PREVIOUS CALL TO THIS ROUTINE IS STILL IN
C EFFECT.
C
C THE FOLLOWING ARGUMENTS ARE RETURNED TO CALLING
C PROGRAM IDENTIFYING ASSOCIATED WORD FOUND IF KIND IS
C RETURNED CONTAINING EITHER 4 OR 11. THESE ARGUMENTS
C ARE RETURNED UNCHANGED IF KIND IS RETURNED WITH ANY
C VALUE OTHER THAN 4 OR 11.
C
C LOCAL = RETURNED CONTAINING SEQUENCE NUMBER OF
C ASSOCIATED WORD AMONG ALL POSSIBLE
C ASSOCIATED WORDS. THE SEQUENCE NUMBER DOES
C NOT INCLUDE LETTERS SKIPPED OVER BY VALUE OF
C LWRDLO BEING GREATER THAN 1, AND DOES NOT
C INCLUDE LETTERS SKIPPED OVER BY NEGATIVE
C VALUES ENCOUNTERED IN LCOUNT ARRAY. LOCAL
C IS NUMBER OF VALUES IN LCOUNT ARRAY WHICH
C ARE GREATER THAN ZERO STARTING AT
C LCOUNT(LCNTLO) UP TO AND INCLUDING LCOUNT
C ARRAY LOCATION WHICH CONTAINS NUMBER OF
C LETTERS IN ASSOCIATED WORD WHICH IS
C SUCCESSFULLY MATCHED.
C LWRDID = RETURNED CONTAINING SUBSCRIPT OF LWORD ARRAY
C LOCATION WHICH CONTAINS FIRST CHARACTER OF
C MATCHED ASSOCIATED WORD.
C LCNTID = RETURNED CONTAINING SUBSCRIPT OF LCOUNT
C ARRAY LOCATION WHICH CONTAINS NUMBER OF
C CHARACTERS IN MATCHED ASSOCIATED WORD.
C
C THE FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT.
C THEIR INPUT VALUES ARE IGNORED.
C
C INITAL = RETURNED CONTAINING SUBSCRIPT OF IBUFFR
C ARRAY LOCATION WHICH CONTAINS FIRST
C CHARACTER OF ASSOCIATED WORD (KIND RETURNED
C AS 4 OR 11), OF NUMBER (KIND RETURNED AS 5
C OR 12), OR OF UNKNOWN SEQUENCE OF CHARACTERS
C (KIND RETURNED AS 7 OR 14). IF QUOTED TEXT
C STRING IS FOUND (KIND RETURNED CONTAINING 6
C OR 13), THEN INITAL IS RETURNED POINTING TO
C APOSTROPHE AT LEFT END OF STRING.
C IVALUE = RETURNED CONTAINING VALUE IF NUMBER IS FOUND
C (KIND BEING RETURNED CONTAINING 5 OR 12) AND
C IF NUMBER IS EVALUATED AS OCTAL INTEGER OR
C AS DECIMAL INTEGER.
C VALUE = RETURNED CONTAINING VALUE IF NUMBER IS FOUND
C (KIND BEING RETURNED CONTAINING 5 OR 12) AND
C IF NUMBER IS EVALUATED AS DECIMAL REAL.
C IFLOAT = SPECIFIES HOW NUMBER WAS EVALUATED. IFLOAT
C IS RETURNED SET EQUAL TO INITYP IF NUMBER IS
C OUTSIDE RANGE OF COMMAND, OR SET EQUAL TO
C NXTTYP IF NUMBER IS WITHIN RANGE OF COMMAND
C AND NXTTYP HAS VALUE GREATER THAN -3, OR SET
C EQUAL TO ENTRY IN NUMTYP ARRAY HAVING SAME
C SUBSCRIPT AS KCOUNT ARRAY ENTRY WHICH
C SPECIFIES NUMBER OF CHARACTERS IN COMMAND IF
C NXTTYP=-3. IFLOAT IS RETURNED UNDEFINED,
C BUT PROBABLY CHANGED, IF KIND IS RETURNED
C WITH VALUE OTHER THAN 5 OR 12.
C = -1, NUMBER WAS EVALUATED AS OCTAL INTEGER
C AND ITS VALUE IS RETURNED IN IVALUE.
C = 0, NUMBER WAS EVALUATED AS DECIMAL INTEGER
C AND ITS VALUE IS RETURNED IN IVALUE.
C = 1 OR GREATER, NUMBER WAS EVALUATED AS
C DECIMAL REAL AND ITS VALUE IS RETURNED IN
C ARGUMENT NAMED VALUE.
C
DIMENSION KWORD(KWRDHI),KCOUNT(KCNTHI),
1NUMTYP(KCNTHI),LWORD(LWRDHI),LCOUNT(LCNTHI),
2IBUFFR(MAXBFR)
DATA KOMENT,IEND,IAND,KOMMA,IQUOTE,IBLANK,ITAB/
11H!,1H;,1H&,1H,,1H',1H ,1H /
C
C SET INITIAL CONSTANTS
IF(KIND.EQ.10)GO TO 15
IF(KIND.LE.2)GO TO 1
IF(KIND.EQ.8)GO TO 1
IF(KIND.NE.9)GO TO 2
1 KOMAND=0
2 KIND=1
GO TO 4
C
C LOOK FOR NEXT NONBLANK CHARACTERS
3 LOWBFR=LOWBFR+1
4 IF(LOWBFR.GT.MAXBFR)GO TO 26
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.IBLANK)GO TO 3
IF(LETTER.EQ.ITAB)GO TO 3
IF(LETTER.EQ.KOMMA)GO TO 3
IF(LETTER.EQ.IEND)GO TO 25
IF(LETTER.EQ.IAND)GO TO 23
IF(LETTER.EQ.KOMENT)GO TO 24
INITAL=LOWBFR
IF(LETTER.EQ.IQUOTE)GO TO 18
LEGAL=0
C
C TEST IF PRINTING CHARACTERS FORM A COMMAND WORD
CALL DAVERB(KWRDLO,KWRDHI,KWORD,KCNTLO,KCNTHI,
1KCOUNT,IBUFFR,MAXBFR,LOWBFR,ITYPE,IMATCH,IWRDID,
2ICNTID,LCNBFR)
C
C TEST IF PRINTING CHARACTERS FORM AN ARGUMENT WORD
JPOINT=INITAL
CALL DAVERB(LWRDLO,LWRDHI,LWORD,LCNTLO,LCNTHI,
1LCOUNT,IBUFFR,MAXBFR,JPOINT,JTYPE,JMATCH,JWRDID,
2JCNTID,LCNBFR)
C
C IF WORD MATCHES FROM BOTH DICTIONARIES, DECIDE ACTION
IF(LOWBFR.LT.JPOINT)GO TO 6
IF(LOWBFR.GT.JPOINT)GO TO 5
IF(ITYPE.LE.2)GO TO 8
IF(ITYPE.EQ.JTYPE)GO TO 12
IF(JTYPE.EQ.3)GO TO 7
IF(ITYPE.NE.3)GO TO 12
5 IF(ITYPE.NE.5)LEGAL=-1
GO TO 12
6 LOWBFR=JPOINT
7 IF(JTYPE.NE.5)LEGAL=1
GO TO 12
C
C CHECK FOR NUMBER
8 IF(KOMAND.LE.0)GO TO 10
IF(NXTTYP.GE.-2)GO TO 9
IFLOAT=NUMTYP(KCNTID)
GO TO 11
9 IFLOAT=NXTTYP
GO TO 11
10 IFLOAT=INITYP
11 CALL DAHEFT(IFLOAT,ITRAIL,0,IBUFFR,MAXBFR,
1LOWBFR,ITYPE,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2VALUE)
IF(ITYPE.LE.2)GO TO 12
KIND=KIND+4
GO TO 26
C
C CHECK FOLLOWING CHARACTERS
12 IF(LOWBFR.GT.MAXBFR)GO TO 13
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.IBLANK)GO TO 13
IF(LETTER.EQ.ITAB)GO TO 13
IF(LETTER.EQ.KOMMA)GO TO 13
IF(LETTER.EQ.IEND)GO TO 13
IF(LETTER.EQ.IAND)GO TO 13
IF(LETTER.EQ.KOMENT)GO TO 13
IF(LETTER.EQ.IQUOTE)GO TO 13
LOWBFR=LOWBFR+1
LEGAL=0
GO TO 12
13 IF(LEGAL.LT.0)GO TO 14
IF(LEGAL.GT.0)GO TO 17
KIND=KIND+6
GO TO 26
14 IF(KIND.NE.1)GO TO 16
KOMAND=IMATCH
KCNTID=ICNTID
KWRDID=IWRDID
15 KIND=8
GO TO 4
16 KIND=15
LOWBFR=INITAL
GO TO 26
17 LOCAL=JMATCH
LCNTID=JCNTID
LWRDID=JWRDID
KIND=KIND+3
GO TO 26
C
C APOSTROPHE FOUND
18 KIND=KIND+5
I=LOWBFR
J=LOWBFR
19 IF(I.GE.MAXBFR)GO TO 20
I=I+1
J=J+1
IBUFFR(J)=IBUFFR(I)
IF(IBUFFR(I).EQ.IBLANK)GO TO 19
IF(IBUFFR(I).EQ.ITAB)GO TO 19
LOWBFR=J
IF(IBUFFR(I).NE.IQUOTE)GO TO 19
IF(I.GE.MAXBFR)GO TO 22
IF(IBUFFR(I+1).NE.IQUOTE)GO TO 22
I=I+1
GO TO 19
20 LOWBFR=LOWBFR+1
21 IF(J.GE.I)GO TO 26
J=J+1
22 IBUFFR(J)=IBLANK
GO TO 21
C
C AMPERSAND FOUND
23 KIND=KIND+2
24 LOWBFR=MAXBFR+1
GO TO 26
C
C SEMICOLON FOUND
25 KIND=KIND+1
LOWBFR=LOWBFR+1
C
C RETURN TO CALLING PROGRAM
26 RETURN
C842625025196!;&'
END
SUBROUTINE DATEAM(KONTNU,KONTRL,ITRAIL,NUMMAX,MAXBFR,
1 IBUFFR,LOWBFR,NUMKNT,KIND ,NUMVAL,VALNUM)
C RENBR(/EVALUATE SEVERAL NUMBERS IN SINGLE LINE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C A SINGLE CALL TO DATEAM INTERPRETS AN ARRAY READ BY
C THE CALLING PROGRAM WITH A MULTIPLE OF AN A1 FORMAT
C AND RETURNS ALL OF THE VALUES REPRESENTED IN THIS
C ARRAY. IF MORE VALUES ARE FOUND THAN CAN BE STORED
C IN THE ARRAY PROVIDED FOR RETURNING THESE VALUES TO
C THE CALLING PROGRAM, THEN DATEAM CAN INDICATE THE
C FIRST CHARACTER OF THE FIRST EXTRA NUMBER, OR CAN
C SCAN ACROSS AND POSSIBLY COUNT THE EXCESS NUMBERS.
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY AND ARE
C RETURNED UNCHANGED.
C
C KONTNU = -1, IF MORE VALUES ARE FOUND THAN CAN BE
C RETURNED IN NUMVAL OR VALNUM ARRAY, THEN
C KIND IS RETURNED CONTAINING 5 AND LOWBFR IS
C RETURNED POINTING TO LEFT CHARACTER OF FIRST
C EXCESS NUMBER.
C = 0, IF MORE VALUES ARE FOUND THAN CAN BE
C RETURNED IN NUMVAL OR VALNUM ARRAY, THEN
C EXCESS VALUES ARE INTERPRETED AND LOWBFR IS
C RETURNED POINTING BEYOND FINAL NUMBER, BUT
C NUMKNT IS NOT INCREMENTED FOR THESE EXCESS
C VALUES AND EXCESS VALUES ARE NOT RETURNED TO
C CALLING PROGRAM.
C = 1, IF MORE VALUES ARE FOUND THAN CAN BE
C RETURNED IN NUMVAL OR VALNUM ARRAY, THEN
C EXCESS VALUES ARE INTERPRETED, LOWBFR IS
C RETURNED POINTING BEYOND FINAL NUMBER, AND
C NUMKNT IS INCREMENTED FOR EACH VALUE FOUND,
C BUT EXCESS VALUES ARE NOT RETURNED TO
C CALLING PROGRAM.
C KONTRL = IF REPRESENTATION OF NUMBER IS FOUND, KONTRL
C SPECIFIES WHETHER VALUE IS TO BE RETURNED IN
C INTEGER ARRAY WHICH IS NAMED NUMVAL OR IN
C REAL ARRAY WHICH IS NAMED VALNUM. NUMBER
C CAN BE TYPED WITH DECIMAL POINT AND/OR
C EXPONENT REGARDLESS OF VALUE OF KONTRL.
C = -1, VALUE IS CALCULATED AS OCTAL INTEGER AND
C IS RETURNED IN NUMVAL ARRAY. HOWEVER,
C NUMBER FOLLOWING LETTER E OF EXPONENT IS
C EVALUATED IN DECIMAL.
C = 0, VALUE IS CALCULATED AS DECIMAL INTEGER
C AND IS RETURNED IN NUMVAL ARRAY.
C = 1 OR GREATER, VALUE IS RETURNED IN VALNUM
C ARRAY. IF POSSIBLE, REAL NUMBER WILL BE
C ACCUMULATED AS INTEGER, THEN BE CONVERTED TO
C REAL AND SHIFTED AS NECESSARY. KONTRL IS
C MAXIMUM NUMBER OF DIGITS IN INTEGER.
C ITRAIL = SELECTS WHETHER EXPONENTS ARE TO BE
C RECOGNIZED. IF EXPONENTS ARE NOT TO BE
C RECOGNIZED BUT EXPONENT IS FOUND, THEN
C EVALUATION OF CONTENTS OF INPUT TEXT BUFFER
C WILL BE TERMINATED PRIOR TO EXPONENT AND
C FIRST CHARACTER OF EXPONENT WILL BE TREATED
C SAME AS ANY OTHER UNKNOWN ALPHABETIC
C CHARACTER. WHEN SUCH UNKNOWN CHARACTER IS
C FOUND, KIND IS RETURNED CONTAINING 4 AND
C LOWBFR IS RETURNED POINTING TO UNKNOWN
C CHARACTER.
C = -1, EXPONENTS EXPRESSED IN E NOTATION ARE TO
C BE RECOGNIZED, BUT PERCENT SIGN AND LETTERS
C K AND M ARE TO BE TREATED SAME AS ANY OTHER
C ALPHABETIC CHARACTERS.
C = 0, NO EXPONENTS ARE TO BE RECOGNIZED.
C EVALUATION WILL BE TERMINATED PRIOR TO
C PERCENT SIGNS OR TO LETTERS E OR K OR M.
C = 1, PERCENT SIGNS, LETTERS K AND M, AND
C EXPONENTS EXPRESSED IN E NOTATION ARE ALL TO
C BE RECOGNIZED.
C NUMMAX = HIGHEST SUBSCRIPT OF NUMVAL OR VALNUM ARRAY
C LOCATIONS INTO WHICH CAN BE PLACED VALUES
C REPRESENTED BY CHARACTERS IN IBUFFR ARRAY.
C MAXBFR = SUBSCRIPT OF IBUFFR ARRAY LOCATION
C CONTAINING RIGHTMOST (HIGHEST SUBSCRIPT)
C CHARACTER IN LINE OF TEXT BEING INTERPRETED.
C MAXBFR WOULD NORMALLY BE DIMENSION OF IBUFFR
C ARRAY.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS OF
C LINE OF TEXT TO BE INTERPRETED, ONE
C CHARACTER PER ARRAY LOCATION, AS READ BY
C MULTIPLE OF A1 FORMAT.
C
C FOLLOWING ARGUMENTS ARE USED BOTH FOR INPUT TO THIS
C ROUTINE AND FOR OUTPUT TO CALLING PROGRAM.
C
C LOWBFR = INPUT CONTAINING SUBSCRIPT OF IBUFFR ARRAY
C LOCATION WHICH CONTAINS LEFTMOST (LOWEST
C SUBSCRIPT) CHARACTER WHICH IS TO BE
C INTERPRETED BY THIS ROUTINE. LOWBFR IS
C RETURNED POINTING TO LEFTMOST CHARACTER NOT
C YET IDENTIFIED BY THIS ROUTINE. LOWBFR IS
C RETURNED CONTAINING SUBSCRIPT OF IBUFFR
C ARRAY LOCATION CONTAINING UNKNOWN CHARACTER
C (KIND BEING RETURNED CONTAINING 4) OR
C CONTAINING CHARACTER TO RIGHT OF SEMICOLON
C (KIND BEING RETURNED CONTAINING 2). IF
C KONTNU IS SET TO -1 AND IF MORE VALUES ARE
C FOUND THAN CAN BE STORED IN AVAILABLE
C PORTION OF NUMVAL OR VALNUM ARRAY, THEN
C LOWBFR IS RETURNED CONTAINING SUBSCRIPT OF
C IBUFFR ARRAY LOCATION WHICH CONTAINS FIRST
C CHARACTER OF FIRST VALUE WHICH COULD NOT BE
C STORED. IF AMPERSAND OR EXCLAMATION POINT
C IS FOUND OR IF ALL CHARACTERS IN INPUT TEXT
C BUFFER HAVE BEEN INTERPRETED, THEN LOWBFR IS
C RETURNED POINTING BEYOND RIGHT END OF
C BUFFER.
C NUMKNT = INPUT CONTAINING SUBSCRIPT OF HIGHEST
C LOCATION IN NUMVAL OR VALNUM ARRAY WHICH IS
C CURRENTLY IN USE AND WHICH MUST THEREFORE BE
C RETURNED UNCHANGED. FIRST VALUE FOUND BY
C THIS ROUTINE WILL BE STORED IN
C NUMVAL(NUMKNT+1) OR IN VALNUM(NUMKNT+1). IF
C KONTNU IS LESS THAN OR EQUAL TO ZERO, OR IF
C KONTNU IS GREATER THAN ZERO BUT NO MORE THAN
C NUMMAX-NUMKNT VALUES ARE FOUND, THEN NUMKNT
C IS RETURNED CONTAINING SUBSCRIPT OF HIGHEST
C LOCATION IN NUMVAL OR VALNUM ARRAY WHICH WAS
C USED BY THIS ROUTINE FOR STORAGE OF VALUES
C REPRESENTED BY TEXT IN IBUFFR ARRAY. IF
C KONTNU IS GREATER THAN ZERO, BUT MORE THAN
C NUMMAX-NUMKNT VALUES ARE FOUND, THEN
C LOCATIONS ABOVE NUMVAL(NUMMAX) OR
C VALNUM(NUMMAX) ARE RETURNED UNCHANGED, BUT
C NUMKNT IS RETURNED INCREMENTED AS THOUGH
C THESE EXCESS VALUES HAD BEEN STORED.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT TO
C CALLING PROGRAM. THEIR INPUT VALUES ARE IGNORED.
C
C KIND = RETURNED DESCRIBING REASON FOR TRANSFER OF
C CONTROL BACK TO CALLING PROGRAM. KIND DOES
C NOT INDICATE WHETHER ANY VALUES HAVE BEEN
C STORED IN NUMVAL OR VALNUM ARRAY.
C = 1, ALL CHARACTERS CURRENTLY WITHIN IBUFFR
C ARRAY HAVE BEEN INTERPETED. IF EXCLAMATION
C POINT WAS FOUND, THEN CHARACTERS TO RIGHT OF
C EXCLAMATION POINT HAVE BEEN IGNORED AND
C LOWBFR IS RETURNED CONTAINING MAXBFR+1.
C = 2, SEMICOLON WAS FOUND. LOWBFR IS RETURNED
C POINTING TO CHARACTER TO RIGHT OF SEMICOLON.
C IF SEMICOLONS ARE TO BE CONSIDERED AS
C EQUIVALENT TO SPACES, THEN CALLING PROGRAM
C SHOULD AGAIN CALL THIS ROUTINE WITHOUT FIRST
C CHANGING VALUES OF ANY OF ARGUMENTS.
C = 3, AMPERSAND WAS FOUND. CHARACTERS TO RIGHT
C OF AMPERSAND HAVE BEEN IGNORED AND LOWBFR IS
C RETURNED CONTAINING MAXBFR+1. IF AMPERSAND
C INDICATES THAT TEXT REPRESENTING ADDITIONAL
C VALUES IS TO BE READ BY CALLING PROGRAM,
C THEN LOWBFR SHOULD BE RESET TO POINT TO
C START OF NEW TEXT BEFORE THIS ROUTINE IS
C CALLED AGAIN.
C = 4, UNKNOWN CHARACTER WAS FOUND. LOWBFR IS
C RETURNED CONTAINING SUBSCRIPT OF IBUFFR
C ARRAY LOCATION CONTAINING THIS UNKNOWN
C CHARACTER. IF UNKNOWN CHARACTER IS TO BE
C CONSIDERED AS EQUIVALENT TO SPACE, THEN
C LOWBFR MUST BE INCREMENTED BY ONE BEFORE
C THIS ROUTINE IS CALLED AGAIN.
C = 5, KONTNU CONTAINS -1 AND VALUE WAS FOUND
C WHICH COULD NOT BE STORED IN AVAILABLE
C PORTION OF NUMVAL OR VALNUM ARRAY. LOWBFR
C IS RETURNED POINTING TO LEFTMOST CHARACTER
C IN REPRESENTATION OF NUMBER. CALLING
C PROGRAM MUST SUPPLY ADDITONAL SPACE IN
C NUMVAL OR VALNUM ARRAY OR ELSE MUST RESET
C KONTNU TO BE ZERO OR GREATER BEFORE AGAIN
C CALLING THIS ROUTINE TO PROCESS REMAINING
C TEXT IN IBUFFR ARRAY.
C NUMVAL = ARRAY INTO WHICH ARE STORED INTEGER VALUES
C REPRESENTED BY TEXT IN IBUFFR ARRAY IF
C KONTRL IS LESS THAN OR EQUAL TO ZERO.
C VALNUM = ARRAY INTO WHICH ARE STORED REAL VALUES
C REPRESENTED BY TEXT IN IBUFFR ARRAY IF
C KONTRL IS GREATER THAN ZERO.
C
DIMENSION NUMVAL(NUMMAX),VALNUM(NUMMAX),
1IBUFFR(MAXBFR)
DATA KOMMA,KOMENT,IAND,IEND/1H,,1H!,1H&,1H;/
C
C OBTAIN NEXT NUMBER
1 INITAL=LOWBFR
CALL DAHEFT(KONTRL,ITRAIL,0,IBUFFR,MAXBFR,
1LOWBFR,ITYPE,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2VALUE)
GO TO (11,2,6),ITYPE
C
C UNKNOWN CHARACTER FOUND
2 LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.KOMMA)GO TO 3
IF(LETTER.EQ.IEND)GO TO 4
IF(LETTER.EQ.IAND)GO TO 5
IF(LETTER.EQ.KOMENT)GO TO 10
KIND=4
GO TO 12
C
C SKIP OVER COMMA AND CONTINUE
3 LOWBFR=LOWBFR+1
GO TO 1
C
C SEMICOLON FOUND
4 KIND=2
LOWBFR=LOWBFR+1
GO TO 12
C
C AMPERSAND FOUND
5 KIND=3
LOWBFR=MAXBFR+1
GO TO 12
C
C INSERT NEW VALUE INTO THE LIST
6 IF(NUMKNT.GE.NUMMAX)GO TO 8
NUMKNT=NUMKNT+1
IF(KONTRL.GT.0)GO TO 7
NUMVAL(NUMKNT)=IVALUE
GO TO 1
7 VALNUM(NUMKNT)=VALUE
GO TO 1
C
C TOO MANY VALUES FOUND
8 IF(KONTNU.LT.0)GO TO 9
IF(KONTNU.GT.0)NUMKNT=NUMKNT+1
GO TO 1
9 KIND=5
LOWBFR=INITAL
GO TO 12
C
C INPUT BUFFER IS EMPTY
10 LOWBFR=MAXBFR+1
11 KIND=1
C
C RETURN TO CALLING PROGRAM
12 RETURN
C293727231057!&;
END
SUBROUTINE DAJOIN(ITRAIL,IBUFFR,MAXBFR,LOWBFR,KIND ,
1 VALUE ,DIVISR,ISHIFT,JSHIFT)
C RENBR(/EVALUATE FRACTIONS AND MIXED NUMBERS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE EVALUATES THE WHOLE NUMBERS, FRACTIONS
C AND MIXED NUMBERS CONTAINED IN A LINE OF TEXT READ
C WITH A MULTIPLE OF AN A1 FORMAT. IF THE FRACTION OR
C MIXED NUMBER IS TO BE MULTIPLED BY 10.0 RAISED TO
C SOME POWER, THEN THIS EXPONENT MUST APPEAR TO THE
C IMMEDATE RIGHT OF THE DENOMINATOR OF THE FRACTION.
C THE TEXT CONTENTS 1 1/2K OR 1.5K OR 3/2K WOULD ALL
C REPRESENT THE VALUE 1500.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR INPUT AND ARE
C RETURNED UNCHANGED.
C
C ITRAIL = SELECTS WHETHER EXPONENTS ARE TO BE
C RECOGNIZED. IF EXPONENTS ARE NOT TO BE
C RECOGNIZED BUT EXPONENT IS FOUND, THEN
C EVALUATION OF CONTENTS OF INPUT TEXT BUFFER
C WILL BE TERMINATED PRIOR TO EXPONENT AND
C FIRST CHARACTER OF EXPONENT WILL BE TREATED
C SAME AS ANY OTHER UNKNOWN ALPHABETIC
C CHARACTER. WHEN SUCH UNKNOWN CHARACTER IS
C FOUND, KIND IS RETURNED CONTAINING 2 AND
C LOWBFR IS RETURNED POINTING TO UNKNOWN
C CHARACTER.
C = -1, EXPONENTS EXPRESSED IN E NOTATION ARE TO
C BE RECOGNIZED, BUT PERCENT SIGN AND LETTERS
C K AND M ARE TO BE TREATED SAME AS ANY OTHER
C ALPHABETIC CHARACTERS.
C = 0, NO EXPONENTS ARE TO BE RECOGNIZED.
C EVALUATION WILL BE TERMINATED PRIOR TO
C PERCENT SIGNS OR TO LETTERS E OR K OR M.
C = 1, PERCENT SIGNS, LETTERS K AND M, AND
C EXPONENTS EXPRESSED IN E NOTATION ARE ALL TO
C BE RECOGNIZED.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS OF
C LINE OF TEXT TO BE INTERPRETED, ONE
C CHARACTER PER ARRAY LOCATION, AS READ BY
C MULTIPLE OF A1 FORMAT.
C MAXBFR = SUBSCRIPT OF IBUFFR ARRAY LOCATION
C CONTAINING RIGHTMOST (HIGHEST SUBSCRIPT)
C CHARACTER IN LINE OF TEXT BEING INTERPRETED.
C MAXBFR WOULD NORMALLY BE DIMENSION OF IBUFFR
C ARRAY.
C
C FOLLOWING ARGUMENT IS USED BOTH FOR INPUT TO THIS
C ROUTINE AND FOR OUTPUT TO CALLING PROGRAM.
C
C LOWBFR = INPUT CONTAINING SUBSCRIPT OF IBUFFR ARRAY
C LOCATION WHICH CONTAINS LEFTMOST (LOWEST
C SUBSCRIPT) CHARACTER WHICH IS TO BE
C INTERPRETED BY THIS ROUTINE. LOWBFR IS
C RETURNED POINTING TO LEFTMOST CHARACTER NOT
C YET IDENTIFIED BY THIS ROUTINE. IF KIND IS
C RETURNED CONTAINING 3 OR GREATER, THEN
C LOWBFR IS RETURNED POINTING TO CHARACTER TO
C IMMEDIATE RIGHT OF REPRESENTATION OF NUMBER.
C IF KIND IS RETURNED CONTAINING 2, THEN
C LOWBFR IS RETURNED POINTING TO CHARACTER
C WHICH COULD NOT BE EVALUATED. IF KIND IS
C RETURNED CONTAINING 1, THEN LOWBFR IS
C RETURNED POINTING BEYOND END OF BUFFER.
C
C FOLLOWING ARGUMENTS ARE USED FOR OUTPUT ONLY. THEIR
C INPUT VALUES ARE IGNORED.
C
C KIND = 1, NO PRINTING CHARACTERS APPEARED AT OR TO
C THE RIGHT OF IBUFFR(LOWBFR). LOWBFR IS
C RETURNED POINTING BEYOND END OF BUFFER.
C = 2, UNKNOWN CHARACTER WAS FOUND. LOWBFR IS
C RETURNED CONTAINING SUBSCRIPT OF IBUFFR
C ARRAY LOCATION CONTAINING THIS UNKNOWN
C CHARACTER. LOWBFR MUST BE INCREMENTED BY AT
C LEAST 1 BEFORE THIS ROUTINE IS AGAIN CALLED
C TO CONTINUE PROCESSING OF TEXT.
C = 3, WHOLE NUMBER WAS FOUND. LOWBFR IS
C RETURNED POINTING TO CHARACTER TO IMMEDIATE
C RIGHT OF REPRESENTATION OF WHOLE NUMBER.
C = 4, MIXED NUMBER CONSISTING OF WHOLE NUMBER
C FOLLOWED BY UNSIGNED FRACTION WAS FOUND.
C LOWBFR IS RETURNED POINTING TO CHARACTER TO
C IMMEDIATE RIGHT OF REPRESENTATION OF
C FRACTION.
C = 5, FRACTION WAS FOUND. LOWBFR IS RETURNED
C POINTING TO CHARACTER TO IMMEDIATE RIGHT OF
C REPRESENTATION OF FRACTION.
C = 6, MIXED NUMBER OR FRACTION WAS FOUND IN
C WHICH RIGHTMOST DENOMINATOR WAS MISSING.
C LOWBFR IS RETURNED POINTING TO CHARACTER TO
C RIGHT OF RIGHTMOST SLASH.
C VALUE = RETURNED CONTAINING VALUE OF WHOLE NUMBER,
C OR MIXED NUMBER OR FRACTION IF KIND IS
C RETURNED CONTAINING 3 OR GREATER. VALUE,
C DIVISR, ISHIFT AND JSHIFT ARE RETURNED
C UNDEFINED IF KIND IS RETURNED CONTAINING 1
C OR 2.
C DIVISR = RETURNED CONTAINING VALUE OF DENOMINATOR IF
C FRACTION OR MIXED NUMBER IS FOUND. RETURNED
C SET TO 1 IF WHOLE NUMBER IS FOUND.
C ISHIFT = 0, RETURNED IF NONE OF CHARACTERS E, %, K OR
C M FOLLOW NUMBER
C = 1, PERCENT SIGN FOLLOWS NUMBER
C = 2, K FOLLOWS NUMBER
C = 3, M FOLLOWS NUMBER
C = LESS THAN ZERO, RETURNED IF E FOLLOWS
C NUMBER.
C = -1, E AND POSSIBLY SIGNED NUMBER FOLLOW
C NUMBER.
C = -2, E IS FOLLOWED BY PLUS SIGN NOT IN TURN
C FOLLOWED BY DIGITS.
C = -3, E IS FOLLOWED BY MINUS SIGN NOT IN TURN
C FOLLOWED BY DIGITS.
C = -4, E IS FOLLOWED BY NEITHER SIGN NOR DIGITS
C JSHIFT = EXPONENT INDICATED BY FOLLOWING PERCENT
C SIGN, K, M OR E FOLLOWED BY DIGITS. 12.34K
C OR 12.34E3 OR 12 34/100K OR 12 34/100E3
C WOULD GIVE JSHIFT OF 3. 12% OR 12E-2 WOULD
C GIVE JSHIFT -2.
C
DIMENSION IBUFFR(MAXBFR)
C
C ISPACE CONTAINS SPACE CHARACTER AND ITAB CONTAINS
C TAB CHARACTER. IF TAB CHARACTER IS NOT AVAILABLE,
C ITAB SHOULD INSTEAD CONTAIN A SPACE ALSO.
DATA MINUS,IPLUS,ISLASH,ISPACE,ITAB/
11H-,1H+,1H/,1H ,1H /
C
C INITIALIZE
INITAL=0
LEVEL=0
ISIGN=1
KIND=1
JTRAIL=10
IF(ITRAIL.LT.0)JTRAIL=9
IF(ITRAIL.GT.0)JTRAIL=11
GO TO 3
C
C *********************
C * SCAN FOR NUMBER *
C *********************
C
C LOOP LOOKING AT CHARACTERS IN IBUFFR ARRAY
1 LEVEL=1
2 LOWBFR=LOWBFR+1
3 IF(LOWBFR.GT.MAXBFR)GO TO 12
NOWLTR=IBUFFR(LOWBFR)
C
C LOOK FOR LEADING SPACES, SIGNS OR SLASHES
IF(LEVEL.NE.0)GO TO 5
IF(NOWLTR.EQ.ISPACE)GO TO 2
IF(NOWLTR.EQ.ITAB)GO TO 2
IF(NOWLTR.EQ.ISLASH)GO TO 7
IF(NOWLTR.EQ.IPLUS)GO TO 4
IF(NOWLTR.NE.MINUS)GO TO 6
ISIGN=-1
4 IF(INITAL.NE.0)GO TO 12
GO TO 6
5 IF(NOWLTR.EQ.IPLUS)GO TO 12
IF(NOWLTR.EQ.MINUS)GO TO 12
IF(NOWLTR.EQ.ISPACE)GO TO 12
IF(NOWLTR.EQ.ITAB)GO TO 12
IF(NOWLTR.EQ.ISLASH)GO TO 2
C
C EVALUATE NUMBER
6 CALL DAHEFT(1,JTRAIL,0,IBUFFR,MAXBFR,
1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2VALUE)
IF(KIND.NE.3)GO TO 12
KSHIFT=KSHIFT-JSHIFT
IF(KSHIFT.NE.0)VALUE=VALUE*(10.0**KSHIFT)
C
C MARK THAT ARE IN FRACTION IF FIND SLASH
IF(ISHIFT.NE.0)GO TO 9
IF(LOWBFR.GT.MAXBFR)GO TO 9
IF(IBUFFR(LOWBFR).NE.ISLASH)GO TO 9
IF(LEVEL.EQ.0)GO TO 8
LEVEL=-1
GO TO 10
7 VALUE=0.0
8 DIVISR=1.0
FRACTN=VALUE
GO TO 1
C
C *******************************
C * NUMBER HAS BEEN EVALUATED *
C *******************************
C
C DIVIDE FRACTION BY NEW DENOMINATOR
9 IF(LEVEL.EQ.0)GO TO 11
10 IF(LSHIFT.LE.0)VALUE=1.0
DIVISR=VALUE
FRACTN=FRACTN/VALUE
IF(LEVEL.GT.0)GO TO 13
GO TO 1
C
C STORE WHOLE NUMBER AND LOOP BACK FOR FRACTION
11 IF(INITAL.NE.0)GO TO 12
IF(ISHIFT.NE.0)GO TO 19
INITAL=ISIGN
LOWSAV=LOWBFR
WHOLE=VALUE
GO TO 3
C
C COMBINE WHOLE NUMBER AND FRACTION
12 ISHIFT=0
JSHIFT=0
IF(LEVEL.EQ.0)GO TO 18
KIND=6
IF(INITAL.EQ.0)GO TO 17
GO TO 14
13 IF(INITAL.EQ.0)GO TO 16
KIND=4
14 IF(INITAL.GT.0)GO TO 15
VALUE=WHOLE-FRACTN
GO TO 20
15 VALUE=WHOLE+FRACTN
GO TO 20
16 KIND=5
17 VALUE=FRACTN
GO TO 20
18 IF(INITAL.EQ.0)GO TO 21
LOWBFR=LOWSAV
VALUE=WHOLE
19 KIND=3
DIVISR=1.0
20 IF(JSHIFT.NE.0)VALUE=VALUE*(10.0**JSHIFT)
GO TO 22
C
C SIMULATE NUMBER IF NONE FOUND
21 VALUE=0.0
DIVISR=1.0
C
C RETURN TO CALLING PROGRAM
22 RETURN
C INITAL = 0, NO WHOLE NUMBER STORED
C = -1, NEGATIVE WHOLE NUMBER STORED
C = 1, POSITIVE WHOLE NUMBER STORED
C ISIGN = -1, MINUS SIGN AT START OF NUMBER
C = 1, NUMBER DOES NOT START WITH MINUS SIGN
C LEVEL = 0, A SLASH HAS NOT BEEN FOUND.
C = 1, THE NUMERATOR OF FRACTION HAS BEEN
C STORED AND NEED TO GET DENOMINATOR.
C = -1, A SLASH APPEARS AT RIGHT OF THE
C DENOMINATOR OF THE FRACTION SO NEED
C TO CALCULATE NEW NUMERATOR AND THEN
C GO BACK TO LEVEL=1 STATE.
C510407084164
END
SUBROUTINE DAHEFT(KONTRL,ITRAIL,IEXTRA,IBUFFR,MAXBFR,
1 LOWBFR,KIND ,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2 VALUE )
C RENBR(/FREE FORMAT NUMERIC INPUT ROUTINE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAHEFT INTERPRETS AN ARRAY READ BY THE CALLING
C PROGRAM WITH A MULTIPLE OF AN A1 FORMAT AND RETURNS
C THE VALUES CONTAINED IN THIS ARRAY.
C
C NUMBERS INTERPRETTED BY DAHEFT CAN CONTAIN LEADING
C SIGN, EMBEDDED DECIMAL POINT AND/OR TRAILING E WITH
C SIGNED EXPONENT. A PERCENT SIGN FOLLOWING THE NUMBER
C IMPLIES E-2, TRAILING LETTER K IMPLIES E3 AND
C TRAILING LETTER M IMPLIES E6.
C
C ARGUMENT LIST DEFINITIONS:
C
C KONTRL = 1 OR GREATER, ITEM IN IBUFFR ARRAY IS
C FLOATING POINT. IF POSSIBLE, THE FLOATING
C POINT NUMBER WILL BE ACCUMULATED AS AN
C INTEGER, THEN BE CONVERTED TO FLOATING POINT
C AND SHIFTED IF NECESSARY. KONTRL IS THEN
C THE MAXIMUM NUMBER OF DIGITS IN THE INTEGER.
C THE VALUE IS OUTPUT AS THE ARGUMENT VALUE.
C IF THE ITEM HAS MORE THAN KONTRL DIGITS,
C THEN THE ENTIRE EVALUATION IS DONE IN
C FLOATING POINT. THE ADVANTAGE OF
C CALCULATING THE FLOATING POINT VALUES IN
C INTEGER AS LONG AS THE PRECISION OF THE
C COMPUTER IS NOT OVERFLOWED IS THAT THE
C CALCULATION OF THE PORTION OF THE NUMBER
C RIGHT OF THE DECIMAL POINT IS MORE EXACT.
C AS AN EXAMPLE, IF KONTRL IS GREATER THAN OR
C EQUAL TO 4, THEN THE NUMBER 33.33 CAN BE
C STORED AS THE INTEGER 3333, THEN BE
C CONVERTED TO FLOATING POINT VALUE 3333.0 AND
C DIVIDED BY 100.0 TO OBTAIN THE FINAL
C ANSWER. IF IT MAKES NO DIFFERENCE WHETHER
C THE NUMBER TYPED AS 33.33 HAS VALUE 33.33 OR
C 33.32999... THEN KONTRL CAN BE GIVEN THE
C VALUE 1.
C = 0, ITEM IN IBUFFR ARRAY IS INTEGER DECIMAL.
C THE NUMBER CAN BE TYPED WITH A DECIMAL POINT
C (FOR EXAMPLE 1.23K OR 1.23E3 EQUALS 1230),
C BUT IS STORED AS AN INTEGER IN DAHEFT, AND
C IS OUTPUT AS ARGUMENT IVALUE. ANY DECIMAL
C INTEGER WHICH THE COMPUTER CAN REPRESENT CAN
C BE EVALUATED. THIS INCLUDES, ON TWOS
C COMPLEMENT COMPUTERS, THE LARGEST NEGATIVE
C NUMBER THE ABSOLUTE VALUE OF WHICH CANNOT BE
C STORED. ON THE PDP10, A 36 BIT COMPUTER
C WITH TWOS COMPLEMENT NOTATION, THE RANGE OF
C DECIMAL INTEGERS IS -34359738368 THROUGH
C 34359738367 (OCTAL NOTATION OF BIT PATTERNS
C BEING 400000000000 THROUGH 377777777777).
C = -1, ITEM IN IBUFFR ARRAY IS OCTAL. THE
C NUMBER CAN BE TYPED WITH A DECIMAL POINT
C AND/OR WITH AN EXPONENT. HOWEVER, THE
C NUMBER FOLLOWING THE LETTER E OF THE
C EXPONENT IS EVALUATED IN DECIMAL. THE VALUE
C OF THE OCTAL NUMBER IS RETURNED AS THE
C ARGUMENT IVALUE. IT MUST BE NOTED THAT
C NUMBERS EVALUATED AS NEGATIVE OCTAL INTEGERS
C HAVE THE NEGATIVE OCTAL INTEGER AS THEIR
C VALUE, NOT AS THEIR BIT REPRESENTATION IN
C COMPUTER STORAGE. FOR EXAMPLE, ON A 36 BIT
C TWOS COMPLEMENT COMPUTER, THE OCTAL NUMBER
C -400000000000 (WHICH COULD ALSO BE TYPED AS
C -4E11 OR -4E+11 WHERE THE 11 AFTER THE E IS
C IN DECIMAL) IS REPRESENTED AS BIT PATTERN
C HAVING OCTAL NOTATION 400000000000 AND THE
C OCTAL NUMBER -377777777777 IS REPRESENTED BY
C THE BIT PATTERN 400000000001.
C = -2, DO NOT EVALUATE NUMBERS. INSTEAD THE
C CHARACTERS FORMING NUMBER ARE TREATED LIKE
C ANY OTHER PRINTING CHARACTERS.
C ITRAIL = SPECIFIES WHETHER EXPONENTS ARE TO BE
C RECOGNIZED.
C = -1, ALLOW NUMBERS TO BE FOLLOWED BY E
C EXPONENT, BUT DO NOT RECOGNIZE PERCENT SIGN,
C K OR M AT END OF NUMBER. E IS NOT
C RECOGNIZED IF NOT PRECEDED BY SIGN, DECIMAL
C POINT OR DIGIT.
C = 0, DO NOT ALLOW TRAILING PERCENT SIGN, K M
C OR E EXPONENT.
C = 1, ALLOW NUMBERS TO BE FOLLOWED BY PERCENT
C SIGN, K M OR E EXPONENT. PERCENT SIGN, K M
C OR E IS NOT RECOGNIZED IF NOT PRECEDED BY
C SIGN, DECIMAL POINT OR DIGIT.
C
C FOLLOWING VALUES DO NOT REQUIRE THAT EXPONENT
C BE PRECEDED BY NUMBER. ALTHOUGH RETURNED
C VALUE WILL ALWAYS BE ZERO IF NO VALUE DIGITS
C ARE FOUND, CALLING PROGRAM COULD ADJUST THIS
C RETURNED VALUE.
C
C = -3, LEADING E EXPONENT IS RECOGNIZED.
C LEADING DIGITS, SIGNS AND DECIMAL POINTS ARE
C NOT ALLOWED.
C = -2, SAME AS ITRAIL=-1, EXCEPT THAT IN
C ADDITION E EXPONENT IS RECOGNIZED EVEN IF
C NOT PRECEDED BY DIGITS, SIGN OR DECIMAL
C POINT.
C = 2, SAME AS ITRAIL=1, EXCEPT THAT IN ADDITION
C LEADING PERCENT SIGN, OR LETTERS K M OR E
C EXPONENT ARE RECOGNIZED EVEN IF NOT PRECEDED
C BY DIGITS, SIGN OR DECIMAL POINT.
C = 3, ONLY LEADING PERCENT SIGN OR LETTERS K M
C OR E EXPONENT ARE RECOGNIZED. LEADING
C DIGITS, SIGNS OR DECIMAL POINTS ARE NOT
C ALLOWED.
C
C IF 10 IS SUBTRACTED FROM ITRAIL VALUES -3
C THROUGH 3, AND IF EITHER VALUE DIGITS OR
C DIGITS FOLLOWING LETTER E ARE MISSING, THEN
C ONE, RATHER THAN ZERO, IS ASSUMED TO BE THE
C DEFAULT FOR THE VALUE OR THE EXPONENT
C RESPECTIVELY. -E- WOULD BE EQUIVALENT TO
C -1E-1 AND -E OR -E+ WOULD BE EQUIVALENT TO
C -1E1
C
C IF 10 IS ADDED TO ITRAIL VALUES -3 THROUGH 3,
C THEN VALUE IS RETURNED AS THOUGH NEITHER
C EXPONENT NOR DECIMAL POINT HAD BEEN TYPED.
C VALUE INDICATED BY COMBINATION OF DIGITS,
C DECIMAL POINT AND/OR EXPONENT CAN BE OBTAINED
C AS VALUE*10**KSHIFT OR IVALUE*10**KSHIFT.
C VALUE INDICATED BY COMBINATION OF DIGITS AND
C DECIMAL POINT BUT IGNORING EXPONENT CAN BE
C OBTAINED AS VALUE*10**(KSHIFT-JSHIFT) OR
C IVALUE*10**(KSHIFT-JSHIFT).
C IEXTRA = EXTRA SHIFT TO BE APPLIED TO VALUE. SHIFT
C IS STATED AS POWER OF RADIX. THIS IS
C APPLIED IN ADDITION TO SHIFT REPORTED IN
C ISHIFT, JSHIFT AND KSHIFT AS SPECIFIED BY
C USER. FOR EXAMPLE, IF DOLLAR VALUE IS TO BE
C RETURNED AS INTEGER NUMBER OF CENTS, IEXTRA
C WOULD HAVE VALUE 2.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY A MULTIPLE OF AN A1
C FORMAT, WHICH IS TO BE SEARCHED FOR WORDS
C AND NUMBERS. IBUFFR THEN CONTAINS 1 LETTER
C PER COMPUTER STORAGE LOCATION.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY TO BE
C SEARCHED
C LOWBFR = SUBSCRIPT WITHIN THE IBUFFR ARRAY OF THE
C FIRST (LEFTMOST) CHARACTER WHICH CAN BE
C SCANNED FOR NUMBERS. LOWBFR WILL BE RETURNED
C POINTING TO FIRST PRINTING CHARACTER WHICH
C CANNOT APPEAR IN A NUMBER, OR BEYOND THE END
C OF THE BUFFER IF THE BUFFER DOES NOT CONTAIN
C ANY PRINTING CHARACTERS.
C KIND = RETURNED DESCRIBING THE KIND OF ITEM LOCATED
C IN THE IBUFFR ARRAY.
C = 1, NOTHING WAS FOUND AT OR TO THE RIGHT OF
C LOWBFR. THE CALLING PROGRAM SHOULD READ A
C NEW LINE INTO IBUFFR.
C = 2, NUMBER WAS NOT FOUND, BUT A PRINTING
C CHARACTER WHICH CANNOT START A NUMBER WAS
C FOUND. LOWBFR IS RETURNED POINTING TO THIS
C PRINTING CHARACTER.
C = 3, A NUMBER WAS FOUND. LOWBFR IS RETURNED
C POINTING TO CHARACTER TO RIGHT OF NUMBER.
C ISHIFT = 0, RETURNED IF NONE OF CHARACTERS E, %, K OR
C M FOLLOW NUMBER
C = 1, PERCENT SIGN FOLLOWS NUMBER
C = 2, K FOLLOWS NUMBER
C = 3, M FOLLOWS NUMBER
C = LESS THAN ZERO, RETURNED IF E FOLLOWS
C NUMBER.
C = -1, E AND POSSIBLY SIGNED NUMBER FOLLOW
C NUMBER.
C = -2, E IS FOLLOWED BY PLUS SIGN NOT IN TURN
C FOLLOWED BY DIGITS.
C = -3, E IS FOLLOWED BY MINUS SIGN NOT IN TURN
C FOLLOWED BY DIGITS.
C = -4, E IS FOLLOWED BY NEITHER SIGN NOR DIGITS
C JSHIFT = EXPONENT INDICATED BY FOLLOWING PERCENT
C SIGN, K, M OR E FOLLOWED BY DIGITS. THIS
C WILL HAVE BEEN APPLIED TO RETURNED VALUE IF
C ITRAIL EQUALS EITHER -1 OR 1. 12.34K OR
C 12.34E3 WOULD GIVE JSHIFT OF 3. 12% OR
C 12E-2 WOULD GIVE JSHIFT -2.
C KSHIFT = EXPONENT WHICH WOULD BE NECESSARY TO OBTAIN
C DESIRED VALUE IF NUMBER HAD BEEN TYPED
C WITHOUT DECIMAL POINT. 12.34 STATED WITHOUT
C DECIMAL POINT WOULD BE 1234E-2 SO KSHIFT
C WOULD BE -2. 12.34K WOULD BE 1234E1 SO
C KSHIFT WOULD BE 1.
C LSHIFT = ZERO OR LESS, THE VALUE ZERO IS BEING
C RETURNED FOR EITHER VALUE OR IVALUE,
C WHICHEVER IS APPROPRIATE.
C = -4, NUMBER CONTAINED NEITHER VALUE DIGITS,
C NOR DECIMAL POINT, NOR LEADING PLUS SIGN,
C NOR LEADING MINUS SIGN. THIS VALUE OF
C LSHIFT IS ALWAYS RETURNED IF KIND IS
C RETURNED CONTAINING A VALUE OTHER THAN 3.
C IF KIND IS RETURNED CONTAINING THE VALUE 3,
C THEN ITRAIL MUST BE EITHER -3 OR 3, AND THE
C CONTENTS OF THE INPUT TEXT BUFFER MUST BEGIN
C WITH A REPRESENTATION OF AN EXPONENT.
C = -3, A LEADING MINUS SIGN BUT NO VALUE DIGITS
C WAS FOUND.
C = -2, A LEADING PLUS SIGN BUT NO VALUE DIGITS
C WAS FOUND.
C = -1, A LEADING PERIOD BUT NO VALUE DIGITS WAS
C FOUND.
C = 0, ONE OR MORE ZERO DIGITS WERE FOUND, BUT
C THE NUMBER CONTAINED NO DIGITS OTHER THAN
C ZERO. THE NUMBER REPRESENTATION MAY OR MAY
C NOT HAVE BEEN BEGUN BY A PLUS SIGN OR A
C MINUS SIGN AND MAY OR MAY NOT HAVE CONTAINED
C A DECIMAL POINT.
C = GREATER THAN ZERO, LSHIFT IS NUMBER OF
C DIGITS COUNTING LEFTMOST NON-ZERO DIGIT AND
C ALL WHICH WERE SPECIFIED TO ITS RIGHT. THIS
C IS INDEPENDENT OF ANY SHIFT IMPLIED BY A
C DECIMAL POINT OR EXPONENT
C IVALUE = RETURNED WITH VALUE IF KONTRL IS LESS THAN
C OR EQUAL TO ZERO. NOTE THAT IF KONTRL IS
C LESS THAN OR EQUAL TO ZERO, THEN ORIGINAL
C CONTENT OF IVALUE IS ALWAYS DESTROYED. IN
C PARTICULAR, IF KONTRL IS LESS THAN OR EQUAL
C TO ZERO AND IF KIND IS RETURNED CONTAINING
C EITHER 1 OR 2, THEN IVALUE WILL BE ZEROED.
C VALUE = RETURNED WITH VALUE IF KONTRL IS GREATER
C THAN ZERO. NOTE THAT IF KONTRL IS GREATER
C THAN ZERO, THEN THE ORIGINAL CONTENT OF
C VALUE IS ALWAYS DESTROYED. IN PARTICULAR,
C IF KONTRL IS GREATER THAN ZERO AND IF KIND
C IS RETURNED CONTAINING EITHER 1 OR 2, THEN
C VALUE WILL BE ZEROED.
C
DIMENSION IBUFFR(MAXBFR),IDIGIT(10),KAPLTR(3),
1LOWLTR(3),JPOWER(3)
C
C IDIGIT CONTAINS ALPHAMERIC FORM OF DIGITS 0 THRU 9
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C IBLANK CONTAINS SPACE CHARACTER AND ITAB CONTAINS
C TAB CHARACTER. IF TAB CHARACTER IS NOT AVAILABLE,
C ITAB SHOULD INSTEAD CONTAIN A SPACE ALSO.
DATA IPLUS,IMINUS,IDOT,IBLANK,ITAB/
11H+,1H-,1H.,1H ,1H /
C
C KAPLTR = LIST OF UPPER CASE LETTERS WHICH CAN FOLLOW
C A NUMBER TO INDICATE AN EXPONENT.
C LOWLTR = LIST OF LOWER CASE LETTERS CORRESPONDING TO
C UPPER CASE LETTERS IN KAPLTR ARRAY.
C JPOWER = VALUE OF THE EXPONENT ASSOCIATED WITH THE
C PARALLEL CHARACTERS IN THE KAPLTR AND LOWLTR
C ARRAYS. JPOWER CAN BE NEGATIVE, FOR EXAMPLE
C PERCENT SIGN WOULD CORRESPOND TO JPOWER=-2.
C MAXTST = NUMBER OF ITEMS IN EACH OF KAPLTR, LOWLTR
C AND JPOWER ARRAYS.
C KAPEXP = UPPER CASE LETTER E
C LOWEXP = LOWER CASE LETTER E
C
C UPPER CASE LETTERS CAN BE SUBSTITUTED FOR LOWER CASE
C IN FOLLOWING DATA STATEMENTS, IF COMPUTER UPON WHICH
C THIS ROUTINE IS USED DOES NOT SUPPORT LOWER CASE.
C
DATA KAPLTR/1H%,1HK,1HM/
DATA LOWLTR/1H%,1Hk,1Hm/
DATA JPOWER/-2,3,6/
DATA MAXTST/3/
DATA KAPEXP,LOWEXP/1HE,1He/
C
C INITIALIZE
ISIGN=0
IF(KONTRL.GT.0)VALUE=0.0
IF(KONTRL.LE.0)IVALUE=0
ISHIFT=0
JSHIFT=0
KSHIFT=0
LSHIFT=-4
IRADIX=10
IF(KONTRL.LT.0)IRADIX=8
IADD=IRADIX-2
IPOWER=0
NUMKNT=-4
NUMVAL=0
NMBEXP=-1
NUMPNT=-1
IDEFLT=0
IF(ITRAIL.LT.-5)IDEFLT=1
KTRAIL=ITRAIL
IF(KTRAIL.GT.5)KTRAIL=KTRAIL-10
IF(KTRAIL.LT.-5)KTRAIL=KTRAIL+10
LTRAIL=KTRAIL
IF(LTRAIL.LT.0)LTRAIL=-LTRAIL
GO TO 2
C
C *********************
C * SCAN FOR NUMBER *
C *********************
C
C LOOP LOOKING AT CHARACTERS IN IBUFFR ARRAY
1 LOWBFR=LOWBFR+1
2 IF(LOWBFR.GT.MAXBFR)GO TO 25
NOWLTR=IBUFFR(LOWBFR)
IF(NMBEXP.GE.0)GO TO 20
IF(ISIGN.NE.0)GO TO 4
C
C SCAN OVER LEADING SPACES AND/OR TABS
IF(NOWLTR.EQ.IBLANK)GO TO 1
IF(NOWLTR.EQ.ITAB)GO TO 1
C
C LOOK FOR INITIAL SIGNS + OR -
IF(KONTRL.LE.-2)GO TO 40
IF(LTRAIL.GE.3)GO TO 4
IF(NOWLTR.EQ.IPLUS)GO TO 3
IF(NOWLTR.NE.IMINUS)GO TO 4
ISIGN=-1
NUMKNT=-3
GO TO 1
3 ISIGN=1
NUMKNT=-2
GO TO 1
C
C LOOK FOR % K OR M FOLLOWING NUMBER
C LOCK OUT THESE AND ALSO E IF NO PART OF NUMBER FOUND
4 IF(LTRAIL.GE.2)GO TO 5
IF(ISIGN.EQ.0)GO TO 10
IF(KTRAIL.EQ.0)GO TO 10
5 IF(KTRAIL.LT.0)GO TO 8
I=0
6 I=I+1
IF(I.GT.MAXTST)GO TO 8
IF(NOWLTR.EQ.KAPLTR(I))GO TO 7
IF(NOWLTR.NE.LOWLTR(I))GO TO 6
7 IPOWER=JPOWER(I)
JSIGN=1
NMBEXP=1
ISHIFT=I
LOWBFR=LOWBFR+1
GO TO 26
C
C LOOK FOR LETTER E
8 IF(NOWLTR.EQ.KAPEXP)GO TO 9
IF(NOWLTR.NE.LOWEXP)GO TO 10
9 JSIGN=0
NMBEXP=0
ISHIFT=-4
GO TO 19
C
C LOOK FOR LEADING OR EMBEDDED PERIOD
10 IF(LTRAIL.GE.3)GO TO 24
IF(NUMPNT.GE.0)GO TO 11
IF(NOWLTR.NE.IDOT)GO TO 11
DECML=0.1
IF(ISIGN.EQ.0)NUMKNT=-1
GO TO 18
C
C LOOK FOR DIGIT OTHER THAN IN EXPONENT FIELD
11 DO 16 I=1,IRADIX
IF(NOWLTR.NE.IDIGIT(I))GO TO 16
IF(NUMKNT.GT.0)GO TO 12
NUMKNT=0
IF(I.EQ.1)GO TO 13
12 NUMKNT=NUMKNT+1
13 IF(KONTRL.LE.0)GO TO 15
IF(NUMKNT.LE.KONTRL)NUMVAL=(10*NUMVAL)+I-1
IF(NUMPNT.GE.0)GO TO 14
VALUE=(10.0*VALUE)+FLOAT(I-1)
GO TO 19
14 VALUE=VALUE+(DECML*FLOAT(I-1))
DECML=DECML/10.0
GO TO 18
C FOLLOWING ALLOWS LARGEST NEGATIVE NUMBER FOR
C WHICH THERE IS NOT CORRESPONDING POSITIVE VALUE
15 IF(NUMKNT.EQ.1)IVALUE=I-2
IF(NUMKNT.GT.1)IVALUE=(IRADIX*IVALUE)+I+IADD
GO TO 17
16 CONTINUE
GO TO 24
C
C DIGIT, E OR . FOUND SO MARK AS BEING IN NUMBER
17 IF(NUMPNT.LT.0)GO TO 19
18 NUMPNT=NUMPNT+1
19 IF(ISIGN.EQ.0)ISIGN=1
GO TO 1
C
C LOOK FOR SIGN IN EXPONENT FIELD
20 IF(JSIGN.NE.0)GO TO 22
IF(NOWLTR.EQ.IPLUS)GO TO 21
IF(NOWLTR.NE.IMINUS)GO TO 22
JSIGN=-1
ISHIFT=-3
GO TO 1
21 JSIGN=1
ISHIFT=-2
GO TO 1
C
C LOOK FOR DIGITS IN EXPONENT FIELD
22 DO 23 I=1,10
IF(NOWLTR.NE.IDIGIT(I))GO TO 23
IPOWER=(10*IPOWER)+I-1
NMBEXP=1
ISHIFT=-1
IF(JSIGN.EQ.0)JSIGN=1
GO TO 1
23 CONTINUE
GO TO 26
C
C DECIDE WHAT TO DO IF NO MATCH FOUND
24 IF(ISIGN.NE.0)GO TO 26
GO TO 40
C
C *******************************
C * NUMBER HAS BEEN EVALUATED *
C *******************************
C
25 IF(ISIGN.EQ.0)GO TO 39
26 KIND=3
C
C ADJUST EXPONENT SIGN
IF(NMBEXP.LT.0)GO TO 27
IF(NMBEXP.EQ.0)IPOWER=IDEFLT
IF(JSIGN.LT.0)IPOWER=-IPOWER
C
C SHIFT FLOATING POINT NUMBER ACCORDING TO EXPONENT
27 JSHIFT=IPOWER
KSHIFT=IPOWER
IF(NUMPNT.GT.0)KSHIFT=KSHIFT-NUMPNT
LSHIFT=NUMKNT
IF(NUMPNT.LT.0)NUMPNT=0
IF(ITRAIL.GT.5)IPOWER=NUMPNT
IPOWER=IPOWER+IEXTRA
IF(KONTRL.LE.0)GO TO 31
IF(NUMKNT.GT.KONTRL)GO TO 28
IF(NUMKNT.LT.0)NUMVAL=IDEFLT
IF(ISIGN.LT.0)NUMVAL=-NUMVAL
VALUE=FLOAT(NUMVAL)
IPOWER=IPOWER-NUMPNT
GO TO 29
28 IF(NUMKNT.LT.0)VALUE=IDEFLT
IF(ISIGN.LT.0)VALUE=-VALUE
29 IF(IPOWER.EQ.0)GO TO 41
IF(IPOWER.GT.0)GO TO 30
IPOWER=-IPOWER
VALUE=VALUE/(10.0**IPOWER)
GO TO 41
30 VALUE=VALUE*(10.0**IPOWER)
GO TO 41
C
C SHIFT AN INTEGER ACCORDING TO EXPONENT
31 IF(NUMKNT.LT.0)IVALUE=IDEFLT
IPOWER=IPOWER-NUMPNT
IF(ISIGN.GE.0)GO TO 32
IVALUE=-IVALUE
C NOTE THAT NEGATIVE NUMBER AT THIS POINT HAS ABSOLUTE
C VALUE 1 TOO LOW TO ALLOW THE LARGEST NEGATIVE NUMBER
C WHICH HAS NO CORRESPONDING POSITIVE VALUE IN TWOS
C COMPLEMENT NOTATION
IF(NUMKNT.GT.0)IVALUE=IVALUE-1
GO TO 33
32 IF(NUMKNT.GT.0)IVALUE=IVALUE+1
33 IF(IPOWER.LE.0)GO TO 37
IPOWER=IPOWER-1
KVALUE=IVALUE
IVALUE=IRADIX*IVALUE
IF(ISIGN.GE.0)GO TO 34
IF(IVALUE.GE.KVALUE)GO TO 36
GO TO 35
34 IF(IVALUE.LE.KVALUE)GO TO 36
35 IF((IVALUE/IRADIX).EQ.KVALUE)GO TO 33
36 IVALUE=KVALUE
37 IF(IPOWER.GE.0)GO TO 41
IPOWER=IPOWER+1
KVALUE=IVALUE
IVALUE=IVALUE/IRADIX
IF(ISIGN.GE.0)GO TO 38
IF((IRADIX*IVALUE).LT.KVALUE)IVALUE=IVALUE+1
38 IF(IVALUE.NE.0)GO TO 37
GO TO 41
C
C NUMBER NOT FOUND
39 KIND=1
GO TO 41
40 KIND=2
C
C RETURN TO CALLING PROGRAM
41 RETURN
C
C IBLANK = THE BLANK OR SPACE CHARACTER
C JSIGN = 0, NEITHER SIGN NOR DIGITS AFTER E
C = 1, EITHER PLUS OR DIGITS AFTER E
C = -1, MINUS SIGN AFTER E
C ITAB = THE TAB CHARACTER
C ISIGN = 0, NO PART OF NUMBER ENCOUNTERED
C = -1, MINUS SIGN AT START OF NUMBER
C = 1, NUMBER DOES NOT START WITH MINUS SIGN
C NMBEXP = -1, NO EXPONENT FIELD YET FOUND
C = 0, EXPONENT FIELD FOUND BUT NUMBER NOT
C YET FOUND
C = 1, NUMBER FOUND IN EXPONENT FIELD
C NOWLTR = THE CHARACTER CURRENTLY BEING TESTED
C NUMKNT = NUMBER OF DIGITS IN VALUE FIELD
C = 0, LEFT HAND ZERO ONLY READ SO FAR
C = -1, NO DIGITS YET FOUND
C NUMPNT = -1, DECIMAL POINT NOT YET FOUND
C = 0, DECIMAL POINT ENCOUNTERED IN VALUE FIELD
C = .GT.0, VALUE IS NUMBER OF DIGITS ENCOUNTERED
C TO RIGHT OF DECIMAL POINT IN NUMBER.
C204733708764%kme
END
SUBROUTINE DAIHFT(KONTRL,ITRAIL,IEXTRA,IBUFFR,MAXBFR,
1 LOWBFR,KIND ,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE)
C RENBR(/FREE FORMAT INTEGER INPUT ROUTINE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAIHFT INTERPRETS AN ARRAY READ BY THE CALLING
C PROGRAM WITH A MULTIPLE OF AN A1 FORMAT AND RETURNS
C THE VALUES IN THIS ARRAY.
C
C NUMBERS INTERPRETTED BY DAIHFT CAN CONTAIN LEADING
C SIGN, EMBEDDED DECIMAL POINT AND/OR TRAILING E WITH
C SIGNED EXPONENT. A PERCENT SIGN FOLLOWING THE NUMBER
C IMPLIES E-2, TRAILING LETTER K IMPLIES E3 AND
C TRAILING LETTER M IMPLIES E6.
C
C ARGUMENT LIST DEFINITIONS:
C
C KONTRL = 0 OR GREATER, NUMBER IS EVALUATED AS DECIMAL
C INTEGER. NUMBER CAN CONTAIN A DECIMAL POINT
C (FOR EXAMPLE 1.23K OR 1.23E3 EQUALS 1230),
C BUT IS STORED AS AN INTEGER IN DAIHFT, AND
C IS OUTPUT AS ARGUMENT IVALUE. ANY DECIMAL
C INTEGER WHICH THE COMPUTER CAN REPRESENT CAN
C BE EVALUATED. THIS INCLUDES, ON TWOS
C COMPLEMENT COMPUTERS, THE LARGEST NEGATIVE
C NUMBER THE ABSOLUTE VALUE OF WHICH CANNOT BE
C STORED. ON THE PDP10, A 36 BIT COMPUTER
C WITH TWOS COMPLEMENT NOTATION, THE RANGE OF
C DECIMAL INTEGERS IS -34359738368 THROUGH
C 34359738367 (OCTAL NOTATION OF BIT PATTERNS
C BEING 400000000000 THROUGH 377777777777).
C = -1, ITEM IN IBUFFR ARRAY IS OCTAL. THE
C NUMBER CAN BE TYPED WITH A DECIMAL POINT
C AND/OR WITH AN EXPONENT. HOWEVER, THE
C NUMBER FOLLOWING THE LETTER E OF THE
C EXPONENT IS EVALUATED IN DECIMAL. THE VALUE
C OF THE OCTAL NUMBER IS RETURNED AS THE
C ARGUMENT IVALUE. IT MUST BE NOTED THAT
C NUMBERS EVALUATED AS NEGATIVE OCTAL INTEGERS
C HAVE THE NEGATIVE OCTAL INTEGER AS THEIR
C VALUE, NOT AS THEIR BIT REPRESENTATION IN
C COMPUTER STORAGE. FOR EXAMPLE, ON A 36 BIT
C TWOS COMPLEMENT COMPUTER, THE OCTAL NUMBER
C -400000000000 (WHICH COULD ALSO BE TYPED AS
C -4E11 OR -4E+11 WHERE THE 11 AFTER THE E IS
C IN DECIMAL) IS REPRESENTED AS BIT PATTERN
C HAVING OCTAL NOTATION 400000000000 AND THE
C OCTAL NUMBER -377777777777 IS REPRESENTED BY
C THE BIT PATTERN 400000000001.
C = -2, DO NOT EVALUATE NUMBERS. INSTEAD THE
C CHARACTERS FORMING NUMBER ARE TREATED LIKE
C ANY OTHER PRINTING CHARACTERS.
C ITRAIL = SPECIFIES WHETHER EXPONENTS ARE TO BE
C RECOGNIZED.
C = -1, ALLOW NUMBERS TO BE FOLLOWED BY E
C EXPONENT, BUT DO NOT RECOGNIZE PERCENT SIGN,
C K OR M AT END OF NUMBER. E IS NOT
C RECOGNIZED IF NOT PRECEDED BY SIGN, DECIMAL
C POINT OR DIGIT.
C = 0, DO NOT ALLOW TRAILING PERCENT SIGN, K M
C OR E EXPONENT.
C = 1, ALLOW NUMBERS TO BE FOLLOWED BY PERCENT
C SIGN, K M OR E EXPONENT. PERCENT SIGN, K M
C OR E IS NOT RECOGNIZED IF NOT PRECEDED BY
C SIGN, DECIMAL POINT OR DIGIT.
C
C FOLLOWING VALUES DO NOT REQUIRE THAT EXPONENT
C BE PRECEDED BY NUMBER. ALTHOUGH RETURNED
C VALUE WILL ALWAYS BE ZERO IF NO VALUE DIGITS
C ARE FOUND, CALLING PROGRAM COULD ADJUST THIS
C RETURNED VALUE.
C
C = -3, LEADING E EXPONENT IS RECOGNIZED.
C LEADING DIGITS, SIGNS AND DECIMAL POINTS ARE
C NOT ALLOWED.
C = -2, SAME AS ITRAIL=-1, EXCEPT THAT IN
C ADDITION E EXPONENT IS RECOGNIZED EVEN IF
C NOT PRECEDED BY DIGITS, SIGN OR DECIMAL
C POINT.
C = 2, SAME AS ITRAIL=1, EXCEPT THAT IN ADDITION
C LEADING PERCENT SIGN, OR LETTERS K M OR E
C EXPONENT ARE RECOGNIZED EVEN IF NOT PRECEDED
C BY DIGITS, SIGN OR DECIMAL POINT.
C = 3, ONLY LEADING PERCENT SIGN OR LETTERS K M
C OR E EXPONENT ARE RECOGNIZED. LEADING
C DIGITS, SIGNS OR DECIMAL POINTS ARE NOT
C ALLOWED.
C
C IF 10 IS SUBTRACTED FROM ITRAIL VALUES -3
C THROUGH 3, AND IF EITHER VALUE DIGITS OR
C DIGITS FOLLOWING LETTER E ARE MISSING, THEN
C ONE, RATHER THAN ZERO, IS ASSUMED TO BE THE
C DEFAULT FOR THE VALUE OR THE EXPONENT
C RESPECTIVELY. -E- WOULD BE EQUIVALENT TO
C -1E-1 AND -E OR -E+ WOULD BE EQUIVALENT TO
C -1E1
C
C IF 10 IS ADDED TO ITRAIL VALUES -3 THROUGH 3,
C THEN VALUE IS RETURNED AS THOUGH NEITHER
C EXPONENT NOR DECIMAL POINT HAD BEEN TYPED.
C VALUE INDICATED BY COMBINATION OF DIGITS,
C DECIMAL POINT AND/OR EXPONENT CAN BE OBTAINED
C AS VALUE*10**KSHIFT OR IVALUE*10**KSHIFT.
C VALUE INDICATED BY COMBINATION OF DIGITS AND
C DECIMAL POINT BUT IGNORING EXPONENT CAN BE
C OBTAINED AS VALUE*10**(KSHIFT-JSHIFT) OR
C IVALUE*10**(KSHIFT-JSHIFT).
C IEXTRA = EXTRA SHIFT TO BE APPLIED TO VALUE. SHIFT
C IS STATED AS POWER OF RADIX. THIS IS
C APPLIED IN ADDITION TO SHIFT REPORTED IN
C ISHIFT, JSHIFT AND KSHIFT AS SPECIFIED BY
C USER. FOR EXAMPLE, IF DOLLAR VALUE IS TO BE
C RETURNED AS INTEGER NUMBER OF CENTS, IEXTRA
C WOULD HAVE VALUE 2.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY A MULTIPLE OF AN A1
C FORMAT, WHICH IS TO BE SEARCHED FOR WORDS
C AND NUMBERS. IBUFFR THEN CONTAINS 1 LETTER
C PER COMPUTER STORAGE LOCATION.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY TO BE
C SEARCHED
C LOWBFR = SUBSCRIPT WITHIN THE IBUFFR ARRAY OF THE
C FIRST (LEFTMOST) CHARACTER WHICH CAN BE
C SCANNED FOR NUMBERS. LOWBFR WILL BE RETURNED
C POINTING TO FIRST PRINTING CHARACTER WHICH
C CANNOT APPEAR IN A NUMBER, OR BEYOND THE END
C OF THE BUFFER IF THE BUFFER DOES NOT CONTAIN
C ANY PRINTING CHARACTERS.
C KIND = RETURNED DESCRIBING THE KIND OF ITEM LOCATED
C IN THE IBUFFR ARRAY.
C = 1, NOTHING WAS FOUND AT OR TO THE RIGHT OF
C LOWBFR. THE CALLING PROGRAM SHOULD READ A
C NEW LINE INTO IBUFFR.
C = 2, NUMBER WAS NOT FOUND, BUT A PRINTING
C CHARACTER WHICH CANNOT START A NUMBER WAS
C FOUND. LOWBFR IS RETURNED POINTING TO THIS
C PRINTING CHARACTER.
C = 3, A NUMBER WAS FOUND. LOWBFR IS RETURNED
C POINTING TO CHARACTER TO RIGHT OF NUMBER.
C ISHIFT = 0, RETURNED IF NONE OF CHARACTERS E, %, K OR
C M FOLLOW NUMBER
C = 1, PERCENT SIGN FOLLOWS NUMBER
C = 2, K FOLLOWS NUMBER
C = 3, M FOLLOWS NUMBER
C = LESS THAN ZERO, RETURNED IF E FOLLOWS
C NUMBER.
C = -1, E AND POSSIBLY SIGNED NUMBER FOLLOW
C NUMBER.
C = -2, E IS FOLLOWED BY PLUS SIGN NOT IN TURN
C FOLLOWED BY DIGITS.
C = -3, E IS FOLLOWED BY MINUS SIGN NOT IN TURN
C FOLLOWED BY DIGITS.
C = -4, E IS FOLLOWED BY NEITHER SIGN NOR DIGITS
C JSHIFT = EXPONENT INDICATED BY FOLLOWING PERCENT
C SIGN, K, M OR E FOLLOWED BY DIGITS. THIS
C WILL HAVE BEEN APPLIED TO RETURNED VALUE IF
C ITRAIL EQUALS EITHER -1 OR 1. 12.34K OR
C 12.34E3 WOULD GIVE JSHIFT OF 3. 12% OR
C 12E-2 WOULD GIVE JSHIFT -2.
C KSHIFT = EXPONENT WHICH WOULD BE NECESSARY TO OBTAIN
C DESIRED VALUE IF NUMBER HAD BEEN TYPED
C WITHOUT DECIMAL POINT. 12.34 STATED WITHOUT
C DECIMAL POINT WOULD BE 1234E-2 SO KSHIFT
C WOULD BE -2. 12.34K WOULD BE 1234E1 SO
C KSHIFT WOULD BE 1.
C LSHIFT = ZERO OR LESS, THE VALUE ZERO IS BEING
C RETURNED FOR EITHER VALUE OR IVALUE,
C WHICHEVER IS APPROPRIATE.
C = -4, NUMBER CONTAINED NEITHER VALUE DIGITS,
C NOR DECIMAL POINT, NOR LEADING PLUS SIGN,
C NOR LEADING MINUS SIGN. THIS VALUE OF
C LSHIFT IS ALWAYS RETURNED IF KIND IS
C RETURNED CONTAINING A VALUE OTHER THAN 3.
C IF KIND IS RETURNED CONTAINING THE VALUE 3,
C THEN ITRAIL MUST BE EITHER -3 OR 3, AND THE
C CONTENTS OF THE INPUT TEXT BUFFER MUST BEGIN
C WITH A REPRESENTATION OF AN EXPONENT.
C = -3, A LEADING MINUS SIGN BUT NO VALUE DIGITS
C WAS FOUND.
C = -2, A LEADING PLUS SIGN BUT NO VALUE DIGITS
C WAS FOUND.
C = -1, A LEADING PERIOD BUT NO VALUE DIGITS WAS
C FOUND.
C = 0, ONE OR MORE ZERO DIGITS WERE FOUND, BUT
C THE NUMBER CONTAINED NO DIGITS OTHER THAN
C ZERO. THE NUMBER REPRESENTATION MAY OR MAY
C NOT HAVE BEEN BEGUN BY A PLUS SIGN OR A
C MINUS SIGN AND MAY OR MAY NOT HAVE CONTAINED
C A DECIMAL POINT.
C = GREATER THAN ZERO, LSHIFT IS NUMBER OF
C DIGITS COUNTING LEFTMOST NON-ZERO DIGIT AND
C ALL WHICH WERE SPECIFIED TO ITS RIGHT. THIS
C IS INDEPENDENT OF ANY SHIFT IMPLIED BY A
C DECIMAL POINT OR EXPONENT
C IVALUE = RETURNED WITH VALUE IF NUMBER IS FOUND. THE
C ORIGINAL CONTENT OF IVALUE IS DESTROYED. IN
C PARTICULAR, IF KIND IS RETURNED CONTAINING
C EITHER 1 OR 2, THEN IVALUE WILL BE ZEROED.
C
DIMENSION IBUFFR(MAXBFR),IDIGIT(10),KAPLTR(3),
1LOWLTR(3),JPOWER(3)
C
C IDIGIT CONTAINS ALPHAMERIC FORM OF DIGITS 0 THRU 9
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C IBLANK CONTAINS SPACE CHARACTER AND ITAB CONTAINS
C TAB CHARACTER. IF TAB CHARACTER IS NOT AVAILABLE,
C ITAB SHOULD INSTEAD CONTAIN A SPACE ALSO.
DATA IPLUS,IMINUS,IDOT,IBLANK,ITAB/
11H+,1H-,1H.,1H ,1H /
C
C KAPLTR = LIST OF UPPER CASE LETTERS WHICH CAN FOLLOW
C A NUMBER TO INDICATE AN EXPONENT.
C LOWLTR = LIST OF LOWER CASE LETTERS CORRESPONDING TO
C UPPER CASE LETTERS IN KAPLTR ARRAY.
C JPOWER = VALUE OF THE EXPONENT ASSOCIATED WITH THE
C PARALLEL CHARACTERS IN THE KAPLTR AND LOWLTR
C ARRAYS. JPOWER CAN BE NEGATIVE, FOR EXAMPLE
C PERCENT SIGN WOULD CORRESPOND TO JPOWER=-2.
C MAXTST = NUMBER OF ITEMS IN EACH OF KAPLTR, LOWLTR
C AND JPOWER ARRAYS.
C KAPEXP = UPPER CASE LETTER E
C LOWEXP = LOWER CASE LETTER E
C
C UPPER CASE LETTERS CAN BE SUBSTITUTED FOR LOWER CASE
C IN FOLLOWING DATA STATEMENTS, IF COMPUTER UPON WHICH
C THIS ROUTINE IS USED DOES NOT SUPPORT LOWER CASE.
C
DATA KAPLTR/1H%,1HK,1HM/
DATA LOWLTR/1H%,1Hk,1Hm/
DATA JPOWER/-2,3,6/
DATA MAXTST/3/
DATA KAPEXP,LOWEXP/1HE,1He/
C
C INITIALIZE
ISIGN=0
IVALUE=0
ISHIFT=0
JSHIFT=0
KSHIFT=0
LSHIFT=-4
IRADIX=10
IF(KONTRL.LT.0)IRADIX=8
IADD=IRADIX-2
IPOWER=0
NUMKNT=-4
NMBEXP=-1
NUMPNT=-1
IDEFLT=0
IF(ITRAIL.LT.-5)IDEFLT=1
KTRAIL=ITRAIL
IF(KTRAIL.GT.5)KTRAIL=KTRAIL-10
IF(KTRAIL.LT.-5)KTRAIL=KTRAIL+10
LTRAIL=KTRAIL
IF(LTRAIL.LT.0)LTRAIL=-LTRAIL
GO TO 2
C
C *********************
C * SCAN FOR NUMBER *
C *********************
C
C LOOP LOOKING AT CHARACTERS IN IBUFFR ARRAY
1 LOWBFR=LOWBFR+1
2 IF(LOWBFR.GT.MAXBFR)GO TO 23
NOWLTR=IBUFFR(LOWBFR)
IF(NMBEXP.GE.0)GO TO 18
IF(ISIGN.NE.0)GO TO 4
C
C SCAN OVER LEADING SPACES AND/OR TABS
IF(NOWLTR.EQ.IBLANK)GO TO 1
IF(NOWLTR.EQ.ITAB)GO TO 1
C
C LOOK FOR INITIAL SIGNS + OR -
IF(KONTRL.LE.-2)GO TO 34
IF(LTRAIL.GE.3)GO TO 4
IF(NOWLTR.EQ.IPLUS)GO TO 3
IF(NOWLTR.NE.IMINUS)GO TO 4
ISIGN=-1
NUMKNT=-3
GO TO 1
3 ISIGN=1
NUMKNT=-2
GO TO 1
C
C LOOK FOR % K OR M FOLLOWING NUMBER
C LOCK OUT THESE AND ALSO E IF NO PART OF NUMBER FOUND
4 IF(LTRAIL.GE.2)GO TO 5
IF(ISIGN.EQ.0)GO TO 10
IF(KTRAIL.EQ.0)GO TO 10
5 IF(KTRAIL.LT.0)GO TO 8
I=0
6 I=I+1
IF(I.GT.MAXTST)GO TO 8
IF(NOWLTR.EQ.KAPLTR(I))GO TO 7
IF(NOWLTR.NE.LOWLTR(I))GO TO 6
7 IPOWER=JPOWER(I)
JSIGN=1
NMBEXP=1
ISHIFT=I
LOWBFR=LOWBFR+1
GO TO 24
C
C LOOK FOR LETTER E
8 IF(NOWLTR.EQ.KAPEXP)GO TO 9
IF(NOWLTR.NE.LOWEXP)GO TO 10
9 JSIGN=0
NMBEXP=0
ISHIFT=-4
GO TO 17
C
C LOOK FOR LEADING OR EMBEDDED PERIOD
10 IF(LTRAIL.GE.3)GO TO 22
IF(NUMPNT.GE.0)GO TO 11
IF(NOWLTR.NE.IDOT)GO TO 11
IF(ISIGN.EQ.0)NUMKNT=-1
GO TO 16
C
C LOOK FOR DIGIT OTHER THAN IN EXPONENT FIELD
11 DO 14 I=1,IRADIX
IF(NOWLTR.NE.IDIGIT(I))GO TO 14
IF(NUMKNT.GT.0)GO TO 12
NUMKNT=0
IF(I.EQ.1)GO TO 13
12 NUMKNT=NUMKNT+1
C FOLLOWING ALLOWS LARGEST NEGATIVE NUMBER FOR
C WHICH THERE IS NOT CORRESPONDING POSITIVE VALUE
13 IF(NUMKNT.EQ.1)IVALUE=I-2
IF(NUMKNT.GT.1)IVALUE=(IRADIX*IVALUE)+I+IADD
GO TO 15
14 CONTINUE
GO TO 22
C
C DIGIT, E OR . FOUND SO MARK AS BEING IN NUMBER
15 IF(NUMPNT.LT.0)GO TO 17
16 NUMPNT=NUMPNT+1
17 IF(ISIGN.EQ.0)ISIGN=1
GO TO 1
C
C LOOK FOR SIGN IN EXPONENT FIELD
18 IF(JSIGN.NE.0)GO TO 20
IF(NOWLTR.EQ.IPLUS)GO TO 19
IF(NOWLTR.NE.IMINUS)GO TO 20
JSIGN=-1
ISHIFT=-3
GO TO 1
19 JSIGN=1
ISHIFT=-2
GO TO 1
C
C LOOK FOR DIGITS IN EXPONENT FIELD
20 DO 21 I=1,10
IF(NOWLTR.NE.IDIGIT(I))GO TO 21
IPOWER=(10*IPOWER)+I-1
NMBEXP=1
ISHIFT=-1
IF(JSIGN.EQ.0)JSIGN=1
GO TO 1
21 CONTINUE
GO TO 24
C
C DECIDE WHAT TO DO IF NO MATCH FOUND
22 IF(ISIGN.NE.0)GO TO 24
GO TO 34
C
C *******************************
C * NUMBER HAS BEEN EVALUATED *
C *******************************
C
23 IF(ISIGN.EQ.0)GO TO 33
24 KIND=3
C
C ADJUST EXPONENT SIGN
IF(NMBEXP.LT.0)GO TO 25
IF(NMBEXP.EQ.0)IPOWER=IDEFLT
IF(JSIGN.LT.0)IPOWER=-IPOWER
C
C SHIFT AN INTEGER ACCORDING TO EXPONENT
25 JSHIFT=IPOWER
KSHIFT=IPOWER
IF(NUMPNT.GT.0)KSHIFT=KSHIFT-NUMPNT
LSHIFT=NUMKNT
IF(NUMPNT.GT.0)IPOWER=IPOWER-NUMPNT
IF(ITRAIL.GT.5)IPOWER=0
IPOWER=IPOWER+IEXTRA
IF(NUMKNT.LT.0)IVALUE=IDEFLT
IF(ISIGN.GE.0)GO TO 26
IVALUE=-IVALUE
C NOTE THAT NEGATIVE NUMBER AT THIS POINT HAS ABSOLUTE
C VALUE 1 TOO LOW TO ALLOW THE LARGEST NEGATIVE NUMBER
C WHICH HAS NO CORRESPONDING POSITIVE VALUE IN TWOS
C COMPLEMENT NOTATION
IF(NUMKNT.GT.0)IVALUE=IVALUE-1
GO TO 27
26 IF(NUMKNT.GT.0)IVALUE=IVALUE+1
27 IF(IPOWER.LE.0)GO TO 31
IPOWER=IPOWER-1
KVALUE=IVALUE
IVALUE=IRADIX*IVALUE
IF(ISIGN.GE.0)GO TO 28
IF(IVALUE.GE.KVALUE)GO TO 30
GO TO 29
28 IF(IVALUE.LE.KVALUE)GO TO 30
29 IF((IVALUE/IRADIX).EQ.KVALUE)GO TO 27
30 IVALUE=KVALUE
31 IF(IPOWER.GE.0)GO TO 35
IPOWER=IPOWER+1
KVALUE=IVALUE
IVALUE=IVALUE/IRADIX
IF(ISIGN.GE.0)GO TO 32
IF((IRADIX*IVALUE).LT.KVALUE)IVALUE=IVALUE+1
32 IF(IVALUE.NE.0)GO TO 31
GO TO 35
C
C IF DELIMITER AT END OF LINE, MARK VALUE AS MISSING
33 KIND=1
GO TO 35
34 KIND=2
C
C RETURN TO CALLING PROGRAM
35 RETURN
C
C IBLANK = THE BLANK OR SPACE CHARACTER
C JSIGN = 0, NEITHER SIGN NOR DIGITS AFTER E
C = 1, EITHER PLUS OR DIGITS AFTER E
C = -1, MINUS SIGN AFTER E
C ITAB = THE TAB CHARACTER
C ISIGN = 0, NO PART OF NUMBER ENCOUNTERED
C = -1, MINUS SIGN AT START OF NUMBER
C = 1, NUMBER DOES NOT START WITH MINUS SIGN
C NMBEXP = -1, NO EXPONENT FIELD YET FOUND
C = 0, EXPONENT FIELD FOUND BUT NUMBER NOT
C YET FOUND
C = 1, NUMBER FOUND IN EXPONENT FIELD
C NOWLTR = THE CHARACTER CURRENTLY BEING TESTED
C NUMKNT = NUMBER OF DIGITS IN VALUE FIELD
C = 0, LEFT HAND ZERO ONLY READ SO FAR
C = -1, NO DIGITS YET FOUND
C NUMPNT = -1, DECIMAL POINT NOT YET FOUND
C = 0, DECIMAL POINT ENCOUNTERED IN VALUE FIELD
C = .GT.0, VALUE IS NUMBER OF DIGITS ENCOUNTERED
C TO RIGHT OF DECIMAL POINT IN NUMBER.
C982714844451%kme
END
SUBROUTINE DATREK(LOWVLU,MAXVLU,MAXBFR,IBUFFR,LOWBFR,
1 KIND ,IVALUE,KNTVLU)
C RENBR(/EVALUATE INTEGER SERIES OF FORM 1.2.3)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO EVALUATE SERIES OF UNSIGNED INTEGERS
C SEPARATED BY PERIODS. VALUE OF -1 IS RETURNED FOR A
C MISSING INTEGER INDICATED BY AN INITIAL PERIOD, BY A
C TRAILING PERIOD, OR BY 2 ADJACENT PERIODS. SIGNS AND
C EXPONENTS ARE NOT RECOGNIZED.
C
C LOWVLU = SUBSCRIPT OF LOWEST LOCATION IN IVALUE ARRAY
C WHICH CAN BE USED TO RETURN VALUES IN SERIES
C MAXVLU = SUBSCRIPT OF HIGHEST LOCATION IN IVALUE
C ARRAY WHICH CAN BE USED TO RETURN VALUES IN
C SERIES
C MAXBFR = SUBSCRIPT OF LOCATION IN IBUFFR ARRAY
C CONTAINING FINAL CHARACTER TO BE EVALUATED
C IBUFFR = ARRAY CONTAINING IN LOCATIONS LOWBFR THROUGH
C MAXBFR THE CHARACTERS TO BE EVALUATED AS IF
C READ BY MULTIPLE OF A1 FORMAT OR BY SEVERAL
C 1H FIELDS
C LOWBFR = INPUT CONTAINING SUBSCRIPT OF FIRST LOCATION
C OF IBUFFR ARRAY CONTAINING CHARACTER TO BE
C EVALUATED
C = RETURNED CONTAINING SUBSCRIPT OF FIRST
C LOCATION IN IBUFFR ARRAY CONTAINING
C CHARACTER NOT YET EVALUATED BY THIS ROUTINE
C KIND = 1, RETURNED IF IBUFFR IS EMPTY OR CONTAINS
C ONLY BLANKS OR TABS. LOWBFR IS RETURNED
C CONTAINING MAXBFR+1
C = 2, RETURNED IF NUMBER NOT FOUND, BUT UNKNOWN
C CHARACTER IS LOCATED AT RETURNED VALUE OF
C LOWBFR
C = 3, RETURNED IF NUMBER OR SERIES OF NUMBERS
C WAS FOUND. LOWBFR IS RETURNED POINTING TO
C NEXT CHARACTER BEYOND END OF SERIES OF
C NUMBERS
C = 4, SAME AS KIND=3, EXCEPT IVALUE CONTAINS
C INSUFFICIENT SPACE TO STORE ALL THE VALUES
C ENCOUNTERED.
C IVALUE = ARRAY RETURNED CONTAINING EVALUATED NUMBERS
C IN LOCATIONS LOWVLU THROUGH RETURNED VALUE
C OF KNTVLU. A NUMBER INDICATED AS MISSING BY
C AN INITIAL OR TERMINAL PERIOD, OR BY 2
C ADJACENT PERIODS, IS INDICATED BY THE VALUE
C -1 BEING RETURNED IN IVALUE. NEGATIVE
C NUMBERS ARE NOT OTHERWISE RETURNED
C KNTVLU = RETURNED CONTAINING SUBSCRIPT OF HIGHEST
C LOCATION USED IN IVALUE ARRAY.
C
DIMENSION IBUFFR(MAXBFR),IVALUE(MAXVLU),IDIGIT(10)
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA IDOT,IBLANK,ITAB/1H.,1H ,1H /
C
KNTVLU=LOWVLU-1
ISTATE=0
NEWVLU=0
GO TO 4
C
C PERIOD FOUND
1 IF(KNTVLU.GE.MAXVLU)GO TO 2
IF(ISTATE.LE.0)NEWVLU=-1
KNTVLU=KNTVLU+1
IVALUE(KNTVLU)=NEWVLU
2 NEWVLU=0
ISTATE=-1
C
C CHECK IF NEXT CHARACTER IS ALLOWED IN NUMBER SERIES
3 LOWBFR=LOWBFR+1
4 IF(LOWBFR.GT.MAXBFR)GO TO 7
LETTER=IBUFFR(LOWBFR)
IF(LETTER.EQ.IBLANK)GO TO 6
IF(LETTER.EQ.ITAB)GO TO 6
IF(LETTER.EQ.IDOT)GO TO 1
DO 5 I=1,10
IF(LETTER.NE.IDIGIT(I))GO TO 5
ISTATE=1
NEWVLU=(10*NEWVLU)+I-1
GO TO 3
5 CONTINUE
C
C UNKNOWN CHARACTER FOUND
IF(ISTATE.EQ.0)GO TO 9
C
C SPACE OR TAB CHARACTER FOUND
6 IF(ISTATE.EQ.0)GO TO 3
C
C END OF BUFFER
7 IF(ISTATE.EQ.0)GO TO 8
C
C END OF NUMBER SEQUENCE
IF(KNTVLU.GE.MAXVLU)GO TO 11
IF(ISTATE.LE.0)NEWVLU=-1
KNTVLU=KNTVLU+1
IVALUE(KNTVLU)=NEWVLU
GO TO 10
C
C RETURN TO CALLING PROGRAM
8 KIND=1
GO TO 12
9 KIND=2
GO TO 12
10 KIND=3
GO TO 12
11 KIND=4
12 RETURN
C309755265976
END
SUBROUTINE DAPATH(LOWVLU,KNTVLU,IVALUE,JSTIFY,IFILL ,
1 IWIDTH,LFTCOL,MAXBFR,IBUFFR,KOUNT ,IERR )
C RENBR(/REPRESENT INTEGER SEQUENCE OF FORM 1.2.3)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C LOWVLU = SUBSCRIPT OF LOWEST LOCATION IN IVALUE ARRAY
C WHICH SPECIFIES PART OF INTEGER SEQUENCE TO
C BE REPRESENTED.
C KNTVLU = SUBSCRIPT OF HIGHEST LOCATION IN IVALUE
C ARRAY WHICH SPECIFIES PART OF INTEGER
C SEQUENCE TO BE REPRESENTED.
C IVALUE = ARRAY CONTAINING DESCRIPTION OF INTEGER
C SEQUENCE IN LOCATIONS IVALUE(LOWVLU) THROUGH
C IVALUE(KNTVLU). VALUES EQUAL TO OR GREATER
C THAN ZERO ARE REPRESENTED DIRECTLY AND
C SEPARATED BY PERIODS. VALUES LESS THAN ZERO
C ARE NOT REPRESENTED, BUT SAME SEPARATING
C PERIODS APPEAR AS IF VALUES WERE
C REPRESENTED.
C JSTIFY = -1, LEFT JUSTIFY REPRESENTATION OF INTEGER
C SEQUENCE IN FIELD CONSISTING OF
C IBUFFR(LFTCOL+1) THROUGH IBUFFR(LFTCOL+
C IWIDTH).
C = 0, CENTER REPRESENTATION OF INTEGER SEQUENCE
C IN FIELD CONSISTING OF IBUFFR(LFTCOL+1)
C THROUGH IBUFFR(LFTCOL+IWIDTH). IBUFFR ARRAY
C LOCATIONS TO LEFT OF REPRESENTATION OF
C INTEGER SEQUENCE ARE FILLED WITH SPACES.
C = 1, RIGHT JUSTIFY REPRESENTATION OF INTEGER
C SEQUENCE IN FIELD CONSISTING OF
C IBUFFR(LFTCOL+1) THROUGH IBUFFR(LFTCOL+
C IWIDTH). IBUFFR ARRAY LOCATIONS TO LEFT OF
C REPRESENTATION OF INTEGER SEQUENCE ARE
C FILLED WITH SPACES.
C IFILL = 0, DO NOT FILL PORTION OF FIELD RIGHT OF
C REPRESENTATION OF INTEGER SEQUENCE WITH
C SPACES. VALUE OF IFILL HAS NO EFFECT ON
C PRINTING CHARACTERS IN REPRESENTATION OF
C INTEGER SEQUENCE. KOUNT WILL BE RETURNED
C POINTING TO RIGHTMOST PRINTING CHARACTER IN
C REPRESENTATION OF INTEGER SEQUENCE.
C = 1, FILL FIELD RIGHT OF REPRESENTATION OF
C INTEGER SEQUENCE AND EXTENDING THROUGH
C IBUFFR(LFTCOL+IWIDTH) WITH SPACES. KOUNT
C WILL BE RETURNED RETURNED POINTING TO
C IBUFFR(LFTCOL+IWIDTH).
C IWIDTH = WIDTH, STATED AS NUMBER OF COLUMNS OR IBUFFR
C ARRAY LOCATIONS, OF FIELD IN WHICH INTEGER
C SEQUENCE IS TO BE REPRESENTATED. RIGHTMOST
C IBUFFR ARRAY LOCATION IN FIELD HAS SUBSCRIPT
C LFTCOL+IWIDTH OR ELSE MAXBFR, WHICHEVER IS
C SMALLER.
C LFTCOL = SUBSCRIPT OF IBUFFR ARRAY LOCATION TO
C IMMEDIATE LEFT OF LEFTMOST IBUFFR ARRAY
C LOCATION INTO WHICH EITHER SPACE OR
C CHARACTER OF REPRESENTATION OF INTEGER
C SEQUENCE CAN BE PLACED.
C MAXBFR = SUBSCRIPT OF RIGHTMOST IBUFFR ARRAY LOCATION
C WHICH COULD BE PLACED SPACE OR CHARACTER OF
C REPRESENTATION OF INTEGER SEQUENCE IF IWIDTH
C IS LARGE ENOUGH.
C IBUFFR = ARRAY IN WHICH REPRESENTATION OF INTEGER
C SEQUENCE IS RETURNED, 1 CHARACTER PER ARRAY
C LOCATION AS THOUGH READ BY MULTIPLE OF A1
C FORMAT.
C KOUNT = RETURNED CONTAINING SUBSCRIPT OF RIGHTMOST
C LOCATION OF IBUFFR ARRAY INTO WHICH
C CHARACTER HAS BEEN PLACED BY THIS ROUTINE.
C IERR = -1 RETURNED IF REPRESENTATION OF ENTIRE
C INTEGER SEQUENCE WOULD NOT FIT INTO FIELD
C INDICATED BY LFTCOL AND BY EITHER IWIDTH OR
C MAXBFR, WHICHEVER INDICATES SMALLER FIELD.
C IF MAXBFR IS GREATER THAN OR EQUAL TO
C LFTCOL+IWIDTH, THEN IBUFFR(LFTCOL+1) THROUGH
C IBUFFR(LFTCOL+IWIDTH) ARE RETURNED
C CONTAINING ASTERISKS, AND KOUNT IS RETURNED
C SET EQUAL TO LFTCOL+IWIDTH. IF MAXBFR IS
C LESS THAN LFTCOL+IWIDTH, THEN THE ASTERISKS
C EXTEND THROUGH IBUFFR(MAXBFR) AND KOUNT IS
C RETURNED SET EQUAL TO MAXBFR.
C = 0 RETURNED IF ENTIRE INTEGER SEQUENCE COULD
C BE REPRESENTED IN FIELD.
C
DIMENSION IBUFFR(MAXBFR),IVALUE(KNTVLU)
DATA IDOT/1H./
C
C PREPARE TO REPRESENT FIRST NUMBER IN SERIES
LTREND=LFTCOL+IWIDTH
IF(LTREND.GT.MAXBFR)LTREND=MAXBFR
JPOINT=LFTCOL
IERR=0
IF(KNTVLU.LT.LOWVLU)GO TO 4
INDEX=LOWVLU
C
C REPRESENT NEXT NUMBER IN SERIES
1 NUMBER=IVALUE(INDEX)
IF(NUMBER.LT.0)GO TO 2
INITAL=JPOINT
CALL DANUMB(0,NUMBER,10,IBUFFR,JPOINT,INITAL,LTREND)
IF(JPOINT.LE.INITAL)GO TO 3
2 INDEX=INDEX+1
IF(INDEX.GT.KNTVLU)GO TO 4
IF(JPOINT.GE.LTREND)GO TO 3
JPOINT=JPOINT+1
IBUFFR(JPOINT)=IDOT
GO TO 1
C
C FILL FIELD WITH STARS IF SERIES WON'T FIT
3 IERR=-1
C
C JUSTIFY THE SERIES
4 CALL DAMOVE(JSTIFY,IFILL ,LFTCOL,LTREND,IERR ,
1 IBUFFR,JPOINT )
C
C RETURN TO CALLING PROGRAM
5 KOUNT=JPOINT
RETURN
C223649117134
END
SUBROUTINE DAVERB(LOWWRD,MAXWRD,IWORD ,LOWKNT,MAXKNT,
1 KNTLTR,IBUFFR,MAXBFR,LOWBFR,KIND ,MATCH ,LCNWRD,
2 LCNKNT,LCNBFR)
C RENBR(/IDENTIFY WORDS OR ABBREVIATIONS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAVERB INTERPRETS AN ARRAY READ BY THE CALLING
C PROGRAM WITH A MULTIPLE OF AN A1 FORMAT AND
C IDENTIFIES THE WORDS AND WORD ABBREVIATIONS CONTAINED
C IN THIS ARRAY. THE WORDS ARE RECOGNIZED BY BEING
C MATCHED AGAINST A USER DEFINED DICTIONARY. IF THE
C ARRAY CONTAINS ABBREVIATIONS OF WORDS IN THE
C DICTIONARY, THEN DAVERB ALSO SPECIFIES WHETHER THESE
C ABBREVIATIONS ARE AMBIGUOUS.
C
C ARGUMENT LIST DEFINITIONS:
C
C LOWBFR IS USED FOR BOTH INPUT AND OUTPUT. KIND,
C MATCH, LCNWRD, LCNKNT AND LCNBFR ARE USED ONLY FOR
C OUTPUT. REMAINING ARGUMENTS ARE USED ONLY FOR INPUT.
C
C LOWWRD = SUBSCRIPT OF LOCATION IN IWORD ARRAY WHICH
C CONTAINS 1ST LETTER OF 1ST WORD. NOTE THAT
C IF KNTLTR(LOWKNT) IS NEGATIVE, THEN THE 1ST
C LETTER OF 1ST WORD WILL BE FOUND IN ARRAY
C LOCATION IWORD(LOWWRD-KNTLTR(LOWKNT)).
C MAXWRD = DIMENSION OF IWORD ARRAY.
C IWORD = DICTIONARY ARRAY CONTAINING CHARACTERS OF
C WORDS TO BE RECOGNIZED, 1 CHARACTER PER
C ARRAY LOCATION AS READ BY A1 FORMAT OR ELSE
C DEFINED BY 1H FIELD. SECTIONS OF A WORD CAN
C BE ABBREVIATED AND/OR SEPARATED BY SPACES OR
C TABS IF THE WORD IN IWORD CONTAINS A SINGLE
C SPACE BETWEEN EACH SUCH SECTION AND IF THE
C LENGTH STORED IN THE KNTLTR ARRAY IS 100
C MORE THAN THE ACTUAL LENGTH (INCLUDING THE
C SPACES). ALL LETTERS IN THE IWORD ARRAY
C MUST BE UPPER CASE.
C LOWKNT = SUBSCRIPT OF KNTLTR ARRAY LOCATION DEFINING
C LENGTH OF FIRST WORD WHICH CAN BE MATCHED IN
C THE IWORD ARRAY. THIS FIRST WORD WILL START
C AT IWORD(LOWWRD). IF NO WORDS ARE TO BE
C RECOGNIZED, THEN EITHER MAXKNT SHOULD BE
C LESS THAN LOWKNT, OR ELSE BOTH LOWKNT AND
C MAXKNT CAN POINT TO THE SAME ZERO ENTRY IN
C THE KNTLTR ARRAY.
C MAXKNT = SUBSCRIPT OF KNTLTR ARRAY LOCATION DEFINING
C LENGTH OF FINAL WORD WHICH CAN BE MATCHED IN
C THE IWORD ARRAY.
C KNTLTR = ARRAY CONTAINING THE NUMBERS OF CHARACTERS
C IN THE WORDS IN THE IWORD ARRAY. A ZERO OR
C NEGATIVE VALUE IN THE KNTLTR ARRAY OFFSETS
C THE NEXT POSSIBLE WORD WHICH CAN BE MATCHED
C IN THE IWORD ARRAY BY THE NUMBER OF LETTERS
C GIVEN BY THE ABSOLUTE VALUE OF THE NEGATIVE
C NUMBER IN THE KNTLTR ARRAY. DIMENSION OF
C KNTLTR MUST BE AT LEAST MAXKNT. FOR EXAMPLE
C TO RECOGNIZE THE WORDS
C
C YES, NO, MAYBE
C
C THE CONTENTS OF THE IWORD ARRAY WOULD BE
C
C 1HY,1HE,1HS,1HN,1HO,1HM,1HA,1HY,1HB,1HE
C
C AND CONTENTS OF THE KNTLTR ARRAY WOULD BE
C
C 3,2,5
C
C IF A WORD IN THE IWORD ARRAY CONTAINS
C EMBEDDED SPACES, THEN 100 MUST BE ADDED TO
C THE LENGTH STORED FOR THIS WORD IN THE
C KNTLTR ARRAY TO ALLOW THE PORTION OF THE
C WORD LEFT OF THE SPACE TO BE ABBREVIATED.
C VALUES 101 THROUGH 199 IN KNTLTR ARRAY THUS
C INDICATE WORDS CONTAINING SPACES WHICH HAVE
C LENGTHS OF 1 THROUGH 99 RESPECTIVELY. THE
C VALUE 100 IN THE KNTLTR ARRAY IS TREATED THE
C SAME AS A ZERO.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY A MULTIPLE OF AN A1
C FORMAT, WHICH IS TO BE SEARCHED FOR WORDS.
C IBUFFR THEN CONTAINS 1 LETTER PER COMPUTER
C STORAGE LOCATION. LETTERS IN THE IBUFFR
C ARRAY CAN BE EITHER UPPER OR LOWER CASE.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY TO BE
C SEARCHED
C LOWBFR = SUBSCRIPT WITHIN THE IBUFFR ARRAY OF THE
C FIRST (LEFTMOST) CHARACTER WHICH CAN BE
C SCANNED FOR WORDS. LOWBFR WILL BE RETURNED
C POINTING TO THE NEXT CHARACTER BEYOND A
C MATCHED WORD IF A WORD IS FOUND. IF THERE
C IS NOTHING AT OR TO RIGHT OF LOWBFR, THEN
C LOWBFR WILL BE LEFT POINTING AT MAXBFR+1 AND
C KIND WILL BE RETURNED CONTAINING ONE.
C LOWBFR MUST BE SET BY CALLING PROGRAM BEFORE
C ANYTHING IS PROCESSED IN CURRENT CONTENTS
C OF THE IBUFFR ARRAY, BUT THEN SHOULD NOT BE
C MODIFIED BY CALLING PROGRAM UNTIL THE ENTIRE
C CONTENTS OF IBUFFR ARRAY HAS BEEN PROCESSED.
C KIND = RETURNED DESCRIBING THE KIND OF ITEM LOCATED
C IN THE IBUFFR ARRAY.
C = 1, NOTHING WAS FOUND AT OR TO THE RIGHT OF
C LOWBFR. THE CALLING PROGRAM SHOULD READ A
C NEW LINE INTO IBUFFR.
C = 2, ACCEPTABLE WORD OR ABBREVIATION THEREOF
C WAS NOT FOUND, BUT A PRINTING CHARACTER WAS
C FOUND WHICH DOES NOT BEGIN ANY WORD IN THE
C DICTIONARY. LOWBFR IS RETURNED POINTING TO
C THIS PRINTING CHARACTER.
C = RETURNED CONTAINING 3, 4 OR 5 IF A WORD IN
C THE DICTIONARY WAS MATCHED EVEN PARTIALLY.
C FOR EXAMPLE, IF DICTIONARY CONTAINED BOTH OF
C THE WORDS NO AND NONE, THEN
C A) INITIAL LETTER N IN THE BUFFER FOLLOWED
C BY SOME CHARACTER OTHER THAN THE LETTER O
C WOULD BE AMBIGUOUS ABBREVIATION AND THE
C POINTER NAMED MATCH WOULD BE RETURNED
C POINTING TO (CONTAINING SEQUENCE NUMBER
C WITHIN DICTIONARY OF) WHICHEVER WORD NO
C OR NONE APPEARED FIRST IN THE DICTIONARY.
C B) INITIAL LETTERS N AND O FOLLOWED BY SOME
C CHARACTER OTHER THAN THE LETTER N WOULD
C BE AN EXACT MATCH WITH THE WORD NO.
C C) INITIAL LETTERS N AND O AND N WOULD BE A
C PARTIAL BUT NONAMBIGUOUS MATCH WITH THE
C WORD NONE.
C LEADING SPACES AND/OR TABS ARE IGNORED. A
C STRING OF CHARACTERS CONTAINING EMBEDDED
C SPACES AND/OR TABS CAN MATCH A WORD IN THE
C DICTIONARY ONLY IF THE WORD IN DICTIONARY
C CONTAINS A SINGLE SPACE AT THE POSITION AT
C WHICH THE SPACES AND/OR TABS ARE ALLOWED
C (BUT NOT NECESSARY).
C = 3, A WORD IN THE IWORD ARRAY WAS MATCHED
C EXACTLY. MATCH IS RETURNED CONTAINING THE
C SEQUENCE NUMBER OF THE WORD MATCHED IN THE
C IWORD ARRAY.
C = 4, A NONAMBIGUOUS ABBREVIATION OF A WORD IN
C THE IWORD ARRAY WAS FOUND. MATCH IS
C RETURNED CONTAINING THE SEQUENCE NUMBER OF
C THE WORD IN THE IWORD ARRAY.
C = 5, AN AMBIGUOUS ABBREVIATION OF A WORD WAS
C FOUND. MATCH IS RETURNED CONTAINING THE
C SEQUENCE NUMBER OF THE FIRST WORD MATCHED IN
C THE IWORD ARRAY.
C MATCH = RETURNED CONTAINING THE SEQUENCE NUMBER OF A
C WORD MATCHED IN THE IWORD ARRAY IF KIND IS
C RETURNED CONTAINING 3, 4 OR 5. FOR EXAMPLE,
C IF THE SECOND WORD IS MATCHED, THEN MATCH
C WOULD BE RETURNED CONTAINING 2. THE
C SEQUENCE NUMBER OF THE WORD IN THE IWORD
C ARRAY DOES NOT INCLUDE THE LETTERS SKIPPED
C OVER BY THE VALUE OF LOWWRD, AND DOES NOT
C INCLUDE THE LETTERS SKIPPED OVER BY NEGATIVE
C VALUES ENCOUNTERED IN THE KNTLTR ARRAY.
C MATCH IS RETURNED CONTAINING KIND-2 IF KIND
C IS RETURNED .LE.2 INDICATING THAT NO WORD IN
C THE IWORD ARRAY COULD BE MATCHED EVEN
C PARTIALLY. THIS MEANS THAT IF THE CALLING
C PROGRAM TESTS FOR KIND=5 AFTER THE RETURN
C FROM DAVERB, AND IF KIND=4 IS TO BE TAKEN AS
C EQUIVALENT TO KIND=3, THEN CALLING PROGRAM
C CAN ADD 2 TO THE VALUE OF MATCH AND USE THIS
C SUM AS INDEX FOR A COMPUTED GO TO STATEMENT.
C LCNWRD = IF KIND IS RETURNED CONTAINING 3 OR GREATER,
C LOCWRD IS RETURNED WITH SUBSCRIPT OF IWORD
C LOCATION CONTAINING FIRST LETTER OF MATCHED
C WORD.
C LCNKNT = IF KIND IS RETURNED CONTAINING 3 OR GREATER,
C LCNKNT IS RETURNED WITH SUBSCRIPT OF KNTWRD
C LOCATION CONTAINING THE WORD LENGTH.
C LCNBFR = IF KIND IS RETURNED CONTAINING 3 OR GREATER,
C INDICATING THAT A WORD OR ITS ABBREVIATION
C WAS FOUND, THEN LCNBFR IS RETURNED
C CONTAINING THE SUBSCRIPT OF THE IBUFFR ARRAY
C LOCATION WHICH CONTAINS THE FIRST CHARACTER
C OF THE WORD OR ITS ABBREVIATION.
C
DIMENSION IBUFFR(MAXBFR),IWORD(MAXWRD),
1KNTLTR(MAXKNT),KONVRT(10),KAPITL(26),LOWER(26)
C
C CCCC AAA UU UU TTTTTTTT IIII OOOO NN NN
C CC AAAA UU UU TT II OO OO NNN NN
C CC AA AA UU UU TT II OO OO NNNN NN
C CC AA AA UU UU TT II OO OO NN NN NN
C CC AAAAAAA UU UU TT II OO OO NN NNNN
C CC AA AA UU UU TT II OO OO NN NNN
C CCCC AA AA UUU TT IIII OOOO NN NN
C
C TO CONVERT LOWER CASE LETTERS IN THE INPUT TEXT
C BUFFER INTO UPPER CASE LETTERS WHICH CAN BE MATCHED
C AGAINST THE DICTIONARY, THIS ROUTINE COMPARES THE
C CHARACTERS IN THE INPUT TEXT BUFFER AGAINST THE LOWER
C CASE LETTERS IN THE LOWER ARRAY. THE LETTERS IN THE
C LOWER ARRAY MUST BE ARRANGED IN INCREASING NUMERICAL
C ORDER. IF THE NUMERICAL ORDER IS NOT THE SAME AS THE
C ALPHABETICAL ORDER, THEN THE DATA STATEMENTS
C APPEARING BELOW MUST BE CHANGED OR ELSE SOME OR ALL
C LOWER CASE LETTERS IN THE INPUT TEXT BUFFER WILL NOT
C BE TREATED AS EQUIVALENT TO THE CORRESPONDING UPPER
C CASE LETTERS. ONCE THE LETTERS IN THE LOWER ARRAY
C ARE SORTED INTO INCREASING NUMERICAL ORDER, THE UPPER
C CASE LETTERS IN THE KAPITL ARRAY SHOULD BE REARRANGED
C SO THAT LOWER AND UPPER CASE VERSIONS OF EACH LETTER
C APPEAR IN LOCATIONS IN THE LOWER AND KAPITL ARRAYS
C HAVING THE SAME SUBSCRIPTS.
C
C IF THE COMPUTER UPON WHICH THIS ROUTINE IS USED DOES
C NOT SUPPORT LOWER CASE LETTERS, THEN BOTH THE LOWER
C AND KAPITL ARRAYS CAN CONTAIN THE LETTERS 1HA THROUGH
C 1HZ IN ALPHABETICAL ORDER (EVEN IF THIS IS NOT THE
C NUMERICALLY SORTED ORDER).
C
C KAPITL = UPPER CASE LETTERS A THROUGH Z SORTED ON
C LOWER ARRAY
DATA KAPITL/
11HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
21HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
31HU,1HV,1HW,1HX,1HY,1HZ/
C
C LOWER = LOWER CASE LETTERS A THROUGH Z SORTED INTO
C NUMERICALLY INCREASING ORDER
DATA LOWER/
11Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,
21Hk,1Hl,1Hm,1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,
31Hu,1Hv,1Hw,1Hx,1Hy,1Hz/
C
C IBLANK = THE BLANK OR SPACE CHARACTER
C ITAB = TABULATION CHARACTER, THIS CAN BE REPLACED
C BY SPACE IF TAB CHARACTER IS NOT AVAILABLE
DATA IBLANK,ITAB/1H ,1H /
C
C SEARCH FOR FIRST PRINTING CHARACTER
GO TO 2
1 LOWBFR=LOWBFR+1
2 IF(LOWBFR.GT.MAXBFR)GO TO 29
NOWLTR=IBUFFR(LOWBFR)
IF(NOWLTR.EQ.IBLANK)GO TO 1
IF(NOWLTR.EQ.ITAB)GO TO 1
C
C SET INITIAL CONSTANTS IF FIND PRINTING CHARACTER
LMTBFR=MAXBFR
LCNBFR=LOWBFR
IEND=LOWWRD
MSTSAM=1
KNTKNV=0
KNTWRD=LOWKNT-1
INDEX=0
3 IEXACT=1
4 KNTWRD=KNTWRD+1
IF(KNTWRD.GT.MAXKNT)GO TO 28
C
C GET NEXT WORD IN DICTIONARY
JEND=KNTLTR(KNTWRD)
KEND=JEND-100
IF(KEND.GE.0)JEND=KEND
IF(JEND.LE.0)GO TO 27
KEND=0
NXTCMP=IEND
IEND=IEND+JEND
JEXACT=-1
INDEX=INDEX+1
NXTBFR=LOWBFR
NOWSAM=1
C
C GET NEXT CHARACTERS TO BE COMPARED
5 IF(NXTBFR.GT.LMTBFR)GO TO 22
KOMPAR=IBUFFR(NXTBFR)
IF(KOMPAR.EQ.IBLANK)GO TO 15
IF(KOMPAR.EQ.ITAB)GO TO 15
IF(NOWSAM.LE.KNTKNV)GO TO 13
C
C DETERMINE UPPER CASE VERSION OF A LOWER CASE LETTER.
C THIS IS A TERNARY SEARCH TAKING ADVANTAGE OF THE SIZE
C OF ALPHABET BEING NEARLY 3**3. THE 3RD OF THE ARRAY
C CONTAINING THE DESIRED LETTER IS FIRST LOCATED, THEN
C THE 3RD OF THIS 3RD, AND FINALLY EACH OF THE
C REMAINING 3 LETTERS ARE TESTED INDIVIDUALLY. TO
C PREVENT TESTING AGAINST THE 27TH LETTER WHICH DOES
C NOT EXIST, UPPER 3RD IS TAKEN AS UPPER 9 SORTED
C LETTERS, RATHER THAN FROM 19TH THROUGH 27TH LETTERS,
C SO THAT LOWER(18) IS TESTED AGAINST IN UPPER 3RD EVEN
C THOUGH LETTER BEING MATCHED HAS ALREADY BEEN FOUND TO
C BE LARGER THAN THIS.
IF(KOMPAR.GT.LOWER(18))GO TO 7
IF(KOMPAR.GT.LOWER(9))GO TO 6
IF(KOMPAR.LT.LOWER(1))GO TO 11
KUT=3
GO TO 8
6 KUT=12
GO TO 8
7 IF(KOMPAR.GT.LOWER(26))GO TO 11
KUT=20
8 IF(KOMPAR.LE.LOWER(KUT))GO TO 9
KUT=KUT+3
IF(KOMPAR.GT.LOWER(KUT))KUT=KUT+3
9 IF(KOMPAR.EQ.LOWER(KUT))GO TO 10
KUT=KUT-1
IF(KOMPAR.EQ.LOWER(KUT))GO TO 10
KUT=KUT-1
IF(KOMPAR.NE.LOWER(KUT))GO TO 11
10 KOMPAR=KAPITL(KUT)
11 IF(KNTKNV.GE.10)GO TO 12
KNTKNV=KNTKNV+1
KONVRT(KNTKNV)=KOMPAR
C
C DETERMINE IF LETTER IN BUFFER MATCHES DICTIONARY.
12 IF(KOMPAR.EQ.IWORD(NXTCMP))GO TO 19
GO TO 14
13 IF(KONVRT(NOWSAM).EQ.IWORD(NXTCMP))GO TO 19
14 IF(KEND.LE.0)GO TO 23
GO TO 17
15 IF(KEND.LE.0)GO TO 23
16 NXTBFR=NXTBFR+1
IF(NXTBFR.GT.LMTBFR)GO TO 22
IF(IBUFFR(NXTBFR).EQ.IBLANK)GO TO 16
IF(IBUFFR(NXTBFR).EQ.ITAB)GO TO 16
17 KEND=0
18 IF(IWORD(NXTCMP).EQ.IBLANK)GO TO 20
JEXACT=0
NXTCMP=NXTCMP+1
IF(NXTCMP.LT.IEND)GO TO 18
GO TO 24
19 NOWSAM=NOWSAM+1
NEWBFR=NXTBFR
KEND=JEND
NXTBFR=NXTBFR+1
20 NXTCMP=NXTCMP+1
21 IF(NXTCMP.LT.IEND)GO TO 5
GO TO 24
C
C WORD CANNOT EXTEND FURTHER TO RIGHT
22 LMTBFR=NEWBFR
23 JEXACT=0
24 IF(NOWSAM.LT.MSTSAM)GO TO 4
IF(NOWSAM.GT.MSTSAM)GO TO 26
IF(IEXACT.GE.0)GO TO 25
IF(JEXACT.LT.0)GO TO 3
GO TO 4
25 IF(JEXACT.GE.0)GO TO 3
26 IEXACT=JEXACT
MSTSAM=NOWSAM
MATCH=INDEX
LSTBFR=NEWBFR+1
LCNKNT=KNTWRD
LCNWRD=IEND
GO TO 4
27 IEND=IEND-JEND
GO TO 4
C
C ENTIRE DICTIONARY HAS BEEN SEARCHED
28 IF(MSTSAM.LE.1)GO TO 30
LOWBFR=LSTBFR
KIND=4+IEXACT
JEND=KNTLTR(LCNKNT)
IF(JEND.GE.100)JEND=JEND-100
LCNWRD=LCNWRD-JEND
GO TO 31
C
C NO PRINTING CHARACTERS WERE FOUND TO BE IDENTIFIED
29 KIND=1
MATCH=-1
GO TO 31
C
C NOT EVEN A PARTIAL MATCH COULD BE MADE
30 KIND=2
MATCH=0
C
C RETURN TO CALLING PROGRAM
31 RETURN
C
C IEXACT = -1, EXACT MATCH FOUND BUT MUST CHECK THAT
C A LONGER MATCH CANNOT BE FOUND WITH ANOTHER
C WORD (FOR EXAMPLE, IF IWORD ARRAY CONTAINS
C BOTH OF THE WORDS NO AND NONE, THEN THE
C BUFFER CONTENTS "NON" WOULD MATCH WORD NO
C EXACTLY, BUT THE PARTIAL MATCH WITH WORD
C NONE WOULD BE BETTER)
C = 0, A PARTIAL MATCH HAS BEEN FOUND
C = 1, NO MATCH FOUND OR DUPLICATE PARTIAL
C MSTSAM = 1 + MAXIMUM NUMBER OF LETTERS MATCHED
C NOWSAM = 1 + NUMBER OF LETTERS MATCHING CURRENT WORD
C864241272470abcdefghijklmnopqrstuvwxyz
END
SUBROUTINE DASWAP(IARRAY,LOW,MID,MAX)
C
C DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERSITY
C
C ROUTINE TO SWAP ADJACENT SECTIONS OF SINGLE ARRAY
C
C IARRAY = ARRAY CONTAINING SECTIONS TO BE SWAPPED
C LOW = SUBSCRIPT OF LOWEST LOCATION IN LOW SECTION
C MID = SUBSCRIPT OF HIGHEST LOCATION IN LOW SECTION
C MAX = SUBSCRIPT OF HIGHEST LOCATION IN HIGH
C SECTION
C
C SWAP IS PERFORMED BY MOVING VALUES DIRECTLY TO
C LOCATIONS THEY ARE TO OCCUPY IN THE RESULT.
C
C FOR EXAMPLE, TO SWAP ABCD AND 123 IN THE
C FOLLOWING EXAMPLE, 3 IS MOVED TO LOCATION HOLDING C
C WHICH IS MOVED TO LOCATION HOLDING 2 AND SO ON.
C
C A B C D 1 2 3
C . . I-----------I
C . . I--------I .
C . I-----------I .
C . I--------I . .
C I-----------I . .
C I--------I . . .
C . . . I--------I
C
C IARRAY ARRAY AND NEW AND KEEP VARIABLES SHOULD BE
C MADE FLOATING POINT TO SWAP A FLOATING POINT ARRAY.
C
DIMENSION IARRAY(MAX)
IF(LOW.GT.MID)GO TO 5
IF(MID.GE.MAX)GO TO 5
KOUNT=LOW-MAX-1
LAST=MAX
LONGLO=LOW-MID-1
LONGHI=MAX-MID
1 INDEX=LAST+LONGLO
KEEP=IARRAY(LAST)
2 KOUNT=KOUNT+1
NEW=IARRAY(INDEX)
IARRAY(INDEX)=KEEP
KEEP=NEW
IF(INDEX.GT.MID)GO TO 3
INDEX=INDEX+LONGHI
GO TO 2
3 IF(INDEX.EQ.LAST)GO TO 4
INDEX=INDEX+LONGLO
GO TO 2
4 IF(KOUNT.EQ.0)GO TO 5
LAST=LAST-1
GO TO 1
5 RETURN
C107401072377
END
SUBROUTINE DAFILL(INITAL,INTRVL,IBEGIN,IFINAL,MAXBFR,
1IBUFFR,MAXPRT,MAXUSD)
C RENBR(/EXPAND TABS TO SPACES WITHOUT EXTRA BUFFER)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THE TAB CHARACTER IS A NONPRINTING CHARACTER WHICH
C CAUSES THE FOLLOWING CHARACTER TO APPEAR IN THE NEXT
C COLUMN BEYOND THE NEXT MULTIPLE OF THE TAB STOP.
C
C INITAL = LESS THAN ZERO, PROVIDING THAT INTRVL IS
C GREATER THAN ZERO, THE NUMBER OF EXTRA
C SPACES INDICATED BY THE ABSOLUTE VALUE OF
C INITAL ARE TO BE INSERTED AT THE START OF
C THE BUFFER SHIFTING THE REST OF THE TEXT TO
C THE RIGHT. THE FIRST TAB STOP WILL BE OF
C THE WIDTH INDICATED BY INTRVL. IF INTRVL IS
C LESS THAN OR EQUAL TO ZERO, THEN NO LEADING
C SPACES WILL APPEAR AT START OF THE PROCESSED
C TEXT, WHETHER REQUESTED BY INITAL OR BY
C LEADING SPACES OR TABS IN THE IBUFFR ARRAY.
C = EQUAL TO OR GREATER THAN ZERO, INITAL IS THE
C NUMBER OF SPACES TO THE FIRST TAB STOP. IF
C INITAL IS ZERO, THEN THE DISTANCE TO THE
C FIRST TAB STOP IS TAKEN AS THE ABSOLUTE
C VALUE OF INTRVL. IF THE FIRST CHARACTER IN
C INPUT BUFFER IS A TAB, IT WILL BE EXPANDED
C TO THIS NUMBER OF SPACES. INITAL CAN EQUAL
C EITHER ZERO OR VALUE OF INTRVL IF FIRST TAB
C STOP IS TO BE OF SAME WIDTH AS THOSE WHICH
C FOLLOW IT.
C INTRVL = THE ABSOLUTE VALUE OF INTRVL IS THE TAB STOP
C INTERVAL. A TAB CHARACTER IN THE INPUT
C BUFFER CAUSES THE FOLLOWING CHARACTER TO GO
C INTO THE NEXT POSITION BEYOND THE SUM OF THE
C ABSOLUTE VALUE OF INITAL AND NEXT MULTIPLE
C OF THE ABSOLUTE VALUE OF INTRVL.
C = LESS THAN ZERO, NO LEADING SPACES ARE TO BE
C INSERTED INTO THE PROCESSED TEXT WHETHER
C REQUESTED BY A NEGATIVE VALUE OF INITAL OR
C BY LEADING SPACES OR TABS IN THE IBUFFR
C ARRAY. ONCE A PRINTING CHARACTER HAS BEEN
C ENCOUNTERED IN THE TEXT BEING PROCESSED,
C THEN ALL REMAINING SPACES WILL BE COPIED AND
C REMAINING TABS WILL BE EXPANDED TO SPACES.
C = ZERO, NO SPACES ARE TO BE INSERTED INTO THE
C PROCESSED TEXT. TABS IN THE INPUT BUFFER
C ARE IGNORED, AND SPACES ARE NOT COPIED.
C = GREATER THAN ZERO, ALL SPACES WHETHER
C REQUESTED BY A NEGATIVE VALUE OF INITAL OR
C BY SPACES OR TABS IN THE INPUT BUFFER ARE
C INSERTED INTO THE PROCESSED TEXT.
C IBEGIN = SUBSCRIPT OF THE IBUFFR ARRAY AT WHICH IS TO
C BE FOUND THE FIRST CHARACTER OF THE TEXT TO
C BE PROCESSSED. FOLLOWING CONVERSION OF TAB
C CHARACTERS TO PROPER NUMBER OF SPACES, THE
C TEXT IS PLACED BACK INTO THE IBUFFR ARRAY
C STARTING AT SUBSCRIPT IBEGIN.
C IFINAL = SUBSCRIPT OF THE IBUFFR ARRAY AT WHICH IS TO
C BE FOUND THE FINAL CHARACTER OF THE TEXT TO
C BE PROCESSED.
C MAXBFR = MAXIMUM SUBSCRIPT OF THE IBUFFR ARRAY AT
C WHICH THE FINAL CHARACTER OF THE PROCESSED
C TEXT CAN BE PLACED. MAXBFR MUST BE EQUAL TO
C OR BE GREATER THAN IFINAL.
C IBUFFR = ARRAY USED FOR INPUT OF THE TEXT CONTAINING
C TAB CHARACTERS TO BE EXPANDED TO THE PROPER
C NUMBER OF SPACES, AND USED FOR OUTPUT OF THE
C TEXT AFTER THE EXPANSION HAS BEEN PERFORMED.
C IBUFFR CONTAINS CHARACTERS READ BY A1
C FORMAT.
C MAXPRT = RETURNED CONTAINING THE SUBSCRIPT OF HIGHEST
C LOCATION IN THE OUTPUT CONTENTS OF IBUFFR
C WHICH CONTAINS A PRINTING CHARACTER.
C MAXUSD = RETURNED CONTAINING THE SUBSCRIPT OF HIGHEST
C LOCATION IN THE IBUFFR ARRAY CONTAINING A
C CHARACTER OF THE TEXT AFTER PROCESSING. IF
C INTRVL IS LESS THAN OR EQUAL TO ZERO, AND
C TEXT CONTAINS ONLY SPACES AND TABS, THEN
C MAXUSD IS RETURNED SET EQUAL TO IBEGIN-1.
C THE MAXIMUM VALUE OF MAXUSD IS MAXBFR.
C
C
DIMENSION IBUFFR(MAXBFR)
C
C ISPACE = THE SPACE CHARACTER
C ITAB = THE TAB CHARACTER
DATA ISPACE,ITAB/1H ,1H /
C
C ****************************************************
C * *
C * COPY CHARACTERS GOING TO LEFT OR STAYING FIXED *
C * *
C ****************************************************
C
C INITIAL POINTERS
JBEGIN=IBEGIN-1
JUSED=JBEGIN
JPRINT=JUSED
NEED=INITAL
KPYEND=MAXBFR
LOKEND=IFINAL
C
C INSERT EXTRA SPACES AT START IF INITAL.LT.0
IF(INTRVL.LE.0)GO TO 1
JNTRVL=INTRVL
IF(NEED.LT.0)GO TO 9
NONSPC=1
GO TO 2
1 JNTRVL=-INTRVL
NONSPC=0
C
C TEST IF AT END OF TEXT MOVING LEFT OR KEPT IN PLACE
2 IF(JBEGIN.GE.LOKEND)GO TO 21
JBEGIN=JBEGIN+1
C
C SET DISTANCE TO NEXT TAB STOP OF JUST BEYOND LAST
IF(NEED.LE.0)NEED=JNTRVL
C
C TEST IF NEW CHARACTER IS A SPACE OR A TAB
IF(IBUFFR(JBEGIN).EQ.ISPACE)GO TO 5
IF(IBUFFR(JBEGIN).NE.ITAB)GO TO 6
C
C IF FIND A TAB, COPY IN THE SPACES TO NEXT TAB STOP
IF(NONSPC.EQ.0)GO TO 4
3 JUSED=JUSED+1
IBUFFR(JUSED)=ISPACE
NEED=NEED-1
IF(NEED.LE.0)GO TO 2
IF(JUSED.LT.JBEGIN)GO TO 3
GO TO 10
4 NEED=0
GO TO 2
C
C IF FIND CHARACTER OTHER THAN A TAB, JUST COPY IT
5 IF(NONSPC.NE.0)GO TO 7
GO TO 8
6 JPRINT=JUSED+1
NONSPC=JNTRVL
7 JUSED=JUSED+1
IBUFFR(JUSED)=IBUFFR(JBEGIN)
8 NEED=NEED-1
GO TO 2
C
C *****************************************************
C * *
C * MOVE RIGHTMOST AS YET UNMOVED GROUP OF TABS OR *
C * GROUP OF NON-TABS TO ITS FINAL DESTINATION *
C * *
C *****************************************************
C
C INITIAL POINTERS
9 NEED=-NEED
10 IF(KPYEND.LE.JBEGIN)GO TO 21
LOOK=JBEGIN
KOPY=JBEGIN
LIMIT=NEED
GO TO 13
C
C TEST IF HAVE SCANNED TO RIGHT END OF UNPROCESSED TEXT
11 IF(KOPY.GE.KPYEND)GO TO 17
12 IF(LOOK.GE.LOKEND)GO TO 17
LOOK=LOOK+1
C
C SET DISTANCE TO NEXT TAB STOP OF JUST BEYOND LAST
IF(LIMIT.LE.0)LIMIT=JNTRVL
C
C TEST IF NEW CHARACTER IS A SPACE OR A TAB
IF(IBUFFR(LOOK).EQ.ISPACE)GO TO 16
IF(IBUFFR(LOOK).NE.ITAB)GO TO 15
C
C IF FIND A TAB, RECORD NUMBER OF SPACES TO NEXT STOP
IF(KIND.GT.0)GO TO 14
13 LOCATN=KOPY
KIND=1
14 KOPY=KOPY+LIMIT
LIMIT=0
IF(KOPY.LT.KPYEND)GO TO 12
KOPY=KPYEND
GO TO 17
C
C IF FIND CHARACTER OTHER THAN A TAB, RECORD LOCATION
15 IF(KOPY.GE.JPRINT)JPRINT=KOPY+1
16 LIMIT=LIMIT-1
IF(KIND.GT.0)LOCATN=KOPY
KOPY=KOPY+1
KIND=0
GO TO 11
C
C COPY RIGHTMOST GROUP OF CHARACTERS
17 IF(JUSED.LT.KOPY)JUSED=KOPY
IF(KIND.GT.0)GO TO 19
18 IBUFFR(KOPY)=IBUFFR(LOOK)
KOPY=KOPY-1
LOOK=LOOK-1
IF(KOPY.GT.LOCATN)GO TO 18
GO TO 20
19 IBUFFR(KOPY)=ISPACE
KOPY=KOPY-1
IF(KOPY.GT.LOCATN)GO TO 19
LOOK=LOOK-1
C
C SHRINK THE UNPROCESSED REGION AND GO BACK TO DO AGAIN
20 LOKEND=LOOK
KPYEND=KOPY
GO TO 10
C
C RETURN TO CALLING PROGRAM
21 MAXUSD=JUSED
MAXPRT=JPRINT
RETURN
C404242973694
END
SUBROUTINE DAIFLL(INITAL,INTRVL,IBEGIN,IFINAL,MAXBFR,
1IBUFFR,MAXPRT,MAXUSD)
C RENBR(/EXPAND TABS TO SPACES WITHOUT EXTRA BUFFER)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THE TAB CHARACTER IS A NONPRINTING CHARACTER WHICH
C CAUSES THE FOLLOWING CHARACTER TO APPEAR IN THE NEXT
C COLUMN BEYOND THE NEXT MULTIPLE OF THE TAB STOP.
C
C INITAL = EQUAL TO OR GREATER THAN ZERO, INITAL IS THE
C NUMBER OF SPACES TO THE FIRST TAB STOP. IF
C INITAL IS ZERO, THEN DISTANCE TO FIRST TAB
C IS VALUE OF INTRVL. IF FIRST CHARACTER IN
C INPUT BUFFER IS A TAB, IT WILL BE EXPANDED
C TO THIS NUMBER OF SPACES. INITAL CAN EQUAL
C EITHER ZERO OR VALUE OF INTRVL IF FIRST TAB
C STOP IS TO BE OF SAME WIDTH AS THOSE WHICH
C FOLLOW IT.
C INTRVL = TAB STOP INTERVAL. A TAB CHARACTER IN INPUT
C BUFFER CAUSES THE FOLLOWING CHARACTER TO GO
C INTO THE NEXT POSITION BEYOND THE SUM OF THE
C VALUE OF INITAL AND NEXT MULTIPLE OF INTRVL.
C IBEGIN = SUBSCRIPT OF THE IBUFFR ARRAY AT WHICH IS TO
C BE FOUND THE FIRST CHARACTER OF THE TEXT TO
C BE PROCESSSED. FOLLOWING CONVERSION OF TAB
C CHARACTERS TO PROPER NUMBER OF SPACES, THE
C TEXT IS PLACED BACK INTO THE IBUFFR ARRAY
C STARTING AT SUBSCRIPT IBEGIN.
C IFINAL = SUBSCRIPT OF THE IBUFFR ARRAY AT WHICH IS TO
C BE FOUND THE FINAL CHARACTER OF THE TEXT TO
C BE PROCESSED.
C MAXBFR = MAXIMUM SUBSCRIPT OF THE IBUFFR ARRAY AT
C WHICH THE FINAL CHARACTER OF THE PROCESSED
C TEXT CAN BE PLACED. MAXBFR MUST BE EQUAL TO
C OR BE GREATER THAN IFINAL.
C IBUFFR = ARRAY USED FOR INPUT OF THE TEXT CONTAINING
C TAB CHARACTERS TO BE EXPANDED TO THE PROPER
C NUMBER OF SPACES, AND USED FOR OUTPUT OF THE
C TEXT AFTER THE EXPANSION HAS BEEN PERFORMED.
C IBUFFR CONTAINS CHARACTERS READ BY A1
C FORMAT.
C MAXPRT = RETURNED CONTAINING THE SUBSCRIPT OF HIGHEST
C LOCATION IN THE OUTPUT CONTENTS OF IBUFFR
C WHICH CONTAINS A PRINTING CHARACTER.
C MAXUSD = RETURNED CONTAINING THE SUBSCRIPT OF HIGHEST
C LOCATION IN THE IBUFFR ARRAY CONTAINING A
C CHARACTER OF THE TEXT AFTER PROCESSING. THE
C MAXIMUM VALUE OF MAXUSD IS MAXBFR.
C
DIMENSION IBUFFR(MAXBFR)
C
C ISPACE = THE SPACE CHARACTER
C ITAB = THE TAB CHARACTER
DATA ISPACE,ITAB/1H ,1H /
C
C INITIAL POINTERS
JBEGIN=IBEGIN-1
NEEDED=INITAL
JPRINT=JBEGIN
KPYEND=MAXBFR
LOKEND=IFINAL
1 JUSED=JBEGIN
IF(IFINAL.LE.JBEGIN)GO TO 14
C
C RESET POINTERS PRIOR TO NEXT SCAN
2 IF(KPYEND.LE.JBEGIN)GO TO 14
LOOK=JBEGIN
KOPY=JBEGIN
LIMIT=NEEDED
KIND=-1
C
C TEST IF HAVE SCANNED TO RIGHT END OF UNPROCESSED TEXT
3 IF(KOPY.GE.KPYEND)GO TO 10
4 IF(LOOK.GE.LOKEND)GO TO 10
LOOK=LOOK+1
C
C ADJUST NUMBER OF COLUMNS LEFT UNTIL NEXT TAB STOP
IF(LIMIT.LE.0)LIMIT=INTRVL
C
C TEST IF NEW CHARACTER IS A SPACE OR A TAB
IF(IBUFFR(LOOK).EQ.ISPACE)GO TO 7
IF(IBUFFR(LOOK).NE.ITAB)GO TO 6
C
C IF FIND A TAB, RECORD NUMBER OF SPACES TO NEXT STOP
IF(KIND.GT.0)GO TO 5
LOCATN=KOPY
KIND=1
5 KOPY=KOPY+LIMIT
LIMIT=0
IF(KOPY.LT.KPYEND)GO TO 4
KOPY=KPYEND
GO TO 10
C
C IF FIND CHARACTER OTHER THAN A TAB, RECORD LOCATION
6 IF(KOPY.GE.JPRINT)JPRINT=KOPY+1
7 LIMIT=LIMIT-1
IF(KIND.EQ.0)GO TO 8
IF(KIND.LT.0)GO TO 9
LOCATN=KOPY
KIND=0
8 KOPY=KOPY+1
GO TO 3
9 NEEDED=LIMIT
JBEGIN=LOOK
GO TO 1
C
C COPY RIGHTMOST GROUP OF CHARACTERS
10 IF(JUSED.LT.KOPY)JUSED=KOPY
IF(KIND.GT.0)GO TO 12
11 IBUFFR(KOPY)=IBUFFR(LOOK)
KOPY=KOPY-1
LOOK=LOOK-1
IF(KOPY.GT.LOCATN)GO TO 11
GO TO 13
12 IBUFFR(KOPY)=ISPACE
KOPY=KOPY-1
IF(KOPY.GT.LOCATN)GO TO 12
LOOK=LOOK-1
C
C SHRINK THE UNPROCESSED REGION AND GO BACK TO DO AGAIN
13 LOKEND=LOOK
KPYEND=KOPY
GO TO 2
C
C RETURN TO CALLING PROGRAM
14 MAXUSD=JUSED
MAXPRT=JPRINT
RETURN
C281985458052
END
SUBROUTINE DACOPY(INITAL,INTRVL,IBUFFR,IBEGIN,IFINAL,
1JFINAL,JUSED,JBUFFR,NXTINI,NXTBGN,MAXPRT)
C RENBR(/COPY BUFFER EXPANDING TABS TO SPACES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THE TAB CHARACTER IS A NONPRINTING CHARACTER WHICH
C CAUSES THE FOLLOWING CHARACTER TO APPEAR IN THE NEXT
C COLUMN BEYOND THE NEXT MULTIPLE OF THE TAB STOP.
C
C INITAL = LESS THAN ZERO, PROVIDING THAT INTRVL IS
C GREATER THAN ZERO, THE NUMBER OF EXTRA
C SPACES INDICATED BY THE ABSOLUTE VALUE OF
C INITAL ARE TO BE INSERTED AT THE START OF
C THE JBUFFR ARRAY BEFORE THE CONTENTS OF THE
C IBUFFR ARRAY IS COPIED INTO THE JBUFFR
C ARRAY. THE FIRST TAB STOP WILL BE OF THE
C WIDTH INDICATED BY INTRVL. IF INTRVL IS
C LESS THAN OR EQUAL TO ZERO, THEN NO LEADING
C SPACES WILL BE INSERTED INTO THE JBUFFR
C ARRAY WHETHER REQUESTED BY INITAL OR BY
C LEADING SPACES OR TABS IN THE IBUFFR ARRAY.
C = EQUAL TO OR GREATER THAN ZERO, INITAL IS THE
C NUMBER OF SPACES TO THE FIRST TAB STOP. IF
C INITAL IS ZERO, THEN COPYING HAS ALREADY
C PASSED BEYOND THE FIRST TAB STOP AND THE
C DISTANCE TO THE NEXT TAB STOP IS TAKEN AS
C THE ABSOLUTE VALUE OF INTRVL. IF THE FIRST
C CHARACTER IN THE INPUT BUFFER IS A TAB, IT
C WILL BE EXPANDED TO THIS NUMBER OF SPACES.
C INITAL CAN EQUAL EITHER ZERO OR THE VALUE OF
C INTRVL IF THE FIRST TAB STOP IS TO BE OF THE
C SAME WIDTH AS THOSE WHICH FOLLOW IT.
C INTRVL = THE ABSOLUTE VALUE OF INTRVL IS THE TAB STOP
C INTERVAL. A TAB CHARACTER IN THE INPUT
C BUFFER CAUSES THE FOLLOWING CHARACTER TO GO
C INTO THE NEXT POSITION BEYOND THE SUM OF THE
C ABSOLUTE VALUE OF INITAL AND NEXT MULTIPLE
C OF THE ABSOLUTE VALUE OF INTRVL.
C = LESS THAN ZERO, NO LEADING SPACES ARE TO BE
C INSERTED INTO THE JBUFFR ARRAY WHETHER
C REQUESTED BY A NEGATIVE VALUE OF INITAL OR
C BY LEADING SPACES OR TABS IN THE IBUFFR
C ARRAY. ONCE A PRINTING CHARACTER HAS BEEN
C COPIED INTO THE JBUFFR ARRAY, HOWEVER, THEN
C ALL REMAINING SPACES WILL BE COPIED AND ALL
C REMAINING TABS WILL BE EXPANDED TO SPACES.
C = ZERO, NO SPACES ARE TO BE INSERTED INTO THE
C JBUFFR ARRAY. TABS IN THE IBUFFR ARRAY ARE
C IGNORED, AND SPACES ARE NOT COPIED.
C = GREATER THAN ZERO, ALL SPACES WHETHER
C REQUESTED BY A NEGATIVE VALUE OF INITAL OR
C BY SPACES OR TABS IN THE IBUFFR ARRAY ARE
C INSERTED INTO THE JBUFFR ARRAY.
C IBUFFR = THE INPUT BUFFER WHICH IS TO BE COPIED INTO
C THE OUTPUT BUFFER EXPANDING ANY TABS FOUND.
C IBUFFR CONTAINS CHARACTERS READ BY A1
C FORMAT.
C IBEGIN = SUBSCRIPT IN IBUFFR ARRAY AT WHICH IS TO BE
C FOUND THE FIRST CHARACTER TO BE COPIED.
C IFINAL = SUBSCRIPT IN IBUFFR ARRAY AT WHICH IS TO BE
C FOUND THE FINAL CHARACTER TO BE COPIED.
C JFINAL = THE DIMENSION OF JBUFFR ARRAY.
C JUSED = SUBSCRIPT OF THE LOWEST LOCATION IN JBUFFR
C ARRAY WHICH IS CURRENTLY IN USE AND WHICH
C CONTAINS DATA WHICH MUST BE MAINTAINED.
C JUSED IS RETURNED CONTAINING THE SUBSCRIPT
C OF THE HIGHEST LOCATION INTO WHICH DACOPY
C HAS PLACED A CHARACTER.
C JBUFFR = ARRAY INTO WHICH THE CONTENTS OF IBUFFR ARE
C TO BE COPIED EXPANDING TABS TO SPACES.
C NXTINI = RETURNED CONTAINING VALUE NEXT TO BE GIVEN
C TO INITAL IF THE CURRENT CALL COULD NOT
C COMPLETELY REPESENT THE CONTENTS OF THE
C IBUFFR ARRAY DUE TO THE ROOM AVAILABLE IN
C JBUFFR BEING TOO SMALL. IF A TAB WAS
C ENCOUNTERED IN IBUFFR BUT COULD NOT BE
C COMPLETELY REPRESENTED, THEN NXTINI WILL BE
C NEGATIVE. IF THE LAST CHARACTER ENCOUNTERED
C IN THE IBUFFR ARRAY WAS NOT A TAB, THEN
C NXTINI WILL BE RETURNED WITH THE REMAINING
C DISTANCE TO THE NEXT TAB STOP.
C NXTBGN = RETURNED CONTAINING THE SUBSCRIPT WITHIN THE
C IBUFFR ARRAY OF THE FIRST LETTER WHICH COULD
C NOT BE REPRESENTED IN THE OUTPUT BUFFER. IF
C ALL LETTERS COULD BE REPRESENTED, THEN
C NXTBGN WILL BE RETURNED CONTAINING IFINAL+1.
C NOTE THAT IF A TAB IS REPRESENTED EVEN BY
C SINGLE SPACE, THEN NXTBGN IS PASSED BEYOND
C THIS TAB ALTHOUGH THERE MIGHT NOT BE ENOUGH
C ROOM IN THE OUTPUT BUFFER TO FILL COMPLETELY
C TO THE NEXT TAB STOP.
C MAXPRT = RETURNED CONTAINING THE SUBSCRIPT OF HIGHEST
C LOCATION IN JBUFFR ARRAY INTO WHICH DACOPY
C HAS PLACED A PRINTING CHARACTER.
C
DIMENSION IBUFFR(IFINAL),JBUFFR(JFINAL)
C
C ISPACE = THE SPACE CHARACTER
C ITAB = THE TAB CHARACTER
DATA ISPACE,ITAB/1H ,1H /
C
C INITIAL POINTERS
INDEX=IBEGIN-1
IPRINT=JUSED
LIMIT=INITAL
C
C INSERT EXTRA SPACES AT START IF INITAL.LT.0
IF(INTRVL.LE.0)GO TO 2
JNTRVL=INTRVL
NONSPC=1
1 IF(LIMIT.GE.0)GO TO 4
LIMIT=-LIMIT
GO TO 6
2 JNTRVL=-INTRVL
NONSPC=0
GO TO 4
C
C TEST IF ARE AT END OF EITHER INPUT OR OUTPUT BUFFERS
3 LIMIT=0
4 INDEX=INDEX+1
IF(JUSED.GE.JFINAL)GO TO 11
IF(INDEX.GT.IFINAL)GO TO 11
C
C ADJUST NUMBER OF COLUMNS LEFT UNTIL NEXT TAB STOP
IF(LIMIT.LE.0)LIMIT=JNTRVL
LIMIT=LIMIT-1
C
C TEST IF NEW CHARACTER IS A SPACE OR A TAB
IF(IBUFFR(INDEX).EQ.ISPACE)GO TO 7
IF(IBUFFR(INDEX).NE.ITAB)GO TO 8
C
C IF FIND A TAB, COPY IN THE SPACES TO NEXT TAB STOP
IF(NONSPC.EQ.0)GO TO 3
5 JUSED=JUSED+1
JBUFFR(JUSED)=ISPACE
IF(LIMIT.LE.0)GO TO 4
6 IF(JUSED.GE.JFINAL)GO TO 10
LIMIT=LIMIT-1
GO TO 5
C
C IF FIND CHARACTER OTHER THAN A TAB, JUST COPY IT
7 IF(NONSPC.EQ.0)GO TO 4
GO TO 9
8 IPRINT=JUSED+1
NONSPC=JNTRVL
9 JUSED=JUSED+1
JBUFFR(JUSED)=IBUFFR(INDEX)
GO TO 4
C
C NOT ENOUGH ROOM FOR ALL SPACES IN TAB EXPANSION
10 LIMIT=-LIMIT
INDEX=INDEX+1
C
C RETURN TO CALLING PROGRAM
11 NXTINI=LIMIT
NXTBGN=INDEX
MAXPRT=IPRINT
RETURN
C243897269317
END
SUBROUTINE DALOOP(IRAPID,LOWSUB,KNTSUB,INISUB,LMTSUB,
1 INCSUB,NXTSUB,INLOOP,NOWSUB)
C RENBR(/VARIABLY EMBEDDED DO LOOP SIMULATOR)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C ROUTINE TO PROVIDE CONTROL OF VARIABLY EMBEDDED
C LOOPS TO ANY DESIRED LEVEL. EACH LOOP HAS ITS OWN
C INITIAL AND FINAL VALUE, AND ITS OWN INCREMENT BY
C WHICH IT VARIES BETWEEN THESE. THE FINAL VALUE CAN
C BE EITHER LESS THAN, EQUAL TO OR GREATER THAN THE
C INITIAL VALUE.
C
C ***************************************************
C * CAUTION, DALOOP MUST BE CALLED INITIALLY TO *
C * DEFINE LOOP STRUCTURE, THEN AT EACH LOOP END. *
C * NONE OF THE CALLING ARGUMENTS CAN BE CHANGED *
C * BY CALLING PROGRAM UNTIL ALL LOOPS ARE DONE. *
C ***************************************************
C
C THE FOLLOWING ARGUMENTS ARE USED AS INPUT ONLY
C
C IRAPID = 0, THE INNERMOST LOOP (ONE DONE THE MOST
C RAPIDLY) IS THAT WITH THE SMALLEST VALUE
C IN THE NXTSUB ARRAY.
C = 1, THE INNERMOST LOOP IS THAT WITH THE
C LARGEST VALUE IN THE NXTSUB ARRAY.
C LOWSUB = THE INITIAL SUBSCRIPT OF THE ARRAYS WHICH
C ARE TO BE USED AS THE LOOP DESCRIPTORS.
C KNTSUB = THE FINAL SUBSCRIPT OF THE ARRAYS WHICH
C ARE TO BE USED AS THE LOOP DESCRIPTORS.
C KNTSUB MUST BE GREATER THAN OR EQUAL TO
C LOWSUB.
C INISUB = ARRAY CONTAINING THE STARTING VALUES OF THE
C INDIVIDUAL LOOP LIMITS.
C LMTSUB = ARRAY CONTAINING ENDING VALUES OF THE
C INDIVIDUAL LOOP LIMITS. AN INDIVIDUAL ITEM
C IN THE LMTSUB ARRAY CAN BE EITHER LESS THAN,
C EQUAL TO, OR GREATER THAN THE CORRESPONDING
C ITEM IN THE INISUB ARRAY.
C INCSUB = ARRAY CONTAINING THE INCREMENT BY WHICH THE
C NOWSUB ARRAY IS VARIED BETWEEN THE STARTING
C VALUES IN INISUB ARRAY, AND THE ENDING
C VALUES IN LMTSUB ARRAY. IF THE INCREMENT
C IS ZERO, IT IS CHANGED TO 1. IF THE
C INCREMENT HAS THE WRONG SIGN, ITS SIGN IS
C CHANGED.
C
C THE FOLLOWING ARGUMENT IS USED AS INPUT, THEN IS
C RETURNED CHANGED FOR USE BY SUBSEQUENT DALOOP CALLS
C
C NXTSUB = ARRAY SET BY THE CALLING PROGRAM BEFORE THE
C INITIAL CALL TO DALOOP TO CONTROL THE ORDER
C OF THE EMBEDDED LOOPS. DALOOP WILL RETURN
C NXTSUB AS AN ARRAY CONTAINING POINTERS FOR
C USE BY SUBSEQUENT CALLS TO DALOOP. THE
C ORIGINAL CONTENTS OF NXTSUB ARE USED TO
C ESTABLISH THE ORDER OF THE POINTERS, BUT
C THE ORIGINAL CONTENTS ARE DESTROYED AFTER
C BEING USED. THE RETURNED VALUES MUST NOT BE
C ALTERED BY CALLING PROGRAM. SEE DEFINITION
C OF IRAPID FOR DESCRIPTION OF INPUT NXTSUB
C VALUES. LOOPS WHICH HAVE IDENTICAL VALUES
C OF NXTSUB ARE PERFORMED AS A SINGLE UNIT, A
C SINGLE CALL TO DALOOP ADVANCING THE NOWSUB
C ARRAY VALUES FOR ALL MEMEBERS OF THE GROUP
C UNTIL NOWSUB ARRAY VALUE OF ANY MEMBER OF
C THE GROUP EXCEEDS ITS OWN CORRESPONDING
C LMTSUB ARRAY VALUE. WHEN DALOOP FINALLY
C SIGNALS THAT ALL LOOPS HAVE BEEN COMPLETED,
C BY RETURNING INLOOP=0, IT WILL ALSO ATTEMPT
C TO RESTORE THE ORIGINAL VALUES OF THE NXTSUB
C ARRAY, MAKING THE ASSUMPTION THAT SMALLEST
C VALUE IN RANGE NXTSUB(LOWSUB) THROUGH
C NXTSUB(KNTSUB) HAS THE VALUE LOWSUB, AND
C THAT THE VALUES ARE THEN INCREMENTED BY 1.
C THE RELATIVE ORDER WITHIN THE USED PORTION
C OF NXTSUB ARRAY WILL BE RETURNED CORRECT,
C BUT IF THE ASSUMPTIONS ARE NOT CORRECT, THE
C ORDER WILL BE INCORRECT RELATIVE TO THAT OF
C THE UNUSED PORTION, IF ANY, OF NXTSUB ARRAY.
C
C THE FOLLOWING ARGUMENT IS USED AS INPUT, THEN IS
C RETURNED CHANGED FOR USE BY BOTH THE CALLING PROGRAM
C AND BY SUBSEQUENT CALLS TO DALOOP
C
C INLOOP = MUST BE SET TO ZERO BEFORE INITIAL CALL TO
C DALOOP. THIS INITIAL CALL WILL SET INLOOP
C NONZERO, AND WILL COPY THE INISUB ARRAY
C INTO THE NOWSUB ARRAY FOR USE AS THE LOOP
C PARAMETERS. EACH SUBSEQUENT CALL TO DALOOP
C WILL EITHER LOAD THE PARAMETERS FOR THE
C NEXT SET OF LOOPS INTO THE NOWSUB ARRAY OR
C SET INLOOP TO ZERO IF THE LOOP STRUCTURE
C HAS BEEN COMPLETED.
C
C THE FOLLOWING ARGUMENT IS RETURNED CHANGED FOR USE
C BY BOTH THE CALLING PROGRAM AND SUBSEQUENT CALLS TO
C DALOOP. THE ORIGINAL CONTENTS ARE IGNORED.
C
C NOWSUB = ARRAY RETURNED CONTAINING THE LOOP CONTROL
C PARAMETERS FOR THE NEXT LOOP STRUCTURE.
C THE CONTENTS OF NOWSUB(LOWSUB) THROUGH
C NOWSUB(KNTSUB) ARE USED IN THE SAME MANNER
C AS THE INDEXES OF FORTRAN DO LOOPS.
C THE VALUES UPON INPUT TO THE INITIAL CALL
C TO DALOOP ARE IGNORED.
C
C AS AN EXAMPLE, WITH LOWSUB=5, KNTSUB=8, IRAPID=1 AND
C (NXTSUB(I),I=5,8)=1,2,3,4
C THE STATEMENTS
C
C INLOOP=0
C 1 CALL DALOOP(IRAPID,LOWSUB,KNTSUB,INISUB,LMTSUB,
C 1INCSUB,NXTSUB,INLOOP,NOWSUB)
C IF(INLOOP.EQ.0)GO TO 2
C *
C *
C TEXT TO BE EXECUTED WITHIN THE LOOP STRUCTURE
C *
C *
C GO TO 1
C 2 CONTINUE
C
C WOULD SIMULATE THE CORRESPONDING DO LOOP STRUCTURE
C
C DO 2 NOWSUB(5)=INISUB(5),LMTSUB(5),INCSUB(5)
C DO 2 NOWSUB(6)=INISUB(6),LMTSUB(6),INCSUB(6)
C DO 2 NOWSUB(7)=INISUB(7),LMTSUB(7),INCSUB(7)
C DO 2 NOWSUB(8)=INISUB(8),LMTSUB(8),INCSUB(8)
C *
C *
C TEXT TO BE EXECUTED WITHIN THE LOOP STRUCTURE
C *
C *
C 2 CONTINUE
C
C HOWEVER, MERELY BY CHANGING THE NXTSUB ARRAY TO
C (NXTSUB(I),I=5,8)=3,1,4,2
C THE ORDER OF THE SIMULATED DO LOOPS WOULD BECOME
C
C DO 2 NOWSUB(6)=INISUB(6),LMTSUB(6),INCSUB(6)
C DO 2 NOWSUB(8)=INISUB(8),LMTSUB(8),INCSUB(8)
C DO 2 NOWSUB(5)=INISUB(5),LMTSUB(5),INCSUB(5)
C DO 2 NOWSUB(7)=INISUB(7),LMTSUB(7),INCSUB(7)
C *
C *
C TEXT TO BE EXECUTED WITHIN THE LOOP STRUCTURE
C *
C *
C 2 CONTINUE
C
C THE FIRST CALL TO DALOOP CONVERTS THE NXTSUB ARRAY
C FROM AN ORDER ARRAY TO A POINTER ARRAY SO AS TO
C PREVENT UNNECESSARY SEARCHES BY SUCCEEDING CALLS.
C THE FIRST LOCATION IN THE USED PORTION OF THE NXTSUB
C ARRAY AFTER ITS CONVERSION TO A POINTER ARRAY
C CONTAINS THE SUBSCRIPT OF THE INDEX WHICH IS BEING
C VARIED THE MOST RAPIDLY. IF ADDITIONAL INDEXES ARE
C BEING VARIED AT THE SAME RATE, THEN THE SECOND
C LOCATION IN THE POINTER ARRAY WILL CONTAIN THE SUM OF
C THE SUBSCRIPT OF THE INDEX BEING VARIED AT THE SAME
C RATE AND THE TOTAL NUMBER OF INDEXES SO THAT THE SUM
C IS GREATER THAN THE MAXIMUM POSSIBLE SUBSCRIPT.
C SCANNING FROM LEFT TO RIGHT, THE NEXT LOCATION IN THE
C POINTER ARRAY WHICH CONTAINS A VALUE LESS THAN OR
C EQUAL TO THE MAXIMUM SUBSCRIPT OF AN INDEX WILL POINT
C TO THE INDEX BEING VARIED THE NEXT MOST RAPIDLY. FOR
C EXAMPLE, IF THE INITIAL CONTENTS OF THE NXTSUB ARRAY
C IS
C
C 1, 2, 3, 2, 3, 4, 3, 4, 5
C
C MEANING (IF SMALLEST NUMBER INDICATES INNERMOST LOOP)
C THAT THE FIRST INDEX IS VARIED MOST RAPIDLY, THE
C SECOND AND FOURTH ARE VARIED NEXT MOST RAPIDLY, AND
C SO ON THROUGH THE NINTH WHICH IS VARIED THE LEAST
C RAPIDLY, THEN, AFTER CONVERSION TO A POINTER ARRAY,
C THE CONTENTS OF THE NXTSUB ARRAY ARE
C
C 1, 2, (4+9)=13, 3, (5+9)=14, (7+9)=16, 6, (8+9)=17, 9
C
DIMENSION NOWSUB(KNTSUB),NXTSUB(KNTSUB),
1INISUB(KNTSUB),LMTSUB(KNTSUB),INCSUB(KNTSUB)
IF(INLOOP.GT.0)GO TO 11
C
C CHANGE ORDER ARRAY INTO A POINTER ARRAY
INLOOP=KNTSUB-LOWSUB+1
IF(INLOOP.LE.0)GO TO 24
DO 1 I=LOWSUB,KNTSUB
1 NOWSUB(I)=I
I=LOWSUB
L=LOWSUB
2 IF(I.GT.KNTSUB)GO TO 25
N=NXTSUB(I)
M=I
IF(I.EQ.KNTSUB)GO TO 6
L=L+1
DO 5 K=L,KNTSUB
IF(IRAPID.LE.0)GO TO 3
IF(NXTSUB(K).LE.N)GO TO 5
GO TO 4
3 IF(NXTSUB(K).GE.N)GO TO 5
4 M=K
N=NXTSUB(K)
5 CONTINUE
NXTSUB(M)=NXTSUB(I)
6 J=NOWSUB(M)
NOWSUB(M)=NOWSUB(I)
IF(I.EQ.LOWSUB)GO TO 7
IF(LAST.EQ.N)J=J+INLOOP
7 NXTSUB(I)=J
LAST=N
NOWSUB(I)=INISUB(I)
IF(INCSUB(I).EQ.0)INCSUB(I)=1
IF(INISUB(I).GT.LMTSUB(I))GO TO 8
IF(INCSUB(I).GE.0)GO TO 10
GO TO 9
8 IF(INCSUB(I).LE.0)GO TO 10
9 INCSUB(I)=-INCSUB(I)
10 I=I+1
GO TO 2
C
C IF ALREADY INITIALIZED, FIND NEXT VALUES
11 I=LOWSUB
12 J=I
K=NXTSUB(J)
13 NOWSUB(K)=NOWSUB(K)+INCSUB(K)
IF(INISUB(K).GT.LMTSUB(K))GO TO 14
IF(NOWSUB(K).GT.LMTSUB(K))GO TO 16
GO TO 15
14 IF(NOWSUB(K).LT.LMTSUB(K))GO TO 16
15 J=J+1
IF(J.GT.KNTSUB)GO TO 25
K=NXTSUB(J)
IF(K.LE.KNTSUB)GO TO 25
K=K-INLOOP
GO TO 13
16 J=NXTSUB(I)
17 NOWSUB(J)=INISUB(J)
I=I+1
IF(I.GT.KNTSUB)GO TO 18
IF(NXTSUB(I).LE.KNTSUB)GO TO 12
J=NXTSUB(I)-INLOOP
GO TO 17
C
C ALL DONE WITH LOOPS, TRY TO RESTORE NXTSUB ARRAY
18 I=LOWSUB
K=-1
GO TO 21
19 K=K+1
20 NOWSUB(J)=K
I=I+1
21 IF(I.GT.KNTSUB)GO TO 22
J=NXTSUB(I)
IF(J.LE.KNTSUB)GO TO 19
J=J-INLOOP
GO TO 20
22 DO 23 I=LOWSUB,KNTSUB
IF(IRAPID.GT.0)NOWSUB(I)=K-NOWSUB(I)
23 NXTSUB(I)=LOWSUB+NOWSUB(I)
C
C ALL DONE
24 INLOOP=0
25 RETURN
C485603982534
END
SUBROUTINE DASITE(IRAPID,KOUNT ,LOWSUB,KNTSUB,NOWSUB,
1 IEXTRA,LRGNUM,NUMUSD,NUMSTR,LSTKNT,NUMINI,INITAL,
2 LOCATN)
C RENBR(/GET BUFFER SUBSCRIPT FROM NAME + SUBSCRIPTS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DASITE RETURNS THE POSITION WITHIN A SINGLY
C SUBSCRIPTED BUFFER OF A SINGLE ITEM OF A POSSIBLY
C MULTIPLY SUBSCRIPTED ARRAY EQUIVALENCED WITH OR
C OTHERWISE LOADED INTO PART OR ALL OF THE SINGLY
C SUBSCRIPTED BUFFER (AS DEFINED PERHAPS BY THE
C DICTIONARY CONSTRUCTED BY THE DALOAD ROUTINE). THERE
C IS NO UPPER LIMIT TO THE NUMBER OF SUBSCRIPTS OF THE
C ARRAYS SIMULATED IN THE BUFFER (OTHER THAN THE
C OBVIOUS RESTRICTIONS IMPOSED BY THE LENGTHS OF THE
C NOWSUB AND NUMSTR ARRAYS AND BY THE LENGTH OF THE
C BUFFER ITSELF). THE RANGE OF VALUES OF ANY SUBSCRIPT
C CAN START AT ANY VALUE AND CAN BE EITHER INCREASING
C OR DECREASING. THIS CONVERSION IS THE OPPOSITE OF
C THAT PERFORMED BY DANAME.
C
C THE FOLLOWING ARGUMENTS ARE USED AS INPUT
C
C IRAPID = 0, SELECTED ARRAY, IF MULTIPLY SUBSCRIPTED,
C HAS LEFT SUBSCRIPT VARYING MOST RAPIDLY.
C THIS IS THE NORMAL FORTRAN CONVENTION FOR
C READS OR WRITES IN WHICH NAME OF ARRAY IS
C USED WITHOUT ANY SUBSCRIPTS.
C = 1, SELECTED ARRAY, IF MULTIPLY SUBSCRIPTED,
C HAS RIGHT SUBSCRIPT VARYING MOST RAPIDLY.
C KOUNT = SEQUENCE NUMBER OF THE DESIRED ARRAY AMONG
C ALL ARRAYS IN BUFFER. 1ST ARRAY IS SELECTED
C BY KOUNT=1, 2ND BY KOUNT=2 AND SO ON.
C LOWSUB = SUBSCRIPT OF NOWSUB ARRAY CONTAINING FIRST
C SIMULATED SUBSCRIPT OF THE ITEM BEING
C LOCATED.
C KNTSUB = SUBSCRIPT OF NOWSUB ARRAY CONTAINING FINAL
C SIMULATED SUBSCRIPT OF THE ITEM BEING
C LOCATED. IF THE LOWER PORTION OF THE NOWSUB
C ARRAY IS USED, THEN LOWSUB WILL HAVE THE
C VALUE 1 AND KNTSUB WILL BE THE NUMBER OF
C SUBSCRIPTS OF THE SIMULATED ARRAY.
C NOWSUB = ARRAY CONTAINING THE SIMULATED SUBSCRIPTS OF
C THE ITEM BEING LOCATED. NOWSUB(LOWSUB)
C THROUGH NOWSUB(KNTSUB) CONTAIN VALUES OF THE
C SUBSCRIPTS OF THE SIMULATED ARRAY WHICH
C SELECT A PARTICULAR WORD WITHIN THE TOTAL
C BUFFER.
C IEXTRA = 0, FOR EACH SIMULATED ARRAY, THE NUMSTR
C ARRAY CONTAINS ONLY THE NUMBER OF SUBSCRIPTS
C AND THE SUBSCRIPT LIMITS.
C = GREATER THAN ZERO, NUMSTR(LRGNUM) CONTAINS
C FIRST OF IEXTRA WORDS WHICH APPEAR BEFORE
C THE FIRST SUBSCRIPT DESCRIPTION. THEREAFTER,
C IEXTRA EXTRA WORDS ARE TO BE IGNORED BETWEEN
C DESCRIPTIONS OF CONSECUTIVE SIMULATED ARRAYS
C = -1, EACH SUBSCRIPT DESCRIPTION IS PRECEDED
C BY A VARIABLE NUMBER OF WORDS TO BE IGNORED.
C EACH SECTION TO BE IGNORED STARTS WITH A
C WORD CONTAINING NUMBER OF WORDS EXCLUSIVE OF
C ITSELF WHICH ARE TO BE IGNORED BEFORE NEXT
C SUBSCRIPT COUNT IS FOUND. NUMSTR(LRGNUM)
C CONTAINS NUMBER OF WORDS EXCLUSIVE OF ITSELF
C TO BE IGNORED BEFORE THE FIRST SUBSCRIPT
C DESCRIPTION.
C = -2, DICTIONARY WAS CONSTRUCTED BY DALOAD
C ROUTINE. LRGNUM CAN POINT TO EITHER START
C OF THE DESCRIPTION OF THE LOGICAL GROUP OR
C TO THE START OF THE DESCRIPTION OF THE FIRST
C ARRAY IN THE LOGICAL GROUP.
C LRGNUM = SUBSCRIPT OF THE NUMSTR ARRAY CONTAINING THE
C START OF THE DESCRIPTION OF THE FIRST
C SIMULATED ARRAY IN WHICH A PARTICULAR WORD
C CAN BE LOCATED.
C NUMUSD = SUBSCRIPT OF THE NUMSTR ARRAY CONTAINING THE
C END OF THE DESCRIPTION OF THE FINAL
C SIMULATED ARRAY IN WHICH A PARTICULAR WORD
C CAN BE LOCATED. IF ERRORS ARE NOT EXPECTED,
C THEN NUMUSD CAN JUST BE THE DIMENSION OF THE
C NUMSTR ARRAY REGARDLESS OF WHETHER ALL OF
C THE NUMSTR ARRAY IS USED.
C NUMSTR = ARRAY DESCRIBING THE SUBSCRIPT LIMITS OF THE
C ARRAYS SIMULATED IN THE SINGLY SUBSCRIPTED
C BUFFER. THE CONTENTS OF THE NUMSTR ARRAY
C ARE, FOR EACH ARRAY SIMULATED IN THE BUFFER,
C THE NUMBER OF SUBSCRIPTS OF THE SIMULATED
C ARRAY FOLLOWED BY LEFT AND RIGHT LIMITING
C VALUES OF THESE SUBSCRIPTS (VALUES WHICH THE
C SUBSCRIPTS WOULD HAVE IF THE ARRAYS
C SIMULATED IN THE BUFFER WERE ACTUALLY
C INCLUDED IN DIMENSION STATEMENTS). IF THE
C ITEM IN THE BUFFER WOULD BE DIMENSIONED AT
C 1, OR WOULD NOT DIMENSIONED, THEN A SINGLE 0
C CAN BE USED IN PLACE OF THE SEQUENCE 1,1,1.
C IT SHOULD BE NOTED THAT THE RIGHT LIMIT CAN
C BE EITHER GREATER THAN OR LESS THAN THE LEFT
C LIMIT.
C
C FOLLOWING ARGUMENTS ARE USED AS BOTH INPUT AND OUTPUT
C
C LSTKNT = SHOULD BE SET TO ZERO BY THE CALLING PROGRAM
C BEFORE DASITE IS FIRST CALLED AND WHENEVER
C THE DICTIONARY CORRESPONDING TO THE BUFFER
C CHANGES.
C = RETURNED CONTAINING INPUT VALUE OF KOUNT.
C NUMINI = INPUT VALUE IS IGNORED IF LSTKNT IS ZERO OR
C IF LSTKNT IS GREATER THAN KOUNT. NUMINI IS
C SET BY EACH CALL TO DASITE AND SHOULD NEVER
C BE SET BY THE CALLING PROGRAM.
C = INPUT VALUE IS LOCATION IN NUMSTR ARRAY (AS
C SUBSCRIPT OF THE NUMSTR ARRAY) OF THE START
C OF THE DESCRIPTION OF THE SELECTED ARRAY.
C IF IEXTRA=0, THEN NUMSTR(NUMINI) CONTAINS
C SUBSCRIPT COUNT AT START OF THE DESCRIPTION.
C = RETURNED CONTAINING LOCATION IN NUMSTR ARRAY
C OF THE START OF DESCRIPTION OF SELECTED
C ARRAY.
C INITAL = INPUT VALUE IS IGNORED IF LSTKNT IS ZERO OR
C IF LSTKNT IS GREATER THAN KOUNT. INITAL IS
C SET BY EACH CALL TO DASITE AND SHOULD NEVER
C BE SET BY THE CALLING PROGRAM.
C = INPUT VALUE IS LOCATION IN BUFFER (AS THE
C WORD COUNT WITHIN BUFFER) OF THE START OF
C SELECTED ARRAY.
C = RETURNED CONTAINING LOCATION IN BUFFER OF
C START OF SELECTED ARRAY.
C
C THE FOLLOWING ARGUMENT IS RETURNED AS OUTPUT
C
C LOCATN = IF RETURNED GREATER THAN ZERO, LOCATN IS THE
C POSITION OF THE SELECTED WORD OF THE
C SELECTED ARRAY FROM THE START OF THE BUFFER.
C = 0 RETURNED IF SUBSCRIPTS ARE NOT IN THE
C RANGE PREDICTED BY NUMSTR ARRAY.
C = -1 RETURNED IF NOWSUB ARRAY CONTAINS
C DIFFERENT NUMBER OF SUBSCRIPTS THAN NUMSTR
C ARRAY.
C = -2 RETURNED IF SEQUENCE NUMBER INDICATED BY
C KOUNT IS NOT IN THE NUMSTR ARRAY.
C
C FOR EXAMPLE, IF BUFFER CONTAINS VALUES OF ARRAYS A,
C B, E DIMENSIONED A(1/3,1/5), B(1/5,1/6), E(1/10,1/10)
C (THIS SPECIFICATION MEANS THAT THE LEFT SUBSCRIPT OF
C ARRAY A CAN RANGE FROM 1 THROUGH 3 AND THAT THE
C SECOND SUBSCRIPT CAN RANGE FROM 1 THROUGH 5) AND
C CONTAINS NONDIMENSIONED ITEMS C AND D IN ORDER
C
C A,B,C,D,E
C
C THEN THE CONTENTS OF THE NUMSTR ARRAY WOULD BE
C
C 2,1,3,1,5,2,1,5,1,6,0,0,2,1,10,1,10
C
C OR
C
C 2,1,3,1,5,2,1,5,1,6,1,1,1,1,1,1,2,1,10,1,10
C
C IF KOUNT HAS THE VALUE 2 AND IF THE NOWSUB ARRAY
C CONTAINS THE VALUES 4 AND 3 SELECTING B(4,3) AND IF
C IRAPID HAD VALUE 0, SO THAT ALL OF ARRAY A, B(1,1)
C THROUGH B(5,1), B(1,2) THROUGH B(5,2), AND B(1,3)
C THROUGH B(3,3) WOULD BE BELOW B(4,3) THEN LOCATN
C WOULD BE RETURNED AS 15+5+5+3+1=29
C
C IF IRAPID=0, ORDER OF A ARRAY IN BUFFER WOULD BE
C (READING ACROSS EACH LINE FROM LEFT TO RIGHT)
C A(1,1),A(2,1),A(3,1),A(1,2),A(2,2),A(3,2),
C A(1,3),A(2,3),A(3,3),A(1,4),A(2,4),A(3,4),
C A(1,5),A(2,5),A(3,5)
C
C IF IRAPID=1, ORDER OF A ARRAY IN BUFFER WOULD BE
C A(1,1),A(1,2),A(1,3),A(1,4),A(1,5)
C A(2,1),A(2,2),A(2,3),A(2,4),A(2,5)
C A(3,1),A(3,2),A(3,3),A(3,4),A(3,5)
C
C IF Z ARRAY IS EFFECTIVELY DIMENSIONED Z(4/3,-1/1)
C THEN ITS REPRESENTATION IN NUMSTR ARRAY WOULD BE
C 2,4,3,-1,1
C AND IF IRAPID=0, ITS ORDER IN BUFFER WOULD BE
C Z(4,-1),Z(3,-1),Z(4,0),Z(3,0),Z(4,1),Z(3,1)
C IF INSTEAD IRAPID=1, ITS ORDER IN BUFFER WOULD BE
C Z(4,-1),Z(4,0),Z(4,1),Z(3,-1),Z(3,0),Z(3,1)
C
DIMENSION NOWSUB(KNTSUB),NUMSTR(NUMUSD)
C
C FIND NUMBER OF WORDS BELOW SELECTED ARRAY
IFORMT=IEXTRA+1
JEXTRA=2
IF(IFORMT.GT.0)JEXTRA=IEXTRA
IF(LSTKNT.LE.0)GO TO 1
IF(KOUNT.GE.LSTKNT)GO TO 2
1 LSTKNT=1
INITAL=1
NUMINI=LRGNUM
IF(IFORMT.GE.0)GO TO 2
IF(NUMINI.GT.NUMUSD)GO TO 13
IF(NUMSTR(NUMINI).GT.0)GO TO 2
IF(NUMSTR(NUMINI+2).LT.0)GO TO 13
NUMINI=NUMINI+3+(2*NUMSTR(NUMINI+2))
2 IF(NUMINI.GT.NUMUSD)GO TO 13
IF(IFORMT.GT.0)GO TO 4
IF(IFORMT.EQ.0)GO TO 3
IF(NUMSTR(NUMINI).GT.0)GO TO 4
GO TO 13
3 JEXTRA=NUMSTR(NUMINI)+1
IF(JEXTRA.LE.0)GO TO 13
4 NEXT=NUMINI+JEXTRA
KNTLMT=NUMSTR(NEXT)
IF(KOUNT.LE.LSTKNT)GO TO 7
NUMINI=NEXT+1
NEXT=NEXT+KNTLMT+KNTLMT
LOCAL=1
5 IF(NUMINI.GE.NEXT)GO TO 6
ISIZE=NUMSTR(NUMINI+1)-NUMSTR(NUMINI)+1
IF(ISIZE.LE.0)ISIZE=2-ISIZE
LOCAL=LOCAL*ISIZE
NUMINI=NUMINI+2
GO TO 5
6 INITAL=INITAL+LOCAL
LSTKNT=LSTKNT+1
GO TO 2
C
C FIND LOCATION WITHIN SELECTED ARRAY
7 LOCAL=0
IF(KNTLMT.GT.0)GO TO 8
IF(KNTSUB.LT.LOWSUB)GO TO 16
IF(KNTSUB.NE.LOWSUB)GO TO 14
IF(NOWSUB(LOWSUB).NE.1)GO TO 15
GO TO 16
8 IF((KNTSUB-LOWSUB).NE.(KNTLMT-1))GO TO 14
IF(IRAPID.GT.0)GO TO 9
INDEX=KNTLMT+LOWSUB-1
LMTPNT=NEXT+KNTLMT+KNTLMT
GO TO 10
9 INDEX=LOWSUB
LMTPNT=NEXT+2
10 ILOWER=NOWSUB(INDEX)-NUMSTR(LMTPNT-1)
ISIZE=NUMSTR(LMTPNT)-NUMSTR(LMTPNT-1)+1
IF(ISIZE.GT.0)GO TO 11
ILOWER=-ILOWER
ISIZE=2-ISIZE
11 IF(ILOWER.LT.0)GO TO 15
IF(ILOWER.GE.ISIZE)GO TO 15
LOCAL=(LOCAL*ISIZE)+ILOWER
KNTLMT=KNTLMT-1
IF(KNTLMT.LE.0)GO TO 16
IF(IRAPID.GT.0)GO TO 12
INDEX=INDEX-1
LMTPNT=LMTPNT-2
GO TO 10
12 INDEX=INDEX+1
LMTPNT=LMTPNT+2
GO TO 10
C
C ARRAY SEQUENCE NUMBER TOO LARGE
13 LOCATN=-2
GO TO 17
C
C INCORRECT NUMBER OF SUBSCRIPTS
14 LOCATN=-1
GO TO 17
C
C SUBSCRIPT OUTSIDE INDICATED LIMIT
15 LOCATN=0
GO TO 17
C
C ADD OFFSET TO START OF AND OFFSET WITHIN ARRAY
16 LOCATN=INITAL+LOCAL
17 RETURN
C575207010056
END
SUBROUTINE DANAME(IRAPID,LOCATN,LRGNUM,NUMUSD,NUMSTR,
1 LRGLTR,MAXSUB,INITAL,KOUNT ,LTRINI,NUMINI,KNTSUB,
2 NOWSUB)
C RENBR(/GET NAME + SUBSCRIPTS FROM BUFFER SUBSCRIPT)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DANAME CONVERTS A SUBSCRIPT OF A SINGLY SUBSCRIPTED
C BUFFER WHICH IS CONSIDERED TO HOLD ONE OR MORE
C POSSIBLY MULTIPLY SUBSCRIPTED ARRAYS INTO THE ARRAY
C NAME AND ITS SUBSCRIPTS AS DEFINED BY THE DICTIONARY
C CONSTRUCTED BY THE DALOAD ROUTINE. THIS CONVERSION
C IS THE OPPOSITE OF THAT PERFORMED BY THE DASITE
C ROUTINE.
C
C SINCE THE DICTIONARY CONSTRUCTED BY DALOAD IS DIVIDED
C INTO LOGICAL GROUPS OF ARRAY NAMES, THE PROPER
C LOGICAL GROUP MUST BE LOCATED BY CALLING THE DABASE
C ROUTINE PRIOR TO THE FIRST CALL TO DANAME, UNLESS IT
C IS KNOWN THAT THE DESIRED LOGICAL GROUP IS THE FIRST
C (OR ONLY) GROUP IN THE DICTIONARY.
C
C FOLLOWING ARGUMENTS ARE USED FOR INPUT ONLY AND ARE
C RETURNED UNCHANGED.
C
C IRAPID = 0, MULTIPLY SUBSCRIPTED ARRAYS HAVE THEIR
C LEFT SUBSCRIPTS VARY MOST RAPIDLY
C = 1, MULTIPLY SUBSCRIPTED ARRAYS HAVE THEIR
C RIGHT SUBSCRIPTS VARY MOST RAPIDLY.
C
C LOCATN = THE VALUE OF SUBSCRIPT OF SINGLY SUBSCRIPTED
C BUFFER WHICH IS TO BE CONVERTED TO
C CORRESPONDING ARRAY NAME AND ITS SUBSCRIPTS.
C
C LRGNUM = SUBSCRIPT OF NUMSTR ARRAY LOCATION WHICH
C CONTAINS FIRST OF NUMERIC INFORMATION
C ASSOCIATED WITH LOGICAL GROUP OF NAMES OF
C ARRAYS VALUES OF WHICH ARE EQUIVALENCED WITH
C OR OTHERWISE CONTAINED IN SINGLY SUBSCRIPTED
C BUFFER. NUMSTR(LRGNUM) CONTAINS AS ITS
C ABSOLUTE VALUE NUMBER OF CHARACTERS WHICH
C ARE CONTAINED IN NAME, IF ANY, OF LOGICAL
C GROUP.
C
C NUMUSD = HIGHEST SUBSCRIPT OF LOCATIONS IN NUMSTR
C ARRAY CONTAINING NUMERIC INFORMATION
C CORRESPONDING TO POSSIBLY MULTIPLY
C SUBSCRIPTED ARRAYS VALUES OF WHICH ARE
C EQUIVALENCED WITH OR OTHERWISE CONTAINED IN
C SINGLY SUBSCRIPTED BUFFER. NUMUSD IS
C HIGHEST SUBSCRIPT USED IN NUMSTR ARRAY FOR
C STORAGE OF INFORMATION ABOUT ANY ARRAY IN
C ANY LOGICAL GROUP, AND IS NOT NECESSARILY
C HIGHEST SUBSCRIPT USED IN NUMSTR ARRAY FOR
C STORAGE OF INFORMATION ABOUT ARRAY IN
C CURRENT LOGICAL GROUP.
C
C NUMSTR = THE ARRAY CONTAINING NUMERIC INFORMATION
C CORRESPONDING TO POSSIBLY MULTIPLY
C SUBSCRIPTED ARRAYS VALUES OF WHICH ARE
C EQUIVALENCED WITH OR OTHERWISE CONTAINED IN
C SINGLY SUBSCRIPTED BUFFER. CONSTRUCTION OF
C NUMSTR ARRAY IS DESCRIBED IN DETAIL IN
C DALOAD DOCUMENTATION. FOR EACH NAME IN
C DICTIONARY, NUMSTR ARRAY CONTAINS
C
C A. THE NUMBER OF CHARACTERS IN NAME
C B. AN INDICATION OF ASSOCIATED DATA TYPE
C C. THE NUMBER OF SUBSCRIPT RANGES
C D. PAIRS OF STARTING AND ENDING VALUES OF
C THESE RANGES.
C
C IF NUMBER OF CHARACTERS IS INSTEAD ZERO OR
C NEGATIVE, THEN ITS ABSOLUTE VALUE IS NUMBER
C OF CHARACTERS IN NAME OF LOGICAL GROUP OF
C NAMES, AND NEXT LOCATION, RATHER THAN
C INDICATING DATA TYPE, CONTAINS NUMBER OF
C LOCATIONS WITHIN SINGLY SUBSCRIPTED BUFFER
C WHICH WOULD BE NEEDED TO STORE VALUES OF
C MULTIPLY SUBSCRIPTED ARRAYS WHICH ARE WITHIN
C LOGICAL GROUP AND EQUIVALENCED WITH OR
C OTHERWISE LOADED INTO SUCH SINGLY
C SUBSCRIPTED BUFFER.
C
C LRGLTR = THE SUBSCRIPT OF LTRSTR ARRAY (NOT ARGUMENT
C OF THIS ROUTINE BUT CONSTRUCTED BY DALOAD IN
C PARALLEL WITH NUMSTR) WHICH CONTAINS FIRST
C LETTER OF NAME ASSOCIATED WITH LOGICAL GROUP
C OF NAMES IN DICTIONARY IF NUMSTR(LRGNUM) IS
C NEGATIVE, OR WHICH CONTAINS FIRST LETTER OF
C FIRST ARRAY NAME IN LOGICAL GROUP OF NAMES
C IF NUMSTR(LRGNUM) IS POSITIVE OR ZERO.
C
C MAXSUB = HIGHEST SUBSCRIPT OF LOCTIONS IN NOWSUB
C ARRAY WHICH CAN BE USED BY THIS ROUTINE TO
C STORE VALUES OF SUBSCRIPTS OF ARRAY NAME
C CORRESPONDING TO SUBSCRIPT (INPUT AS VALUE
C OF LOCATN) OF SINGLY SUBSCRIPTED BUFFER.
C
C FOLLOWING ARGUMENTS ARE USED FOR BOTH INPUT AND
C OUTPUT. IF THIS ROUTINE IS ASKED TO CONVERT VALUE OF
C LOCATN WHICH IS SUBSCRIPT OF LOCATION IN OR FURTHER
C BEYOND ARRAY IDENTIFIED BY PREVIOUS CALL TO THIS
C ROUTINE BUT WHICH IS STILL WITHIN SAME LOGICAL GROUP
C OF ARRAYS AS DEALT WITH BY PREVOUS CALL, THEN VALUES
C OF THESE ARGUMENTS AS OUTPUT BY PREVIOUS CALL ARE
C USED AS NEW OFFSETS IN DICTIONARY AND BUFFER, RATHER
C THAN REPEATING CALCULATIONS FOR LOWER PORTION OF
C LOGICAL GROUP.
C
C INITAL = SHOULD BE SET TO ZERO BY CALLING PROGRAM
C BEFORE THIS ROUTINE IS FIRST CALLED, AND
C AGAIN SET TO ZERO WHENEVER THIS ROUTINE IS
C CALLED TO REFERENCE DIFFERENT LOGICAL GROUP
C OF ARRAY NAMES IN DICTIONARY.
C = RETURNED GREATER THAN ZERO IF SUBSCRIPT OF
C SINGLY SUBSCRIPTED BUFFER INPUT AS VALUE OF
C ARGUMENT LOCATN COULD BE CONVERTED INTO NAME
C AND SUBSCRIPTS OF POSSIBLY MULTIPLY
C SUBSCRIPTED ARRAY EQUIVALENCED WITH OR
C OTHERWISE CONTAINED IN PART OR ALL OF SINGLY
C SUBSCRIPTED BUFFER. INITAL IS RETURNED
C CONTAINING SUBSCRIPT OF SINGLY SUBSCRIPTED
C BUFFER LOCATION WHICH CONTAINS START OF (THE
C FIRST LOCATION WITHIN) POSSIBLY MULTIPLY
C SUBSCRIPTED ARRAY SOME LOCATION WITHIN WHICH
C CORRESPONDS TO SINGLY SUBSCRIPTED BUFFER
C LOCATION HAVING AS ITS SUBSCRIPT INPUT VALUE
C OF ARGUMENT LOCATN. IF POSSIBLY MULTIPLY
C SUBSCRIPTED ARRAY IDENTIFIED BY THIS ROUTINE
C CONSISTS OF SINGLE LOCATION, THEN INITAL IS
C RETURNED CONTAINING INPUT VALUE OF LOCATN.
C = 0, RETURNED IF SUBSCRIPT OF SINGLY
C SUBSCRIPTED BUFFER INPUT AS VALUE OF
C ARGUMENT LOCATN COULD NOT BE CONVERTED INTO
C NAME AND SUBSCRIPTS OF ARRAY EQUIVALENCED
C WITH OR OTHERWISE CONTAINED IN PART OR ALL
C OF SINGLY SUBSCRIPTED BUFFER. IN OTHER
C WORDS, LOCATN WAS INPUT CONTAINING VALUE NOT
C INDICATED BY DICTIONARY AS BEING WITHIN
C SINGLY SUBSCRIPTED BUFFER CONTAINING ARRAYS
C FORMING LOGICAL GROUP.
C = -1, MAXSUB IS LESS THAN NUMBER OF SUBSCRIPTS
C OF POSSIBLY MULTIPLY SUBSCRIPTED ARRAY
C IDENTIFIED BY THIS ROUTINE SO THAT NOT ALL
C OF SUBSCRIPTS COULD BE REPRESENTED IN NOWSUB
C ARRAY.
C
C KOUNT = INPUT VALUE IS IGNORED IF INITAL IS INPUT
C CONTAINING ZERO OR IF INITAL IS INPUT
C GREATER THAN INPUT VALUE OF LOCATN. KOUNT
C IS SET BY EACH CALL TO THIS ROUTINE, AND
C SHOULD NEVER BE SET BY CALLING PROGRAM.
C = IF INITAL IS INPUT GREATER THAN ZERO BUT
C LESS THAN OR EQUAL TO LOCATN, THEN KOUNT, AS
C RETURNED BY PREVIOUS CALL TO THIS ROUTINE,
C IS SEQUENCE NUMBER OF POSSIBLY MULTIPLY
C SUBSCRIPTED ARRAY CORRESPONDING TO INPUT
C VALUE OF INITAL.
C = RETURNED CONTAINING SEQUENCE NUMBER OF
C IDENTIFIED ARRAY RELATIVE TO ALL ARRAYS IN
C LOGICAL GROUP OF ARRAYS. IF THIRD ARRAY IN
C LOGICAL GROUP CONTAINS LOCATION
C CORRESPONDING TO INPUT VALUE OF LOCATN, THEN
C KOUNT IS RETURNED CONTAINING VALUE 3.
C
C LTRINI = INPUT VALUE IS IGNORED IF INITAL IS INPUT
C CONTAINING ZERO OR IF INITAL IS INPUT
C GREATER THAN INPUT VALUE OF LOCATN. LTRINI
C IS SET BY EACH CALL TO THIS ROUTINE, AND
C SHOULD NEVER BE SET BY CALLING PROGRAM.
C = IF INITAL IS INPUT GREATER THAN ZERO BUT
C LESS THAN OR EQUAL TO LOCATN, THEN LTRINI,
C AS RETURNED BY PREVIOUS CALL TO THIS
C ROUTINE, IS SUBSCRIPT OF LTRSTR LOCATION
C CONTAINING 1ST CHARACTER OF THE NAME OF THE
C POSSIBLY MULTIPLY SUBSCRIPTED ARRAY
C CORRESPONDING TO INPUT VALUE OF INITAL.
C = RETURNED CONTAINING SUBSCRIPT OF LTRSTR
C ARRAY LOCATION CONTAINING 1ST CHARACTER OF
C NAME OF IDENTIFIED ARRAY.
C
C NUMINI = INPUT VALUE IS IGNORED IF INITAL IS INPUT
C CONTAINING ZERO OR IF INITAL IS INPUT
C GREATER THAN INPUT VALUE OF LOCATN. NUMINI
C IS SET BY EACH CALL TO THIS ROUTINE, AND
C SHOULD NEVER BE SET BY CALLING PROGRAM.
C = IF INITAL IS INPUT GREATER THAN ZERO BUT
C LESS THAN OR EQUAL TO LOCATN, THEN NUMINI,
C AS RETURNED BY PREVIOUS CALL TO THIS
C ROUTINE, IS SUBSCRIPT OF NUMSTR LOCATION
C CONTAINING START OF NUMERIC DESCRIPTION OF
C POSSIBLY MULTIPLY SUBSCRIPTED ARRAY
C CORRESPONDING TO INPUT VALUE OF INITAL.
C = RETURNED CONTAINING SUBSCRIPT OF NUMSTR
C ARRAY LOCATION CONTAINING START OF NUMERIC
C DESCRIPTION OF IDENTIFIED ARRAY.
C
C FOLLOWING ARGUMENTS ARE USED ONLY FOR OUTPUT. THEIR
C INPUT VALUES ARE IGNORED. THESE ARGUMENTS ARE
C RETURNED UNDEFINED IF INITAL IS RETURNED LESS THAN OR
C EQUAL TO ZERO.
C
C KNTSUB = RETURNED CONTAINING NUMBER OF SUBSCRIPTS OF
C IDENTIFIED ARRAY. IF NUMSTR ARRAY INDICATES
C THAT IDENTIFIED ARRAY IS NONDIMENSIONED,
C THEN KNTSUB IS RETURNED CONTAINING 1, AND
C NOWSUB(1) IS RETURNED ALSO CONTAINING 1.
C
C NOWSUB = ARRAY RETURNED CONTAINING IN LOCATIONS
C NOWSUB(1) THROUGH AND INCLUDING
C NOWSUB(KNTSUB) VALUES OF SUBSCRIPTS OF
C POSSIBLY MULTIPLY SUBSCRIPTED ARRAY LOCATION
C CORRESPONDING TO SUBSCRIPT OF SINGLY
C SUBSCRIPTED BUFFER INPUT AS ARGUMENT LOCATN.
C
DIMENSION NUMSTR(NUMUSD),NOWSUB(MAXSUB)
C
IF(INITAL.LE.0)GO TO 1
IF(LOCATN.GE.INITAL)GO TO 2
C
C FIND NUMBER OF LOCATIONS BELOW CURRENT LOCATION
1 NUMINI=LRGNUM
LTRINI=LRGLTR
KOUNT=0
INITAL=1
2 IF(NUMINI.GE.NUMUSD)GO TO 14
KNTLTR=NUMSTR(NUMINI)
IF(KNTLTR.GT.0)GO TO 3
IF(NUMINI.NE.LRGNUM)GO TO 14
KNTLTR=-KNTLTR
GO TO 6
3 KOUNT=KOUNT+1
ISIZE=1
INDEX=NUMINI+3
LIMIT=NUMSTR(INDEX-1)
4 IF(LIMIT.LE.0)GO TO 5
JSIZE=NUMSTR(INDEX+1)-NUMSTR(INDEX)+1
IF(JSIZE.LE.0)JSIZE=2-JSIZE
ISIZE=ISIZE*JSIZE
INDEX=INDEX+2
LIMIT=LIMIT-1
GO TO 4
5 IF((INITAL+ISIZE).GT.LOCATN)GO TO 7
INITAL=INITAL+ISIZE
6 LTRINI=LTRINI+KNTLTR
NUMINI=NUMINI+3+(2*NUMSTR(NUMINI+2))
GO TO 2
C
C FIND SUBSCRIPTS CORRESPONDING TO CURRENT LOCATION
7 LOCAL=LOCATN-INITAL
LIMIT=NUMSTR(NUMINI+2)
IF(LIMIT.LE.0)GO TO 12
IF(LIMIT.GT.MAXSUB)GO TO 13
KNTSUB=LIMIT
IF(IRAPID.LE.0)GO TO 8
ICHANG=-2
INDEX=NUMINI+1+LIMIT+LIMIT
JCHANG=-1
LOCSUB=LIMIT
GO TO 9
8 ICHANG=2
INDEX=NUMINI+3
JCHANG=1
LOCSUB=1
9 IF(LIMIT.LE.0)GO TO 15
INISUB=NUMSTR(INDEX)
ISIZE=NUMSTR(INDEX+1)-INISUB+1
NEWSUB=LOCAL
IF(ISIZE.GT.0)GO TO 10
ISIZE=2-ISIZE
LOCAL=LOCAL/ISIZE
NOWSUB(LOCSUB)=INISUB-NEWSUB+(ISIZE*LOCAL)
GO TO 11
10 LOCAL=LOCAL/ISIZE
NOWSUB(LOCSUB)=INISUB+NEWSUB-(ISIZE*LOCAL)
11 LIMIT=LIMIT-1
INDEX=INDEX+ICHANG
LOCSUB=LOCSUB+JCHANG
GO TO 9
C
C SIMULATE SUBSCRIPT IF NAME IS UNDIMENSIONED
12 IF(MAXSUB.LE.0)GO TO 13
KNTSUB=1
NOWSUB(1)=1
GO TO 15
C
C NOWSUB ARRAY TOO SMALL
13 INITAL=-1
GO TO 15
C
C LOCATION NOT IN LOGICAL GROUP
14 INITAL=0
C
C RETURN TO CALLING PROGRAM
15 RETURN
C445857737136
END
SUBROUTINE DASAVE(IPART ,IFORMT,MAXCLM,MAXLIN,IDATA ,
1 KNTDAT,LETTER,KNTLTR,NAME ,KNTNAM,IOUT ,IERR )
C RENBR(/INTEGER AND 1H DATA STATEMENT GENERATOR)
C
C DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C JUL 14, 1970
C
C IPART = -1, CONSTRUCT DIMENSION AND EQUIVALENCE
C STATEMENTS BUT NOT DATA STATEMENTS
C = 0, CONSTRUCT DIMENSION, EQUIVALENCE AND DATA
C STATEMENTS
C = 1, CONSTRUCT DIMENSION STATEMENTS ONLY
C = 2, CONSTRUCT EQUIVALENCE STATEMENTS ONLY
C = 3, CONSTRUCT DATA STATEMENTS ONLY
C = -4, -3 OR -2, IDENTICAL TO IPART=-1, 0 OR 1
C RESPECTIVELY, EXCEPT THAT DIMENSION
C STATEMENTS SPECIFY COMPONENT ARRAYS NECESARY
C TO CONSTRUCT ORGINAL ARRAY BUT DO NOT
C INCLUDE NAME AND DIMENSION OF ORIGINAL
C ARRAY.
C IFORMT = -1, REPRESENT CHARACTERS IN LETTER ARRAY
C WHICH WERE DEFINED BY 1H FIELDS OR READ WITH
C A1 FORMATS
C = 0, REPRESENT INTEGERS IN IDATA ARRAY IN
C COMPACT FORM
C = 1 OR GREATER, REPRESENT INTEGERS IN IDATA
C ARRAY IN COLUMNS WHICH ARE AT LEAST IFORMT
C CHARACTERS WIDE (IFORMT=10 IS EQUIVALENT TO
C I10 FORMAT)
C MAXCLM = NUMBER OF CHARACTERS TO BE IN STATEMENT
C FIELD (66 IF MAXIMUM, IE 72 MINUS LEFT 6
C COLUMNS)
C MAXLIN = MAXIMUM NUMBER OF LINES FOR SINGLE STATEMENT
C IDATA = ARRAY OF INTEGERS TO BE REPRESENTED IN DATA
C STATEMENTS IF IFORMT IS ZERO OR GREATER
C KNTDAT = NUMBER OF LOCATIONS IN IDATA ARRAY TO BE
C REPRESENTED IN DATA STATEMENTS
C LETTER = ARRAY OF CHARACTERS READ WITH A1 FORMAT OR
C DEFINED USING 1H FIELDS TO BE REPRESENTED IN
C DATA STATEMENTS IF IFORMT HAS VALUE -1
C KNTLTR = NUMBER OF LOCATIONS IN LETTER ARRAY TO BE
C REPRESENTED IN DATA STATEMENTS
C NAME = ALPHAMERIC ARRAY CONTAINING NAME OF ARRAY
C (READ BY MULTIPLE OF A1 FORMAT)
C KNTNAM = NUMBER OF LETTERS IN NAME OF ARRAY
C IOUT = OUTPUT UNIT ON WHICH STATEMENT IS WRITTEN
C IERR = 0 RETURNED IF COULD GENERATE DATA STATEMENT
C = 1 RETURNED IF MAXCLM TOO SMALL
C = 2 RETURNED IF ISTORE ARRAY TOO SMALL
C
DIMENSION IDATA(KNTDAT),LETTER(KNTLTR),NAME(KNTNAM),
1IBUFFR(66),ISTORE(200)
DATA IBLANK,ISLASH,KOMMA,ILPR,IRPR,IONE,IHOLLR/
11H ,1H/,1H,,1H(,1H),1H1,1HH/
C
C JSTORE = DIMENSION OF ISTORE ARRAY. THIS IS THE
C MAXIMUM NUMBER OF SMALL ARRAYS WHICH CAN
C BE USED TO REPRESENT THE IDATA ARRAY.
C
DATA JSTORE/200/
C
JPART=IPART
IF(JPART.LT.-1)JPART=JPART+3
IERR=0
IF(IFORMT)1,2,2
1 NEEDED=KNTLTR
GO TO 3
2 NEEDED=KNTDAT
3 IF(NEEDED)113,113,4
4 LOCK=1
MOST=0
MAX1=MAXCLM-1
MAX2=MAXCLM-2
LEFT=0
CALL DANUMB(0,NEEDED,10,IBUFFR,LEFT,0,MAXCLM)
LENGTH=KNTNAM+LEFT
IF(LENGTH-6)6,6,5
5 LENGTH=6
6 IF(IFORMT)12,81,7
C
C PREPARE FOR EXPANDED FORMAT
7 MOST=IDATA(1)
LEAST=MOST
DO 8 INDEX=1,NEEDED
IF(LEAST.GT.IDATA(INDEX))LEAST=IDATA(INDEX)
IF(MOST.LT.IDATA(INDEX))MOST=IDATA(INDEX)
8 CONTINUE
KOUNT=0
CALL DANUMB(0,MOST,10,IBUFFR,KOUNT,0,MAXCLM)
MOST=KOUNT
KOUNT=0
CALL DANUMB(0,LEAST,10,IBUFFR,KOUNT,0,MAXCLM)
IF(MOST-KOUNT)9,10,10
9 MOST=KOUNT
10 IF(MOST-IFORMT)11,13,13
11 MOST=IFORMT
GO TO 13
12 MOST=3
13 LIMIT=MAXLIN*((MAXCLM-LENGTH-6)/(MOST+1))
IF(LIMIT)112,112,14
14 KNTPRT=1+((NEEDED-1)/LIMIT)
IF(KNTPRT-JSTORE)15,15,111
15 LEAST=1
DO 16 INDEX=1,KNTPRT
ISTORE(INDEX)=LEAST
16 LEAST=LEAST+LIMIT
C
C TEST IF LABELS ARE OF MINIMUM LENGTH
17 ITEST=0
CALL DANUMB(0,ISTORE(KNTPRT),10,IBUFFR,ITEST,0,
1MAXCLM)
IF(KNTNAM+ITEST-LENGTH)18,19,19
18 LENGTH=KNTNAM+ITEST
IF(IFORMT)13,81,13
19 LOCK=0
IF(IFORMT)21,20,21
20 LEFT=0
ITEST=0
C
C CONSTRUCT SINGLE LINE OF DIMENSION STATEMENT
21 IF(JPART-2)22,59,81
22 INDEX=0
DO 23 LEAST=1,10
23 IBUFFR(LEAST)=IBLANK
24 LINE=1
LAST=INDEX
25 KOUNT=10
26 IF(INDEX)27,27,39
C
C INSERT NAME OF MAIN ARRAY
27 IF(IFORMT)28,29,28
28 LIMIT=-LENGTH
GO TO 30
29 LIMIT=0
30 LEAST=KOUNT
CALL DABOTH(LIMIT,LEFT,NAME,KNTNAM,0,NEEDED,IBUFFR,
1KOUNT,MAX1)
C
C OUTPUT COMMENT LINE DESCRIBING DIMENSION
IF(IPART+1)31,38,38
31 IF(LINE-1)32,32,35
32 IF(KOUNT-10)33,33,34
33 WRITE(IOUT,120)
GO TO 52
34 WRITE(IOUT,120)(IBUFFR(LEAST),LEAST=11,KOUNT)
GO TO 37
35 IF(KOUNT-LEAST)112,112,36
36 WRITE(IOUT,121)MANY,(IBUFFR(LEAST),LEAST=1,KOUNT)
37 INDEX=1
GO TO 24
C
C INSERT NAME OF SMALL ARRAY
38 IF(KOUNT-LEAST)46,46,43
39 IF(INDEX-KNTPRT)41,40,40
40 LIMIT=NEEDED-ISTORE(INDEX)+1
GO TO 42
41 LIMIT=ISTORE(INDEX+1)-ISTORE(INDEX)
42 LEAST=KOUNT
CALL DABOTH(LENGTH,LEFT,NAME,KNTNAM,ISTORE(INDEX),
1LIMIT,IBUFFR,KOUNT,MAX1)
IF(KOUNT-LEAST)44,44,43
43 INDEX=INDEX+1
KOUNT=KOUNT+1
IBUFFR(KOUNT)=KOMMA
IF(INDEX-KNTPRT)26,26,45
C
C OUTPUT SINGLE LINE OF DIMENSION STATEMENT
44 IF(LINE-MAXLIN)46,45,45
45 KOUNT=KOUNT-1
46 IF(LINE-1)47,47,50
47 IF(KOUNT-10)48,48,49
48 WRITE(IOUT,116)
GO TO 52
49 WRITE(IOUT,116)(IBUFFR(LEAST),LEAST=11,KOUNT)
GO TO 52
50 IF(KOUNT)112,112,51
51 WRITE(IOUT,119)MANY,(IBUFFR(LEAST),LEAST=1,KOUNT)
MANY=MANY+1
IF(MANY-9)53,53,52
52 MANY=1
53 IF(INDEX-KNTPRT)54,54,58
54 IF(LINE-MAXLIN)56,55,55
55 IF(INDEX-LAST)112,112,24
56 LINE=LINE+1
IF(IFORMT)25,57,25
57 KOUNT=0
GO TO 26
C
C CONSTRUCT SINGLE LINE OF EQUIVALENCE STATEMENT
58 IF(JPART)59,59,113
59 INDEX=1
DO 60 LEAST=1,12
60 IBUFFR(LEAST)=IBLANK
61 LINE=1
LAST=INDEX
62 KOUNT=12
C
C INSERT NAME OF SMALL ARRAY
63 KOUNT=KOUNT+1
LEAST=KOUNT
CALL DABOTH(LENGTH,0,NAME,KNTNAM,ISTORE(INDEX),1,
1IBUFFR,KOUNT,MAX2)
IF(KOUNT-LEAST)66,66,64
C
C INSERT NAME OF MAIN ARRAY
64 KOUNT=KOUNT+1
LIMIT=KOUNT
CALL DABOTH(0,ITEST,NAME,KNTNAM,0,ISTORE(INDEX),
1IBUFFR,KOUNT,MAX2)
IF(KOUNT-LIMIT)66,66,65
65 IBUFFR(LEAST)=ILPR
IBUFFR(LIMIT)=KOMMA
KOUNT=KOUNT+1
IBUFFR(KOUNT)=IRPR
KOUNT=KOUNT+1
IBUFFR(KOUNT)=KOMMA
INDEX=INDEX+1
IF(INDEX-KNTPRT)63,63,67
C
C OUTPUT SINGLE LINE OF EQUIVALENCE STATEMENT
66 KOUNT=LEAST-1
IF(LINE-MAXLIN)68,67,67
67 KOUNT=KOUNT-1
68 IF(LINE-1)69,69,72
69 IF(KOUNT-12)70,70,71
70 WRITE(IOUT,117)
GO TO 74
71 WRITE(IOUT,117)(IBUFFR(LEAST),LEAST=13,KOUNT)
GO TO 74
72 IF(KOUNT)112,112,73
73 WRITE(IOUT,119)MANY,(IBUFFR(LEAST),LEAST=1,KOUNT)
MANY=MANY+1
IF(MANY-9)75,75,74
74 MANY=1
75 IF(INDEX-KNTPRT)76,76,80
76 IF(LINE-MAXLIN)78,77,77
77 IF(INDEX-LAST)112,112,61
78 LINE=LINE+1
IF(IFORMT)62,79,62
79 KOUNT=0
GO TO 63
C
C CONSTRUCT SINGLE LINE OF DATA STATEMENT
80 IF(JPART)113,81,113
81 INDEX=1
KNTPRT=0
82 LINE=1
LAST=INDEX+1
KOUNT=5
83 LIMIT=KOUNT+MOST
84 LEAST=KOUNT
IF(LAST-INDEX)88,88,85
C
C INSERT NAME OF SMALL ARRAY
85 CALL DABOTH(LENGTH,-1,NAME,KNTNAM,INDEX,0,IBUFFR,
1KOUNT,MAX1)
IF(KOUNT-LEAST)97,97,86
86 LAST=INDEX
KOUNT=KOUNT+1
IBUFFR(KOUNT)=ISLASH
IF(KNTPRT-JSTORE)87,111,111
87 KNTPRT=KNTPRT+1
ISTORE(KNTPRT)=INDEX
GO TO 83
C
C INSERT INTEGER ENTRY
88 IF(IFORMT)90,89,89
89 CALL DANUMB(IFORMT,IDATA(INDEX),10,IBUFFR,KOUNT,
1LIMIT,MAX1)
IF(KOUNT-LEAST)95,95,94
GO TO 94
90 IF(LIMIT-MAX1)91,91,95
91 IF(KOUNT-(LIMIT-3))92,93,93
92 KOUNT=KOUNT+1
IBUFFR(KOUNT)=IBLANK
GO TO 91
93 KOUNT=KOUNT+3
IBUFFR(KOUNT-2)=IONE
IBUFFR(KOUNT-1)=IHOLLR
IBUFFR(KOUNT)=LETTER(INDEX)
94 KOUNT=KOUNT+1
IBUFFR(KOUNT)=KOMMA
INDEX=INDEX+1
IF(INDEX-NEEDED)83,83,96
C
C OUTPUT SINGLE LINE OF DATA STATEMENT
95 IF(LINE-MAXLIN)97,96,96
96 IBUFFR(KOUNT)=ISLASH
97 IF(LOCK)98,98,105
98 IF(LINE-1)99,99,102
99 IF(KOUNT-5)100,100,101
100 WRITE(IOUT,118)
GO TO 104
101 WRITE(IOUT,118)(IBUFFR(LEAST),LEAST=6,KOUNT)
GO TO 104
102 IF(KOUNT)112,112,103
103 WRITE(IOUT,119)MANY,(IBUFFR(LEAST),LEAST=1,KOUNT)
MANY=MANY+1
IF(MANY-9)105,105,104
104 MANY=1
105 IF(INDEX-NEEDED)106,106,110
106 IF(LINE-MAXLIN)108,107,107
107 IF(INDEX-LAST)112,112,82
108 LINE=LINE+1
KOUNT=0
IF(IFORMT)109,83,109
109 LIMIT=6+LENGTH+MOST
GO TO 84
110 IF(LOCK)113,113,17
C
C RETURN TO CALLING PROGRAM
111 WRITE(IOUT,114)JSTORE
IERR=2
GO TO 113
112 WRITE(IOUT,115)MAXCLM
IERR=1
113 RETURN
114 FORMAT(19H DASAVE - MORE THAN,1I4,11H STATEMENTS)
115 FORMAT(21H DASAVE - FIELD WIDTH,1I3,10H TOO SHORT)
116 FORMAT(6X,10HDIMENSION ,66A1)
117 FORMAT(6X,12HEQUIVALENCE ,66A1)
118 FORMAT(6X,5HDATA ,61A1)
119 FORMAT(5X,1I1,66A1)
120 FORMAT(1HC,5X,10HDIMENSION ,66A1)
121 FORMAT(1HC,4X,1I1,66A1)
C985104445547
END
SUBROUTINE DABOTH(INDEX,IFORMT,NAME,KNTLTR,NUMBER,
1IVALUE,LETTER,KOUNT,MAX)
C
C ROUTINE TO CREATE ARRAY NAMES WITH DIMENSION NUMBERS
C
C DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C
C INDEX = NEGATIVE OR 0, A SYMBOL CONTAINING AT LEAST
C -INDEX CHARACTERS IS PRODUCED IN LETTER
C ARRAY BY COPYING LOCATIONS 1 THRU KNTLTR OF
C NAME ARRAY AND INSERTING RIGHT BLANKS IF
C NECESSARY.
C = 1 OR GREATER, IS LENGTH OF SYMBOL TO BE
C OUTPUT IN LETTER ARRAY BY RIGHT JUSTIFYING
C DIGITS OF NUMBER AND MAKING LEFT CHARACTERS
C BE THOSE IN NAME ARRAY OR THE LETTER ZERO.
C IFORMT = -1, NO NUMBER IS GIVEN ENCLOSED IN
C PARENTHESES.
C = 0, IVALUE IS REPRESENTED ENCLOSED IN
C PARENTHESES TO RIGHT OF SYMBOL.
C = 1 OR GREATER, IVALUE IS REPRESENTED RIGHT
C JUSTIFIED IN A FIELD OF IFORMT LOCATIONS AND
C ENCLOSED IN PARENTHESES TO RIGHT OF SYMBOL.
C NAME = ALPHAMERIC ARRAY READ BY MULTIPLE OF A1
C FORMAT AND CONTAINING LETTERS OF SYMBOL.
C KNTLTR = NUMBER OF SYMBOL CHARACTERS IN NAME ARRAY.
C NUMBER = NUMBER TO BECOME PART OF SYMBOL IF INDEX=1
C OR GREATER.
C IVALUE = NUMBER TO FOLLOW SYMBOL IF IFORMT=1 OR
C GREATER.
C LETTER = ARRAY TO RECEIVE SYMBOL.
C KOUNT = NUMBER OF LOCATIONS OF LETTER ARRAY IN USE.
C MAX = MAXIMUM NUMBER OF LOCATIONS IN LETTER WHICH
C CAN BE FILLED.
C
DIMENSION LETTER(MAX),NAME(KNTLTR)
DATA IBLANK,IZERO,ILPR,IRPR/1H ,1H0,1H(,1H)/
C
C COPY SYMBOL WITHOUT RIGHT JUSTIFIED NUMBER
INIT=KOUNT
IF(INDEX)1,1,8
1 IF(KOUNT+KNTLTR-MAX)2,2,17
2 KOLUMN=0
3 IF(KOLUMN-KNTLTR)4,5,5
4 KOUNT=KOUNT+1
KOLUMN=KOLUMN+1
LETTER(KOUNT)=NAME(KOLUMN)
GO TO 3
5 IF(KOUNT-INDEX-KNTLTR-MAX)7,7,15
6 KOUNT=KOUNT+1
KOLUMN=KOLUMN+1
LETTER(KOUNT)=IBLANK
7 IF(KOLUMN+INDEX)6,13,13
C
C COPY SYMBOL WITH RIGHT JUSTIFIED NUMBER
8 KOLUMN=KOUNT+INDEX
IF(KOLUMN-MAX)9,9,17
9 LONG=KOUNT
CALL DANUMB(1,NUMBER,10,LETTER,KOUNT,KOLUMN,MAX)
KOLUMN=0
10 LONG=LONG+1
IF(LETTER(LONG).NE.IBLANK)GO TO 13
IF(KOLUMN-KNTLTR)12,11,11
11 LETTER(LONG)=IZERO
GO TO 10
12 KOLUMN=KOLUMN+1
LETTER(LONG)=NAME(KOLUMN)
GO TO 10
C
C INSERT NUMBER ENCLOSED IN PARENTHESES
13 IF(IFORMT)17,14,14
14 KOLUMN=KOUNT+IFORMT+1
CALL DANUMB(IFORMT,IVALUE,10,LETTER,KOUNT,KOLUMN,
1MAX-1)
IF(KOUNT-KOLUMN)15,16,16
15 KOUNT=INIT
GO TO 17
16 KOLUMN=KOLUMN-IFORMT
LETTER(KOLUMN)=ILPR
KOUNT=KOUNT+1
LETTER(KOUNT)=IRPR
C
C RETURN TO CALLING PROGRAM
17 RETURN
C353052349589
END
SUBROUTINE DANUMB(KONTRL,NUMBER,IRADIX,LETTER,
1KOUNT,LFTCOL,MAX)
C RENBR(/REPRESENT INTEGER VALUE)
C
C DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C JAN 2, 1970
C
C KONTRL = 0 LEFT JUSTIFIES AT LFTCOL OR AT KOUNT+1
C IF KOUNT IS GREATER THAN LFTCOL.
C KONTRL = 1 RIGHT JUSTIFIES AT LFTCOL.
C NUMBER = NUMBER TO BE INSERTED.
C IRADIX = BASE TO WHICH NUMBER WILL BE EXPRESSED.
C LETTER = ALPHAMERIC BUFFER ARRAY TO BE CODED.
C KOUNT = NUMBER OF LOCATIONS IN LETTER IN USE.
C LFTCOL = LOCATION OF NEW NUMBER.
C LFTCOL = CHARACTERS LEFT OF NUMBER IF KONTRL = 0.
C LFTCOL = POSITION OF RIGHT DIGIT IF KONTRL = 1.
C MAX = DIMENSION OF LETTER ARRAY.
C
C THE ONLY ARGUMENTS RETURNED CHANGED ARE THE
C LETTER ARRAY WHICH IS RETURNED WITH THE NEW NUMBER
C REPRESENTED AT ITS RIGHT END, AND KOUNT WHICH IS
C RETURNED CONTAINING THE NUMBER OF CHARACTERS IN THE
C LETTER ARRAY.
C
DIMENSION LETTER(MAX),IDGT(10)
DATA IDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA IBLANK,IMINUS/1H ,1H-/
C
C EVEN UP RIGHT MARGIN IF NEEDED
KSAVE=KOUNT
KOLLFT=LFTCOL
IF(KOLLFT-MAX)1,1,26
1 IF(KOUNT-MAX)2,26,26
2 IF(KONTRL)26,4,3
3 IF(KOUNT-KOLLFT)6,26,26
4 IF(KOUNT-KOLLFT)5,6,5
5 KOUNT=KOUNT+1
LETTER(KOUNT)=IBLANK
IF(KOUNT-KOLLFT)5,6,6
C
C SET INITIAL POINTERS
6 KNT=0
KEEP=KOUNT+1
IF(NUMBER)8,7,7
C
C POSITIVE NUMBER
7 NUMB=NUMBER
IF(KOUNT-MAX)12,25,25
C
C NEGATIVE NUMBER
8 IF(KEEP-MAX)9,25,25
9 KOUNT=KOUNT+1
LETTER(KOUNT)=IMINUS
C ABSOLUTE VALUE OF A NEGATIVE NUMBER IS DECREMENTED
C BY ONE SINCE, ON A TWO'S COMPLEMENT COMPUTER, THE
C ABSOLUTE VALUE OF THE LARGEST NEGATIVE NUMBER (SIGN
C BIT ON AND ALL OTHER BITS OFF) CANNOT BE REPRESENTED.
C THIS NUMBER CAN BE EASILY OBTAINED IF SIGN BIT IS
C USED FOR STORING INFORMATION IN SETS.
INDEX=NUMBER+1
NUMB=-INDEX
GO TO 12
C
C INSERT DIGITS OF NUMBER
10 INDEX=KOUNT+KNT
11 LETTER(INDEX+1)=LETTER(INDEX)
INDEX=INDEX-1
IF(INDEX-KOUNT)26,12,11
12 KNT=KNT+1
INDEX=NUMB
NUMB=NUMB/IRADIX
INDEX=INDEX-IRADIX*NUMB
IF(NUMBER)13,16,16
13 IF(KNT-1)26,14,16
14 INDEX=INDEX+1
IF(INDEX-IRADIX)16,15,26
15 INDEX=0
NUMB=NUMB+1
16 LETTER(KOUNT+1)=IDGT(INDEX+1)
IF(NUMB)26,18,17
17 IF(KNT+KOUNT-MAX)10,25,25
18 KOUNT=KOUNT+KNT
C
C EVEN UP LEFT MARGIN IF NEEDED
IF(KONTRL)26,26,19
19 IF(KOUNT-KOLLFT)20,26,23
C
C ADD BLANKS TO LEFT MARGIN
20 DO 21 KNT=KEEP,KOUNT
INDEX=KOLLFT-KNT+KEEP
NUMB=KOUNT-KNT+KEEP
21 LETTER(INDEX)=LETTER(NUMB)
INDEX=KOLLFT-KOUNT+KEEP-1
DO 22 KNT=KEEP,INDEX
22 LETTER(KNT)=IBLANK
KOUNT=KOLLFT
GO TO 26
C
C REMOVE EXCESS DIGITS FROM LEFT MARGIN
23 DO 24 KNT=KEEP,KOLLFT
INDEX=KNT+KOUNT-KOLLFT
24 LETTER(KNT)=LETTER(INDEX)
KOUNT=KOLLFT
GO TO 26
25 KOUNT=KSAVE
26 RETURN
C KEEP = SUBSCRIPT AT WHICH INSERT 1ST CHARACTER.
C KNT = NUMBER OF DIGITS ADDED TO ARRAY.
C KSAVE = NUMBER OF CHARACTERS IN ORIGINAL ARRAY.
C NUMB = ABSOLUTE VALUE OF UNUSED PART OF NUMBER.
C423899686864
END
SUBROUTINE DAMOVE(JSTIFY,IFILL ,LFTCOL,LTREND,IERR ,
1 IBUFFR,KOUNT )
C RENBR(/JUSTIFY ITEM IN FIELD OF SPACES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C JSTIFY = -1, DO NOT MOVE ITEM IN IBUFFR(LFTCOL+1)
C THROUGH IBUFFR(KOUNT).
C = 0, THE ITEM IN IBUFFR(LFTCOL+1) THROUGH
C IBUFFR(KOUNT) IS TO BE CENTERED IN THE FIELD
C STARTING AT IBUFFR(LFTCOL+1) AND EXTENDING
C THROUGH IBUFFR(LTREND). THE IBUFFR ARRAY
C LOCATIONS TO THE LEFT OF THE ITEM ARE THEN
C FILLED WITH SPACES.
C = 1, THE ITEM IN IBUFFR(LFTCOL+1) THROUGH
C IBUFFR(KOUNT) IS TO BE MOVED TO THE RIGHT SO
C THAT THE CHARACTER INPUT IN IBUFFR(KOUNT) IS
C PLACED INTO IBUFFR(LTREND). THE IBUFFR
C ARRAY LOCATIONS TO THE LEFT OF THE ITEM ARE
C THEN FILLED WITH SPACES.
C IFILL = 0, DO NOT FILL PORTION OF FIELD RIGHT OF
C ITEM WITH SPACES. THE VALUE OF IFILL HAS NO
C EFFECT ON THE CHARACTERS OF THE ITEM ITSELF.
C KOUNT WILL BE RETURNED POINTING TO THE
C RIGHTMOST CHARACTER OF THE ITEM.
C = 1, FILL THE FIELD RIGHT OF THE ITEM AND
C EXTENDING THROUGH IBUFFR(LTREND) WITH
C SPACES. KOUNT WILL BE RETURNED RETURNED
C POINTING TO IBUFFR(LTREND).
C LFTCOL = SUBSCRIPT OF THE IBUFFR ARRAY ENTRY TO THE
C IMMEDIATE LEFT OF THE FIRST CHARACTER IN THE
C ITEM.
C LTREND = SUBSCRIPT OF THE IBUFFR ARRAY ENTRY WHICH
C FORMS THE RIGHT END OF THE FIELD WHICH IS TO
C CONTAIN THE ITEM. IF JSTIFY=1, THEN THE
C RIGHTMOST CHARACTER OF THE ITEM WILL BE
C PLACED INTO IBUFFR(LTREND).
C IERR = -1, FILL THE FIELD STARTING WITH
C IBUFFR(LFTCOL+1) AND EXTENDING THROUGH
C IBUFFR(LTREND) WITH ASTERISKS AND RETURN
C KOUNT POINTING TO IBUFFR(LTREND).
C = ZERO OR GREATER, MOVE THE ITEM INPUT IN
C IBUFFR(LFTCOL+1) THROUGH IBUFFR(KOUNT) INTO
C THE POSITION INDICATED BY JSTIFY.
C IBUFFR = INPUT CONTAINING THE ITEM TO BE MOVED IN
C LOCATIONS IBUFFR(LFTCOL+1) THROUGH
C IBUFFR(KOUNT). THIS ITEM IS POSITIONED IN
C THE FIELD STARTING AT IBUFFR(LFTCOL+1) AND
C EXTENDING THROUGH IBUFFR(LTREND) AS DIRECTED
C BY JSTIFY.
C KOUNT = INPUT CONTAINING THE SUBSCRIPT IN THE IBUFFR
C ARRAY OF THE RIGHTMOST CHARACTER OF THE ITEM
C TO BE POSITIONED AS DIRECTED BY JSTIFY.
C = RETURNED POINTING TO THE RIGHTMOST CHARACTER
C DEFINED IN THE FIELD AFTER THE ITEM HAS BEEN
C MOVED, AND SPACES ADDED IF REQUESTED BY
C IFILL.
C
DIMENSION IBUFFR(LTREND)
DATA ISTAR,IBLANK/1H*,1H /
C
C DETERMINE HOW FAR TO SHIFT ITEM TO RIGHT
IF(IERR.LT.0)GO TO 5
IF(KOUNT.LE.LFTCOL)GO TO 3
IF(JSTIFY.LT.0)GO TO 3
J=LTREND-KOUNT
IF(JSTIFY.EQ.0)J=J/2
IF(J.LE.0)GO TO 3
I=KOUNT
J=J+KOUNT
KOUNT=J
C
C SHIFT ITEM TO RIGHT IF CENTERING OR RIGHT JUSTIFYING
1 IF(I.LE.LFTCOL)GO TO 2
IBUFFR(J)=IBUFFR(I)
J=J-1
I=I-1
GO TO 1
C
C INSERT BLANKS TO LEFT OF RIGHT SHIFTED ITEM
2 IF(J.LE.LFTCOL)GO TO 3
IBUFFR(J)=IBLANK
J=J-1
GO TO 2
C
C FILL OUT REST OF FIELD WITH BLANKS
3 IF(IFILL.LE.0)GO TO 7
4 IF(KOUNT.GE.LTREND)GO TO 7
KOUNT=KOUNT+1
IBUFFR(KOUNT)=IBLANK
GO TO 4
C
C FILL FIELD WITH ASTERISKS IF ITEM CANNOT FIT
5 KOUNT=LFTCOL
6 IF(KOUNT.GE.LTREND)GO TO 7
KOUNT=KOUNT+1
IBUFFR(KOUNT)=ISTAR
GO TO 6
C
C RETURN TO CALLING PROGRAM
7 RETURN
C165672143471
END
SUBROUTINE PLTCUT(IPLCUT,IX,IY,JX,JY,MINX,MINY,
1MAXX,MAXY)
C RENBR(/CLIP PORTION OF LINE OUTSIDE WINDOW)
C
C DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERSITY
C
C ROUTINE BASED ON GENPLT-II PLOTTER COUPLING
C ROUTINES PUBLISHED IN VOLUME 3 OF COMPUTER
C PROGRAMS FOR CHEMISTRY
C
C IPLCUT = RETURNED AS 0 IF LINE DOES NOT PASS THRU
C WINDOW.
C = RETURNED AS 1 IF LINE PASSES THRU WINDOW
C
C IX = HORIZONTAL COORDINATE OF START OF LINE
C IY = VERTICAL COORDINATE OF START OF LINE
C JX = HORIZONTAL COORDINATE OF END OF LINE
C JY = VERTICAL COORDINATE OF END OF LINE
C MINX = HORIZONTAL COORDINATE OF LOWER LEFT
C CORNER OF WINDOW
C MINY = VERTICAL COORDINATE OF LOWER LEFT CORNER
C OF WINDOW
C MAXX = HORIZONTAL COORDINATE OF UPPER RIGHT
C CORNER OF WINDOW
C MAXY = VERTICAL COORDINATE OF UPPER RIGHT CORNER
C OF WINDOW
C
C ROUTINE RETURNS JX, JY, IX AND IY CHANGED IF
C WINDOWING IS NECESSARY
C
C TEST IF LINE NEEDS TO BE WINDOWED
IF(IX-MINX)8,1,1
1 IF(IX-MAXX)2,2,8
2 IF(JX-MINX)8,3,3
3 IF(JX-MAXX)4,4,8
4 IF(IY-MINY)8,5,5
5 IF(IY-MAXY)6,6,8
6 IF(JY-MINY)8,7,7
7 IF(JY-MAXY)38,38,8
8 IIX=IX
IIY=IY
IJX=JX
IJY=JY
MOVEX=JX-IX
MOVEY=JY-IY
C
C INTERSECTION WITH LEFT AND RIGHT BORDERS
IF(IIX-MINX)9,10,10
9 IIX=MINX
IF(IJX-MINX)36,14,14
10 IF(IIX-MAXX)12,12,11
11 IIX=MAXX
IF(IJX-MAXX)12,12,36
12 IF(IJX-MINX)13,14,14
13 IJX=MINX
GO TO 16
14 IF(IJX-MAXX)16,16,15
15 IJX=MAXX
16 IF(MOVEX)17,18,17
17 IIY=IY+((MOVEY*(IIX-IX))/MOVEX)
IJY=JY-((MOVEY*(JX-IJX))/MOVEX)
C
C INTERSECTION WITH LOWER AND UPPER BORDERS
18 IF(IIY-MINY)19,20,20
19 IIY=MINY
IF(IJY-MINY)36,24,24
20 IF(IIY-MAXY)22,22,21
21 IIY=MAXY
IF(IJY-MAXY)22,22,36
22 IF(IJY-MINY)23,24,24
23 IJY=MINY
GO TO 26
24 IF(IJY-MAXY)26,26,25
25 IJY=MAXY
26 IF(MOVEY)27,28,27
27 IIX=IX+((MOVEX*(IIY-IY))/MOVEY)
IJX=JX-((MOVEX*(JY-IJY))/MOVEY)
28 IF(IIX-MINX)29,30,30
29 IIX=MINX
30 IF(IIX-MAXX)32,32,31
31 IIX=MAXX
32 IF(IJX-MINX)33,34,34
33 IJX=MINX
34 IF(IJX-MAXX)37,37,35
35 IJX=MAXX
GO TO 37
C
C IPLCUT=0 IF LINE NOT WITHIN WINDOW
36 IPLCUT=0
GO TO 39
C
C IPLCUT=1 IF LINE IS WITHIN WINDOW
37 JX=IJX
JY=IJY
IX=IIX
IY=IIY
38 IPLCUT=1
C
C RETURN TO CALLING PROGRAM
39 RETURN
C372613660265
END