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

Diff of /MITgcm/optim/utils.F

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

revision 1.1 by heimbach, Tue Feb 5 20:34:35 2002 UTC revision 1.2 by heimbach, Fri Nov 15 04:03:25 2002 UTC
# Line 0  Line 1 
1    C $Header$
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************************************************************************
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
  ViewVC Help
Powered by ViewVC 1.1.22