/[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.9 by jahn, Tue Jan 29 00:35:31 2008 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    
# Line 35  C     == Local variables == Line 35  C     == Local variables ==
35        INTEGER ndiagcount, ndCount        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---+----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 ld=1,numlists        DO ld=1,numLists
120         DO md=1,numperlist         DO md=1,numperList
121          idiag(md,ld) = 0          idiag(md,ld) = 0
122          jdiag(md,ld) = 0          jdiag(md,ld) = 0
123          mdiag(md,ld) = 0          mdiag(md,ld) = 0
# Line 73  C        Search all possible model diagn Line 145  C        Search all possible model diagn
145           IF ( .NOT.found ) THEN           IF ( .NOT.found ) THEN
146             CALL DIAGNOSTICS_LIST_CHECK(             CALL DIAGNOSTICS_LIST_CHECK(
147       O                      ndCount,       O                      ndCount,
148       I                      ld, md, nfields, flds, myThid )       I                      ld, md, nlists, nfields, flds, myThid )
149             IF ( ndCount.EQ.0 ) THEN             IF ( ndCount.EQ.0 ) THEN
150               WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',               WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
151       &                      flds(md,ld),' is not a Diagnostic'       &                      flds(md,ld),' is not a Diagnostic'
# Line 81  C        Search all possible model diagn Line 153  C        Search all possible model diagn
153             ENDIF             ENDIF
154             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
155           ENDIF           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)  
            ENDIF  
            nActive(ld) = mm  
          ENDIF  
156    
157         ENDDO         ENDDO
158         nActiveMax = MAX(nActive(ld),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 134  C     and if it exists. Note: for now, o Line 197  C     and if it exists. Note: for now, o
197          IF (mdiag(md,ld).EQ.0 ) THEN          IF (mdiag(md,ld).EQ.0 ) THEN
198    
199           nd = jdiag(md,ld)           nd = jdiag(md,ld)
200           mate_index = gdiag(nd)(6:8)           mate = hdiag(nd)
201           IF ( mate_index.NE.'   ' .AND. mate_index.NE.'***' ) THEN           IF ( mate.GT.0 ) THEN
           READ(mate_index,'(I3)') mate  
202            DO j=1,nlists            DO j=1,nlists
203             DO i=1,nActive(j)             DO i=1,nActive(j)
204              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
205                mdiag(md,ld) = ABS(idiag(i,j))               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              ENDIF
211             ENDDO             ENDDO
212            ENDDO            ENDDO
213           ENDIF           ENDIF
214           IF ( mdiag(md,ld).NE.0 ) THEN           IF ( mdiag(md,ld).NE.0 ) THEN
215            WRITE(msgBuf,'(A,I4,4A)') '  set mate pointer for diag #',            WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
216       &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)       &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
217         &             ' , mate:', hdiag(nd)
218            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
219       &                        SQUEEZE_RIGHT , myThid)       &                        SQUEEZE_RIGHT, myThid )
220           ENDIF           ENDIF
221    
222          ENDIF          ENDIF
# Line 162  C--   Set list of levels to write (if no Line 229  C--   Set list of levels to write (if no
229        DO ld=1,nlists        DO ld=1,nlists
230          IF ( nlevels(ld).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 md=1,nfields(ld)            DO md=1,nfields(ld)
234              nd = jdiag(md,ld)              nd = jdiag(md,ld)
235              kLev = MIN(kdiag(nd),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 l=',ld,', fnames: ', fnames(ld)       &      ' 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
# Line 182  C-      set Nb of levels to the minimum Line 258  C-      set Nb of levels to the minimum
258       &      'Set levels for Outp.Stream: ',fnames(ld)       &      '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              suffix = ' Levels:    '
262              IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
263            DO k1=1,nlevels(ld),20            DO k1=1,nlevels(ld),20
264              k2 = MIN(nlevels(ld),k1+19)              k2 = MIN(nlevels(ld),k1+19)
265              WRITE(msgBuf,'(A,20F5.0)')              WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
      &         ' Levels:    ', (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
# Line 202  C- Note: diagnostics_out take care (in s Line 279  C- Note: diagnostics_out take care (in s
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 l=', ld, ', filename: ', fnames(ld)       &         ' 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(nd),') for Diag. #', nd, ' : ',cdiag(nd)       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
289               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.16
  ViewVC Help
Powered by ViewVC 1.1.22