/[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.2 by jmc, Wed Dec 15 00:18:39 2004 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    
33  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
34  C     == Local variables ==  C     == Local variables ==
35        INTEGER ndiagcount        INTEGER ndiagcount, ndCount
36        INTEGER m,mm,n        INTEGER md,ld,nd
37        INTEGER mate, nActiveMax        INTEGER mate, nActiveMax
38          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*12 suffix
 C--   Calculate pointers for diagnostics set to non-zero frequency  
42    
43        _BEGIN_MASTER( myThid)        _BEGIN_MASTER( myThid)
44    
45    C--   Initialize pointer arrays to zero:
46          DO ld=1,numlists
47           DO md=1,numperlist
48            idiag(md,ld) = 0
49            jdiag(md,ld) = 0
50            mdiag(md,ld) = 0
51           ENDDO
52          ENDDO
53    
54    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
59        DO n=1,nlists        DO ld=1,nlists
60         nActive(n) = nfields(n)         nActive(ld) = nfields(ld)
61         DO m=1,nfields(n)         DO md=1,nfields(ld)
62    
63           found = .FALSE.           found = .FALSE.
64  C        Search all possible model diagnostics  C        Search all possible model diagnostics
65           DO mm=1,ndiagt           DO nd=1,ndiagt
66            IF ( flds(m,n).EQ.cdiag(mm) ) THEN            IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
67              CALL DIAGNOSTICS_SETDIAG (mate,ndiagcount,mm,myThid)              CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
68              found = .TRUE.              found = .TRUE.
69              jdiag(m,n) = mm              jdiag(md,ld) = nd
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       &                      flds(m,n),' is not a Diagnostic'       O                      ndCount,
75             CALL PRINT_ERROR( msgBuf , myThid )       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'
79                 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
84              nActive(n) = nActive(n) + 1             mm = nActive(ld) + 1
85              IF ( nActive(n).LE.numperlist ) THEN             IF ( mm.LE.numperlist ) THEN
86               jdiag(nActive(n),n) = mate               jdiag(mm,ld) = mate
87               flds( nActive(n),n) = cdiag(mate)               idiag(mm,ld) = mdiag(md,ld)
88                 flds (mm,ld) = cdiag(mate)
89             ENDIF             ENDIF
90               nActive(ld) = mm
91           ENDIF           ENDIF
92    
93         ENDDO         ENDDO
94         nActiveMax = MAX(nActive(n),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)') 'DIAGNOSTICS_SET_POINTERS: done'          WRITE(msgBuf,'(A,I8,A)')
100          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,       &    '  space allocated for all diagnostics:',
      &                      SQUEEZE_RIGHT , myThid)  
         WRITE(msgBuf,'(A,I6,A)')  
      &    '  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)
         WRITE(msgBuf,'(2A)')  
      &   '------------------------------------------------------------'  
         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,  
      &                      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 113  C        Search all possible model diagn Line 125  C        Search all possible model diagn
125         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
126        ENDIF        ENDIF
127    
128    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
129    C--   Set pointer for mate (e.g.vector component mate) if not already done
130    C     and if it exists. Note: for now, only used to print message.
131          DO ld=1,nlists
132           DO md=1,nActive(ld)
133            IF (mdiag(md,ld).EQ.0 ) THEN
134    
135             nd = jdiag(md,ld)
136             mate = hdiag(nd)
137             IF ( mate.GT.0 ) THEN
138              DO j=1,nlists
139               DO i=1,nActive(j)
140                IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
141                  mdiag(md,ld) = ABS(idiag(i,j))
142                ENDIF
143               ENDDO
144              ENDDO
145             ENDIF
146             IF ( mdiag(md,ld).NE.0 ) THEN
147              WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
148         &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
149         &             ' , mate:', hdiag(nd)
150              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
151         &                        SQUEEZE_RIGHT , myThid)
152             ENDIF
153    
154            ENDIF
155           ENDDO
156          ENDDO
157    
158    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
159    C--   Set list of levels to write (if not specified in data.diagnostics)
160    
161          DO ld=1,nlists
162            IF ( nlevels(ld).EQ.-1 ) THEN
163    C-      set Nb of levels to the minimum size of all diag of this list:
164              kLev = numLevels*10
165              DO md=1,nfields(ld)
166                nd = jdiag(md,ld)
167                kLev = MIN(kdiag(nd),kLev)
168              ENDDO
169              IF ( kLev.LE.0 ) THEN
170                WRITE(msgBuf,'(2A,I4,2A)')
171         &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
172         &      ' 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 )
183                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
184              ENDIF
185              nlevels(ld) = kLev
186              DO k=1,kLev
187               levs(k,ld) = k
188              ENDDO
189              WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
190         &      'Set levels for Outp.Stream: ',fnames(ld)
191              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
192         &                        SQUEEZE_RIGHT, myThid)
193              suffix = ' Levels:    '
194              IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
195              DO k1=1,nlevels(ld),20
196                k2 = MIN(nlevels(ld),k1+19)
197                WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
198                CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
199         &                          SQUEEZE_RIGHT, myThid)
200              ENDDO
201            ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
202    C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
203              kLev = 0
204              DO k=1,nlevels(ld)
205                kLev = MAX(NINT(levs(k,ld)),kLev)
206              ENDDO
207              DO md=1,nfields(ld)
208                nd = jdiag(md,ld)
209                IF ( kLev.GT.kdiag(nd) ) THEN
210    C- Note: diagnostics_out take care (in some way) of this case
211    C        so that it does not cause "index out-off bounds" error.
212    C        However, the output file looks strange.
213    C- For now, choose to stop, but could change it to just a warning
214                 WRITE(msgBuf,'(A,I4,A,I6,2A)')
215         &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
216         &         ' in list l=', ld, ', filename: ', fnames(ld)
217                 CALL PRINT_ERROR( msgBuf , myThid )
218                 WRITE(msgBuf,'(2A,I4,A,I6,2A)')
219         &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
220         &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
221                 CALL PRINT_ERROR( msgBuf , myThid )
222                 WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
223         &       ' parsing code >>',gdiag(nd),'<<'
224                 CALL PRINT_ERROR( msgBuf , myThid )
225                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
226                ENDIF
227              ENDDO
228            ENDIF
229          ENDDO
230    
231            WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
232            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
233         &                      SQUEEZE_RIGHT , myThid)
234            WRITE(msgBuf,'(2A)')
235         &   '------------------------------------------------------------'
236            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
237         &                      SQUEEZE_RIGHT , myThid)
238    
239        _END_MASTER( myThid )        _END_MASTER( myThid )
240    
241        RETURN        RETURN
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.13
  ViewVC Help
Powered by ViewVC 1.1.22