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