pkg/diagnostics/diagnostics_setdiag.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.7 2011/06/21 18:00:15 jmc Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

CBOP
C     !ROUTINE: DIAGNOSTICS_SETDIAG
C     !INTERFACE:
      SUBROUTINE DIAGNOSTICS_SETDIAG(
     O                      mate,
     U                      ndiagmx,
     I                      mId, listId, ndId, myThid )

C     !DESCRIPTION: \bv
C     *==================================================================
C     | S/R DIAGNOSTICS_SETDIAG
C     | o activate diagnostic "ndId":
C     |   set pointer locations for this diagnostic ;
C     |   look for a counter mate and set it
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     mate    :: counter-mate number in available diagnostics list
C     ndiagmx :: current space allocated in storage array
C     mId     :: current field index in list "listId"
C     listId  :: current list number that contains field "mId"
C     ndId    :: diagnostic number in available diagnostics list
C     myThid  :: Thread number for this instance of the routine.
      INTEGER mate
      INTEGER ndiagmx
      INTEGER mId, listId, ndId
      INTEGER myThid
CEOP

C     !LOCAL VARIABLES:
C     == Local variables ==
      INTEGER stdUnit, errUnit
      INTEGER nn, k, l
      LOGICAL diagIsPP, flagD, flagP, flagM

      CHARACTER*10 gcode
      CHARACTER*18 tmpMsg
      CHARACTER*(MAX_LEN_MBUF) msgBuf

C **********************************************************************
C ****                SET POINTERS FOR DIAGNOSTIC ndId              ****
C **********************************************************************

      stdUnit = standardMessageUnit
      errUnit = errorMessageUnit

C-    Case of Post-Procesed diag, not filled up but computed from other diags:
      diagIsPP = gdiag(ndId)(5:5).EQ.'P'

C---  Seach for the same diag (with same freq) to see if already set
C     do it recursively on Post-Processed diag dependance (=mate)
C     until we find either one already set or a non Post-Processed diag
      flagD = .TRUE.
      flagP = .TRUE.
      nn = ndId
      DO WHILE ( flagP )
        DO l=1,listId
         IF (flagD .AND. freq(l) .EQ. freq(listId)
     &             .AND. phase(l).EQ.phase(listId)
     &             .AND. averageFreq(l) .EQ.averageFreq(listId)
     &             .AND. averagePhase(l).EQ.averagePhase(listId)
     &             .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
          DO k=1,MIN(nActive(l),numperList)
           IF (flagD .AND. jdiag(k,l).GT.0) THEN
            IF ( cdiag(nn).EQ.cdiag(jdiag(k,l)) ) THEN
C-    diagnostics already set ; use the same slot:
             flagD = .FALSE.
             idiag(mId,listId) = -ABS(idiag(k,l))
             mdiag(mId,listId) = mdiag(k,l)
            ENDIF
           ENDIF
          ENDDO
         ENDIF
        ENDDO
        flagP = flagD .AND. gdiag(nn)(5:5).EQ.'P'
        IF ( flagP ) nn = hdiag(nn)
      ENDDO

C---  Set pointer if not already set, otherwise just print a message

      IF ( diagIsPP ) THEN
        WRITE(msgBuf,'(2(A,I6,1X,A))')
     &    'SETDIAG: Diag #', ndId, cdiag(ndId),
     &    ' processed from Diag #',nn,cdiag(nn)
        CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
      ENDIF
      gcode   = gdiag(nn)(1:10)
      IF ( flagD ) THEN
        IF ( diagIsPP ) THEN
C-      Add this diag with negative idiag pointer (since those 2 diags
C        share the same pointer and "nn" will get the positive pointer).
          idiag(mId,listId) = -(ndiagmx+1)
C-      Also add "nn" to the Active list
          k = nActive(listId) + 1
          IF ( k.LE.numperList ) THEN
            jdiag(k,listId) = nn
            idiag(k,listId) = ndiagmx + 1
            flds (k,listId) = cdiag(nn)
          ENDIF
          nActive(listId) = k
        ELSE
          idiag(mId,listId) = ndiagmx + 1
        ENDIF
        ndiagmx = ndiagmx + kdiag(nn)*averageCycle(listId)
        IF ( ndiagmx.GT.numDiags ) THEN
         WRITE(msgBuf,'(A,I6,1X,A)')
     &    'SETDIAG: Not enough space for Diagnostic #',nn,cdiag(nn)
         CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
        ELSE
         WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
     &                   kdiag(nn), ' x', averageCycle(listId),
     &                ' Levels for Diagnostic #', nn, cdiag(nn)
         CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
        ENDIF
      ELSE
        WRITE(msgBuf,'(A,I6,1X,2A)') '- NOTE - SETDIAG: Diagnostic #',
     &        nn, cdiag(nn), ' is already set'
        CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
      ENDIF

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

C---  Check for Counter Diagnostic
      mate = 0

C-    if Post-Processed diag, activate 2nd components of vector field
      tmpMsg = ' Vector-mate Diag.'
      IF ( diagIsPP .AND. gcode(5:5).NE.'P' .AND.
     &    (gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V') ) mate = hdiag(nn)
C-    activate mate if this is a Counter Diagnostic
      IF ( gcode(5:5).EQ.'C') THEN
        mate = hdiag(nn)
        tmpMsg = 'Counter Diagnostic'
      ENDIF

      IF ( mate.GT.0 ) THEN
C--     Seach for the same diag (with same freq) to see if already set
        flagM = .TRUE.
        DO l=1,listId
         IF (flagM .AND. freq(l) .EQ.freq(listId)
     &             .AND. phase(l).EQ.phase(listId)
     &             .AND. averageFreq(l) .EQ.averageFreq(listId)
     &             .AND. averagePhase(l).EQ.averagePhase(listId)
     &             .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
          DO k=1,MIN(nActive(l),numperList)
           IF (flagM .AND. jdiag(k,l).GT.0) THEN
            IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN
C-    diagnostics already set ; use the same slot:
             flagM = .FALSE.
             mdiag(mId,listId) = ABS(idiag(k,l))
            ENDIF
           ENDIF
          ENDDO
         ENDIF
        ENDDO

C---  Set pointer if not already set, otherwise just print a message
        IF ( flagM ) THEN
          mdiag(mId,listId) = ndiagmx + 1
          k = nActive(listId) + 1
          IF ( k.LE.numperList ) THEN
C-      Also add mate to the Active list
            jdiag(k,listId) = mate
            idiag(k,listId) = ndiagmx + 1
            flds (k,listId) = cdiag(mate)
          ENDIF
          nActive(listId) = k
          ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId)
          IF ( ndiagmx.GT.numDiags ) THEN
           WRITE(msgBuf,'(3A,I6,1X,A)')
     &      'SETDIAG: Not enough space for ',tmpMsg,' #',
     &      mate, cdiag(mate)
           CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
          ELSE
           WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
     &                     kdiag(mate), ' x', averageCycle(listId),
     &                  ' Levels for Mate Diag. #', mate, cdiag(mate)
           CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
          ENDIF
        ELSE
          WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
     &    ' #', mate, cdiag(mate), ' is already set'
          CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
        ENDIF
      ENDIF

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
      RETURN
      END
1	jmc	1.8	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.7 2011/06/21 18:00:15 jmc Exp $
2	jmc	1.1	C $Name: $
3
4			#include "DIAG_OPTIONS.h"
5
6			CBOP
7			C !ROUTINE: DIAGNOSTICS_SETDIAG
8			C !INTERFACE:
9	jmc	1.2	SUBROUTINE DIAGNOSTICS_SETDIAG(
10	jmc	1.1	O mate,
11	jmc	1.2	U ndiagmx,
12			I mId, listId, ndId, myThid )
13	jmc	1.1
14			C !DESCRIPTION: \bv
15			C *==================================================================
16			C \| S/R DIAGNOSTICS_SETDIAG
17	jmc	1.2	C \| o activate diagnostic "ndId":
18	jmc	1.1	C \| set pointer locations for this diagnostic ;
19			C \| look for a counter mate and set it
20			C *==================================================================
21			C \ev
22
23			C !USES:
24			IMPLICIT NONE
25
26			C == Global variables ===
27			#include "EEPARAMS.h"
28			#include "SIZE.h"
29			#include "DIAGNOSTICS_SIZE.h"
30			#include "DIAGNOSTICS.h"
31
32			C !INPUT/OUTPUT PARAMETERS:
33			C == Routine arguments ==
34	jmc	1.2	C mate :: counter-mate number in available diagnostics list
35			C ndiagmx :: current space allocated in storage array
36			C mId :: current field index in list "listId"
37			C listId :: current list number that contains field "mId"
38			C ndId :: diagnostic number in available diagnostics list
39			C myThid :: Thread number for this instance of the routine.
40	jmc	1.1	INTEGER mate
41			INTEGER ndiagmx
42	jmc	1.2	INTEGER mId, listId, ndId
43	jmc	1.1	INTEGER myThid
44			CEOP
45
46			C !LOCAL VARIABLES:
47			C == Local variables ==
48			INTEGER stdUnit, errUnit
49	jmc	1.7	INTEGER nn, k, l
50			LOGICAL diagIsPP, flagD, flagP, flagM
51	jmc	1.1
52	jmc	1.5	CHARACTER*10 gcode
53	jmc	1.7	CHARACTER*18 tmpMsg
54	jmc	1.1	CHARACTER*(MAX_LEN_MBUF) msgBuf
55
56			C **********************************************************************
57	jmc	1.5	C ** SET POINTERS FOR DIAGNOSTIC ndId **
58	jmc	1.1	C **********************************************************************
59
60			stdUnit = standardMessageUnit
61			errUnit = errorMessageUnit
62
63	jmc	1.7	C- Case of Post-Procesed diag, not filled up but computed from other diags:
64			diagIsPP = gdiag(ndId)(5:5).EQ.'P'
65
66			C--- Seach for the same diag (with same freq) to see if already set
67			C do it recursively on Post-Processed diag dependance (=mate)
68			C until we find either one already set or a non Post-Processed diag
69			flagD = .TRUE.
70			flagP = .TRUE.
71			nn = ndId
72			DO WHILE ( flagP )
73			DO l=1,listId
74			IF (flagD .AND. freq(l) .EQ. freq(listId)
75			& .AND. phase(l).EQ.phase(listId)
76			& .AND. averageFreq(l) .EQ.averageFreq(listId)
77			& .AND. averagePhase(l).EQ.averagePhase(listId)
78			& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
79			DO k=1,MIN(nActive(l),numperList)
80			IF (flagD .AND. jdiag(k,l).GT.0) THEN
81			IF ( cdiag(nn).EQ.cdiag(jdiag(k,l)) ) THEN
82	jmc	1.2	C- diagnostics already set ; use the same slot:
83	jmc	1.7	flagD = .FALSE.
84			idiag(mId,listId) = -ABS(idiag(k,l))
85			mdiag(mId,listId) = mdiag(k,l)
86			ENDIF
87			ENDIF
88			ENDDO
89	jmc	1.2	ENDIF
90			ENDDO
91	jmc	1.7	flagP = flagD .AND. gdiag(nn)(5:5).EQ.'P'
92			IF ( flagP ) nn = hdiag(nn)
93	jmc	1.2	ENDDO
94
95	jmc	1.7	C--- Set pointer if not already set, otherwise just print a message
96	jmc	1.2
97	jmc	1.7	IF ( diagIsPP ) THEN
98			WRITE(msgBuf,'(2(A,I6,1X,A))')
99			& 'SETDIAG: Diag #', ndId, cdiag(ndId),
100			& ' processed from Diag #',nn,cdiag(nn)
101			CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
102			ENDIF
103			gcode = gdiag(nn)(1:10)
104			IF ( flagD ) THEN
105			IF ( diagIsPP ) THEN
106	jmc	1.8	C- Add this diag with negative idiag pointer (since those 2 diags
107			C share the same pointer and "nn" will get the positive pointer).
108			idiag(mId,listId) = -(ndiagmx+1)
109	jmc	1.7	C- Also add "nn" to the Active list
110			k = nActive(listId) + 1
111			IF ( k.LE.numperList ) THEN
112			jdiag(k,listId) = nn
113			idiag(k,listId) = ndiagmx + 1
114			flds (k,listId) = cdiag(nn)
115			ENDIF
116			nActive(listId) = k
117	jmc	1.8	ELSE
118			idiag(mId,listId) = ndiagmx + 1
119	jmc	1.7	ENDIF
120			ndiagmx = ndiagmx + kdiag(nn)*averageCycle(listId)
121	jmc	1.5	IF ( ndiagmx.GT.numDiags ) THEN
122			WRITE(msgBuf,'(A,I6,1X,A)')
123	jmc	1.7	& 'SETDIAG: Not enough space for Diagnostic #',nn,cdiag(nn)
124	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
125			ELSE
126	jmc	1.5	WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
127	jmc	1.7	& kdiag(nn), ' x', averageCycle(listId),
128			& ' Levels for Diagnostic #', nn, cdiag(nn)
129	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
130			ENDIF
131			ELSE
132	jmc	1.7	WRITE(msgBuf,'(A,I6,1X,2A)') '- NOTE - SETDIAG: Diagnostic #',
133			& nn, cdiag(nn), ' is already set'
134	jmc	1.6	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
135	jmc	1.1	ENDIF
136
137	jmc	1.7	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
138	jmc	1.6
139	jmc	1.7	C--- Check for Counter Diagnostic
140	jmc	1.1	mate = 0
141	jmc	1.7
142			C- if Post-Processed diag, activate 2nd components of vector field
143			tmpMsg = ' Vector-mate Diag.'
144			IF ( diagIsPP .AND. gcode(5:5).NE.'P' .AND.
145			& (gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V') ) mate = hdiag(nn)
146			C- activate mate if this is a Counter Diagnostic
147	jmc	1.5	IF ( gcode(5:5).EQ.'C') THEN
148	jmc	1.7	mate = hdiag(nn)
149			tmpMsg = 'Counter Diagnostic'
150			ENDIF
151	jmc	1.1
152	jmc	1.7	IF ( mate.GT.0 ) THEN
153	jmc	1.2	C-- Seach for the same diag (with same freq) to see if already set
154	jmc	1.7	flagM = .TRUE.
155	jmc	1.2	DO l=1,listId
156	jmc	1.7	IF (flagM .AND. freq(l) .EQ.freq(listId)
157			& .AND. phase(l).EQ.phase(listId)
158			& .AND. averageFreq(l) .EQ.averageFreq(listId)
159			& .AND. averagePhase(l).EQ.averagePhase(listId)
160			& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
161			DO k=1,MIN(nActive(l),numperList)
162			IF (flagM .AND. jdiag(k,l).GT.0) THEN
163	jmc	1.2	IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN
164			C- diagnostics already set ; use the same slot:
165	jmc	1.7	flagM = .FALSE.
166	jmc	1.2	mdiag(mId,listId) = ABS(idiag(k,l))
167			ENDIF
168			ENDIF
169			ENDDO
170			ENDIF
171			ENDDO
172
173	jmc	1.7	C--- Set pointer if not already set, otherwise just print a message
174			IF ( flagM ) THEN
175	jmc	1.4	mdiag(mId,listId) = ndiagmx + 1
176	jmc	1.7	k = nActive(listId) + 1
177			IF ( k.LE.numperList ) THEN
178			C- Also add mate to the Active list
179			jdiag(k,listId) = mate
180			idiag(k,listId) = ndiagmx + 1
181			flds (k,listId) = cdiag(mate)
182			ENDIF
183			nActive(listId) = k
184	jmc	1.4	ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId)
185	jmc	1.5	IF ( ndiagmx.GT.numDiags ) THEN
186	jmc	1.7	WRITE(msgBuf,'(3A,I6,1X,A)')
187			& 'SETDIAG: Not enough space for ',tmpMsg,' #',
188	jmc	1.2	& mate, cdiag(mate)
189	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
190			ELSE
191	jmc	1.5	WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
192	jmc	1.4	& kdiag(mate), ' x', averageCycle(listId),
193	jmc	1.7	& ' Levels for Mate Diag. #', mate, cdiag(mate)
194	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
195			ENDIF
196			ELSE
197	jmc	1.7	WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
198			& ' #', mate, cdiag(mate), ' is already set'
199	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
200			ENDIF
201			ENDIF
202
203			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
204			RETURN
205			END