/[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.4 by jmc, Mon May 16 15:07:45 2005 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 l, k, 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*12 suffix
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:  C--   Initialize pointer arrays to zero:
119        DO n=1,ndiagMax        DO ld=1,numLists
120          idiag(n) = 0         DO md=1,numperList
121            idiag(md,ld) = 0
122            jdiag(md,ld) = 0
123            mdiag(md,ld) = 0
124           ENDDO
125        ENDDO        ENDDO
126    
127  C--   Calculate pointers for diagnostics set to non-zero frequency  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,'(A,I6,A)')          WRITE(msgBuf,'(A,I8,A)')
164       &    '  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
# Line 114  C        Search all possible model diagn Line 190  C        Search all possible model diagn
190        ENDIF        ENDIF
191    
192  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  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)  C--   Set list of levels to write (if not specified in data.diagnostics)
228    
229        DO n=1,nlists        DO ld=1,nlists
230          IF ( nlevels(n).EQ.-1 ) THEN          IF ( nlevels(ld).EQ.-1 ) THEN
231  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:
232            kLev = numLevels            kLev = numLevels*10
233            DO m=1,nfields(n)            DO md=1,nfields(ld)
234              mm = jdiag(m,n)              nd = jdiag(md,ld)
235              kLev = MIN(kdiag(mm),kLev)              kLev = MIN(kdiag(nd),kLev)
236            ENDDO            ENDDO
237            IF ( kLev.LE.0 ) THEN            IF ( kLev.LE.0 ) THEN
238              WRITE(msgBuf,'(2A,I4,2A)')              WRITE(msgBuf,'(2A,I4,2A)')
239       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
240       &      ' setting levs of list n=',n,', fnames: ', fnames(n)       &      ' 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 )              CALL PRINT_ERROR( msgBuf , myThid )
251              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
252            ENDIF            ENDIF
253            nlevels(n) = kLev            nlevels(ld) = kLev
254            DO k=1,kLev            DO k=1,kLev
255             levs(k,n) = k             levs(k,ld) = k
256            ENDDO            ENDDO
257            WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',            WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
258       &      'Set levels for Outp.Stream: ',fnames(n)       &      'Set levels for Outp.Stream: ',fnames(ld)
259            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
260       &                        SQUEEZE_RIGHT, myThid)       &                        SQUEEZE_RIGHT, myThid)
261            DO l=1,nlevels(n),20            suffix = ' Levels:    '
262              m = MIN(nlevels(n),l+19)            IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
263              WRITE(msgBuf,'(A,20F5.0)')' Levels:    ',(levs(k,n),k=l,m)            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,              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
267       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
268            ENDDO            ENDDO
269          ELSE          ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
270  C-      Check for levels out of range ( > kdiag)  C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
271            kLev = 0            kLev = 0
272            DO k=1,nlevels(n)            DO k=1,nlevels(ld)
273              kLev = MAX(NINT(levs(k,n)),kLev)              kLev = MAX(NINT(levs(k,ld)),kLev)
274            ENDDO            ENDDO
275            DO m=1,nfields(n)            DO md=1,nfields(ld)
276              mm = jdiag(m,n)              nd = jdiag(md,ld)
277              IF ( kLev.GT.kdiag(mm) ) THEN              IF ( kLev.GT.kdiag(nd) ) THEN
278  C- Note: diagnostics_out take care (in some way) of this case  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.  C        so that it does not cause "index out-off bounds" error.
280  C        However, the output file looks strange.  C        However, the output file looks strange.
281  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
282               WRITE(msgBuf,'(A,I3,A,I3,2A)')               WRITE(msgBuf,'(A,I4,A,I6,2A)')
283       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
284       &         ' in list n=', n, ', filename: ', fnames(n)       &         ' in list l=', ld, ', filename: ', fnames(ld)
285               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
286               WRITE(msgBuf,'(2A,I3,A,I3,2A)')               WRITE(msgBuf,'(2A,I4,A,I6,2A)')
287       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
288       &       '(=',kdiag(mm),') for Diag. #', mm, ' : ',cdiag(mm)       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
289               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
290               WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',               WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
291       &       ' parsing code >>',gdiag(mm),'<<'       &       ' parsing code >>',gdiag(nd),'<<'
292               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
293               STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'               STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
294              ENDIF              ENDIF
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.16
  ViewVC Help
Powered by ViewVC 1.1.22