eesupp/src/utils.F

C $Header: /u/gcmpack/models/MITgcmUV/eesupp/src/utils.F,v 1.8 2000/03/15 16:00:52 adcroft Exp $

#include "CPP_EEOPTIONS.h"

C--   File utils.F: General purpose support routines
C--    Contents
C-- U DATE            - Returns date and time.
C--   IFNBLNK         - Returns index of first non-blank string character.
C--   ILNBLNK         - Returns index of last non-blank string character.
C--   IO_ERRCOUNT     - Reads IO error counter.
C--   LCASE           - Translates to lower case.
C--UM MACHINE         - Returns character string identifying computer.
C--   UCASE           - Translates to upper case.
C--   Routines marked "M" contain specific machine dependent code.
C--   Routines marked "U" contain UNIX OS calls.

CStartOfInterface
      SUBROUTINE DATE ( string , myThreadId )
C     /==========================================================\
C     | SUBROUTINE DATE                                          |
C     | o Return current date                                    |
C     \==========================================================/
      IMPLICIT NONE
#include "SIZE.h"
#include "EEPARAMS.h"
C
      CHARACTER*(*) string
      INTEGER myThreadId
CEndOfInterface
C
      INTEGER lDate
      CHARACTER*(MAX_LEN_MBUF) msgBuffer
C
      lDate = 24
      IF ( LEN(string) .LT. lDate ) GOTO 901
      string = ' '
#ifndef TARGET_T3E
#ifndef TARGET_CRAY_VECTOR
      CALL FDATE( string )
#endif
#endif
C   
 1000 CONTINUE
      RETURN
  901 CONTINUE
      WRITE(msgBuffer,'(A)')
     &'                                                       '
      CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
     &SQUEEZE_RIGHT,myThreadId)
      WRITE(msgBuffer,'(A)')
     &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'
      CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
     &SQUEEZE_RIGHT,myThreadId)
      WRITE(msgBuffer,'(A)')
     &'procedure: "DATE".'
      CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
     &SQUEEZE_RIGHT,myThreadId)
      WRITE(msgBuffer,'(A)')
     &'Variable passed to S/R DATE is too small.'
      CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
     &SQUEEZE_RIGHT,myThreadId)
      WRITE(msgBuffer,'(A)')
     &' Argument must be at least',lDate,'characters long.'
      CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
     &SQUEEZE_RIGHT,myThreadId)
      WRITE(msgBuffer,'(A)')
     &'*******************************************************'
      CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
     &SQUEEZE_RIGHT,myThreadId)
      GOTO 1000
      END

CStartOfInterface
      INTEGER FUNCTION IFNBLNK( string )
C     /==========================================================\
C     | FUNCTION IFNBLNK                                         |
C     | o Find first non-blank in character string.              |
C     \==========================================================/
      IMPLICIT NONE
C
      CHARACTER*(*) string
CEndOfInterface
C
      INTEGER L, LS
C
      LS     = LEN(string)
      IFNBLNK = 0
      DO 10 L = 1, LS
       IF ( string(L:L) .EQ. ' ' ) GOTO 10
        IFNBLNK = L
        GOTO 11
   10 CONTINUE
   11 CONTINUE
C
      RETURN
      END

CStartOfInterface
      INTEGER FUNCTION ILNBLNK( string )
C     /==========================================================\
C     | FUNCTION ILNBLNK                                         |
C     | o Find last non-blank in character string.               |
C     \==========================================================/
      IMPLICIT NONE
      CHARACTER*(*) string
CEndOfInterface
      INTEGER L, LS
C
      LS      = LEN(string)
      ILNBLNK = LS
      DO 10 L = LS, 1, -1
        IF ( string(L:L) .EQ. ' ' ) GOTO 10
         ILNBLNK = L
         GOTO 11
   10 CONTINUE
   11 CONTINUE
C
      RETURN
      END

CStartofinterface
      INTEGER FUNCTION IO_ERRCOUNT(myThid)
C     /==========================================================\
C     | FUNCTION IO_ERRCOUNT                                     |
C     | o Reads IO error counter.                                |
C     \==========================================================/
      IMPLICIT NONE
C     == Global variables ==
#include "SIZE.h"
#include "EEPARAMS.h"

C     == Routine arguments ==
      INTEGER myThid
CEndofinterface

      IO_ERRCOUNT = ioErrorCount(myThid)

      RETURN
      END

CStartOfInterface
      SUBROUTINE LCASE ( string )
C     /==========================================================\
C     | SUBROUTINE LCASE                                         |
C     | o Convert character string to all lower case.            |
C     \==========================================================/
      IMPLICIT NONE
      CHARACTER*(*) string
CEndOfInterface
      CHARACTER*26  LOWER
      DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
      SAVE LOWER
      CHARACTER*26  UPPER
      DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
      SAVE UPPER
      INTEGER   I, L
C
      DO 10 I = 1, LEN(string)
        L = INDEX(UPPER,string(I:I))
        IF ( L .EQ. 0 ) GOTO 10
         string(I:I) = LOWER(L:L)
   10 CONTINUE
C   
      RETURN
      END

CStartOfInterface
      SUBROUTINE MACHINE ( string )
C     /==========================================================\
C     | SUBROUTINE MACHINE                                       |
C     | o Return computer identifier in string.                  |
C     \==========================================================/
      IMPLICIT NONE
#include "SIZE.h"
#include "EEPARAMS.h"
      CHARACTER*(*) string
CEndOfInterface
C
      INTEGER  IFNBLNK
      INTEGER  ILNBLNK
      EXTERNAL IFNBLNK
      EXTERNAL ILNBLNK
C
      INTEGER  iFirst
      INTEGER  iLast 
      INTEGER  iEnd  
      INTEGER  iFree
      INTEGER  idSize
      CHARACTER*1024 strTmp
      CHARACTER*1024 idString

      strTmp = 'UNKNOWN'
      iFree  = 1
      idSize = LEN(string)
#if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
      IFirst = 0
      CALL PXFGETENV('USER',iFirst,strTmp,ILast,Iend  )
#else
      CALL GETENV('USER',strTmp  )
#endif
      IF ( strTmp .NE. ' ' ) THEN
        iFirst = IFNBLNK(strTmp)
        iLast  = ILNBLNK(strTmp)
        iEnd   = iLast-iFirst+1
        IF (iEnd .GE. 0 ) THEN
         idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
        ENDIF
        iFree = iFree+iEnd+1
        IF ( iFree .LE. idSize ) THEN
          idString(iFree:iFree) = '@'
          iFree = iFree+1
        ENDIF
      ENDIF
      strTmp = 'UNKNOWN'
#if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
      IFirst = 0
      CALL PXFGETENV('HOST',iFirst,strTmp,ILast,Iend  )
#else
      CALL GETENV('HOST',strTmp  )
#endif
      IF ( strTmp .NE. ' ' ) THEN
        iFirst = IFNBLNK(strTmp)
        iLast  = ILNBLNK(strTmp)
        iEnd   = iLast-iFirst+1
        iEnd   = MIN(iEnd,idSize-iFree)
        iEnd   = iEnd-1
        IF (iEnd .GE. 0 ) THEN
          idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
        ENDIF
        iFree = iFree+iEnd+1
      ENDIF
C
      string = idString
C
 1000 CONTINUE
      RETURN
      END
C***********************************************************************
      SUBROUTINE UCASE ( string )
      IMPLICIT NONE
C     Translate string to upper case.
      CHARACTER*(*) string
      CHARACTER*26  LOWER
      DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
      SAVE LOWER
      CHARACTER*26  UPPER
      DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
      SAVE UPPER
      INTEGER   I, L
C
      DO 10 I = 1, LEN(string)
        L = INDEX(LOWER,string(I:I))
        IF ( L .EQ. 0 ) GOTO 10
          string(I:I) = UPPER(L:L)
   10 CONTINUE
C   
      RETURN
      END
C************************************************************************
1	heimbach	1.9	C $Header: /u/gcmpack/models/MITgcmUV/eesupp/src/utils.F,v 1.8 2000/03/15 16:00:52 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	adcroft	1.6	IMPLICIT NONE
24	cnh	1.1	#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	adcroft	1.7	#ifndef TARGET_T3E
38	heimbach	1.9	#ifndef TARGET_CRAY_VECTOR
39	cnh	1.1	CALL FDATE( string )
40	adcroft	1.7	#endif
41	heimbach	1.9	#endif
42	cnh	1.1	C
43			1000 CONTINUE
44			RETURN
45			901 CONTINUE
46			WRITE(msgBuffer,'(A)')
47			&' '
48	cnh	1.5	CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
49			&SQUEEZE_RIGHT,myThreadId)
50	cnh	1.1	WRITE(msgBuffer,'(A)')
51			&'* WARNING WARNING WARNING WARNING WARNING WARNING *'
52	cnh	1.5	CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
53			&SQUEEZE_RIGHT,myThreadId)
54	cnh	1.1	WRITE(msgBuffer,'(A)')
55			&'procedure: "DATE".'
56	cnh	1.5	CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
57			&SQUEEZE_RIGHT,myThreadId)
58	cnh	1.1	WRITE(msgBuffer,'(A)')
59			&'Variable passed to S/R DATE is too small.'
60	cnh	1.5	CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
61			&SQUEEZE_RIGHT,myThreadId)
62	cnh	1.1	WRITE(msgBuffer,'(A)')
63			&' Argument must be at least',lDate,'characters long.'
64	cnh	1.5	CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
65			&SQUEEZE_RIGHT,myThreadId)
66	cnh	1.1	WRITE(msgBuffer,'(A)')
67			&'*******************************************************'
68	cnh	1.5	CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
69			&SQUEEZE_RIGHT,myThreadId)
70	cnh	1.1	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	adcroft	1.6	IMPLICIT NONE
80	cnh	1.1	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	adcroft	1.6	IMPLICIT NONE
105	cnh	1.1	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	cnh	1.3	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	adcroft	1.6	IMPLICIT NONE
128	cnh	1.3	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	cnh	1.1	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	adcroft	1.6	IMPLICIT NONE
148	cnh	1.1	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	adcroft	1.6	IMPLICIT NONE
174	cnh	1.1	#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	heimbach	1.9	#if (defined (TARGET_T3E) \|\| defined (TARGET_CRAY_VECTOR))
196	adcroft	1.7	IFirst = 0
197			CALL PXFGETENV('USER',iFirst,strTmp,ILast,Iend )
198			#else
199	cnh	1.1	CALL GETENV('USER',strTmp )
200	adcroft	1.7	#endif
201	cnh	1.1	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	heimbach	1.9	#if (defined (TARGET_T3E) \|\| defined (TARGET_CRAY_VECTOR))
216	adcroft	1.7	IFirst = 0
217			CALL PXFGETENV('HOST',iFirst,strTmp,ILast,Iend )
218			#else
219			CALL GETENV('HOST',strTmp )
220			#endif
221	cnh	1.1	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	adcroft	1.6	IMPLICIT NONE
241	cnh	1.1	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************************************************************************