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 k, l
      LOGICAL flag

      CHARACTER*10 gcode
      CHARACTER*(MAX_LEN_MBUF) msgBuf


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

      gcode   = gdiag(ndId)(1:10)
      stdUnit = standardMessageUnit
      errUnit = errorMessageUnit

C--   Seach for the same diag (with same freq) to see if already set
      flag = .TRUE.
      DO l=1,listId
       IF (flag .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 (flag .AND. jdiag(k,l).GT.0) THEN
          IF ( cdiag(ndId).EQ.cdiag(jdiag(k,l)) ) THEN
C-    diagnostics already set ; use the same slot:
           flag = .FALSE.
           idiag(mId,listId) = -ABS(idiag(k,l))
           mdiag(mId,listId) = mdiag(k,l)
          ENDIF
         ENDIF
        ENDDO
       ENDIF
      ENDDO

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

      IF ( flag ) THEN
        idiag(mId,listId) = ndiagmx + 1
        ndiagmx = ndiagmx + kdiag(ndId)*averageCycle(listId)
        IF ( ndiagmx.GT.numDiags ) THEN
         WRITE(msgBuf,'(A,I6,1X,A)')
     &    'SETDIAG: Not enough space for Diagnostic #',ndId,cdiag(ndId)
         CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
        ELSE
         WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
     &                   kdiag(ndId), ' x', averageCycle(listId),
     &                ' Levels for Diagnostic #', ndId, cdiag(ndId)
         CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
        ENDIF
      ELSE
        WRITE(msgBuf,'(A,I6,1X,2A)')
     &    '- NOTE - SETDIAG: Diagnostic #', ndId, cdiag(ndId),
     &    ' has already been set'
        CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
      ENDIF

C     Check for Counter Diagnostic

      mate = 0
      IF ( gcode(5:5).EQ.'C') THEN
        mate = hdiag(ndId)

C--     Seach for the same diag (with same freq) to see if already set
        flag = .TRUE.
        DO l=1,listId
         IF (flag .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 (flag .AND. jdiag(k,l).GT.0) THEN
            IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN
C-    diagnostics already set ; use the same slot:
             flag = .FALSE.
             mdiag(mId,listId) = ABS(idiag(k,l))
            ENDIF
           ENDIF
          ENDDO
         ENDIF
        ENDDO

        IF ( flag ) THEN
          mdiag(mId,listId) = ndiagmx + 1
          ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId)
          IF ( ndiagmx.GT.numDiags ) THEN
           WRITE(msgBuf,'(A,I6,1X,A)')
     &      'SETDIAG: Not enough space for Counter Diagnostic #',
     &      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 Count.Diag #', mate, cdiag(mate)
           CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
          ENDIF
        ELSE
          WRITE(msgBuf,'(A,I6,1X,2A)')
     &    '- NOTE - SETDIAG: Counter Diagnostic #', mate, cdiag(mate),
     &    ' has already been set'
          CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
          mate = 0
        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.2	INTEGER k, l
50			LOGICAL flag
51	jmc	1.1
52	jmc	1.5	CHARACTER*10 gcode
53	jmc	1.1	CHARACTER*(MAX_LEN_MBUF) msgBuf
54
55
56			C **********************************************************************
57	jmc	1.5	C ** SET POINTERS FOR DIAGNOSTIC ndId **
58	jmc	1.1	C **********************************************************************
59
60	jmc	1.5	gcode = gdiag(ndId)(1:10)
61	jmc	1.1	stdUnit = standardMessageUnit
62			errUnit = errorMessageUnit
63
64	jmc	1.2	C-- Seach for the same diag (with same freq) to see if already set
65			flag = .TRUE.
66			DO l=1,listId
67			IF (flag .AND. freq(l) .EQ. freq(listId)
68	jmc	1.4	& .AND. phase(l).EQ.phase(listId)
69			& .AND. averageFreq(l) .EQ.averageFreq(listId)
70			& .AND. averagePhase(l).EQ.averagePhase(listId)
71			& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
72	jmc	1.2	DO k=1,MIN(nActive(l),numperlist)
73			IF (flag .AND. jdiag(k,l).GT.0) THEN
74			IF ( cdiag(ndId).EQ.cdiag(jdiag(k,l)) ) THEN
75			C- diagnostics already set ; use the same slot:
76			flag = .FALSE.
77			idiag(mId,listId) = -ABS(idiag(k,l))
78			mdiag(mId,listId) = mdiag(k,l)
79			ENDIF
80			ENDIF
81			ENDDO
82			ENDIF
83			ENDDO
84
85			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
86
87			IF ( flag ) THEN
88	jmc	1.4	idiag(mId,listId) = ndiagmx + 1
89			ndiagmx = ndiagmx + kdiag(ndId)*averageCycle(listId)
90	jmc	1.5	IF ( ndiagmx.GT.numDiags ) THEN
91			WRITE(msgBuf,'(A,I6,1X,A)')
92	jmc	1.2	& 'SETDIAG: Not enough space for Diagnostic #',ndId,cdiag(ndId)
93	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
94			ELSE
95	jmc	1.5	WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
96	jmc	1.4	& kdiag(ndId), ' x', averageCycle(listId),
97			& ' Levels for Diagnostic #', ndId, cdiag(ndId)
98	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
99			ENDIF
100			ELSE
101	jmc	1.5	WRITE(msgBuf,'(A,I6,1X,2A)')
102	jmc	1.6	& '- NOTE - SETDIAG: Diagnostic #', ndId, cdiag(ndId),
103	jmc	1.1	& ' has already been set'
104	jmc	1.6	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
105	jmc	1.1	ENDIF
106
107	jmc	1.6	C Check for Counter Diagnostic
108
109	jmc	1.1	mate = 0
110	jmc	1.5	IF ( gcode(5:5).EQ.'C') THEN
111			mate = hdiag(ndId)
112	jmc	1.1
113	jmc	1.2	C-- Seach for the same diag (with same freq) to see if already set
114			flag = .TRUE.
115			DO l=1,listId
116	jmc	1.4	IF (flag .AND. freq(l) .EQ.freq(listId)
117			& .AND. phase(l).EQ.phase(listId)
118			& .AND. averageFreq(l) .EQ.averageFreq(listId)
119			& .AND. averagePhase(l).EQ.averagePhase(listId)
120			& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
121	jmc	1.2	DO k=1,MIN(nActive(l),numperlist)
122			IF (flag .AND. jdiag(k,l).GT.0) THEN
123			IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN
124			C- diagnostics already set ; use the same slot:
125			flag = .FALSE.
126			mdiag(mId,listId) = ABS(idiag(k,l))
127			ENDIF
128			ENDIF
129			ENDDO
130			ENDIF
131			ENDDO
132
133			IF ( flag ) THEN
134	jmc	1.4	mdiag(mId,listId) = ndiagmx + 1
135			ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId)
136	jmc	1.5	IF ( ndiagmx.GT.numDiags ) THEN
137			WRITE(msgBuf,'(A,I6,1X,A)')
138	jmc	1.2	& 'SETDIAG: Not enough space for Counter Diagnostic #',
139			& mate, cdiag(mate)
140	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
141			ELSE
142	jmc	1.5	WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
143	jmc	1.4	& kdiag(mate), ' x', averageCycle(listId),
144			& ' Levels for Count.Diag #', mate, cdiag(mate)
145	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
146			ENDIF
147			ELSE
148	jmc	1.5	WRITE(msgBuf,'(A,I6,1X,2A)')
149	jmc	1.1	& '- NOTE - SETDIAG: Counter Diagnostic #', mate, cdiag(mate),
150			& ' has already been set'
151			CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
152			mate = 0
153			ENDIF
154			ENDIF
155
156			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
157			RETURN
158			END