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

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

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

revision 1.4 by adcroft, Wed Jun 10 21:38:29 1998 UTC revision 1.9 by heimbach, Wed Jun 21 20:44:06 2000 UTC
# Line 20  C     /================================= Line 20  C     /=================================
20  C     | SUBROUTINE DATE                                          |  C     | SUBROUTINE DATE                                          |
21  C     | o Return current date                                    |  C     | o Return current date                                    |
22  C     \==========================================================/  C     \==========================================================/
23          IMPLICIT NONE
24  #include "SIZE.h"  #include "SIZE.h"
25  #include "EEPARAMS.h"  #include "EEPARAMS.h"
26  C  C
# Line 33  C Line 34  C
34        lDate = 24        lDate = 24
35        IF ( LEN(string) .LT. lDate ) GOTO 901        IF ( LEN(string) .LT. lDate ) GOTO 901
36        string = ' '        string = ' '
37    #ifndef TARGET_T3E
38    #ifndef TARGET_CRAY_VECTOR
39        CALL FDATE( string )        CALL FDATE( string )
40    #endif
41    #endif
42  C    C  
43   1000 CONTINUE   1000 CONTINUE
44        RETURN        RETURN
45    901 CONTINUE    901 CONTINUE
46        WRITE(msgBuffer,'(A)')        WRITE(msgBuffer,'(A)')
47       &'                                                       '       &'                                                       '
48        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,SQUEEZE_RIGHT,myThreadId)        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
49         &SQUEEZE_RIGHT,myThreadId)
50        WRITE(msgBuffer,'(A)')        WRITE(msgBuffer,'(A)')
51       &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'       &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'
52        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,SQUEEZE_RIGHT,myThreadId)        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
53         &SQUEEZE_RIGHT,myThreadId)
54        WRITE(msgBuffer,'(A)')        WRITE(msgBuffer,'(A)')
55       &'procedure: "DATE".'       &'procedure: "DATE".'
56        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,SQUEEZE_RIGHT,myThreadId)        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
57         &SQUEEZE_RIGHT,myThreadId)
58        WRITE(msgBuffer,'(A)')        WRITE(msgBuffer,'(A)')
59       &'Variable passed to S/R DATE is too small.'       &'Variable passed to S/R DATE is too small.'
60        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,SQUEEZE_RIGHT,myThreadId)        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
61         &SQUEEZE_RIGHT,myThreadId)
62        WRITE(msgBuffer,'(A)')        WRITE(msgBuffer,'(A)')
63       &' Argument must be at least',lDate,'characters long.'       &' Argument must be at least',lDate,'characters long.'
64        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,SQUEEZE_RIGHT,myThreadId)        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
65         &SQUEEZE_RIGHT,myThreadId)
66        WRITE(msgBuffer,'(A)')        WRITE(msgBuffer,'(A)')
67       &'*******************************************************'       &'*******************************************************'
68        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,SQUEEZE_RIGHT,myThreadId)        CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
69         &SQUEEZE_RIGHT,myThreadId)
70        GOTO 1000        GOTO 1000
71        END        END
72    
# Line 65  C     /================================= Line 76  C     /=================================
76  C     | FUNCTION IFNBLNK                                         |  C     | FUNCTION IFNBLNK                                         |
77  C     | o Find first non-blank in character string.              |  C     | o Find first non-blank in character string.              |
78  C     \==========================================================/  C     \==========================================================/
79          IMPLICIT NONE
80  C  C
81        CHARACTER*(*) string        CHARACTER*(*) string
82  CEndOfInterface  CEndOfInterface
# Line 89  C     /================================= Line 101  C     /=================================
101  C     | FUNCTION ILNBLNK                                         |  C     | FUNCTION ILNBLNK                                         |
102  C     | o Find last non-blank in character string.               |  C     | o Find last non-blank in character string.               |
103  C     \==========================================================/  C     \==========================================================/
104          IMPLICIT NONE
105        CHARACTER*(*) string        CHARACTER*(*) string
106  CEndOfInterface  CEndOfInterface
107        INTEGER L, LS        INTEGER L, LS
# Line 111  C     /================================= Line 124  C     /=================================
124  C     | FUNCTION IO_ERRCOUNT                                     |  C     | FUNCTION IO_ERRCOUNT                                     |
125  C     | o Reads IO error counter.                                |  C     | o Reads IO error counter.                                |
126  C     \==========================================================/  C     \==========================================================/
127          IMPLICIT NONE
128  C     == Global variables ==  C     == Global variables ==
129  #include "SIZE.h"  #include "SIZE.h"
130  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "DFILE.h"  
131    
132  C     == Routine arguments ==  C     == Routine arguments ==
133        INTEGER myThid        INTEGER myThid
# Line 132  C     /================================= Line 144  C     /=================================
144  C     | SUBROUTINE LCASE                                         |  C     | SUBROUTINE LCASE                                         |
145  C     | o Convert character string to all lower case.            |  C     | o Convert character string to all lower case.            |
146  C     \==========================================================/  C     \==========================================================/
147          IMPLICIT NONE
148        CHARACTER*(*) string        CHARACTER*(*) string
149  CEndOfInterface  CEndOfInterface
150        CHARACTER*26  LOWER        CHARACTER*26  LOWER
# Line 157  C     /================================= Line 170  C     /=================================
170  C     | SUBROUTINE MACHINE                                       |  C     | SUBROUTINE MACHINE                                       |
171  C     | o Return computer identifier in string.                  |  C     | o Return computer identifier in string.                  |
172  C     \==========================================================/  C     \==========================================================/
173          IMPLICIT NONE
174  #include "SIZE.h"  #include "SIZE.h"
175  #include "EEPARAMS.h"  #include "EEPARAMS.h"
176        CHARACTER*(*) string        CHARACTER*(*) string
# Line 178  C Line 192  C
192        strTmp = 'UNKNOWN'        strTmp = 'UNKNOWN'
193        iFree  = 1        iFree  = 1
194        idSize = LEN(string)        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  )        CALL GETENV('USER',strTmp  )
200    #endif
201        IF ( strTmp .NE. ' ' ) THEN        IF ( strTmp .NE. ' ' ) THEN
202          iFirst = IFNBLNK(strTmp)          iFirst = IFNBLNK(strTmp)
203          iLast  = ILNBLNK(strTmp)          iLast  = ILNBLNK(strTmp)
# Line 193  C Line 212  C
212          ENDIF          ENDIF
213        ENDIF        ENDIF
214        strTmp = 'UNKNOWN'        strTmp = 'UNKNOWN'
215        CALL GETENV('HOST',strtmp )  #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        IF ( strTmp .NE. ' ' ) THEN
222          iFirst = IFNBLNK(strTmp)          iFirst = IFNBLNK(strTmp)
223          iLast  = ILNBLNK(strTmp)          iLast  = ILNBLNK(strTmp)
# Line 213  C Line 237  C
237        END        END
238  C***********************************************************************  C***********************************************************************
239        SUBROUTINE UCASE ( string )        SUBROUTINE UCASE ( string )
240          IMPLICIT NONE
241  C     Translate string to upper case.  C     Translate string to upper case.
242        CHARACTER*(*) string        CHARACTER*(*) string
243        CHARACTER*26  LOWER        CHARACTER*26  LOWER
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.9
  ViewVC Help
Powered by ViewVC 1.1.22