/[MITgcm]/MITgcm_contrib/ecco_utils/ecco_v4_release3_optimization/optim/utils.F
ViewVC logotype

Annotation of /MITgcm_contrib/ecco_utils/ecco_v4_release3_optimization/optim/utils.F

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


Revision 1.1 - (hide annotations) (download)
Wed Jan 3 17:14:05 2018 UTC (7 years, 6 months ago) by ou.wang
Branch: MAIN
CVS Tags: HEAD
Check in the optimization used in ECCO v4r3

1 ou.wang 1.1 C $Header: /u/gcmpack/MITgcm/optim/utils.F,v 1.3 2003/11/11 20:38:27 edhill 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     #ifdef HAVE_FDATE
38     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