File indexing completed on 2024-07-17 05:10:41 UTC
view on githubraw file Latest commit acacc28f on 2024-07-17 03:59:01 UTC
dd6d146759 Jean*0001 #include "DIAG_OPTIONS.h"
acacc28f7f Jean*0002 #ifdef ALLOW_AUTODIFF
0003 # include "AUTODIFF_OPTIONS.h"
0004 #endif
dd6d146759 Jean*0005
0006
acacc28f7f Jean*0007
dd6d146759 Jean*0008
0009
0010
acacc28f7f Jean*0011 SUBROUTINE DIAGNOSTICS_SWITCH_ONOFF(
41c4545f8f Jean*0012 I seqFlag, myTime, myIter, myThid )
dd6d146759 Jean*0013
0014
0015
0016
0017
0018
0019
0020
0021
0022
0023
0024
0025
0026 IMPLICIT NONE
0027 #include "SIZE.h"
0028 #include "EEPARAMS.h"
0029 #include "PARAMS.h"
0030 #include "DIAGNOSTICS_SIZE.h"
0031 #include "DIAGNOSTICS.h"
0032
0033
41c4545f8f Jean*0034
0035
0036
0037
0038
0039
0040 INTEGER seqFlag
02545dbccf Jean*0041 _RL myTime
dd6d146759 Jean*0042 INTEGER myIter
0043 INTEGER myThid
acacc28f7f Jean*0044
0045
0046 LOGICAL DIFF_PHASE_MULTIPLE
0047 EXTERNAL DIFF_PHASE_MULTIPLE
dd6d146759 Jean*0048
0049
0050
0051
666b944083 Jean*0052 CHARACTER*(MAX_LEN_MBUF) msgBuf
509dcf5e56 Jean*0053
3ae5f90260 Jean*0054 INTEGER m, n, nd
0055 INTEGER bi, bj, ip, iSp
509dcf5e56 Jean*0056 LOGICAL time4SnapShot
0057 _RL phiSec, freqSec
666b944083 Jean*0058 INTEGER nInterval
0059 _RL xInterval
acacc28f7f Jean*0060 LOGICAL firstCall
3e5de6a370 Jean*0061 LOGICAL dBugFlag
80df109dfc Jean*0062 INTEGER dBugUnit
509dcf5e56 Jean*0063 #ifdef ALLOW_FIZHI
9a18ea0ab4 Jean*0064 LOGICAL ALARM2NEXT
0065 EXTERNAL ALARM2NEXT
acacc28f7f Jean*0066 CHARACTER*9 tagname
509dcf5e56 Jean*0067 #endif
acacc28f7f Jean*0068
dd6d146759 Jean*0069
0070
0071
41c4545f8f Jean*0072 dBugFlag = diag_dBugLevel.GE.debLevE .AND. myThid.EQ.1
80df109dfc Jean*0073 dBugUnit = errorMessageUnit
666b944083 Jean*0074
ab43bc12c4 Jean*0075
acacc28f7f Jean*0076 firstCall = myIter.EQ.nIter0
0077 IF ( seqFlag.EQ.-1 ) THEN
0078 #ifdef ALLOW_DIVIDED_ADJOINT
0079 CALL DIAGS_TRACK_DIVA( firstCall, myIter, myThid )
0080 #else
0081 firstCall = (myIter+1).EQ.nEndIter
0082 #endif
0083 ENDIF
0084 IF ( firstCall .AND. ( seqFlag.EQ.1 .OR. seqFlag.EQ.-1 ) ) THEN
0085
e01144d3ad Jean*0086 _BARRIER
0087 _BEGIN_MASTER(myThid)
ab43bc12c4 Jean*0088 diag_pkgStatus = ready2fillDiags
0089 _END_MASTER(myThid)
e01144d3ad Jean*0090 _BARRIER
ab43bc12c4 Jean*0091
0092
0093 ENDIF
0094
509dcf5e56 Jean*0095
dd6d146759 Jean*0096 DO n = 1,nlists
509dcf5e56 Jean*0097
0098 IF ( freq(n).LT.0. ) THEN
0099
0100
0101 freqSec = freq(n)
0102 phiSec = phase(n)
333e96bf9c Andr*0103 time4SnapShot = DIFF_PHASE_MULTIPLE( phiSec, freqSec,
9a18ea0ab4 Jean*0104 & myTime, deltaTClock )
463845a645 Andr*0105 #ifdef ALLOW_FIZHI
666b944083 Jean*0106 IF ( useFIZHI ) THEN
0107 WRITE(tagname,'(A,I2.2)')'diagtag',n
9a18ea0ab4 Jean*0108 time4SnapShot = ALARM2NEXT(tagname,deltaT)
666b944083 Jean*0109 ENDIF
463845a645 Andr*0110 #endif
9a18ea0ab4 Jean*0111 #ifdef ALLOW_CAL
0112 IF ( useCAL ) THEN
0113 CALL CAL_TIME2DUMP( phiSec, freqSec, deltaTClock,
0114 U time4SnapShot,
0115 I myTime, myIter, myThid )
0116 ENDIF
0117 #endif /* ALLOW_CAL */
463845a645 Andr*0118
3ae5f90260 Jean*0119 DO bj=myByLo(myThid), myByHi(myThid)
0120 DO bi=myBxLo(myThid), myBxHi(myThid)
0121 IF ( time4SnapShot ) THEN
0122
0123 DO m=1,nActive(n)
b38beaf3c1 Jean*0124
3ae5f90260 Jean*0125
0126 ip = idiag(m,n)
0127 IF (ip.GT.0) ndiag(ip,bi,bj) = 0
0128 ENDDO
0129 ELSE
0130
0131 DO m=1,nActive(n)
b38beaf3c1 Jean*0132
3ae5f90260 Jean*0133
0134 ip = idiag(m,n)
0135 IF (ip.GT.0) ndiag(ip,bi,bj) = -1
0136 ENDDO
0137 ENDIF
0138 ENDDO
0139 ENDDO
dd6d146759 Jean*0140
666b944083 Jean*0141
dd6d146759 Jean*0142 ENDIF
666b944083 Jean*0143
0144 IF ( averageCycle(n).GT.1 ) THEN
0145
9a18ea0ab4 Jean*0146 xInterval = myTime + deltaTClock*0.5 _d 0 - averagePhase(n)
666b944083 Jean*0147 xInterval = xInterval / averageFreq(n)
0148 IF ( xInterval.GE.0. ) THEN
0149 nInterval = INT(xInterval)
0150 ELSE
0151 nInterval = 1 + INT( -xInterval/FLOAT(averageCycle(n)) )
0152 nInterval = nInterval*averageCycle(n) + INT(xInterval) - 1
0153 ENDIF
0154 nInterval = MOD(nInterval,averageCycle(n))
0155
0156
0157 IF (dBugFlag.AND.pdiag(n,1,1).NE.nInterval)
e129400813 Jean*0158 & WRITE(dBugUnit,'(A,I8,3(A,I4),F17.6)')
80df109dfc Jean*0159 & 'DIAG_SWITCH_ONOFF: at it=', myIter, ', list:', n,
0160 & ' switch', pdiag(n,1,1),' ->', nInterval, xInterval
666b944083 Jean*0161 IF ( nInterval.LT.0 .OR. nInterval.GE.averageCycle(n) ) THEN
e129400813 Jean*0162 WRITE(msgBuf,'(2A,I3,A,I4)') 'DIAGNOSTICS_SWITCH_ONOFF:',
666b944083 Jean*0163 & ' error setting pdiag(n=',n,') to:', nInterval
0164 CALL PRINT_ERROR( msgBuf , myThid )
e129400813 Jean*0165 WRITE(msgBuf,'(2A,I4,A,F17.6)') 'DIAGNOSTICS_SWITCH_ONOFF:',
666b944083 Jean*0166 & ' cycle=', averageCycle(n), ', xInt=', xInterval
0167 CALL PRINT_ERROR( msgBuf , myThid )
0168 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SWITCH_ONOFF'
0169 ENDIF
0170
0171 DO bj=myByLo(myThid), myByHi(myThid)
0172 DO bi=myBxLo(myThid), myBxHi(myThid)
0173 pdiag(n,bi,bj) = nInterval
0174 ENDDO
0175 ENDDO
0176
0177 ENDIF
0178
dd6d146759 Jean*0179 ENDDO
0180
3e5de6a370 Jean*0181
0182
0183 DO n = 1,diagSt_nbLists
0184
0185 IF ( diagSt_freq(n).LT.0. ) THEN
0186
0187
41c4545f8f Jean*0188 dBugFlag = diag_dBugLevel.GE.debLevE
3e5de6a370 Jean*0189
0190 freqSec = diagSt_freq(n)
0191 phiSec = diagSt_phase(n)
0192 time4SnapShot = DIFF_PHASE_MULTIPLE( phiSec, freqSec,
9a18ea0ab4 Jean*0193 & myTime, deltaTClock )
3e5de6a370 Jean*0194
0ca8304c4f Jean*0195 #ifdef ALLOW_FIZHI
666b944083 Jean*0196 IF ( useFIZHI ) THEN
0197 WRITE(tagname,'(A,I2.2)')'diagStg',n
9a18ea0ab4 Jean*0198 time4SnapShot = ALARM2NEXT(tagname,deltaT)
666b944083 Jean*0199 ENDIF
0ca8304c4f Jean*0200 #endif
9a18ea0ab4 Jean*0201 #ifdef ALLOW_CAL
0202 IF ( useCAL ) THEN
0203 CALL CAL_TIME2DUMP( phiSec, freqSec, deltaTClock,
0204 U time4SnapShot,
0205 I myTime, myIter, myThid )
0206 ENDIF
0207 #endif /* ALLOW_CAL */
0ca8304c4f Jean*0208
3e5de6a370 Jean*0209 DO bj=myByLo(myThid), myByHi(myThid)
0210 DO bi=myBxLo(myThid), myBxHi(myThid)
0211 dBugFlag = dBugFlag.AND.(bi.EQ.1.AND.bj.EQ.1.AND.myThid.EQ.1)
0212 IF ( time4SnapShot ) THEN
0213
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. 0.)
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),' ->', 0
3ae5f90260 Jean*0222 qSdiag(0,0,iSp,bi,bj) = 0.
0223 ENDIF
3e5de6a370 Jean*0224 ENDDO
0225 ELSE
0226
0227 DO m=1,diagSt_nbActv(n)
3ae5f90260 Jean*0228 iSp = iSdiag(m,n)
0229 IF (iSp.GT.0) THEN
0230 nd = jSdiag(m,n)
0231 IF (dBugFlag.AND.qSdiag(0,0,iSp,bi,bj).NE.-1.)
e129400813 Jean*0232 & WRITE(dBugUnit,'(A,I8,A,I6,3A,1PE10.3,A,I3)')
80df109dfc Jean*0233 & 'DIAG_SWITCH_ONOFF: at it=', myIter, ' diag:', nd,
0234 & ' ',cdiag(nd),' :',qSdiag(0,0,iSp,bi,bj),' ->', -1
3ae5f90260 Jean*0235 qSdiag(0,0,iSp,bi,bj) = -1.
0236 ENDIF
3e5de6a370 Jean*0237 ENDDO
0238 ENDIF
0239 ENDDO
0240 ENDDO
0241
0242 ENDIF
0243 ENDDO
0244
dd6d146759 Jean*0245 RETURN
0246 END