1*-----------------------------------------------------------------------
2*     CHVAL
3*-----------------------------------------------------------------------
4*     Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved.
5*-----------------------------------------------------------------------
6      SUBROUTINE CHVAL(CFMT,VAL,CVAL)
7
8*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
9*
10*     THIS ROUTINE RETURNS CHARACTERIZED VALUE "CVAL" OF "VAL" USING
11*     USER SPECIFIED FORMAT "CFMT". IF ONE OF THE FOLLOWING OPTINONS IS
12*     SPECIFIED AS "CFMT", FORMAT WILL BE GENERATED AUTOMATICALLY TO
13*     REPRESENT 3 SIGNIFICANT DIGITS.
14*
15*     CFMT   (C*(*)) : FORMAT OR OPTION NAME (I/ ).
16*                    : FORMAT SHOULD BEGIN WITH '('.
17*                    : ONE OF THE FOLLOWING OPTIONS CAN BE SPECIFIED.
18*                    : 'A' - FORMAT IS SET AUTOMATICALLY.
19*                    : 'B' - 'A' AND TRAILING ZERO AND DECIMAL POINT ARE
20*                    :       DELETED.
21*                    : 'C' - 'B' AND ZERO BEFORE DECIMAL POINT AND '+'
22*                    :       ARE DELETED.
23*                    : 'D' - 'C' BUT ONLY FOR THE EXPONENT TYPE.
24*     VAL    (R)     : NUMERIC VALUE THAT SHOULD BE CHARACTERIZED (I/ ).
25*     CVAL   (C*(*)) : CHARACTERIZED VALUE OF "VAL" ( /O).
26*                    : LEN(CVAL) SHOULD BE 8 OR MORE.
27*
28*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
29
30      CHARACTER CFMT*(*),CVAL*(*)
31
32      CHARACTER CFMTX*16,CHX*16,CF*1,COPT*3
33      LOGICAL   LFRST,LCHREQ,LON,LAT
34
35      SAVE
36
37      EXTERNAL  LCHREQ,LENC,INDXCF,RMOD
38
39      DATA      LFRST/.TRUE./
40
41
42*     / CHECK LENGTH OF OUTPUT CHARACTER /
43
44      IF (LEN(CVAL).LT.8 .AND. LFRST) THEN
45        CALL MSGDMP('W','CHVAL ','LENGTH OF CHARACTER IS LESS THAN 8.')
46        LFRST=.FALSE.
47      END IF
48
49*     / CHECK MAIN OPTION /
50
51      CF=CFMT(1:1)
52      CALL CUPPER(CF)
53
54*     / CHECK SUB OPTION /
55
56      NC=LENC(CFMT)
57      LON=.FALSE.
58      LAT=.FALSE.
59      IF (NC.GE.3) THEN
60        IF (CFMT(2:2).EQ.'+') THEN
61          COPT=CFMT(3:NC)
62          IF (LCHREQ(COPT,'X') .OR. LCHREQ(COPT,'LON')) THEN
63            LON=.TRUE.
64          ELSE IF (LCHREQ(COPT,'Y') .OR. LCHREQ(COPT,'LAT')) THEN
65            LAT=.TRUE.
66          END IF
67        END IF
68      END IF
69
70      IF (CF.NE.'(') THEN
71
72*       / LONGITUDE (X) OR LATITUDE (Y) OPTION /
73
74        IF (LON) THEN
75          VALZ=RMOD(VAL+180,360.0)-180
76        ELSE IF (LAT) THEN
77          VALZ=VAL
78        ELSE
79          VALZ=VAL
80        END IF
81
82*       / AUTOMATIC GENERATION (NOT USER FORMAT) /
83
84*       / PICK UP 3 SIGNIFICANT DIGITS AND EXPONENT /
85
86        CFMTX='(1P,E9.2E2)'
87        WRITE(CHX,CFMTX) VALZ
88        READ(CHX(7:9),'(I3)') IE
89        READ(CHX(1:5),'(F5.2)') RB
90        VALX=RB*10.0**IE
91
92*       / FORMAT /
93
94        IF (0.LE.IE .AND. IE.LE.2) THEN
95
96*         / DECIMAL /
97
98          CFMTX='(F6. )'
99          WRITE(CFMTX(5:5),'(I1)') 2-IE
100
101        ELSE IF (3.LE.IE .AND. IE.LE.4) THEN
102
103*         / INTEGER /
104
105          CFMTX='(I6)'
106
107        ELSE IF (-3.LE.IE .AND. IE.LE.-1) THEN
108
109*         / DECIMAL OR EXPONENT /
110
111*         / COUNT TRAILING ZERO /
112
113          NZ=0
114   10     IF (.NOT.(CHX(5-NZ:5-NZ).EQ.'0')) GO TO 15
115            NZ=NZ+1
116            GO TO 10
117   15     CONTINUE
118
119*         / IF -IE .LE. TRAILING ZERO +1 THEN DECIMAL ELSE EXPONENT /
120
121          IF (-IE.LE.NZ) THEN
122            CFMTX='(F6.2)'
123          ELSE IF (-IE.LE.NZ+1) THEN
124            CFMTX='(F6.3)'
125          ELSE
126            CFMTX='(1P,E8.2E1)'
127          END IF
128
129        ELSE IF (-9.LE.IE .AND. IE.LE.9) THEN
130
131*         / EXPONENT ( SIGNIFICANT DIGITS = 3 ) /
132
133          CFMTX='(1P,E8.2E1)'
134
135        ELSE
136
137*         / EXPONENT ( SIGNIFICANT DIGITS = 2 ) /
138
139          CFMTX='(1P,E8.1E2)'
140
141        END IF
142
143      ELSE
144
145*       / USER FORMAT /
146
147        CFMTX=CFMT
148        VALX=VAL
149
150      END IF
151
152*     / ENCODING /
153
154      CHX=' '
155      IF (LCHREQ(CFMTX(2:2),'I')) THEN
156        WRITE(CHX,CFMTX) NINT(VALX)
157      ELSE
158        WRITE(CHX,CFMTX) VALX
159      END IF
160
161*     / CHECK BLANK BEFORE DECIMAL POINT (SYSTEM DEPENDENT) /
162
163      IDXDC=INDXCF(CHX,LENC(CHX),1,'.')
164      IF (IDXDC.NE.0) THEN
165        ID1=IDXDC-1
166        IF (CHX(ID1:ID1).EQ.' ') THEN
167          CHX(ID1:ID1)='0'
168        ELSE IF (CHX(ID1:ID1).EQ.'-') THEN
169          CHX(ID1-1:ID1)='-0'
170        END IF
171      END IF
172
173*     / LEFT ADJUST /
174
175      CALL CLADJ(CHX)
176      NC=LENC(CHX)
177      IF (CHX(1:1).EQ.'+') THEN
178        CVAL(1:NC-1)=CHX(2:NC)
179        NC=NC-1
180        CHX=CVAL(1:NC)
181      END IF
182
183*     / OPTION /
184
185      IF (((CF.EQ.'B' .OR. CF.EQ.'C') .AND. INDXCF(CHX,NC,1,'.').NE.0)
186     +  .OR. (CF.EQ.'D' .AND. INDXCF(CHX,NC,1,'E').NE.0)) THEN
187
188*       / DELETE TRAILING ZERO AND DECIMAL POINT /
189
190*       / CHECK EXPONENT OR DECIMAL /
191
192        IDE=INDXCF(CHX,NC,1,'E')
193        IF (IDE.EQ.0) THEN
194*         / DECIMAL /
195          MC=NC
196        ELSE
197*         / EXPONENT /
198          MC=IDE-1
199        END IF
200
201*       / COUNT TRAILING ZERO /
202
203   25   IF (.NOT.(CHX(MC:MC).EQ.'0')) GO TO 20
204          MC=MC-1
205          GO TO 25
206   20   CONTINUE
207
208*       / CHECK DECIMAL POINT /
209
210        IF (CHX(MC:MC).EQ.'.') THEN
211          MC=MC-1
212        END IF
213
214*       / AVAILABLE LENGTH /
215
216        IF (IDE.EQ.0) THEN
217          NC=MC
218        ELSE
219          CVAL=CHX(1:MC)//CHX(IDE:NC)
220          NC=MC+NC-IDE+1
221          CHX(1:NC)=CVAL(1:NC)
222        END IF
223
224*       / 'C' & 'D' OPTION /
225
226        IF ((CF.EQ.'C' .OR. CF.EQ.'D') .AND. NC.GT.1) THEN
227
228*         / DELETE ZERO BEFORE DECIMAL POINT /
229
230          IF (CHX(1:1).EQ.'0') THEN
231            CVAL=CHX(2:NC)
232            NC=NC-1
233            CHX(1:NC)=CVAL(1:NC)
234          ELSE IF (CHX(1:1).EQ.'-' .AND. CHX(2:2).EQ.'0') THEN
235            CVAL=CHX(1:1)//CHX(3:NC)
236            NC=NC-1
237            CHX(1:NC)=CVAL(1:NC)
238          END IF
239
240*         / DELETE '+' IN EXPONENT PART /
241
242          IDP=INDXCF(CHX,NC,1,'+')
243          IF (IDP.NE.0) THEN
244            CVAL(1:NC-1)=CHX(1:IDP-1)//CHX(IDP+1:NC)
245            NC=NC-1
246            CHX(1:NC)=CVAL(1:NC)
247          END IF
248
249        END IF
250
251      END IF
252
253*     / RETURN CHARACTER /
254
255      IF (CF.NE.'(') THEN
256        IF (LON) THEN
257          IF (VALZ.EQ.0 .OR. VALZ.EQ.-180) THEN
258            IF (VALZ.EQ.0) THEN
259              CVAL=CHX(1:NC)
260            ELSE IF (VALZ.EQ.-180) THEN
261              CVAL=CHX(2:NC)
262            END IF
263          ELSE
264            IF (CHX(1:1).EQ.'-') THEN
265              CVAL=CHX(2:NC)//'W'
266            ELSE
267              CVAL=CHX(1:NC)//'E'
268            END IF
269          END IF
270        ELSE IF (LAT) THEN
271          IF (VALZ.EQ.0) THEN
272*           CVAL=CHX(1:NC)
273            CVAL='EQ'
274          ELSE
275            IF (CHX(1:1).EQ.'-') THEN
276              CVAL=CHX(2:NC)//'S'
277            ELSE
278              CVAL=CHX(1:NC)//'N'
279            END IF
280          END IF
281        ELSE
282          CVAL=CHX(1:NC)
283          CALL CLOWER(CVAL)
284        END IF
285      ELSE
286        CVAL=CHX(1:NC)
287        CALL CLOWER(CVAL)
288      END IF
289
290      END
291