程序运行后效果：
| 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
