/[MITgcm]/MITgcm/optim/utils.F
ViewVC logotype

Contents of /MITgcm/optim/utils.F

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


Revision 1.3 - (show annotations) (download)
Tue Nov 11 20:38:27 2003 UTC (16 years, 6 months ago) by edhill
Branch: MAIN
CVS Tags: checkpoint62v, checkpoint57m_post, checkpoint52l_pre, checkpoint62u, hrcube4, hrcube5, checkpoint57g_pre, checkpoint62t, checkpoint57s_post, checkpoint58b_post, checkpoint57b_post, checkpoint52d_pre, checkpoint57g_post, checkpoint56b_post, checkpoint57y_post, checkpoint52j_pre, checkpoint65z, checkpoint65x, checkpoint65y, checkpoint54d_post, checkpoint65r, checkpoint65s, checkpoint65p, checkpoint65q, checkpoint65v, checkpoint65w, checkpoint65t, checkpoint65u, checkpoint65j, checkpoint65k, checkpoint65h, checkpoint65i, checkpoint65n, checkpoint54e_post, checkpoint65l, checkpoint65m, checkpoint65b, checkpoint65c, checkpoint65a, checkpoint65f, checkpoint65g, checkpoint65d, checkpoint65e, checkpoint62c, checkpoint57r_post, checkpoint57d_post, checkpoint57i_post, checkpoint52k_post, checkpoint59, checkpoint58, checkpoint55, checkpoint54, checkpoint57, checkpoint56, checkpoint53, checkpoint58f_post, checkpoint52f_post, checkpoint57n_post, checkpoint58d_post, checkpoint62s, checkpoint58a_post, checkpoint62r, checkpoint62q, checkpoint62p, checkpoint57z_post, checkpoint54f_post, checkpoint62a, checkpoint62g, checkpoint62f, checkpoint62e, checkpoint62d, checkpoint62k, checkpoint62j, checkpoint62i, checkpoint62h, checkpoint62o, checkpoint62n, checkpoint62m, checkpoint62l, checkpoint62w, checkpoint62z, checkpoint62y, checkpoint62x, checkpoint58y_post, checkpoint58t_post, checkpoint55i_post, checkpoint58m_post, checkpoint57l_post, checkpoint52i_pre, hrcube_1, hrcube_2, hrcube_3, checkpoint57t_post, checkpoint55c_post, checkpoint63g, checkpoint52e_pre, checkpoint57v_post, checkpoint57f_post, checkpoint52e_post, checkpoint53d_post, checkpoint64, checkpoint65, checkpoint60, checkpoint61, checkpoint62, checkpoint63, checkpoint57a_post, checkpoint57h_pre, checkpoint66g, checkpoint66f, checkpoint66e, checkpoint66d, checkpoint66c, checkpoint66b, checkpoint66a, checkpoint66o, checkpoint66n, checkpoint66m, checkpoint66l, checkpoint66k, checkpoint66j, checkpoint66i, checkpoint66h, checkpoint52b_pre, checkpoint54b_post, checkpoint58w_post, checkpoint57h_post, checkpoint52m_post, checkpoint57y_pre, checkpoint55g_post, checkpoint52b_post, checkpoint52c_post, checkpoint58o_post, checkpoint57c_post, checkpoint58p_post, checkpoint58q_post, checkpoint52f_pre, checkpoint55d_post, checkpoint58e_post, checkpoint54a_pre, checkpoint63p, checkpoint63q, checkpoint63r, checkpoint63s, checkpoint63l, checkpoint63m, checkpoint63n, checkpoint63o, checkpoint63h, checkpoint63i, checkpoint63j, checkpoint63k, checkpoint63d, checkpoint63e, checkpoint63f, checkpoint53c_post, checkpoint63a, checkpoint63b, checkpoint63c, checkpoint55d_pre, checkpoint57c_pre, checkpoint58r_post, checkpoint55j_post, checkpoint54a_post, checkpoint55h_post, checkpoint58n_post, checkpoint57e_post, checkpoint55b_post, checkpoint53a_post, checkpoint65o, checkpoint59q, checkpoint59p, checkpoint59r, checkpoint59e, checkpoint59d, checkpoint59g, checkpoint59f, checkpoint59a, checkpoint55f_post, checkpoint59c, checkpoint59b, checkpoint59m, checkpoint59l, checkpoint59o, checkpoint59n, checkpoint59i, checkpoint59h, checkpoint59k, checkpoint52d_post, checkpoint53g_post, checkpoint57p_post, checkpint57u_post, checkpoint57q_post, eckpoint57e_pre, checkpoint58k_post, checkpoint52a_pre, checkpoint62b, checkpoint58v_post, checkpoint52i_post, checkpoint52h_pre, checkpoint56a_post, checkpoint64y, checkpoint64x, checkpoint58l_post, checkpoint64z, checkpoint53f_post, checkpoint64q, checkpoint64p, checkpoint64s, checkpoint64r, checkpoint64u, checkpoint64t, checkpoint64w, checkpoint64v, checkpoint64i, checkpoint64h, checkpoint64k, checkpoint64j, checkpoint64m, checkpoint64l, checkpoint64o, checkpoint64n, checkpoint64a, checkpoint64c, checkpoint64b, checkpoint64e, checkpoint64d, checkpoint64g, checkpoint64f, checkpoint57h_done, checkpoint52j_post, checkpoint57j_post, checkpoint57f_pre, checkpoint61f, checkpoint58g_post, branch-netcdf, checkpoint52l_post, checkpoint58x_post, checkpoint61n, checkpoint52n_post, checkpoint53b_pre, checkpoint59j, checkpoint58h_post, checkpoint56c_post, checkpoint58j_post, checkpoint57a_pre, checkpoint55a_post, checkpoint57o_post, checkpoint61q, checkpoint57k_post, checkpoint53b_post, checkpoint52a_post, checkpoint57w_post, checkpoint61e, checkpoint58i_post, checkpoint57x_post, checkpoint58c_post, checkpoint58u_post, checkpoint53d_pre, checkpoint58s_post, checkpoint55e_post, checkpoint61g, checkpoint61d, checkpoint54c_post, checkpoint61b, checkpoint61c, checkpoint61a, checkpoint61o, checkpoint61l, checkpoint61m, checkpoint61j, checkpoint61k, checkpoint61h, checkpoint61i, checkpoint61v, checkpoint61w, checkpoint61t, checkpoint61u, checkpoint61r, checkpoint61s, checkpoint61p, checkpoint61z, checkpoint61x, checkpoint61y, HEAD
Branch point for: netcdf-sm0
Changes since 1.2: +2 -4 lines
 o add various compilation tests to genmake2 so that it acts more
   like a typical autoconf-generated "./configure" script:
   - HAVE_SYSTEM
   - HAVE_FDATE
   - FC_NAMEMANGLE.h
 o small code modifications to use the above #define-s

1 C $Header: /u/u3/gcmpack/MITgcm/optim/utils.F,v 1.2 2002/11/15 04:03:25 heimbach Exp $
2
3 #include "CPP_EEOPTIONS.h"
4
5 C-- File utils.F: General purpose support routines
6 C-- Contents
7 C-- U DATE - Returns date and time.
8 C-- IFNBLNK - Returns index of first non-blank string character.
9 C-- ILNBLNK - Returns index of last non-blank string character.
10 C-- IO_ERRCOUNT - Reads IO error counter.
11 C-- LCASE - Translates to lower case.
12 C--UM MACHINE - Returns character string identifying computer.
13 C-- UCASE - Translates to upper case.
14 C-- Routines marked "M" contain specific machine dependent code.
15 C-- Routines marked "U" contain UNIX OS calls.
16
17 CStartOfInterface
18 SUBROUTINE DATE ( string , myThreadId )
19 C /==========================================================\
20 C | SUBROUTINE DATE |
21 C | o Return current date |
22 C \==========================================================/
23 IMPLICIT NONE
24 #include "SIZE.h"
25 #include "EEPARAMS.h"
26 C
27 CHARACTER*(*) string
28 INTEGER myThreadId
29 CEndOfInterface
30 C
31 INTEGER lDate
32 CHARACTER*(MAX_LEN_MBUF) msgBuffer
33 C
34 lDate = 24
35 IF ( LEN(string) .LT. lDate ) GOTO 901
36 string = ' '
37 #ifdef HAVE_FDATE
38 CALL FDATE( string )
39 #endif
40 C
41 1000 CONTINUE
42 RETURN
43 901 CONTINUE
44 WRITE(msgBuffer,'(A)')
45 &' '
46 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
47 &SQUEEZE_RIGHT,myThreadId)
48 WRITE(msgBuffer,'(A)')
49 &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'
50 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
51 &SQUEEZE_RIGHT,myThreadId)
52 WRITE(msgBuffer,'(A)')
53 &'procedure: "DATE".'
54 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
55 &SQUEEZE_RIGHT,myThreadId)
56 WRITE(msgBuffer,'(A)')
57 &'Variable passed to S/R DATE is too small.'
58 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
59 &SQUEEZE_RIGHT,myThreadId)
60 WRITE(msgBuffer,'(A)')
61 &' Argument must be at least',lDate,'characters long.'
62 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
63 &SQUEEZE_RIGHT,myThreadId)
64 WRITE(msgBuffer,'(A)')
65 &'*******************************************************'
66 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
67 &SQUEEZE_RIGHT,myThreadId)
68 GOTO 1000
69 END
70
71 CStartOfInterface
72 INTEGER FUNCTION IFNBLNK( string )
73 C /==========================================================\
74 C | FUNCTION IFNBLNK |
75 C | o Find first non-blank in character string. |
76 C \==========================================================/
77 IMPLICIT NONE
78 C
79 CHARACTER*(*) string
80 CEndOfInterface
81 C
82 INTEGER L, LS
83 C
84 LS = LEN(string)
85 IFNBLNK = 0
86 DO 10 L = 1, LS
87 IF ( string(L:L) .EQ. ' ' ) GOTO 10
88 IFNBLNK = L
89 GOTO 11
90 10 CONTINUE
91 11 CONTINUE
92 C
93 RETURN
94 END
95
96 CStartOfInterface
97 INTEGER FUNCTION ILNBLNK( string )
98 C /==========================================================\
99 C | FUNCTION ILNBLNK |
100 C | o Find last non-blank in character string. |
101 C \==========================================================/
102 IMPLICIT NONE
103 CHARACTER*(*) string
104 CEndOfInterface
105 INTEGER L, LS
106 C
107 LS = LEN(string)
108 ILNBLNK = LS
109 DO 10 L = LS, 1, -1
110 IF ( string(L:L) .EQ. ' ' ) GOTO 10
111 ILNBLNK = L
112 GOTO 11
113 10 CONTINUE
114 11 CONTINUE
115 C
116 RETURN
117 END
118
119 CStartofinterface
120 INTEGER FUNCTION IO_ERRCOUNT(myThid)
121 C /==========================================================\
122 C | FUNCTION IO_ERRCOUNT |
123 C | o Reads IO error counter. |
124 C \==========================================================/
125 IMPLICIT NONE
126 C == Global variables ==
127 #include "SIZE.h"
128 #include "EEPARAMS.h"
129
130 C == Routine arguments ==
131 INTEGER myThid
132 CEndofinterface
133
134 IO_ERRCOUNT = ioErrorCount(myThid)
135
136 RETURN
137 END
138
139 CStartOfInterface
140 SUBROUTINE LCASE ( string )
141 C /==========================================================\
142 C | SUBROUTINE LCASE |
143 C | o Convert character string to all lower case. |
144 C \==========================================================/
145 IMPLICIT NONE
146 CHARACTER*(*) string
147 CEndOfInterface
148 CHARACTER*26 LOWER
149 DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
150 SAVE LOWER
151 CHARACTER*26 UPPER
152 DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
153 SAVE UPPER
154 INTEGER I, L
155 C
156 DO 10 I = 1, LEN(string)
157 L = INDEX(UPPER,string(I:I))
158 IF ( L .EQ. 0 ) GOTO 10
159 string(I:I) = LOWER(L:L)
160 10 CONTINUE
161 C
162 RETURN
163 END
164
165 CStartOfInterface
166 SUBROUTINE MACHINE ( string )
167 C /==========================================================\
168 C | SUBROUTINE MACHINE |
169 C | o Return computer identifier in string. |
170 C \==========================================================/
171 IMPLICIT NONE
172 #include "SIZE.h"
173 #include "EEPARAMS.h"
174 CHARACTER*(*) string
175 CEndOfInterface
176 C
177 INTEGER IFNBLNK
178 INTEGER ILNBLNK
179 EXTERNAL IFNBLNK
180 EXTERNAL ILNBLNK
181 C
182 INTEGER iFirst
183 INTEGER iLast
184 INTEGER iEnd
185 INTEGER iFree
186 INTEGER idSize
187 CHARACTER*1024 strTmp
188 CHARACTER*1024 idString
189
190 strTmp = 'UNKNOWN'
191 iFree = 1
192 idSize = LEN(string)
193 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
194 IFirst = 0
195 CALL PXFGETENV('USER',iFirst,strTmp,ILast,Iend )
196 #else
197 CALL GETENV('USER',strTmp )
198 #endif
199 IF ( strTmp .NE. ' ' ) THEN
200 iFirst = IFNBLNK(strTmp)
201 iLast = ILNBLNK(strTmp)
202 iEnd = iLast-iFirst+1
203 IF (iEnd .GE. 0 ) THEN
204 idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
205 ENDIF
206 iFree = iFree+iEnd+1
207 IF ( iFree .LE. idSize ) THEN
208 idString(iFree:iFree) = '@'
209 iFree = iFree+1
210 ENDIF
211 ENDIF
212 strTmp = 'UNKNOWN'
213 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
214 IFirst = 0
215 CALL PXFGETENV('HOST',iFirst,strTmp,ILast,Iend )
216 #else
217 CALL GETENV('HOST',strTmp )
218 #endif
219 IF ( strTmp .NE. ' ' ) THEN
220 iFirst = IFNBLNK(strTmp)
221 iLast = ILNBLNK(strTmp)
222 iEnd = iLast-iFirst+1
223 iEnd = MIN(iEnd,idSize-iFree)
224 iEnd = iEnd-1
225 IF (iEnd .GE. 0 ) THEN
226 idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
227 ENDIF
228 iFree = iFree+iEnd+1
229 ENDIF
230 C
231 string = idString
232 C
233 1000 CONTINUE
234 RETURN
235 END
236 C***********************************************************************
237 SUBROUTINE UCASE ( string )
238 IMPLICIT NONE
239 C Translate string to upper case.
240 CHARACTER*(*) string
241 CHARACTER*26 LOWER
242 DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
243 SAVE LOWER
244 CHARACTER*26 UPPER
245 DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
246 SAVE UPPER
247 INTEGER I, L
248 C
249 DO 10 I = 1, LEN(string)
250 L = INDEX(LOWER,string(I:I))
251 IF ( L .EQ. 0 ) GOTO 10
252 string(I:I) = UPPER(L:L)
253 10 CONTINUE
254 C
255 RETURN
256 END
257 C************************************************************************

  ViewVC Help
Powered by ViewVC 1.1.22