/[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.1.2.1 - (show annotations) (download)
Tue Feb 5 20:34:35 2002 UTC (22 years, 2 months ago) by heimbach
Branch: ecco-branch
CVS Tags: ecco_c50_e32, ecco_c50_e33, ecco_c50_e30, ecco_c50_e31, ecco_c51_e34d, ecco_c51_e34e, ecco_c51_e34f, ecco_c51_e34g, ecco_c51_e34a, ecco_c51_e34b, ecco_c51_e34c, icebear5, icebear4, icebear3, icebear2, ecco_c50_e29, ecco_c50_e28, ecco_c44_e19, ecco_c44_e18, ecco_c44_e17, ecco_c44_e16, ecco_c50_e33a, ecco_c51_e34, ecco_ice2, ecco_ice1, ecco_c44_e25, ecco_c44_e22, ecco_c44_e23, ecco_c44_e20, ecco_c44_e21, ecco_c44_e26, ecco_c44_e27, ecco_c44_e24, ecco-branch-mod1, ecco-branch-mod2, ecco-branch-mod3, ecco-branch-mod4, ecco-branch-mod5
Branch point for: c24_e25_ice, icebear
Changes since 1.1: +259 -0 lines 
o Updating adjoint/makefile to ECCO code
o Adding optim and lsopt for line search optimization.
o Adding verif. experiments for ECCO
Code will be tagged ecco-branch-mod1.
1 C $Header: /u/gcmpack/development/heimbach/ecco_env/optim/utils.F,v 1.1 2000/10/23 16:32:11 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