/[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.10 by jmc, Tue Feb 5 15:13:01 2008 UTC
# Line 32  CEOP Line 32  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    
 C--   Calculate pointers for diagnostics set to non-zero frequency  
   
42        _BEGIN_MASTER( myThid)        _BEGIN_MASTER( myThid)
43    
44    C--   Initialize pointer arrays to zero:
45          DO ld=1,numlists
46           DO md=1,numperlist
47            idiag(md,ld) = 0
48            jdiag(md,ld) = 0
49            mdiag(md,ld) = 0
50           ENDDO
51          ENDDO
52    
53    C--   Calculate pointers for diagnostics in active output-stream
54    C                                   (i.e., with defined filename)
55    
56        ndiagcount = 0        ndiagcount = 0
57        nActiveMax = 0        nActiveMax = 0
58        DO n=1,nlists        DO ld=1,nlists
59         nActive(n) = nfields(n)         nActive(ld) = nfields(ld)
60         DO m=1,nfields(n)         DO md=1,nfields(ld)
61    
62           found = .FALSE.           found = .FALSE.
63  C        Search all possible model diagnostics  C        Search all possible model diagnostics
64           DO mm=1,ndiagt           DO nd=1,ndiagt
65            IF ( flds(m,n).EQ.cdiag(mm) ) THEN            IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
66              CALL DIAGNOSTICS_SETDIAG (mate,ndiagcount,mm,myThid)              CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
67              found = .TRUE.              found = .TRUE.
68              jdiag(m,n) = mm              jdiag(md,ld) = nd
69            ENDIF            ENDIF
70           ENDDO           ENDDO
71           IF ( .NOT.found ) THEN           IF ( .NOT.found ) THEN
72             WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',             CALL DIAGNOSTICS_LIST_CHECK(
73       &                      flds(m,n),' is not a Diagnostic'       O                      ndCount,
74             CALL PRINT_ERROR( msgBuf , myThid )       I                      ld, md, nfields, flds, myThid )
75               IF ( ndCount.EQ.0 ) THEN
76                 WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
77         &                      flds(md,ld),' is not a Diagnostic'
78                 CALL PRINT_ERROR( msgBuf , myThid )
79               ENDIF
80             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
81           ENDIF           ENDIF
82           IF ( found .AND. mate.GE.1 ) THEN           IF ( found .AND. mate.GE.1 ) THEN
83              nActive(n) = nActive(n) + 1             mm = nActive(ld) + 1
84              IF ( nActive(n).LE.numperlist ) THEN             IF ( mm.LE.numperlist ) THEN
85               jdiag(nActive(n),n) = mate               jdiag(mm,ld) = mate
86               flds( nActive(n),n) = cdiag(mate)               idiag(mm,ld) = mdiag(md,ld)
87                 flds (mm,ld) = cdiag(mate)
88             ENDIF             ENDIF
89               nActive(ld) = mm
90           ENDIF           ENDIF
91    
92         ENDDO         ENDDO
93         nActiveMax = MAX(nActive(n),nActiveMax)         nActiveMax = MAX(nActive(ld),nActiveMax)
94        ENDDO        ENDDO
95    
96        IF (  ndiagcount.LE.numdiags .AND.        IF (  ndiagcount.LE.numDiags .AND.
97       &      nActiveMax.LE.numperlist ) THEN       &      nActiveMax.LE.numperlist ) THEN
98          WRITE(msgBuf,'(2A,I6,A)')          WRITE(msgBuf,'(A,I8,A)')
99       &    'DIAGNOSTICS_SET_POINTERS: ',       &    '  space allocated for all diagnostics:',
      &    'space allocated for all diagnostics:',  
100       &    ndiagcount, ' levels'       &    ndiagcount, ' levels'
101          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
102       &                    SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid)
103        ELSE        ELSE
104         IF ( ndiagcount.GT.numdiags ) THEN         IF ( ndiagcount.GT.numDiags ) THEN
105           WRITE(msgBuf,'(2A)')           WRITE(msgBuf,'(2A)')
106       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',       &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
107       &    ' for all active diagnostics (from data.diagnostics)'       &    ' for all active diagnostics (from data.diagnostics)'
108           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
109           WRITE(msgBuf,'(A,I6,A,I6)')           WRITE(msgBuf,'(A,I8,A,I8)')
110       &    'DIAGNOSTICS_SET_POINTERS: numdiags=', numdiags,       &    'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
111       &    ' but needs at least', ndiagcount       &    ' but needs at least', ndiagcount
112           CALL PRINT_ERROR( msgBuf , myThid )           CALL PRINT_ERROR( msgBuf , myThid )
113         ENDIF         ENDIF
# Line 107  C        Search all possible model diagn Line 124  C        Search all possible model diagn
124         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
125        ENDIF        ENDIF
126    
127    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
128    C--   Set pointer for mate (e.g.vector component mate) if not already done
129    C     and if it exists. Note: for now, only used to print message.
130          DO ld=1,nlists
131           DO md=1,nActive(ld)
132            IF (mdiag(md,ld).EQ.0 ) THEN
133    
134             nd = jdiag(md,ld)
135             mate = hdiag(nd)
136             IF ( mate.GT.0 ) THEN
137              DO j=1,nlists
138               DO i=1,nActive(j)
139                IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
140                  mdiag(md,ld) = ABS(idiag(i,j))
141                ENDIF
142               ENDDO
143              ENDDO
144             ENDIF
145             IF ( mdiag(md,ld).NE.0 ) THEN
146              WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
147         &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
148         &             ' , mate:', hdiag(nd)
149              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
150         &                        SQUEEZE_RIGHT , myThid)
151             ENDIF
152    
153            ENDIF
154           ENDDO
155          ENDDO
156    
157    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
158    C--   Set list of levels to write (if not specified in data.diagnostics)
159    
160          DO ld=1,nlists
161            IF ( nlevels(ld).EQ.-1 ) THEN
162    C-      set Nb of levels to the minimum size of all diag of this list:
163              kLev = numLevels
164              DO md=1,nfields(ld)
165                nd = jdiag(md,ld)
166                kLev = MIN(kdiag(nd),kLev)
167              ENDDO
168              IF ( kLev.LE.0 ) THEN
169                WRITE(msgBuf,'(2A,I6,2A)')
170         &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',
171         &      ' setting levs of list l=',ld,', fnames: ', fnames(ld)
172                CALL PRINT_ERROR( msgBuf , myThid )
173                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
174              ENDIF
175              nlevels(ld) = kLev
176              DO k=1,kLev
177               levs(k,ld) = k
178              ENDDO
179              WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
180         &      'Set levels for Outp.Stream: ',fnames(ld)
181              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
182         &                        SQUEEZE_RIGHT, myThid)
183              DO k1=1,nlevels(ld),20
184                k2 = MIN(nlevels(ld),k1+19)
185                WRITE(msgBuf,'(A,20F5.0)')
186         &         ' Levels:    ', (levs(k,ld),k=k1,k2)
187                CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
188         &                          SQUEEZE_RIGHT, myThid)
189              ENDDO
190            ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
191    C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
192              kLev = 0
193              DO k=1,nlevels(ld)
194                kLev = MAX(NINT(levs(k,ld)),kLev)
195              ENDDO
196              DO md=1,nfields(ld)
197                nd = jdiag(md,ld)
198                IF ( kLev.GT.kdiag(nd) ) THEN
199    C- Note: diagnostics_out take care (in some way) of this case
200    C        so that it does not cause "index out-off bounds" error.
201    C        However, the output file looks strange.
202    C- For now, choose to stop, but could change it to just a warning
203                 WRITE(msgBuf,'(A,I4,A,I6,2A)')
204         &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
205         &         ' in list l=', ld, ', filename: ', fnames(ld)
206                 CALL PRINT_ERROR( msgBuf , myThid )
207                 WRITE(msgBuf,'(2A,I4,A,I6,2A)')
208         &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
209         &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
210                 CALL PRINT_ERROR( msgBuf , myThid )
211                 WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
212         &       ' parsing code >>',gdiag(nd),'<<'
213                 CALL PRINT_ERROR( msgBuf , myThid )
214                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
215                ENDIF
216              ENDDO
217            ENDIF
218          ENDDO
219    
220            WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
221            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
222         &                      SQUEEZE_RIGHT , myThid)
223            WRITE(msgBuf,'(2A)')
224         &   '------------------------------------------------------------'
225            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
226         &                      SQUEEZE_RIGHT , myThid)
227    
228        _END_MASTER( myThid )        _END_MASTER( myThid )
229    
230        RETURN        RETURN
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.10
  ViewVC Help
Powered by ViewVC 1.1.22