/[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.7 by jmc, Sun Nov 19 21:59:56 2006 UTC revision 1.13 by jmc, Mon Jan 11 19:44:07 2010 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.'   ' ) 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
# Line 146  C     and if it exists. Note: for now, o Line 144  C     and if it exists. Note: for now, o
144            ENDDO            ENDDO
145           ENDIF           ENDIF
146           IF ( mdiag(md,ld).NE.0 ) THEN           IF ( mdiag(md,ld).NE.0 ) THEN
147            WRITE(msgBuf,'(A,I4,4A)') '  set mate pointer for diag #',            WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
148       &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)       &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
149         &             ' , mate:', hdiag(nd)
150            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
151       &                        SQUEEZE_RIGHT , myThid)       &                        SQUEEZE_RIGHT , myThid)
152           ENDIF           ENDIF
# Line 162  C--   Set list of levels to write (if no Line 161  C--   Set list of levels to write (if no
161        DO ld=1,nlists        DO ld=1,nlists
162          IF ( nlevels(ld).EQ.-1 ) THEN          IF ( nlevels(ld).EQ.-1 ) THEN
163  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:
164            kLev = numLevels            kLev = numLevels*10
165            DO md=1,nfields(ld)            DO md=1,nfields(ld)
166              nd = jdiag(md,ld)              nd = jdiag(md,ld)
167              kLev = MIN(kdiag(nd),kLev)              kLev = MIN(kdiag(nd),kLev)
168            ENDDO            ENDDO
169            IF ( kLev.LE.0 ) THEN            IF ( kLev.LE.0 ) THEN
170              WRITE(msgBuf,'(2A,I4,2A)')              WRITE(msgBuf,'(2A,I4,2A)')
171       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
172       &      ' setting levs of list l=',ld,', fnames: ', fnames(ld)       &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
173                CALL PRINT_ERROR( msgBuf , myThid )
174                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
175              ELSEIF ( kLev.GT.numLevels ) THEN
176                WRITE(msgBuf,'(A,2(I6,A))')
177         &      'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
178         &                  ' >', numLevels, ' =numLevels'
179                CALL PRINT_ERROR( msgBuf , myThid )
180                WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
181         &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
182              CALL PRINT_ERROR( msgBuf , myThid )              CALL PRINT_ERROR( msgBuf , myThid )
183              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
184            ENDIF            ENDIF
# Line 182  C-      set Nb of levels to the minimum Line 190  C-      set Nb of levels to the minimum
190       &      'Set levels for Outp.Stream: ',fnames(ld)       &      'Set levels for Outp.Stream: ',fnames(ld)
191            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
192       &                        SQUEEZE_RIGHT, myThid)       &                        SQUEEZE_RIGHT, myThid)
193              suffix = ' Levels:    '
194              IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
195            DO k1=1,nlevels(ld),20            DO k1=1,nlevels(ld),20
196              k2 = MIN(nlevels(ld),k1+19)              k2 = MIN(nlevels(ld),k1+19)
197              WRITE(msgBuf,'(A,20F5.0)')              WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
      &         ' Levels:    ', (levs(k,ld),k=k1,k2)  
198              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
199       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
200            ENDDO            ENDDO
201          ELSE          ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
202  C-      Check for levels out of range ( > kdiag)  C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
203            kLev = 0            kLev = 0
204            DO k=1,nlevels(ld)            DO k=1,nlevels(ld)
205              kLev = MAX(NINT(levs(k,ld)),kLev)              kLev = MAX(NINT(levs(k,ld)),kLev)
# Line 202  C- Note: diagnostics_out take care (in s Line 211  C- Note: diagnostics_out take care (in s
211  C        so that it does not cause "index out-off bounds" error.  C        so that it does not cause "index out-off bounds" error.
212  C        However, the output file looks strange.  C        However, the output file looks strange.
213  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
214               WRITE(msgBuf,'(A,I3,A,I3,2A)')               WRITE(msgBuf,'(A,I4,A,I6,2A)')
215       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
216       &         ' in list l=', ld, ', filename: ', fnames(ld)       &         ' in list l=', ld, ', filename: ', fnames(ld)
217               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
218               WRITE(msgBuf,'(2A,I3,A,I3,2A)')               WRITE(msgBuf,'(2A,I4,A,I6,2A)')
219       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
220       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
221               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
Legend:
Removed from v.1.7  
changed lines
  Added in v.1.13
  ViewVC Help
Powered by ViewVC 1.1.22