 |
Millepede-II
V04-00-00
|
|
Millepede-II
V04-00-00
|
00001 00002 ! Code converted using TO_F90 by Alan Miller 00003 ! Date: 2012-03-16 Time: 11:09:42 00004 00007 00014 00015 SUBROUTINE pzvert(n,x) 00016 IMPLICIT NONE 00017 INTEGER :: i 00018 INTEGER :: i1 00019 INTEGER :: i2 00020 INTEGER :: ia 00021 INTEGER :: ij 00022 INTEGER :: im 00023 INTEGER :: in 00024 INTEGER :: iz 00025 INTEGER :: j 00026 INTEGER :: jl 00027 INTEGER :: jm 00028 INTEGER :: ke 00029 INTEGER :: kl 00030 INTEGER :: kn 00031 INTEGER :: lc 00032 INTEGER :: m 00033 INTEGER :: mx 00034 REAL :: fac 00035 REAL :: xm 00036 ! 00037 00038 INTEGER, INTENT(IN) :: n 00039 REAL, INTENT(IN) :: x(n) 00040 INTEGER, PARAMETER :: nn=6 00041 00042 CHARACTER (LEN=66):: px(10) 00043 CHARACTER (LEN=66)::ch(10)*1 00044 SAVE 00045 DATA ch/'0','1','2','3','4','5','6','7','8','9'/ 00046 ! ... 00047 IF(n <= 0) RETURN 00048 jm=0 00049 DO i=1,10 00050 px(i)=' ' 00051 END DO 00052 00053 m=MIN(60,n) 00054 jl=0 00055 xm=0.0 00056 DO j=1,m 00057 IF(ABS(x(j)) > xm) THEN 00058 xm=ABS(x(j)) 00059 mx=j ! index of max 00060 END IF 00061 IF(x(j) < 0.0) px(1)(6+j:6+j)='-' ! negative columns 00062 IF(x(j) /= 0.0) jl=j ! last non-zero column 00063 END DO 00064 IF(xm == 0.0.OR.jl <= 0) RETURN ! empty array 00065 jl=60 00066 00067 kn=MIN(6,MAX(2,IABS(nn))) 00068 ke=INT(ALOG10(xm*1.0001)) 00069 IF(xm < 1.0) ke=ke-1 00070 22 fac=10.0**(kn-1-ke) 00071 ij=INT(fac*xm+0.5) 00072 IF(ij >= 10**kn) THEN 00073 ke=ke+1 00074 GO TO 22 00075 END IF 00076 ia=2+kn 00077 00078 DO j=1,jl 00079 ij=INT(fac*ABS(x(j))+0.5) ! convert to integer 00080 im=0 00081 IF(ij /= 0) THEN 00082 DO i=1,kn 00083 IF(ij /= 0) THEN 00084 in=MOD(ij,10) ! last digit 00085 ij=ij/10 ! reduce 00086 IF(in /= 0.AND.im == 0) im=ia-i+1 00087 px(ia-i)(6+j:6+j)=ch(in+1) 00088 END IF 00089 END DO 00090 END IF 00091 jm=MAX(im,jm) 00092 END DO 00093 00094 kl=ke 00095 50 IF(ke >= kn) THEN 00096 ke=ke-3 00097 GO TO 50 00098 END IF 00099 55 IF(ke < 0) THEN 00100 ke=ke+3 00101 GO TO 55 00102 END IF 00103 00104 in=ke+2 ! exponent 00105 iz=kl-ke 00106 px(in)(6:6)='.' 00107 px(in)(1:1)='E' 00108 IF(iz < 0) THEN 00109 px(in)(2:2)='-' 00110 iz=-iz 00111 END IF 00112 i1=iz/10 ! insert exponent 00113 i2=MOD(iz,10) 00114 px(in)(3:3)=ch(i1+1) 00115 px(in)(4:4)=ch(i2+1) 00116 jm=MIN(2+kn,jm) 00117 jm=MAX(in+1,jm) 00118 DO j=1,jl ! '0' for small nonzero values 00119 IF(x(j) /= 0.0.AND.px(jm-1)(6+j:6+j) == ' ') px(jm-1)(6+j:6+j)='0' 00120 END DO 00121 DO i=jm,8 00122 px(i)=' ' 00123 END DO 00124 00125 DO j=1,((jl+9)/10)*10 ! index line below 00126 IF(px(jm-1)(6+j:6+j) == ' ') px(jm-1)(6+j:6+j)='_' 00127 IF(MOD(j,2) /= 1) THEN 00128 i=MOD(j,10)+1 00129 px(jm+1)(6+j:6+j)=ch(i) ! last digit of even bin numbers 00130 IF(i == 1) THEN ! ten'th column 00131 i=MOD(j/10,10)+1 00132 px(jm)(6+j:6+j)=ch(i) 00133 00134 END IF 00135 END IF 00136 END DO 00137 00138 DO j=1,jl 00139 IF(x(j) == x(mx)) THEN 00140 px(jm)(6+j:6+j)='*' ! * in max bin 00141 END IF 00142 END DO 00143 00144 jm=jm+1 00145 IF(nn < 0) jm=jm-2 ! no index line 00146 lc=((jl+9)/10)*10+6 00147 DO j=1,jm 00148 WRITE(*,*) px(j)(1:lc) ! print 00149 ! WRITE(*,101) PX(J)(1:LC) ! print 00150 END DO 00151 RETURN 00152 ! 101 FORMAT(A) 00153 END SUBROUTINE pzvert 00154 00161 00162 SUBROUTINE pivert(n,list) ! 00163 IMPLICIT NONE 00164 INTEGER :: i 00165 INTEGER :: l 00166 INTEGER :: ll 00167 INTEGER :: m 00168 INTEGER :: nhist 00169 00170 INTEGER, INTENT(IN) :: n 00171 INTEGER, INTENT(IN) :: list(n) 00172 00173 00174 REAL :: y(60) 00175 00176 SAVE 00177 ! ... 00178 ll=(n+59)/60 ! compression factor 00179 m=0 00180 i=0 00181 10 nhist=0 00182 DO l=1,ll 00183 IF(i+l <= n) nhist=nhist+list(i+l) 00184 END DO 00185 i=i+ll 00186 m=m+1 00187 y(m)=nhist 00188 IF(i < n) GO TO 10 00189 CALL pzvert(m,y) 00190 RETURN 00191 END SUBROUTINE pivert 00192 00199 00200 SUBROUTINE pfvert(n,x) ! vert. print fltpt data 00201 IMPLICIT NONE 00202 REAL :: dsum 00203 INTEGER :: i 00204 INTEGER :: l 00205 INTEGER :: ll 00206 INTEGER :: m 00207 REAL :: y(60) 00208 00209 INTEGER, INTENT(IN) :: n 00210 INTEGER, INTENT(IN) :: x(n) 00211 00212 ll=(n+59)/60 ! compression factor 00213 m=0 00214 i=0 00215 20 dsum=0.0 00216 DO l=1,ll 00217 IF(i+l <= n) dsum=dsum+x(i+l) 00218 END DO 00219 i=i+ll 00220 m=m+1 00221 y(m)=REAL(dsum) 00222 IF(i < n) GO TO 20 00223 CALL pzvert(m,y) 00224 RETURN 00225 END SUBROUTINE pfvert 00226 00231 00232 SUBROUTINE psvert(xa,xb) ! print scale 00233 IMPLICIT NONE 00234 INTEGER:: i 00235 REAL:: xc 00236 ! print scale from XA ... XB 00237 00238 00239 REAL, INTENT(IN) :: xa 00240 REAL, INTENT(IN) :: xb 00241 REAL:: sc(7) 00242 xc=xb 00243 DO i=1,7 00244 sc(i)=(FLOAT(7-i)*xa+FLOAT(i-1)*xc)/6.0 00245 END DO 00246 WRITE(*,101) sc 00247 101 FORMAT(3X,7G10.3) 00248 RETURN 00249 END SUBROUTINE psvert 00250
1.8.0
