MITgcm/optim/utils.F

4cee17c1be Patr*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.
                0008 C--   IO_ERRCOUNT     - Reads IO error counter.
                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
                0015 CStartOfInterface
                0016       SUBROUTINE DATE ( string , myThreadId )
                0017 C     /==========================================================\
                0018 C     | SUBROUTINE DATE                                          |
                0019 C     | o Return current date                                    |
                0020 C     \==========================================================/
                0021       IMPLICIT NONE
                0022 #include "SIZE.h"
                0023 #include "EEPARAMS.h"
                0024 C
                0025       CHARACTER*(*) string
                0026       INTEGER myThreadId
                0027 CEndOfInterface
                0028 C
                0029       INTEGER lDate
                0030       CHARACTER*(MAX_LEN_MBUF) msgBuffer
                0031 C
                0032       lDate = 24
                0033       IF ( LEN(string) .LT. lDate ) GOTO 901
                0034       string = ' '
e51ecc3fef Ed H*0035 #ifdef HAVE_FDATE
4cee17c1be Patr*0036       CALL FDATE( string )
                0037 #endif
                0038 C
                0039  1000 CONTINUE
                0040       RETURN
                0041   901 CONTINUE
                0042       WRITE(msgBuffer,'(A)')
                0043      &'                                                       '
                0044       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0045      &SQUEEZE_RIGHT,myThreadId)
                0046       WRITE(msgBuffer,'(A)')
                0047      &'*** WARNING WARNING WARNING WARNING WARNING WARNING ***'
                0048       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0049      &SQUEEZE_RIGHT,myThreadId)
                0050       WRITE(msgBuffer,'(A)')
                0051      &'procedure: "DATE".'
                0052       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0053      &SQUEEZE_RIGHT,myThreadId)
                0054       WRITE(msgBuffer,'(A)')
                0055      &'Variable passed to S/R DATE is too small.'
                0056       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0057      &SQUEEZE_RIGHT,myThreadId)
                0058       WRITE(msgBuffer,'(A)')
                0059      &' Argument must be at least',lDate,'characters long.'
                0060       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0061      &SQUEEZE_RIGHT,myThreadId)
                0062       WRITE(msgBuffer,'(A)')
                0063      &'*******************************************************'
                0064       CALL PRINT_MESSAGE(msgBuffer,standardMessageUnit,
                0065      &SQUEEZE_RIGHT,myThreadId)
                0066       GOTO 1000
                0067       END
                0068
                0069 CStartOfInterface
                0070       INTEGER FUNCTION IFNBLNK( string )
                0071 C     /==========================================================\
                0072 C     | FUNCTION IFNBLNK                                         |
                0073 C     | o Find first non-blank in character string.              |
                0074 C     \==========================================================/
                0075       IMPLICIT NONE
                0076 C
                0077       CHARACTER*(*) string
                0078 CEndOfInterface
                0079 C
                0080       INTEGER L, LS
                0081 C
                0082       LS     = LEN(string)
                0083       IFNBLNK = 0
                0084       DO 10 L = 1, LS
                0085        IF ( string(L:L) .EQ. ' ' ) GOTO 10
                0086         IFNBLNK = L
                0087         GOTO 11
                0088    10 CONTINUE
                0089    11 CONTINUE
                0090 C
                0091       RETURN
                0092       END
                0093
                0094 CStartOfInterface
                0095       INTEGER FUNCTION ILNBLNK( string )
                0096 C     /==========================================================\
                0097 C     | FUNCTION ILNBLNK                                         |
                0098 C     | o Find last non-blank in character string.               |
                0099 C     \==========================================================/
                0100       IMPLICIT NONE
                0101       CHARACTER*(*) string
                0102 CEndOfInterface
                0103       INTEGER L, LS
                0104 C
                0105       LS      = LEN(string)
                0106       ILNBLNK = LS
                0107       DO 10 L = LS, 1, -1
                0108         IF ( string(L:L) .EQ. ' ' ) GOTO 10
                0109          ILNBLNK = L
                0110          GOTO 11
                0111    10 CONTINUE
                0112    11 CONTINUE
                0113 C
                0114       RETURN
                0115       END
                0116
                0117 CStartofinterface
                0118       INTEGER FUNCTION IO_ERRCOUNT(myThid)
                0119 C     /==========================================================\
                0120 C     | FUNCTION IO_ERRCOUNT                                     |
                0121 C     | o Reads IO error counter.                                |
                0122 C     \==========================================================/
                0123       IMPLICIT NONE
                0124 C     == Global variables ==
                0125 #include "SIZE.h"
                0126 #include "EEPARAMS.h"
                0127
                0128 C     == Routine arguments ==
                0129       INTEGER myThid
                0130 CEndofinterface
                0131
                0132       IO_ERRCOUNT = ioErrorCount(myThid)
                0133
                0134       RETURN
                0135       END
                0136
                0137 CStartOfInterface
                0138       SUBROUTINE LCASE ( string )
                0139 C     /==========================================================\
                0140 C     | SUBROUTINE LCASE                                         |
                0141 C     | o Convert character string to all lower case.            |
                0142 C     \==========================================================/
                0143       IMPLICIT NONE
                0144       CHARACTER*(*) string
                0145 CEndOfInterface
                0146       CHARACTER*26  LOWER
                0147       DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
                0148       SAVE LOWER
                0149       CHARACTER*26  UPPER
                0150       DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
                0151       SAVE UPPER
                0152       INTEGER   I, L
                0153 C
                0154       DO 10 I = 1, LEN(string)
                0155         L = INDEX(UPPER,string(I:I))
                0156         IF ( L .EQ. 0 ) GOTO 10
                0157          string(I:I) = LOWER(L:L)
                0158    10 CONTINUE
                0159 C
                0160       RETURN
                0161       END
                0162
                0163 CStartOfInterface
                0164       SUBROUTINE MACHINE ( string )
                0165 C     /==========================================================\
                0166 C     | SUBROUTINE MACHINE                                       |
                0167 C     | o Return computer identifier in string.                  |
                0168 C     \==========================================================/
                0169       IMPLICIT NONE
                0170 #include "SIZE.h"
                0171 #include "EEPARAMS.h"
                0172       CHARACTER*(*) string
                0173 CEndOfInterface
                0174 C
                0175       INTEGER  IFNBLNK
                0176       INTEGER  ILNBLNK
                0177       EXTERNAL IFNBLNK
                0178       EXTERNAL ILNBLNK
                0179 C
                0180       INTEGER  iFirst
                0181       INTEGER  iLast
                0182       INTEGER  iEnd
                0183       INTEGER  iFree
                0184       INTEGER  idSize
                0185       CHARACTER*1024 strTmp
                0186       CHARACTER*1024 idString
                0187
                0188       strTmp = 'UNKNOWN'
                0189       iFree  = 1
                0190       idSize = LEN(string)
                0191 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
                0192       IFirst = 0
                0193       CALL PXFGETENV('USER',iFirst,strTmp,ILast,Iend  )
                0194 #else
                0195       CALL GETENV('USER',strTmp  )
                0196 #endif
                0197       IF ( strTmp .NE. ' ' ) THEN
                0198         iFirst = IFNBLNK(strTmp)
                0199         iLast  = ILNBLNK(strTmp)
                0200         iEnd   = iLast-iFirst+1
                0201         IF (iEnd .GE. 0 ) THEN
                0202          idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
                0203         ENDIF
                0204         iFree = iFree+iEnd+1
                0205         IF ( iFree .LE. idSize ) THEN
                0206           idString(iFree:iFree) = '@'
                0207           iFree = iFree+1
                0208         ENDIF
                0209       ENDIF
                0210       strTmp = 'UNKNOWN'
                0211 #if (defined (TARGET_T3E) || defined (TARGET_CRAY_VECTOR))
                0212       IFirst = 0
                0213       CALL PXFGETENV('HOST',iFirst,strTmp,ILast,Iend  )
                0214 #else
                0215       CALL GETENV('HOST',strTmp  )
                0216 #endif
                0217       IF ( strTmp .NE. ' ' ) THEN
                0218         iFirst = IFNBLNK(strTmp)
                0219         iLast  = ILNBLNK(strTmp)
                0220         iEnd   = iLast-iFirst+1
                0221         iEnd   = MIN(iEnd,idSize-iFree)
                0222         iEnd   = iEnd-1
                0223         IF (iEnd .GE. 0 ) THEN
                0224           idString(iFree:) = strTmp(iFirst:iFirst+iEnd)
                0225         ENDIF
                0226         iFree = iFree+iEnd+1
                0227       ENDIF
                0228 C
                0229       string = idString
                0230 C
                0231  1000 CONTINUE
                0232       RETURN
                0233       END
                0234 C***********************************************************************
                0235       SUBROUTINE UCASE ( string )
                0236       IMPLICIT NONE
                0237 C     Translate string to upper case.
                0238       CHARACTER*(*) string
                0239       CHARACTER*26  LOWER
                0240       DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
                0241       SAVE LOWER
                0242       CHARACTER*26  UPPER
                0243       DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
                0244       SAVE UPPER
                0245       INTEGER   I, L
                0246 C
                0247       DO 10 I = 1, LEN(string)
                0248         L = INDEX(LOWER,string(I:I))
                0249         IF ( L .EQ. 0 ) GOTO 10
                0250           string(I:I) = UPPER(L:L)
                0251    10 CONTINUE
                0252 C
                0253       RETURN
                0254       END
                0255 C************************************************************************