pkg/diagnostics/diagnostics_setdiag.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.1 2004/12/13 21:43:54 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*3 mate_index
      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) ) 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
        IF (ndiagmx+kdiag(ndId).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,I3,A,I4,1X,A)') 'SETDIAG: Allocate',
     &    kdiag(ndId), ' Levels for Diagnostic #', ndId, cdiag(ndId)
         CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
        ENDIF
        idiag(mId,listId) = ndiagmx + 1
        ndiagmx = ndiagmx + kdiag(ndId)
      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)
        RETURN
      ENDIF

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