SUBROUTINE VPRINT(ARRAY,N,A,B,TEXT) * * Vertical print of the content of array ARRAY(N). * Length of the array is not limited. * Text TEXT is printed above, if non-blank. * For A not equal B a scale is printed below, assuming * a N-bin histogram; in addition the content is * 'plotted' using up to 10 rows of X's. This works for * negative content too. * REAL ARRAY(*) CHARACTER*(*) TEXT CHARACTER*12 TSC(0:12),STR * ... IF(TEXT.NE.' ') THEN WRITE(*,101) WRITE(*,101) TEXT END IF IF(N.GT.0.AND.N.LE.120) THEN * check last nonzero value NUL=0 DO I=1,N IF(ARRAY(I).NE.0.0) NUL=I END DO IF(NUL.EQ.0) GOTO 100 IF(A.NE.B) CALL XVERT(ARRAY,N) CALL PVERT(ARRAY,N,6) IF(A.NE.B) THEN NN=MIN((NUL+9)/10,11) DO I=0,NN SCN=A+FLOAT(I)*10.0*(B-A)/FLOAT(N) CALL PNVG(SCN,STR,JS) TSC(I-NA)=' ' II=0 IF(JS.LT.10) II=(10-JS)/2 TSC(I-NA)(II+1:II+JS)=STR(1:JS) END DO WRITE(*,103) (TSC(I),I=0,NN) END IF ELSE IF(N.GT.120) THEN * print in parts IB=0 10 IA=IB+1 IF(IA.LE.N) THEN IB=MIN(IA+99,N) WRITE(*,101) WRITE(*,102) IA,IB IF(A.NE.B) CALL XVERT(ARRAY(IA),IB-IA+1) CALL PVERT(ARRAY(IA),IB-IA+1,6) NUL=0 DO I=IA,IB IF(ARRAY(I).NE.0) NUL=I END DO IF(A.NE.B) THEN NA=(IA+9)/10-1 NB=(NUL+9)/10 DO I=NA,NB SCN=A+FLOAT(I)*10.0*(B-A)/FLOAT(N) CALL PNVG(SCN,STR,JS) TSC(I-NA)=' ' II=0 IF(JS.LT.10) II=(10-JS)/2 TSC(I-NA)(II+1:II+JS)=STR(1:JS) END DO WRITE(*,103) (TSC(I-NA),I=NA,NB) GOTO 10 END IF END IF END IF 100 RETURN 101 FORMAT(11X,A) 102 FORMAT(1X,'Cols',I5,' to',I5) 103 FORMAT(6X,12A10) END SUBROUTINE XVERT(G,M) REAL G(*) CHARACTER*128 PX(10) * ... * find LM, IMIN, IMAX, NPOS, NNEG ... LM=0 IMIN=1 IMAX=1 NPOS=0 NNEG=0 DO I=1,M IF(G(I).NE.0.0) THEN LM=I IF(G(I).GT.0.0) THEN NPOS=NPOS+1 IF(G(I).GT.G(IMAX)) IMAX=I ELSE NNEG=NNEG+1 IF(G(I).LT.G(IMIN)) IMIN=I END IF END IF END DO LASTM=LM * IF(LM.EQ.0) GOTO 100 * print up to 10 lines of X's DO J=1,10 PX(J)=' ' END DO IF(NNEG*10.LT.LM) THEN * plot only positive contents FAC=10.0/G(IMAX) DO I=1,LM K=G(I)*FAC+0.5 IF(K.GT.0) THEN JA=11-K DO J=JA,10 PX(J)(I+8:I+8)='X' END DO END IF END DO ELSE * print positive and negative contents GMIN=AMIN1(G(IMIN),0.0) GMAX=AMAX1(G(IMAX),0.0) FAC=9.0/(GMAX-GMIN) 37 LMIN=-GMIN*FAC+0.5 LMAX=+GMAX*FAC+0.5 IF(LMAX+LMIN.GT.9) THEN FAC=FAC*0.98 GOTO 37 END IF LMIN=-LMIN DO I=1,LM IF(G(I).NE.0.0) THEN IF(G(I).GT.0.0) THEN L=+G(I)*FAC+0.5 LA=LMAX+1-L LB=LMAX LL=LMAX+1 ELSE L=-G(I)*FAC+0.5 L=-L LA=LMAX+2 LB=LMAX+1-L LL=LMAX+1 END IF DO L=LA,LB PX(L)(I+8:I+8)='X' END DO PX(LL)(I+8:I+8)='0' END IF END DO END IF WRITE(*,101) DO J=1,10 WRITE(*,101) PX(J)(1:8+LM) END DO 100 RETURN 101 FORMAT(3X,A) END SUBROUTINE PVERT(X,N,NN) * PVERT prints the array X of dimension N (MAX 120) in IABS(NN) * lines C - - -- C CALL PVERT(X,N,NN) C C IABS(NN) = NUMBER OF DIGITS (3 TO 6) C NN NEGATIVE = PRINT NO INDEXLINE BELOW ARRAY C REAL X(*) CHARACTER*128 PX(10),CH(10)*1 DATA CH/'0','1','2','3','4','5','6','7','8','9'/ * ... JM=0 DO I=1,10 PX(I)=' ' END DO IF(N.LE.0) GOTO 100 M=MIN(120,N) JL=0 XM=0.0 DO J=1,M * maximum value IF(ABS(X(J)).GT.XM) THEN XM=ABS(X(J)) MX=J END IF * negative columns IF(X(J).LT.0.0) PX(1)(8+J:8+J)='-' * last nonzero column IF(X(J).NE.0.0) JL=J END DO * return for empty array IF(XM.EQ.0.0.OR.JL.LE.0) GOTO 100 * KN=MIN(6,MAX(2,IABS(NN))) KE=ALOG10(XM*1.0001) IF(XM.LT.1.0) KE=KE-1 22 FAC=10.0**(KN-1-KE) IJ=FAC*XM+0.5 IF(IJ.GE.10**KN) THEN KE=KE+1 GOTO 22 END IF IA=2+KN * DO J=1,JL IJ=FAC*ABS(X(J))+0.5 IM=0 IF(IJ.NE.0) THEN DO I=1,KN IF(IJ.NE.0) THEN IN=MOD(IJ,10) IJ=IJ/10 IF(IN.NE.0.AND.IM.EQ.0) IM=IA-I+1 PX(IA-I)(8+J:8+J)=CH(IN+1) END IF END DO END IF JM=MAX(IM,JM) END DO KL=KE 50 IF(KE.GE.KN) THEN KE=KE-3 GOTO 50 END IF 55 IF(KE.LT.0) THEN KE=KE+3 GOTO 55 END IF * exponent IN=KE+2 IZ=KL-KE PX(IN)(8:8)='.' PX(IN)(3:3)='E' IF(IZ.LT.0) THEN PX(IN)(4:4)='-' IZ=-IZ END IF * insert exponent I1=IZ/10 I2=MOD(IZ,10) PX(IN)(5:5)=CH(I1+1) PX(IN)(6:6)=CH(I2+1) JM=MIN(2+KN,JM) JM=MAX(IN+1,JM) * '0' for small nonzero values DO J=1,JL IF(X(J).NE.0.0.AND.PX(JM-1)(8+J:8+J).EQ.' ') PX(JM-1)(8+J:8+J)='0' END DO DO I=JM,8 PX(I)=' ' END DO * index line below DO J=1,((JL+9)/10)*10 PX(JM)(8+J:8+J)='-' IF(MOD(J,2).NE.1) THEN I=MOD(J,10)+1 * last digit of even bin numbers PX(JM+1)(8+J:8+J)=CH(I) IF(I.EQ.1) THEN * ten'th column I=MOD(J/10,10)+1 PX(JM)(8+J:8+J)=CH(I) END IF END IF END DO * '*' in maximum bin PX(JM)(8+J:8+J)='*' * no index line for negative argument JM=JM+1 IF(NN.LT.0) JM=JM-2 * print LC=((JL+9)/10)*10+8 DO J=1,JM WRITE(6,101) PX(J)(1:LC) END DO 100 RETURN 101 FORMAT(3X,A) END SUBROUTINE SMTEXT(TEXT) * * Prints TEXT in one or several lines, LWID characters per line * ---- * CALL SMTEXT(text) print text * * CALL SMTEXT('PAGE') starts new page (without writing 'PAGE') * CALL SMTEXT(' ') one blank line * if text ends with blank, continuation (by another call of SMTEXT) * expected * PARAMETER (LWID=71) CHARACTER*(*) TEXT CHARACTER LINE*132 DATA LINE/' '/ DATA LA/1/ * ... IF(TEXT.EQ.'PAGE') THEN * new page WRITE(*,'(1H1)') ELSE IF(TEXT.EQ.' ') THEN * blank line ... IF(LA.NE.1) THEN * ... but print buffer before WRITE(*,'(1X,A)') LINE(1:LWID) LA=1 LINE=' ' END IF WRITE(*,'(1X,A)') LINE(1:LWID) ELSE IA=1 IB=LEN(TEXT) 10 IF(IA.LE.IB) THEN * search for next blank ... I=INDEX(TEXT(IA:IB),' ') IF(I.EQ.0) THEN * ... no blank found I=IB ELSE I=I+IA-1 END IF * I is now pointing to last character to be copied IF(I.NE.IA.OR.TEXT(IA:IA).NE.' ') THEN 20 LB=LA+I-IA IF(LB.GT.LWID) THEN * ... does not fit into the line ... IF(LA.NE.1) THEN * ... print the line ... WRITE(*,'(1X,A)') LINE(1:LWID) LINE=' ' LA=1 * ... and fill into next line GOTO 20 END IF * ... but this line was empty (LA=1) - break at max I=IA+LWID-1 GOTO 20 END IF LINE(LA:LB)=TEXT(IA:I) LA=LB+1 END IF IA=I+1 GOTO 10 END IF IF(TEXT(IB:IB).NE.' ') THEN * print buffer WRITE(*,'(1X,A)') LINE(1:LWID) LA=1 LINE=' ' END IF END IF END