Back to home page

MITgcm
 
 

    

File indexing completed on 2024-05-11 05:10:23 UTC

view on githubraw file Latest commit 41c4545f on 2024-05-10 15:00:41 UTC
09ceb40cd6 Jean*0001 #include "DIAG_OPTIONS.h"
                0002 
                0003 CBOP
                0004 C     !ROUTINE: DIAGNOSTICS_SET_POINTERS
                0005 C     !INTERFACE:
                0006       SUBROUTINE DIAGNOSTICS_SET_POINTERS( myThid )
                0007 
                0008 C     !DESCRIPTION: \bv
                0009 C     *==================================================================
                0010 C     | S/R DIAGNOSTICS_SET_POINTERS
                0011 C     | o set pointers for active 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"
41c4545f8f Jean*0022 #include "DIAGNOSTICS_P2SHARE.h"
09ceb40cd6 Jean*0023 #include "DIAGNOSTICS.h"
                0024 
                0025 C     !INPUT/OUTPUT PARAMETERS:
                0026 C     == Routine arguments ==
5f837b700f Jean*0027 C     myThid :: my Thread Id. number
09ceb40cd6 Jean*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
09ceb40cd6 Jean*0035       INTEGER mate, nActiveMax
e2b0f3f4e8 Jean*0036       INTEGER i, j, k, k1, k2, kLev
09ceb40cd6 Jean*0037       LOGICAL found
                0038       CHARACTER*(MAX_LEN_MBUF) msgBuf
5f837b700f Jean*0039       CHARACTER*12 suffix
09ceb40cd6 Jean*0040 
                0041       _BEGIN_MASTER( myThid)
                0042 
5b34dd5380 Jean*0043 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0044 
                0045 C--   In case an output file contains 2 post-processed diags which are computed
                0046 C     together (mate of 2nd PP-diag one is 1rst PP-diag), move these 2 diags
                0047 C     next to each other (to only computate them once): 1rst one then 2nd one.
                0048       DO ld=1,nlists
                0049        found = .FALSE.
                0050        DO md=1,nfields(ld)
                0051 C        Search all possible model diagnostics
                0052          nd = 0
                0053          DO i=1,ndiagt
                0054           IF ( nd.EQ.0 .AND. flds(md,ld).EQ.cdiag(i) ) nd = i
                0055          ENDDO
                0056          j  = 0
                0057          IF ( nd.GE.1 ) THEN
                0058            IF ( gdiag(nd)(5:5).EQ.'P' ) THEN
                0059              mate = hdiag(nd)
                0060              IF ( gdiag(mate)(5:5).EQ.'P' ) THEN
                0061 C        Mate of Post-Processed diag "nd" is also Post-Processed
                0062                DO i=1,nfields(ld)
                0063                  IF ( j.EQ.0 .AND. flds(i,ld).EQ.cdiag(mate) ) j = i
                0064                ENDDO
                0065              ENDIF
                0066            ENDIF
                0067          ENDIF
                0068 C        And is found in the same output stream "ld" (at rank "j")
                0069          IF ( j.GE.1 .AND. j.NE.md-1 ) THEN
                0070            IF ( .NOT.found ) THEN
                0071              WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
                0072      &             'Re-Order Diags in Outp.Stream: ',fnames(ld)
                0073              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0074      &                           SQUEEZE_RIGHT, myThid )
                0075            ENDIF
                0076            found  = .TRUE.
                0077            IF ( j.LT.md-1 ) THEN
                0078              WRITE(msgBuf,'(2A,2(A,I4),2A)')
                0079      &         ' move ',flds(j,ld),' from ',j,' down to',md-1,
                0080      &         ' just before ',flds(md,ld)
                0081              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0082      &                           SQUEEZE_RIGHT, myThid )
                0083              DO i=j,md-2
                0084                flds(i,ld) = flds(i+1,ld)
                0085              ENDDO
                0086              flds(md-1,ld) = cdiag(mate)
                0087            ELSEIF ( j.GT.md ) THEN
                0088              WRITE(msgBuf,'(2A,2(A,I4),2A)')
                0089      &         ' move ',flds(j,ld),' from ',j,'  up to ',md,
                0090      &         ' just before ',flds(md,ld)
                0091              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0092      &                           SQUEEZE_RIGHT, myThid )
                0093              DO i=j,md+1,-1
                0094                flds(i,ld) = flds(i-1,ld)
                0095              ENDDO
                0096              flds(md,ld) = cdiag(mate)
                0097            ENDIF
                0098          ENDIF
                0099        ENDDO
                0100        IF ( found ) THEN
                0101          WRITE(msgBuf,'(2A,I4,A)') 'DIAGNOSTICS_SET_POINTERS: ',
                0102      &             'Updated list in Outp.Stream #', ld, ' :'
                0103          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0104      &                       SQUEEZE_RIGHT, myThid )
                0105          DO md = 1,nfields(ld),10
                0106            j = MIN(nfields(ld),md+9)
                0107            WRITE(msgBuf,'(21A)') ' Fields:   ',(' ',flds(i,ld),i=md,j)
                0108            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0109      &                         SQUEEZE_RIGHT, myThid )
                0110          ENDDO
                0111        ENDIF
                0112       ENDDO
                0113 
                0114 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0115 
2dd05c816c Jean*0116 C--   Initialize pointer arrays to zero:
e2b0f3f4e8 Jean*0117       DO ld=1,numLists
                0118        DO md=1,numperList
3ae5f90260 Jean*0119         idiag(md,ld) = 0
                0120         jdiag(md,ld) = 0
                0121         mdiag(md,ld) = 0
                0122        ENDDO
2dd05c816c Jean*0123       ENDDO
                0124 
92ea3de5e8 Jean*0125 C--   Calculate pointers for diagnostics in active output-stream
                0126 C                                   (i.e., with defined filename)
2dd05c816c Jean*0127 
09ceb40cd6 Jean*0128       ndiagcount = 0
                0129       nActiveMax = 0
3ae5f90260 Jean*0130       DO ld=1,nlists
                0131        nActive(ld) = nfields(ld)
                0132        DO md=1,nfields(ld)
09ceb40cd6 Jean*0133 
                0134          found = .FALSE.
                0135 C        Search all possible model diagnostics
3ae5f90260 Jean*0136          DO nd=1,ndiagt
                0137           IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
                0138             CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
09ceb40cd6 Jean*0139             found = .TRUE.
                0140           ENDIF
                0141          ENDDO
                0142          IF ( .NOT.found ) THEN
16d76554fb Jean*0143            CALL DIAGNOSTICS_LIST_CHECK(
                0144      O                      ndCount,
8f787f35d4 Davi*0145      I                      ld, md, nlists, nfields, flds, myThid )
16d76554fb Jean*0146            IF ( ndCount.EQ.0 ) THEN
                0147              WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
3ae5f90260 Jean*0148      &                      flds(md,ld),' is not a Diagnostic'
16d76554fb Jean*0149              CALL PRINT_ERROR( msgBuf , myThid )
                0150            ENDIF
09ceb40cd6 Jean*0151            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
                0152          ENDIF
                0153 
                0154        ENDDO
3ae5f90260 Jean*0155        nActiveMax = MAX(nActive(ld),nActiveMax)
09ceb40cd6 Jean*0156       ENDDO
                0157 
931cda44c0 Jean*0158       IF (  ndiagcount.LE.numDiags .AND.
e2b0f3f4e8 Jean*0159      &      nActiveMax.LE.numperList ) THEN
931cda44c0 Jean*0160         WRITE(msgBuf,'(A,I8,A)')
3ae5f90260 Jean*0161      &    '  space allocated for all diagnostics:',
09ceb40cd6 Jean*0162      &    ndiagcount, ' levels'
                0163         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
5b34dd5380 Jean*0164      &                      SQUEEZE_RIGHT, myThid )
09ceb40cd6 Jean*0165       ELSE
931cda44c0 Jean*0166        IF ( ndiagcount.GT.numDiags ) THEN
09ceb40cd6 Jean*0167          WRITE(msgBuf,'(2A)')
                0168      &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
                0169      &    ' for all active diagnostics (from data.diagnostics)'
                0170          CALL PRINT_ERROR( msgBuf , myThid )
931cda44c0 Jean*0171          WRITE(msgBuf,'(A,I8,A,I8)')
                0172      &    'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
09ceb40cd6 Jean*0173      &    ' but needs at least', ndiagcount
                0174          CALL PRINT_ERROR( msgBuf , myThid )
                0175        ENDIF
e2b0f3f4e8 Jean*0176        IF ( nActiveMax.GT.numperList ) THEN
09ceb40cd6 Jean*0177          WRITE(msgBuf,'(2A)')
                0178      &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
                0179      &    ' for all active diagnostics (from data.diagnostics)'
                0180          CALL PRINT_ERROR( msgBuf , myThid )
                0181          WRITE(msgBuf,'(A,I6,A,I6)')
e2b0f3f4e8 Jean*0182      &    'DIAGNOSTICS_SET_POINTERS: numperList=', numperList,
09ceb40cd6 Jean*0183      &    ' but needs at least', nActiveMax
                0184          CALL PRINT_ERROR( msgBuf , myThid )
                0185        ENDIF
                0186        STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
                0187       ENDIF
                0188 
7e2f6e329a Jean*0189 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
3ae5f90260 Jean*0190 C--   Set pointer for mate (e.g.vector component mate) if not already done
                0191 C     and if it exists. Note: for now, only used to print message.
                0192       DO ld=1,nlists
                0193        DO md=1,nActive(ld)
                0194         IF (mdiag(md,ld).EQ.0 ) THEN
                0195 
1ef638beb5 Jean*0196          k = SIGN(1,jdiag(md,ld))
                0197          nd = ABS(jdiag(md,ld))
931cda44c0 Jean*0198          mate = hdiag(nd)
                0199          IF ( mate.GT.0 ) THEN
3ae5f90260 Jean*0200           DO j=1,nlists
                0201            DO i=1,nActive(j)
1ef638beb5 Jean*0202             IF ( mdiag(md,ld).EQ.0 .AND. (k*jdiag(i,j)).EQ.mate ) THEN
fdb74cebcb Jean*0203              IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld)
                0204      &           .AND. averageFreq(j) .EQ.averageFreq(ld)
                0205      &           .AND. averagePhase(j).EQ.averagePhase(ld)
                0206      &           .AND. averageCycle(j).EQ.averageCycle(ld) )
                0207      &          mdiag(md,ld) = ABS(idiag(i,j))
3ae5f90260 Jean*0208             ENDIF
                0209            ENDDO
                0210           ENDDO
                0211          ENDIF
                0212          IF ( mdiag(md,ld).NE.0 ) THEN
931cda44c0 Jean*0213           WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
                0214      &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
                0215      &             ' , mate:', hdiag(nd)
3ae5f90260 Jean*0216           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
5b34dd5380 Jean*0217      &                        SQUEEZE_RIGHT, myThid )
3ae5f90260 Jean*0218          ENDIF
                0219 
                0220         ENDIF
                0221        ENDDO
                0222       ENDDO
                0223 
                0224 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
a5ec81ed49 Timo*0225 C--   Set internal parameter "useDiag4AdjOutp" if Adj Diagnostics are found
                0226       DO ld=1,nlists
                0227        DO md=1,nfields(ld)
                0228 c      DO md=1,nActive(ld)
                0229          nd = ABS(jdiag(md,ld))
                0230          useDiag4AdjOutp = useDiag4AdjOutp
                0231      &                .OR. ( gdiag(nd)(4:4).EQ.'A' )
                0232        ENDDO
                0233       ENDDO
                0234 
                0235 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7e2f6e329a Jean*0236 C--   Set list of levels to write (if not specified in data.diagnostics)
                0237 
3ae5f90260 Jean*0238       DO ld=1,nlists
                0239         IF ( nlevels(ld).EQ.-1 ) THEN
7e2f6e329a Jean*0240 C-      set Nb of levels to the minimum size of all diag of this list:
17a1deb272 Jean*0241           kLev = numLevels*10
3ae5f90260 Jean*0242           DO md=1,nfields(ld)
1ef638beb5 Jean*0243             nd = ABS(jdiag(md,ld))
3ae5f90260 Jean*0244             kLev = MIN(kdiag(nd),kLev)
7e2f6e329a Jean*0245           ENDDO
                0246           IF ( kLev.LE.0 ) THEN
17a1deb272 Jean*0247             WRITE(msgBuf,'(2A,I4,2A)')
                0248      &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
                0249      &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
                0250             CALL PRINT_ERROR( msgBuf , myThid )
                0251             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
                0252           ELSEIF ( kLev.GT.numLevels ) THEN
                0253             WRITE(msgBuf,'(A,2(I6,A))')
                0254      &      'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
                0255      &                  ' >', numLevels, ' =numLevels'
                0256             CALL PRINT_ERROR( msgBuf , myThid )
                0257             WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
                0258      &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
7e2f6e329a Jean*0259             CALL PRINT_ERROR( msgBuf , myThid )
                0260             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
                0261           ENDIF
3ae5f90260 Jean*0262           nlevels(ld) = kLev
7e2f6e329a Jean*0263           DO k=1,kLev
3ae5f90260 Jean*0264            levs(k,ld) = k
7e2f6e329a Jean*0265           ENDDO
                0266           WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
3ae5f90260 Jean*0267      &      'Set levels for Outp.Stream: ',fnames(ld)
7e2f6e329a Jean*0268           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0269      &                        SQUEEZE_RIGHT, myThid)
5f837b700f Jean*0270           suffix = ' Levels:    '
                0271           IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
3ae5f90260 Jean*0272           DO k1=1,nlevels(ld),20
                0273             k2 = MIN(nlevels(ld),k1+19)
5f837b700f Jean*0274             WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
7e2f6e329a Jean*0275             CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0276      &                          SQUEEZE_RIGHT, myThid)
                0277           ENDDO
c65a5004af Jean*0278         ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
                0279 C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
7e2f6e329a Jean*0280           kLev = 0
3ae5f90260 Jean*0281           DO k=1,nlevels(ld)
                0282             kLev = MAX(NINT(levs(k,ld)),kLev)
7e2f6e329a Jean*0283           ENDDO
3ae5f90260 Jean*0284           DO md=1,nfields(ld)
1ef638beb5 Jean*0285             nd = ABS(jdiag(md,ld))
3ae5f90260 Jean*0286             IF ( kLev.GT.kdiag(nd) ) THEN
                0287 C- Note: diagnostics_out take care (in some way) of this case
7e2f6e329a Jean*0288 C        so that it does not cause "index out-off bounds" error.
                0289 C        However, the output file looks strange.
                0290 C- For now, choose to stop, but could change it to just a warning
931cda44c0 Jean*0291              WRITE(msgBuf,'(A,I4,A,I6,2A)')
7e2f6e329a Jean*0292      &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
3ae5f90260 Jean*0293      &         ' in list l=', ld, ', filename: ', fnames(ld)
7e2f6e329a Jean*0294              CALL PRINT_ERROR( msgBuf , myThid )
931cda44c0 Jean*0295              WRITE(msgBuf,'(2A,I4,A,I6,2A)')
7e2f6e329a Jean*0296      &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
3ae5f90260 Jean*0297      &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
7e2f6e329a Jean*0298              CALL PRINT_ERROR( msgBuf , myThid )
                0299              WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
3ae5f90260 Jean*0300      &       ' parsing code >>',gdiag(nd),'<<'
7e2f6e329a Jean*0301              CALL PRINT_ERROR( msgBuf , myThid )
                0302              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
                0303             ENDIF
                0304           ENDDO
                0305         ENDIF
                0306       ENDDO
                0307 
                0308         WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
                0309         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0310      &                      SQUEEZE_RIGHT , myThid)
                0311         WRITE(msgBuf,'(2A)')
                0312      &   '------------------------------------------------------------'
                0313         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0314      &                      SQUEEZE_RIGHT , myThid)
                0315 
09ceb40cd6 Jean*0316       _END_MASTER( myThid )
                0317 
                0318       RETURN
                0319       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!