Back to home page

MITgcm

 
 

    


File indexing completed on 2024-07-17 05:10:41 UTC

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