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
09ceb40cd6 Jean*0001 #include "DIAG_OPTIONS.h"
0002
0003
0004
0005
0006 SUBROUTINE DIAGNOSTICS_SET_POINTERS( myThid )
0007
0008
0009
0010
0011
0012
0013
0014
0015
0016 IMPLICIT NONE
0017
0018
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
0026
5f837b700f Jean*0027
09ceb40cd6 Jean*0028 INTEGER myThid
0029
0030
0031
0032
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
0044
0045
0046
0047
0048 DO ld=1,nlists
0049 found = .FALSE.
0050 DO md=1,nfields(ld)
0051
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
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
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
0115
2dd05c816c Jean*0116
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
0126
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
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
3ae5f90260 Jean*0190
0191
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
a5ec81ed49 Timo*0225
0226 DO ld=1,nlists
0227 DO md=1,nfields(ld)
0228
0229 nd = ABS(jdiag(md,ld))
0230 useDiag4AdjOutp = useDiag4AdjOutp
0231 & .OR. ( gdiag(nd)(4:4).EQ.'A' )
0232 ENDDO
0233 ENDDO
0234
0235
7e2f6e329a Jean*0236
0237
3ae5f90260 Jean*0238 DO ld=1,nlists
0239 IF ( nlevels(ld).EQ.-1 ) THEN
7e2f6e329a Jean*0240
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,
acacc28f7f Jean*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,
acacc28f7f Jean*0276 & SQUEEZE_RIGHT, myThid )
7e2f6e329a Jean*0277 ENDDO
c65a5004af Jean*0278 ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
0279
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
7e2f6e329a Jean*0288
0289
0290
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
acacc28f7f Jean*0308 WRITE(msgBuf,'(2A,2(I8,A))') 'DIAGNOSTICS_SET_POINTERS: done',
0309 & ', use', ndiagcount, ' levels (numDiags =', numDiags, ' )'
0310 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0311 & SQUEEZE_RIGHT, myThid )
0312 WRITE(msgBuf,'(2A)')
7e2f6e329a Jean*0313 & '------------------------------------------------------------'
acacc28f7f Jean*0314 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0315 & SQUEEZE_RIGHT, myThid )
7e2f6e329a Jean*0316
09ceb40cd6 Jean*0317 _END_MASTER( myThid )
0318
0319 RETURN
0320 END