pkg/diagnostics/diagnostics_set_pointers.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.10 2008/02/05 15:13:01 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

      _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
          DO md=1,nfields(ld)
            nd = jdiag(md,ld)
            kLev = MIN(kdiag(nd),kLev)
          ENDDO
          IF ( kLev.LE.0 ) THEN
            WRITE(msgBuf,'(2A,I6,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,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	dfer	1.11	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.10 2008/02/05 15:13:01 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
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			kLev = numLevels
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.10	WRITE(msgBuf,'(2A,I6,2A)')
170	jmc	1.3	& 'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',
171	jmc	1.5	& ' setting levs of list l=',ld,', fnames: ', fnames(ld)
172	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
173			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
174			ENDIF
175	jmc	1.5	nlevels(ld) = kLev
176	jmc	1.3	DO k=1,kLev
177	jmc	1.5	levs(k,ld) = k
178	jmc	1.3	ENDDO
179			WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
180	jmc	1.5	& 'Set levels for Outp.Stream: ',fnames(ld)
181	jmc	1.3	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
182			& SQUEEZE_RIGHT, myThid)
183	jmc	1.5	DO k1=1,nlevels(ld),20
184			k2 = MIN(nlevels(ld),k1+19)
185			WRITE(msgBuf,'(A,20F5.0)')
186			& ' Levels: ', (levs(k,ld),k=k1,k2)
187	jmc	1.3	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
188			& SQUEEZE_RIGHT, myThid)
189			ENDDO
190	jmc	1.8	ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
191			C- if no Vert.Interpolation, check for levels out of range ( > kdiag):
192	jmc	1.3	kLev = 0
193	jmc	1.5	DO k=1,nlevels(ld)
194			kLev = MAX(NINT(levs(k,ld)),kLev)
195	jmc	1.3	ENDDO
196	jmc	1.5	DO md=1,nfields(ld)
197			nd = jdiag(md,ld)
198			IF ( kLev.GT.kdiag(nd) ) THEN
199			C- Note: diagnostics_out take care (in some way) of this case
200	jmc	1.3	C so that it does not cause "index out-off bounds" error.
201			C However, the output file looks strange.
202			C- For now, choose to stop, but could change it to just a warning
203	jmc	1.10	WRITE(msgBuf,'(A,I4,A,I6,2A)')
204	jmc	1.3	& 'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
205	jmc	1.5	& ' in list l=', ld, ', filename: ', fnames(ld)
206	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
207	jmc	1.10	WRITE(msgBuf,'(2A,I4,A,I6,2A)')
208	jmc	1.3	& 'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
209	jmc	1.5	& '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
210	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
211			WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
212	jmc	1.5	& ' parsing code >>',gdiag(nd),'<<'
213	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
214			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
215			ENDIF
216			ENDDO
217			ENDIF
218			ENDDO
219
220			WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
221			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
222			& SQUEEZE_RIGHT , myThid)
223			WRITE(msgBuf,'(2A)')
224			& '------------------------------------------------------------'
225			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
226			& SQUEEZE_RIGHT , myThid)
227
228	jmc	1.1	_END_MASTER( myThid )
229
230			RETURN
231			END