/[MITgcm]/MITgcm/eesupp/src/utils.F
ViewVC logotype

Contents of /MITgcm/eesupp/src/utils.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph

Revision 1.11 - (show annotations) (download)
Fri Sep 21 03:54:35 2001 UTC (22 years, 7 months ago) by cnh
Branch: MAIN
CVS Tags: checkpoint46n_post, checkpoint47e_post, checkpoint44e_post, checkpoint46l_post, checkpoint46g_pre, checkpoint47c_post, release1_p13_pre, checkpoint50c_post, checkpoint46f_post, checkpoint48e_post, checkpoint50c_pre, checkpoint44f_post, checkpoint46b_post, checkpoint43a-release1mods, ecco_c50_e32, ecco_c50_e33, ecco_c50_e30, ecco_c50_e31, release1_p13, checkpoint48i_post, checkpoint46l_pre, chkpt44d_post, checkpoint51, checkpoint50, release1_p8, release1_p9, checkpoint50d_post, release1_p1, release1_p2, release1_p3, release1_p4, release1_p5, release1_p6, release1_p7, checkpoint50b_pre, checkpoint44e_pre, release1_b1, ecco_c51_e34a, ecco_c51_e34b, ecco_c51_e34c, checkpoint48b_post, checkpoint43, checkpoint48c_pre, checkpoint47d_pre, release1_chkpt44d_post, checkpoint47a_post, checkpoint48d_pre, checkpoint47i_post, release1_p11, checkpoint47d_post, icebear5, icebear4, icebear3, icebear2, checkpoint46d_pre, checkpoint48d_post, release1-branch_tutorials, checkpoint48f_post, checkpoint45d_post, checkpoint46j_pre, chkpt44a_post, checkpoint44h_pre, checkpoint48h_post, ecco_c50_e29, checkpoint51b_pre, checkpoint46a_post, checkpoint47g_post, checkpoint46j_post, checkpoint46k_post, ecco_c50_e28, chkpt44c_pre, checkpoint48a_post, checkpoint45a_post, checkpoint50f_post, checkpoint50a_post, checkpoint50f_pre, ecco_c44_e19, ecco_c44_e18, ecco_c44_e17, ecco_c44_e16, release1_p12, release1_p10, release1_p16, release1_p17, release1_p14, release1_p15, checkpoint47j_post, ecco_c50_e33a, branch-exfmods-tag, checkpoint44g_post, checkpoint46e_pre, checkpoint48c_post, checkpoint45b_post, checkpoint46b_pre, release1-branch-end, release1_final_v1, checkpoint51b_post, checkpoint51c_post, checkpoint46c_pre, checkpoint46, checkpoint47b_post, checkpoint44b_post, ecco_c51_e34, checkpoint46h_pre, checkpoint46m_post, checkpoint46a_pre, checkpoint50g_post, checkpoint45c_post, ecco_ice2, ecco_ice1, checkpoint44h_post, checkpoint46g_post, release1_p12_pre, ecco_c44_e22, checkpoint50h_post, checkpoint50e_pre, checkpoint50i_post, ecco_c44_e25, checkpoint47f_post, checkpoint50e_post, chkpt44a_pre, checkpoint46i_post, ecco_c44_e23, ecco_c44_e20, ecco_c44_e21, ecco_c44_e26, ecco_c44_e27, ecco_c44_e24, checkpoint46c_post, ecco-branch-mod1, ecco-branch-mod2, ecco-branch-mod3, ecco-branch-mod4, ecco-branch-mod5, checkpoint50d_pre, checkpoint46e_post, release1_beta1, checkpoint44b_pre, checkpoint42, checkpoint41, checkpoint47, checkpoint44, checkpoint45, checkpoint48, checkpoint49, checkpoint46h_post, chkpt44c_post, checkpoint48g_post, checkpoint47h_post, checkpoint44f_pre, checkpoint46d_post, checkpoint50b_post, release1-branch_branchpoint, checkpoint51a_post
Branch point for: c24_e25_ice, branch-exfmods-curt, release1_final, release1-branch, release1, ecco-branch, release1_50yr, icebear, release1_coupled
Changes since 1.10: +117 -38 lines 
Starting to bring comments up to date and format comments
for document extraction of "prototypes".
1 C $Header: /u/gcmpack/models/MITgcmUV/eesupp/src/utils.F,v 1.10 2001/02/04 14:38:44 cnh Exp $
2 C $Name: $
3
4 #include "CPP_EEOPTIONS.h"
5
6 C-- File utils.F: General purpose support routines
7 C-- Contents
8 C-- U DATE - Returns date and time.
9 C-- IFNBLNK - Returns index of first non-blank string character.
10 C-- ILNBLNK - Returns index of last non-blank string character.
11 C-- IO_ERRCOUNT - Reads IO error counter.
12 C-- LCASE - Translates to lower case.
13 C--UM MACHINE - Returns character string identifying computer.
14 C-- UCASE - Translates to upper case.
15 C-- Routines marked "M" contain specific machine dependent code.
16 C-- Routines marked "U" contain UNIX OS calls.
17
18 CBOP
19 C !ROUTINE: DATE
20
21 C !INTERFACE:
22 SUBROUTINE DATE ( string , myThreadId )
23 IMPLICIT NONE
24
25 C !DESCRIPTION:
26 C *==========================================================*
27 C | SUBROUTINE DATE |
28 C | o Return current date |
29 C *==========================================================*
30
31 C !USES:
32 #include "SIZE.h"
33 #include "EEPARAMS.h"
34
35 C !INPUT/OUTPUT PARAMETERS:
36 C string :: Date returned in string
37 C myThreadId :: My thread number
38 CHARACTER*(*) string
39 INTEGER myThreadId
40 C
41 C !LOCAL VARIABLES:
42 C lDate :: Length of date string
43 C msgBuffer :: Temp. for building error messages
44 INTEGER lDate
45 CHARACTER*(MAX_LEN_MBUF) msgBuffer
46 CEOP
47 C
48 lDate = 24
49 IF ( LEN(string) .LT. lDate ) GOTO 901
50 string = ' '
51 #ifndef TARGET_T3E
52 #ifndef TARGET_CRAY_VECTOR
53 CALL FDATE( string )
54 #endif
55 #endif
56 C
57 1000 CONTINUE
58 RETURN
59 901 CONTINUE
60 WRITE(msgBuffer,'(A)')
61 &' '
62 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
63 &SQUEEZE_RIGHT,myThreadId)
64 WRITE(msgBuffer,'(A)')
65 &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'
66 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
67 &SQUEEZE_RIGHT,myThreadId)
68 WRITE(msgBuffer,'(A)')
69 &'procedure: "DATE".'
70 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
71 &SQUEEZE_RIGHT,myThreadId)
72 WRITE(msgBuffer,'(A)')
73 &'Variable passed to S/R DATE is too small.'
74 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
75 &SQUEEZE_RIGHT,myThreadId)
76 WRITE(msgBuffer,'(A)')
77 &' Argument must be at least',lDate,'characters long.'
78 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
79 &SQUEEZE_RIGHT,myThreadId)
80 WRITE(msgBuffer,'(A)')
81 &'*******************************************************'
82 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
83 &SQUEEZE_RIGHT,myThreadId)
84 GOTO 1000
85 END
86
87 CBOP
88 C !ROUTINE: IFNBLNK
89
90 C !INTERFACE:
91 INTEGER FUNCTION IFNBLNK( string )
92 IMPLICIT NONE
93
94 C !DESCRIPTION:
95 C *==========================================================*
96 C | FUNCTION IFNBLNK |
97 C | o Find first non-blank in character string. |
98 C *==========================================================*
99 C
100 C !INPUT PARAMETERS:
101 C string :: String to find first non-blank in.
102 CHARACTER*(*) string
103
104 C !LOCAL VARIABLES:
105 C L, LS :: Temps for string locations
106 INTEGER L, LS
107 CEOP
108 C
109 LS = LEN(string)
110 IFNBLNK = 0
111 DO 10 L = 1, LS
112 IF ( string(L:L) .EQ. ' ' ) GOTO 10
113 IFNBLNK = L
114 GOTO 11
115 10 CONTINUE
116 11 CONTINUE
117 C
118 RETURN
119 END
120
121 CBOP
122 C !ROUTINE: ILNBLNK
123
124 C !INTERFACE:
125 INTEGER FUNCTION ILNBLNK( string )
126 IMPLICIT NONE
127
128 C !DESCRIPTION:
129 C *==========================================================*
130 C | FUNCTION ILNBLNK |
131 C | o Find last non-blank in character string. |
132 C *==========================================================*
133
134 C !INPUT PARAMETERS:
135 C string :: string to scan
136 CHARACTER*(*) string
137
138 C !LOCAL VARIABLES:
139 C L, LS :: Temps. used in scanning string
140 INTEGER L, LS
141 CEOP
142 C
143 LS = LEN(string)
144 ILNBLNK = LS
145 DO 10 L = LS, 1, -1
146 IF ( string(L:L) .EQ. ' ' ) GOTO 10
147 ILNBLNK = L
148 GOTO 11
149 10 CONTINUE
150 11 CONTINUE
151 C
152 RETURN
153 END
154
155 CBOP
156 C !ROUTINE: IO_ERRCOUNT
157
158 C !INTERFACE:
159 INTEGER FUNCTION IO_ERRCOUNT(myThid)
160 IMPLICIT NONE
161
162 C !DESCRIPTION:
163 C *==========================================================*
164 C | FUNCTION IO_ERRCOUNT |
165 C | o Reads IO error counter. |
166 C *==========================================================*
167
168 C !USES:
169 C == Global variables ==
170 #include "SIZE.h"
171 #include "EEPARAMS.h"
172
173 C !INPUT PARAMETERS:
174 C == Routine arguments ==
175 C myThid :: My thread number
176 INTEGER myThid
177
178 CEOP
179
180 IO_ERRCOUNT = ioErrorCount(myThid)
181
182 RETURN
183 END
184
185 CBOP
186
187 C !ROUTINE: LCASE
188
189 C !INTERFACE:
190 SUBROUTINE LCASE ( string )
191 IMPLICIT NONE
192
193 C !DESCRIPTION:
194 C *==========================================================*
195 C | SUBROUTINE LCASE |
196 C | o Convert character string to all lower case. |
197 C *==========================================================*
198
199 C !INPUT/OUTPUT PARAMETERS:
200 CHARACTER*(*) string
201
202 C !LOCALVARIABLES:
203 CHARACTER*26 LOWER
204 DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
205 SAVE LOWER
206 CHARACTER*26 UPPER
207 DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
208 SAVE UPPER
209 INTEGER I, L
210 CEOP
211
212 C
213 DO 10 I = 1, LEN(string)
214 L = INDEX(UPPER,string(I:I))
215 IF ( L .EQ. 0 ) GOTO 10
216 string(I:I) = LOWER(L:L)
217 10 CONTINUE
218 C
219 RETURN
220 END
221
222 CBOP
223 C !ROUTINE: MACHINE
224
225 C !INTERFACE:
226 SUBROUTINE MACHINE ( string )
227 IMPLICIT NONE
228
229 C !DESCRIPTION:
230 C *==========================================================*
231 C | SUBROUTINE MACHINE |
232 C | o Return computer identifier in string. |
233 C *==========================================================*
234
235 C !USES:
236 #include "SIZE.h"
237 #include "EEPARAMS.h"
238 INTEGER IFNBLNK
239 INTEGER ILNBLNK
240 EXTERNAL IFNBLNK
241 EXTERNAL ILNBLNK
242
243 C !OUTPUT PARAMETERS:
244 C string :: Machine identifier
245 CHARACTER*(*) string
246
247 C !LOCAL VARIABLES:
248 C iFirst, iLast, :: String indexing temps.
249 C iEnd, iFree, idSize
250 C strTmp, idString :: Temps. for strings.
251 INTEGER iFirst
252 INTEGER iLast
253 INTEGER iEnd
254 INTEGER iFree
255 INTEGER idSize
256 CHARACTER*1024 strTmp
257 CHARACTER*1024 idString
258 CEOP
259
260 strTmp = 'UNKNOWN'
261 iFree = 1
262 idSize = LEN(string)
263 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
264 IFirst = 0
265 CALL PXFGETENV('USER',iFirst,strTmp,ILast,Iend )
266 #else
267 CALL GETENV('USER',strTmp )
268 #endif
269 IF ( strTmp .NE. ' ' ) THEN
270 iFirst = IFNBLNK(strTmp)
271 iLast = ILNBLNK(strTmp)
272 iEnd = iLast-iFirst+1
273 IF (iEnd .GE. 0 ) THEN
274 idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
275 ENDIF
276 iFree = iFree+iEnd+1
277 IF ( iFree .LE. idSize ) THEN
278 idString(iFree:iFree) = '@'
279 iFree = iFree+1
280 ENDIF
281 ENDIF
282 strTmp = 'UNKNOWN'
283 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
284 IFirst = 0
285 CALL PXFGETENV('HOST',iFirst,strTmp,ILast,Iend )
286 #else
287 CALL GETENV('HOST',strTmp )
288 #endif
289 IF ( strTmp .NE. ' ' ) THEN
290 iFirst = IFNBLNK(strTmp)
291 iLast = ILNBLNK(strTmp)
292 iEnd = iLast-iFirst+1
293 iEnd = MIN(iEnd,idSize-iFree)
294 iEnd = iEnd-1
295 IF (iEnd .GE. 0 ) THEN
296 idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
297 ENDIF
298 iFree = iFree+iEnd+1
299 ENDIF
300 C
301 string = idString
302 C
303 1000 CONTINUE
304 RETURN
305 END
306
307 CBOP
308 C !ROUTINE: UCASE
309
310 C !INTERFACE:
311 SUBROUTINE UCASE ( string )
312 IMPLICIT NONE
313
314 C !DESCRIPTION:
315 C Translate string to upper case.
316
317 C !INPUT/OUTPUT PARAMETERS:
318 CHARACTER*(*) string
319
320 C !LOCAL VARIABLES:
321 CHARACTER*26 LOWER
322 DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
323 SAVE LOWER
324 CHARACTER*26 UPPER
325 DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
326 SAVE UPPER
327 INTEGER I, L
328 CEOP
329
330 C
331 DO 10 I = 1, LEN(string)
332 L = INDEX(LOWER,string(I:I))
333 IF ( L .EQ. 0 ) GOTO 10
334 string(I:I) = UPPER(L:L)
335 10 CONTINUE
336 C
337 RETURN
338 END
339 C************************************************************************
  ViewVC Help
Powered by ViewVC 1.1.22