*----------------------------------------------------------------------- * USPACK REAL TO CHARACTER S. Sakai 90/03/16 *----------------------------------------------------------------------- * Copyright (C) 2000 GFD Dennou Club. All rights reserved. *----------------------------------------------------------------------- SUBROUTINE USCHVL(X, CHX) CHARACTER CHX*(*), CFMT*16, CVAL*16, CEXP*8, CEXP2*8, CSGI*1 REAL X LOGICAL LEXP, LCNTL CALL SGLGET('LCNTL', LCNTL) CALL GLRGET('REPSL', PREC) NPREC = -LOG10(PREC) IF(NPREC.GT.8) NPREC = 8 CFMT = '(E16.xE3)' WRITE(CFMT(6:6), '(I1)') NPREC WRITE(CVAL, CFMT) X CFMT = '(F11.x, TR1, I4)' WRITE(CFMT(6:6), '(I1)') NPREC READ (CVAL, CFMT) XX, NEXP *------------------------ effective digits ----------------------------- DO 10 N=11, 4, -1 NDIG=N IF(CVAL(N:N).NE.'0') GOTO 20 10 CONTINUE 20 CONTINUE NDIG = NDIG - INDEX(CVAL, '.') *----------------------------- mantissa -------------------------------- NLOW = NEXP - NDIG + 1 LEXP = NEXP.LE.-3 .OR. NLOW.GE.5 IF(LEXP) THEN XX = XX*10 NPREC = NDIG - 1 ELSE XX = XX*1.D1**NEXP NPREC = -NLOW + 1 ENDIF IF(NPREC.GE.1) THEN CFMT = '(SP, F16.x)' WRITE(CFMT(10:10), '(I1)') NPREC WRITE(CVAL, CFMT) XX ELSE CFMT = '(SP, I16)' IX = NINT(XX) WRITE(CVAL, CFMT) IX ENDIF CALL CLADJ(CVAL) *-------------------------- characteristic ----------------------------- IF(LEXP) THEN NEXP = NEXP - 1 WRITE(CEXP2, '(I3)') NEXP CALL CLADJ(CEXP2) IF(LCNTL) THEN CALL SGIGET('ISUP', ISUP) CALL SGIGET('IRST', IRST) CEXP = CSGI(194)//'10'//CHAR(ISUP)//CEXP2(1:LENC(CEXP2)) + //CHAR(IRST) ELSE CEXP = 'E'//CEXP2(1:LENC(CEXP2)) ENDIF ELSE CEXP = ' ' ENDIF *----------------------------------------------------------------------- IF(LCNTL .AND. CVAL(2:3).EQ.'1 ' .AND. CEXP.NE.' ') THEN CHX = CVAL(1:1) // CEXP(2:8) ELSE CHX = CVAL(1:LENC(CVAL)) // CEXP ENDIF RETURN END *----------------------------------------------------------------------- * Copyright (C) 2000 GFD Dennou Club. All rights reserved. *----------------------------------------------------------------------- SUBROUTINE ULXLOG ( CSIDE, NLBL, NTICKS ) * CSIDE : 'T','B','U' * NLBL : 1-4 ... Label buffer number used in the axis * NTICKS: 1-9 ... Number of small ticks in 10**N-10**(N+1) PARAMETER(MAXL=50,MAXS=200) DIMENSION BL(10),BS(10),UX1(MAXS),UX2(MAXL),UXT(MAXL) CHARACTER CH(MAXL)*16,CHR*8,CFMT*16,CSGI,CSIDE LOGICAL LRLT,LRGT,LABEL,LEPSL,LCNTL,LUXCHK,LOFF SAVE IF(.NOT.LUXCHK(CSIDE)) # CALL MSGDMP('E', 'ULXLOG', 'INVALID CSIDE.') IF(NLBL.LT.1 .OR. NLBL.GT.4) # CALL MSGDMP('E', 'ULXLOG', 'INVALID NLBL.') IF(NTICKS.LT.1 .OR. NTICKS.GT.9) # CALL MSGDMP('E', 'ULXLOG', 'INVALID NTICKS.') CALL SGQWND(UXMIN,UXMAX,UYMIN,UYMAX) CALL UZLGET('LOFFSET', LOFF) IF(LOFF) THEN CALL UZRGET('XFACT', FACTOR) XMIN = UXMIN/FACTOR XMAX = UXMAX/FACTOR CALL SGSWND(XMIN,XMAX,UYMIN,UYMAX) CALL SGSTRF ELSE XMIN = UXMIN XMAX = UXMAX ENDIF IF(XMIN.GT.XMAX)THEN XXX=XMIN XMIN=XMAX XMAX=XXX END IF CALL ULIGET('IXTYPE', ITYPE) CALL ULIGET('IXCHR' , IXCHR) CALL ULXLBL( BL, NB , NLBL) CALL SGIGET('ISUP', ISUP) CALL SGIGET('IRST', IRST) CALL GLLGET('LEPSL',LEPSL) CALL SGLGET('LCNTL',LCNTL) CALL GLLSET('LEPSL',.TRUE.) CALL GNSAVE * SMALL TICKS CALL VRGNN(BS, 10, 1) BS(NTICKS+1)=10. CALL GNSBLK(BS,NTICKS+1) CALL GNLE(XMAX,BXMAX,IPMAX) CALL GNGE(XMIN,BXMIN,IPMIN) NBS=0 DO 100 IP=IPMIN,IPMAX DO 100 IB=1,NTICKS IF(IP.EQ.IPMIN.AND.LRLT(BS(IB),BXMIN))GOTO 100 IF(IP.EQ.IPMAX.AND.LRGT(BS(IB),BXMAX))GOTO 100 NBS=NBS+1 IF(NBS.GT.MAXS) CALL MSGDMP('E', 'ULXLOG', 'TOO MANY TICKS.') UX1(NBS)=BS(IB)*10.**IP 100 CONTINUE * LARGE LABELS AND TICKS CALL GNSBLK(BL,NB+1) CALL GNLE(XMAX,BXMAX,IPMAX) CALL GNGE(XMIN,BXMIN,IPMIN) NBL=0 NBT=0 JTYPE = MOD(ITYPE, 2) DO 201 IP=IPMIN,IPMAX DO 201 IB=1,NB IF(IP.EQ.IPMIN.AND.LRLT(BL(IB),BXMIN))GOTO 201 IF(IP.EQ.IPMAX.AND.LRGT(BL(IB),BXMAX))GOTO 201 IF(IB.EQ.1)THEN NBT=NBT+1 UXT(NBT)=10.**IP END IF NBL=NBL+1 IF(NBL.GT.MAXL) CALL MSGDMP('E', 'ULXLOG', 'TOO MANY LABELS.') UX2(NBL)=BL(IB)*10.**IP IF(ITYPE.LE.2) THEN IF(JTYPE.EQ.0 .AND. IB.NE.1) THEN WRITE(CH(NBL),'(I1)') INT(BL(IB)) ELSE IF(JTYPE.EQ.1 .AND. NB.NE.1) THEN WRITE(CH(NBL),'(I1,A1)') INT(BL(IB)), CSGI(IXCHR) ELSE CH(NBL)=' ' ENDIF WRITE(CHR,'(I8)') IP CALL CLADJ(CHR) IF(LCNTL) THEN CH(NBL)(3:16)='10'//CSGI(ISUP)//CHR(1:LENZ(CHR)) + //CSGI(IRST) ELSE CH(NBL)(2:16)='E'//CHR ENDIF CALL CLADJ(CH(NBL)) END IF ELSE IF(JTYPE.EQ.0 .AND. IB.NE.1) THEN WRITE(CH(NBL),'(I1)') INT(BL(IB)) ELSE CALL UZCGET('CXFMT', CFMT) CALL CHVAL(CFMT, UX2(NBL), CH(NBL)) CALL CLADJ(CH(NBL)) ENDIF ENDIF 201 CONTINUE * DRAW AXIS, TICKS, AND LABELS CALL UXPAXS(CSIDE,2) IF(NBS.NE.0) CALL UXPTMK(CSIDE,1,UX1,NBS) IF(NBT.NE.0) CALL UXPTMK(CSIDE,2,UXT,NBT) CALL UZLGET('LABELX'//CSIDE,LABEL) IF(LABEL) CALL UXPLBL(CSIDE,1,UX2,CH,16,NBL) CALL GLLSET('LEPSL',LEPSL) CALL GNRSET IF (LOFF) THEN CALL SGSWND(UXMIN,UXMAX,UYMIN,UYMAX) CALL SGSTRF ENDIF END *----------------------------------------------------------------------- * Copyright (C) 2000 GFD Dennou Club. All rights reserved. *----------------------------------------------------------------------- SUBROUTINE ULYLOG ( CSIDE, NLBL, NTICKS ) * CSIDE : 'L','R','U' * NLBL : 1-4 ... Label buffer number used in the axis * NTICKS: 1-9 ... Number of small ticks in 10**N-10**(N+1) PARAMETER(MAXL=50,MAXS=200) DIMENSION BL(10),BS(10),UY1(MAXS),UY2(MAXL),UYT(MAXL) CHARACTER CH(MAXL)*16,CHR*8,CFMT*16,CSGI,CSIDE LOGICAL LRLT,LRGT,LABEL,LEPSL,LCNTL,LUYCHK,LOFF SAVE IF(.NOT.LUYCHK(CSIDE)) # CALL MSGDMP('E', 'ULYLOG', 'INVALID CSIDE.') IF(NLBL.LT.1 .OR. NLBL.GT.4) # CALL MSGDMP('E', 'ULYLOG', 'INVALID NLBL.') IF(NTICKS.LT.1 .OR. NTICKS.GT.9) # CALL MSGDMP('E', 'ULYLOG', 'INVALID NTICKS.') CALL SGQWND(UXMIN,UXMAX,UYMIN,UYMAX) CALL UZLGET('LOFFSET', LOFF) IF(LOFF) THEN CALL UZRGET('YFACT', FACTOR) YMIN = UYMIN/FACTOR YMAX = UYMAX/FACTOR CALL SGSWND(UXMIN, UXMAX , YMIN, YMAX) CALL SGSTRF ELSE YMIN = UYMIN YMAX = UYMAX ENDIF IF(YMIN.GT.YMAX)THEN YYY=YMIN YMIN=YMAX YMAX=YYY END IF CALL ULIGET('IYTYPE', ITYPE) CALL ULIGET('IYCHR' , IYCHR) CALL ULYLBL( BL, NB , NLBL) CALL GLLGET('LEPSL',LEPSL) CALL SGLGET('LCNTL',LCNTL) CALL SGIGET('ISUP', ISUP) CALL SGIGET('IRST', IRST) CALL GLLSET('LEPSL',.TRUE.) CALL GNSAVE * SMALL TICKS CALL VRGNN(BS, 10, 1) BS(NTICKS+1)=10. CALL GNSBLK(BS,NTICKS+1) CALL GNLE(YMAX,BYMAX,IPMAX) CALL GNGE(YMIN,BYMIN,IPMIN) NBS=0 DO 100 IP=IPMIN,IPMAX DO 100 IB=1,NTICKS IF(IP.EQ.IPMIN.AND.LRLT(BS(IB),BYMIN))GOTO 100 IF(IP.EQ.IPMAX.AND.LRGT(BS(IB),BYMAX))GOTO 100 NBS=NBS+1 IF(NBS.GT.MAXS) CALL MSGDMP('E', 'ULYLOG', 'TOO MANY TICKS.') UY1(NBS)=BS(IB)*10.**IP 100 CONTINUE * LARGE LABELS AND TICKS CALL GNSBLK(BL,NB+1) CALL GNLE(YMAX,BYMAX,IPMAX) CALL GNGE(YMIN,BYMIN,IPMIN) NBL=0 NBT=0 JTYPE = MOD(ITYPE, 2) DO 201 IP=IPMIN,IPMAX DO 201 IB=1,NB IF(IP.EQ.IPMIN.AND.LRLT(BL(IB),BYMIN))GOTO 201 IF(IP.EQ.IPMAX.AND.LRGT(BL(IB),BYMAX))GOTO 201 IF(IB.EQ.1)THEN NBT=NBT+1 UYT(NBT)=10.**IP END IF NBL=NBL+1 IF(NBL.GT.MAXL) CALL MSGDMP('E', 'ULYLOG', 'TOO MANY LABELS.') UY2(NBL)=BL(IB)*10.**IP IF(ITYPE.LE.2) THEN IF(JTYPE.EQ.0 .AND. IB.NE.1) THEN WRITE(CH(NBL),'(I1)') INT(BL(IB)) ELSE IF(JTYPE.EQ.1 .AND. NB.NE.1) THEN WRITE(CH(NBL),'(I1,A1)') INT(BL(IB)), CSGI(IYCHR) ELSE CH(NBL)=' ' ENDIF WRITE(CHR,'(I8)') IP CALL CLADJ(CHR) IF(LCNTL) THEN CH(NBL)(3:16)='10'//CSGI(ISUP)//CHR(1:LENZ(CHR)) + //CSGI(IRST) ELSE CH(NBL)(2:16)='E'//CHR ENDIF CALL CLADJ(CH(NBL)) ENDIF ELSE IF(JTYPE.EQ.0 .AND. IB.NE.1) THEN WRITE(CH(NBL),'(I1)') INT(BL(IB)) ELSE CALL UZCGET('CYFMT', CFMT) CALL CHVAL(CFMT, UY2(NBL), CH(NBL)) CALL CLADJ(CH(NBL)) ENDIF ENDIF 201 CONTINUE * DRAW AXIS, TICKS, AND LABELS CALL UYPAXS(CSIDE,2) IF(NBS.NE.0) CALL UYPTMK(CSIDE,1,UY1,NBS) IF(NBT.NE.0) CALL UYPTMK(CSIDE,2,UYT,NBT) CALL UZLGET('LABELY'//CSIDE,LABEL) IF(LABEL) CALL UYPLBL(CSIDE,1,UY2,CH,16,NBL) CALL GLLSET('LEPSL',LEPSL) CALL GNRSET IF(LOFF) THEN CALL SGSWND(UXMIN,UXMAX,UYMIN,UYMAX) CALL SGSTRF ENDIF END