pkg/diagnostics/diagnostics_setdiag.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.9 2011/07/01 18:26: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 nn, k, l, no_hFac
      LOGICAL diagIsPP, flagD, flagP, flagM, use_hFac

      CHARACTER*10 gcode
      CHARACTER*12 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-    Register negative "jdiag" when cumulating thickness (hFac) weighted field
      no_hFac = 1
      IF ( fflags(listId)(3:3).EQ.'h' ) THEN
        gcode = gdiag(ndId)(1:10)
        use_hFac = ( gcode(2:2).EQ.'U' .OR. gcode(2:2).EQ.'V'
     &                                 .OR. gcode(2:2).EQ.'M' )
        use_hFac = use_hFac .AND. gcode(9:10).EQ.'MR'
     &                      .AND. gcode(3:3).EQ.'R'
     &                      .AND. gcode(5:5).EQ.' '
        IF ( use_hFac ) no_hFac = -1
      ENDIF

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. no_hFac*jdiag(k,l).GT.0 ) THEN
            IF ( cdiag(nn).EQ.cdiag(ABS(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
      jdiag(mId,listId) = no_hFac*ndId

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
        tmpMsg = ' Diagnostic '
        WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
     &           ' #', 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'
      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-mate'
      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.10	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.9 2011/07/01 18:26: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.10	INTEGER nn, k, l, no_hFac
50			LOGICAL diagIsPP, flagD, flagP, flagM, use_hFac
51	jmc	1.1
52	jmc	1.5	CHARACTER*10 gcode
53	jmc	1.9	CHARACTER*12 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	jmc	1.10	C- Register negative "jdiag" when cumulating thickness (hFac) weighted field
67			no_hFac = 1
68			IF ( fflags(listId)(3:3).EQ.'h' ) THEN
69			gcode = gdiag(ndId)(1:10)
70			use_hFac = ( gcode(2:2).EQ.'U' .OR. gcode(2:2).EQ.'V'
71			& .OR. gcode(2:2).EQ.'M' )
72			use_hFac = use_hFac .AND. gcode(9:10).EQ.'MR'
73			& .AND. gcode(3:3).EQ.'R'
74			& .AND. gcode(5:5).EQ.' '
75			IF ( use_hFac ) no_hFac = -1
76			ENDIF
77
78	jmc	1.7	C--- Seach for the same diag (with same freq) to see if already set
79			C do it recursively on Post-Processed diag dependance (=mate)
80			C until we find either one already set or a non Post-Processed diag
81			flagD = .TRUE.
82			flagP = .TRUE.
83			nn = ndId
84			DO WHILE ( flagP )
85			DO l=1,listId
86			IF (flagD .AND. freq(l) .EQ. freq(listId)
87			& .AND. phase(l).EQ.phase(listId)
88			& .AND. averageFreq(l) .EQ.averageFreq(listId)
89			& .AND. averagePhase(l).EQ.averagePhase(listId)
90			& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
91			DO k=1,MIN(nActive(l),numperList)
92	jmc	1.10	IF ( flagD .AND. no_hFac*jdiag(k,l).GT.0 ) THEN
93			IF ( cdiag(nn).EQ.cdiag(ABS(jdiag(k,l))) ) THEN
94	jmc	1.2	C- diagnostics already set ; use the same slot:
95	jmc	1.7	flagD = .FALSE.
96			idiag(mId,listId) = -ABS(idiag(k,l))
97			mdiag(mId,listId) = mdiag(k,l)
98			ENDIF
99			ENDIF
100			ENDDO
101	jmc	1.2	ENDIF
102			ENDDO
103	jmc	1.7	flagP = flagD .AND. gdiag(nn)(5:5).EQ.'P'
104			IF ( flagP ) nn = hdiag(nn)
105	jmc	1.2	ENDDO
106	jmc	1.10	jdiag(mId,listId) = no_hFac*ndId
107	jmc	1.2
108	jmc	1.7	C--- Set pointer if not already set, otherwise just print a message
109	jmc	1.2
110	jmc	1.7	IF ( diagIsPP ) THEN
111			WRITE(msgBuf,'(2(A,I6,1X,A))')
112			& 'SETDIAG: Diag #', ndId, cdiag(ndId),
113			& ' processed from Diag #',nn,cdiag(nn)
114			CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
115			ENDIF
116			gcode = gdiag(nn)(1:10)
117			IF ( flagD ) THEN
118			IF ( diagIsPP ) THEN
119	jmc	1.8	C- Add this diag with negative idiag pointer (since those 2 diags
120			C share the same pointer and "nn" will get the positive pointer).
121			idiag(mId,listId) = -(ndiagmx+1)
122	jmc	1.7	C- Also add "nn" to the Active list
123			k = nActive(listId) + 1
124			IF ( k.LE.numperList ) THEN
125			jdiag(k,listId) = nn
126			idiag(k,listId) = ndiagmx + 1
127			flds (k,listId) = cdiag(nn)
128			ENDIF
129			nActive(listId) = k
130	jmc	1.8	ELSE
131			idiag(mId,listId) = ndiagmx + 1
132	jmc	1.7	ENDIF
133			ndiagmx = ndiagmx + kdiag(nn)*averageCycle(listId)
134	jmc	1.5	IF ( ndiagmx.GT.numDiags ) THEN
135			WRITE(msgBuf,'(A,I6,1X,A)')
136	jmc	1.7	& 'SETDIAG: Not enough space for Diagnostic #',nn,cdiag(nn)
137	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
138			ELSE
139	jmc	1.5	WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
140	jmc	1.7	& kdiag(nn), ' x', averageCycle(listId),
141			& ' Levels for Diagnostic #', nn, cdiag(nn)
142	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
143			ENDIF
144			ELSE
145	jmc	1.9	tmpMsg = ' Diagnostic '
146			WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
147			& ' #', nn, cdiag(nn), ' is already set'
148	jmc	1.6	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
149	jmc	1.1	ENDIF
150
151	jmc	1.7	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
152	jmc	1.6
153	jmc	1.7	C--- Check for Counter Diagnostic
154	jmc	1.1	mate = 0
155	jmc	1.7
156			C- if Post-Processed diag, activate 2nd components of vector field
157	jmc	1.9	tmpMsg = ' Vector-mate'
158	jmc	1.7	IF ( diagIsPP .AND. gcode(5:5).NE.'P' .AND.
159			& (gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V') ) mate = hdiag(nn)
160			C- activate mate if this is a Counter Diagnostic
161	jmc	1.5	IF ( gcode(5:5).EQ.'C') THEN
162	jmc	1.7	mate = hdiag(nn)
163	jmc	1.9	tmpMsg = 'Counter-mate'
164	jmc	1.7	ENDIF
165	jmc	1.1
166	jmc	1.7	IF ( mate.GT.0 ) THEN
167	jmc	1.2	C-- Seach for the same diag (with same freq) to see if already set
168	jmc	1.7	flagM = .TRUE.
169	jmc	1.2	DO l=1,listId
170	jmc	1.7	IF (flagM .AND. freq(l) .EQ.freq(listId)
171			& .AND. phase(l).EQ.phase(listId)
172			& .AND. averageFreq(l) .EQ.averageFreq(listId)
173			& .AND. averagePhase(l).EQ.averagePhase(listId)
174			& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
175			DO k=1,MIN(nActive(l),numperList)
176			IF (flagM .AND. jdiag(k,l).GT.0) THEN
177	jmc	1.2	IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN
178			C- diagnostics already set ; use the same slot:
179	jmc	1.7	flagM = .FALSE.
180	jmc	1.2	mdiag(mId,listId) = ABS(idiag(k,l))
181			ENDIF
182			ENDIF
183			ENDDO
184			ENDIF
185			ENDDO
186
187	jmc	1.7	C--- Set pointer if not already set, otherwise just print a message
188			IF ( flagM ) THEN
189	jmc	1.4	mdiag(mId,listId) = ndiagmx + 1
190	jmc	1.7	k = nActive(listId) + 1
191			IF ( k.LE.numperList ) THEN
192			C- Also add mate to the Active list
193			jdiag(k,listId) = mate
194			idiag(k,listId) = ndiagmx + 1
195			flds (k,listId) = cdiag(mate)
196			ENDIF
197			nActive(listId) = k
198	jmc	1.4	ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId)
199	jmc	1.5	IF ( ndiagmx.GT.numDiags ) THEN
200	jmc	1.7	WRITE(msgBuf,'(3A,I6,1X,A)')
201			& 'SETDIAG: Not enough space for ',tmpMsg,' #',
202	jmc	1.2	& mate, cdiag(mate)
203	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
204			ELSE
205	jmc	1.5	WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
206	jmc	1.4	& kdiag(mate), ' x', averageCycle(listId),
207	jmc	1.7	& ' Levels for Mate Diag. #', mate, cdiag(mate)
208	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
209			ENDIF
210			ELSE
211	jmc	1.7	WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
212			& ' #', mate, cdiag(mate), ' is already set'
213	jmc	1.1	CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
214			ENDIF
215			ENDIF
216
217			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
218			RETURN
219			END