vertpr.f90

Go to the documentation of this file.

! Code converted using TO_F90 by Alan Miller
! Date: 2012-03-16  Time: 11:09:42



SUBROUTINE pzvert(n,x)
    IMPLICIT NONE
    INTEGER :: i
    INTEGER :: i1
    INTEGER :: i2
    INTEGER :: ia
    INTEGER :: ij
    INTEGER :: im
    INTEGER :: in
    INTEGER :: iz
    INTEGER :: j
    INTEGER :: jl
    INTEGER :: jm
    INTEGER :: ke
    INTEGER :: kl
    INTEGER :: kn
    INTEGER :: lc
    INTEGER :: m
    INTEGER :: mx
    REAL :: fac
    REAL :: xm
    !

    INTEGER, INTENT(IN)                      :: n
    REAL, INTENT(IN)                         :: x(n)
    INTEGER, PARAMETER :: nn=6

    CHARACTER (LEN=66):: px(10)
    CHARACTER (LEN=66)::ch(10)*1
    SAVE
    DATA ch/'0','1','2','3','4','5','6','7','8','9'/
    !     ...
    IF(n <= 0) return
    jm=0
    DO i=1,10
        px(i)=' '
    END DO

    m=min(60,n)
    jl=0
    xm=0.0
    DO j=1,m
        IF(abs(x(j)) > xm) THEN
            xm=abs(x(j))
            mx=j                             ! index of max
        END IF
        IF(x(j) < 0.0) px(1)(6+j:6+j)='-'  ! negative columns
        IF(x(j) /= 0.0) jl=j                ! last non-zero column
    END DO
    IF(xm == 0.0.OR.jl <= 0) return      ! empty array
    jl=60

    kn=min(6,max(2,iabs(nn)))
    ke=int(alog10(xm*1.0001))
    IF(xm < 1.0) ke=ke-1
22  fac=10.0**(kn-1-ke)
    ij=int(fac*xm+0.5)
    IF(ij >= 10**kn) THEN
        ke=ke+1
        go to 22
    END IF
    ia=2+kn

    DO j=1,jl
        ij=int(fac*abs(x(j))+0.5)   ! convert to integer
        im=0
        IF(ij /= 0) THEN
            DO i=1,kn
                IF(ij /= 0) THEN
                    in=mod(ij,10)   ! last digit
                    ij=ij/10        ! reduce
                    IF(in /= 0.AND.im == 0) im=ia-i+1
                    px(ia-i)(6+j:6+j)=ch(in+1)
                END IF
            END DO
        END IF
        jm=max(im,jm)
    END DO

    kl=ke
50  IF(ke >= kn) THEN
        ke=ke-3
        go to 50
    END IF
55  IF(ke < 0) THEN
        ke=ke+3
        go to 55
    END IF

    in=ke+2                          ! exponent
    iz=kl-ke
    px(in)(6:6)='.'
    px(in)(1:1)='E'
    IF(iz < 0) THEN
        px(in)(2:2)='-'
        iz=-iz
    END IF
    i1=iz/10                         ! insert exponent
    i2=mod(iz,10)
    px(in)(3:3)=ch(i1+1)
    px(in)(4:4)=ch(i2+1)
    jm=min(2+kn,jm)
    jm=max(in+1,jm)
    DO j=1,jl    ! '0' for small nonzero values
        IF(x(j) /= 0.0.AND.px(jm-1)(6+j:6+j) == ' ') px(jm-1)(6+j:6+j)='0'
    END DO
    DO i=jm,8
        px(i)=' '
    END DO

    DO j=1,((jl+9)/10)*10            ! index line below
        IF(px(jm-1)(6+j:6+j) == ' ') px(jm-1)(6+j:6+j)='_'
        IF(mod(j,2) /= 1) THEN
            i=mod(j,10)+1
            px(jm+1)(6+j:6+j)=ch(i)      ! last digit of even bin numbers
            IF(i == 1) THEN              ! ten'th column
                i=mod(j/10,10)+1
                px(jm)(6+j:6+j)=ch(i)
      
            END IF
        END IF
    END DO

    DO j=1,jl
        IF(x(j) == x(mx)) THEN
            px(jm)(6+j:6+j)='*'          ! * in max bin
        END IF
    END DO

    jm=jm+1
    IF(nn < 0) jm=jm-2              ! no index line
    lc=((jl+9)/10)*10+6
    DO j=1,jm
        WRITE(*,*)  px(j)(1:lc)       ! print
    !       WRITE(*,101)  PX(J)(1:LC)       ! print
    END DO
    return
!  101 FORMAT(A)
END SUBROUTINE pzvert


SUBROUTINE pivert(n,list)                  !
    IMPLICIT NONE
    INTEGER :: i
    INTEGER :: l
    INTEGER :: ll
    INTEGER :: m
    INTEGER :: nhist

    INTEGER, INTENT(IN)                      :: n
    INTEGER, INTENT(IN)                      :: list(n)

    
    REAL :: y(60)
    
    SAVE
    !     ...
    ll=(n+59)/60 ! compression factor
    m=0
    i=0
10  nhist=0
    DO l=1,ll
        IF(i+l <= n) nhist=nhist+list(i+l)
    END DO
    i=i+ll
    m=m+1
    y(m)=nhist
    IF(i < n) go to 10
    CALL pzvert(m,y)
    return
END SUBROUTINE pivert


SUBROUTINE pfvert(n,x)                       ! vert. print fltpt data
    IMPLICIT NONE
    REAL :: dsum
    INTEGER :: i
    INTEGER :: l
    INTEGER :: ll
    INTEGER :: m
    REAL :: y(60)

    INTEGER, INTENT(IN)                      :: n
    INTEGER, INTENT(IN)                      :: x(n)

    ll=(n+59)/60 ! compression factor
    m=0
    i=0
20  dsum=0.0
    DO l=1,ll
        IF(i+l <= n) dsum=dsum+x(i+l)
    END DO
    i=i+ll
    m=m+1
    y(m)=REAL(dsum)
    IF(i < n) go to 20
    CALL pzvert(m,y)
    return
END SUBROUTINE pfvert


SUBROUTINE psvert(xa,xb)                     ! print scale
    IMPLICIT NONE
    INTEGER:: i
    REAL:: xc
    !     print scale from XA ... XB


    REAL, INTENT(IN)                         :: xa
    REAL, INTENT(IN)                         :: xb
    REAL:: sc(7)
    xc=xb
    DO i=1,7
        sc(i)=(float(7-i)*xa+float(i-1)*xc)/6.0
    END DO
    WRITE(*,101) sc
101 format(3x,7g10.3)
    return
END SUBROUTINE psvert