/[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.3 by jmc, Mon Dec 20 01:52:58 2004 UTC revision 1.11 by dfer, Thu Oct 30 18:52:54 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 l, k, kLev        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, nlists, 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,'(A,I6,A)')          WRITE(msgBuf,'(A,I8,A)')
99       &    '  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 108  C        Search all possible model diagn Line 125  C        Search all possible model diagn
125        ENDIF        ENDIF
126    
127  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  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)  C--   Set list of levels to write (if not specified in data.diagnostics)
159    
160        DO n=1,nlists        DO ld=1,nlists
161          IF ( nlevels(n).EQ.-1 ) THEN          IF ( nlevels(ld).EQ.-1 ) THEN
162  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:
163            kLev = numLevels            kLev = numLevels
164            DO m=1,nfields(n)            DO md=1,nfields(ld)
165              mm = jdiag(m,n)              nd = jdiag(md,ld)
166              kLev = MIN(kdiag(mm),kLev)              kLev = MIN(kdiag(nd),kLev)
167            ENDDO            ENDDO
168            IF ( kLev.LE.0 ) THEN            IF ( kLev.LE.0 ) THEN
169              WRITE(msgBuf,'(2A,I4,2A)')              WRITE(msgBuf,'(2A,I6,2A)')
170       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',
171       &      ' setting levs of list n=',n,', fnames: ', fnames(n)       &      ' setting levs of list l=',ld,', fnames: ', fnames(ld)
172              CALL PRINT_ERROR( msgBuf , myThid )              CALL PRINT_ERROR( msgBuf , myThid )
173              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
174            ENDIF            ENDIF
175            nlevels(n) = kLev            nlevels(ld) = kLev
176            DO k=1,kLev            DO k=1,kLev
177             levs(k,n) = k             levs(k,ld) = k
178            ENDDO            ENDDO
179            WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',            WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
180       &      'Set levels for Outp.Stream: ',fnames(n)       &      'Set levels for Outp.Stream: ',fnames(ld)
181            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
182       &                        SQUEEZE_RIGHT, myThid)       &                        SQUEEZE_RIGHT, myThid)
183            DO l=1,nlevels(n),20            DO k1=1,nlevels(ld),20
184              m = MIN(nlevels(n),l+19)              k2 = MIN(nlevels(ld),k1+19)
185              WRITE(msgBuf,'(A,20F5.0)')' Levels:    ',(levs(k,n),k=l,m)              WRITE(msgBuf,'(A,20F5.0)')
186         &         ' Levels:    ', (levs(k,ld),k=k1,k2)
187              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
188       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
189            ENDDO            ENDDO
190          ELSE          ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
191  C-      Check for levels out of range ( > kdiag)  C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
192            kLev = 0            kLev = 0
193            DO k=1,nlevels(n)            DO k=1,nlevels(ld)
194              kLev = MAX(NINT(levs(k,n)),kLev)              kLev = MAX(NINT(levs(k,ld)),kLev)
195            ENDDO            ENDDO
196            DO m=1,nfields(n)            DO md=1,nfields(ld)
197              mm = jdiag(m,n)              nd = jdiag(md,ld)
198              IF ( kLev.GT.kdiag(mm) ) THEN              IF ( kLev.GT.kdiag(nd) ) THEN
199  C- Note: diagnostics_out take care (in some way) of this case  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.  C        so that it does not cause "index out-off bounds" error.
201  C        However, the output file looks strange.  C        However, the output file looks strange.
202  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
203               WRITE(msgBuf,'(A,I3,A,I3,2A)')               WRITE(msgBuf,'(A,I4,A,I6,2A)')
204       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
205       &         ' in list n=', n, ', filename: ', fnames(n)       &         ' in list l=', ld, ', filename: ', fnames(ld)
206               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
207               WRITE(msgBuf,'(2A,I3,A,I3,2A)')               WRITE(msgBuf,'(2A,I4,A,I6,2A)')
208       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
209       &       '(=',kdiag(mm),') for Diag. #', mm, ' : ',cdiag(mm)       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
210               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
211               WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',               WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
212       &       ' parsing code >>',gdiag(mm),'<<'       &       ' parsing code >>',gdiag(nd),'<<'
213               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
214               STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'               STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
215              ENDIF              ENDIF
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.11
  ViewVC Help
Powered by ViewVC 1.1.22