46 |
C !LOCAL VARIABLES: |
C !LOCAL VARIABLES: |
47 |
C == Local variables == |
C == Local variables == |
48 |
INTEGER stdUnit, errUnit |
INTEGER stdUnit, errUnit |
49 |
INTEGER k, l |
INTEGER nn, k, l |
50 |
LOGICAL flag |
LOGICAL diagIsPP, flagD, flagP, flagM |
51 |
|
|
52 |
CHARACTER*10 gcode |
CHARACTER*10 gcode |
53 |
|
CHARACTER*18 tmpMsg |
54 |
CHARACTER*(MAX_LEN_MBUF) msgBuf |
CHARACTER*(MAX_LEN_MBUF) msgBuf |
55 |
|
|
|
|
|
56 |
C ********************************************************************** |
C ********************************************************************** |
57 |
C **** SET POINTERS FOR DIAGNOSTIC ndId **** |
C **** SET POINTERS FOR DIAGNOSTIC ndId **** |
58 |
C ********************************************************************** |
C ********************************************************************** |
59 |
|
|
|
gcode = gdiag(ndId)(1:10) |
|
60 |
stdUnit = standardMessageUnit |
stdUnit = standardMessageUnit |
61 |
errUnit = errorMessageUnit |
errUnit = errorMessageUnit |
62 |
|
|
63 |
C-- Seach for the same diag (with same freq) to see if already set |
C- Case of Post-Procesed diag, not filled up but computed from other diags: |
64 |
flag = .TRUE. |
diagIsPP = gdiag(ndId)(5:5).EQ.'P' |
65 |
DO l=1,listId |
|
66 |
IF (flag .AND. freq(l) .EQ. freq(listId) |
C--- Seach for the same diag (with same freq) to see if already set |
67 |
& .AND. phase(l).EQ.phase(listId) |
C do it recursively on Post-Processed diag dependance (=mate) |
68 |
& .AND. averageFreq(l) .EQ.averageFreq(listId) |
C until we find either one already set or a non Post-Processed diag |
69 |
& .AND. averagePhase(l).EQ.averagePhase(listId) |
flagD = .TRUE. |
70 |
& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN |
flagP = .TRUE. |
71 |
DO k=1,MIN(nActive(l),numperlist) |
nn = ndId |
72 |
IF (flag .AND. jdiag(k,l).GT.0) THEN |
DO WHILE ( flagP ) |
73 |
IF ( cdiag(ndId).EQ.cdiag(jdiag(k,l)) ) THEN |
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 |
C- diagnostics already set ; use the same slot: |
C- diagnostics already set ; use the same slot: |
83 |
flag = .FALSE. |
flagD = .FALSE. |
84 |
idiag(mId,listId) = -ABS(idiag(k,l)) |
idiag(mId,listId) = -ABS(idiag(k,l)) |
85 |
mdiag(mId,listId) = mdiag(k,l) |
mdiag(mId,listId) = mdiag(k,l) |
86 |
ENDIF |
ENDIF |
87 |
|
ENDIF |
88 |
|
ENDDO |
89 |
ENDIF |
ENDIF |
90 |
ENDDO |
ENDDO |
91 |
ENDIF |
flagP = flagD .AND. gdiag(nn)(5:5).EQ.'P' |
92 |
|
IF ( flagP ) nn = hdiag(nn) |
93 |
ENDDO |
ENDDO |
94 |
|
|
95 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
C--- Set pointer if not already set, otherwise just print a message |
96 |
|
|
97 |
IF ( flag ) THEN |
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 |
idiag(mId,listId) = ndiagmx + 1 |
idiag(mId,listId) = ndiagmx + 1 |
106 |
ndiagmx = ndiagmx + kdiag(ndId)*averageCycle(listId) |
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 |
IF ( ndiagmx.GT.numDiags ) THEN |
IF ( ndiagmx.GT.numDiags ) THEN |
118 |
WRITE(msgBuf,'(A,I6,1X,A)') |
WRITE(msgBuf,'(A,I6,1X,A)') |
119 |
& 'SETDIAG: Not enough space for Diagnostic #',ndId,cdiag(ndId) |
& 'SETDIAG: Not enough space for Diagnostic #',nn,cdiag(nn) |
120 |
CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid) |
CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid) |
121 |
ELSE |
ELSE |
122 |
WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate', |
WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate', |
123 |
& kdiag(ndId), ' x', averageCycle(listId), |
& kdiag(nn), ' x', averageCycle(listId), |
124 |
& ' Levels for Diagnostic #', ndId, cdiag(ndId) |
& ' Levels for Diagnostic #', nn, cdiag(nn) |
125 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
126 |
ENDIF |
ENDIF |
127 |
ELSE |
ELSE |
128 |
WRITE(msgBuf,'(A,I6,1X,2A)') |
WRITE(msgBuf,'(A,I6,1X,2A)') '- NOTE - SETDIAG: Diagnostic #', |
129 |
& '- NOTE - SETDIAG: Diagnostic #', ndId, cdiag(ndId), |
& nn, cdiag(nn), ' is already set' |
|
& ' has already been set' |
|
130 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
131 |
ENDIF |
ENDIF |
132 |
|
|
133 |
C Check for Counter Diagnostic |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
134 |
|
|
135 |
|
C--- Check for Counter Diagnostic |
136 |
mate = 0 |
mate = 0 |
137 |
|
|
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 |
IF ( gcode(5:5).EQ.'C') THEN |
IF ( gcode(5:5).EQ.'C') THEN |
144 |
mate = hdiag(ndId) |
mate = hdiag(nn) |
145 |
|
tmpMsg = 'Counter Diagnostic' |
146 |
|
ENDIF |
147 |
|
|
148 |
|
IF ( mate.GT.0 ) THEN |
149 |
C-- Seach for the same diag (with same freq) to see if already set |
C-- Seach for the same diag (with same freq) to see if already set |
150 |
flag = .TRUE. |
flagM = .TRUE. |
151 |
DO l=1,listId |
DO l=1,listId |
152 |
IF (flag .AND. freq(l) .EQ.freq(listId) |
IF (flagM .AND. freq(l) .EQ.freq(listId) |
153 |
& .AND. phase(l).EQ.phase(listId) |
& .AND. phase(l).EQ.phase(listId) |
154 |
& .AND. averageFreq(l) .EQ.averageFreq(listId) |
& .AND. averageFreq(l) .EQ.averageFreq(listId) |
155 |
& .AND. averagePhase(l).EQ.averagePhase(listId) |
& .AND. averagePhase(l).EQ.averagePhase(listId) |
156 |
& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN |
& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN |
157 |
DO k=1,MIN(nActive(l),numperlist) |
DO k=1,MIN(nActive(l),numperList) |
158 |
IF (flag .AND. jdiag(k,l).GT.0) THEN |
IF (flagM .AND. jdiag(k,l).GT.0) THEN |
159 |
IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN |
IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN |
160 |
C- diagnostics already set ; use the same slot: |
C- diagnostics already set ; use the same slot: |
161 |
flag = .FALSE. |
flagM = .FALSE. |
162 |
mdiag(mId,listId) = ABS(idiag(k,l)) |
mdiag(mId,listId) = ABS(idiag(k,l)) |
163 |
ENDIF |
ENDIF |
164 |
ENDIF |
ENDIF |
166 |
ENDIF |
ENDIF |
167 |
ENDDO |
ENDDO |
168 |
|
|
169 |
IF ( flag ) THEN |
C--- Set pointer if not already set, otherwise just print a message |
170 |
|
IF ( flagM ) THEN |
171 |
mdiag(mId,listId) = ndiagmx + 1 |
mdiag(mId,listId) = ndiagmx + 1 |
172 |
|
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 |
ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId) |
ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId) |
181 |
IF ( ndiagmx.GT.numDiags ) THEN |
IF ( ndiagmx.GT.numDiags ) THEN |
182 |
WRITE(msgBuf,'(A,I6,1X,A)') |
WRITE(msgBuf,'(3A,I6,1X,A)') |
183 |
& 'SETDIAG: Not enough space for Counter Diagnostic #', |
& 'SETDIAG: Not enough space for ',tmpMsg,' #', |
184 |
& mate, cdiag(mate) |
& mate, cdiag(mate) |
185 |
CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid) |
CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid) |
186 |
ELSE |
ELSE |
187 |
WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate', |
WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate', |
188 |
& kdiag(mate), ' x', averageCycle(listId), |
& kdiag(mate), ' x', averageCycle(listId), |
189 |
& ' Levels for Count.Diag #', mate, cdiag(mate) |
& ' Levels for Mate Diag. #', mate, cdiag(mate) |
190 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
191 |
ENDIF |
ENDIF |
192 |
ELSE |
ELSE |
193 |
WRITE(msgBuf,'(A,I6,1X,2A)') |
WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg, |
194 |
& '- NOTE - SETDIAG: Counter Diagnostic #', mate, cdiag(mate), |
& ' #', mate, cdiag(mate), ' is already set' |
|
& ' has already been set' |
|
195 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
|
mate = 0 |
|
196 |
ENDIF |
ENDIF |
197 |
ENDIF |
ENDIF |
198 |
|
|