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

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

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

Revision 1.11 - (hide annotations) (download)
Fri Sep 21 03:54:35 2001 UTC (22 years, 8 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 cnh 1.11 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 cnh 1.1
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 cnh 1.3 C-- IO_ERRCOUNT - Reads IO error counter.
12 cnh 1.1 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 cnh 1.11 CBOP
19     C !ROUTINE: DATE
20    
21     C !INTERFACE:
22 cnh 1.1 SUBROUTINE DATE ( string , myThreadId )
23 cnh 1.11 IMPLICIT NONE
24    
25     C !DESCRIPTION:
26     C *==========================================================*
27 cnh 1.1 C | SUBROUTINE DATE |
28     C | o Return current date |
29 cnh 1.11 C *==========================================================*
30    
31     C !USES:
32 cnh 1.1 #include "SIZE.h"
33     #include "EEPARAMS.h"
34 cnh 1.11
35     C !INPUT/OUTPUT PARAMETERS:
36     C string :: Date returned in string
37     C myThreadId :: My thread number
38 cnh 1.1 CHARACTER*(*) string
39     INTEGER myThreadId
40     C
41 cnh 1.11 C !LOCAL VARIABLES:
42     C lDate :: Length of date string
43     C msgBuffer :: Temp. for building error messages
44 cnh 1.1 INTEGER lDate
45     CHARACTER*(MAX_LEN_MBUF) msgBuffer
46 cnh 1.11 CEOP
47 cnh 1.1 C
48     lDate = 24
49     IF ( LEN(string) .LT. lDate ) GOTO 901
50     string = ' '
51 adcroft 1.7 #ifndef TARGET_T3E
52 heimbach 1.9 #ifndef TARGET_CRAY_VECTOR
53 cnh 1.1 CALL FDATE( string )
54 adcroft 1.7 #endif
55 heimbach 1.9 #endif
56 cnh 1.1 C
57     1000 CONTINUE
58     RETURN
59     901 CONTINUE
60     WRITE(msgBuffer,'(A)')
61     &' '
62 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
63     &SQUEEZE_RIGHT,myThreadId)
64 cnh 1.1 WRITE(msgBuffer,'(A)')
65     &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'
66 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
67     &SQUEEZE_RIGHT,myThreadId)
68 cnh 1.1 WRITE(msgBuffer,'(A)')
69     &'procedure: "DATE".'
70 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
71     &SQUEEZE_RIGHT,myThreadId)
72 cnh 1.1 WRITE(msgBuffer,'(A)')
73     &'Variable passed to S/R DATE is too small.'
74 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
75     &SQUEEZE_RIGHT,myThreadId)
76 cnh 1.1 WRITE(msgBuffer,'(A)')
77     &' Argument must be at least',lDate,'characters long.'
78 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
79     &SQUEEZE_RIGHT,myThreadId)
80 cnh 1.1 WRITE(msgBuffer,'(A)')
81     &'*******************************************************'
82 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
83     &SQUEEZE_RIGHT,myThreadId)
84 cnh 1.1 GOTO 1000
85     END
86    
87 cnh 1.11 CBOP
88     C !ROUTINE: IFNBLNK
89    
90     C !INTERFACE:
91 cnh 1.1 INTEGER FUNCTION IFNBLNK( string )
92 cnh 1.11 IMPLICIT NONE
93    
94     C !DESCRIPTION:
95     C *==========================================================*
96 cnh 1.1 C | FUNCTION IFNBLNK |
97     C | o Find first non-blank in character string. |
98 cnh 1.11 C *==========================================================*
99 cnh 1.1 C
100 cnh 1.11 C !INPUT PARAMETERS:
101     C string :: String to find first non-blank in.
102 cnh 1.1 CHARACTER*(*) string
103 cnh 1.11
104     C !LOCAL VARIABLES:
105     C L, LS :: Temps for string locations
106 cnh 1.1 INTEGER L, LS
107 cnh 1.11 CEOP
108 cnh 1.1 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 cnh 1.11 CBOP
122     C !ROUTINE: ILNBLNK
123    
124     C !INTERFACE:
125 cnh 1.1 INTEGER FUNCTION ILNBLNK( string )
126 cnh 1.11 IMPLICIT NONE
127    
128     C !DESCRIPTION:
129     C *==========================================================*
130 cnh 1.1 C | FUNCTION ILNBLNK |
131     C | o Find last non-blank in character string. |
132 cnh 1.11 C *==========================================================*
133    
134     C !INPUT PARAMETERS:
135     C string :: string to scan
136 cnh 1.1 CHARACTER*(*) string
137 cnh 1.11
138     C !LOCAL VARIABLES:
139     C L, LS :: Temps. used in scanning string
140 cnh 1.1 INTEGER L, LS
141 cnh 1.11 CEOP
142 cnh 1.1 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 cnh 1.3 RETURN
153     END
154    
155 cnh 1.11 CBOP
156     C !ROUTINE: IO_ERRCOUNT
157    
158     C !INTERFACE:
159 cnh 1.3 INTEGER FUNCTION IO_ERRCOUNT(myThid)
160 cnh 1.11 IMPLICIT NONE
161    
162     C !DESCRIPTION:
163     C *==========================================================*
164 cnh 1.3 C | FUNCTION IO_ERRCOUNT |
165     C | o Reads IO error counter. |
166 cnh 1.11 C *==========================================================*
167    
168     C !USES:
169 cnh 1.3 C == Global variables ==
170     #include "SIZE.h"
171     #include "EEPARAMS.h"
172    
173 cnh 1.11 C !INPUT PARAMETERS:
174 cnh 1.3 C == Routine arguments ==
175 cnh 1.11 C myThid :: My thread number
176 cnh 1.3 INTEGER myThid
177 cnh 1.11
178     CEOP
179 cnh 1.3
180     IO_ERRCOUNT = ioErrorCount(myThid)
181    
182 cnh 1.1 RETURN
183     END
184    
185 cnh 1.11 CBOP
186    
187     C !ROUTINE: LCASE
188    
189     C !INTERFACE:
190 cnh 1.1 SUBROUTINE LCASE ( string )
191 cnh 1.11 IMPLICIT NONE
192    
193     C !DESCRIPTION:
194     C *==========================================================*
195 cnh 1.1 C | SUBROUTINE LCASE |
196     C | o Convert character string to all lower case. |
197 cnh 1.11 C *==========================================================*
198    
199     C !INPUT/OUTPUT PARAMETERS:
200 cnh 1.1 CHARACTER*(*) string
201 cnh 1.11
202     C !LOCALVARIABLES:
203 cnh 1.1 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 cnh 1.11 CEOP
211    
212 cnh 1.1 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 cnh 1.11 CBOP
223     C !ROUTINE: MACHINE
224    
225     C !INTERFACE:
226 cnh 1.1 SUBROUTINE MACHINE ( string )
227 cnh 1.11 IMPLICIT NONE
228    
229     C !DESCRIPTION:
230     C *==========================================================*
231 cnh 1.1 C | SUBROUTINE MACHINE |
232     C | o Return computer identifier in string. |
233 cnh 1.11 C *==========================================================*
234    
235     C !USES:
236 cnh 1.1 #include "SIZE.h"
237     #include "EEPARAMS.h"
238     INTEGER IFNBLNK
239     INTEGER ILNBLNK
240     EXTERNAL IFNBLNK
241     EXTERNAL ILNBLNK
242 cnh 1.11
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 cnh 1.1 INTEGER iFirst
252     INTEGER iLast
253     INTEGER iEnd
254     INTEGER iFree
255     INTEGER idSize
256     CHARACTER*1024 strTmp
257     CHARACTER*1024 idString
258 cnh 1.11 CEOP
259 cnh 1.1
260     strTmp = 'UNKNOWN'
261     iFree = 1
262     idSize = LEN(string)
263 heimbach 1.9 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
264 adcroft 1.7 IFirst = 0
265     CALL PXFGETENV('USER',iFirst,strTmp,ILast,Iend )
266     #else
267 cnh 1.1 CALL GETENV('USER',strTmp )
268 adcroft 1.7 #endif
269 cnh 1.1 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 heimbach 1.9 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
284 adcroft 1.7 IFirst = 0
285     CALL PXFGETENV('HOST',iFirst,strTmp,ILast,Iend )
286     #else
287     CALL GETENV('HOST',strTmp )
288     #endif
289 cnh 1.1 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 cnh 1.11
307     CBOP
308     C !ROUTINE: UCASE
309    
310     C !INTERFACE:
311 cnh 1.1 SUBROUTINE UCASE ( string )
312 adcroft 1.6 IMPLICIT NONE
313 cnh 1.11
314     C !DESCRIPTION:
315 cnh 1.1 C Translate string to upper case.
316 cnh 1.11
317     C !INPUT/OUTPUT PARAMETERS:
318 cnh 1.1 CHARACTER*(*) string
319 cnh 1.11
320     C !LOCAL VARIABLES:
321 cnh 1.1 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 cnh 1.11 CEOP
329    
330 cnh 1.1 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