Back to home page

MITgcm
 
 

    

File indexing completed on 2019-08-15 05:10:36 UTC

view on githubraw file Latest commit 6cc227ba on 2019-03-20 19:12:24 UTC
c90c060abd Ed H*0001 #include "DIAG_OPTIONS.h"
                0002 
e129400813 Jean*0003 C--   File diagnostics_utils.F: General purpose support routines
                0004 C--    Contents:
                0005 C--    o DIAGNOSTICS_COUNT
721cebbdca Jean*0006 C--    o DIAGNOSTICS_GET_DIAG
205bd86651 Jean*0007 C--    o DIAGNOSTICS_GET_POINTERS
a0bbeea03c Jean*0008 C--    o DIAGNOSTICS_SETKLEV
205bd86651 Jean*0009 C--    o DIAGS_GET_PARMS_I (Function)
e129400813 Jean*0010 C--    o DIAGS_MK_UNITS (Function)
                0011 C--    o DIAGS_MK_TITLE (Function)
3dcfb9510a Jean*0012 C--    o DIAGS_RENAMED (Function)
e129400813 Jean*0013 
313f3157b9 Ed H*0014 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0015 
337bea277a Jean*0016 CBOP 0
448e4f0724 Jean*0017 C     !ROUTINE: DIAGNOSTICS_COUNT
                0018 C     !INTERFACE:
721cebbdca Jean*0019       SUBROUTINE DIAGNOSTICS_COUNT( diagName,
                0020      I                              biArg, bjArg, myThid )
448e4f0724 Jean*0021 
                0022 C     !DESCRIPTION:
                0023 C***********************************************************************
                0024 C   routine to increment the diagnostic counter only
                0025 C***********************************************************************
                0026 C     !USES:
                0027       IMPLICIT NONE
                0028 
                0029 C     == Global variables ===
                0030 #include "EEPARAMS.h"
                0031 #include "SIZE.h"
                0032 #include "DIAGNOSTICS_SIZE.h"
                0033 #include "DIAGNOSTICS.h"
                0034 
                0035 C     !INPUT PARAMETERS:
                0036 C***********************************************************************
                0037 C  Arguments Description
                0038 C  ----------------------
721cebbdca Jean*0039 C     diagName :: name of diagnostic to increment the counter
448e4f0724 Jean*0040 C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
                0041 C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
                0042 C     myThid   :: my thread Id number
                0043 C***********************************************************************
721cebbdca Jean*0044       CHARACTER*8 diagName
448e4f0724 Jean*0045       INTEGER biArg, bjArg
                0046       INTEGER myThid
                0047 CEOP
                0048 
                0049 C     !LOCAL VARIABLES:
                0050 C ===============
3ae5f90260 Jean*0051       INTEGER m, n
                0052       INTEGER bi, bj
955e921fb3 Jean*0053       INTEGER ipt, ndId
448e4f0724 Jean*0054 c     CHARACTER*(MAX_LEN_MBUF) msgBuf
                0055 
955e921fb3 Jean*0056       IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
                0057         bi = myBxLo(myThid)
                0058         bj = myByLo(myThid)
                0059       ELSE
                0060         bi = MIN(biArg,nSx)
                0061         bj = MIN(bjArg,nSy)
                0062       ENDIF
                0063 
3ae5f90260 Jean*0064 C--   Run through list of active diagnostics to find which counter
                0065 C     to increment (needs to be a valid & active diagnostic-counter)
721cebbdca Jean*0066       DO n=1,nLists
448e4f0724 Jean*0067        DO m=1,nActive(n)
721cebbdca Jean*0068         IF ( diagName.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
3ae5f90260 Jean*0069          ipt = idiag(m,n)
955e921fb3 Jean*0070          IF (ndiag(ipt,bi,bj).GE.0) THEN
b38beaf3c1 Jean*0071           ndId = ABS(jdiag(m,n))
955e921fb3 Jean*0072           ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId)
3ae5f90260 Jean*0073 C-    Increment the counter for the diagnostic
                0074           IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
                0075            DO bj=myByLo(myThid), myByHi(myThid)
                0076             DO bi=myBxLo(myThid), myBxHi(myThid)
                0077              ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
                0078             ENDDO
                0079            ENDDO
                0080           ELSE
                0081              ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
                0082           ENDIF
                0083 C-    Increment is done
                0084          ENDIF
448e4f0724 Jean*0085         ENDIF
                0086        ENDDO
                0087       ENDDO
                0088 
3ae5f90260 Jean*0089       RETURN
448e4f0724 Jean*0090       END
                0091 
                0092 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0093 
                0094 CBOP 0
721cebbdca Jean*0095 C     !ROUTINE: DIAGNOSTICS_GET_DIAG
                0096 
                0097 C     !INTERFACE:
                0098       SUBROUTINE DIAGNOSTICS_GET_DIAG(
                0099      I                    kl, undefRL,
                0100      O                    qtmp,
                0101      I                    ndId, mate, ip, im, bi, bj, myThid )
                0102 
                0103 C     !DESCRIPTION:
                0104 C     Retrieve time-averaged (or snap-shot) diagnostic field
                0105 
                0106 C     !USES:
                0107       IMPLICIT NONE
                0108 #include "EEPARAMS.h"
                0109 #include "SIZE.h"
                0110 #include "DIAGNOSTICS_SIZE.h"
                0111 #include "DIAGNOSTICS.h"
                0112 
                0113 C     !INPUT PARAMETERS:
                0114 C     kl      :: level selection: >0 : single selected lev ; =0 : all kdiag levels
                0115 C     undefRL :: undefined "_RL" type value
                0116 C     ndId    :: diagnostic Id number (in available diagnostics list)
                0117 C     mate    :: counter diagnostic number if any ; 0 otherwise
                0118 C     ip      :: pointer to storage array location for diag.
                0119 C     im      :: pointer to storage array location for mate
                0120 C     bi      :: X-direction tile number
                0121 C     bj      :: Y-direction tile number
                0122 C     myThid  :: my thread Id number
                0123       INTEGER kl
                0124       _RL undefRL
                0125       INTEGER ndId, mate, ip, im
                0126       INTEGER bi, bj, myThid
                0127 
                0128 C     !OUTPUT PARAMETERS:
                0129 C     qtmp    :: time-averaged (or snap-shot) diagnostic field
                0130       _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,*)
                0131 CEOP
                0132 
                0133 C     !LOCAL VARIABLES:
                0134       _RL factor
                0135       INTEGER i, j, ipnt, ipCt
                0136       INTEGER k, kd, km, kLev
                0137 
                0138       IF (ndId.GE.1) THEN
                0139        kLev = kdiag(ndId)
                0140        IF ( kl.GE.1 .AND. kl.LE.kLev ) THEN
                0141         kLev = 1
                0142        ELSEIF ( kl.NE.0 ) THEN
                0143         kLev = 0
                0144        ENDIF
                0145 
                0146        DO k = 1,kLev
                0147         kd = k
                0148         IF ( kl.GE.1 ) kd = kl
                0149 
                0150         IF ( mate.EQ.0 ) THEN
                0151 C-      No counter diagnostics => average = Sum / ndiag :
                0152 
                0153           ipnt = ip + kd - 1
                0154           factor = FLOAT(ndiag(ip,bi,bj))
                0155           IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
                0156 
                0157 #ifdef ALLOW_FIZHI
                0158           DO j = 1,sNy+1
                0159             DO i = 1,sNx+1
                0160               IF ( qdiag(i,j,ipnt,bi,bj) .LE. undefRL ) THEN
                0161                 qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
                0162               ELSE
                0163                 qtmp(i,j,k) = undefRL
                0164               ENDIF
                0165             ENDDO
                0166           ENDDO
                0167 #else /* ALLOW_FIZHI */
                0168           DO j = 1,sNy+1
                0169             DO i = 1,sNx+1
                0170               qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
                0171             ENDDO
                0172           ENDDO
                0173 #endif /* ALLOW_FIZHI */
                0174 
                0175         ELSE
                0176 C-      With counter diagnostics => average = Sum / counter:
                0177 
                0178           ipnt = ip + kd - 1
                0179           km = MIN(kd,kdiag(mate))
                0180           ipCt = im + km - 1
                0181           DO j = 1,sNy+1
                0182             DO i = 1,sNx+1
                0183               IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
                0184                 qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)
                0185      &                      / qdiag(i,j,ipCt,bi,bj)
                0186               ELSE
                0187                 qtmp(i,j,k) = undefRL
                0188               ENDIF
                0189             ENDDO
                0190           ENDDO
                0191 
                0192         ENDIF
                0193        ENDDO
                0194       ENDIF
                0195 
                0196       RETURN
                0197       END
                0198 
                0199 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0200 
                0201 CBOP 0
205bd86651 Jean*0202 C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
                0203 C     !INTERFACE:
                0204       SUBROUTINE DIAGNOSTICS_GET_POINTERS(
                0205      I                       diagName, listId,
                0206      O                       ndId, ip,
                0207      I                       myThid )
                0208 
                0209 C     !DESCRIPTION:
                0210 C     *================================================================*
                0211 C     | o Returns the diagnostic Id number and diagnostic
                0212 C     |   pointer to storage array for a specified diagnostic.
                0213 C     *================================================================*
                0214 C     | Note: A diagnostics field can be stored multiple times
                0215 C     |       (for different output frequency,phase, ...).
                0216 C     | operates in 2 ways:
                0217 C     | o listId =0 => find 1 diagnostics Id & pointer which name matches.
                0218 C     | o listId >0 => find the unique diagnostic Id & pointer with
                0219 C     |      the right name and same output time as "listId" output-list
                0220 C     | o return ip=0 if did not find the right diagnostic;
                0221 C     |   (ndId <>0 if diagnostic exist but output time does not match)
                0222 C     *================================================================*
                0223 
                0224 C     !USES:
                0225       IMPLICIT NONE
                0226 #include "EEPARAMS.h"
                0227 #include "SIZE.h"
                0228 #include "DIAGNOSTICS_SIZE.h"
                0229 #include "DIAGNOSTICS.h"
                0230 
                0231 C     !INPUT PARAMETERS:
                0232 C     diagName :: diagnostic identificator name (8 characters long)
                0233 C     listId   :: list number that specify the output frequency
                0234 C     myThid   :: my Thread Id number
                0235 C     !OUTPUT PARAMETERS:
                0236 C     ndId     :: diagnostics  Id number (in available diagnostics list)
                0237 C     ip       :: diagnostics  pointer to storage array
                0238 
                0239       CHARACTER*8 diagName
                0240       INTEGER listId
                0241       INTEGER ndId, ip
                0242       INTEGER myThid
                0243 CEOP
                0244 
                0245 C     !LOCAL VARIABLES:
                0246       INTEGER n,m
                0247 
                0248       ip   = 0
                0249       ndId = 0
                0250 
                0251       IF ( listId.LE.0 ) THEN
                0252 C--   select the 1rst one which name matches:
                0253 
                0254 C-    search for this diag. in the active 2D/3D diagnostics list
721cebbdca Jean*0255         DO n=1,nLists
205bd86651 Jean*0256          DO m=1,nActive(n)
                0257            IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
                0258      &                  .AND. idiag(m,n).NE.0 ) THEN
                0259             ip   = ABS(idiag(m,n))
b38beaf3c1 Jean*0260             ndId = ABS(jdiag(m,n))
205bd86651 Jean*0261            ENDIF
                0262          ENDDO
                0263         ENDDO
                0264 
721cebbdca Jean*0265       ELSEIF ( listId.LE.nLists ) THEN
205bd86651 Jean*0266 C--   select the unique diagnostic with output-time identical to listId
                0267 
                0268 C-    search for this diag. in the active 2D/3D diagnostics list
721cebbdca Jean*0269         DO n=1,nLists
205bd86651 Jean*0270          IF ( ip.EQ.0
                0271      &        .AND. freq(n) .EQ. freq(listId)
                0272      &        .AND. phase(n).EQ.phase(listId)
                0273      &        .AND. averageFreq(n) .EQ.averageFreq(listId)
                0274      &        .AND. averagePhase(n).EQ.averagePhase(listId)
                0275      &        .AND. averageCycle(n).EQ.averageCycle(listId)
                0276      &      ) THEN
                0277           DO m=1,nActive(n)
                0278            IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
                0279      &                  .AND. idiag(m,n).NE.0 ) THEN
                0280             ip   = ABS(idiag(m,n))
b38beaf3c1 Jean*0281             ndId = ABS(jdiag(m,n))
205bd86651 Jean*0282            ENDIF
                0283           ENDDO
                0284          ELSEIF ( ip.EQ.0 ) THEN
                0285           DO m=1,nActive(n)
                0286            IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
                0287      &                  .AND. idiag(m,n).NE.0 ) THEN
b38beaf3c1 Jean*0288             ndId = ABS(jdiag(m,n))
205bd86651 Jean*0289            ENDIF
                0290           ENDDO
                0291          ENDIF
                0292         ENDDO
                0293 
                0294       ELSE
                0295         STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
                0296       ENDIF
                0297 
                0298       RETURN
                0299       END
                0300 
                0301 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0302 
                0303 CBOP 0
a0bbeea03c Jean*0304 C     !ROUTINE: DIAGNOSTICS_SETKLEV
                0305 
                0306 C     !INTERFACE:
                0307       SUBROUTINE DIAGNOSTICS_SETKLEV(
                0308      I                                diagName, nLevDiag, myThid )
                0309 
                0310 C     !DESCRIPTION:
                0311 C     *==========================================================*
                0312 C     | S/R DIAGNOSTICS_SETKLEV
                0313 C     | o Define explicitly the number of level (stored in kdiag)
                0314 C     |   of a diagnostic field. For most diagnostics, the number
                0315 C     |   of levels is derived (in S/R SET_LEVELS) from gdiag(10)
                0316 C     |   but occasionally one may want to set it explicitly.
                0317 C     *==========================================================*
                0318 
                0319 C     !USES:
                0320       IMPLICIT NONE
                0321 #include "EEPARAMS.h"
                0322 #include "SIZE.h"
                0323 #include "DIAGNOSTICS_SIZE.h"
                0324 #include "DIAGNOSTICS.h"
                0325 
                0326 C     !INPUT PARAMETERS:
                0327 C     diagName  :: diagnostic identificator name (8 characters long)
                0328 C     nLevDiag  :: number of level to set for this diagnostics field
                0329 C     myThid    :: my Thread Id number
                0330       CHARACTER*8  diagName
                0331       INTEGER nLevDiag
                0332       INTEGER myThid
                0333 CEOP
                0334 
                0335 C     !LOCAL VARIABLES:
                0336       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0337       INTEGER n, ndId
                0338 
                0339 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0340 
70be99e003 Jean*0341       _BEGIN_MASTER( myThid)
                0342 
a0bbeea03c Jean*0343 C--   Check if this S/R is called from the right place ;
                0344 C     needs to be after DIAGNOSTICS_INIT_EARLY and before DIAGNOSTICS_INIT_FIXED
8a1f6fb317 Jean*0345       IF ( diag_pkgStatus.NE.ready2setDiags ) THEN
                0346         CALL DIAGNOSTICS_STATUS_ERROR( 'DIAGNOSTICS_SETKLEV',
                0347      &                   ' ', diagName, ready2setDiags, myThid )
a0bbeea03c Jean*0348       ENDIF
                0349 
                0350 C--   Find this diagnostics in the list of available diag.
                0351       ndId = 0
                0352       DO n = 1,ndiagt
                0353         IF ( diagName.EQ.cdiag(n) ) THEN
                0354           ndId = n
                0355         ENDIF
                0356       ENDDO
                0357       IF ( ndId.EQ.0 ) THEN
                0358         WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SETKLEV: ',
                0359      &     'diagName="', diagName, '" not known.'
                0360         CALL PRINT_ERROR( msgBuf, myThid )
                0361         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'
                0362       ENDIF
                0363 
                0364 C-    Optional level number diagnostics (X): set number of levels
                0365       IF ( kdiag(ndId).EQ.0
                0366      &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
                0367         kdiag(ndId) = nLevDiag
                0368       ELSEIF ( kdiag(ndId).EQ.nLevDiag
                0369      &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
                0370 C-    level number already set to same value: send warning
                0371         WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
                0372      &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
                0373         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0374      &                      SQUEEZE_RIGHT , myThid )
                0375         WRITE(msgBuf,'(2A,I5,A)')'** WARNING ** DIAGNOSTICS_SETKLEV:',
                0376      &     ' level Nb (=', kdiag(ndId), ') already set.'
                0377         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0378      &                      SQUEEZE_RIGHT , myThid )
                0379       ELSEIF ( gdiag(ndId)(10:10).EQ.'X' ) THEN
                0380 C-    level number already set to a different value: do not reset but stop
                0381         WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',
                0382      &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
                0383         CALL PRINT_ERROR( msgBuf, myThid )
                0384         WRITE(msgBuf,'(2A,I5,3A)') 'DIAGNOSTICS_SETKLEV: ',
                0385      &     'level Nb already set to', kdiag(ndId), ' => STOP'
                0386         CALL PRINT_ERROR( msgBuf, myThid )
                0387       ELSE
                0388 C-    for now, do nothing but just send a warning
                0389         WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
                0390      &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
                0391         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0392      &                      SQUEEZE_RIGHT , myThid )
                0393         WRITE(msgBuf,'(2A,I5,3A)') '** WARNING ** will set level Nb',
                0394      &     ' from diagCode(ndId=', ndId, ')="', gdiag(ndId)(1:10), '"'
                0395         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0396      &                      SQUEEZE_RIGHT , myThid )
                0397         WRITE(msgBuf,'(4A)') '** WARNING ** DIAGNOSTICS_SETKLEV',
                0398      &     '("', diagName, '") <== Ignore this call.'
                0399         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0400      &                      SQUEEZE_RIGHT , myThid )
                0401       ENDIF
                0402 
70be99e003 Jean*0403       _END_MASTER( myThid)
                0404 
a0bbeea03c Jean*0405       RETURN
                0406       END
                0407 
                0408 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0409 
                0410 CBOP 0
205bd86651 Jean*0411 C     !ROUTINE: DIAGS_GET_PARMS_I
                0412 
                0413 C     !INTERFACE:
                0414       INTEGER FUNCTION DIAGS_GET_PARMS_I(
                0415      I                            parName, myThid )
                0416 
                0417 C     !DESCRIPTION:
                0418 C     *==========================================================*
                0419 C     | FUNCTION DIAGS_GET_PARMS_I
                0420 C     | o Return the value of integer parameter
                0421 C     |   from one of the DIAGNOSTICS.h common blocs
                0422 C     *==========================================================*
                0423 
                0424 C     !USES:
                0425       IMPLICIT NONE
                0426 #include "EEPARAMS.h"
                0427 #include "SIZE.h"
                0428 #include "DIAGNOSTICS_SIZE.h"
                0429 #include "DIAGNOSTICS.h"
                0430 
                0431 C     !INPUT PARAMETERS:
                0432 C     parName   :: string used to identify which parameter to get
                0433 C     myThid    :: my Thread Id number
                0434       CHARACTER*(*) parName
                0435       INTEGER myThid
                0436 CEOP
                0437 
                0438 C     !LOCAL VARIABLES:
                0439       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0440       INTEGER n
                0441 
                0442 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0443 
                0444       n = LEN(parName)
                0445 c     write(0,'(3A,I4)')
                0446 c    &  'DIAGS_GET_PARMS_I: parName="',parName,'" , length=',n
                0447 
                0448       IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
                0449          DIAGS_GET_PARMS_I = ndiagt
                0450       ELSE
                0451          WRITE(msgBuf,'(4A)') 'DIAGS_GET_PARMS_I: ',
                0452      &    ' parName="', parName, '" not known.'
                0453          CALL PRINT_ERROR( msgBuf, myThid )
                0454          STOP 'ABNORMAL END: S/R DIAGS_GET_PARMS_I'
                0455       ENDIF
                0456 
                0457       RETURN
                0458       END
                0459 
                0460 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0461 
                0462 CBOP 0
db26b4dd29 Jean*0463 C     !ROUTINE: DIAGS_MK_UNITS
                0464 
                0465 C     !INTERFACE:
3ae5f90260 Jean*0466       CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
db26b4dd29 Jean*0467      I                            diagUnitsInPieces, myThid )
                0468 
                0469 C     !DESCRIPTION:
                0470 C     *==========================================================*
                0471 C     | FUNCTION DIAGS_MK_UNITS
3ae5f90260 Jean*0472 C     | o Return the diagnostic units string (16c) removing
db26b4dd29 Jean*0473 C     |   blanks from the input string
                0474 C     *==========================================================*
                0475 
                0476 C     !USES:
                0477       IMPLICIT NONE
                0478 #include "EEPARAMS.h"
                0479 
                0480 C     !INPUT PARAMETERS:
3ae5f90260 Jean*0481 C     diagUnitsInPieces :: string for diagnostic units: in several
db26b4dd29 Jean*0482 C                          pieces, with blanks in between
                0483 C     myThid            ::  my thread Id number
                0484       CHARACTER*(*) diagUnitsInPieces
                0485       INTEGER      myThid
                0486 CEOP
                0487 
                0488 C     !LOCAL VARIABLES:
                0489       CHARACTER*(MAX_LEN_MBUF) msgBuf
869e534853 Jean*0490       INTEGER i,j,n,nbc
db26b4dd29 Jean*0491 
a0bbeea03c Jean*0492       DIAGS_MK_UNITS = '                '
db26b4dd29 Jean*0493       n = LEN(diagUnitsInPieces)
3ae5f90260 Jean*0494 
db26b4dd29 Jean*0495       j = 0
                0496       DO i=1,n
                0497        IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
                0498          j = j+1
                0499          IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
                0500        ENDIF
                0501       ENDDO
869e534853 Jean*0502       nbc = j
                0503 
                0504       IF ( nbc.GT.16 ) THEN
                0505 C-    try to reduce length by changing m^2 & m^3 to m2 & m3:
                0506        DIAGS_MK_UNITS = '                '
                0507        j = 0
                0508        DO i=1,n
                0509         IF ( diagUnitsInPieces(i:i) .NE. ' ' ) THEN
                0510          IF ( j.GE.1 .AND. nbc.GT.16 .AND.
                0511      &         diagUnitsInPieces(i:i).EQ.'^' ) THEN
                0512           IF ( diagUnitsInPieces(i-1:i-1).EQ.'m' ) THEN
                0513             nbc = nbc - 1
                0514           ELSE
                0515            j = j+1
                0516            IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
                0517           ENDIF
                0518          ELSE
                0519           j = j+1
                0520           IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
                0521          ENDIF
                0522         ENDIF
                0523        ENDDO
                0524       ENDIF
db26b4dd29 Jean*0525 
                0526       IF ( j.GT.16 ) THEN
a0bbeea03c Jean*0527          WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
db26b4dd29 Jean*0528      &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
                0529         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0530      &       SQUEEZE_RIGHT , myThid)
a0bbeea03c Jean*0531          WRITE(msgBuf,'(3A)') '** WARNING ** ',
db26b4dd29 Jean*0532      &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
                0533         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0534      &       SQUEEZE_RIGHT , myThid)
                0535       ENDIF
                0536 
                0537       RETURN
                0538       END
2b8fe1e3ff Jean*0539 
                0540 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0541 
                0542 CBOP 0
                0543 C     !ROUTINE: DIAGS_MK_TITLE
                0544 
                0545 C     !INTERFACE:
                0546       CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
                0547      I                            diagTitleInPieces, myThid )
                0548 
                0549 C     !DESCRIPTION:
                0550 C     *==========================================================*
                0551 C     | FUNCTION DIAGS_MK_TITLE
                0552 C     | o Return the diagnostic title string (80c) removing
                0553 C     |   consecutive blanks from the input string
                0554 C     *==========================================================*
                0555 
                0556 C     !USES:
                0557       IMPLICIT NONE
                0558 #include "EEPARAMS.h"
                0559 
                0560 C     !INPUT PARAMETERS:
                0561 C     diagTitleInPieces :: string for diagnostic units: in several
                0562 C                          pieces, with blanks in between
                0563 C     myThid            ::  my Thread Id number
                0564       CHARACTER*(*) diagTitleInPieces
                0565       INTEGER      myThid
                0566 CEOP
                0567 
                0568 C     !LOCAL VARIABLES:
                0569       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0570       LOGICAL flag
                0571       INTEGER i,j,n
                0572 
85e5c644de Andr*0573 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
2b8fe1e3ff Jean*0574 
                0575       DIAGS_MK_TITLE = '                                        '
                0576      &               //'                                        '
                0577       n = LEN(diagTitleInPieces)
                0578 
                0579       j = 0
                0580       flag = .FALSE.
                0581       DO i=1,n
                0582        IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
                0583          IF ( flag ) THEN
                0584            j = j+1
                0585            IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
                0586          ENDIF
                0587          j = j+1
                0588          IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
                0589          flag = .FALSE.
                0590        ELSE
                0591          flag = j.GE.1
                0592        ENDIF
                0593       ENDDO
                0594 
                0595       IF ( j.GT.80 ) THEN
a0bbeea03c Jean*0596          WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
2b8fe1e3ff Jean*0597      &   'DIAGS_MK_TITLE: too long (',j,' >80) input string'
                0598         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0599      &       SQUEEZE_RIGHT , myThid)
a0bbeea03c Jean*0600          WRITE(msgBuf,'(3A)') '** WARNING ** ',
2b8fe1e3ff Jean*0601      &   'DIAGS_MK_TITLE: input=', diagTitleInPieces
                0602         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0603      &       SQUEEZE_RIGHT , myThid)
                0604       ENDIF
                0605 
                0606       RETURN
                0607       END
3dcfb9510a Jean*0608 
                0609 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0610 
                0611 CBOP 0
                0612 C     !ROUTINE: DIAGS_RENAMED
                0613 
                0614 C     !INTERFACE:
                0615       CHARACTER*8 FUNCTION DIAGS_RENAMED(
                0616      I                           diagName, myThid )
                0617 
                0618 C     !DESCRIPTION:
                0619 C     *==========================================================*
                0620 C     | FUNCTION DIAGS_RENAMED
                0621 C     | o In case of an old diagnostics name,
                0622 C     |   provides the corresponding new name
                0623 C     *==========================================================*
                0624 
                0625 C     !USES:
                0626       IMPLICIT NONE
                0627 #include "EEPARAMS.h"
                0628 #include "SIZE.h"
                0629 #include "PARAMS.h"
                0630 #include "DIAGNOSTICS_SIZE.h"
                0631 #include "DIAGNOSTICS.h"
                0632 
                0633 C     !INPUT PARAMETERS:
                0634 C     diagName  :: name of diagnostic to rename (or not)
                0635 C     myThid    :: my Thread Id number
                0636       CHARACTER*8 diagName
                0637       INTEGER myThid
                0638 CEOP
                0639 
                0640 C     !LOCAL VARIABLES:
                0641       CHARACTER*8 newName
                0642       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0643 
                0644 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0645 
                0646       newName = blkName
                0647 
                0648       IF ( useSEAICE ) THEN
                0649        IF ( diagName .EQ. 'SIfu    ' ) newName = 'oceTAUX '
                0650        IF ( diagName .EQ. 'SIfv    ' ) newName = 'oceTAUY '
                0651        IF ( diagName .EQ. 'SIuwind ' ) newName = 'EXFuwind'
                0652        IF ( diagName .EQ. 'SIvwind ' ) newName = 'EXFvwind'
7c20314e9e Mart*0653        IF ( diagName .EQ. 'SIsigI  ' ) newName = 'SIsig1  '
                0654        IF ( diagName .EQ. 'SIsigII ' ) newName = 'SIsig2  '
3dcfb9510a Jean*0655       ENDIF
6cc227ba22 Jean*0656        IF ( diagName .EQ. 'Um_dPHdx' ) newName = 'Um_dPhiX'
                0657        IF ( diagName .EQ. 'Vm_dPHdy' ) newName = 'Vm_dPhiY'
3dcfb9510a Jean*0658 
                0659       IF ( newName.EQ.blkName ) THEN
                0660         DIAGS_RENAMED = diagName
                0661       ELSE
                0662         DIAGS_RENAMED = newName
                0663         WRITE(msgBuf,'(6A)') '** WARNING ** (DIAGS_RENAMED):',
                0664      &    ' diagnostics "', diagName, '" replaced by "', newName, '"'
                0665         CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0666      &                      SQUEEZE_RIGHT , myThid )
                0667         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0668      &                      SQUEEZE_RIGHT , myThid )
                0669       ENDIF
                0670 
                0671       RETURN
                0672       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!