/[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.15 by jmc, Tue Jun 21 18:00:15 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--   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             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'             IF ( ndCount.EQ.0 ) THEN
77           ENDIF               WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
78           IF ( found .AND. mate.GE.1 ) THEN       &                      flds(md,ld),' is not a Diagnostic'
79              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)  
80             ENDIF             ENDIF
81               STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
82           ENDIF           ENDIF
83    
84         ENDDO         ENDDO
85         nActiveMax = MAX(nActive(n),nActiveMax)         nActiveMax = MAX(nActive(ld),nActiveMax)
86        ENDDO        ENDDO
87    
88        IF (  ndiagcount.LE.numdiags .AND.        IF (  ndiagcount.LE.numDiags .AND.
89       &      nActiveMax.LE.numperlist ) THEN       &      nActiveMax.LE.numperList ) THEN
90          WRITE(msgBuf,'(2A,I6,A)')          WRITE(msgBuf,'(A,I8,A)')
91       &    'DIAGNOSTICS_SET_POINTERS: ',       &    '  space allocated for all diagnostics:',
      &    'space allocated for all diagnostics:',  
92       &    ndiagcount, ' levels'       &    ndiagcount, ' levels'
93          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
94       &                    SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid)
95        ELSE        ELSE
96         IF ( ndiagcount.GT.numdiags ) THEN         IF ( ndiagcount.GT.numDiags ) THEN
97           WRITE(msgBuf,'(2A)')           WRITE(msgBuf,'(2A)')
98       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
99       &    ' for all active diagnostics (from data.diagnostics)'       &    ' for all active diagnostics (from data.diagnostics)'
100           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
101           WRITE(msgBuf,'(A,I6,A,I6)')           WRITE(msgBuf,'(A,I8,A,I8)')
102       &    'DIAGNOSTICS_SET_POINTERS: numdiags=', numdiags,       &    'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
103       &    ' but needs at least', ndiagcount       &    ' but needs at least', ndiagcount
104           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
105         ENDIF         ENDIF
106         IF ( nActiveMax.GT.numperlist ) THEN         IF ( nActiveMax.GT.numperList ) THEN
107           WRITE(msgBuf,'(2A)')           WRITE(msgBuf,'(2A)')
108       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
109       &    ' for all active diagnostics (from data.diagnostics)'       &    ' for all active diagnostics (from data.diagnostics)'
110           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
111           WRITE(msgBuf,'(A,I6,A,I6)')           WRITE(msgBuf,'(A,I6,A,I6)')
112       &    'DIAGNOSTICS_SET_POINTERS: numperlist=', numperlist,       &    'DIAGNOSTICS_SET_POINTERS: numperList=', numperList,
113       &    ' but needs at least', nActiveMax       &    ' but needs at least', nActiveMax
114           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
115         ENDIF         ENDIF
116         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
117        ENDIF        ENDIF
118    
119    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
120    C--   Set pointer for mate (e.g.vector component mate) if not already done
121    C     and if it exists. Note: for now, only used to print message.
122          DO ld=1,nlists
123           DO md=1,nActive(ld)
124            IF (mdiag(md,ld).EQ.0 ) THEN
125    
126             nd = jdiag(md,ld)
127             mate = hdiag(nd)
128             IF ( mate.GT.0 ) THEN
129              DO j=1,nlists
130               DO i=1,nActive(j)
131                IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
132                 IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld)
133         &           .AND. averageFreq(j) .EQ.averageFreq(ld)
134         &           .AND. averagePhase(j).EQ.averagePhase(ld)
135         &           .AND. averageCycle(j).EQ.averageCycle(ld) )
136         &          mdiag(md,ld) = ABS(idiag(i,j))
137                ENDIF
138               ENDDO
139              ENDDO
140             ENDIF
141             IF ( mdiag(md,ld).NE.0 ) THEN
142              WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
143         &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
144         &             ' , mate:', hdiag(nd)
145              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
146         &                        SQUEEZE_RIGHT , myThid)
147             ENDIF
148    
149            ENDIF
150           ENDDO
151          ENDDO
152    
153    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
154    C--   Set list of levels to write (if not specified in data.diagnostics)
155    
156          DO ld=1,nlists
157            IF ( nlevels(ld).EQ.-1 ) THEN
158    C-      set Nb of levels to the minimum size of all diag of this list:
159              kLev = numLevels*10
160              DO md=1,nfields(ld)
161                nd = jdiag(md,ld)
162                kLev = MIN(kdiag(nd),kLev)
163              ENDDO
164              IF ( kLev.LE.0 ) THEN
165                WRITE(msgBuf,'(2A,I4,2A)')
166         &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
167         &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
168                CALL PRINT_ERROR( msgBuf , myThid )
169                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
170              ELSEIF ( kLev.GT.numLevels ) THEN
171                WRITE(msgBuf,'(A,2(I6,A))')
172         &      'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
173         &                  ' >', numLevels, ' =numLevels'
174                CALL PRINT_ERROR( msgBuf , myThid )
175                WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: 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              ENDIF
180              nlevels(ld) = kLev
181              DO k=1,kLev
182               levs(k,ld) = k
183              ENDDO
184              WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
185         &      'Set levels for Outp.Stream: ',fnames(ld)
186              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
187         &                        SQUEEZE_RIGHT, myThid)
188              suffix = ' Levels:    '
189              IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
190              DO k1=1,nlevels(ld),20
191                k2 = MIN(nlevels(ld),k1+19)
192                WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
193                CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
194         &                          SQUEEZE_RIGHT, myThid)
195              ENDDO
196            ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
197    C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
198              kLev = 0
199              DO k=1,nlevels(ld)
200                kLev = MAX(NINT(levs(k,ld)),kLev)
201              ENDDO
202              DO md=1,nfields(ld)
203                nd = jdiag(md,ld)
204                IF ( kLev.GT.kdiag(nd) ) THEN
205    C- Note: diagnostics_out take care (in some way) of this case
206    C        so that it does not cause "index out-off bounds" error.
207    C        However, the output file looks strange.
208    C- For now, choose to stop, but could change it to just a warning
209                 WRITE(msgBuf,'(A,I4,A,I6,2A)')
210         &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
211         &         ' in list l=', ld, ', filename: ', fnames(ld)
212                 CALL PRINT_ERROR( msgBuf , myThid )
213                 WRITE(msgBuf,'(2A,I4,A,I6,2A)')
214         &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
215         &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
216                 CALL PRINT_ERROR( msgBuf , myThid )
217                 WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
218         &       ' parsing code >>',gdiag(nd),'<<'
219                 CALL PRINT_ERROR( msgBuf , myThid )
220                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
221                ENDIF
222              ENDDO
223            ENDIF
224          ENDDO
225    
226            WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
227            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
228         &                      SQUEEZE_RIGHT , myThid)
229            WRITE(msgBuf,'(2A)')
230         &   '------------------------------------------------------------'
231            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
232         &                      SQUEEZE_RIGHT , myThid)
233    
234        _END_MASTER( myThid )        _END_MASTER( myThid )
235    
236        RETURN        RETURN
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.15
  ViewVC Help
Powered by ViewVC 1.1.22