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