pkg/diagnostics/diagnostics_set_pointers.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.13 2010/01/11 19:44:07 jmc Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

CBOP
C     !ROUTINE: DIAGNOSTICS_SET_POINTERS
C     !INTERFACE:
      SUBROUTINE DIAGNOSTICS_SET_POINTERS( myThid )

C     !DESCRIPTION: \bv
C     *==================================================================
C     | S/R DIAGNOSTICS_SET_POINTERS
C     | o set pointers for active diagnostics
C     *==================================================================
C     \ev

C     !USES:
      IMPLICIT NONE

C     == Global variables ===
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"

C     !INPUT/OUTPUT PARAMETERS:
C     == Routine arguments ==
C     myThid :: my Thread Id. number
      INTEGER myThid
CEOP

C     !LOCAL VARIABLES:
C     == Local variables ==
      INTEGER ndiagcount, ndCount
      INTEGER md,ld,nd
      INTEGER mate, nActiveMax
      INTEGER i, j, k, k1, k2, mm, kLev
      LOGICAL found
      CHARACTER*(MAX_LEN_MBUF) msgBuf
      CHARACTER*12 suffix

      _BEGIN_MASTER( myThid)

C--   Initialize pointer arrays to zero:
      DO ld=1,numlists
       DO md=1,numperlist
        idiag(md,ld) = 0
        jdiag(md,ld) = 0
        mdiag(md,ld) = 0
       ENDDO
      ENDDO

C--   Calculate pointers for diagnostics in active output-stream
C                                   (i.e., with defined filename)

      ndiagcount = 0
      nActiveMax = 0
      DO ld=1,nlists
       nActive(ld) = nfields(ld)
       DO md=1,nfields(ld)

         found = .FALSE.
C        Search all possible model diagnostics
         DO nd=1,ndiagt
          IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
            CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
            found = .TRUE.
            jdiag(md,ld) = nd
          ENDIF
         ENDDO
         IF ( .NOT.found ) THEN
           CALL DIAGNOSTICS_LIST_CHECK(
     O                      ndCount,
     I                      ld, md, nlists, nfields, flds, myThid )
           IF ( ndCount.EQ.0 ) THEN
             WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
     &                      flds(md,ld),' is not a Diagnostic'
             CALL PRINT_ERROR( msgBuf , myThid )
           ENDIF
           STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
         ENDIF
         IF ( found .AND. mate.GE.1 ) THEN
           mm = nActive(ld) + 1
           IF ( mm.LE.numperlist ) THEN
             jdiag(mm,ld) = mate
             idiag(mm,ld) = mdiag(md,ld)
             flds (mm,ld) = cdiag(mate)
           ENDIF
           nActive(ld) = mm
         ENDIF

       ENDDO
       nActiveMax = MAX(nActive(ld),nActiveMax)
      ENDDO

      IF (  ndiagcount.LE.numDiags .AND.
     &      nActiveMax.LE.numperlist ) THEN
        WRITE(msgBuf,'(A,I8,A)')
     &    '  space allocated for all diagnostics:',
     &    ndiagcount, ' levels'
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                      SQUEEZE_RIGHT , myThid)
      ELSE
       IF ( ndiagcount.GT.numDiags ) THEN
         WRITE(msgBuf,'(2A)')
     &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
     &    ' for all active diagnostics (from data.diagnostics)'
         CALL PRINT_ERROR( msgBuf , myThid )
         WRITE(msgBuf,'(A,I8,A,I8)')
     &    'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
     &    ' but needs at least', ndiagcount
         CALL PRINT_ERROR( msgBuf , myThid )
       ENDIF
       IF ( nActiveMax.GT.numperlist ) THEN
         WRITE(msgBuf,'(2A)')
     &    'DIAGNOSTICS_SET_POINTERS: Not enough space',
     &    ' for all active diagnostics (from data.diagnostics)'
         CALL PRINT_ERROR( msgBuf , myThid )
         WRITE(msgBuf,'(A,I6,A,I6)')
     &    'DIAGNOSTICS_SET_POINTERS: numperlist=', numperlist,
     &    ' but needs at least', nActiveMax
         CALL PRINT_ERROR( msgBuf , myThid )
       ENDIF
       STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
      ENDIF

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C--   Set pointer for mate (e.g.vector component mate) if not already done
C     and if it exists. Note: for now, only used to print message.
      DO ld=1,nlists
       DO md=1,nActive(ld)
        IF (mdiag(md,ld).EQ.0 ) THEN

         nd = jdiag(md,ld)
         mate = hdiag(nd)
         IF ( mate.GT.0 ) THEN
          DO j=1,nlists
           DO i=1,nActive(j)
            IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
             IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld)
     &           .AND. averageFreq(j) .EQ.averageFreq(ld)
     &           .AND. averagePhase(j).EQ.averagePhase(ld)
     &           .AND. averageCycle(j).EQ.averageCycle(ld) )
     &          mdiag(md,ld) = ABS(idiag(i,j))
            ENDIF
           ENDDO
          ENDDO
         ENDIF
         IF ( mdiag(md,ld).NE.0 ) THEN
          WRITE(msgBuf,'(A,I6,5A,I6)') '  set mate pointer for diag #',
     &         nd, '  ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
     &             ' , mate:', hdiag(nd)
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                        SQUEEZE_RIGHT , myThid)
         ENDIF

        ENDIF
       ENDDO
      ENDDO

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C--   Set list of levels to write (if not specified in data.diagnostics)

      DO ld=1,nlists
        IF ( nlevels(ld).EQ.-1 ) THEN
C-      set Nb of levels to the minimum size of all diag of this list:
          kLev = numLevels*10
          DO md=1,nfields(ld)
            nd = jdiag(md,ld)
            kLev = MIN(kdiag(nd),kLev)
          ENDDO
          IF ( kLev.LE.0 ) THEN
            WRITE(msgBuf,'(2A,I4,2A)')
     &      'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
     &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
            CALL PRINT_ERROR( msgBuf , myThid )
            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
          ELSEIF ( kLev.GT.numLevels ) THEN
            WRITE(msgBuf,'(A,2(I6,A))')
     &      'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
     &                  ' >', numLevels, ' =numLevels'
            CALL PRINT_ERROR( msgBuf , myThid )
            WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
     &      ' setting levs of list l=',ld,', fnames=', fnames(ld)
            CALL PRINT_ERROR( msgBuf , myThid )
            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
          ENDIF
          nlevels(ld) = kLev
          DO k=1,kLev
           levs(k,ld) = k
          ENDDO
          WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
     &      'Set levels for Outp.Stream: ',fnames(ld)
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                        SQUEEZE_RIGHT, myThid)
          suffix = ' Levels:    '
          IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
          DO k1=1,nlevels(ld),20
            k2 = MIN(nlevels(ld),k1+19)
            WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                          SQUEEZE_RIGHT, myThid)
          ENDDO
        ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
C-      if no Vert.Interpolation, check for levels out of range ( > kdiag):
          kLev = 0
          DO k=1,nlevels(ld)
            kLev = MAX(NINT(levs(k,ld)),kLev)
          ENDDO
          DO md=1,nfields(ld)
            nd = jdiag(md,ld)
            IF ( kLev.GT.kdiag(nd) ) THEN
C- Note: diagnostics_out take care (in some way) of this case
C        so that it does not cause "index out-off bounds" error.
C        However, the output file looks strange.
C- For now, choose to stop, but could change it to just a warning
             WRITE(msgBuf,'(A,I4,A,I6,2A)')
     &       'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
     &         ' in list l=', ld, ', filename: ', fnames(ld)
             CALL PRINT_ERROR( msgBuf , myThid )
             WRITE(msgBuf,'(2A,I4,A,I6,2A)')
     &       'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
     &       '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
             CALL PRINT_ERROR( msgBuf , myThid )
             WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
     &       ' parsing code >>',gdiag(nd),'<<'
             CALL PRINT_ERROR( msgBuf , myThid )
             STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
            ENDIF
          ENDDO
        ENDIF
      ENDDO

        WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                      SQUEEZE_RIGHT , myThid)
        WRITE(msgBuf,'(2A)')
     &   '------------------------------------------------------------'
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                      SQUEEZE_RIGHT , myThid)

      _END_MASTER( myThid )

      RETURN
      END
1	jmc	1.14	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.13 2010/01/11 19:44:07 jmc Exp $
2	jmc	1.1	C $Name: $
3
4			#include "DIAG_OPTIONS.h"
5
6			CBOP
7			C !ROUTINE: DIAGNOSTICS_SET_POINTERS
8			C !INTERFACE:
9			SUBROUTINE DIAGNOSTICS_SET_POINTERS( myThid )
10
11			C !DESCRIPTION: \bv
12			C *==================================================================
13			C \| S/R DIAGNOSTICS_SET_POINTERS
14			C \| o set pointers for active diagnostics
15			C *==================================================================
16			C \ev
17
18			C !USES:
19			IMPLICIT NONE
20
21			C == Global variables ===
22			#include "EEPARAMS.h"
23			#include "SIZE.h"
24			#include "DIAGNOSTICS_SIZE.h"
25			#include "DIAGNOSTICS.h"
26
27			C !INPUT/OUTPUT PARAMETERS:
28			C == Routine arguments ==
29	jmc	1.13	C myThid :: my Thread Id. number
30	jmc	1.1	INTEGER myThid
31			CEOP
32
33			C !LOCAL VARIABLES:
34			C == Local variables ==
35	jmc	1.7	INTEGER ndiagcount, ndCount
36	jmc	1.5	INTEGER md,ld,nd
37	jmc	1.1	INTEGER mate, nActiveMax
38	jmc	1.5	INTEGER i, j, k, k1, k2, mm, kLev
39	jmc	1.1	LOGICAL found
40			CHARACTER*(MAX_LEN_MBUF) msgBuf
41	jmc	1.13	CHARACTER*12 suffix
42	jmc	1.1
43			_BEGIN_MASTER( myThid)
44
45	jmc	1.4	C-- Initialize pointer arrays to zero:
46	jmc	1.5	DO ld=1,numlists
47			DO md=1,numperlist
48			idiag(md,ld) = 0
49			jdiag(md,ld) = 0
50			mdiag(md,ld) = 0
51			ENDDO
52	jmc	1.4	ENDDO
53
54	jmc	1.6	C-- Calculate pointers for diagnostics in active output-stream
55			C (i.e., with defined filename)
56	jmc	1.4
57	jmc	1.1	ndiagcount = 0
58			nActiveMax = 0
59	jmc	1.5	DO ld=1,nlists
60			nActive(ld) = nfields(ld)
61			DO md=1,nfields(ld)
62	jmc	1.1
63			found = .FALSE.
64			C Search all possible model diagnostics
65	jmc	1.5	DO nd=1,ndiagt
66			IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
67			CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
68	jmc	1.1	found = .TRUE.
69	jmc	1.5	jdiag(md,ld) = nd
70	jmc	1.1	ENDIF
71			ENDDO
72			IF ( .NOT.found ) THEN
73	jmc	1.7	CALL DIAGNOSTICS_LIST_CHECK(
74			O ndCount,
75	dfer	1.11	I ld, md, nlists, nfields, flds, myThid )
76	jmc	1.7	IF ( ndCount.EQ.0 ) THEN
77			WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
78	jmc	1.5	& flds(md,ld),' is not a Diagnostic'
79	jmc	1.7	CALL PRINT_ERROR( msgBuf , myThid )
80			ENDIF
81	jmc	1.1	STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
82			ENDIF
83			IF ( found .AND. mate.GE.1 ) THEN
84	jmc	1.5	mm = nActive(ld) + 1
85			IF ( mm.LE.numperlist ) THEN
86			jdiag(mm,ld) = mate
87			idiag(mm,ld) = mdiag(md,ld)
88			flds (mm,ld) = cdiag(mate)
89	jmc	1.1	ENDIF
90	jmc	1.5	nActive(ld) = mm
91	jmc	1.1	ENDIF
92
93			ENDDO
94	jmc	1.5	nActiveMax = MAX(nActive(ld),nActiveMax)
95	jmc	1.1	ENDDO
96
97	jmc	1.10	IF ( ndiagcount.LE.numDiags .AND.
98	jmc	1.1	& nActiveMax.LE.numperlist ) THEN
99	jmc	1.10	WRITE(msgBuf,'(A,I8,A)')
100	jmc	1.5	& ' space allocated for all diagnostics:',
101	jmc	1.1	& ndiagcount, ' levels'
102			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
103	jmc	1.2	& SQUEEZE_RIGHT , myThid)
104	jmc	1.1	ELSE
105	jmc	1.10	IF ( ndiagcount.GT.numDiags ) THEN
106	jmc	1.1	WRITE(msgBuf,'(2A)')
107			& 'DIAGNOSTICS_SET_POINTERS: Not enough space',
108			& ' for all active diagnostics (from data.diagnostics)'
109			CALL PRINT_ERROR( msgBuf , myThid )
110	jmc	1.10	WRITE(msgBuf,'(A,I8,A,I8)')
111			& 'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
112	jmc	1.1	& ' but needs at least', ndiagcount
113			CALL PRINT_ERROR( msgBuf , myThid )
114			ENDIF
115			IF ( nActiveMax.GT.numperlist ) THEN
116			WRITE(msgBuf,'(2A)')
117			& 'DIAGNOSTICS_SET_POINTERS: Not enough space',
118			& ' for all active diagnostics (from data.diagnostics)'
119			CALL PRINT_ERROR( msgBuf , myThid )
120			WRITE(msgBuf,'(A,I6,A,I6)')
121			& 'DIAGNOSTICS_SET_POINTERS: numperlist=', numperlist,
122			& ' but needs at least', nActiveMax
123			CALL PRINT_ERROR( msgBuf , myThid )
124			ENDIF
125			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
126			ENDIF
127
128	jmc	1.3	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
129	jmc	1.5	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	jmc	1.10	mate = hdiag(nd)
137			IF ( mate.GT.0 ) THEN
138	jmc	1.5	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	jmc	1.14	IF ( freq(j).EQ.freq(ld) .AND. phase(j).EQ.phase(ld)
142			& .AND. averageFreq(j) .EQ.averageFreq(ld)
143			& .AND. averagePhase(j).EQ.averagePhase(ld)
144			& .AND. averageCycle(j).EQ.averageCycle(ld) )
145			& mdiag(md,ld) = ABS(idiag(i,j))
146	jmc	1.5	ENDIF
147			ENDDO
148			ENDDO
149			ENDIF
150			IF ( mdiag(md,ld).NE.0 ) THEN
151	jmc	1.10	WRITE(msgBuf,'(A,I6,5A,I6)') ' set mate pointer for diag #',
152			& nd, ' ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
153			& ' , mate:', hdiag(nd)
154	jmc	1.5	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
155			& SQUEEZE_RIGHT , myThid)
156			ENDIF
157
158			ENDIF
159			ENDDO
160			ENDDO
161
162			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
163	jmc	1.3	C-- Set list of levels to write (if not specified in data.diagnostics)
164
165	jmc	1.5	DO ld=1,nlists
166			IF ( nlevels(ld).EQ.-1 ) THEN
167	jmc	1.3	C- set Nb of levels to the minimum size of all diag of this list:
168	jmc	1.12	kLev = numLevels*10
169	jmc	1.5	DO md=1,nfields(ld)
170			nd = jdiag(md,ld)
171			kLev = MIN(kdiag(nd),kLev)
172	jmc	1.3	ENDDO
173			IF ( kLev.LE.0 ) THEN
174	jmc	1.12	WRITE(msgBuf,'(2A,I4,2A)')
175			& 'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
176			& ' setting levs of list l=',ld,', fnames=', fnames(ld)
177			CALL PRINT_ERROR( msgBuf , myThid )
178			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
179			ELSEIF ( kLev.GT.numLevels ) THEN
180			WRITE(msgBuf,'(A,2(I6,A))')
181			& 'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
182			& ' >', numLevels, ' =numLevels'
183			CALL PRINT_ERROR( msgBuf , myThid )
184			WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
185			& ' setting levs of list l=',ld,', fnames=', fnames(ld)
186	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
187			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
188			ENDIF
189	jmc	1.5	nlevels(ld) = kLev
190	jmc	1.3	DO k=1,kLev
191	jmc	1.5	levs(k,ld) = k
192	jmc	1.3	ENDDO
193			WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
194	jmc	1.5	& 'Set levels for Outp.Stream: ',fnames(ld)
195	jmc	1.3	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
196			& SQUEEZE_RIGHT, myThid)
197	jmc	1.13	suffix = ' Levels: '
198			IF ( fflags(ld)(2:2).EQ.'I' ) suffix = ' Sum Levels:'
199	jmc	1.5	DO k1=1,nlevels(ld),20
200			k2 = MIN(nlevels(ld),k1+19)
201	jmc	1.13	WRITE(msgBuf,'(A,20F5.0)') suffix, (levs(k,ld),k=k1,k2)
202	jmc	1.3	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
203			& SQUEEZE_RIGHT, myThid)
204			ENDDO
205	jmc	1.8	ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
206			C- if no Vert.Interpolation, check for levels out of range ( > kdiag):
207	jmc	1.3	kLev = 0
208	jmc	1.5	DO k=1,nlevels(ld)
209			kLev = MAX(NINT(levs(k,ld)),kLev)
210	jmc	1.3	ENDDO
211	jmc	1.5	DO md=1,nfields(ld)
212			nd = jdiag(md,ld)
213			IF ( kLev.GT.kdiag(nd) ) THEN
214			C- Note: diagnostics_out take care (in some way) of this case
215	jmc	1.3	C so that it does not cause "index out-off bounds" error.
216			C However, the output file looks strange.
217			C- For now, choose to stop, but could change it to just a warning
218	jmc	1.10	WRITE(msgBuf,'(A,I4,A,I6,2A)')
219	jmc	1.3	& 'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
220	jmc	1.5	& ' in list l=', ld, ', filename: ', fnames(ld)
221	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
222	jmc	1.10	WRITE(msgBuf,'(2A,I4,A,I6,2A)')
223	jmc	1.3	& 'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
224	jmc	1.5	& '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
225	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
226			WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
227	jmc	1.5	& ' parsing code >>',gdiag(nd),'<<'
228	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
229			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
230			ENDIF
231			ENDDO
232			ENDIF
233			ENDDO
234
235			WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
236			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
237			& SQUEEZE_RIGHT , myThid)
238			WRITE(msgBuf,'(2A)')
239			& '------------------------------------------------------------'
240			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
241			& SQUEEZE_RIGHT , myThid)
242
243	jmc	1.1	_END_MASTER( myThid )
244
245			RETURN
246			END