/[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.1 by jmc, Mon Dec 13 21:43:54 2004 UTC revision 1.16 by jmc, Fri Jul 1 18:52:18 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, 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---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
46    
47    C--   In case an output file contains 2 post-processed diags which are computed
48    C     together (mate of 2nd PP-diag one is 1rst PP-diag), move these 2 diags
49    C     next to each other (to only computate them once): 1rst one then 2nd one.
50          DO ld=1,nlists
51           found = .FALSE.
52           DO md=1,nfields(ld)
53    C        Search all possible model diagnostics
54             nd = 0
55             DO i=1,ndiagt
56              IF ( nd.EQ.0 .AND. flds(md,ld).EQ.cdiag(i) ) nd = i
57             ENDDO
58             j  = 0
59             IF ( nd.GE.1 ) THEN
60               IF ( gdiag(nd)(5:5).EQ.'P' ) THEN
61                 mate = hdiag(nd)
62                 IF ( gdiag(mate)(5:5).EQ.'P' ) THEN
63    C        Mate of Post-Processed diag "nd" is also Post-Processed
64                   DO i=1,nfields(ld)
65                     IF ( j.EQ.0 .AND. flds(i,ld).EQ.cdiag(mate) ) j = i
66                   ENDDO
67                 ENDIF
68               ENDIF
69             ENDIF
70    C        And is found in the same output stream "ld" (at rank "j")
71             IF ( j.GE.1 .AND. j.NE.md-1 ) THEN
72               IF ( .NOT.found ) THEN
73                 WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
74         &             'Re-Order Diags in Outp.Stream: ',fnames(ld)
75                 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
76         &                           SQUEEZE_RIGHT, myThid )
77               ENDIF
78               found  = .TRUE.
79               IF ( j.LT.md-1 ) THEN
80                 WRITE(msgBuf,'(2A,2(A,I4),2A)')
81         &         ' move ',flds(j,ld),' from ',j,' down to',md-1,
82         &         ' just before ',flds(md,ld)
83                 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
84         &                           SQUEEZE_RIGHT, myThid )
85                 DO i=j,md-2
86                   flds(i,ld) = flds(i+1,ld)
87                 ENDDO
88                 flds(md-1,ld) = cdiag(mate)
89               ELSEIF ( j.GT.md ) THEN
90                 WRITE(msgBuf,'(2A,2(A,I4),2A)')
91         &         ' move ',flds(j,ld),' from ',j,'  up to ',md,
92         &         ' just before ',flds(md,ld)
93                 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
94         &                           SQUEEZE_RIGHT, myThid )
95                 DO i=j,md+1,-1
96                   flds(i,ld) = flds(i-1,ld)
97                 ENDDO
98                 flds(md,ld) = cdiag(mate)
99               ENDIF
100             ENDIF
101           ENDDO
102           IF ( found ) THEN
103             WRITE(msgBuf,'(2A,I4,A)') 'DIAGNOSTICS_SET_POINTERS: ',
104         &             'Updated list in Outp.Stream #', ld, ' :'
105             CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
106         &                       SQUEEZE_RIGHT, myThid )
107             DO md = 1,nfields(ld),10
108               j = MIN(nfields(ld),md+9)
109               WRITE(msgBuf,'(21A)') ' Fields:   ',(' ',flds(i,ld),i=md,j)
110               CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
111         &                         SQUEEZE_RIGHT, myThid )
112             ENDDO
113           ENDIF
114          ENDDO
115    
116    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
117    
118    C--   Initialize pointer arrays to zero:
119          DO ld=1,numLists
120           DO md=1,numperList
121            idiag(md,ld) = 0
122            jdiag(md,ld) = 0
123            mdiag(md,ld) = 0
124           ENDDO
125          ENDDO
126    
127    C--   Calculate pointers for diagnostics in active output-stream
128    C                                   (i.e., with defined filename)
129    
130        ndiagcount = 0        ndiagcount = 0
131        nActiveMax = 0        nActiveMax = 0
132        DO n=1,nlists        DO ld=1,nlists
133         nActive(n) = nfields(n)         nActive(ld) = nfields(ld)
134         DO m=1,nfields(n)         DO md=1,nfields(ld)
135    
136           found = .FALSE.           found = .FALSE.
137  C        Search all possible model diagnostics  C        Search all possible model diagnostics
138           DO mm=1,ndiagt           DO nd=1,ndiagt
139            IF ( flds(m,n).EQ.cdiag(mm) ) THEN            IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
140              CALL DIAGNOSTICS_SETDIAG (mate,ndiagcount,mm,myThid)              CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
141              found = .TRUE.              found = .TRUE.
142              jdiag(m,n) = mm              jdiag(md,ld) = nd
143            ENDIF            ENDIF
144           ENDDO           ENDDO
145           IF ( .NOT.found ) THEN           IF ( .NOT.found ) THEN
146             WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',             CALL DIAGNOSTICS_LIST_CHECK(
147       &                      flds(m,n),' is not a Diagnostic'       O                      ndCount,
148             CALL PRINT_ERROR( msgBuf , myThid )       I                      ld, md, nlists, nfields, flds, myThid )
149             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'             IF ( ndCount.EQ.0 ) THEN
150           ENDIF               WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
151           IF ( found .AND. mate.GE.1 ) THEN       &                      flds(md,ld),' is not a Diagnostic'
152              nActive(n) = nActive(n) + 1               CALL PRINT_ERROR( msgBuf , myThid )
             IF ( nActive(n).LE.numperlist ) THEN  
              jdiag(nActive(n),n) = mate  
              flds( nActive(n),n) = cdiag(mate)  
153             ENDIF             ENDIF
154               STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
155           ENDIF           ENDIF
156    
157         ENDDO         ENDDO
158         nActiveMax = MAX(nActive(n),nActiveMax)         nActiveMax = MAX(nActive(ld),nActiveMax)
159        ENDDO        ENDDO
160    
161        IF (  ndiagcount.LE.numdiags .AND.        IF (  ndiagcount.LE.numDiags .AND.
162       &      nActiveMax.LE.numperlist ) THEN       &      nActiveMax.LE.numperList ) THEN
163          WRITE(msgBuf,'(2A,I6,A)')          WRITE(msgBuf,'(A,I8,A)')
164       &    'DIAGNOSTICS_SET_POINTERS: ',       &    '  space allocated for all diagnostics:',
      &    'space allocated for all diagnostics:',  
165       &    ndiagcount, ' levels'       &    ndiagcount, ' levels'
166          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
167       &                    SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT, myThid )
168        ELSE        ELSE
169         IF ( ndiagcount.GT.numdiags ) THEN         IF ( ndiagcount.GT.numDiags ) THEN
170           WRITE(msgBuf,'(2A)')           WRITE(msgBuf,'(2A)')
171       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
172       &    ' for all active diagnostics (from data.diagnostics)'       &    ' for all active diagnostics (from data.diagnostics)'
173           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
174           WRITE(msgBuf,'(A,I6,A,I6)')           WRITE(msgBuf,'(A,I8,A,I8)')
175       &    'DIAGNOSTICS_SET_POINTERS: numdiags=', numdiags,       &    'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
176       &    ' but needs at least', ndiagcount       &    ' but needs at least', ndiagcount
177           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
178         ENDIF         ENDIF
179         IF ( nActiveMax.GT.numperlist ) THEN         IF ( nActiveMax.GT.numperList ) THEN
180           WRITE(msgBuf,'(2A)')           WRITE(msgBuf,'(2A)')
181       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
182       &    ' for all active diagnostics (from data.diagnostics)'       &    ' for all active diagnostics (from data.diagnostics)'
183           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
184           WRITE(msgBuf,'(A,I6,A,I6)')           WRITE(msgBuf,'(A,I6,A,I6)')
185       &    'DIAGNOSTICS_SET_POINTERS: numperlist=', numperlist,       &    'DIAGNOSTICS_SET_POINTERS: numperList=', numperList,
186       &    ' but needs at least', nActiveMax       &    ' but needs at least', nActiveMax
187           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
188         ENDIF         ENDIF
189         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
190        ENDIF        ENDIF
191    
192    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
193    C--   Set pointer for mate (e.g.vector component mate) if not already done
194    C     and if it exists. Note: for now, only used to print message.
195          DO ld=1,nlists
196           DO md=1,nActive(ld)
197            IF (mdiag(md,ld).EQ.0 ) THEN
198    
199             nd = jdiag(md,ld)
200             mate = hdiag(nd)
201             IF ( mate.GT.0 ) THEN
202              DO j=1,nlists
203               DO i=1,nActive(j)
204                IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
205                 IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld)
206         &           .AND. averageFreq(j) .EQ.averageFreq(ld)
207         &           .AND. averagePhase(j).EQ.averagePhase(ld)
208         &           .AND. averageCycle(j).EQ.averageCycle(ld) )
209         &          mdiag(md,ld) = ABS(idiag(i,j))
210                ENDIF
211               ENDDO
212              ENDDO
213             ENDIF
214             IF ( mdiag(md,ld).NE.0 ) THEN
215              WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
216         &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
217         &             ' , mate:', hdiag(nd)
218              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
219         &                        SQUEEZE_RIGHT, myThid )
220             ENDIF
221    
222            ENDIF
223           ENDDO
224          ENDDO
225    
226    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
227    C--   Set list of levels to write (if not specified in data.diagnostics)
228    
229          DO ld=1,nlists
230            IF ( nlevels(ld).EQ.-1 ) THEN
231    C-      set Nb of levels to the minimum size of all diag of this list:
232              kLev = numLevels*10
233              DO md=1,nfields(ld)
234                nd = jdiag(md,ld)
235                kLev = MIN(kdiag(nd),kLev)
236              ENDDO
237              IF ( kLev.LE.0 ) THEN
238                WRITE(msgBuf,'(2A,I4,2A)')
239         &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
240         &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
241                CALL PRINT_ERROR( msgBuf , myThid )
242                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
243              ELSEIF ( kLev.GT.numLevels ) THEN
244                WRITE(msgBuf,'(A,2(I6,A))')
245         &      'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
246         &                  ' >', numLevels, ' =numLevels'
247                CALL PRINT_ERROR( msgBuf , myThid )
248                WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
249         &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
250                CALL PRINT_ERROR( msgBuf , myThid )
251                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
252              ENDIF
253              nlevels(ld) = kLev
254              DO k=1,kLev
255               levs(k,ld) = k
256              ENDDO
257              WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
258         &      'Set levels for Outp.Stream: ',fnames(ld)
259              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
260         &                        SQUEEZE_RIGHT, myThid)
261              suffix = ' Levels:    '
262              IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
263              DO k1=1,nlevels(ld),20
264                k2 = MIN(nlevels(ld),k1+19)
265                WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
266                CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
267         &                          SQUEEZE_RIGHT, myThid)
268              ENDDO
269            ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
270    C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
271              kLev = 0
272              DO k=1,nlevels(ld)
273                kLev = MAX(NINT(levs(k,ld)),kLev)
274              ENDDO
275              DO md=1,nfields(ld)
276                nd = jdiag(md,ld)
277                IF ( kLev.GT.kdiag(nd) ) THEN
278    C- Note: diagnostics_out take care (in some way) of this case
279    C        so that it does not cause "index out-off bounds" error.
280    C        However, the output file looks strange.
281    C- For now, choose to stop, but could change it to just a warning
282                 WRITE(msgBuf,'(A,I4,A,I6,2A)')
283         &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
284         &         ' in list l=', ld, ', filename: ', fnames(ld)
285                 CALL PRINT_ERROR( msgBuf , myThid )
286                 WRITE(msgBuf,'(2A,I4,A,I6,2A)')
287         &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
288         &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
289                 CALL PRINT_ERROR( msgBuf , myThid )
290                 WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
291         &       ' parsing code >>',gdiag(nd),'<<'
292                 CALL PRINT_ERROR( msgBuf , myThid )
293                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
294                ENDIF
295              ENDDO
296            ENDIF
297          ENDDO
298    
299            WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
300            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
301         &                      SQUEEZE_RIGHT , myThid)
302            WRITE(msgBuf,'(2A)')
303         &   '------------------------------------------------------------'
304            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
305         &                      SQUEEZE_RIGHT , myThid)
306    
307        _END_MASTER( myThid )        _END_MASTER( myThid )
308    
309        RETURN        RETURN
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.16
  ViewVC Help
Powered by ViewVC 1.1.22