pkg/diagnostics/diagnostics_set_levels.F

09ceb40cd6 Jean*0001 #include "DIAG_OPTIONS.h"
                0002
                0003 CBOP 0
                0004 C     !ROUTINE: DIAGNOSTICS_SET_LEVELS
                0005
                0006 C     !INTERFACE:
                0007       SUBROUTINE DIAGNOSTICS_SET_LEVELS( myThid )
                0008
                0009 C     !DESCRIPTION:
                0010 C     Initialize Diagnostic Levels, according to GDIAG
                0011 C      for all available diagnostics
                0012 C     Notes: needs to be called after all packages set they own available
                0013 C            diagnostics
                0014
                0015 C     \begin{center}
                0016 C       \begin{tabular}[h]{|c|c|}\hline
                0017 C         \textbf{Positions}  &  \textbf{Characters}
                0018 C         &  \textbf{Meanings} \\\hline
                0019 C         parse(10) &  0  &  levels = 0  \\
                0020 C                   &  1  &  levels = 1  \\
                0021 C                   &  R  &  levels = Nr  \\
                0022 C                   &  L  &  levels = MAX(Nr,NrPhys)  \\
                0023 C                   &  M  &  levels = MAX(Nr,NrPhys) - 1  \\
83678acfcc Jean*0024 C                   &  G  &  levels = Ground_level Number \\
                0025 C                   &  I  &  levels = sea-Ice_level Number \\
a0bbeea03c Jean*0026 C                   &  X  &  free levels option (need to be set explicitly) \\
09ceb40cd6 Jean*0027 C       \end{tabular}
                0028 C     \end{center}
                0029
                0030 C     !USES:
                0031       IMPLICIT NONE
                0032
                0033 #include "SIZE.h"
83678acfcc Jean*0034 #define SIZE_IS_SET
09ceb40cd6 Jean*0035 #include "EEPARAMS.h"
                0036 #include "PARAMS.h"
                0037 #include "DIAGNOSTICS_SIZE.h"
                0038 #include "DIAGNOSTICS.h"
                0039
                0040 #ifdef ALLOW_FIZHI
                0041 #include "fizhi_SIZE.h"
                0042 #else
                0043        INTEGER Nrphys
                0044        PARAMETER (Nrphys=0)
                0045 #endif
                0046
83678acfcc Jean*0047 #ifdef ALLOW_LAND
                0048 #include "LAND_SIZE.h"
                0049 #else
                0050       INTEGER land_nLev
                0051       PARAMETER ( land_nLev = 0 )
                0052 #endif
                0053
09ceb40cd6 Jean*0054 C     !INPUT PARAMETERS:
8c2b124434 Jean*0055 C     myThid :: my Thread Id number
09ceb40cd6 Jean*0056       INTEGER myThid
                0057 CEOP
                0058
8c2b124434 Jean*0059 C     !LOCAL VARIABLES:
e129400813 Jean*0060       INTEGER l, n, ncount
                0061       INTEGER nlevs, nGroundLev
8c2b124434 Jean*0062       INTEGER  dUnit, stdUnit
                0063       CHARACTER*(MAX_LEN_MBUF) msgBuf
e129400813 Jean*0064       CHARACTER*84 ccHead, ccLine
                0065       CHARACTER*10 gcode
a0bbeea03c Jean*0066       CHARACTER*1  g10code
8c2b124434 Jean*0067       INTEGER  ILNBLNK
                0068       EXTERNAL ILNBLNK
09ceb40cd6 Jean*0069
8c2b124434 Jean*0070 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
09ceb40cd6 Jean*0071
e01144d3ad Jean*0072       _BARRIER
e3e2b00dee Jean*0073       _BEGIN_MASTER( myThid )
                0074
a0bbeea03c Jean*0075 C--   Diagnostics definition/setting ends (cannot add diags to list anymore)
ab43bc12c4 Jean*0076 c     IF ( diag_pkgStatus.NE.2 ) STOP
                0077       diag_pkgStatus = 3
a0bbeea03c Jean*0078
09ceb40cd6 Jean*0079       nlevs   = MAX(Nr,Nrphys)
83678acfcc Jean*0080       nGroundLev = land_nLev
09ceb40cd6 Jean*0081
e129400813 Jean*0082 C     Diagnostic Levels
                0083 C     -----------------
a0bbeea03c Jean*0084       ncount = 0
09ceb40cd6 Jean*0085       DO n = 1,ndiagt
a0bbeea03c Jean*0086         g10code = gdiag(n)(10:10)
                0087         IF     ( g10code .EQ. '0' ) THEN
219b3f2d10 Jean*0088           kdiag(n) = 0
a0bbeea03c Jean*0089         ELSEIF ( g10code .EQ. '1' ) THEN
219b3f2d10 Jean*0090           kdiag(n) = 1
a0bbeea03c Jean*0091         ELSEIF ( g10code .EQ. 'R' ) THEN
219b3f2d10 Jean*0092           kdiag(n) = Nr
a0bbeea03c Jean*0093         ELSEIF ( g10code .EQ. 'L' ) THEN
219b3f2d10 Jean*0094           kdiag(n) = nlevs
a0bbeea03c Jean*0095         ELSEIF ( g10code .EQ. 'M' ) THEN
219b3f2d10 Jean*0096           kdiag(n) = nlevs - 1
a0bbeea03c Jean*0097         ELSEIF ( g10code .EQ. 'G' ) THEN
219b3f2d10 Jean*0098           kdiag(n) = nGroundLev
a0bbeea03c Jean*0099         ELSEIF ( g10code .EQ. 'g' ) THEN
219b3f2d10 Jean*0100           kdiag(n) = 1
a0bbeea03c Jean*0101         ELSEIF ( g10code .EQ. 'X' ) THEN
                0102          IF ( kdiag(n) .LE. 0 ) THEN
                0103           WRITE(msgBuf,'(2A,I4,3A)')
                0104      &     '** WARNING ** DIAGNOSTICS_SET_LEVELS: ',
                0105      &     'level Nb =', kdiag(n), ' < 1 for diag."', cdiag(n),'"'
                0106           CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0107      &                        SQUEEZE_RIGHT , myThid )
                0108          ENDIF
                0109         ELSE
                0110 C-      enforce a strict matching:
                0111           WRITE(msgBuf,'(2A,4A)') 'DIAGNOSTICS_SET_LEVELS: ',
                0112      &     'invalid gdiag(10)="', g10code, '" code for diag."',
                0113      &                            cdiag(n),'"'
                0114           CALL PRINT_ERROR( msgBuf , myThid )
                0115           ncount = ncount + 1
219b3f2d10 Jean*0116         ENDIF
09ceb40cd6 Jean*0117       ENDDO
a0bbeea03c Jean*0118       IF ( ncount.GT.0 ) THEN
                0119         WRITE(msgBuf,'(2A,I6,3A)') 'DIAGNOSTICS_SET_LEVELS: ',
                0120      &   'found', ncount, ' invalid parser "gdiag(10)" => STOP'
                0121         CALL PRINT_ERROR( msgBuf , myThid )
                0122         STOP 'ABNORMAL END: S/R DIAGSTATS_SET_LEVELS'
                0123       ENDIF
09ceb40cd6 Jean*0124
9de9316d99 Jean*0125 C--   Check for inconsistent diagnostic parser field
                0126       ncount = 0
                0127       DO n = 1,ndiagt
                0128        gcode = gdiag(n)(1:10)
                0129        IF ( ( gcode(3:3).EQ.'r' .OR. gcode(3:3).EQ.'R' )
                0130      &                         .AND. gcode(10:10).NE.'R' ) THEN
                0131         WRITE(msgBuf,'(2A,4A)') 'DIAGNOSTICS_SET_LEVELS: ',
                0132      &   'inconsistent gdiag(3&10)="',gcode,'" for diag."',cdiag(n),'"'
                0133         CALL PRINT_ERROR( msgBuf , myThid )
                0134         ncount = ncount + 1
                0135        ENDIF
                0136       ENDDO
                0137       IF ( ncount.GT.0 ) THEN
                0138         WRITE(msgBuf,'(2A,I6,3A)') 'DIAGNOSTICS_SET_LEVELS: ',
                0139      &   'found', ncount, ' inconsistent parser "gdiag" => STOP'
                0140         CALL PRINT_ERROR( msgBuf , myThid )
                0141         STOP 'ABNORMAL END: S/R DIAGSTATS_SET_LEVELS'
                0142       ENDIF
                0143
e129400813 Jean*0144 C--   Check for unvalid diag.mate number
                0145       ncount = 0
                0146       DO n = 1,ndiagt
                0147        IF ( hdiag(n).LT.0 .OR. hdiag(n).GT.ndiagt ) THEN
                0148         WRITE(msgBuf,'(2A,I6,3A)') 'DIAGNOSTICS_SET_LEVELS: ',
                0149      &    'unvalid mate number=',hdiag(n),' for diag."',cdiag(n),'"'
                0150         CALL PRINT_ERROR( msgBuf , myThid )
                0151         ncount = ncount + 1
                0152        ENDIF
c534926046 Jean*0153        gcode = gdiag(n)(1:10)
                0154        IF ( ( gcode(5:5).EQ.'C' .OR. gcode(5:5).EQ.'P' )
                0155      &                         .AND. hdiag(n).EQ.0 ) THEN
                0156         WRITE(msgBuf,'(6A)') 'DIAGNOSTICS_SET_LEVELS: ',
                0157      &    'mate number required for diag."',cdiag(n),
                0158      &    '" (gdiag(5)=',gcode(5:5),')'
                0159         CALL PRINT_ERROR( msgBuf , myThid )
                0160         ncount = ncount + 1
                0161        ENDIF
e129400813 Jean*0162       ENDDO
                0163       IF ( ncount.GT.0 ) THEN
                0164         WRITE(msgBuf,'(2A,I6,3A)') 'DIAGNOSTICS_SET_LEVELS: ',
c534926046 Jean*0165      &    'found', ncount, ' unvalid/missing mate number(s) => STOP'
e129400813 Jean*0166         CALL PRINT_ERROR( msgBuf , myThid )
                0167         STOP 'ABNORMAL END: S/R DIAGSTATS_SET_LEVELS'
                0168       ENDIF
                0169
9de9316d99 Jean*0170 C--   Print to standard output
8c2b124434 Jean*0171       stdUnit = standardMessageUnit
                0172       WRITE(msgBuf,'(2A)')
                0173      &   '------------------------------------------------------------'
                0174       CALL PRINT_MESSAGE( msgBuf, stdUnit,SQUEEZE_RIGHT, myThid)
                0175       WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_LEVELS: done'
                0176       CALL PRINT_MESSAGE( msgBuf, stdUnit,SQUEEZE_RIGHT, myThid)
e129400813 Jean*0177       WRITE(msgBuf,'(A,I6)')
8c2b124434 Jean*0178      &   ' Total Nb of available Diagnostics: ndiagt=', ndiagt
                0179       CALL PRINT_MESSAGE( msgBuf, stdUnit,SQUEEZE_RIGHT, myThid)
                0180
                0181 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0182 C     write a summary of the (long) list of all available diagnostics:
41c4545f8f Jean*0183       IF ( diag_dBugLevel.GE.debLevA .AND. myProcId.EQ.0 ) THEN
8c2b124434 Jean*0184
                0185         WRITE(msgBuf,'(2A)')
                0186      &   ' write list of available Diagnostics to file: ',
b89cfd6db1 Jean*0187      &   'available_diagnostics.log'
8c2b124434 Jean*0188         CALL PRINT_MESSAGE( msgBuf, stdUnit,SQUEEZE_RIGHT, myThid)
                0189
                0190         WRITE(ccHead,'(2A)')
e129400813 Jean*0191      &   '  Num  |<-Name->|Levs|  mate |<- code ->|',
                0192      &   '<--  Units   -->|<- Tile (max=80c)'
8c2b124434 Jean*0193         DO l=1,LEN(ccLine)
                0194          ccLine(l:l) = '-'
                0195         ENDDO
                0196
e01144d3ad Jean*0197         CALL MDSFINDUNIT( dUnit, myThid )
dd5a4867c9 Jean*0198         OPEN(dUnit, file='available_diagnostics.log',
                0199      &              status='unknown', form='formatted')
e129400813 Jean*0200         WRITE(dUnit,'(A,I6)')
8c2b124434 Jean*0201      &   ' Total Nb of available Diagnostics: ndiagt=', ndiagt
                0202         WRITE(dUnit,'(A)') ccLine
                0203         WRITE(dUnit,'(A)') ccHead
                0204         WRITE(dUnit,'(A)') ccLine
                0205         DO n=1,ndiagt
                0206          IF ( MOD(n,100).EQ.0 ) THEN
                0207            WRITE(dUnit,'(A)') ccLine
                0208            WRITE(dUnit,'(A)') ccHead
                0209            WRITE(dUnit,'(A)') ccLine
                0210          ENDIF
                0211          l = ILNBLNK(tdiag(n))
e129400813 Jean*0212          gcode = gdiag(n)(1:10)
                0213          IF ( hdiag(n).NE.0 .AND. l.GE.1 ) THEN
                0214            WRITE(dUnit,'(I6,3A,I3,A,I6,6A)') n, ' |', cdiag(n), '|',
                0215      &                 kdiag(n),' |', hdiag(n), ' |', gcode, '|',
                0216      &                 udiag(n), '|', tdiag(n)(1:l)
                0217          ELSEIF ( hdiag(n).NE.0 ) THEN
                0218            WRITE(dUnit,'(I6,3A,I3,A,I6,6A)') n, ' |', cdiag(n), '|',
                0219      &                 kdiag(n),' |', hdiag(n), ' |', gcode, '|',
                0220      &                 udiag(n), '|'
                0221          ELSEIF (l.GE.1) THEN
                0222            WRITE(dUnit,'(I6,3A,I3,6A)')      n, ' |', cdiag(n), '|',
                0223      &                 kdiag(n),' |       |',         gcode, '|',
                0224      &                 udiag(n), '|', tdiag(n)(1:l)
8c2b124434 Jean*0225          ELSE
e129400813 Jean*0226            WRITE(dUnit,'(I6,3A,I3,6A)')      n, ' |', cdiag(n), '|',
                0227      &                 kdiag(n),' |       |',         gcode, '|',
                0228      &                 udiag(n), '|'
8c2b124434 Jean*0229          ENDIF
                0230         ENDDO
                0231         WRITE(dUnit,'(A)') ccLine
                0232         WRITE(dUnit,'(A)') ccHead
                0233         WRITE(dUnit,'(A)') ccLine
                0234         CLOSE(dUnit)
                0235
                0236 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0237       ENDIF
94db193af3 Jean*0238
                0239 C--   Check for multiple definition of the same diagnostic name
                0240       DO n = 2,ndiagt
ab43bc12c4 Jean*0241        IF ( cdiag(n).NE.blkName ) THEN
94db193af3 Jean*0242         DO l = 1,n-1
                0243          IF ( cdiag(l).EQ.cdiag(n) ) THEN
                0244             WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_LEVELS: ',
                0245      &       'diag.Name: ',cdiag(n),' registered 2 times :'
                0246             CALL PRINT_ERROR( msgBuf , myThid )
                0247             WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_LEVELS: ',
                0248      &       '1rst (l=', l, ' ), title= ',tdiag(l)
                0249             CALL PRINT_ERROR( msgBuf , myThid )
                0250             WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_LEVELS: ',
                0251      &       ' 2nd (n=', n, ' ), title= ',tdiag(n)
                0252             CALL PRINT_ERROR( msgBuf , myThid )
                0253             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_LEVELS'
                0254          ENDIF
                0255         ENDDO
                0256        ENDIF
                0257       ENDDO
                0258
ada33f880b Jean*0259 C--   Check that number of levels to write (in data.diagnostics) does not
                0260 C     exceeds max size: nlevs=max(Nr,NrPhys)
49f3c51920 Jean*0261 C   note: max size of array to write has been changed to "numLevels",
                0262 C         so that this checking is no longer usefull since nlevels
                0263 C         cannot be larger than "numLevels" anyway.
ada33f880b Jean*0264
8c2b124434 Jean*0265       _END_MASTER( myThid )
                0266
e3e2b00dee Jean*0267 C--   Everyone else must wait for the levels to be set
                0268       _BARRIER
                0269
09ceb40cd6 Jean*0270       RETURN
                0271       END