pkg/diagnostics/diagnostics_set_pointers.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.11 2008/10/30 18:52:54 dfer 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 - Thread number for this instance of the routine.
      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

      _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
              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)
          DO k1=1,nlevels(ld),20
            k2 = MIN(nlevels(ld),k1+19)
            WRITE(msgBuf,'(A,20F5.0)')
     &         ' Levels:    ', (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.12	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.11 2008/10/30 18:52:54 dfer 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			C myThid - Thread number for this instance of the routine.
30			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
42			_BEGIN_MASTER( myThid)
43
44	jmc	1.4	C-- Initialize pointer arrays to zero:
45	jmc	1.5	DO ld=1,numlists
46			DO md=1,numperlist
47			idiag(md,ld) = 0
48			jdiag(md,ld) = 0
49			mdiag(md,ld) = 0
50			ENDDO
51	jmc	1.4	ENDDO
52
53	jmc	1.6	C-- Calculate pointers for diagnostics in active output-stream
54			C (i.e., with defined filename)
55	jmc	1.4
56	jmc	1.1	ndiagcount = 0
57			nActiveMax = 0
58	jmc	1.5	DO ld=1,nlists
59			nActive(ld) = nfields(ld)
60			DO md=1,nfields(ld)
61	jmc	1.1
62			found = .FALSE.
63			C Search all possible model diagnostics
64	jmc	1.5	DO nd=1,ndiagt
65			IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
66			CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
67	jmc	1.1	found = .TRUE.
68	jmc	1.5	jdiag(md,ld) = nd
69	jmc	1.1	ENDIF
70			ENDDO
71			IF ( .NOT.found ) THEN
72	jmc	1.7	CALL DIAGNOSTICS_LIST_CHECK(
73			O ndCount,
74	dfer	1.11	I ld, md, nlists, nfields, flds, myThid )
75	jmc	1.7	IF ( ndCount.EQ.0 ) THEN
76			WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
77	jmc	1.5	& flds(md,ld),' is not a Diagnostic'
78	jmc	1.7	CALL PRINT_ERROR( msgBuf , myThid )
79			ENDIF
80	jmc	1.1	STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
81			ENDIF
82			IF ( found .AND. mate.GE.1 ) THEN
83	jmc	1.5	mm = nActive(ld) + 1
84			IF ( mm.LE.numperlist ) THEN
85			jdiag(mm,ld) = mate
86			idiag(mm,ld) = mdiag(md,ld)
87			flds (mm,ld) = cdiag(mate)
88	jmc	1.1	ENDIF
89	jmc	1.5	nActive(ld) = mm
90	jmc	1.1	ENDIF
91
92			ENDDO
93	jmc	1.5	nActiveMax = MAX(nActive(ld),nActiveMax)
94	jmc	1.1	ENDDO
95
96	jmc	1.10	IF ( ndiagcount.LE.numDiags .AND.
97	jmc	1.1	& nActiveMax.LE.numperlist ) THEN
98	jmc	1.10	WRITE(msgBuf,'(A,I8,A)')
99	jmc	1.5	& ' space allocated for all diagnostics:',
100	jmc	1.1	& ndiagcount, ' levels'
101			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
102	jmc	1.2	& SQUEEZE_RIGHT , myThid)
103	jmc	1.1	ELSE
104	jmc	1.10	IF ( ndiagcount.GT.numDiags ) THEN
105	jmc	1.1	WRITE(msgBuf,'(2A)')
106			& 'DIAGNOSTICS_SET_POINTERS: Not enough space',
107			& ' for all active diagnostics (from data.diagnostics)'
108			CALL PRINT_ERROR( msgBuf , myThid )
109	jmc	1.10	WRITE(msgBuf,'(A,I8,A,I8)')
110			& 'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
111	jmc	1.1	& ' but needs at least', ndiagcount
112			CALL PRINT_ERROR( msgBuf , myThid )
113			ENDIF
114			IF ( nActiveMax.GT.numperlist ) THEN
115			WRITE(msgBuf,'(2A)')
116			& 'DIAGNOSTICS_SET_POINTERS: Not enough space',
117			& ' for all active diagnostics (from data.diagnostics)'
118			CALL PRINT_ERROR( msgBuf , myThid )
119			WRITE(msgBuf,'(A,I6,A,I6)')
120			& 'DIAGNOSTICS_SET_POINTERS: numperlist=', numperlist,
121			& ' but needs at least', nActiveMax
122			CALL PRINT_ERROR( msgBuf , myThid )
123			ENDIF
124			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
125			ENDIF
126
127	jmc	1.3	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
128	jmc	1.5	C-- Set pointer for mate (e.g.vector component mate) if not already done
129			C and if it exists. Note: for now, only used to print message.
130			DO ld=1,nlists
131			DO md=1,nActive(ld)
132			IF (mdiag(md,ld).EQ.0 ) THEN
133
134			nd = jdiag(md,ld)
135	jmc	1.10	mate = hdiag(nd)
136			IF ( mate.GT.0 ) THEN
137	jmc	1.5	DO j=1,nlists
138			DO i=1,nActive(j)
139			IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
140			mdiag(md,ld) = ABS(idiag(i,j))
141			ENDIF
142			ENDDO
143			ENDDO
144			ENDIF
145			IF ( mdiag(md,ld).NE.0 ) THEN
146	jmc	1.10	WRITE(msgBuf,'(A,I6,5A,I6)') ' set mate pointer for diag #',
147			& nd, ' ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
148			& ' , mate:', hdiag(nd)
149	jmc	1.5	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
150			& SQUEEZE_RIGHT , myThid)
151			ENDIF
152
153			ENDIF
154			ENDDO
155			ENDDO
156
157			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
158	jmc	1.3	C-- Set list of levels to write (if not specified in data.diagnostics)
159
160	jmc	1.5	DO ld=1,nlists
161			IF ( nlevels(ld).EQ.-1 ) THEN
162	jmc	1.3	C- set Nb of levels to the minimum size of all diag of this list:
163	jmc	1.12	kLev = numLevels*10
164	jmc	1.5	DO md=1,nfields(ld)
165			nd = jdiag(md,ld)
166			kLev = MIN(kdiag(nd),kLev)
167	jmc	1.3	ENDDO
168			IF ( kLev.LE.0 ) THEN
169	jmc	1.12	WRITE(msgBuf,'(2A,I4,2A)')
170			& 'DIAGNOSTICS_SET_POINTERS: kLev < 1 in',
171			& ' setting levs of list l=',ld,', fnames=', fnames(ld)
172			CALL PRINT_ERROR( msgBuf , myThid )
173			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
174			ELSEIF ( kLev.GT.numLevels ) THEN
175			WRITE(msgBuf,'(A,2(I6,A))')
176			& 'DIAGNOSTICS_SET_POINTERS: kLev=', kLev,
177			& ' >', numLevels, ' =numLevels'
178			CALL PRINT_ERROR( msgBuf , myThid )
179			WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_SET_POINTERS: in',
180			& ' setting levs of list l=',ld,', fnames=', fnames(ld)
181	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
182			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
183			ENDIF
184	jmc	1.5	nlevels(ld) = kLev
185	jmc	1.3	DO k=1,kLev
186	jmc	1.5	levs(k,ld) = k
187	jmc	1.3	ENDDO
188			WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
189	jmc	1.5	& 'Set levels for Outp.Stream: ',fnames(ld)
190	jmc	1.3	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
191			& SQUEEZE_RIGHT, myThid)
192	jmc	1.5	DO k1=1,nlevels(ld),20
193			k2 = MIN(nlevels(ld),k1+19)
194			WRITE(msgBuf,'(A,20F5.0)')
195			& ' Levels: ', (levs(k,ld),k=k1,k2)
196	jmc	1.3	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
197			& SQUEEZE_RIGHT, myThid)
198			ENDDO
199	jmc	1.8	ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
200			C- if no Vert.Interpolation, check for levels out of range ( > kdiag):
201	jmc	1.3	kLev = 0
202	jmc	1.5	DO k=1,nlevels(ld)
203			kLev = MAX(NINT(levs(k,ld)),kLev)
204	jmc	1.3	ENDDO
205	jmc	1.5	DO md=1,nfields(ld)
206			nd = jdiag(md,ld)
207			IF ( kLev.GT.kdiag(nd) ) THEN
208			C- Note: diagnostics_out take care (in some way) of this case
209	jmc	1.3	C so that it does not cause "index out-off bounds" error.
210			C However, the output file looks strange.
211			C- For now, choose to stop, but could change it to just a warning
212	jmc	1.10	WRITE(msgBuf,'(A,I4,A,I6,2A)')
213	jmc	1.3	& 'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
214	jmc	1.5	& ' in list l=', ld, ', filename: ', fnames(ld)
215	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
216	jmc	1.10	WRITE(msgBuf,'(2A,I4,A,I6,2A)')
217	jmc	1.3	& 'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
218	jmc	1.5	& '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
219	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
220			WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
221	jmc	1.5	& ' parsing code >>',gdiag(nd),'<<'
222	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
223			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
224			ENDIF
225			ENDDO
226			ENDIF
227			ENDDO
228
229			WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
230			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
231			& SQUEEZE_RIGHT , myThid)
232			WRITE(msgBuf,'(2A)')
233			& '------------------------------------------------------------'
234			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
235			& SQUEEZE_RIGHT , myThid)
236
237	jmc	1.1	_END_MASTER( myThid )
238
239			RETURN
240			END