1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
SUBROUTINE CONECD (VAL,IOUT,NUSED)
C
C +-----------------------------------------------------------------+
C | |
C | Copyright (C) 1986 by UCAR |
C | University Corporation for Atmospheric Research |
C | All Rights Reserved |
C | |
C | NCARGRAPHICS Version 1.00 |
C | |
C +-----------------------------------------------------------------+
C
C
C
C ENCODE A NUMBER IN THE LEAST AMOUNT OF SPACE
C ON INPUT
C VAL THE NUMBER TO BE ENCODED
C ON OUTPUT
C IOUT CHARACTER STRING FILLED WITH THE ENCODED RESULT, MUST BE ABLE TO
C HOLD UP TO 9 CHARACTERS.
C
C NUSED NUMBER OF CHARACTERS IN IOUT
C
C VALUE INPUT WILL BE SCALED BY SCALE IN CONRA2
C
C
C
C
COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) ,
1 FINC ,HI ,FLO
COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS ,
1 ISCALE ,LOOK ,PLDVLS ,GRD ,
2 CINC ,CHILO ,CON ,LABON ,
3 PMIMX ,SCALE ,FRADV ,EXTRI ,
4 BPSIZ ,LISTOP
COMMON /CONRA3/ IREC
COMMON /CONRA4/ NCP ,NCPSZ
COMMON /CONRA5/ NIT ,ITIPV
COMMON /CONRA6/ XST ,YST ,XED ,YED ,
1 STPSZ ,IGRAD ,IG ,XRG ,
2 YRG ,BORD ,PXST ,PYST ,
3 PXED ,PYED ,ITICK
COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ
COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT ,
1 LEN ,IFMT ,LEND ,
2 IFMTD ,ISIZEP ,INMIN
COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR ,
1 BR ,TL ,BL ,CONV ,
2 XN ,YN ,ITLL ,IBLL ,
3 ITRL ,IBRL ,XC ,YC ,
4 ITLOC(210) ,JX ,JY ,ILOC ,
5 ISHFCT ,XO ,YO ,IOC ,NC
COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT ,
1 JWIWL ,JWIWP ,JWIPL ,IPR ,
2 ITPV
COMMON /CONR11/ NREP ,NCRT ,ISIZEL ,
1 MINGAP ,ISIZEM ,
2 TENS
COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX
LOGICAL REPEAT ,EXTRAP ,PER ,MESS ,
1 LOOK ,PLDVLS ,GRD ,LABON ,
2 PMIMX ,FRADV ,EXTRI ,CINC ,
3 TITLE ,LISTOP ,CHILO ,CON
COMMON /CONR15/ ISTRNG
CHARACTER*64 ISTRNG
COMMON /CONR16/ FORM
CHARACTER*10 FORM
COMMON /CONR17/ NDASH, IDASH, EDASH
CHARACTER*10 NDASH, IDASH, EDASH
C
C
CHARACTER*(*) IOUT
CHARACTER*6 IFMT1
C
C +NOAO - Variables CHTMP and IT are not used.
C
C CHARACTER*9 CHTMP
C CHARACTER*1 IT
C
C -NOAO
C
SAVE
C
V = VAL
C
C IF VAL EQUALS ZERO EASY PROCESSING
C
IF (V.NE.0.) GO TO 20
IOUT = '0.0'
NUSED = 3
RETURN
C
C SCALE VALUE
C
20 V = V*SCALE
C
C GET SIZE OF NUMBER
C
LOG = IFIX(ALOG10(ABS(V))+.1)
IF (IABS(LOG).GT.4) GO TO 60
C
C COMPUTE FLOATING POINT FIELD
C
NS = IABS(LOG)+3
ND = 1
IF (LOG.GT.0) GO TO 40
C
C LOG = 0 TEST FOR FRACTIONAL PART ONLY
C
IF (ALOG10( ABS(V) ).GE.0.) GO TO 30
C
C NUMBER LT 1 BUT GREATER THAN ZERO IN ABSOLUTE VALUE
C
NS = 4
ND = 1
GO TO 40
C
C NUMBER LESS THAN 10 BUT GE 1
C
30 ND = 1
NS = 4
C
C BUILD THE FORMAT
C
40 IF (V.LT.0) NS = NS+1
IFMT1 = '(F . )'
C
C INSERT THE FLOATING POINT FORMAT SIZE
C
C +NOAO - Scheme for creating format has been modified because it uses
C FTN internal writes. NOAO mods are written in lower case.
C
C WRITE(IT,'(I1)')NS
C IFMT1(3:3) = IT
C WRITE(IT,'(I1)')ND
C IFMT1(5:5) = IT
C
ifmt1(1:6) = '(f . )'
ifmt1(3:3) = char (ns + ichar ('0') + 1)
ifmt1(5:5) = char (nd + ichar ('0'))
C
C ENCODE THE DESIRED NUMBER
C
C WRITE(CHTMP,IFMT1)V
C IOUT = CHTMP
C
call encode (ns, ifmt1, iout, v)
NUSED = NS
RETURN
C
C DATA LARGER THAN A NICE SIZE FORCE IT TO BE ENCODED
C
C 60 WRITE(CHTMP,'(E8.3)')V
C IOUT = CHTMP
C
60 call encode (8, '(E8.3)', iout, v)
C
C -NOAO
NUSED = 8
RETURN
C
C******************************************************************
C* *
C* REVISION HISTORY *
C* *
C* JUNE 1980 ADDED CONCOM TO ULIB *
C* AUGUST 1980 FIXED BOARDER CONTOUR DETECTION *
C* DECEMBER 1980 FIXED ERROR TRAP, CONTOUR REORDERING ALGORITHM *
C* AND ERROR MESSAGE 10 *
C* AUGUST 1983 ADDED LINEAR INTERPOLATION AND SHIELDING *
C* JULY 1984 CONVERTED TO FORTRAN77 AND GKS *
C* AUGUST 1985 DELETED (MACHINE DEPENDENT) FUNCTION LOC; CHANGED *
C* COMMON /CONR13/ *
C* *
C******************************************************************
C
END
|
