pkg/diagnostics/diagnostics_setdiag.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.5 2008/02/05 15:13:01 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
        idiag(mId,listId) = ndiagmx + 1
        IF ( diagIsPP ) THEN
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
        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.6	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.5 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_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	jmc	1.4	idiag(mId,listId) = ndiagmx + 1
106	jmc	1.7	IF ( diagIsPP ) THEN
107			C- Also add "nn" to the Active list
108			k = nActive(listId) + 1
109			IF ( k.LE.numperList ) THEN
110			jdiag(k,listId) = nn
111			idiag(k,listId) = ndiagmx + 1
112			flds (k,listId) = cdiag(nn)
113			ENDIF
114			nActive(listId) = k
115			ENDIF
116			ndiagmx = ndiagmx + kdiag(nn)*averageCycle(listId)
117	jmc	1.5	IF ( ndiagmx.GT.numDiags ) THEN
118			WRITE(msgBuf,'(A,I6,1X,A)')
119	jmc	1.7	& 'SETDIAG: Not enough space for Diagnostic #',nn,cdiag(nn)
120	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
121			ELSE
122	jmc	1.5	WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
123	jmc	1.7	& kdiag(nn), ' x', averageCycle(listId),
124			& ' Levels for Diagnostic #', nn, cdiag(nn)
125	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
126			ENDIF
127			ELSE
128	jmc	1.7	WRITE(msgBuf,'(A,I6,1X,2A)') '- NOTE - SETDIAG: Diagnostic #',
129			& nn, cdiag(nn), ' is already set'
130	jmc	1.6	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
131	jmc	1.1	ENDIF
132
133	jmc	1.7	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
134	jmc	1.6
135	jmc	1.7	C--- Check for Counter Diagnostic
136	jmc	1.1	mate = 0
137	jmc	1.7
138			C- if Post-Processed diag, activate 2nd components of vector field
139			tmpMsg = ' Vector-mate Diag.'
140			IF ( diagIsPP .AND. gcode(5:5).NE.'P' .AND.
141			& (gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V') ) mate = hdiag(nn)
142			C- activate mate if this is a Counter Diagnostic
143	jmc	1.5	IF ( gcode(5:5).EQ.'C') THEN
144	jmc	1.7	mate = hdiag(nn)
145			tmpMsg = 'Counter Diagnostic'
146			ENDIF
147	jmc	1.1
148	jmc	1.7	IF ( mate.GT.0 ) THEN
149	jmc	1.2	C-- Seach for the same diag (with same freq) to see if already set
150	jmc	1.7	flagM = .TRUE.
151	jmc	1.2	DO l=1,listId
152	jmc	1.7	IF (flagM .AND. freq(l) .EQ.freq(listId)
153			& .AND. phase(l).EQ.phase(listId)
154			& .AND. averageFreq(l) .EQ.averageFreq(listId)
155			& .AND. averagePhase(l).EQ.averagePhase(listId)
156			& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
157			DO k=1,MIN(nActive(l),numperList)
158			IF (flagM .AND. jdiag(k,l).GT.0) THEN
159	jmc	1.2	IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN
160			C- diagnostics already set ; use the same slot:
161	jmc	1.7	flagM = .FALSE.
162	jmc	1.2	mdiag(mId,listId) = ABS(idiag(k,l))
163			ENDIF
164			ENDIF
165			ENDDO
166			ENDIF
167			ENDDO
168
169	jmc	1.7	C--- Set pointer if not already set, otherwise just print a message
170			IF ( flagM ) THEN
171	jmc	1.4	mdiag(mId,listId) = ndiagmx + 1
172	jmc	1.7	k = nActive(listId) + 1
173			IF ( k.LE.numperList ) THEN
174			C- Also add mate to the Active list
175			jdiag(k,listId) = mate
176			idiag(k,listId) = ndiagmx + 1
177			flds (k,listId) = cdiag(mate)
178			ENDIF
179			nActive(listId) = k
180	jmc	1.4	ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId)
181	jmc	1.5	IF ( ndiagmx.GT.numDiags ) THEN
182	jmc	1.7	WRITE(msgBuf,'(3A,I6,1X,A)')
183			& 'SETDIAG: Not enough space for ',tmpMsg,' #',
184	jmc	1.2	& mate, cdiag(mate)
185	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
186			ELSE
187	jmc	1.5	WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
188	jmc	1.4	& kdiag(mate), ' x', averageCycle(listId),
189	jmc	1.7	& ' Levels for Mate Diag. #', mate, cdiag(mate)
190	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
191			ENDIF
192			ELSE
193	jmc	1.7	WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
194			& ' #', mate, cdiag(mate), ' is already set'
195	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
196			ENDIF
197			ENDIF
198
199			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
200			RETURN
201			END