C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_levels.F,v 1.19 2015/06/02 20:58:22 jmc Exp $
C $Name: $
#include "DIAG_OPTIONS.h"
CBOP 0
C !ROUTINE: DIAGNOSTICS_SET_LEVELS
C !INTERFACE:
SUBROUTINE DIAGNOSTICS_SET_LEVELS( myThid )
C !DESCRIPTION:
C Initialize Diagnostic Levels, according to GDIAG
C for all available diagnostics
C Notes: needs to be called after all packages set they own available
C diagnostics
C \begin{center}
C \begin{tabular}[h]{|c|c|}\hline
C \textbf{Positions} & \textbf{Characters}
C & \textbf{Meanings} \\\hline
C parse(10) & 0 & levels = 0 \\
C & 1 & levels = 1 \\
C & R & levels = Nr \\
C & L & levels = MAX(Nr,NrPhys) \\
C & M & levels = MAX(Nr,NrPhys) - 1 \\
C & G & levels = Ground_level Number \\
C & I & levels = sea-Ice_level Number \\
C & X & free levels option (need to be set explicitly) \\
C \end{tabular}
C \end{center}
C !USES:
IMPLICIT NONE
#include "SIZE.h"
#define SIZE_IS_SET
#include "EEPARAMS.h"
#include "PARAMS.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"
#ifdef ALLOW_FIZHI
#include "fizhi_SIZE.h"
#else
INTEGER Nrphys
PARAMETER (Nrphys=0)
#endif
#ifdef ALLOW_LAND
#include "LAND_SIZE.h"
#else
INTEGER land_nLev
PARAMETER ( land_nLev = 0 )
#endif
C !INPUT PARAMETERS:
C myThid :: my Thread Id number
INTEGER myThid
CEOP
C !LOCAL VARIABLES:
INTEGER l, n, ncount
INTEGER nlevs, nGroundLev
INTEGER dUnit, stdUnit
CHARACTER*(MAX_LEN_MBUF) msgBuf
CHARACTER*84 ccHead, ccLine
CHARACTER*10 gcode
CHARACTER*1 g10code
INTEGER ILNBLNK
EXTERNAL
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
_BARRIER
_BEGIN_MASTER( myThid )
C-- Diagnostics definition/setting ends (cannot add diags to list anymore)
c IF ( diag_pkgStatus.NE.2 ) STOP
diag_pkgStatus = 3
nlevs = MAX(Nr,Nrphys)
nGroundLev = land_nLev
C Diagnostic Levels
C -----------------
ncount = 0
DO n = 1,ndiagt
g10code = gdiag(n)(10:10)
IF ( g10code .EQ. '0' ) THEN
kdiag(n) = 0
ELSEIF ( g10code .EQ. '1' ) THEN
kdiag(n) = 1
ELSEIF ( g10code .EQ. 'R' ) THEN
kdiag(n) = Nr
ELSEIF ( g10code .EQ. 'L' ) THEN
kdiag(n) = nlevs
ELSEIF ( g10code .EQ. 'M' ) THEN
kdiag(n) = nlevs - 1
ELSEIF ( g10code .EQ. 'G' ) THEN
kdiag(n) = nGroundLev
ELSEIF ( g10code .EQ. 'g' ) THEN
kdiag(n) = 1
ELSEIF ( g10code .EQ. 'X' ) THEN
IF ( kdiag(n) .LE. 0 ) THEN
WRITE(msgBuf,'(2A,I4,3A)')
& '** WARNING ** DIAGNOSTICS_SET_LEVELS: ',
& 'level Nb =', kdiag(n), ' < 1 for diag."', cdiag(n),'"'
CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
& SQUEEZE_RIGHT , myThid )
ENDIF
ELSE
C- enforce a strict matching:
WRITE(msgBuf,'(2A,4A)') 'DIAGNOSTICS_SET_LEVELS: ',
& 'invalid gdiag(10)="', g10code, '" code for diag."',
& cdiag(n),'"'
CALL PRINT_ERROR( msgBuf , myThid )
ncount = ncount + 1
ENDIF
ENDDO
IF ( ncount.GT.0 ) THEN
WRITE(msgBuf,'(2A,I6,3A)') 'DIAGNOSTICS_SET_LEVELS: ',
& 'found', ncount, ' invalid parser "gdiag(10)" => STOP'
CALL PRINT_ERROR( msgBuf , myThid )
STOP 'ABNORMAL END: S/R DIAGSTATS_SET_LEVELS'
ENDIF
C-- Check for inconsistent diagnostic parser field
ncount = 0
DO n = 1,ndiagt
gcode = gdiag(n)(1:10)
IF ( ( gcode(3:3).EQ.'r' .OR. gcode(3:3).EQ.'R' )
& .AND. gcode(10:10).NE.'R' ) THEN
WRITE(msgBuf,'(2A,4A)') 'DIAGNOSTICS_SET_LEVELS: ',
& 'inconsistent gdiag(3&10)="',gcode,'" for diag."',cdiag(n),'"'
CALL PRINT_ERROR( msgBuf , myThid )
ncount = ncount + 1
ENDIF
ENDDO
IF ( ncount.GT.0 ) THEN
WRITE(msgBuf,'(2A,I6,3A)') 'DIAGNOSTICS_SET_LEVELS: ',
& 'found', ncount, ' inconsistent parser "gdiag" => STOP'
CALL PRINT_ERROR( msgBuf , myThid )
STOP 'ABNORMAL END: S/R DIAGSTATS_SET_LEVELS'
ENDIF
C-- Check for unvalid diag.mate number
ncount = 0
DO n = 1,ndiagt
IF ( hdiag(n).LT.0 .OR. hdiag(n).GT.ndiagt ) THEN
WRITE(msgBuf,'(2A,I6,3A)') 'DIAGNOSTICS_SET_LEVELS: ',
& 'unvalid mate number=',hdiag(n),' for diag."',cdiag(n),'"'
CALL PRINT_ERROR( msgBuf , myThid )
ncount = ncount + 1
ENDIF
gcode = gdiag(n)(1:10)
IF ( ( gcode(5:5).EQ.'C' .OR. gcode(5:5).EQ.'P' )
& .AND. hdiag(n).EQ.0 ) THEN
WRITE(msgBuf,'(6A)') 'DIAGNOSTICS_SET_LEVELS: ',
& 'mate number required for diag."',cdiag(n),
& '" (gdiag(5)=',gcode(5:5),')'
CALL PRINT_ERROR( msgBuf , myThid )
ncount = ncount + 1
ENDIF
ENDDO
IF ( ncount.GT.0 ) THEN
WRITE(msgBuf,'(2A,I6,3A)') 'DIAGNOSTICS_SET_LEVELS: ',
& 'found', ncount, ' unvalid/missing mate number(s) => STOP'
CALL PRINT_ERROR( msgBuf , myThid )
STOP 'ABNORMAL END: S/R DIAGSTATS_SET_LEVELS'
ENDIF
C-- Print to standard output
stdUnit = standardMessageUnit
WRITE(msgBuf,'(2A)')
& '------------------------------------------------------------'
CALL PRINT_MESSAGE( msgBuf, stdUnit,SQUEEZE_RIGHT, myThid)
WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_LEVELS: done'
CALL PRINT_MESSAGE( msgBuf, stdUnit,SQUEEZE_RIGHT, myThid)
WRITE(msgBuf,'(A,I6)')
& ' Total Nb of available Diagnostics: ndiagt=', ndiagt
CALL PRINT_MESSAGE( msgBuf, stdUnit,SQUEEZE_RIGHT, myThid)
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C write a summary of the (long) list of all available diagnostics:
IF ( debugLevel.GE.debLevA .AND. myProcId.EQ.0 ) THEN
WRITE(msgBuf,'(2A)')
& ' write list of available Diagnostics to file: ',
& 'available_diagnostics.log'
CALL PRINT_MESSAGE( msgBuf, stdUnit,SQUEEZE_RIGHT, myThid)
WRITE(ccHead,'(2A)')
& ' Num |<-Name->|Levs| mate |<- code ->|',
& '<-- Units -->|<- Tile (max=80c)'
DO l=1,LEN(ccLine)
ccLine(l:l) = '-'
ENDDO
CALL MDSFINDUNIT( dUnit, myThid )
OPEN(dUnit, file='available_diagnostics.log',
& status='unknown', form='formatted')
WRITE(dUnit,'(A,I6)')
& ' Total Nb of available Diagnostics: ndiagt=', ndiagt
WRITE(dUnit,'(A)') ccLine
WRITE(dUnit,'(A)') ccHead
WRITE(dUnit,'(A)') ccLine
DO n=1,ndiagt
IF ( MOD(n,100).EQ.0 ) THEN
WRITE(dUnit,'(A)') ccLine
WRITE(dUnit,'(A)') ccHead
WRITE(dUnit,'(A)') ccLine
ENDIF
l = ILNBLNK(tdiag(n))
gcode = gdiag(n)(1:10)
IF ( hdiag(n).NE.0 .AND. l.GE.1 ) THEN
WRITE(dUnit,'(I6,3A,I3,A,I6,6A)') n, ' |', cdiag(n), '|',
& kdiag(n),' |', hdiag(n), ' |', gcode, '|',
& udiag(n), '|', tdiag(n)(1:l)
ELSEIF ( hdiag(n).NE.0 ) THEN
WRITE(dUnit,'(I6,3A,I3,A,I6,6A)') n, ' |', cdiag(n), '|',
& kdiag(n),' |', hdiag(n), ' |', gcode, '|',
& udiag(n), '|'
ELSEIF (l.GE.1) THEN
WRITE(dUnit,'(I6,3A,I3,6A)') n, ' |', cdiag(n), '|',
& kdiag(n),' | |', gcode, '|',
& udiag(n), '|', tdiag(n)(1:l)
ELSE
WRITE(dUnit,'(I6,3A,I3,6A)') n, ' |', cdiag(n), '|',
& kdiag(n),' | |', gcode, '|',
& udiag(n), '|'
ENDIF
ENDDO
WRITE(dUnit,'(A)') ccLine
WRITE(dUnit,'(A)') ccHead
WRITE(dUnit,'(A)') ccLine
CLOSE(dUnit)
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
ENDIF
C-- Check for multiple definition of the same diagnostic name
DO n = 2,ndiagt
IF ( cdiag(n).NE.blkName ) THEN
DO l = 1,n-1
IF ( cdiag(l).EQ.cdiag(n) ) THEN
WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_LEVELS: ',
& 'diag.Name: ',cdiag(n),' registered 2 times :'
CALL PRINT_ERROR( msgBuf , myThid )
WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_LEVELS: ',
& '1rst (l=', l, ' ), title= ',tdiag(l)
CALL PRINT_ERROR( msgBuf , myThid )
WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_LEVELS: ',
& ' 2nd (n=', n, ' ), title= ',tdiag(n)
CALL PRINT_ERROR( msgBuf , myThid )
STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_LEVELS'
ENDIF
ENDDO
ENDIF
ENDDO
C-- Check that number of levels to write (in data.diagnostics) does not
C exceeds max size: nlevs=max(Nr,NrPhys)
C note: max size of array to write has been changed to "numLevels",
C so that this checking is no longer usefull since nlevels
C cannot be larger than "numLevels" anyway.
_END_MASTER( myThid )
C-- Everyone else must wait for the levels to be set
_BARRIER
RETURN
END