pkg/diagnostics/diagnostics_set_pointers.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.5 2005/06/26 16:51:49 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
      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
           WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
     &                      flds(md,ld),' is not a Diagnostic'
           CALL PRINT_ERROR( msgBuf , myThid )
           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.'   ' ) 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
        ELSE
C-      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	jmc	1.6	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.5 2005/06/26 16:51:49 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			INTEGER ndiagcount
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.5	WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
75			& flds(md,ld),' is not a Diagnostic'
76	jmc	1.1	CALL PRINT_ERROR( msgBuf , myThid )
77			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
78			ENDIF
79			IF ( found .AND. mate.GE.1 ) THEN
80	jmc	1.5	mm = nActive(ld) + 1
81			IF ( mm.LE.numperlist ) THEN
82			jdiag(mm,ld) = mate
83			idiag(mm,ld) = mdiag(md,ld)
84			flds (mm,ld) = cdiag(mate)
85	jmc	1.1	ENDIF
86	jmc	1.5	nActive(ld) = mm
87	jmc	1.1	ENDIF
88
89			ENDDO
90	jmc	1.5	nActiveMax = MAX(nActive(ld),nActiveMax)
91	jmc	1.1	ENDDO
92
93			IF ( ndiagcount.LE.numdiags .AND.
94			& nActiveMax.LE.numperlist ) THEN
95	jmc	1.2	WRITE(msgBuf,'(A,I6,A)')
96	jmc	1.5	& ' space allocated for all diagnostics:',
97	jmc	1.1	& ndiagcount, ' levels'
98			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
99	jmc	1.2	& SQUEEZE_RIGHT , myThid)
100	jmc	1.1	ELSE
101			IF ( ndiagcount.GT.numdiags ) THEN
102			WRITE(msgBuf,'(2A)')
103			& 'DIAGNOSTICS_SET_POINTERS: Not enough space',
104			& ' for all active diagnostics (from data.diagnostics)'
105			CALL PRINT_ERROR( msgBuf , myThid )
106			WRITE(msgBuf,'(A,I6,A,I6)')
107			& 'DIAGNOSTICS_SET_POINTERS: numdiags=', numdiags,
108			& ' but needs at least', ndiagcount
109			CALL PRINT_ERROR( msgBuf , myThid )
110			ENDIF
111			IF ( nActiveMax.GT.numperlist ) THEN
112			WRITE(msgBuf,'(2A)')
113			& 'DIAGNOSTICS_SET_POINTERS: Not enough space',
114			& ' for all active diagnostics (from data.diagnostics)'
115			CALL PRINT_ERROR( msgBuf , myThid )
116			WRITE(msgBuf,'(A,I6,A,I6)')
117			& 'DIAGNOSTICS_SET_POINTERS: numperlist=', numperlist,
118			& ' but needs at least', nActiveMax
119			CALL PRINT_ERROR( msgBuf , myThid )
120			ENDIF
121			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
122			ENDIF
123
124	jmc	1.3	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
125	jmc	1.5	C-- Set pointer for mate (e.g.vector component mate) if not already done
126			C and if it exists. Note: for now, only used to print message.
127			DO ld=1,nlists
128			DO md=1,nActive(ld)
129			IF (mdiag(md,ld).EQ.0 ) THEN
130
131			nd = jdiag(md,ld)
132			mate_index = gdiag(nd)(6:8)
133			IF ( mate_index.NE.' ' ) THEN
134			READ(mate_index,'(I3)') mate
135			DO j=1,nlists
136			DO i=1,nActive(j)
137			IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
138			mdiag(md,ld) = ABS(idiag(i,j))
139			ENDIF
140			ENDDO
141			ENDDO
142			ENDIF
143			IF ( mdiag(md,ld).NE.0 ) THEN
144			WRITE(msgBuf,'(A,I4,4A)') ' set mate pointer for diag #',
145			& nd, ' ', cdiag(nd), ' , Parms: ', gdiag(nd)
146			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
147			& SQUEEZE_RIGHT , myThid)
148			ENDIF
149
150			ENDIF
151			ENDDO
152			ENDDO
153
154			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
155	jmc	1.3	C-- Set list of levels to write (if not specified in data.diagnostics)
156
157	jmc	1.5	DO ld=1,nlists
158			IF ( nlevels(ld).EQ.-1 ) THEN
159	jmc	1.3	C- set Nb of levels to the minimum size of all diag of this list:
160			kLev = numLevels
161	jmc	1.5	DO md=1,nfields(ld)
162			nd = jdiag(md,ld)
163			kLev = MIN(kdiag(nd),kLev)
164	jmc	1.3	ENDDO
165			IF ( kLev.LE.0 ) THEN
166			WRITE(msgBuf,'(2A,I4,2A)')
167			& 'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',
168	jmc	1.5	& ' setting levs of list l=',ld,', fnames: ', fnames(ld)
169	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
170			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
171			ENDIF
172	jmc	1.5	nlevels(ld) = kLev
173	jmc	1.3	DO k=1,kLev
174	jmc	1.5	levs(k,ld) = k
175	jmc	1.3	ENDDO
176			WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
177	jmc	1.5	& 'Set levels for Outp.Stream: ',fnames(ld)
178	jmc	1.3	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
179			& SQUEEZE_RIGHT, myThid)
180	jmc	1.5	DO k1=1,nlevels(ld),20
181			k2 = MIN(nlevels(ld),k1+19)
182			WRITE(msgBuf,'(A,20F5.0)')
183			& ' Levels: ', (levs(k,ld),k=k1,k2)
184	jmc	1.3	CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
185			& SQUEEZE_RIGHT, myThid)
186			ENDDO
187			ELSE
188			C- Check for levels out of range ( > kdiag)
189			kLev = 0
190	jmc	1.5	DO k=1,nlevels(ld)
191			kLev = MAX(NINT(levs(k,ld)),kLev)
192	jmc	1.3	ENDDO
193	jmc	1.5	DO md=1,nfields(ld)
194			nd = jdiag(md,ld)
195			IF ( kLev.GT.kdiag(nd) ) THEN
196			C- Note: diagnostics_out take care (in some way) of this case
197	jmc	1.3	C so that it does not cause "index out-off bounds" error.
198			C However, the output file looks strange.
199			C- For now, choose to stop, but could change it to just a warning
200			WRITE(msgBuf,'(A,I3,A,I3,2A)')
201			& 'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
202	jmc	1.5	& ' in list l=', ld, ', filename: ', fnames(ld)
203	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
204			WRITE(msgBuf,'(2A,I3,A,I3,2A)')
205			& 'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
206	jmc	1.5	& '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
207	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
208			WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
209	jmc	1.5	& ' parsing code >>',gdiag(nd),'<<'
210	jmc	1.3	CALL PRINT_ERROR( msgBuf , myThid )
211			STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
212			ENDIF
213			ENDDO
214			ENDIF
215			ENDDO
216
217			WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
218			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
219			& SQUEEZE_RIGHT , myThid)
220			WRITE(msgBuf,'(2A)')
221			& '------------------------------------------------------------'
222			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
223			& SQUEEZE_RIGHT , myThid)
224
225	jmc	1.1	_END_MASTER( myThid )
226
227			RETURN
228			END