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

Annotation of /MITgcm/optim/utils.F

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

Revision 1.1.2.1 - (hide 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 heimbach 1.1.2.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