pkg/diagnostics/diagnostics_set_pointers.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.4 2005/05/16 15:07:45 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 set to non-zero frequency

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