eesupp/src/utils.F

924557e60a Chri*0001 #include "CPP_EEOPTIONS.h"
                0002
                0003 C--   File utils.F: General purpose support routines
                0004 C--    Contents
                0005 C-- U DATE            - Returns date and time.
                0006 C--   IFNBLNK         - Returns index of first non-blank string character.
                0007 C--   ILNBLNK         - Returns index of last non-blank string character.
66dc79a095 Chri*0008 C--   IO_ERRCOUNT     - Reads IO error counter.
924557e60a Chri*0009 C--   LCASE           - Translates to lower case.
                0010 C--UM MACHINE         - Returns character string identifying computer.
                0011 C--   UCASE           - Translates to upper case.
                0012 C--   Routines marked "M" contain specific machine dependent code.
                0013 C--   Routines marked "U" contain UNIX OS calls.
                0014
ec7b4bf650 Jean*0015 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
4c563c2ee9 Chri*0016 CBOP
                0017 C     !ROUTINE: DATE
                0018
                0019 C     !INTERFACE:
924557e60a Chri*0020       SUBROUTINE DATE ( string , myThreadId )
4c563c2ee9 Chri*0021       IMPLICIT NONE
                0022
                0023 C     !DESCRIPTION:
                0024 C     *==========================================================*
924557e60a Chri*0025 C     | SUBROUTINE DATE                                          |
                0026 C     | o Return current date                                    |
4c563c2ee9 Chri*0027 C     *==========================================================*
                0028
                0029 C     !USES:
924557e60a Chri*0030 #include "SIZE.h"
                0031 #include "EEPARAMS.h"
4c563c2ee9 Chri*0032
                0033 C     !INPUT/OUTPUT PARAMETERS:
                0034 C     string     :: Date returned in string
                0035 C     myThreadId :: My thread number
924557e60a Chri*0036       CHARACTER*(*) string
                0037       INTEGER myThreadId
ec7b4bf650 Jean*0038
4c563c2ee9 Chri*0039 C     !LOCAL VARIABLES:
                0040 C     lDate     :: Length of date string
                0041 C     msgBuffer :: Temp. for building error messages
924557e60a Chri*0042       INTEGER lDate
                0043       CHARACTER*(MAX_LEN_MBUF) msgBuffer
4c563c2ee9 Chri*0044 CEOP
ec7b4bf650 Jean*0045
924557e60a Chri*0046       lDate = 24
                0047       IF ( LEN(string) .LT. lDate ) GOTO 901
                0048       string = ' '
e51ecc3fef Ed H*0049 #ifdef HAVE_FDATE
924557e60a Chri*0050       CALL FDATE( string )
79f5b9efed Alis*0051 #endif
ec7b4bf650 Jean*0052
924557e60a Chri*0053  1000 CONTINUE
                0054       RETURN
                0055   901 CONTINUE
                0056       WRITE(msgBuffer,'(A)')
                0057      &'                                                       '
46dc4f419b Chri*0058       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0059      &SQUEEZE_RIGHT,myThreadId)
924557e60a Chri*0060       WRITE(msgBuffer,'(A)')
                0061      &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'
46dc4f419b Chri*0062       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0063      &SQUEEZE_RIGHT,myThreadId)
924557e60a Chri*0064       WRITE(msgBuffer,'(A)')
                0065      &'procedure: "DATE".'
46dc4f419b Chri*0066       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0067      &SQUEEZE_RIGHT,myThreadId)
924557e60a Chri*0068       WRITE(msgBuffer,'(A)')
                0069      &'Variable passed to S/R DATE is too small.'
46dc4f419b Chri*0070       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0071      &SQUEEZE_RIGHT,myThreadId)
924557e60a Chri*0072       WRITE(msgBuffer,'(A)')
                0073      &' Argument must be at least',lDate,'characters long.'
46dc4f419b Chri*0074       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0075      &SQUEEZE_RIGHT,myThreadId)
924557e60a Chri*0076       WRITE(msgBuffer,'(A)')
                0077      &'*******************************************************'
46dc4f419b Chri*0078       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0079      &SQUEEZE_RIGHT,myThreadId)
924557e60a Chri*0080       GOTO 1000
                0081       END
                0082
ec7b4bf650 Jean*0083 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
4c563c2ee9 Chri*0084 CBOP
                0085 C     !ROUTINE: IFNBLNK
                0086
                0087 C     !INTERFACE:
924557e60a Chri*0088       INTEGER FUNCTION IFNBLNK( string )
4c563c2ee9 Chri*0089       IMPLICIT NONE
                0090
                0091 C     !DESCRIPTION:
                0092 C     *==========================================================*
924557e60a Chri*0093 C     | FUNCTION IFNBLNK                                         |
                0094 C     | o Find first non-blank in character string.              |
4c563c2ee9 Chri*0095 C     *==========================================================*
ec7b4bf650 Jean*0096
4c563c2ee9 Chri*0097 C     !INPUT PARAMETERS:
                0098 C     string :: String to find first non-blank in.
924557e60a Chri*0099       CHARACTER*(*) string
4c563c2ee9 Chri*0100
                0101 C     !LOCAL VARIABLES:
                0102 C     L, LS :: Temps for string locations
924557e60a Chri*0103       INTEGER L, LS
4c563c2ee9 Chri*0104 CEOP
ec7b4bf650 Jean*0105
924557e60a Chri*0106       LS     = LEN(string)
                0107       IFNBLNK = 0
                0108       DO 10 L = 1, LS
                0109        IF ( string(L:L) .EQ. ' ' ) GOTO 10
                0110         IFNBLNK = L
                0111         GOTO 11
                0112    10 CONTINUE
                0113    11 CONTINUE
ec7b4bf650 Jean*0114
924557e60a Chri*0115       RETURN
                0116       END
                0117
ec7b4bf650 Jean*0118 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
4c563c2ee9 Chri*0119 CBOP
                0120 C     !ROUTINE: ILNBLNK
                0121
                0122 C     !INTERFACE:
924557e60a Chri*0123       INTEGER FUNCTION ILNBLNK( string )
4c563c2ee9 Chri*0124       IMPLICIT NONE
                0125
                0126 C     !DESCRIPTION:
                0127 C     *==========================================================*
924557e60a Chri*0128 C     | FUNCTION ILNBLNK                                         |
                0129 C     | o Find last non-blank in character string.               |
4c563c2ee9 Chri*0130 C     *==========================================================*
                0131
                0132 C     !INPUT PARAMETERS:
                0133 C     string :: string to scan
924557e60a Chri*0134       CHARACTER*(*) string
4c563c2ee9 Chri*0135
                0136 C     !LOCAL VARIABLES:
                0137 C     L, LS :: Temps. used in scanning string
924557e60a Chri*0138       INTEGER L, LS
4c563c2ee9 Chri*0139 CEOP
ec7b4bf650 Jean*0140
924557e60a Chri*0141       LS      = LEN(string)
6795fede1d Jean*0142 c     ILNBLNK = LS
                0143       ILNBLNK = 0
924557e60a Chri*0144       DO 10 L = LS, 1, -1
                0145         IF ( string(L:L) .EQ. ' ' ) GOTO 10
                0146          ILNBLNK = L
                0147          GOTO 11
                0148    10 CONTINUE
                0149    11 CONTINUE
ec7b4bf650 Jean*0150
924557e60a Chri*0151       RETURN
                0152       END
                0153
ec7b4bf650 Jean*0154 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
4c563c2ee9 Chri*0155 CBOP
                0156 C     !ROUTINE: IO_ERRCOUNT
                0157
                0158 C     !INTERFACE:
66dc79a095 Chri*0159       INTEGER FUNCTION IO_ERRCOUNT(myThid)
4c563c2ee9 Chri*0160       IMPLICIT NONE
                0161
                0162 C     !DESCRIPTION:
                0163 C     *==========================================================*
2b4c849245 Ed H*0164 C     | FUNCTION IO\_ERRCOUNT                                     |
66dc79a095 Chri*0165 C     | o Reads IO error counter.                                |
4c563c2ee9 Chri*0166 C     *==========================================================*
                0167
                0168 C     !USES:
66dc79a095 Chri*0169 C     == Global variables ==
                0170 #include "SIZE.h"
                0171 #include "EEPARAMS.h"
                0172
4c563c2ee9 Chri*0173 C     !INPUT PARAMETERS:
66dc79a095 Chri*0174 C     == Routine arguments ==
4c563c2ee9 Chri*0175 C     myThid :: My thread number
66dc79a095 Chri*0176       INTEGER myThid
4c563c2ee9 Chri*0177
                0178 CEOP
66dc79a095 Chri*0179
                0180       IO_ERRCOUNT = ioErrorCount(myThid)
                0181
                0182       RETURN
                0183       END
                0184
ec7b4bf650 Jean*0185 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
4c563c2ee9 Chri*0186 CBOP
                0187 C     !ROUTINE: LCASE
                0188
                0189 C     !INTERFACE:
924557e60a Chri*0190       SUBROUTINE LCASE ( string )
4c563c2ee9 Chri*0191       IMPLICIT NONE
                0192
                0193 C     !DESCRIPTION:
                0194 C     *==========================================================*
924557e60a Chri*0195 C     | SUBROUTINE LCASE                                         |
                0196 C     | o Convert character string to all lower case.            |
4c563c2ee9 Chri*0197 C     *==========================================================*
                0198
                0199 C     !INPUT/OUTPUT PARAMETERS:
924557e60a Chri*0200       CHARACTER*(*) string
4c563c2ee9 Chri*0201
                0202 C     !LOCALVARIABLES:
924557e60a Chri*0203       CHARACTER*26  LOWER
                0204       DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
                0205       SAVE LOWER
                0206       CHARACTER*26  UPPER
                0207       DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
                0208       SAVE UPPER
                0209       INTEGER   I, L
4c563c2ee9 Chri*0210 CEOP
                0211
924557e60a Chri*0212       DO 10 I = 1, LEN(string)
                0213         L = INDEX(UPPER,string(I:I))
                0214         IF ( L .EQ. 0 ) GOTO 10
                0215          string(I:I) = LOWER(L:L)
                0216    10 CONTINUE
ec7b4bf650 Jean*0217
924557e60a Chri*0218       RETURN
                0219       END
                0220
ec7b4bf650 Jean*0221 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
4c563c2ee9 Chri*0222 CBOP
                0223 C     !ROUTINE: MACHINE
                0224
                0225 C     !INTERFACE:
924557e60a Chri*0226       SUBROUTINE MACHINE ( string )
4c563c2ee9 Chri*0227       IMPLICIT NONE
                0228
                0229 C     !DESCRIPTION:
                0230 C     *==========================================================*
924557e60a Chri*0231 C     | SUBROUTINE MACHINE                                       |
                0232 C     | o Return computer identifier in string.                  |
4c563c2ee9 Chri*0233 C     *==========================================================*
                0234
                0235 C     !USES:
924557e60a Chri*0236 #include "SIZE.h"
                0237 #include "EEPARAMS.h"
                0238       INTEGER  IFNBLNK
                0239       INTEGER  ILNBLNK
                0240       EXTERNAL IFNBLNK
                0241       EXTERNAL ILNBLNK
4c563c2ee9 Chri*0242
                0243 C     !OUTPUT PARAMETERS:
                0244 C     string :: Machine identifier
                0245       CHARACTER*(*) string
                0246
                0247 C     !LOCAL VARIABLES:
                0248 C     iFirst, iLast,      :: String indexing temps.
                0249 C     iEnd, iFree, idSize
                0250 C     strTmp, idString    :: Temps. for strings.
924557e60a Chri*0251       INTEGER  iFirst
ec7b4bf650 Jean*0252       INTEGER  iLast
                0253       INTEGER  iEnd
924557e60a Chri*0254       INTEGER  iFree
                0255       INTEGER  idSize
                0256       CHARACTER*1024 strTmp
                0257       CHARACTER*1024 idString
4c563c2ee9 Chri*0258 CEOP
924557e60a Chri*0259
                0260       strTmp = 'UNKNOWN'
                0261       iFree  = 1
                0262       idSize = LEN(string)
d4318425b4 Patr*0263 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR) && !defined (TARGET_NEC_VECTOR))
79f5b9efed Alis*0264       IFirst = 0
                0265       CALL PXFGETENV('USER',iFirst,strTmp,ILast,Iend  )
                0266 #else
924557e60a Chri*0267       CALL GETENV('USER',strTmp  )
79f5b9efed Alis*0268 #endif
924557e60a Chri*0269       IF ( strTmp .NE. ' ' ) THEN
                0270         iFirst = IFNBLNK(strTmp)
                0271         iLast  = ILNBLNK(strTmp)
                0272         iEnd   = iLast-iFirst+1
                0273         IF (iEnd .GE. 0 ) THEN
                0274          idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
                0275         ENDIF
                0276         iFree = iFree+iEnd+1
                0277         IF ( iFree .LE. idSize ) THEN
                0278           idString(iFree:iFree) = '@'
                0279           iFree = iFree+1
                0280         ENDIF
                0281       ENDIF
                0282       strTmp = 'UNKNOWN'
d4318425b4 Patr*0283 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR) && !defined (TARGET_NEC_VECTOR))
79f5b9efed Alis*0284       IFirst = 0
                0285       CALL PXFGETENV('HOST',iFirst,strTmp,ILast,Iend  )
                0286 #else
                0287       CALL GETENV('HOST',strTmp  )
                0288 #endif
924557e60a Chri*0289       IF ( strTmp .NE. ' ' ) THEN
                0290         iFirst = IFNBLNK(strTmp)
                0291         iLast  = ILNBLNK(strTmp)
                0292         iEnd   = iLast-iFirst+1
                0293         iEnd   = MIN(iEnd,idSize-iFree)
                0294         iEnd   = iEnd-1
                0295         IF (iEnd .GE. 0 ) THEN
                0296           idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
                0297         ENDIF
                0298         iFree = iFree+iEnd+1
                0299       ENDIF
ec7b4bf650 Jean*0300
924557e60a Chri*0301       string = idString
ec7b4bf650 Jean*0302
924557e60a Chri*0303       RETURN
                0304       END
4c563c2ee9 Chri*0305
ec7b4bf650 Jean*0306 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
4c563c2ee9 Chri*0307 CBOP
                0308 C     !ROUTINE: UCASE
                0309
                0310 C     !INTERFACE:
924557e60a Chri*0311       SUBROUTINE UCASE ( string )
e7ea7a463f Alis*0312       IMPLICIT NONE
4c563c2ee9 Chri*0313
                0314 C     !DESCRIPTION:
924557e60a Chri*0315 C     Translate string to upper case.
4c563c2ee9 Chri*0316
                0317 C     !INPUT/OUTPUT PARAMETERS:
924557e60a Chri*0318       CHARACTER*(*) string
4c563c2ee9 Chri*0319
                0320 C     !LOCAL VARIABLES:
924557e60a Chri*0321       CHARACTER*26  LOWER
                0322       DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
                0323       SAVE LOWER
                0324       CHARACTER*26  UPPER
                0325       DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
                0326       SAVE UPPER
                0327       INTEGER   I, L
4c563c2ee9 Chri*0328 CEOP
                0329
924557e60a Chri*0330       DO 10 I = 1, LEN(string)
                0331         L = INDEX(LOWER,string(I:I))
                0332         IF ( L .EQ. 0 ) GOTO 10
                0333           string(I:I) = UPPER(L:L)
                0334    10 CONTINUE
ec7b4bf650 Jean*0335
924557e60a Chri*0336       RETURN
                0337       END