/[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.7 by jmc, Sun Nov 19 21:59:56 2006 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          CHARACTER*3 mate_index
42    
43    
44        _BEGIN_MASTER( myThid)        _BEGIN_MASTER( myThid)
45    
46  C--   Initialize pointer arrays to zero:  C--   Initialize pointer arrays to zero:
47        DO n=1,ndiagMax        DO ld=1,numlists
48          idiag(n) = 0         DO md=1,numperlist
49            idiag(md,ld) = 0
50            jdiag(md,ld) = 0
51            mdiag(md,ld) = 0
52           ENDDO
53        ENDDO        ENDDO
54    
55  C--   Calculate pointers for diagnostics set to non-zero frequency  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
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)
# Line 114  C        Search all possible model diagn Line 127  C        Search all possible model diagn
127        ENDIF        ENDIF
128    
129  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  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.'   ' ) 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)  C--   Set list of levels to write (if not specified in data.diagnostics)
161    
162        DO n=1,nlists        DO ld=1,nlists
163          IF ( nlevels(n).EQ.-1 ) THEN          IF ( nlevels(ld).EQ.-1 ) THEN
164  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:
165            kLev = numLevels            kLev = numLevels
166            DO m=1,nfields(n)            DO md=1,nfields(ld)
167              mm = jdiag(m,n)              nd = jdiag(md,ld)
168              kLev = MIN(kdiag(mm),kLev)              kLev = MIN(kdiag(nd),kLev)
169            ENDDO            ENDDO
170            IF ( kLev.LE.0 ) THEN            IF ( kLev.LE.0 ) THEN
171              WRITE(msgBuf,'(2A,I4,2A)')              WRITE(msgBuf,'(2A,I4,2A)')
172       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',       &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',
173       &      ' setting levs of list n=',n,', fnames: ', fnames(n)       &      ' setting levs of list l=',ld,', fnames: ', fnames(ld)
174              CALL PRINT_ERROR( msgBuf , myThid )              CALL PRINT_ERROR( msgBuf , myThid )
175              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'              STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
176            ENDIF            ENDIF
177            nlevels(n) = kLev            nlevels(ld) = kLev
178            DO k=1,kLev            DO k=1,kLev
179             levs(k,n) = k             levs(k,ld) = k
180            ENDDO            ENDDO
181            WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',            WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
182       &      'Set levels for Outp.Stream: ',fnames(n)       &      'Set levels for Outp.Stream: ',fnames(ld)
183            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
184       &                        SQUEEZE_RIGHT, myThid)       &                        SQUEEZE_RIGHT, myThid)
185            DO l=1,nlevels(n),20            DO k1=1,nlevels(ld),20
186              m = MIN(nlevels(n),l+19)              k2 = MIN(nlevels(ld),k1+19)
187              WRITE(msgBuf,'(A,20F5.0)')' Levels:    ',(levs(k,n),k=l,m)              WRITE(msgBuf,'(A,20F5.0)')
188         &         ' Levels:    ', (levs(k,ld),k=k1,k2)
189              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,              CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
190       &                          SQUEEZE_RIGHT, myThid)       &                          SQUEEZE_RIGHT, myThid)
191            ENDDO            ENDDO
192          ELSE          ELSE
193  C-      Check for levels out of range ( > kdiag)  C-      Check for levels out of range ( > kdiag)
194            kLev = 0            kLev = 0
195            DO k=1,nlevels(n)            DO k=1,nlevels(ld)
196              kLev = MAX(NINT(levs(k,n)),kLev)              kLev = MAX(NINT(levs(k,ld)),kLev)
197            ENDDO            ENDDO
198            DO m=1,nfields(n)            DO md=1,nfields(ld)
199              mm = jdiag(m,n)              nd = jdiag(md,ld)
200              IF ( kLev.GT.kdiag(mm) ) THEN              IF ( kLev.GT.kdiag(nd) ) THEN
201  C- Note: diagnostics_out take care (in some way) of this case  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.  C        so that it does not cause "index out-off bounds" error.
203  C        However, the output file looks strange.  C        However, the output file looks strange.
204  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
205               WRITE(msgBuf,'(A,I3,A,I3,2A)')               WRITE(msgBuf,'(A,I3,A,I3,2A)')
206       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,       &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
207       &         ' in list n=', n, ', filename: ', fnames(n)       &         ' in list l=', ld, ', filename: ', fnames(ld)
208               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
209               WRITE(msgBuf,'(2A,I3,A,I3,2A)')               WRITE(msgBuf,'(2A,I3,A,I3,2A)')
210       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',       &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
211       &       '(=',kdiag(mm),') for Diag. #', mm, ' : ',cdiag(mm)       &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
212               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
213               WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',               WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
214       &       ' parsing code >>',gdiag(mm),'<<'       &       ' parsing code >>',gdiag(nd),'<<'
215               CALL PRINT_ERROR( msgBuf , myThid )               CALL PRINT_ERROR( msgBuf , myThid )
216               STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'               STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
217              ENDIF              ENDIF
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.7
  ViewVC Help
Powered by ViewVC 1.1.22