1 |
C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.8 2011/06/29 22:03:56 jmc Exp $ |
2 |
C $Name: $ |
3 |
|
4 |
#include "DIAG_OPTIONS.h" |
5 |
|
6 |
CBOP |
7 |
C !ROUTINE: DIAGNOSTICS_SETDIAG |
8 |
C !INTERFACE: |
9 |
SUBROUTINE DIAGNOSTICS_SETDIAG( |
10 |
O mate, |
11 |
U ndiagmx, |
12 |
I mId, listId, ndId, myThid ) |
13 |
|
14 |
C !DESCRIPTION: \bv |
15 |
C *================================================================== |
16 |
C | S/R DIAGNOSTICS_SETDIAG |
17 |
C | o activate diagnostic "ndId": |
18 |
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 |
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 |
INTEGER mate |
41 |
INTEGER ndiagmx |
42 |
INTEGER mId, listId, ndId |
43 |
INTEGER myThid |
44 |
CEOP |
45 |
|
46 |
C !LOCAL VARIABLES: |
47 |
C == Local variables == |
48 |
INTEGER stdUnit, errUnit |
49 |
INTEGER nn, k, l |
50 |
LOGICAL diagIsPP, flagD, flagP, flagM |
51 |
|
52 |
CHARACTER*10 gcode |
53 |
CHARACTER*12 tmpMsg |
54 |
CHARACTER*(MAX_LEN_MBUF) msgBuf |
55 |
|
56 |
C ********************************************************************** |
57 |
C **** SET POINTERS FOR DIAGNOSTIC ndId **** |
58 |
C ********************************************************************** |
59 |
|
60 |
stdUnit = standardMessageUnit |
61 |
errUnit = errorMessageUnit |
62 |
|
63 |
C- Case of Post-Procesed diag, not filled up but computed from other diags: |
64 |
diagIsPP = gdiag(ndId)(5:5).EQ.'P' |
65 |
|
66 |
C--- Seach for the same diag (with same freq) to see if already set |
67 |
C do it recursively on Post-Processed diag dependance (=mate) |
68 |
C until we find either one already set or a non Post-Processed diag |
69 |
flagD = .TRUE. |
70 |
flagP = .TRUE. |
71 |
nn = ndId |
72 |
DO WHILE ( flagP ) |
73 |
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: |
83 |
flagD = .FALSE. |
84 |
idiag(mId,listId) = -ABS(idiag(k,l)) |
85 |
mdiag(mId,listId) = mdiag(k,l) |
86 |
ENDIF |
87 |
ENDIF |
88 |
ENDDO |
89 |
ENDIF |
90 |
ENDDO |
91 |
flagP = flagD .AND. gdiag(nn)(5:5).EQ.'P' |
92 |
IF ( flagP ) nn = hdiag(nn) |
93 |
ENDDO |
94 |
|
95 |
C--- Set pointer if not already set, otherwise just print a message |
96 |
|
97 |
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 |
IF ( diagIsPP ) THEN |
106 |
C- Add this diag with negative idiag pointer (since those 2 diags |
107 |
C share the same pointer and "nn" will get the positive pointer). |
108 |
idiag(mId,listId) = -(ndiagmx+1) |
109 |
C- Also add "nn" to the Active list |
110 |
k = nActive(listId) + 1 |
111 |
IF ( k.LE.numperList ) THEN |
112 |
jdiag(k,listId) = nn |
113 |
idiag(k,listId) = ndiagmx + 1 |
114 |
flds (k,listId) = cdiag(nn) |
115 |
ENDIF |
116 |
nActive(listId) = k |
117 |
ELSE |
118 |
idiag(mId,listId) = ndiagmx + 1 |
119 |
ENDIF |
120 |
ndiagmx = ndiagmx + kdiag(nn)*averageCycle(listId) |
121 |
IF ( ndiagmx.GT.numDiags ) THEN |
122 |
WRITE(msgBuf,'(A,I6,1X,A)') |
123 |
& 'SETDIAG: Not enough space for Diagnostic #',nn,cdiag(nn) |
124 |
CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid) |
125 |
ELSE |
126 |
WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate', |
127 |
& kdiag(nn), ' x', averageCycle(listId), |
128 |
& ' Levels for Diagnostic #', nn, cdiag(nn) |
129 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
130 |
ENDIF |
131 |
ELSE |
132 |
tmpMsg = ' Diagnostic ' |
133 |
WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg, |
134 |
& ' #', nn, cdiag(nn), ' is already set' |
135 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
136 |
ENDIF |
137 |
|
138 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
139 |
|
140 |
C--- Check for Counter Diagnostic |
141 |
mate = 0 |
142 |
|
143 |
C- if Post-Processed diag, activate 2nd components of vector field |
144 |
tmpMsg = ' Vector-mate' |
145 |
IF ( diagIsPP .AND. gcode(5:5).NE.'P' .AND. |
146 |
& (gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V') ) mate = hdiag(nn) |
147 |
C- activate mate if this is a Counter Diagnostic |
148 |
IF ( gcode(5:5).EQ.'C') THEN |
149 |
mate = hdiag(nn) |
150 |
tmpMsg = 'Counter-mate' |
151 |
ENDIF |
152 |
|
153 |
IF ( mate.GT.0 ) THEN |
154 |
C-- Seach for the same diag (with same freq) to see if already set |
155 |
flagM = .TRUE. |
156 |
DO l=1,listId |
157 |
IF (flagM .AND. freq(l) .EQ.freq(listId) |
158 |
& .AND. phase(l).EQ.phase(listId) |
159 |
& .AND. averageFreq(l) .EQ.averageFreq(listId) |
160 |
& .AND. averagePhase(l).EQ.averagePhase(listId) |
161 |
& .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN |
162 |
DO k=1,MIN(nActive(l),numperList) |
163 |
IF (flagM .AND. jdiag(k,l).GT.0) THEN |
164 |
IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN |
165 |
C- diagnostics already set ; use the same slot: |
166 |
flagM = .FALSE. |
167 |
mdiag(mId,listId) = ABS(idiag(k,l)) |
168 |
ENDIF |
169 |
ENDIF |
170 |
ENDDO |
171 |
ENDIF |
172 |
ENDDO |
173 |
|
174 |
C--- Set pointer if not already set, otherwise just print a message |
175 |
IF ( flagM ) THEN |
176 |
mdiag(mId,listId) = ndiagmx + 1 |
177 |
k = nActive(listId) + 1 |
178 |
IF ( k.LE.numperList ) THEN |
179 |
C- Also add mate to the Active list |
180 |
jdiag(k,listId) = mate |
181 |
idiag(k,listId) = ndiagmx + 1 |
182 |
flds (k,listId) = cdiag(mate) |
183 |
ENDIF |
184 |
nActive(listId) = k |
185 |
ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId) |
186 |
IF ( ndiagmx.GT.numDiags ) THEN |
187 |
WRITE(msgBuf,'(3A,I6,1X,A)') |
188 |
& 'SETDIAG: Not enough space for ',tmpMsg,' #', |
189 |
& mate, cdiag(mate) |
190 |
CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid) |
191 |
ELSE |
192 |
WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate', |
193 |
& kdiag(mate), ' x', averageCycle(listId), |
194 |
& ' Levels for Mate Diag. #', mate, cdiag(mate) |
195 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
196 |
ENDIF |
197 |
ELSE |
198 |
WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg, |
199 |
& ' #', mate, cdiag(mate), ' is already set' |
200 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
201 |
ENDIF |
202 |
ENDIF |
203 |
|
204 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
205 |
RETURN |
206 |
END |