Subroutine Lowerc(Line,Nchars,Linlow) c *********************************************************************** c * * c * Subroutine Lowerc - To change the input character * c * string into lowercase letters. * c * * c * Programmed by Steven C. Fisher, DNTSRDC Code 1522 * c * * c *********************************************************************** c Character*255 Line,Linlow,Chr*1 Byte Byt Equivalence (Byt,Chr) c Do 10 I=1,Nchars If (Line(I:I) .GE. 'A' .AND. Line(I:I) .LE. 'Z') Then Chr = Line(I:I) Byt = Byt + 32 Linlow(I:I) = Chr Else Linlow(I:I) = Line(I:I) End If 10 Continue Return End Subroutine Getlen(String,Nchars,Alen) c Character*255 String Common/Size/Alenth(16,126),Chrsiz,Ileft,Iright,Idefft Common/Font/Iuse,Ifont,Ibold,Iprop,Italic,Lasfnt c Alen = 0 If (Nchars .EQ. 0) Return Kflag = 0 c Do 10 I=1,Nchars c Kflag = Max0(0,Kflag-1) c c Look for escape sequences to ignore in computing c length, and also check for font changes. c If (String(I:I) .EQ. '^' .OR. String(I:I) .EQ. '\') Then Kflag = 2 If (I .GT. 1) Then If (String(I-1:I-1) .EQ. '_') Kflag = 0 End If If (Kflag .NE. 0 .AND. Nchars .GT. I) Then Call Setfon(String(I:I+1)) End If End If c If (String(I:I) .EQ. '`' .OR. String(I:I) .EQ. '~' .OR. $ String(I:I) .EQ. '&') Then Kflag = 1 If (I .GT. 1) Then If (String(I-1:I-1) .EQ. '_') Kflag = 0 End If End If c If (Kflag .EQ. 0) Alen = Alen + $ Alenth(Iuse,Ichar(String(I:I))) 10 Continue Return End Subroutine Center(String,Nchars) c *********************************************************************** c * * Character*255 String Common/Size/Alenth(16,126),Chrsiz,Ileft,Iright,Idefft Common/Font/Iuse,Ifont,Ibold,Iprop,Italic,Lasfnt Common/Marg/Ileftm,Irigtm,Ihypfl,Layout, $ Maroff,Justfl c c Find the start of the text; c Iflag = 0 K = 2 3 Continue K = K + 1 If (String(K:K) .GE. '0' .AND. String(K:K) .LE. '9') Iflag=1 If (String(K:K) .NE. ' ' .AND. String(K:K) .NE. ';') Go To 3 c If (Iflag .EQ. 1) Then String(K:K) = ',' Call Readr(String,K,1,Icntr) Centrl = Icntr If (String(3:3) .EQ. '+') Then Centrl = (Ileftm + Irigtm)/2.0 + Centrl Else If (String(3:3) .EQ. '-') Then Centrl = (Ileftm + Irigtm)/2.0 - Centrl End If Else Centrl = (Ileftm + Irigtm)/2.0 End If K = K + 1 c c Get the string length c Call Getlen(String(K:K),Nchars-K+1,Alen) c Ipos = Centrl * Chrsiz - Alen/2.0 + Maroff c Lpos = 4 If (Ipos .LT. 1000) Lpos = 3 If (Ifont .NE. 3) Then Write(16,100) Ipos,Lasfnt,String(K:Nchars) 100 Format('.c;^7',I,'_`^',I1,A,'^3') Else Write(16,150) Ipos,Lasfnt,String(K:Nchars) 150 Format('.c;^7',I,'_`^',I1,A) End If c Lasfnt = Ifont Return End Subroutine Setfon(String) Character*255 String Common/Font/Iuse,Ifont,Ibold,Iprop,Italic,Lasfnt c If (String(1:1) .EQ. '^' .AND. (String(2:2) .GE. '1' .AND. $ String(2:2) .LE. '6')) Ifont = Ichar(String(2:2)) - 48 If (String(1:2) .EQ. '^~') Ibold = 1 If (String(1:2) .EQ. '\~') Ibold = 0 If (String(1:2) .EQ. '^}') Iprop = 0 If (String(1:2) .EQ. '\}') Iprop = 1 If (String(1:2) .EQ. '^{') Italic = 1 If (String(1:2) .EQ. '\{') Italic = 0 c If (Ifont .EQ. 1) Then Iuse = 1 Else If (Ifont .EQ. 2) Then Iuse = 2 If (Iprop .EQ. 0) Iuse = 7 Else If (Ifont .EQ. 3) Then Iuse = 3 If (Iprop .EQ. 0) Then Iuse = 8 Else If (Italic .EQ. 1 .AND. Ibold .EQ. 1) Then Iuse = 9 Else If (Italic .EQ. 1) Then Iuse = 10 Else If (Ibold .EQ. 1) Then Iuse = 11 End If Else If (Ifont .EQ. 4) Then Iuse = 4 If (Iprop .EQ. 0) Then Iuse = 12 Else If (Ibold .EQ. 1) Then Iuse = 13 End If Else If (Ifont .EQ. 5) Then Iuse = 5 If (Iprop .EQ. 0) Iuse = 14 Else If (Ifont .EQ. 6) Then Iuse = 6 If (Iprop .EQ. 0) Then Iuse = 15 Else If (Ibold .EQ. 1) Then Iuse = 16 End If End If If (String(1:2) .EQ. '^`') Iuse = 1 Return End Subroutine Column(String,Nchars,Ipos,Npos,Chr) c Character*255 String Character Chr,Line*150 Byte Lineb(1) Equivalence (Lineb,Line) Dimension Ipos(1) Common/Size/Alenth(16,126),Chrsiz,Ileft,Iright,Idefft Common/Marg/Ileftm,Irigtm,Ihypfl,Layout, $ Maroff,Justfl c Icount = 0 Lchar = 1 Do 30 I=1,Nchars If (String(I:I) .EQ. Chr) Then Icount = Icount + 1 If (I .LT. Nchars .AND. String(I+1:I+1) .EQ. Chr) Go To 30 Nstep = Ipos(Icount) * Chrsiz + Maroff L = 1 If (Nstep .GE. 10) L = 2 If (Nstep .GE. 100) L = 3 If (Nstep .GE. 1000) L = 4 Encode(Lchar+L+3,'(2H^7,I,2H_`)',Lineb(Lchar)) Nstep c Write(Line(Lchar:Lchar+L+3),'(2H^7,I,2H_`)') Nstep Lchar = Lchar+L+4 Else Line(Lchar:Lchar) = String(I:I) Lchar = Lchar + 1 End If 30 Continue c Do 50 I=1,Lchar-1 String(I:I) = Line(I:I) 50 Continue Nchars = Lchar - 1 c Return End Subroutine Strtcl(Line,Nchars,Ipos,Npos,Chr) c *********************************************************************** c * * c * * c *********************************************************************** c Character*255 Line Character Chr*1 Dimension Ipos(1) c Line(Nchars+1:Nchars+31) = ',0,0,0,0,0,0,0,0,0,0,0,0,0,0,0' Do 10 I=4,Nchars If (Line(I:I) .EQ. '"' .OR. (Line(I:I) .GE. '0' .AND. $ Line(I:I) .LE. '9')) Then If (Line(I:I) .EQ. '"') Then Chr = Line(I+1:I+1) K = I + 1 Else Chr = '|' K = I - 1 End If c c Find the first column number; c 12 Continue K = K + 1 If (Line(K:K) .LT. '0' .OR. Line(K:K) .GT. '9') Go To 12 c Call Readr(Line(K:K),Nchars-K+32,15,Ipos) c Read(Line(K:Nchars+31),*) (Ipos(J),J=1,15) Do 20 Npos=0,14 If (Ipos(Npos+1) .EQ. 0) Return 20 Continue End If 10 Continue Return End Subroutine Disp(Line,Nchars) c *********************************************************************** c * * c * Subroutine Disp - To modify the .display number and * c * .display subtitle runoff commands to include certain * c * necessary escape sequences due to proportional spacing. * c * * c * Programmed by Steven C. Fisher, DTRC Code 1522 * c * * c *********************************************************************** c Character*255 Line Character Endpag*7,Edge*9,Margin*9,Linlow*80 Character*60 Dissub,Dissbt,Distit, $ Disnum,Titles*80,Subtit*80 Common/Displn/Dissub,Distit,Dissbt,Disnum,Titles,Subtit Common/Displc/Nsub,Ltitle,Lstitl,Lennum,Lentit,Lensub Common/Marg/Ileftm,Irigtm,Ihypfl,Layout, $ Maroff,Justfl Common/Size/Alenth(16,126),Chrsiz,Ileft,Iright,Idefft c c Move to the second word of the command c Call Lowerc(Line,Nchars,Linlow) I = 2 3 Continue I = I + 1 If (Line(I:I) .NE. ' ') Go To 3 c c Count the # of quotes c Kflag = 0 Do 5 J=1,Nchars If (Line(J:J) .EQ. '"') Kflag = Kflag + 1 5 Continue c See if it is Display Number or Display Subtitle; c If (Linlow(I+1:I+3) .EQ. 'sub') Then Iflag = 1 If (Kflag .EQ. 2) Then Line(Nchars+1:Nchars+3) = ',""' Nchars = Nchars + 3 End If Else If (Linlow(I+1:I+3) .EQ. 'num') Then Iflag = 2 If (Kflag .EQ. 0) Then Line(Nchars+1:Nchars+3) = ',""' Nchars = Nchars + 3 End If c c Find the start of the number instruction c Do 7 J=I+3,Nchars If (Line(J-1:J-1) .EQ. ' ' .AND. Line(J:J) .NE. ' ') $ Go To 8 7 Continue 8 Continue c If (Kflag .EQ. 2 .AND. Line(J:J) .EQ. '"') Then Line(Nchars+1:Nchars+3) = ',""' Nchars = Nchars + 3 Else If (Line(J:J) .NE. '"') Then Line(J+3:Nchars+3) = Line(J:Nchars) Line(J:J+2) = '"",' Nchars = Nchars + 3 End If Else If (Linlow(I+1:I+3) .EQ. 'tit') Then Iflag = 3 If (Kflag .EQ. 2) Then Line(Nchars+1:Nchars+3) = ',""' Nchars = Nchars + 3 End If Else Write(16,100) Line(1:Nchars) 100 Format(A) Return End If c c For alternating headers, use uniform spacing c which is set up by the define number command c If (Layout .EQ. 2 .OR. Layout .EQ. Layout .EQ. 9 .OR. $ Layout .EQ. 11) Then Endpag = '^7?27l"' Le = 4 Nend = 7 Else Endpag = '"' Le = 0 Nend = 1 End If c c Modify the display number to ensure c the number is in the right spot despite c proportional spacing c If (Layout .EQ. 1 .OR. Layout .EQ. 4 .OR. Layout .EQ. 5 .OR. $ Layout .EQ. 9 .OR. Layout .EQ. 16) Then Ipos = (Irigtm-3) * (Chrsiz - $ Alenth(Idefft,32)) + (5.0 + Le) Else If (Layout .EQ. 2 .OR. Layout .EQ. 3 .OR. Layout .EQ. 4 $ .OR. Layout .EQ. 14) Then Ipos = (Irigtm+Ileftm)/2.0 * $ (Chrsiz-Alenth(Idefft,32)) + (2.5 + Le) * $ Chrsiz Else Ipos = Ileftm*(Chrsiz-Alenth(Idefft,32))+1 End If c c Find the position of the first quote c I = I - 1 9 Continue I = I + 1 If (Line(I:I) .NE. '"') Go To 9 c K = 1 Do 10 J = I+1,Nchars If (Line(J:J) .EQ. '"') K = K + 1 10 Continue c If (Iflag .EQ. 1) Then c c Modify the define subtitle to restart proportional c spacing c If (K .EQ. 4) Then Dissub(1:Nchars-1) = Line(1:Nchars-1) Dissub(Nchars:Nchars+1) = '^Q' Nsub = Nchars + 1 Else Dissub(1:Nchars) = Line(1:Nchars) Dissub(Nchars+1:Nchars+4) = ',"^Q' Nsub = Nchars + 4 End If Write(16,150) Dissub(1:Nsub) 150 Format(A,'"') Dissbt = Line(1:Nchars) Lstitl = Nchars Else If (Iflag .EQ. 2) Then c c Modify the display number command c If (K .EQ. 4) Then Nn = Nchars-I-1 Write(16,200) Line(1:I),Ipos, $ Line(I+1:Nchars-1),Endpag(1:Nend) Else If (Line(Nchars:Nchars) .EQ. '"') Then Nn = 5 Write(16,200) Line(1:I),Ipos,'",D,"',Endpag(1:Nend) Else Nn = Nchars-I Write(16,201) Line(1:I),Ipos, $ Line(I+1:Nchars),',"',Endpag(1:Nend) 201 Format(A,'^7',I'a',A,A2,A) End If End If 200 Format(A,'^7',I'a',A,A) Disnum = Line(1:Nchars) Lennum = Nchars Else c c Display Title; c Write(16,300) Line(1:I),Line(I+1:Nchars) 300 Format(A,A) Distit = Line(1:Nchars) Ltitle = Nchars End If c Return End Subroutine Title(Line,Nchars) c *********************************************************************** c * * c * Subroutine Title - This subroutine adds in escape * c * sequences into the title, first title, and subtitles * c * to position the titles accurately despite proportional * c * spacing problems. * c * * c * Programmed by Steven C. Fisher, DTRC Code 1522 * c * * c *********************************************************************** c Character*255 Line,Cst*80 Byte Bst Equivalence (Bst,Cst) Common/Font/Iuse,Ifont,Ibold,Iprop,Italic,Lasfnt Common/Size/Alenth(16,126),Chrsiz,Ileft,Iright,Idefft Common/Marg/Ileftm,Irigtm,Ihypfl,Layout, $ Maroff,Justfl Character*60 Dissub,Dissbt,Distit, $ Disnum,Titles*80,Subtit*80 Common/Displn/Dissub,Distit,Dissbt,Disnum,Titles,Subtit Common/Displc/Nsub,Ltitle,Lstitl,Lennum,Lentit,Lensub c I = 1 10 Continue I = I + 1 If (Line(I:I) .NE. ';' .AND. Line(I:I) .NE. ' ') Go To 10 c If (Layout .EQ. 1 .OR. Layout .EQ. 5 .OR. Layout .EQ. 6 $ .OR. Layout .EQ. 10 .OR. Layout .GE. 13) Then Iusel = Iuse Ifontl = Ifont Iboldl = Ibold Ipropl = Iprop Italll = Italic Ibold = 0 Iprop = 1 Ifont = 3 Italic = 0 Iuse = 3 Call Getlen(Line(I+1:I+1),Nchars-I,Alen) Iuse = Iusel Ifont = Ifontl Ibold = Iboldl Iprop = Ipropl Italic = Italll c If (Layout .LE. 10) Then Center = Chrsiz * (Ileftm + Irigtm)/2.0 Iposn = Center-Alen/2.0 + Maroff Else Iposn = Chrsiz * Irigtm - Alen * 1.001 + $ Maroff End If Else Iposn = Ileftm * Chrsiz + 1 + Maroff End If c Write(16,100) Line(1:I),Iposn,Ifont,Line(I+1:Nchars) 100 Format(A,'^7',I,'_`^',I1,A,'^3') c If (Line(2:2) .EQ. 's' .OR. Line(2:2) .EQ. 'S') Then Lensub = Nchars+Isize(Iposn) + 8 Encode(Lensub,100,Bst) Line(1:I),Iposn, $ Ifont,Line(I+1:Nchars) Subtit(1:Lensub) = Cst(1:Lensub) c Write(Subtit(1:Lensub),100) Line(1:I),Iposn, c $ Ifont,Line(I+1:Nchars) Else Lentit = Nchars+Isize(Iposn)+8 Encode(Lentit,100,Bst) Line(1:I),Iposn, $ Ifont,Line(I+1:Nchars) Titles(1:Lentit) = Cst(1:Lentit) c Write(Titles(1:Lentit),100) Line(1:I),Iposn, c $ Ifont,Line(I+1:Nchars) End If c Return End Subroutine Space(Line,Nchars,Iflspa) c *********************************************************************** c * * c * Subroutine Space - This routine removes all multiple * c * blanks between words, except after a period, when two * c * blanks are left (if there was only one, another blank is * c * inserted). * c * * c * Programmed by Steven C. Fisher, DTRC Code 1522 * c * * c *********************************************************************** c Character*255 Line Character*150 String,Chr*1 Data Chr/31/ c L = 0 Do 10 I=1,Nchars-1 c c Remove extra spaces between words c If (Line(I:I+1) .EQ. ' ') Then If (I .GT. 1) Then Call Chkper(Line,I-1,Iflag) If (Iflag .EQ. 1) Then L = L + 1 String(L:L) = Line(I:I) End If End If Else L = L + 1 String(L:L) = Line(I:I) End If c c Put two spaces between a period and a word c Call Chkper(Line(I:I),I,Iflag) If (Line(I+1:I+1) .EQ. ' ' .AND. Iflag .EQ. 1) Then If (I+2 .LE. Nchars) Then If (Line(I+2:I+2) .NE. ' ') Then L = L + 1 String(L:L) = ' ' End If End If End If If (Iflspa .EQ. 0 .AND. String(L:L) .EQ. '#') Then If (String(L-1:L-1) .NE. '_') String(L:L) = Chr End If 10 Continue c String(L+1:L+1) = Line(Nchars:Nchars) If (Line(Nchars:Nchars) .NE. ' ') Then Line(1:L+1) = String(1:L+1) Nchars = L+1 Else Line(1:L) = String(1:L) Nchars = L End If c Return End Subroutine Hyword(Line,Nchars,Ihyp,Nhyp) c *********************************************************************** c * * c * Subroutine Hyphen_Word - To hyphenate words. This * c * subroutine uses the Bonner Runoff hyphenation routine * c * to hypheate with. This routine just flags where the * c * Bonner routine says you could hypheate. * c * * c * Programmed by Steven C. Fisher, DTRC Code 1522 * c * * c *********************************************************************** c Character*255 Line,Word*40,Char0*1 Byte Words(40) Dimension Ihyp(1) Equivalence (Words,Word) Data Ith,Idif,Idip,Iop,Ilo,Ihi,Char0/224,15,512,0,2,3,0/ c Nhyp = 1 c c Convert the word to lowercase c Do 10 I=1,Nchars Word(I+1:I+1) = Line(I:I) If (Line(I:I) .GE. 'A' .AND. Line(I:I) .LE. 'Z') Then Words(I+1) = Words(I+1)+32 Else Word(I+1:I+1) = Line(I:I) End If 10 Continue c Word(1:1) = Char0 Min = 2 12 Continue Min = Min + 1 If (Word(Min:Min) .EQ. ' ') Go To 12 c Max = Nchars+1 14 Continue Max = Max - 1 If (Word(Max:Max) .EQ. ' ') Go To 14 c c If the word is too short, return c If (Max-Min .LE. 4) Return c Word(Max+1:40) = Char0 c Isz = -5 Call Hyptst(Words(2),Ilo,Ihi,Iop,Isz,Ith,Idif,Idip) ! Get hyphenations c Do 20 J=Min,Max K = Ichar(Word(J:J)) If (K .GT. 127) Then Ihyp(Nhyp) = J-1 Nhyp = Nhyp + 1 Else If (Word(J:J) .EQ. '-') Then If (Word(J-1:J-1) .GE. 'a' .AND. Word(J+1:J+1) $ .GE. 'a') Then Ihyp(Nhyp) = J - 2 Nhyp = Nhyp + 1 End If End If 20 Continue Ihyp(Nhyp) = Max c Return End Integer Function Isize(Ival) c If (Ival .GE. 0) Then N = 1 If (Ival .GT. 9) N = 2 If (Ival .GT. 99) N = 3 If (Ival .GT. 999) N = 4 If (Ival .GT. 9999) N = 5 Else N = 2 If (Ival .LT. -9) N = 3 If (Ival .LT. -99) N = 4 If (Ival .LT. -999) N = 5 If (Ival .LT. -9999) N = 6 End If c Isize = N Return End Subroutine Sprset(Line,Nchars) Character*255 Line Character*100 Sprtxt,Sprc Byte Sprb(100) Equivalence (Sprc,Sprb) Common/Pgrphc/Sprtxt Common/Pgrphn/Indent,Nspr,Iautop Dimension Itmp(5) c K = 3 Line(Nchars+1:Nchars+13) = ',-99,-99,-99,-99,' Nchars = Nchars + 13 c 10 Continue K = K + 1 If (Line(K:K) .GT. '9' .OR. Line(K:K) .LT. '-') Go To 10 c Call Readr(Line(K:K),Nchars-K+1,4,Itmp) Indent = Itmp(1) Iskip = Itmp(2) Itt = Itmp(3) Itb = Itmp(4) If (Indent .EQ. -99) Indent = 5 If (Iskip .EQ. -99) Iskip = 1 If (Itt .EQ. -99) Itt = 2 If (Itb .EQ. -99) Itb = 2 c Nspr = Isize(Iskip)+Isize(Itt)+Isize(Itb)+19 Encode(Nspr,100,Sprb) Iskip,Itt,Itb Sprtxt = Sprc 100 Format('.skip ',I,' .test text ',I, $ ',',I) Return End Subroutine Margin(Line,Nchars) Character*255 Line Common/Marg/Ileftm,Irigtm,Ihypfl,Layout, $ Maroff,Justfl c K = 3 Line(Nchars+1:Nchars+3) = ',0,' Nchars = Nchars + 3 c 10 Continue K = K + 1 If (Line(K:K) .GT. '9' .OR. Line(K:K) .LT. '0') Go To 10 c Call Readr(Line(K:K),Nchars-K+1,1,Maroff) c Return End Subroutine Wrtout(String,Nchars) Common/Font/Iuse,Ifont,Ibold,Iprop,Italic,Lasfnt c Character*255 String,Char0*1,Char31*1 Data Char0,Char31/0,31/ c If (String(1:1) .EQ. Char0) Then Istart = 2 Else Istart = 1 End If c Do 10 I=Istart,Nchars If (String(I:I) .EQ. Char31) String(I:I) = ' ' 10 Continue c If (Ifont .NE. 3) Then Write(16,100) Lasfnt,String(Istart:Nchars) Else Write(16,200) Lasfnt,String(Istart:Nchars) End If 100 Format('^',I1,A,'^3') 200 Format('^',I1,A) c Return End Subroutine Readr(String,Nchrs,Ntot,Ivec) c Character*132 String,Line Dimension Ivec(1) Byte Lineb(1) Equivalence (Lineb,Line) c Do 10 I=1,Nchrs If (I .EQ. 1) Then Line(1:1) = String(1:1) Else If (String(I:I) .EQ. ' ' .AND. (String(I-1:I-1) .GE. $ '0' .AND. String(I-1:I-1) .LE. '9')) Then Line(I:I) = ',' Else Line(I:I) = String(I:I) End If 10 Continue c If (Line(Nchrs:Nchrs) .EQ. ',' .OR. Line(Nchrs:Nchrs) .EQ. ' ') $ Then Line(Nchrs+1:Nchrs+1) = ' ' Else Line(Nchrs+1:Nchrs+1) = ',' End If c Decode(Nchrs+1,100,Lineb) (Ivec(I),I=1,Ntot) 100 Format(15I10) c Return End Subroutine Setper(String,Nchars) Character*100 String Character*20 Perids Common/Period/Nperid Common/Peridc/Perids c Do 10 I=4,Nchars If (String(I:I) .EQ. '"') Go To 20 10 Continue 20 Continue Nperid = Nchars-I Perids(1:Nperid) = String(I:Nchars-1) Return End Subroutine Chkper(String,Nchars,Iflag) Character*255 String Character*20 Perids Common/Peridc/Perids Common/Period/Nperid c Iflag = 0 If (Nchars .GT. 1) Then If (String(Nchars-1:Nchars-1) .EQ. '_') Return End If c Do 10 I=1,Nperid If (String(Nchars:Nchars) .EQ. Perids(I:I)) Iflag = 1 10 Continue c Return End