pkg/diagnostics/diagnostics_set_pointers.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.8 2006/12/24 20:20:59 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 - 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
      CHARACTER*3 mate_index


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