/[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.6 by jmc, Mon Jun 5 18:05:48 2006 UTC
# Line 33  CEOP Line 33  CEOP
33  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
34  C     == Local variables ==  C     == Local variables ==
35        INTEGER ndiagcount        INTEGER ndiagcount
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: ',             WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
75       &                      flds(m,n),' is not a Diagnostic'       &                      flds(md,ld),' is not a Diagnostic'
76             CALL PRINT_ERROR( msgBuf , myThid )             CALL PRINT_ERROR( msgBuf , myThid )
77             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
78           ENDIF           ENDIF
79           IF ( found .AND. mate.GE.1 ) THEN           IF ( found .AND. mate.GE.1 ) THEN
80              nActive(n) = nActive(n) + 1             mm = nActive(ld) + 1
81              IF ( nActive(n).LE.numperlist ) THEN             IF ( mm.LE.numperlist ) THEN
82               jdiag(nActive(n),n) = mate               jdiag(mm,ld) = mate
83               flds( nActive(n),n) = cdiag(mate)               idiag(mm,ld) = mdiag(md,ld)
84                 flds (mm,ld) = cdiag(mate)
85             ENDIF             ENDIF
86               nActive(ld) = mm
87           ENDIF           ENDIF
88    
89         ENDDO         ENDDO
90         nActiveMax = MAX(nActive(n),nActiveMax)         nActiveMax = MAX(nActive(ld),nActiveMax)
91        ENDDO        ENDDO
92    
93        IF (  ndiagcount.LE.numdiags .AND.        IF (  ndiagcount.LE.numdiags .AND.
94       &      nActiveMax.LE.numperlist ) THEN       &      nActiveMax.LE.numperlist ) THEN
95          WRITE(msgBuf,'(2A,I6,A)')          WRITE(msgBuf,'(A,I6,A)')
96       &    'DIAGNOSTICS_SET_POINTERS: ',       &    '  space allocated for all diagnostics:',
      &    'space allocated for all diagnostics:',  
97       &    ndiagcount, ' levels'       &    ndiagcount, ' levels'
98          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
99       &                    SQUEEZE_RIGHT , myThid)       &                      SQUEEZE_RIGHT , myThid)
100        ELSE        ELSE
101         IF ( ndiagcount.GT.numdiags ) THEN         IF ( ndiagcount.GT.numdiags ) THEN
102           WRITE(msgBuf,'(2A)')           WRITE(msgBuf,'(2A)')
# Line 107  C        Search all possible model diagn Line 121  C        Search all possible model diagn
121         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'         STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
122        ENDIF        ENDIF
123    
124    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
125    C--   Set pointer for mate (e.g.vector component mate) if not already done
126    C     and if it exists. Note: for now, only used to print message.
127          DO ld=1,nlists
128           DO md=1,nActive(ld)
129            IF (mdiag(md,ld).EQ.0 ) THEN
130    
131             nd = jdiag(md,ld)
132             mate_index = gdiag(nd)(6:8)
133             IF ( mate_index.NE.'   ' ) THEN
134              READ(mate_index,'(I3)') mate
135              DO j=1,nlists
136               DO i=1,nActive(j)
137                IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
138                  mdiag(md,ld) = ABS(idiag(i,j))
139                ENDIF
140               ENDDO
141              ENDDO
142             ENDIF
143             IF ( mdiag(md,ld).NE.0 ) THEN
144              WRITE(msgBuf,'(A,I4,4A)') '  set mate pointer for diag #',
145         &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)
146              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
147         &                        SQUEEZE_RIGHT , myThid)
148             ENDIF
149    
150            ENDIF
151           ENDDO
152          ENDDO
153    
154    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
155    C--   Set list of levels to write (if not specified in data.diagnostics)
156    
157          DO ld=1,nlists
158            IF ( nlevels(ld).EQ.-1 ) THEN
159    C-      set Nb of levels to the minimum size of all diag of this list:
160              kLev = numLevels
161              DO md=1,nfields(ld)
162                nd = jdiag(md,ld)
163                kLev = MIN(kdiag(nd),kLev)
164              ENDDO
165              IF ( kLev.LE.0 ) THEN
166                WRITE(msgBuf,'(2A,I4,2A)')
167         &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',
168         &      ' setting levs of list l=',ld,', fnames: ', fnames(ld)
169                CALL PRINT_ERROR( msgBuf , myThid )
170                STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
171              ENDIF
172              nlevels(ld) = kLev
173              DO k=1,kLev
174               levs(k,ld) = k
175              ENDDO
176              WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
177         &      'Set levels for Outp.Stream: ',fnames(ld)
178              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
179         &                        SQUEEZE_RIGHT, myThid)
180              DO k1=1,nlevels(ld),20
181                k2 = MIN(nlevels(ld),k1+19)
182                WRITE(msgBuf,'(A,20F5.0)')
183         &         ' Levels:    ', (levs(k,ld),k=k1,k2)
184                CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
185         &                          SQUEEZE_RIGHT, myThid)
186              ENDDO
187            ELSE
188    C-      Check for levels out of range ( > kdiag)
189              kLev = 0
190              DO k=1,nlevels(ld)
191                kLev = MAX(NINT(levs(k,ld)),kLev)
192              ENDDO
193              DO md=1,nfields(ld)
194                nd = jdiag(md,ld)
195                IF ( kLev.GT.kdiag(nd) ) THEN
196    C- Note: diagnostics_out take care (in some way) of this case
197    C        so that it does not cause "index out-off bounds" error.
198    C        However, the output file looks strange.
199    C- For now, choose to stop, but could change it to just a warning
200                 WRITE(msgBuf,'(A,I3,A,I3,2A)')
201         &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
202         &         ' in list l=', ld, ', filename: ', fnames(ld)
203                 CALL PRINT_ERROR( msgBuf , myThid )
204                 WRITE(msgBuf,'(2A,I3,A,I3,2A)')
205         &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
206         &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
207                 CALL PRINT_ERROR( msgBuf , myThid )
208                 WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
209         &       ' parsing code >>',gdiag(nd),'<<'
210                 CALL PRINT_ERROR( msgBuf , myThid )
211                 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
212                ENDIF
213              ENDDO
214            ENDIF
215          ENDDO
216    
217            WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
218            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
219         &                      SQUEEZE_RIGHT , myThid)
220            WRITE(msgBuf,'(2A)')
221         &   '------------------------------------------------------------'
222            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
223         &                      SQUEEZE_RIGHT , myThid)
224    
225        _END_MASTER( myThid )        _END_MASTER( myThid )
226    
227        RETURN        RETURN
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6
  ViewVC Help
Powered by ViewVC 1.1.22