/[MITgcm]/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F
ViewVC logotype

Diff of /MITgcm/pkg/diagnostics/diagnostics_set_pointers.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.9 by jahn, Tue Jan 29 00:35:31 2008 UTC revision 1.14 by jmc, Wed Jun 15 13:22:43 2011 UTC
# Line 26  C     == Global variables === Line 26  C     == Global variables ===
26    
27  C     !INPUT/OUTPUT PARAMETERS:  C     !INPUT/OUTPUT PARAMETERS:
28  C     == Routine arguments ==  C     == Routine arguments ==
29  C     myThid - Thread number for this instance of the routine.  C     myThid :: my Thread Id. number
30        INTEGER myThid        INTEGER myThid
31  CEOP  CEOP
32    
# Line 38  C     == Local variables == Line 38  C     == Local variables ==
38        INTEGER i, j, k, k1, k2, mm, kLev        INTEGER i, j, k, k1, k2, mm, kLev
39        LOGICAL found        LOGICAL found
40        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
41        CHARACTER*3 mate_index        CHARACTER*12 suffix
   
42    
43        _BEGIN_MASTER( myThid)        _BEGIN_MASTER( myThid)
44    
# Line 73  C        Search all possible model diagn Line 72  C        Search all possible model diagn
72           IF ( .NOT.found ) THEN           IF ( .NOT.found ) THEN
73             CALL DIAGNOSTICS_LIST_CHECK(             CALL DIAGNOSTICS_LIST_CHECK(
74       O                      ndCount,       O                      ndCount,
75       I                      ld, md, nfields, flds, myThid )       I                      ld, md, nlists, nfields, flds, myThid )
76             IF ( ndCount.EQ.0 ) THEN             IF ( ndCount.EQ.0 ) THEN
77               WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',               WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
78       &                      flds(md,ld),' is not a Diagnostic'       &                      flds(md,ld),' is not a Diagnostic'
# Line 95  C        Search all possible model diagn Line 94  C        Search all possible model diagn
94         nActiveMax = MAX(nActive(ld),nActiveMax)         nActiveMax = MAX(nActive(ld),nActiveMax)
95        ENDDO        ENDDO
96    
97        IF (  ndiagcount.LE.numdiags .AND.        IF (  ndiagcount.LE.numDiags .AND.
98       &      nActiveMax.LE.numperlist ) THEN       &      nActiveMax.LE.numperlist ) THEN
99          WRITE(msgBuf,'(A,I6,A)')          WRITE(msgBuf,'(A,I8,A)')
100       &    '  space allocated for all diagnostics:',       &    '  space allocated for all diagnostics:',
101       &    ndiagcount, ' levels'       &    ndiagcount, ' levels'
102          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
103       &                      SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid)
104        ELSE        ELSE
105         IF ( ndiagcount.GT.numdiags ) THEN         IF ( ndiagcount.GT.numDiags ) THEN
106           WRITE(msgBuf,'(2A)')           WRITE(msgBuf,'(2A)')
107       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
108       &    ' for all active diagnostics (from data.diagnostics)'       &    ' for all active diagnostics (from data.diagnostics)'
109           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
110           WRITE(msgBuf,'(A,I6,A,I6)')           WRITE(msgBuf,'(A,I8,A,I8)')
111       &    'DIAGNOSTICS_SET_POINTERS: numdiags=', numdiags,       &    'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
112       &    ' but needs at least', ndiagcount       &    ' but needs at least', ndiagcount
113           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
114         ENDIF         ENDIF
# Line 134  C     and if it exists. Note: for now, o Line 133  C     and if it exists. Note: for now, o
133          IF (mdiag(md,ld).EQ.0 ) THEN          IF (mdiag(md,ld).EQ.0 ) THEN
134    
135           nd = jdiag(md,ld)           nd = jdiag(md,ld)
136           mate_index = gdiag(nd)(6:8)           mate = hdiag(nd)
137           IF ( mate_index.NE.'   ' .AND. mate_index.NE.'***' ) THEN           IF ( mate.GT.0 ) THEN
           READ(mate_index,'(I3)') mate  
138            DO j=1,nlists            DO j=1,nlists
139             DO i=1,nActive(j)             DO i=1,nActive(j)
140              IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN              IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
141                mdiag(md,ld) = ABS(idiag(i,j))               IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld)
142         &           .AND. averageFreq(j) .EQ.averageFreq(ld)
143         &           .AND. averagePhase(j).EQ.averagePhase(ld)
144         &           .AND. averageCycle(j).EQ.averageCycle(ld) )
145         &          mdiag(md,ld) = ABS(idiag(i,j))
146              ENDIF              ENDIF
147             ENDDO             ENDDO
148            ENDDO            ENDDO
149           ENDIF           ENDIF
150           IF ( mdiag(md,ld).NE.0 ) THEN           IF ( mdiag(md,ld).NE.0 ) THEN
151            WRITE(msgBuf,'(A,I4,4A)') '  set mate pointer for diag #',            WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
152       &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)       &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
153         &             ' , mate:', hdiag(nd)
154            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
155       &                        SQUEEZE_RIGHT , myThid)       &                        SQUEEZE_RIGHT , myThid)
156           ENDIF           ENDIF
# Line 162  C--   Set list of levels to write (if no Line 165  C--   Set list of levels to write (if no
165        DO ld=1,nlists        DO ld=1,nlists
166          IF ( nlevels(ld).EQ.-1 ) THEN          IF ( nlevels(ld).EQ.-1 ) THEN
167  C-      set Nb of levels to the minimum size of all diag of this list:  C-      set Nb of levels to the minimum size of all diag of this list:
168            kLev = numLevels            kLev = numLevels*10
169            DO md=1,nfields(ld)            DO md=1,nfields(ld)
170              nd = jdiag(md,ld)              nd = jdiag(md,ld)
171              kLev = MIN(kdiag(nd),kLev)              kLev = MIN(kdiag(nd),kLev)
172            ENDDO            ENDDO
173            IF ( kLev.LE.0 ) THEN            IF ( kLev.LE.0 ) THEN
174              WRITE(msgBuf,'(2A,I4,2A)')              WRITE(msgBuf,'(2A,I4,2A)')
175       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
176       &      ' setting levs of list l=',ld,', fnames: ', fnames(ld)       &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
177                CALL PRINT_ERROR( msgBuf , myThid )
178                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
179              ELSEIF ( kLev.GT.numLevels ) THEN
180                WRITE(msgBuf,'(A,2(I6,A))')
181         &      'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
182         &                  ' >', numLevels, ' =numLevels'
183                CALL PRINT_ERROR( msgBuf , myThid )
184                WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
185         &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
186              CALL PRINT_ERROR( msgBuf , myThid )              CALL PRINT_ERROR( msgBuf , myThid )
187              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
188            ENDIF            ENDIF
# Line 182  C-      set Nb of levels to the minimum Line 194  C-      set Nb of levels to the minimum
194       &      'Set levels for Outp.Stream: ',fnames(ld)       &      'Set levels for Outp.Stream: ',fnames(ld)
195            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
196       &                        SQUEEZE_RIGHT, myThid)       &                        SQUEEZE_RIGHT, myThid)
197              suffix = ' Levels:    '
198              IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
199            DO k1=1,nlevels(ld),20            DO k1=1,nlevels(ld),20
200              k2 = MIN(nlevels(ld),k1+19)              k2 = MIN(nlevels(ld),k1+19)
201              WRITE(msgBuf,'(A,20F5.0)')              WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
      &         ' Levels:    ', (levs(k,ld),k=k1,k2)  
202              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
203       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
204            ENDDO            ENDDO
# Line 202  C- Note: diagnostics_out take care (in s Line 215  C- Note: diagnostics_out take care (in s
215  C        so that it does not cause "index out-off bounds" error.  C        so that it does not cause "index out-off bounds" error.
216  C        However, the output file looks strange.  C        However, the output file looks strange.
217  C- For now, choose to stop, but could change it to just a warning  C- For now, choose to stop, but could change it to just a warning
218               WRITE(msgBuf,'(A,I3,A,I3,2A)')               WRITE(msgBuf,'(A,I4,A,I6,2A)')
219       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
220       &         ' in list l=', ld, ', filename: ', fnames(ld)       &         ' in list l=', ld, ', filename: ', fnames(ld)
221               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
222               WRITE(msgBuf,'(2A,I3,A,I3,2A)')               WRITE(msgBuf,'(2A,I4,A,I6,2A)')
223       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
224       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
225               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22