pkg/diagnostics/diagstats_set_pointers.F

3e5de6a370 Jean*0001 #include "DIAG_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: DIAGSTATS_SET_POINTERS
                0005 C     !INTERFACE:
                0006       SUBROUTINE DIAGSTATS_SET_POINTERS( myThid )
                0007
                0008 C     !DESCRIPTION: \bv
                0009 C     *==================================================================
                0010 C     | S/R DIAGSTATS_SET_POINTERS
                0011 C     | o set pointers for active statistics diagnostics
                0012 C     *==================================================================
                0013 C     \ev
                0014
                0015 C     !USES:
                0016       IMPLICIT NONE
                0017
                0018 C     == Global variables ===
                0019 #include "EEPARAMS.h"
                0020 #include "SIZE.h"
                0021 #include "DIAGNOSTICS_SIZE.h"
                0022 #include "DIAGNOSTICS.h"
9b091adb85 Jean*0023 #include "DIAGSTATS_REGIONS.h"
3e5de6a370 Jean*0024
                0025 C     !INPUT/OUTPUT PARAMETERS:
                0026 C     == Routine arguments ==
                0027 C     myThid - Thread number for this instance of the routine.
                0028       INTEGER myThid
                0029 CEOP
                0030
                0031 C     !LOCAL VARIABLES:
                0032 C     == Local variables ==
16d76554fb Jean*0033       INTEGER ndiagcount, ndCount
3ae5f90260 Jean*0034       INTEGER md,ld,nd
                0035       INTEGER mm, mate, nActiveMax
                0036       INTEGER j, k, l
9b091adb85 Jean*0037       LOGICAL found, addMate2List, inList, regListPb
3e5de6a370 Jean*0038       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0039
                0040       _BEGIN_MASTER( myThid)
                0041
                0042 C--   Initialize pointer arrays to zero:
3ae5f90260 Jean*0043       DO ld=1,numlists
                0044        DO md=1,numperlist
                0045         iSdiag(md,ld) = 0
                0046         jSdiag(md,ld) = 0
                0047         mSdiag(md,ld) = 0
                0048        ENDDO
3e5de6a370 Jean*0049       ENDDO
                0050
                0051 C--   Calculate pointers for diagnostics set to non-zero frequency
                0052
                0053       ndiagcount = 0
                0054       nActiveMax = 0
3ae5f90260 Jean*0055       DO ld=1,diagSt_nbLists
                0056        diagSt_nbActv(ld) = diagSt_nbFlds(ld)
                0057        DO md=1,diagSt_nbFlds(ld)
3e5de6a370 Jean*0058
                0059          found = .FALSE.
                0060 C        Search all possible model diagnostics
3ae5f90260 Jean*0061          DO nd=1,ndiagt
                0062           IF ( diagSt_Flds(md,ld).EQ.cdiag(nd) ) THEN
                0063             CALL DIAGSTATS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
3e5de6a370 Jean*0064             found = .TRUE.
3ae5f90260 Jean*0065             jSdiag(md,ld) = nd
3e5de6a370 Jean*0066           ENDIF
                0067          ENDDO
                0068          IF ( .NOT.found ) THEN
16d76554fb Jean*0069            CALL DIAGNOSTICS_LIST_CHECK(
                0070      O                      ndCount,
8f787f35d4 Davi*0071      I                      ld,md, diagSt_nbLists,
                0072      I                      diagSt_nbFlds,diagSt_Flds,myThid)
16d76554fb Jean*0073            IF ( ndCount.EQ.0 ) THEN
                0074              WRITE(msgBuf,'(3A)') 'DIAGSTATS_SET_POINTERS: ',
3ae5f90260 Jean*0075      &                     diagSt_Flds(md,ld),' is not a Diagnostic'
16d76554fb Jean*0076              CALL PRINT_ERROR( msgBuf , myThid )
                0077            ENDIF
3e5de6a370 Jean*0078            STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
                0079          ENDIF
                0080          IF ( found .AND. mate.LE.-1 ) THEN
                0081 C-       add this fields to the active list in case regions are differents:
                0082            addMate2List = .FALSE.
3ae5f90260 Jean*0083            DO l=1,ld-1
3e5de6a370 Jean*0084             inList = .FALSE.
3ae5f90260 Jean*0085             DO k=1,diagSt_nbActv(l)
                0086               IF ( diagSt_Flds(k,l).EQ.cdiag(-mate) ) inList=.TRUE.
3e5de6a370 Jean*0087             ENDDO
                0088             IF ( inList ) THEN
                0089              DO j=0,nRegions
                0090               addMate2List = addMate2List
3ae5f90260 Jean*0091      &                 .OR. (diagSt_region(j,l).LT.diagSt_region(j,ld))
3e5de6a370 Jean*0092              ENDDO
                0093             ENDIF
                0094            ENDDO
                0095            IF ( .NOT.addMate2List ) mate = 0
                0096          ENDIF
3ae5f90260 Jean*0097          IF ( found .AND. mate.NE.0 ) THEN
                0098             mm = diagSt_nbActv(ld) + 1
                0099             IF ( mm.LE.numperlist ) THEN
                0100              iSdiag(mm,ld) = SIGN(mSdiag(md,ld),mate)
                0101              mate = ABS(mate)
                0102              jSdiag(mm,ld) = mate
                0103              diagSt_Flds(mm,ld) = cdiag(mate)
                0104             ENDIF
                0105             diagSt_nbActv(ld) = mm
3e5de6a370 Jean*0106          ENDIF
                0107
                0108        ENDDO
3ae5f90260 Jean*0109        nActiveMax = MAX(diagSt_nbActv(ld),nActiveMax)
3e5de6a370 Jean*0110       ENDDO
                0111
                0112       IF (  ndiagcount.LE.diagSt_size .AND.
                0113      &      nActiveMax.LE.numperlist ) THEN
e129400813 Jean*0114         WRITE(msgBuf,'(A,I8,A)')
3ae5f90260 Jean*0115      &    '  space allocated for all stats-diags:',
3e5de6a370 Jean*0116      &    ndiagcount, ' levels'
                0117         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
acacc28f7f Jean*0118      &                      SQUEEZE_RIGHT, myThid )
3e5de6a370 Jean*0119       ELSE
                0120        IF ( ndiagcount.GT.diagSt_size ) THEN
                0121          WRITE(msgBuf,'(2A)')
                0122      &    'DIAGSTATS_SET_POINTERS: Not enough space',
                0123      &    ' for all active stats-diags (from data.diagnostics)'
                0124          CALL PRINT_ERROR( msgBuf , myThid )
e129400813 Jean*0125          WRITE(msgBuf,'(A,I8,A,I8)')
3e5de6a370 Jean*0126      &    'DIAGSTATS_SET_POINTERS: diagSt_size=', diagSt_size,
                0127      &    ' but needs at least', ndiagcount
                0128          CALL PRINT_ERROR( msgBuf , myThid )
                0129        ENDIF
                0130        IF ( nActiveMax.GT.numperlist ) THEN
                0131          WRITE(msgBuf,'(2A)')
                0132      &    'DIAGSTATS_SET_POINTERS: Not enough space',
                0133      &    ' for all active stats-diags (from data.diagnostics)'
                0134          CALL PRINT_ERROR( msgBuf , myThid )
                0135          WRITE(msgBuf,'(A,I6,A,I6)')
                0136      &    'DIAGSTATS_SET_POINTERS: numperlist=', numperlist,
                0137      &    ' but needs at least', nActiveMax
                0138          CALL PRINT_ERROR( msgBuf , myThid )
                0139        ENDIF
                0140        STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
                0141       ENDIF
                0142
                0143 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0144 C--   Set list of regions to write
9b091adb85 Jean*0145 C-    check that all selected regions are actually defined
                0146       regListPb = .FALSE.
                0147       DO l=1,diagSt_nbLists
                0148        DO j=1,nRegions
                0149         IF ( diagSt_region(j,l).NE.0 ) THEN
                0150           IF ( diagSt_kRegMsk(j).LT.1 .OR.
02e1437ea2 Jean*0151      &         diagSt_kRegMsk(j).GT.nSetRegMask ) THEN
e129400813 Jean*0152             WRITE(msgBuf,'(A,3(A,I5))') 'DIAGSTATS_SET_POINTERS:',
9b091adb85 Jean*0153      &       ' region', j, ' undefined (k=', diagSt_kRegMsk(j),
                0154      &       ') in list l=', l
                0155             CALL PRINT_ERROR( msgBuf , myThid )
                0156             regListPb = .TRUE.
                0157           ENDIF
                0158         ENDIF
                0159        ENDDO
                0160       ENDDO
                0161       IF ( regListPb ) THEN
                0162         WRITE(msgBuf,'(2A)') 'DIAGSTATS_SET_POINTERS:',
                0163      &                       ' Cannot select undefined regions'
                0164         CALL PRINT_ERROR( msgBuf , myThid )
                0165         STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
                0166       ENDIF
                0167
                0168 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
3e5de6a370 Jean*0169
acacc28f7f Jean*0170       WRITE(msgBuf,'(2A,2(I8,A))') 'DIAGSTATS_SET_POINTERS: done',
                0171      &  ', use', ndiagcount, ' levels (diagSt_size=', diagSt_size, ' )'
                0172       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0173      &                    SQUEEZE_RIGHT, myThid )
                0174       WRITE(msgBuf,'(2A)')
3e5de6a370 Jean*0175      &   '------------------------------------------------------------'
acacc28f7f Jean*0176       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0177      &                    SQUEEZE_RIGHT, myThid )
3e5de6a370 Jean*0178
                0179       _END_MASTER( myThid )
                0180
                0181       RETURN
                0182       END