/[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.3 - (hide annotations) (download)
Tue Nov 11 20:38:27 2003 UTC (20 years, 5 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 edhill 1.3 C $Header: /u/u3/gcmpack/MITgcm/optim/utils.F,v 1.2 2002/11/15 04:03:25 heimbach Exp $
2 heimbach 1.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 edhill 1.3 #ifdef HAVE_FDATE
38 heimbach 1.2 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