pkg/diagnostics/diagnostics_setdiag.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.3 2005/06/26 18:23:03 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*8 parms1
      CHARACTER*(MAX_LEN_MBUF) msgBuf


C **********************************************************************
C ****                SET POINTERS FOR DIAGNOSTIC NUM               ****
C **********************************************************************

      parms1  = gdiag(ndId)(1:8)
      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,I4,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),I4,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,I4,1X,2A)')
     &    '- WARNING - SETDIAG: Diagnostic #', ndId, cdiag(ndId),
     &    ' has already been set'
        CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
        mate = 0
        RETURN
      ENDIF

c Check for Counter Diagnostic
c ----------------------------
      mate = 0
      IF ( parms1(5:5).EQ.'C') THEN
        READ(parms1,'(5X,I3)') mate

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,I4,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),I4,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,I4,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.4	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.3 2005/06/26 18:23:03 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			CHARACTER*8 parms1
53			CHARACTER*(MAX_LEN_MBUF) msgBuf
54
55
56			C **********************************************************************
57			C ** SET POINTERS FOR DIAGNOSTIC NUM **
58			C **********************************************************************
59
60	jmc	1.2	parms1 = gdiag(ndId)(1:8)
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			IF ( ndiagmx.GT.numdiags ) THEN
91	jmc	1.2	WRITE(msgBuf,'(A,I4,1X,A)')
92			& '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.4	WRITE(msgBuf,'(A,2(I3,A),I4,1X,A)') 'SETDIAG: Allocate',
96			& 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.2	WRITE(msgBuf,'(A,I4,1X,2A)')
102			& '- WARNING - SETDIAG: Diagnostic #', ndId, cdiag(ndId),
103	jmc	1.1	& ' has already been set'
104			CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
105	jmc	1.3	mate = 0
106	jmc	1.2	RETURN
107	jmc	1.1	ENDIF
108
109			c Check for Counter Diagnostic
110			c ----------------------------
111			mate = 0
112			IF ( parms1(5:5).EQ.'C') THEN
113	jmc	1.4	READ(parms1,'(5X,I3)') mate
114	jmc	1.1
115	jmc	1.2	C-- Seach for the same diag (with same freq) to see if already set
116			flag = .TRUE.
117			DO l=1,listId
118	jmc	1.4	IF (flag .AND. freq(l) .EQ.freq(listId)
119			& .AND. phase(l).EQ.phase(listId)
120			& .AND. averageFreq(l) .EQ.averageFreq(listId)
121			& .AND. averagePhase(l).EQ.averagePhase(listId)
122			& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
123	jmc	1.2	DO k=1,MIN(nActive(l),numperlist)
124			IF (flag .AND. jdiag(k,l).GT.0) THEN
125			IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN
126			C- diagnostics already set ; use the same slot:
127			flag = .FALSE.
128			mdiag(mId,listId) = ABS(idiag(k,l))
129			ENDIF
130			ENDIF
131			ENDDO
132			ENDIF
133			ENDDO
134
135			IF ( flag ) THEN
136	jmc	1.4	mdiag(mId,listId) = ndiagmx + 1
137			ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId)
138			IF ( ndiagmx.GT.numdiags ) THEN
139	jmc	1.2	WRITE(msgBuf,'(A,I4,1X,A)')
140			& 'SETDIAG: Not enough space for Counter Diagnostic #',
141			& mate, cdiag(mate)
142	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
143			ELSE
144	jmc	1.4	WRITE(msgBuf,'(A,2(I3,A),I4,1X,A)') 'SETDIAG: Allocate',
145			& kdiag(mate), ' x', averageCycle(listId),
146			& ' Levels for Count.Diag #', mate, cdiag(mate)
147	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
148			ENDIF
149			ELSE
150	jmc	1.2	WRITE(msgBuf,'(A,I4,1X,2A)')
151	jmc	1.1	& '- NOTE - SETDIAG: Counter Diagnostic #', mate, cdiag(mate),
152			& ' has already been set'
153			CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
154			mate = 0
155			ENDIF
156			ENDIF
157
158			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
159			RETURN
160			END