首页 > 代码 > 常规代码 > 正文

代码

阅读排行

根据数据反获得格式符
2014-04-12 08:33:53   来源:IFREMER   评论:0 点击:

此代码可根据已有的数据(字符串形式)反算其中的格式,以便使用这种格式读写同样的其他数据。

主程序已演示其中用法。

程序运行后效果:
3.1415926
(F9.7)
3.14159260000000
3.1415926
34.12e+11
(2PE9.2)
3412000000000.00
34.1E+11

蓝色为输入的数据,红色为输出的该数据格式。其后转换为real*8类型,再转回字符型(以便检查是否正确)
 

PROGRAM www_fcode_cn
  CHARACTER (LEN=64) :: ztxt
  CHARACTER (LEN=64) :: zfmt
  Real( Kind = Kind(0.0D0) ) ::  d
  Do
    READ (*, "(A)", end=1000) ztxt
    CALL obtfmt (ztxt, zfmt) !// 从 ztxt 获得格式 zfmt
    WRITE (*, *) zfmt !// 输出格式
    k = isnum (ztxt)
    IF (k == 1) THEN
       READ (ztxt, zfmt) i
       WRITE (*, *) i
       WRITE (*, zfmt) i
    END IF
    IF (k > 1) THEN
       READ (ztxt, zfmt) d
       WRITE (*, *) d
       WRITE (*, zfmt) d
    END IF
  End Do
1000  STOP
END PROGRAM www_fcode_cn

MODULE CODNUM
!  Definition of codes for the numerical types
! _________________________________________________________________
      INTEGER, PARAMETER :: KINT = 1 ! integer
      INTEGER, PARAMETER :: KFIX = 2 ! fixed point real
      INTEGER, PARAMETER :: KEXP = 3 ! exponent type real
      INTEGER, PARAMETER :: KDBL = 4 ! exponent type double
END MODULE CODNUM
INTEGER FUNCTION isnum (ZVAL)
!  Verify that a character string represents a numerical value
      USE CODNUM
      CHARACTER (Len=*), INTENT (IN) :: ZVAL
! __________________________________________________
!  return : 0 = non-numeric string
!        else = code as defined in module codnum
! __________________________________________________
!
! initialise
!
      NUM = 0
      NMTS = 0
      NEXP = 0
      KMTS = 0
      IFEXP = 0
!
! loop over characters
!
      ICHR = 0
      DO
         IF (ICHR >= LEN(ZVAL)) THEN
!
! last check
!
            IF (NMTS == 0) EXIT
            IF (NUM >= KEXP .AND. NEXP == 0) EXIT
            isnum = NUM
            RETURN
         END IF
         ICHR = ICHR + 1
         SELECT CASE (ZVAL(ICHR:ICHR))
!
! process blanks
!
         CASE (' ')
            CONTINUE
!
! process digits
!
         CASE ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9')
            IF (NUM == 0) NUM = KINT
            IF (NUM < KEXP) THEN
               NMTS = NMTS + 1
            ELSE
               NEXP = NEXP + 1
            END IF
!
! process signs
!
         CASE ('+', '-')
            IF (NUM == 0) THEN
               IF (KMTS > 0) EXIT
               KMTS = 1
               NUM = KINT
            ELSE
               IF (NUM < KEXP) EXIT
               IF (IFEXP > 0) EXIT
               IFEXP = 1
            END IF
!
! process decimal point
!
         CASE ('.')
            IF (NUM /= KINT .AND. ICHR /= 1) EXIT
            NUM = KFIX
!
! process exponent
!
         CASE ('e', 'E')
            IF (NUM >= KEXP) EXIT
            IF (NMTS == 0) EXIT
            NUM = KEXP
!
         CASE ('d', 'D')
            IF (NUM >= KEXP) EXIT
            IF (NMTS == 0) EXIT
            NUM = KDBL
!
! any other character means the string is non-numeric
!
         CASE DEFAULT
            EXIT
!
         END SELECT
      END DO
!
! if this point is reached, the string is non-numeric
!
      isnum = 0
      RETURN
END FUNCTION isnum
SUBROUTINE obtfmt (ZVAL, zfmt)
      USE CODNUM
!  Find out what Fortran format was used to write a numerical value
      CHARACTER (Len=*), INTENT (IN) :: ZVAL ! the string
      CHARACTER (Len=*), INTENT (OUT) :: zfmt ! the format
! ____________________________________________________
      CHARACTER (Len=1) :: ZNUM0, ZNUM1, ZNUM2 ! to write the numbers
                                          ! of digits of the integers
                                          ! used in the format
      CHARACTER (Len=27) :: ZFMTW ! The format to write the format ...
      INTERFACE
         INTEGER FUNCTION isnum (ZVAL)
!  Verify that a string is numeric
            CHARACTER (Len=*), INTENT (IN) :: ZVAL ! the string
         END FUNCTION isnum
!
         INTEGER FUNCTION NBRCHF (JVAL)
!  Number of characters (digits and minus sign) to display JVAL
            INTEGER, INTENT (IN) :: JVAL ! the value
         END FUNCTION NBRCHF
      END INTERFACE
!
! initialise
!
      LVAL = LEN (ZVAL)
      LFMT = LEN (zfmt)
!
!  Big switching place
!
      KASE = isnum (ZVAL)
      SELECT CASE (KASE)
!
! non numeric (A Format)
! ____________________________________________________
!
      CASE (0)
         NCHR = LVAL
         NCHR1 = NBRCHF (NCHR)
!
!    The format is (Axxx), we will write it with ('(A',Iw,')')
!    Lets create the latter format, ZFMTW, with w = NCHR1
!
         IF (NCHR1+3 > LFMT) THEN
            WRITE (*, *) "Argument string ZFMT too short"
         ELSE
            IF (NCHR1 > 0 .AND. NCHR1 < 10) THEN
               WRITE (ZNUM1, "(I1)") NCHR1
               ZFMTW = "('(A',I" // ZNUM1 // ",')')"
               WRITE (zfmt, ZFMTW) NCHR
            ELSE
               WRITE (*, *) "Doesn't a string length of",&
              & NCHR, " seem strange ?"
            END IF
         END IF
!
! integer
! ____________________________________________________
!
      CASE (KINT)
         NCHF = LEN_TRIM (ZVAL)
!
! If it looks too long, remove leading blanks
!
         IF (NCHF > 20) THEN
            NCHF = LEN_TRIM (ADJUSTL(ZVAL))
         END IF
!
         NCHR1 = NBRCHF (NCHF)
!
!    The format is (Ixxx), we will write it with  ('(I',Iw,')')
!    Lets create the latter format, ZFMTW, with w = NCHR1
!
         IF (NCHR1+3 > LFMT) THEN
            WRITE (*, *) "Argument string ZFMT too short"
         ELSE
            IF (NCHR1 > 0 .AND. NCHR1 < 10) THEN
               WRITE (ZNUM1, "(I1)") NCHR1
               ZFMTW = "('(I',I" // ZNUM1 // ",')')"
               WRITE (zfmt, ZFMTW) NCHF
            ELSE
               WRITE (*, *) "isn't an integer of ", NCHF, "&
              & digits a strange idea ?"
            END IF
         END IF
!
! real, fixed point form
! ____________________________________________________
!
      CASE (KFIX)
         NCHF = LEN_TRIM (ZVAL)
         NCHFF = NCHF - INDEX (ZVAL, '.')
!
! If it looks too long, remove leading blanks
!
         IF (NCHF > 25) THEN
            NCHF = LEN_TRIM (ADJUSTL(ZVAL))
         END IF
!
         NCHR1 = NBRCHF (NCHF)
         NCHR2 = NBRCHF (NCHFF)
!
!    The format is (Fxx.yy), we will write it with  ('(F',Iw,'.',Id,')')
!    Lets create the latter format, ZFMTW, with w = NCHR1
!    and d = NCHR2, obtained from the position of the decimal point
!
         IF (NCHR1+NCHR2+4 > LFMT) THEN
            WRITE (*, *) "Argument string ZFMT too short"
         ELSE
            IF (NCHR1 > 0 .AND. NCHR1 < 10) THEN
               WRITE (ZNUM1, "(I1)") NCHR1
               WRITE (ZNUM2, "(I1)") NCHR2
               ZFMTW = "('(F',I" // ZNUM1 // ",'.',I" // ZNUM2 //&
              & ",')')"
               WRITE (zfmt, ZFMTW) NCHF, NCHFF
            ELSE
               WRITE (*, *) "isn't a real of ", NCHF, "&
              & digits a strange idea ?"
            END IF
         END IF
!
! real, exponent form
! ____________________________________________________
!
      CASE (KEXP, KDBL)
         NCHF = LEN_TRIM (ZVAL)
         IF (KASE == 3) THEN
            NCHFF = Max (INDEX(ZVAL, 'E'), INDEX(ZVAL, 'e')) - 1 -&
           & INDEX (ZVAL, '.')
         ELSE
            NCHFF = Max (INDEX(ZVAL, 'D'), INDEX(ZVAL, 'd')) - 1 -&
           & INDEX (ZVAL, '.')
         END IF
         IPNT = INDEX (ZVAL, '.')
         IF (IPNT > 0) THEN
            NCHFP = IPNT - VERIFY (ZVAL, " +-")
         ELSE
            NCHFP = NCHFF
            NCHFF = 0
         END IF
!
! If it looks too long, remove leading blanks
!
         IF (NCHF > 30) THEN
            NCHF = LEN_TRIM (ADJUSTL(ZVAL))
         END IF
!
         NCHR0 = NBRCHF (NCHFP)
         NCHR1 = NBRCHF (NCHF)
         NCHR2 = NBRCHF (NCHFF)
!
!    The chosen format is (zPExx.yy), we will write it with
!     ('(',Ik,'PE',Iw,'.',Id,')')
!    Lets create the latter format, ZFMTW, with
!    k= NCHR0, w = NCHR1, d = NCHR2
!
         IF (NCHF+5 > LFMT) THEN
            WRITE (*, *) "Argument string ZFMT too short"
         ELSE
            IF (NCHR1 > 0 .AND. NCHR1 < 10) THEN
               WRITE (ZNUM0, "(I1)") NCHR0
               WRITE (ZNUM1, "(I1)") NCHR1
               WRITE (ZNUM2, "(I1)") NCHR2
               IF (KASE == 3) THEN
                  ZFMTW = "('(',I" // ZNUM0 // ",'PE',I" // ZNUM1 //&
                 & ",'.',I" // ZNUM2 // ",')')"
               ELSE
                  ZFMTW = "('(',I" // ZNUM0 // ",'PD',I" // ZNUM1 //&
                 & ",'.',I" // ZNUM2 // ",')')"
               END IF
               WRITE (zfmt, ZFMTW) NCHFP, NCHF, NCHFF
            ELSE
               WRITE (*, *) "isn't a real of ", NCHF, "&
              & digits a strange idea ?"
            END IF
         END IF
!
!
      CASE DEFAULT
         WRITE (*, *) "Type ", KASE, " not known"
!
      END SELECT
      RETURN
END SUBROUTINE obtfmt
INTEGER FUNCTION NBRCHF (JVAL)
!  Number of characters (digits and minus sign) to display JVAL
      INTEGER, INTENT (IN) :: JVAL ! the value
! ____________________________________________________
!
! Compute with integers to avoid precision problems
! with logarithms
!
! Start with 1, [+1 when negative]
! ____________________________________________________
!
      IF (JVAL < 0) THEN
         NCHF = 2
         JVALA = - JVAL
      ELSE
         NCHF = 1
         JVALA = JVAL
      END IF
!
!         + 1 per overpassing of power of 10
!
      DO
         IF (JVALA < 10) EXIT
         JVALA = JVALA / 10
         NCHF = NCHF + 1
      END DO
      NBRCHF = NCHF
      RETURN
END FUNCTION NBRCHF

相关热词搜索:获得格式符

上一篇:Fortran 校验身份证是否合法
下一篇:仿VF扩展动态生成输出格式

分享到: 收藏