/[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.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 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                 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
147               ENDDO
148              ENDDO
149             ENDIF
150             IF ( mdiag(md,ld).NE.0 ) THEN
151              WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
152         &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
153         &             ' , mate:', hdiag(nd)
154              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
155         &                        SQUEEZE_RIGHT , myThid)
156             ENDIF
157    
158            ENDIF
159           ENDDO
160          ENDDO
161    
162    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
163    C--   Set list of levels to write (if not specified in data.diagnostics)
164    
165          DO ld=1,nlists
166            IF ( nlevels(ld).EQ.-1 ) THEN
167    C-      set Nb of levels to the minimum size of all diag of this list:
168              kLev = numLevels*10
169              DO md=1,nfields(ld)
170                nd = jdiag(md,ld)
171                kLev = MIN(kdiag(nd),kLev)
172              ENDDO
173              IF ( kLev.LE.0 ) THEN
174                WRITE(msgBuf,'(2A,I4,2A)')
175         &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
176         &      ' 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 )
187                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
188              ENDIF
189              nlevels(ld) = kLev
190              DO k=1,kLev
191               levs(k,ld) = k
192              ENDDO
193              WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
194         &      'Set levels for Outp.Stream: ',fnames(ld)
195              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
196         &                        SQUEEZE_RIGHT, myThid)
197              suffix = ' Levels:    '
198              IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
199              DO k1=1,nlevels(ld),20
200                k2 = MIN(nlevels(ld),k1+19)
201                WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
202                CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
203         &                          SQUEEZE_RIGHT, myThid)
204              ENDDO
205            ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
206    C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
207              kLev = 0
208              DO k=1,nlevels(ld)
209                kLev = MAX(NINT(levs(k,ld)),kLev)
210              ENDDO
211              DO md=1,nfields(ld)
212                nd = jdiag(md,ld)
213                IF ( kLev.GT.kdiag(nd) ) THEN
214    C- Note: diagnostics_out take care (in some way) of this case
215    C        so that it does not cause "index out-off bounds" error.
216    C        However, the output file looks strange.
217    C- For now, choose to stop, but could change it to just a warning
218                 WRITE(msgBuf,'(A,I4,A,I6,2A)')
219         &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
220         &         ' in list l=', ld, ', filename: ', fnames(ld)
221                 CALL PRINT_ERROR( msgBuf , myThid )
222                 WRITE(msgBuf,'(2A,I4,A,I6,2A)')
223         &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
224         &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
225                 CALL PRINT_ERROR( msgBuf , myThid )
226                 WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
227         &       ' parsing code >>',gdiag(nd),'<<'
228                 CALL PRINT_ERROR( msgBuf , myThid )
229                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
230                ENDIF
231              ENDDO
232            ENDIF
233          ENDDO
234    
235            WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
236            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
237         &                      SQUEEZE_RIGHT , myThid)
238            WRITE(msgBuf,'(2A)')
239         &   '------------------------------------------------------------'
240            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
241         &                      SQUEEZE_RIGHT , myThid)
242    
243        _END_MASTER( myThid )        _END_MASTER( myThid )
244    
245        RETURN        RETURN
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22