/[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.15 by jmc, Tue Jun 21 18:00:15 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, 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    
45  C--   Initialize pointer arrays to zero:  C--   Initialize pointer arrays to zero:
46        DO ld=1,numlists        DO ld=1,numLists
47         DO md=1,numperlist         DO md=1,numperList
48          idiag(md,ld) = 0          idiag(md,ld) = 0
49          jdiag(md,ld) = 0          jdiag(md,ld) = 0
50          mdiag(md,ld) = 0          mdiag(md,ld) = 0
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 )
            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'  
          ENDIF  
          IF ( found .AND. mate.GE.1 ) THEN  
            mm = nActive(ld) + 1  
            IF ( mm.LE.numperlist ) THEN  
              jdiag(mm,ld) = mate  
              idiag(mm,ld) = mdiag(md,ld)  
              flds (mm,ld) = cdiag(mate)  
80             ENDIF             ENDIF
81             nActive(ld) = mm             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
82           ENDIF           ENDIF
83    
84         ENDDO         ENDDO
85         nActiveMax = MAX(nActive(ld),nActiveMax)         nActiveMax = MAX(nActive(ld),nActiveMax)
86        ENDDO        ENDDO
87    
88        IF (  ndiagcount.LE.numdiags .AND.        IF (  ndiagcount.LE.numDiags .AND.
89       &      nActiveMax.LE.numperlist ) THEN       &      nActiveMax.LE.numperList ) THEN
90          WRITE(msgBuf,'(A,I6,A)')          WRITE(msgBuf,'(A,I8,A)')
91       &    '  space allocated for all diagnostics:',       &    '  space allocated for all diagnostics:',
92       &    ndiagcount, ' levels'       &    ndiagcount, ' levels'
93          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
94       &                      SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid)
95        ELSE        ELSE
96         IF ( ndiagcount.GT.numdiags ) THEN         IF ( ndiagcount.GT.numDiags ) THEN
97           WRITE(msgBuf,'(2A)')           WRITE(msgBuf,'(2A)')
98       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
99       &    ' for all active diagnostics (from data.diagnostics)'       &    ' for all active diagnostics (from data.diagnostics)'
100           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
101           WRITE(msgBuf,'(A,I6,A,I6)')           WRITE(msgBuf,'(A,I8,A,I8)')
102       &    'DIAGNOSTICS_SET_POINTERS: numdiags=', numdiags,       &    'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
103       &    ' but needs at least', ndiagcount       &    ' but needs at least', ndiagcount
104           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
105         ENDIF         ENDIF
106         IF ( nActiveMax.GT.numperlist ) THEN         IF ( nActiveMax.GT.numperList ) THEN
107           WRITE(msgBuf,'(2A)')           WRITE(msgBuf,'(2A)')
108       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
109       &    ' for all active diagnostics (from data.diagnostics)'       &    ' for all active diagnostics (from data.diagnostics)'
110           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
111           WRITE(msgBuf,'(A,I6,A,I6)')           WRITE(msgBuf,'(A,I6,A,I6)')
112       &    'DIAGNOSTICS_SET_POINTERS: numperlist=', numperlist,       &    'DIAGNOSTICS_SET_POINTERS: numperList=', numperList,
113       &    ' but needs at least', nActiveMax       &    ' but needs at least', nActiveMax
114           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
115         ENDIF         ENDIF
# Line 128  C     and if it exists. Note: for now, o Line 124  C     and if it exists. Note: for now, o
124          IF (mdiag(md,ld).EQ.0 ) THEN          IF (mdiag(md,ld).EQ.0 ) THEN
125    
126           nd = jdiag(md,ld)           nd = jdiag(md,ld)
127           mate_index = gdiag(nd)(6:8)           mate = hdiag(nd)
128           IF ( mate_index.NE.'   ' ) THEN           IF ( mate.GT.0 ) THEN
           READ(mate_index,'(I3)') mate  
129            DO j=1,nlists            DO j=1,nlists
130             DO i=1,nActive(j)             DO i=1,nActive(j)
131              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
132                mdiag(md,ld) = ABS(idiag(i,j))               IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld)
133         &           .AND. averageFreq(j) .EQ.averageFreq(ld)
134         &           .AND. averagePhase(j).EQ.averagePhase(ld)
135         &           .AND. averageCycle(j).EQ.averageCycle(ld) )
136         &          mdiag(md,ld) = ABS(idiag(i,j))
137              ENDIF              ENDIF
138             ENDDO             ENDDO
139            ENDDO            ENDDO
140           ENDIF           ENDIF
141           IF ( mdiag(md,ld).NE.0 ) THEN           IF ( mdiag(md,ld).NE.0 ) THEN
142            WRITE(msgBuf,'(A,I4,4A)') '  set mate pointer for diag #',            WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
143       &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)       &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
144         &             ' , mate:', hdiag(nd)
145            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
146       &                        SQUEEZE_RIGHT , myThid)       &                        SQUEEZE_RIGHT , myThid)
147           ENDIF           ENDIF
# Line 156  C--   Set list of levels to write (if no Line 156  C--   Set list of levels to write (if no
156        DO ld=1,nlists        DO ld=1,nlists
157          IF ( nlevels(ld).EQ.-1 ) THEN          IF ( nlevels(ld).EQ.-1 ) THEN
158  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:
159            kLev = numLevels            kLev = numLevels*10
160            DO md=1,nfields(ld)            DO md=1,nfields(ld)
161              nd = jdiag(md,ld)              nd = jdiag(md,ld)
162              kLev = MIN(kdiag(nd),kLev)              kLev = MIN(kdiag(nd),kLev)
163            ENDDO            ENDDO
164            IF ( kLev.LE.0 ) THEN            IF ( kLev.LE.0 ) THEN
165              WRITE(msgBuf,'(2A,I4,2A)')              WRITE(msgBuf,'(2A,I4,2A)')
166       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
167       &      ' setting levs of list l=',ld,', fnames: ', fnames(ld)       &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
168                CALL PRINT_ERROR( msgBuf , myThid )
169                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
170              ELSEIF ( kLev.GT.numLevels ) THEN
171                WRITE(msgBuf,'(A,2(I6,A))')
172         &      'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
173         &                  ' >', numLevels, ' =numLevels'
174                CALL PRINT_ERROR( msgBuf , myThid )
175                WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
176         &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
177              CALL PRINT_ERROR( msgBuf , myThid )              CALL PRINT_ERROR( msgBuf , myThid )
178              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
179            ENDIF            ENDIF
# Line 176  C-      set Nb of levels to the minimum Line 185  C-      set Nb of levels to the minimum
185       &      'Set levels for Outp.Stream: ',fnames(ld)       &      'Set levels for Outp.Stream: ',fnames(ld)
186            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
187       &                        SQUEEZE_RIGHT, myThid)       &                        SQUEEZE_RIGHT, myThid)
188              suffix = ' Levels:    '
189              IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
190            DO k1=1,nlevels(ld),20            DO k1=1,nlevels(ld),20
191              k2 = MIN(nlevels(ld),k1+19)              k2 = MIN(nlevels(ld),k1+19)
192              WRITE(msgBuf,'(A,20F5.0)')              WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
      &         ' Levels:    ', (levs(k,ld),k=k1,k2)  
193              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
194       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
195            ENDDO            ENDDO
196          ELSE          ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
197  C-      Check for levels out of range ( > kdiag)  C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
198            kLev = 0            kLev = 0
199            DO k=1,nlevels(ld)            DO k=1,nlevels(ld)
200              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 206  C- Note: diagnostics_out take care (in s
206  C        so that it does not cause "index out-off bounds" error.  C        so that it does not cause "index out-off bounds" error.
207  C        However, the output file looks strange.  C        However, the output file looks strange.
208  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
209               WRITE(msgBuf,'(A,I3,A,I3,2A)')               WRITE(msgBuf,'(A,I4,A,I6,2A)')
210       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
211       &         ' in list l=', ld, ', filename: ', fnames(ld)       &         ' in list l=', ld, ', filename: ', fnames(ld)
212               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
213               WRITE(msgBuf,'(2A,I3,A,I3,2A)')               WRITE(msgBuf,'(2A,I4,A,I6,2A)')
214       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
215       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
216               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.15
  ViewVC Help
Powered by ViewVC 1.1.22