/[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.2 - (hide annotations) (download)
Fri Nov 15 04:03:25 2002 UTC (21 years, 4 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 heimbach 1.2 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