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

代码

阅读排行

根据数据反获得格式符
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类型，再转回字符型（以便检查是否正确）
 

查看代码
打印?
001PROGRAM www_fcode_cn
002  CHARACTER (LEN=64) :: ztxt
003  CHARACTER (LEN=64) :: zfmt
004  Real( Kind = Kind(0.0D0) ) ::  d
005  Do
006    READ (*, "(A)", end=1000) ztxt
007    CALL obtfmt (ztxt, zfmt) !// 从 ztxt 获得格式 zfmt
008    WRITE (*, *) zfmt !// 输出格式
009    k = isnum (ztxt)
010    IF (k == 1) THEN
011       READ (ztxt, zfmt) i
012       WRITE (*, *) i
013       WRITE (*, zfmt) i
014    END IF
015    IF (k > 1) THEN
016       READ (ztxt, zfmt) d
017       WRITE (*, *) d
018       WRITE (*, zfmt) d
019    END IF
020  End Do
0211000  STOP
022END PROGRAM www_fcode_cn
023 
024MODULE CODNUM
025!  Definition of codes for the numerical types
026! _________________________________________________________________
027      INTEGER, PARAMETER :: KINT = 1 ! integer
028      INTEGER, PARAMETER :: KFIX = 2 ! fixed point real
029      INTEGER, PARAMETER :: KEXP = 3 ! exponent type real
030      INTEGER, PARAMETER :: KDBL = 4 ! exponent type double
031END MODULE CODNUM
032INTEGER FUNCTION isnum (ZVAL)
033!  Verify that a character string represents a numerical value
034      USE CODNUM
035      CHARACTER (Len=*), INTENT (IN) :: ZVAL
036! __________________________________________________
037!  return : 0 = non-numeric string
038!        else = code as defined in module codnum
039! __________________________________________________
040!
041! initialise
042!
043      NUM = 0
044      NMTS = 0
045      NEXP = 0
046      KMTS = 0
047      IFEXP = 0
048!
049! loop over characters
050!
051      ICHR = 0
052      DO
053         IF (ICHR >= LEN(ZVAL)) THEN
054!
055! last check
056!
057            IF (NMTS == 0) EXIT
058            IF (NUM >= KEXP .AND. NEXP == 0) EXIT
059            isnum = NUM
060            RETURN
061         END IF
062         ICHR = ICHR + 1
063         SELECT CASE (ZVAL(ICHR:ICHR))
064!
065! process blanks
066!
067         CASE (' ')
068            CONTINUE
069!
070! process digits
071!
072         CASE ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9')
073            IF (NUM == 0) NUM = KINT
074            IF (NUM < KEXP) THEN
075               NMTS = NMTS + 1
076            ELSE
077               NEXP = NEXP + 1
078            END IF
079!
080! process signs
081!
082         CASE ('+', '-')
083            IF (NUM == 0) THEN
084               IF (KMTS > 0) EXIT
085               KMTS = 1
086               NUM = KINT
087            ELSE
088               IF (NUM < KEXP) EXIT
089               IF (IFEXP > 0) EXIT
090               IFEXP = 1
091            END IF
092!
093! process decimal point
094!
095         CASE ('.')
096            IF (NUM /= KINT .AND. ICHR /= 1) EXIT
097            NUM = KFIX
098!
099! process exponent
100!
101         CASE ('e', 'E')
102            IF (NUM >= KEXP) EXIT
103            IF (NMTS == 0) EXIT
104            NUM = KEXP
105!
106         CASE ('d', 'D')
107            IF (NUM >= KEXP) EXIT
108            IF (NMTS == 0) EXIT
109            NUM = KDBL
110!
111! any other character means the string is non-numeric
112!
113         CASE DEFAULT
114            EXIT
115!
116         END SELECT
117      END DO
118!
119! if this point is reached, the string is non-numeric
120!
121      isnum = 0
122      RETURN
123END FUNCTION isnum
124SUBROUTINE obtfmt (ZVAL, zfmt)
125      USE CODNUM
126!  Find out what Fortran format was used to write a numerical value
127      CHARACTER (Len=*), INTENT (IN) :: ZVAL ! the string
128      CHARACTER (Len=*), INTENT (OUT) :: zfmt ! the format
129! ____________________________________________________
130      CHARACTER (Len=1) :: ZNUM0, ZNUM1, ZNUM2 ! to write the numbers
131                                          ! of digits of the integers
132                                          ! used in the format
133      CHARACTER (Len=27) :: ZFMTW ! The format to write the format ...
134      INTERFACE
135         INTEGER FUNCTION isnum (ZVAL)
136!  Verify that a string is numeric
137            CHARACTER (Len=*), INTENT (IN) :: ZVAL ! the string
138         END FUNCTION isnum
139!
140         INTEGER FUNCTION NBRCHF (JVAL)
141!  Number of characters (digits and minus sign) to display JVAL
142            INTEGER, INTENT (IN) :: JVAL ! the value
143         END FUNCTION NBRCHF
144      END INTERFACE
145!
146! initialise
147!
148      LVAL = LEN (ZVAL)
149      LFMT = LEN (zfmt)
150!
151!  Big switching place
152!
153      KASE = isnum (ZVAL)
154      SELECT CASE (KASE)
155!
156! non numeric (A Format)
157! ____________________________________________________
158!
159      CASE (0)
160         NCHR = LVAL
161         NCHR1 = NBRCHF (NCHR)
162!
163!    The format is (Axxx), we will write it with ('(A',Iw,')')
164!    Lets create the latter format, ZFMTW, with w = NCHR1
165!
166         IF (NCHR1+3 > LFMT) THEN
167            WRITE (*, *) "Argument string ZFMT too short"
168         ELSE
169            IF (NCHR1 > 0 .AND. NCHR1 < 10) THEN
170               WRITE (ZNUM1, "(I1)") NCHR1
171               ZFMTW = "('(A',I" // ZNUM1 // ",')')"
172               WRITE (zfmt, ZFMTW) NCHR
173            ELSE
174               WRITE (*, *) "Doesn't a string length of",&
175              & NCHR, " seem strange ?"
176            END IF
177         END IF
178!
179! integer
180! ____________________________________________________
181!
182      CASE (KINT)
183         NCHF = LEN_TRIM (ZVAL)
184!
185! If it looks too long, remove leading blanks
186!
187         IF (NCHF > 20) THEN
188            NCHF = LEN_TRIM (ADJUSTL(ZVAL))
189         END IF
190!
191         NCHR1 = NBRCHF (NCHF)
192!
193!    The format is (Ixxx), we will write it with  ('(I',Iw,')')
194!    Lets create the latter format, ZFMTW, with w = NCHR1
195!
196         IF (NCHR1+3 > LFMT) THEN
197            WRITE (*, *) "Argument string ZFMT too short"
198         ELSE
199            IF (NCHR1 > 0 .AND. NCHR1 < 10) THEN
200               WRITE (ZNUM1, "(I1)") NCHR1
201               ZFMTW = "('(I',I" // ZNUM1 // ",')')"
202               WRITE (zfmt, ZFMTW) NCHF
203            ELSE
204               WRITE (*, *) "isn't an integer of ", NCHF, "&
205              & digits a strange idea ?"
206            END IF
207         END IF
208!
209! real, fixed point form
210! ____________________________________________________
211!
212      CASE (KFIX)
213         NCHF = LEN_TRIM (ZVAL)
214         NCHFF = NCHF - INDEX (ZVAL, '.')
215!
216! If it looks too long, remove leading blanks
217!
218         IF (NCHF > 25) THEN
219            NCHF = LEN_TRIM (ADJUSTL(ZVAL))
220         END IF
221!
222         NCHR1 = NBRCHF (NCHF)
223         NCHR2 = NBRCHF (NCHFF)
224!
225!    The format is (Fxx.yy), we will write it with  ('(F',Iw,'.',Id,')')
226!    Lets create the latter format, ZFMTW, with w = NCHR1
227!    and d = NCHR2, obtained from the position of the decimal point
228!
229         IF (NCHR1+NCHR2+4 > LFMT) THEN
230            WRITE (*, *) "Argument string ZFMT too short"
231         ELSE
232            IF (NCHR1 > 0 .AND. NCHR1 < 10) THEN
233               WRITE (ZNUM1, "(I1)") NCHR1
234               WRITE (ZNUM2, "(I1)") NCHR2
235               ZFMTW = "('(F',I" // ZNUM1 // ",'.',I" // ZNUM2 //&
236              & ",')')"
237               WRITE (zfmt, ZFMTW) NCHF, NCHFF
238            ELSE
239               WRITE (*, *) "isn't a real of ", NCHF, "&
240              & digits a strange idea ?"
241            END IF
242         END IF
243!
244! real, exponent form
245! ____________________________________________________
246!
247      CASE (KEXP, KDBL)
248         NCHF = LEN_TRIM (ZVAL)
249         IF (KASE == 3) THEN
250            NCHFF = Max (INDEX(ZVAL, 'E'), INDEX(ZVAL, 'e')) - 1 -&
251           & INDEX (ZVAL, '.')
252         ELSE
253            NCHFF = Max (INDEX(ZVAL, 'D'), INDEX(ZVAL, 'd')) - 1 -&
254           & INDEX (ZVAL, '.')
255         END IF
256         IPNT = INDEX (ZVAL, '.')
257         IF (IPNT > 0) THEN
258            NCHFP = IPNT - VERIFY (ZVAL, " +-")
259         ELSE
260            NCHFP = NCHFF
261            NCHFF = 0
262         END IF
263!
264! If it looks too long, remove leading blanks
265!
266         IF (NCHF > 30) THEN
267            NCHF = LEN_TRIM (ADJUSTL(ZVAL))
268         END IF
269!
270         NCHR0 = NBRCHF (NCHFP)
271         NCHR1 = NBRCHF (NCHF)
272         NCHR2 = NBRCHF (NCHFF)
273!
274!    The chosen format is (zPExx.yy), we will write it with
275!     ('(',Ik,'PE',Iw,'.',Id,')')
276!    Lets create the latter format, ZFMTW, with
277!    k= NCHR0, w = NCHR1, d = NCHR2
278!
279         IF (NCHF+5 > LFMT) THEN
280            WRITE (*, *) "Argument string ZFMT too short"
281         ELSE
282            IF (NCHR1 > 0 .AND. NCHR1 < 10) THEN
283               WRITE (ZNUM0, "(I1)") NCHR0
284               WRITE (ZNUM1, "(I1)") NCHR1
285               WRITE (ZNUM2, "(I1)") NCHR2
286               IF (KASE == 3) THEN
287                  ZFMTW = "('(',I" // ZNUM0 // ",'PE',I" // ZNUM1 //&
288                 & ",'.',I" // ZNUM2 // ",')')"
289               ELSE
290                  ZFMTW = "('(',I" // ZNUM0 // ",'PD',I" // ZNUM1 //&
291                 & ",'.',I" // ZNUM2 // ",')')"
292               END IF
293               WRITE (zfmt, ZFMTW) NCHFP, NCHF, NCHFF
294            ELSE
295               WRITE (*, *) "isn't a real of ", NCHF, "&
296              & digits a strange idea ?"
297            END IF
298         END IF
299!
300!
301      CASE DEFAULT
302         WRITE (*, *) "Type ", KASE, " not known"
303!
304      END SELECT
305      RETURN
306END SUBROUTINE obtfmt
307INTEGER FUNCTION NBRCHF (JVAL)
308!  Number of characters (digits and minus sign) to display JVAL
309      INTEGER, INTENT (IN) :: JVAL ! the value
310! ____________________________________________________
311!
312! Compute with integers to avoid precision problems
313! with logarithms
314!
315! Start with 1, [+1 when negative]
316! ____________________________________________________
317!
318      IF (JVAL < 0) THEN
319         NCHF = 2
320         JVALA = - JVAL
321      ELSE
322         NCHF = 1
323         JVALA = JVAL
324      END IF
325!
326!         + 1 per overpassing of power of 10
327!
328      DO
329         IF (JVALA < 10) EXIT
330         JVALA = JVALA / 10
331         NCHF = NCHF + 1
332      END DO
333      NBRCHF = NCHF
334      RETURN
335END FUNCTION NBRCHF

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

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

分享到：           收藏
评论排行