/[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.5 by jmc, Sun Jun 26 16:51:49 2005 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    
33  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
34  C     == Local variables ==  C     == Local variables ==
35        INTEGER ndiagcount        INTEGER ndiagcount, ndCount
36        INTEGER md,ld,nd        INTEGER md,ld,nd
37        INTEGER mate, nActiveMax        INTEGER mate, nActiveMax
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 52  C--   Initialize pointer arrays to zero: Line 51  C--   Initialize pointer arrays to zero:
51         ENDDO         ENDDO
52        ENDDO        ENDDO
53    
54  C--   Calculate pointers for diagnostics set to non-zero frequency  C--   Calculate pointers for diagnostics in active output-stream
55    C                                   (i.e., with defined filename)
56    
57        ndiagcount = 0        ndiagcount = 0
58        nActiveMax = 0        nActiveMax = 0
# Line 70  C        Search all possible model diagn Line 70  C        Search all possible model diagn
70            ENDIF            ENDIF
71           ENDDO           ENDDO
72           IF ( .NOT.found ) THEN           IF ( .NOT.found ) THEN
73             WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',             CALL DIAGNOSTICS_LIST_CHECK(
74         O                      ndCount,
75         I                      ld, md, nlists, nfields, flds, myThid )
76               IF ( ndCount.EQ.0 ) THEN
77                 WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
78       &                      flds(md,ld),' is not a Diagnostic'       &                      flds(md,ld),' is not a Diagnostic'
79             CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
80               ENDIF
81             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
82           ENDIF           ENDIF
83           IF ( found .AND. mate.GE.1 ) THEN           IF ( found .AND. mate.GE.1 ) THEN
# Line 89  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 128  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.'   ' ) 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 156  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 176  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
205          ELSE          ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
206  C-      Check for levels out of range ( > kdiag)  C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
207            kLev = 0            kLev = 0
208            DO k=1,nlevels(ld)            DO k=1,nlevels(ld)
209              kLev = MAX(NINT(levs(k,ld)),kLev)              kLev = MAX(NINT(levs(k,ld)),kLev)
# Line 196  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.5  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22