1 |
C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_setdiag.F,v 1.9 2011/07/01 18:26:54 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, no_hFac |
50 |
LOGICAL diagIsPP, flagD, flagP, flagM, use_hFac |
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- 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 |
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 |
IF ( flagD .AND. no_hFac*jdiag(k,l).GT.0 ) THEN |
93 |
IF ( cdiag(nn).EQ.cdiag(ABS(jdiag(k,l))) ) THEN |
94 |
C- diagnostics already set ; use the same slot: |
95 |
flagD = .FALSE. |
96 |
idiag(mId,listId) = -ABS(idiag(k,l)) |
97 |
mdiag(mId,listId) = mdiag(k,l) |
98 |
ENDIF |
99 |
ENDIF |
100 |
ENDDO |
101 |
ENDIF |
102 |
ENDDO |
103 |
flagP = flagD .AND. gdiag(nn)(5:5).EQ.'P' |
104 |
IF ( flagP ) nn = hdiag(nn) |
105 |
ENDDO |
106 |
jdiag(mId,listId) = no_hFac*ndId |
107 |
|
108 |
C--- Set pointer if not already set, otherwise just print a message |
109 |
|
110 |
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 |
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 |
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 |
ELSE |
131 |
idiag(mId,listId) = ndiagmx + 1 |
132 |
ENDIF |
133 |
ndiagmx = ndiagmx + kdiag(nn)*averageCycle(listId) |
134 |
IF ( ndiagmx.GT.numDiags ) THEN |
135 |
WRITE(msgBuf,'(A,I6,1X,A)') |
136 |
& 'SETDIAG: Not enough space for Diagnostic #',nn,cdiag(nn) |
137 |
CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid) |
138 |
ELSE |
139 |
WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate', |
140 |
& kdiag(nn), ' x', averageCycle(listId), |
141 |
& ' Levels for Diagnostic #', nn, cdiag(nn) |
142 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
143 |
ENDIF |
144 |
ELSE |
145 |
tmpMsg = ' Diagnostic ' |
146 |
WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg, |
147 |
& ' #', nn, cdiag(nn), ' is already set' |
148 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
149 |
ENDIF |
150 |
|
151 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
152 |
|
153 |
C--- Check for Counter Diagnostic |
154 |
mate = 0 |
155 |
|
156 |
C- if Post-Processed diag, activate 2nd components of vector field |
157 |
tmpMsg = ' Vector-mate' |
158 |
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 |
IF ( gcode(5:5).EQ.'C') THEN |
162 |
mate = hdiag(nn) |
163 |
tmpMsg = 'Counter-mate' |
164 |
ENDIF |
165 |
|
166 |
IF ( mate.GT.0 ) THEN |
167 |
C-- Seach for the same diag (with same freq) to see if already set |
168 |
flagM = .TRUE. |
169 |
DO l=1,listId |
170 |
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 |
IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN |
178 |
C- diagnostics already set ; use the same slot: |
179 |
flagM = .FALSE. |
180 |
mdiag(mId,listId) = ABS(idiag(k,l)) |
181 |
ENDIF |
182 |
ENDIF |
183 |
ENDDO |
184 |
ENDIF |
185 |
ENDDO |
186 |
|
187 |
C--- Set pointer if not already set, otherwise just print a message |
188 |
IF ( flagM ) THEN |
189 |
mdiag(mId,listId) = ndiagmx + 1 |
190 |
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 |
ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId) |
199 |
IF ( ndiagmx.GT.numDiags ) THEN |
200 |
WRITE(msgBuf,'(3A,I6,1X,A)') |
201 |
& 'SETDIAG: Not enough space for ',tmpMsg,' #', |
202 |
& mate, cdiag(mate) |
203 |
CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid) |
204 |
ELSE |
205 |
WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate', |
206 |
& kdiag(mate), ' x', averageCycle(listId), |
207 |
& ' Levels for Mate Diag. #', mate, cdiag(mate) |
208 |
CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid) |
209 |
ENDIF |
210 |
ELSE |
211 |
WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg, |
212 |
& ' #', mate, cdiag(mate), ' is already set' |
213 |
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 |