/[MITgcm]/MITgcm/eesupp/src/utils.F
ViewVC logotype

Annotation of /MITgcm/eesupp/src/utils.F

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

Revision 1.5 - (hide annotations) (download)
Wed Oct 28 03:11:35 1998 UTC (25 years, 7 months ago) by cnh
Branch: MAIN
CVS Tags: checkpoint17, checkpoint19, checkpoint18, checkpoint20, checkpoint21, checkpoint16
Changes since 1.4: +13 -7 lines 
Changes to support
 - g77 compilation under Linux
 - LR(1) form of 64-bit is D or E for constants
 - Modified adjoint of exch with adjoint variables
   acuumulated.
1 cnh 1.5 C $Header: /u/gcmpack/models/MITgcmUV/eesupp/src/utils.F,v 1.4 1998/06/10 21:38:29 adcroft Exp $
2 cnh 1.1
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 cnh 1.3 C-- IO_ERRCOUNT - Reads IO error counter.
11 cnh 1.1 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     #include "SIZE.h"
24     #include "EEPARAMS.h"
25     C
26     CHARACTER*(*) string
27     INTEGER myThreadId
28     CEndOfInterface
29     C
30     INTEGER lDate
31     CHARACTER*(MAX_LEN_MBUF) msgBuffer
32     C
33     lDate = 24
34     IF ( LEN(string) .LT. lDate ) GOTO 901
35     string = ' '
36     CALL FDATE( string )
37     C
38     1000 CONTINUE
39     RETURN
40     901 CONTINUE
41     WRITE(msgBuffer,'(A)')
42     &' '
43 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
44     &SQUEEZE_RIGHT,myThreadId)
45 cnh 1.1 WRITE(msgBuffer,'(A)')
46     &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'
47 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
48     &SQUEEZE_RIGHT,myThreadId)
49 cnh 1.1 WRITE(msgBuffer,'(A)')
50     &'procedure: "DATE".'
51 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
52     &SQUEEZE_RIGHT,myThreadId)
53 cnh 1.1 WRITE(msgBuffer,'(A)')
54     &'Variable passed to S/R DATE is too small.'
55 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
56     &SQUEEZE_RIGHT,myThreadId)
57 cnh 1.1 WRITE(msgBuffer,'(A)')
58     &' Argument must be at least',lDate,'characters long.'
59 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
60     &SQUEEZE_RIGHT,myThreadId)
61 cnh 1.1 WRITE(msgBuffer,'(A)')
62     &'*******************************************************'
63 cnh 1.5 CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
64     &SQUEEZE_RIGHT,myThreadId)
65 cnh 1.1 GOTO 1000
66     END
67    
68     CStartOfInterface
69     INTEGER FUNCTION IFNBLNK( string )
70     C /==========================================================\
71     C | FUNCTION IFNBLNK |
72     C | o Find first non-blank in character string. |
73     C \==========================================================/
74     C
75     CHARACTER*(*) string
76     CEndOfInterface
77     C
78     INTEGER L, LS
79     C
80     LS = LEN(string)
81     IFNBLNK = 0
82     DO 10 L = 1, LS
83     IF ( string(L:L) .EQ. ' ' ) GOTO 10
84     IFNBLNK = L
85     GOTO 11
86     10 CONTINUE
87     11 CONTINUE
88     C
89     RETURN
90     END
91    
92     CStartOfInterface
93     INTEGER FUNCTION ILNBLNK( string )
94     C /==========================================================\
95     C | FUNCTION ILNBLNK |
96     C | o Find last non-blank in character string. |
97     C \==========================================================/
98     CHARACTER*(*) string
99     CEndOfInterface
100     INTEGER L, LS
101     C
102     LS = LEN(string)
103     ILNBLNK = LS
104     DO 10 L = LS, 1, -1
105     IF ( string(L:L) .EQ. ' ' ) GOTO 10
106     ILNBLNK = L
107     GOTO 11
108     10 CONTINUE
109     11 CONTINUE
110     C
111 cnh 1.3 RETURN
112     END
113    
114     CStartofinterface
115     INTEGER FUNCTION IO_ERRCOUNT(myThid)
116     C /==========================================================\
117     C | FUNCTION IO_ERRCOUNT |
118     C | o Reads IO error counter. |
119     C \==========================================================/
120    
121     C == Global variables ==
122     #include "SIZE.h"
123     #include "EEPARAMS.h"
124     #include "DFILE.h"
125    
126     C == Routine arguments ==
127     INTEGER myThid
128     CEndofinterface
129    
130     IO_ERRCOUNT = ioErrorCount(myThid)
131    
132 cnh 1.1 RETURN
133     END
134    
135     CStartOfInterface
136     SUBROUTINE LCASE ( string )
137     C /==========================================================\
138     C | SUBROUTINE LCASE |
139     C | o Convert character string to all lower case. |
140     C \==========================================================/
141     CHARACTER*(*) string
142     CEndOfInterface
143     CHARACTER*26 LOWER
144     DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
145     SAVE LOWER
146     CHARACTER*26 UPPER
147     DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
148     SAVE UPPER
149     INTEGER I, L
150     C
151     DO 10 I = 1, LEN(string)
152     L = INDEX(UPPER,string(I:I))
153     IF ( L .EQ. 0 ) GOTO 10
154     string(I:I) = LOWER(L:L)
155     10 CONTINUE
156     C
157     RETURN
158     END
159    
160     CStartOfInterface
161     SUBROUTINE MACHINE ( string )
162     C /==========================================================\
163     C | SUBROUTINE MACHINE |
164     C | o Return computer identifier in string. |
165     C \==========================================================/
166     #include "SIZE.h"
167     #include "EEPARAMS.h"
168     CHARACTER*(*) string
169     CEndOfInterface
170     C
171     INTEGER IFNBLNK
172     INTEGER ILNBLNK
173     EXTERNAL IFNBLNK
174     EXTERNAL ILNBLNK
175     C
176     INTEGER iFirst
177     INTEGER iLast
178     INTEGER iEnd
179     INTEGER iFree
180     INTEGER idSize
181     CHARACTER*1024 strTmp
182     CHARACTER*1024 idString
183    
184     strTmp = 'UNKNOWN'
185     iFree = 1
186     idSize = LEN(string)
187     CALL GETENV('USER',strTmp )
188     IF ( strTmp .NE. ' ' ) THEN
189     iFirst = IFNBLNK(strTmp)
190     iLast = ILNBLNK(strTmp)
191     iEnd = iLast-iFirst+1
192     IF (iEnd .GE. 0 ) THEN
193     idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
194     ENDIF
195     iFree = iFree+iEnd+1
196     IF ( iFree .LE. idSize ) THEN
197     idString(iFree:iFree) = '@'
198     iFree = iFree+1
199     ENDIF
200     ENDIF
201     strTmp = 'UNKNOWN'
202     CALL GETENV('HOST',strtmp )
203     IF ( strTmp .NE. ' ' ) THEN
204     iFirst = IFNBLNK(strTmp)
205     iLast = ILNBLNK(strTmp)
206     iEnd = iLast-iFirst+1
207     iEnd = MIN(iEnd,idSize-iFree)
208     iEnd = iEnd-1
209     IF (iEnd .GE. 0 ) THEN
210     idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
211     ENDIF
212     iFree = iFree+iEnd+1
213     ENDIF
214     C
215     string = idString
216     C
217     1000 CONTINUE
218     RETURN
219     END
220     C***********************************************************************
221     SUBROUTINE UCASE ( string )
222     C Translate string to upper case.
223     CHARACTER*(*) string
224     CHARACTER*26 LOWER
225     DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
226     SAVE LOWER
227     CHARACTER*26 UPPER
228     DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
229     SAVE UPPER
230     INTEGER I, L
231     C
232     DO 10 I = 1, LEN(string)
233     L = INDEX(LOWER,string(I:I))
234     IF ( L .EQ. 0 ) GOTO 10
235     string(I:I) = UPPER(L:L)
236     10 CONTINUE
237     C
238     RETURN
239     END
240     C************************************************************************
  ViewVC Help
Powered by ViewVC 1.1.22