pkg/diagnostics/diagnostics_switch_onoff.F

dd6d146759 Jean*0001 #include "DIAG_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP 0
                0005 C     !ROUTINE: DIAGNOSTICS_SWITCH_ONOFF
                0006
                0007 C     !INTERFACE:
41c4545f8f Jean*0008       SUBROUTINE DIAGNOSTICS_SWITCH_ONOFF(
                0009      I                       seqFlag, myTime, myIter, myThid )
dd6d146759 Jean*0010
                0011 C     !DESCRIPTION:
                0012 C-----
                0013 C     Called at the beginning of the time-step,
                0014 C     to switch on/off diagnostics for snap-shot output
                0015 C-----
                0016 C      during iterations that are multiple of |freq|,
                0017 C      switch ON diagnostics (ndiag>=0) that will become active
                0018 C      and then can be written at the end of the time-step ;
                0019 C      otherwise, put diagnostics in non-active mode (ndiag=-1)
                0020 C-----
                0021
                0022 C     !USES:
                0023       IMPLICIT NONE
                0024 #include "SIZE.h"
                0025 #include "EEPARAMS.h"
                0026 #include "PARAMS.h"
                0027 #include "DIAGNOSTICS_SIZE.h"
                0028 #include "DIAGNOSTICS.h"
                0029
                0030 C     !INPUT PARAMETERS:
41c4545f8f Jean*0031 C     seqFlag  :: flag that indicates where this S/R is called from:
                0032 C              :: = 1 : called from the top of FORWARD_STEP, forward sweep
                0033 C              :: =-1 : called from AUTODIFF_INADMODE_SET_AD, backward sweep
                0034 C     myTime   :: current Time of simulation ( s )
                0035 C     myIter   :: current Iteration number
                0036 C     myThid   :: my Thread Id number
                0037       INTEGER seqFlag
02545dbccf Jean*0038       _RL     myTime
dd6d146759 Jean*0039       INTEGER myIter
                0040       INTEGER myThid
                0041 CEOP
                0042
                0043 C     !LOCAL VARIABLES:
                0044 C      newIter :: future iteration number
                0045 C      j,m,n   :: loop index
666b944083 Jean*0046       CHARACTER*(MAX_LEN_MBUF) msgBuf
509dcf5e56 Jean*0047 c     INTEGER newIter
3ae5f90260 Jean*0048       INTEGER m, n, nd
                0049       INTEGER bi, bj, ip, iSp
509dcf5e56 Jean*0050       LOGICAL time4SnapShot
                0051       _RL     phiSec, freqSec
666b944083 Jean*0052       INTEGER nInterval
                0053       _RL     xInterval
3e5de6a370 Jean*0054       LOGICAL dBugFlag
80df109dfc Jean*0055       INTEGER dBugUnit
509dcf5e56 Jean*0056 #ifdef ALLOW_FIZHI
9a18ea0ab4 Jean*0057       LOGICAL  ALARM2NEXT
                0058       EXTERNAL ALARM2NEXT
666b944083 Jean*0059       CHARACTER *9 tagname
509dcf5e56 Jean*0060 #endif
                0061
                0062       LOGICAL  DIFF_PHASE_MULTIPLE
                0063       EXTERNAL DIFF_PHASE_MULTIPLE
dd6d146759 Jean*0064
                0065 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0066
41c4545f8f Jean*0067       dBugFlag = diag_dBugLevel.GE.debLevE .AND. myThid.EQ.1
80df109dfc Jean*0068       dBugUnit = errorMessageUnit
666b944083 Jean*0069
ab43bc12c4 Jean*0070 C--   Track diagnostics pkg activation status:
                0071       IF ( myIter.EQ.nIter0 ) THEN
                0072 c       IF ( diag_pkgStatus.NE.10 ) STOP
e01144d3ad Jean*0073         _BARRIER
                0074         _BEGIN_MASTER(myThid)
ab43bc12c4 Jean*0075         diag_pkgStatus = ready2fillDiags
                0076         _END_MASTER(myThid)
e01144d3ad Jean*0077         _BARRIER
ab43bc12c4 Jean*0078 c     ELSEIF
                0079 c       IF ( diag_pkgStatus.NE.ready2fillDiags ) STOP
                0080       ENDIF
                0081
509dcf5e56 Jean*0082 c     newIter = 1 + myIter
dd6d146759 Jean*0083       DO n = 1,nlists
509dcf5e56 Jean*0084
                0085        IF ( freq(n).LT.0. ) THEN
                0086 C--    Select diagnostics list that uses instantaneous output
                0087
                0088         freqSec = freq(n)
                0089         phiSec = phase(n)
333e96bf9c Andr*0090         time4SnapShot = DIFF_PHASE_MULTIPLE( phiSec, freqSec,
9a18ea0ab4 Jean*0091      &                                       myTime, deltaTClock )
463845a645 Andr*0092 #ifdef ALLOW_FIZHI
666b944083 Jean*0093         IF ( useFIZHI ) THEN
                0094          WRITE(tagname,'(A,I2.2)')'diagtag',n
9a18ea0ab4 Jean*0095          time4SnapShot = ALARM2NEXT(tagname,deltaT)
666b944083 Jean*0096         ENDIF
463845a645 Andr*0097 #endif
9a18ea0ab4 Jean*0098 #ifdef ALLOW_CAL
                0099         IF ( useCAL ) THEN
                0100           CALL CAL_TIME2DUMP( phiSec, freqSec, deltaTClock,
                0101      U                        time4SnapShot,
                0102      I                        myTime, myIter, myThid )
                0103         ENDIF
                0104 #endif /* ALLOW_CAL */
463845a645 Andr*0105
3ae5f90260 Jean*0106         DO bj=myByLo(myThid), myByHi(myThid)
                0107          DO bi=myBxLo(myThid), myBxHi(myThid)
                0108           IF ( time4SnapShot ) THEN
                0109 C--       switch ON diagnostics of output-stream # n
                0110             DO m=1,nActive(n)
b38beaf3c1 Jean*0111 c             nd = ABS(jdiag(m,n))
3ae5f90260 Jean*0112 c             IF (ndiag(nd).NE.0) WRITE(0,*) myIter,nd,ndiag(nd),' ->',0
                0113               ip = idiag(m,n)
                0114               IF (ip.GT.0) ndiag(ip,bi,bj) = 0
                0115             ENDDO
                0116           ELSE
                0117 C--       switch OFF diagnostics of output-stream # n
                0118             DO m=1,nActive(n)
b38beaf3c1 Jean*0119 c             nd = ABS(jdiag(m,n))
3ae5f90260 Jean*0120 c             IF (ndiag(nd).NE.-1) WRITE(0,*) myIter,nd,ndiag(nd),' ->',-1
                0121               ip = idiag(m,n)
                0122               IF (ip.GT.0) ndiag(ip,bi,bj) = -1
                0123             ENDDO
                0124           ENDIF
                0125          ENDDO
                0126         ENDDO
dd6d146759 Jean*0127
666b944083 Jean*0128 C--    list with instantaneous output: end
dd6d146759 Jean*0129        ENDIF
666b944083 Jean*0130
                0131        IF ( averageCycle(n).GT.1 ) THEN
                0132 C--    Select diagnostics list that uses periodic averaging
9a18ea0ab4 Jean*0133         xInterval = myTime + deltaTClock*0.5 _d 0 - averagePhase(n)
666b944083 Jean*0134         xInterval = xInterval / averageFreq(n)
                0135         IF ( xInterval.GE.0. ) THEN
                0136           nInterval = INT(xInterval)
                0137         ELSE
                0138           nInterval = 1 + INT( -xInterval/FLOAT(averageCycle(n)) )
                0139           nInterval = nInterval*averageCycle(n) + INT(xInterval) - 1
                0140         ENDIF
                0141         nInterval = MOD(nInterval,averageCycle(n))
                0142
                0143 C-     check future value of pdiag:
                0144         IF (dBugFlag.AND.pdiag(n,1,1).NE.nInterval)
e129400813 Jean*0145      &    WRITE(dBugUnit,'(A,I8,3(A,I4),F17.6)')
80df109dfc Jean*0146      &     'DIAG_SWITCH_ONOFF: at it=', myIter, ', list:', n,
                0147      &     ' switch', pdiag(n,1,1),' ->', nInterval, xInterval
666b944083 Jean*0148         IF ( nInterval.LT.0 .OR. nInterval.GE.averageCycle(n) ) THEN
e129400813 Jean*0149           WRITE(msgBuf,'(2A,I3,A,I4)') 'DIAGNOSTICS_SWITCH_ONOFF:',
666b944083 Jean*0150      &       ' error setting pdiag(n=',n,') to:', nInterval
                0151           CALL PRINT_ERROR( msgBuf , myThid )
e129400813 Jean*0152           WRITE(msgBuf,'(2A,I4,A,F17.6)') 'DIAGNOSTICS_SWITCH_ONOFF:',
666b944083 Jean*0153      &       ' cycle=', averageCycle(n), ', xInt=', xInterval
                0154           CALL PRINT_ERROR( msgBuf , myThid )
                0155           STOP 'ABNORMAL END: S/R DIAGNOSTICS_SWITCH_ONOFF'
                0156         ENDIF
                0157
                0158         DO bj=myByLo(myThid), myByHi(myThid)
                0159          DO bi=myBxLo(myThid), myBxHi(myThid)
                0160            pdiag(n,bi,bj) = nInterval
                0161          ENDDO
                0162         ENDDO
                0163 C--    list with periodic averaging: end
                0164        ENDIF
                0165
dd6d146759 Jean*0166       ENDDO
                0167
3e5de6a370 Jean*0168 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0169
                0170       DO n = 1,diagSt_nbLists
                0171
                0172        IF ( diagSt_freq(n).LT.0. ) THEN
                0173 C--    Select diagnostics list that uses instantaneous output
                0174
41c4545f8f Jean*0175         dBugFlag = diag_dBugLevel.GE.debLevE
3e5de6a370 Jean*0176
                0177         freqSec = diagSt_freq(n)
                0178         phiSec = diagSt_phase(n)
                0179         time4SnapShot = DIFF_PHASE_MULTIPLE( phiSec, freqSec,
9a18ea0ab4 Jean*0180      &                                       myTime, deltaTClock )
3e5de6a370 Jean*0181
0ca8304c4f Jean*0182 #ifdef ALLOW_FIZHI
666b944083 Jean*0183         IF ( useFIZHI ) THEN
                0184          WRITE(tagname,'(A,I2.2)')'diagStg',n
9a18ea0ab4 Jean*0185          time4SnapShot = ALARM2NEXT(tagname,deltaT)
666b944083 Jean*0186         ENDIF
0ca8304c4f Jean*0187 #endif
9a18ea0ab4 Jean*0188 #ifdef ALLOW_CAL
                0189         IF ( useCAL ) THEN
                0190           CALL CAL_TIME2DUMP( phiSec, freqSec, deltaTClock,
                0191      U                        time4SnapShot,
                0192      I                        myTime, myIter, myThid )
                0193         ENDIF
                0194 #endif /* ALLOW_CAL */
0ca8304c4f Jean*0195
3e5de6a370 Jean*0196         DO bj=myByLo(myThid), myByHi(myThid)
                0197          DO bi=myBxLo(myThid), myBxHi(myThid)
                0198           dBugFlag = dBugFlag.AND.(bi.EQ.1.AND.bj.EQ.1.AND.myThid.EQ.1)
                0199           IF ( time4SnapShot ) THEN
                0200 C--     switch ON diagnostics of output-stream # n
                0201             DO m=1,diagSt_nbActv(n)
3ae5f90260 Jean*0202              iSp = iSdiag(m,n)
                0203              IF (iSp.GT.0) THEN
                0204                nd = jSdiag(m,n)
                0205                IF (dBugFlag.AND.qSdiag(0,0,iSp,bi,bj).NE. 0.)
e129400813 Jean*0206      &          WRITE(dBugUnit,'(A,I8,A,I6,3A,1PE10.3,A,I3)')
80df109dfc Jean*0207      &           'DIAG_SWITCH_ONOFF: at it=', myIter, ' diag:', nd,
                0208      &           ' ',cdiag(nd),' :',qSdiag(0,0,iSp,bi,bj),' ->', 0
3ae5f90260 Jean*0209                qSdiag(0,0,iSp,bi,bj) = 0.
                0210              ENDIF
3e5de6a370 Jean*0211             ENDDO
                0212           ELSE
                0213 C--     switch OFF diagnostics of output-stream # n
                0214             DO m=1,diagSt_nbActv(n)
3ae5f90260 Jean*0215              iSp = iSdiag(m,n)
                0216              IF (iSp.GT.0) THEN
                0217                nd = jSdiag(m,n)
                0218                IF (dBugFlag.AND.qSdiag(0,0,iSp,bi,bj).NE.-1.)
e129400813 Jean*0219      &          WRITE(dBugUnit,'(A,I8,A,I6,3A,1PE10.3,A,I3)')
80df109dfc Jean*0220      &           'DIAG_SWITCH_ONOFF: at it=', myIter, ' diag:', nd,
                0221      &           ' ',cdiag(nd),' :',qSdiag(0,0,iSp,bi,bj),' ->', -1
3ae5f90260 Jean*0222                qSdiag(0,0,iSp,bi,bj) = -1.
                0223              ENDIF
3e5de6a370 Jean*0224             ENDDO
                0225           ENDIF
                0226          ENDDO
                0227         ENDDO
                0228
                0229        ENDIF
                0230       ENDDO
                0231
dd6d146759 Jean*0232       RETURN
                0233       END