-
Notifications
You must be signed in to change notification settings - Fork 0
/
charsize.f
184 lines (180 loc) · 5.33 KB
/
charsize.f
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
c*********************************************************************
c Set character width and height in NORMAL units. 0 resets.
subroutine charsize(wd, ht)
real wd,ht
include 'plotcom.h'
pchrswdth=chrswdth
pchrshght=chrshght
chrswdth=wd
if(abs(wd) .le. 0.)chrswdth=chrsdef
chrshght=ht
if(abs(ht) .le. 0.)chrshght=chrsdef
return
end
c*********************************************************************
c Set default charsize. This is value used to reset charsize.
subroutine dcharsize(sz)
include 'plotcom.h'
chrsdef=sz
chrswdth=chrsdef
chrshght=chrsdef
end
c*********************************************************************
c Restore immediate prior charsize
subroutine pcharsize()
include 'plotcom.h'
write(*,*)chrswdth,pchrswdth,chrshght,pchrshght
chrswdth=pchrswdth
chrshght=pchrshght
end
c*********************************************************************
c Set character angle in degrees.
subroutine charangl(theta)
real theta,tr
include 'plotcom.h'
tr=3.14159*theta/180.
pchrscos=chrscos
pchrssin=chrssin
chrscos=cos(tr)
chrssin=sin(tr)
end
c*********************************************************************
c Restore immediate prior charsize
subroutine pcharangl()
include 'plotcom.h'
chrscos=pchrscos
chrssin=pchrssin
end
c*********************************************************************
c Get character angle in degrees.
subroutine getcangl(theta)
real theta
include 'plotcom.h'
theta=atan2(chrssin,chrscos)
theta=theta*180./3.14159
end
c*************************************************************************
c********************************************************************
integer function istlen(str,ilmax)
c Return the active length of string str, length ilmax, ignoring
c blanks on the end.
integer ilmax
character*(*) str
do 1 istlen=ilmax,1,-1
if(str(istlen:istlen) .ne. ' ') return
1 continue
end
c**************************************************************************
c Convert spaces at the end of string to 0 so it is a C-string termination.
subroutine termchar(string)
character*(*) string
do 1 i=len(string),1,-1
if(ichar(string(i:i)) .ne. ichar(' ')) goto 2
string(i:i)=char(0)
1 continue
2 continue
end
c********************************************************************
integer function istpos(str,ilmin,ilmax,ch)
c Return the first position of character ch in string str,
c searching from position ilmin to ilmax.
integer ilmin,ilmax
character*(*) str
character*1 ch
if(ilmax.gt.ilmin) then
do 1 istpos=ilmin,ilmax
if(str(istpos:istpos) .eq. ch) return
1 continue
else
do 2 istpos=ilmin,ilmax,-1
if(str(istpos:istpos) .eq. ch) return
2 continue
endif
istpos=0
end
c******************************//**************************************
c Subroutine for decently formatted floating write.
c Returns total width of string.
subroutine fwrite(x,width,point,string)
real x,xx
integer width,point,iax,neg,ibx,i
character*(*) string
c character*8 sformat
character*1 st(20)
c Use g format if too long.
xx=x*10**point
if(abs(xx).gt.1.e9)then
write(string,'(g13.6)')x
width=12
return
endif
c Else standard minimum f.point
iax=int(abs(xx))
if(abs(xx)-iax.gt.0.5)iax=iax+1
width=0
do 2 i=1,point
width=width+1
ibx=iax/10
st(width)=char(48+iax-10*ibx)
iax=ibx
2 continue
width=width+1
st(width)='.'
1 width=width+1
ibx=iax/10
st(width)=char(48+iax-10*ibx)
iax=ibx
if(iax .ne. 0) goto 1
neg=0
if(x.lt.0) then
string(1:1)='-'
neg=1
width=width+1
endif
do 3 i=1+neg,width
string(i:i)=st(width-i+1)
3 continue
c Put a null at the end so we can treat as a C-string.
string(width+1:width+1)=char(0)
return
end
c********************************************************************
c Subroutine for decently formatted integer write.
c Returns total width of string.
c Avoid write statements. Version 4. Nearly 4 timesfaster than version 3.
subroutine iwrite(i,width,string)
integer i,ai,aj
integer width,nc,neg
character*(*) string
character*(1) st(20)
ai=abs(i)
nc=0
1 nc=nc+1
aj=ai/10
st(nc)=char(48+ai-10*aj)
ai=aj
if(ai .ne. 0) goto 1
width=nc
neg=0
if(i .lt. 0) then
neg=1
string(1:1)='-'
endif
do 2 nc=1,width
string(nc+neg:nc+neg)=st(width+1-nc)
2 continue
if(neg .eq.1) width=width+1
c Put a null at the end so we can treat as a C-string.
string(width+1:width+1)=char(0)
return
end
c******************************************************************
c Obtain the length of a string omitting trailing blanks.
function lentrim(string)
character*(*) string
do i=len(string),1,-1
if(string(i:i).ne.' ') goto 101
enddo
i=0
101 lentrim=i
end