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