C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.17 2017/07/23 00:28:37 jmc Exp $ C $Name: $ #include "DIAG_OPTIONS.h" CBOP C !ROUTINE: DIAGNOSTICS_SET_POINTERS C !INTERFACE: SUBROUTINE DIAGNOSTICS_SET_POINTERS( myThid ) C !DESCRIPTION: \bv C *================================================================== C | S/R DIAGNOSTICS_SET_POINTERS C | o set pointers for active diagnostics C *================================================================== C \ev C !USES: IMPLICIT NONE C == Global variables === #include "EEPARAMS.h" #include "SIZE.h" #include "DIAGNOSTICS_SIZE.h" #include "DIAGNOSTICS.h" C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == C myThid :: my Thread Id. number INTEGER myThid CEOP C !LOCAL VARIABLES: C == Local variables == INTEGER ndiagcount, ndCount INTEGER md,ld,nd INTEGER mate, nActiveMax INTEGER i, j, k, k1, k2, kLev LOGICAL found CHARACTER*(MAX_LEN_MBUF) msgBuf CHARACTER*12 suffix _BEGIN_MASTER( myThid) C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| C-- In case an output file contains 2 post-processed diags which are computed C together (mate of 2nd PP-diag one is 1rst PP-diag), move these 2 diags C next to each other (to only computate them once): 1rst one then 2nd one. DO ld=1,nlists found = .FALSE. DO md=1,nfields(ld) C Search all possible model diagnostics nd = 0 DO i=1,ndiagt IF ( nd.EQ.0 .AND. flds(md,ld).EQ.cdiag(i) ) nd = i ENDDO j = 0 IF ( nd.GE.1 ) THEN IF ( gdiag(nd)(5:5).EQ.'P' ) THEN mate = hdiag(nd) IF ( gdiag(mate)(5:5).EQ.'P' ) THEN C Mate of Post-Processed diag "nd" is also Post-Processed DO i=1,nfields(ld) IF ( j.EQ.0 .AND. flds(i,ld).EQ.cdiag(mate) ) j = i ENDDO ENDIF ENDIF ENDIF C And is found in the same output stream "ld" (at rank "j") IF ( j.GE.1 .AND. j.NE.md-1 ) THEN IF ( .NOT.found ) THEN WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ', & 'Re-Order Diags in Outp.Stream: ',fnames(ld) CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, myThid ) ENDIF found = .TRUE. IF ( j.LT.md-1 ) THEN WRITE(msgBuf,'(2A,2(A,I4),2A)') & ' move ',flds(j,ld),' from ',j,' down to',md-1, & ' just before ',flds(md,ld) CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, myThid ) DO i=j,md-2 flds(i,ld) = flds(i+1,ld) ENDDO flds(md-1,ld) = cdiag(mate) ELSEIF ( j.GT.md ) THEN WRITE(msgBuf,'(2A,2(A,I4),2A)') & ' move ',flds(j,ld),' from ',j,' up to ',md, & ' just before ',flds(md,ld) CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, myThid ) DO i=j,md+1,-1 flds(i,ld) = flds(i-1,ld) ENDDO flds(md,ld) = cdiag(mate) ENDIF ENDIF ENDDO IF ( found ) THEN WRITE(msgBuf,'(2A,I4,A)') 'DIAGNOSTICS_SET_POINTERS: ', & 'Updated list in Outp.Stream #', ld, ' :' CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, myThid ) DO md = 1,nfields(ld),10 j = MIN(nfields(ld),md+9) WRITE(msgBuf,'(21A)') ' Fields: ',(' ',flds(i,ld),i=md,j) CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, myThid ) ENDDO ENDIF ENDDO C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| C-- Initialize pointer arrays to zero: DO ld=1,numLists DO md=1,numperList idiag(md,ld) = 0 jdiag(md,ld) = 0 mdiag(md,ld) = 0 ENDDO ENDDO C-- Calculate pointers for diagnostics in active output-stream C (i.e., with defined filename) ndiagcount = 0 nActiveMax = 0 DO ld=1,nlists nActive(ld) = nfields(ld) DO md=1,nfields(ld) found = .FALSE. C Search all possible model diagnostics DO nd=1,ndiagt IF ( flds(md,ld).EQ.cdiag(nd) ) THEN CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid) found = .TRUE. ENDIF ENDDO IF ( .NOT.found ) THEN CALL DIAGNOSTICS_LIST_CHECK( O ndCount, I ld, md, nlists, nfields, flds, myThid ) IF ( ndCount.EQ.0 ) THEN WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ', & flds(md,ld),' is not a Diagnostic' CALL PRINT_ERROR( msgBuf , myThid ) ENDIF STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS' ENDIF ENDDO nActiveMax = MAX(nActive(ld),nActiveMax) ENDDO IF ( ndiagcount.LE.numDiags .AND. & nActiveMax.LE.numperList ) THEN WRITE(msgBuf,'(A,I8,A)') & ' space allocated for all diagnostics:', & ndiagcount, ' levels' CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, myThid ) ELSE IF ( ndiagcount.GT.numDiags ) THEN WRITE(msgBuf,'(2A)') & 'DIAGNOSTICS_SET_POINTERS: Not enough space', & ' for all active diagnostics (from data.diagnostics)' CALL PRINT_ERROR( msgBuf , myThid ) WRITE(msgBuf,'(A,I8,A,I8)') & 'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags, & ' but needs at least', ndiagcount CALL PRINT_ERROR( msgBuf , myThid ) ENDIF IF ( nActiveMax.GT.numperList ) THEN WRITE(msgBuf,'(2A)') & 'DIAGNOSTICS_SET_POINTERS: Not enough space', & ' for all active diagnostics (from data.diagnostics)' CALL PRINT_ERROR( msgBuf , myThid ) WRITE(msgBuf,'(A,I6,A,I6)') & 'DIAGNOSTICS_SET_POINTERS: numperList=', numperList, & ' but needs at least', nActiveMax CALL PRINT_ERROR( msgBuf , myThid ) ENDIF STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS' ENDIF C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| C-- Set pointer for mate (e.g.vector component mate) if not already done C and if it exists. Note: for now, only used to print message. DO ld=1,nlists DO md=1,nActive(ld) IF (mdiag(md,ld).EQ.0 ) THEN k = SIGN(1,jdiag(md,ld)) nd = ABS(jdiag(md,ld)) mate = hdiag(nd) IF ( mate.GT.0 ) THEN DO j=1,nlists DO i=1,nActive(j) IF ( mdiag(md,ld).EQ.0 .AND. (k*jdiag(i,j)).EQ.mate ) THEN IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld) & .AND. averageFreq(j) .EQ.averageFreq(ld) & .AND. averagePhase(j).EQ.averagePhase(ld) & .AND. averageCycle(j).EQ.averageCycle(ld) ) & mdiag(md,ld) = ABS(idiag(i,j)) ENDIF ENDDO ENDDO ENDIF IF ( mdiag(md,ld).NE.0 ) THEN WRITE(msgBuf,'(A,I6,5A,I6)') ' set mate pointer for diag #', & nd, ' ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10), & ' , mate:', hdiag(nd) CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, myThid ) ENDIF ENDIF ENDDO ENDDO C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| C-- Set list of levels to write (if not specified in data.diagnostics) DO ld=1,nlists IF ( nlevels(ld).EQ.-1 ) THEN C- set Nb of levels to the minimum size of all diag of this list: kLev = numLevels*10 DO md=1,nfields(ld) nd = ABS(jdiag(md,ld)) kLev = MIN(kdiag(nd),kLev) ENDDO IF ( kLev.LE.0 ) THEN WRITE(msgBuf,'(2A,I4,2A)') & 'DIAGNOSTICS_SET_POINTERS: kLev < 1 in', & ' setting levs of list l=',ld,', fnames=', fnames(ld) CALL PRINT_ERROR( msgBuf , myThid ) STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS' ELSEIF ( kLev.GT.numLevels ) THEN WRITE(msgBuf,'(A,2(I6,A))') & 'DIAGNOSTICS_SET_POINTERS: kLev=', kLev, & ' >', numLevels, ' =numLevels' CALL PRINT_ERROR( msgBuf , myThid ) WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in', & ' setting levs of list l=',ld,', fnames=', fnames(ld) CALL PRINT_ERROR( msgBuf , myThid ) STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS' ENDIF nlevels(ld) = kLev DO k=1,kLev levs(k,ld) = k ENDDO WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ', & 'Set levels for Outp.Stream: ',fnames(ld) CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, myThid) suffix = ' Levels: ' IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:' DO k1=1,nlevels(ld),20 k2 = MIN(nlevels(ld),k1+19) WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2) CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT, myThid) ENDDO ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN C- if no Vert.Interpolation, check for levels out of range ( > kdiag): kLev = 0 DO k=1,nlevels(ld) kLev = MAX(NINT(levs(k,ld)),kLev) ENDDO DO md=1,nfields(ld) nd = ABS(jdiag(md,ld)) IF ( kLev.GT.kdiag(nd) ) THEN C- Note: diagnostics_out take care (in some way) of this case C so that it does not cause "index out-off bounds" error. C However, the output file looks strange. C- For now, choose to stop, but could change it to just a warning WRITE(msgBuf,'(A,I4,A,I6,2A)') & 'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev, & ' in list l=', ld, ', filename: ', fnames(ld) CALL PRINT_ERROR( msgBuf , myThid ) WRITE(msgBuf,'(2A,I4,A,I6,2A)') & 'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.', & '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd) CALL PRINT_ERROR( msgBuf , myThid ) WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ', & ' parsing code >>',gdiag(nd),'<<' CALL PRINT_ERROR( msgBuf , myThid ) STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS' ENDIF ENDDO ENDIF ENDDO WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done' CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT , myThid) WRITE(msgBuf,'(2A)') & '------------------------------------------------------------' CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, & SQUEEZE_RIGHT , myThid) _END_MASTER( myThid ) RETURN END