Millepede-II V04-17-03
vertpr.f90
Go to the documentation of this file.
1
2! Code converted using TO_F90 by Alan Miller
3! Date: 2012-03-16 Time: 11:09:42
4
27
34
35SUBROUTINE pzvert(n,x)
36 USE mpdef
37
38 IMPLICIT NONE
39 INTEGER(mpi) :: i
40 INTEGER(mpi) :: i1
41 INTEGER(mpi) :: i2
42 INTEGER(mpi) :: ia
43 INTEGER(mpi) :: ij
44 INTEGER(mpi) :: im
45 INTEGER(mpi) :: in
46 INTEGER(mpi) :: iz
47 INTEGER(mpi) :: j
48 INTEGER(mpi) :: jl
49 INTEGER(mpi) :: jm
50 INTEGER(mpi) :: ke
51 INTEGER(mpi) :: kl
52 INTEGER(mpi) :: kn
53 INTEGER(mpi) :: lc
54 INTEGER(mpi) :: m
55 INTEGER(mpi) :: mx
56 REAL(mps) :: fac
57 REAL(mps) :: xm
58 !
59
60 INTEGER(mpi), INTENT(IN) :: n
61 REAL(mps), INTENT(IN) :: x(n)
62 INTEGER(mpi), PARAMETER :: nn=6
63
64 CHARACTER (LEN=66):: px(10)
65 CHARACTER (LEN=66)::ch(10)*1
66 SAVE
67 DATA ch/'0','1','2','3','4','5','6','7','8','9'/
68 ! ...
69 IF(n <= 0) RETURN
70 jm=0
71 DO i=1,10
72 px(i)=' '
73 END DO
74
75 m=min(60,n)
76 jl=0
77 xm=0.0
78 DO j=1,m
79 IF(abs(x(j)) > xm) THEN
80 xm=abs(x(j))
81 mx=j ! index of max
82 END IF
83 IF(x(j) < 0.0) px(1)(6+j:6+j)='-' ! negative columns
84 IF(x(j) /= 0.0) jl=j ! last non-zero column
85 END DO
86 IF(xm == 0.0.OR.jl <= 0) RETURN ! empty array
87 jl=60
88
89 kn=min(6,max(2,iabs(nn)))
90 ke=int(log10(xm*1.0001),mpi)
91 IF(xm < 1.0) ke=ke-1
9222 fac=10.0**(kn-1-ke)
93 ij=nint(fac*xm,mpi)
94 IF(ij >= 10**kn) THEN
95 ke=ke+1
96 GO TO 22
97 END IF
98 ia=2+kn
99
100 DO j=1,jl
101 ij=nint(fac*abs(x(j)),mpi) ! convert to integer
102 im=0
103 IF(ij /= 0) THEN
104 DO i=1,kn
105 IF(ij /= 0) THEN
106 in=mod(ij,10) ! last digit
107 ij=ij/10 ! reduce
108 IF(in /= 0.AND.im == 0) im=ia-i+1
109 px(ia-i)(6+j:6+j)=ch(in+1)
110 END IF
111 END DO
112 END IF
113 jm=max(im,jm)
114 END DO
115
116 kl=ke
11750 IF(ke >= kn) THEN
118 ke=ke-3
119 GO TO 50
120 END IF
12155 IF(ke < 0) THEN
122 ke=ke+3
123 GO TO 55
124 END IF
125
126 in=ke+2 ! exponent
127 iz=kl-ke
128 px(in)(6:6)='.'
129 px(in)(1:1)='E'
130 IF(iz < 0) THEN
131 px(in)(2:2)='-'
132 iz=-iz
133 END IF
134 i1=iz/10 ! insert exponent
135 i2=mod(iz,10)
136 px(in)(3:3)=ch(i1+1)
137 px(in)(4:4)=ch(i2+1)
138 jm=min(2+kn,jm)
139 jm=max(in+1,jm)
140 DO j=1,jl ! '0' for small nonzero values
141 IF(x(j) /= 0.0.AND.px(jm-1)(6+j:6+j) == ' ') px(jm-1)(6+j:6+j)='0'
142 END DO
143 DO i=jm,8
144 px(i)=' '
145 END DO
146
147 DO j=1,((jl+9)/10)*10 ! index line below
148 IF(px(jm-1)(6+j:6+j) == ' ') px(jm-1)(6+j:6+j)='_'
149 IF(mod(j,2) /= 1) THEN
150 i=mod(j,10)+1
151 px(jm+1)(6+j:6+j)=ch(i) ! last digit of even bin numbers
152 IF(i == 1) THEN ! ten'th column
153 i=mod(j/10,10)+1
154 px(jm)(6+j:6+j)=ch(i)
155
156 END IF
157 END IF
158 END DO
159
160 DO j=1,jl
161 IF(x(j) == x(mx)) THEN
162 px(jm)(6+j:6+j)='*' ! * in max bin
163 END IF
164 END DO
165
166 jm=jm+1
167 IF(nn < 0) jm=jm-2 ! no index line
168 lc=((jl+9)/10)*10+6
169 DO j=1,jm
170 WRITE(*,*) px(j)(1:lc) ! print
171 ! WRITE(*,101) PX(J)(1:LC) ! print
172 END DO
173 RETURN
174! 101 FORMAT(A)
175END SUBROUTINE pzvert
176
183
184SUBROUTINE pivert(n,list) !
185 USE mpdef
186
187 IMPLICIT NONE
188 INTEGER(mpi) :: i
189 INTEGER(mpi) :: l
190 INTEGER(mpi) :: ll
191 INTEGER(mpi) :: m
192 INTEGER(mpi) :: nhist
193
194 INTEGER(mpi), INTENT(IN) :: n
195 INTEGER(mpi), INTENT(IN) :: list(n)
196
197
198 REAL(mps) :: y(60)
199
200 SAVE
201 ! ...
202 ll=(n+59)/60 ! compression factor
203 m=0
204 i=0
20510 nhist=0
206 DO l=1,ll
207 IF(i+l <= n) nhist=nhist+list(i+l)
208 END DO
209 i=i+ll
210 m=m+1
211 y(m)=nhist
212 IF(i < n) GO TO 10
213 CALL pzvert(m,y)
214 RETURN
215END SUBROUTINE pivert
216
223
224SUBROUTINE pfvert(n,x) ! vert. print fltpt data
225 USE mpdef
226
227 IMPLICIT NONE
228 REAL(mps) :: dsum
229 INTEGER(mpi) :: i
230 INTEGER(mpi) :: l
231 INTEGER(mpi) :: ll
232 INTEGER(mpi) :: m
233 REAL(mps) :: y(60)
234
235 INTEGER(mpi), INTENT(IN) :: n
236 INTEGER(mpi), INTENT(IN) :: x(n)
237
238 ll=(n+59)/60 ! compression factor
239 m=0
240 i=0
24120 dsum=0.0
242 DO l=1,ll
243 IF(i+l <= n) dsum=dsum+x(i+l)
244 END DO
245 i=i+ll
246 m=m+1
247 y(m)=real(dsum,mps)
248 IF(i < n) GO TO 20
249 CALL pzvert(m,y)
250 RETURN
251END SUBROUTINE pfvert
252
257
258SUBROUTINE psvert(xa,xb) ! print scale
259 USE mpdef
260
261 IMPLICIT NONE
262 INTEGER(mpi) :: i
263 REAL(mps) :: xc
264 ! print scale from XA ... XB
265
266
267 REAL(mps), INTENT(IN) :: xa
268 REAL(mps), INTENT(IN) :: xb
269 REAL(mps) :: sc(7)
270 xc=xb
271 DO i=1,7
272 sc(i)=(real(7-i,mps)*xa+real(i-1,mps)*xc)/6.0
273 END DO
274 WRITE(*,101) sc
275101 FORMAT(3x,7g10.3)
276 RETURN
277END SUBROUTINE psvert
278
Definition of constants.
Definition: mpdef.f90:24
integer, parameter mpi
integer
Definition: mpdef.f90:35
subroutine pfvert(n, x)
Vertical print of floating point data.
Definition: vertpr.f90:225
subroutine pzvert(n, x)
Print vertical.
Definition: vertpr.f90:36
subroutine pivert(n, list)
Vertical print of integer data.
Definition: vertpr.f90:185
subroutine psvert(xa, xb)
Print scale.
Definition: vertpr.f90:259