/[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.2 - (show annotations) (download)
Fri Nov 15 04:03:25 2002 UTC (21 years, 5 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint51k_post, checkpoint47e_post, checkpoint47c_post, checkpoint50c_post, checkpoint48e_post, checkpoint50c_pre, checkpoint51o_pre, checkpoint51l_post, checkpoint48i_post, checkpoint50d_pre, checkpoint51, checkpoint50, checkpoint52, checkpoint50d_post, checkpoint50b_pre, checkpoint51f_post, checkpoint48b_post, checkpoint51d_post, checkpoint48c_pre, checkpoint47d_pre, checkpoint51t_post, checkpoint51n_post, checkpoint51s_post, checkpoint47a_post, checkpoint48d_pre, checkpoint51j_post, checkpoint47i_post, checkpoint51n_pre, checkpoint47d_post, checkpoint48d_post, checkpoint48f_post, checkpoint51l_pre, checkpoint48h_post, checkpoint51q_post, checkpoint51b_pre, checkpoint47g_post, checkpoint51h_pre, checkpoint48a_post, checkpoint50f_post, checkpoint50a_post, checkpoint50f_pre, checkpoint47j_post, branch-exfmods-tag, branchpoint-genmake2, checkpoint51r_post, checkpoint48c_post, checkpoint51i_post, checkpoint51b_post, checkpoint51c_post, checkpoint47b_post, checkpoint50g_post, checkpoint50h_post, checkpoint50e_pre, checkpoint50i_post, checkpoint51i_pre, checkpoint47f_post, checkpoint50e_post, checkpoint51e_post, checkpoint47, checkpoint48, checkpoint49, checkpoint51o_post, checkpoint51f_pre, checkpoint48g_post, checkpoint47h_post, checkpoint51g_post, ecco_c52_e35, checkpoint50b_post, checkpoint51m_post, checkpoint51a_post, checkpoint51p_post, checkpoint51u_post
Branch point for: branch-exfmods-curt, branch-genmake2, branch-nonh, tg2-branch, checkpoint51n_branch
Changes since 1.1: +259 -0 lines 
o Incorporating QNVS line search routines into MITgcm
  (this is separate code, not compiled with MITgcm,
  and therefore not under pkg)
  - lsopt/
  - optim/
1 C $Header: /u/gcmpack/MITgcm/optim/Attic/utils.F,v 1.1.2.1 2002/02/05 20:34:35 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 #ifndef TARGET_T3E
38 #ifndef TARGET_CRAY_VECTOR
39 CALL FDATE( string )
40 #endif
41 #endif
42 C
43 1000 CONTINUE
44 RETURN
45 901 CONTINUE
46 WRITE(msgBuffer,'(A)')
47 &' '
48 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
49 &SQUEEZE_RIGHT,myThreadId)
50 WRITE(msgBuffer,'(A)')
51 &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'
52 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
53 &SQUEEZE_RIGHT,myThreadId)
54 WRITE(msgBuffer,'(A)')
55 &'procedure: "DATE".'
56 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
57 &SQUEEZE_RIGHT,myThreadId)
58 WRITE(msgBuffer,'(A)')
59 &'Variable passed to S/R DATE is too small.'
60 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
61 &SQUEEZE_RIGHT,myThreadId)
62 WRITE(msgBuffer,'(A)')
63 &' Argument must be at least',lDate,'characters long.'
64 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
65 &SQUEEZE_RIGHT,myThreadId)
66 WRITE(msgBuffer,'(A)')
67 &'*******************************************************'
68 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
69 &SQUEEZE_RIGHT,myThreadId)
70 GOTO 1000
71 END
72
73 CStartOfInterface
74 INTEGER FUNCTION IFNBLNK( string )
75 C /==========================================================\
76 C | FUNCTION IFNBLNK |
77 C | o Find first non-blank in character string. |
78 C \==========================================================/
79 IMPLICIT NONE
80 C
81 CHARACTER*(*) string
82 CEndOfInterface
83 C
84 INTEGER L, LS
85 C
86 LS = LEN(string)
87 IFNBLNK = 0
88 DO 10 L = 1, LS
89 IF ( string(L:L) .EQ. ' ' ) GOTO 10
90 IFNBLNK = L
91 GOTO 11
92 10 CONTINUE
93 11 CONTINUE
94 C
95 RETURN
96 END
97
98 CStartOfInterface
99 INTEGER FUNCTION ILNBLNK( string )
100 C /==========================================================\
101 C | FUNCTION ILNBLNK |
102 C | o Find last non-blank in character string. |
103 C \==========================================================/
104 IMPLICIT NONE
105 CHARACTER*(*) string
106 CEndOfInterface
107 INTEGER L, LS
108 C
109 LS = LEN(string)
110 ILNBLNK = LS
111 DO 10 L = LS, 1, -1
112 IF ( string(L:L) .EQ. ' ' ) GOTO 10
113 ILNBLNK = L
114 GOTO 11
115 10 CONTINUE
116 11 CONTINUE
117 C
118 RETURN
119 END
120
121 CStartofinterface
122 INTEGER FUNCTION IO_ERRCOUNT(myThid)
123 C /==========================================================\
124 C | FUNCTION IO_ERRCOUNT |
125 C | o Reads IO error counter. |
126 C \==========================================================/
127 IMPLICIT NONE
128 C == Global variables ==
129 #include "SIZE.h"
130 #include "EEPARAMS.h"
131
132 C == Routine arguments ==
133 INTEGER myThid
134 CEndofinterface
135
136 IO_ERRCOUNT = ioErrorCount(myThid)
137
138 RETURN
139 END
140
141 CStartOfInterface
142 SUBROUTINE LCASE ( string )
143 C /==========================================================\
144 C | SUBROUTINE LCASE |
145 C | o Convert character string to all lower case. |
146 C \==========================================================/
147 IMPLICIT NONE
148 CHARACTER*(*) string
149 CEndOfInterface
150 CHARACTER*26 LOWER
151 DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
152 SAVE LOWER
153 CHARACTER*26 UPPER
154 DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
155 SAVE UPPER
156 INTEGER I, L
157 C
158 DO 10 I = 1, LEN(string)
159 L = INDEX(UPPER,string(I:I))
160 IF ( L .EQ. 0 ) GOTO 10
161 string(I:I) = LOWER(L:L)
162 10 CONTINUE
163 C
164 RETURN
165 END
166
167 CStartOfInterface
168 SUBROUTINE MACHINE ( string )
169 C /==========================================================\
170 C | SUBROUTINE MACHINE |
171 C | o Return computer identifier in string. |
172 C \==========================================================/
173 IMPLICIT NONE
174 #include "SIZE.h"
175 #include "EEPARAMS.h"
176 CHARACTER*(*) string
177 CEndOfInterface
178 C
179 INTEGER IFNBLNK
180 INTEGER ILNBLNK
181 EXTERNAL IFNBLNK
182 EXTERNAL ILNBLNK
183 C
184 INTEGER iFirst
185 INTEGER iLast
186 INTEGER iEnd
187 INTEGER iFree
188 INTEGER idSize
189 CHARACTER*1024 strTmp
190 CHARACTER*1024 idString
191
192 strTmp = 'UNKNOWN'
193 iFree = 1
194 idSize = LEN(string)
195 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
196 IFirst = 0
197 CALL PXFGETENV('USER',iFirst,strTmp,ILast,Iend )
198 #else
199 CALL GETENV('USER',strTmp )
200 #endif
201 IF ( strTmp .NE. ' ' ) THEN
202 iFirst = IFNBLNK(strTmp)
203 iLast = ILNBLNK(strTmp)
204 iEnd = iLast-iFirst+1
205 IF (iEnd .GE. 0 ) THEN
206 idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
207 ENDIF
208 iFree = iFree+iEnd+1
209 IF ( iFree .LE. idSize ) THEN
210 idString(iFree:iFree) = '@'
211 iFree = iFree+1
212 ENDIF
213 ENDIF
214 strTmp = 'UNKNOWN'
215 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
216 IFirst = 0
217 CALL PXFGETENV('HOST',iFirst,strTmp,ILast,Iend )
218 #else
219 CALL GETENV('HOST',strTmp )
220 #endif
221 IF ( strTmp .NE. ' ' ) THEN
222 iFirst = IFNBLNK(strTmp)
223 iLast = ILNBLNK(strTmp)
224 iEnd = iLast-iFirst+1
225 iEnd = MIN(iEnd,idSize-iFree)
226 iEnd = iEnd-1
227 IF (iEnd .GE. 0 ) THEN
228 idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
229 ENDIF
230 iFree = iFree+iEnd+1
231 ENDIF
232 C
233 string = idString
234 C
235 1000 CONTINUE
236 RETURN
237 END
238 C***********************************************************************
239 SUBROUTINE UCASE ( string )
240 IMPLICIT NONE
241 C Translate string to upper case.
242 CHARACTER*(*) string
243 CHARACTER*26 LOWER
244 DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
245 SAVE LOWER
246 CHARACTER*26 UPPER
247 DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
248 SAVE UPPER
249 INTEGER I, L
250 C
251 DO 10 I = 1, LEN(string)
252 L = INDEX(LOWER,string(I:I))
253 IF ( L .EQ. 0 ) GOTO 10
254 string(I:I) = UPPER(L:L)
255 10 CONTINUE
256 C
257 RETURN
258 END
259 C************************************************************************
  ViewVC Help
Powered by ViewVC 1.1.22