/[MITgcm]/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F
ViewVC logotype

Contents of /MITgcm/pkg/diagnostics/diagnostics_set_pointers.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.11 - (show annotations) (download)
Thu Oct 30 18:52:54 2008 UTC (15 years, 6 months ago) by dfer
Branch: MAIN
CVS Tags: checkpoint61f, checkpoint61g, checkpoint61n, checkpoint61o, checkpoint61l, checkpoint61m, checkpoint61j, checkpoint61k, checkpoint61h, checkpoint61i
Changes since 1.10: +2 -2 lines
Fixing bug + retiring KPPmld diagnostic

1 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.10 2008/02/05 15:13:01 jmc Exp $
2 C $Name: $
3
4 #include "DIAG_OPTIONS.h"
5
6 CBOP
7 C !ROUTINE: DIAGNOSTICS_SET_POINTERS
8 C !INTERFACE:
9 SUBROUTINE DIAGNOSTICS_SET_POINTERS( myThid )
10
11 C !DESCRIPTION: \bv
12 C *==================================================================
13 C | S/R DIAGNOSTICS_SET_POINTERS
14 C | o set pointers for active diagnostics
15 C *==================================================================
16 C \ev
17
18 C !USES:
19 IMPLICIT NONE
20
21 C == Global variables ===
22 #include "EEPARAMS.h"
23 #include "SIZE.h"
24 #include "DIAGNOSTICS_SIZE.h"
25 #include "DIAGNOSTICS.h"
26
27 C !INPUT/OUTPUT PARAMETERS:
28 C == Routine arguments ==
29 C myThid - Thread number for this instance of the routine.
30 INTEGER myThid
31 CEOP
32
33 C !LOCAL VARIABLES:
34 C == Local variables ==
35 INTEGER ndiagcount, ndCount
36 INTEGER md,ld,nd
37 INTEGER mate, nActiveMax
38 INTEGER i, j, k, k1, k2, mm, kLev
39 LOGICAL found
40 CHARACTER*(MAX_LEN_MBUF) msgBuf
41
42 _BEGIN_MASTER( myThid)
43
44 C-- Initialize pointer arrays to zero:
45 DO ld=1,numlists
46 DO md=1,numperlist
47 idiag(md,ld) = 0
48 jdiag(md,ld) = 0
49 mdiag(md,ld) = 0
50 ENDDO
51 ENDDO
52
53 C-- Calculate pointers for diagnostics in active output-stream
54 C (i.e., with defined filename)
55
56 ndiagcount = 0
57 nActiveMax = 0
58 DO ld=1,nlists
59 nActive(ld) = nfields(ld)
60 DO md=1,nfields(ld)
61
62 found = .FALSE.
63 C Search all possible model diagnostics
64 DO nd=1,ndiagt
65 IF ( flds(md,ld).EQ.cdiag(nd) ) THEN
66 CALL DIAGNOSTICS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
67 found = .TRUE.
68 jdiag(md,ld) = nd
69 ENDIF
70 ENDDO
71 IF ( .NOT.found ) THEN
72 CALL DIAGNOSTICS_LIST_CHECK(
73 O ndCount,
74 I ld, md, nlists, nfields, flds, myThid )
75 IF ( ndCount.EQ.0 ) THEN
76 WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
77 & flds(md,ld),' is not a Diagnostic'
78 CALL PRINT_ERROR( msgBuf , myThid )
79 ENDIF
80 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
81 ENDIF
82 IF ( found .AND. mate.GE.1 ) THEN
83 mm = nActive(ld) + 1
84 IF ( mm.LE.numperlist ) THEN
85 jdiag(mm,ld) = mate
86 idiag(mm,ld) = mdiag(md,ld)
87 flds (mm,ld) = cdiag(mate)
88 ENDIF
89 nActive(ld) = mm
90 ENDIF
91
92 ENDDO
93 nActiveMax = MAX(nActive(ld),nActiveMax)
94 ENDDO
95
96 IF ( ndiagcount.LE.numDiags .AND.
97 & nActiveMax.LE.numperlist ) THEN
98 WRITE(msgBuf,'(A,I8,A)')
99 & ' space allocated for all diagnostics:',
100 & ndiagcount, ' levels'
101 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
102 & SQUEEZE_RIGHT , myThid)
103 ELSE
104 IF ( ndiagcount.GT.numDiags ) THEN
105 WRITE(msgBuf,'(2A)')
106 & 'DIAGNOSTICS_SET_POINTERS: Not enough space',
107 & ' for all active diagnostics (from data.diagnostics)'
108 CALL PRINT_ERROR( msgBuf , myThid )
109 WRITE(msgBuf,'(A,I8,A,I8)')
110 & 'DIAGNOSTICS_SET_POINTERS: numDiags=', numDiags,
111 & ' but needs at least', ndiagcount
112 CALL PRINT_ERROR( msgBuf , myThid )
113 ENDIF
114 IF ( nActiveMax.GT.numperlist ) THEN
115 WRITE(msgBuf,'(2A)')
116 & 'DIAGNOSTICS_SET_POINTERS: Not enough space',
117 & ' for all active diagnostics (from data.diagnostics)'
118 CALL PRINT_ERROR( msgBuf , myThid )
119 WRITE(msgBuf,'(A,I6,A,I6)')
120 & 'DIAGNOSTICS_SET_POINTERS: numperlist=', numperlist,
121 & ' but needs at least', nActiveMax
122 CALL PRINT_ERROR( msgBuf , myThid )
123 ENDIF
124 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
125 ENDIF
126
127 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
128 C-- Set pointer for mate (e.g.vector component mate) if not already done
129 C and if it exists. Note: for now, only used to print message.
130 DO ld=1,nlists
131 DO md=1,nActive(ld)
132 IF (mdiag(md,ld).EQ.0 ) THEN
133
134 nd = jdiag(md,ld)
135 mate = hdiag(nd)
136 IF ( mate.GT.0 ) THEN
137 DO j=1,nlists
138 DO i=1,nActive(j)
139 IF ( mdiag(md,ld).EQ.0 .AND. jdiag(i,j).EQ.mate ) THEN
140 mdiag(md,ld) = ABS(idiag(i,j))
141 ENDIF
142 ENDDO
143 ENDDO
144 ENDIF
145 IF ( mdiag(md,ld).NE.0 ) THEN
146 WRITE(msgBuf,'(A,I6,5A,I6)') ' set mate pointer for diag #',
147 & nd, ' ', cdiag(nd), ' , Parms: ', gdiag(nd)(1:10),
148 & ' , mate:', hdiag(nd)
149 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
150 & SQUEEZE_RIGHT , myThid)
151 ENDIF
152
153 ENDIF
154 ENDDO
155 ENDDO
156
157 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
158 C-- Set list of levels to write (if not specified in data.diagnostics)
159
160 DO ld=1,nlists
161 IF ( nlevels(ld).EQ.-1 ) THEN
162 C- set Nb of levels to the minimum size of all diag of this list:
163 kLev = numLevels
164 DO md=1,nfields(ld)
165 nd = jdiag(md,ld)
166 kLev = MIN(kdiag(nd),kLev)
167 ENDDO
168 IF ( kLev.LE.0 ) THEN
169 WRITE(msgBuf,'(2A,I6,2A)')
170 & 'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',
171 & ' setting levs of list l=',ld,', fnames: ', fnames(ld)
172 CALL PRINT_ERROR( msgBuf , myThid )
173 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
174 ENDIF
175 nlevels(ld) = kLev
176 DO k=1,kLev
177 levs(k,ld) = k
178 ENDDO
179 WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
180 & 'Set levels for Outp.Stream: ',fnames(ld)
181 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
182 & SQUEEZE_RIGHT, myThid)
183 DO k1=1,nlevels(ld),20
184 k2 = MIN(nlevels(ld),k1+19)
185 WRITE(msgBuf,'(A,20F5.0)')
186 & ' Levels: ', (levs(k,ld),k=k1,k2)
187 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
188 & SQUEEZE_RIGHT, myThid)
189 ENDDO
190 ELSEIF ( fflags(ld)(2:2).NE.'P' ) THEN
191 C- if no Vert.Interpolation, check for levels out of range ( > kdiag):
192 kLev = 0
193 DO k=1,nlevels(ld)
194 kLev = MAX(NINT(levs(k,ld)),kLev)
195 ENDDO
196 DO md=1,nfields(ld)
197 nd = jdiag(md,ld)
198 IF ( kLev.GT.kdiag(nd) ) THEN
199 C- Note: diagnostics_out take care (in some way) of this case
200 C so that it does not cause "index out-off bounds" error.
201 C However, the output file looks strange.
202 C- For now, choose to stop, but could change it to just a warning
203 WRITE(msgBuf,'(A,I4,A,I6,2A)')
204 & 'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
205 & ' in list l=', ld, ', filename: ', fnames(ld)
206 CALL PRINT_ERROR( msgBuf , myThid )
207 WRITE(msgBuf,'(2A,I4,A,I6,2A)')
208 & 'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
209 & '(=',kdiag(nd),') for Diag. #', nd, ' : ',cdiag(nd)
210 CALL PRINT_ERROR( msgBuf , myThid )
211 WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
212 & ' parsing code >>',gdiag(nd),'<<'
213 CALL PRINT_ERROR( msgBuf , myThid )
214 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
215 ENDIF
216 ENDDO
217 ENDIF
218 ENDDO
219
220 WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
221 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
222 & SQUEEZE_RIGHT , myThid)
223 WRITE(msgBuf,'(2A)')
224 & '------------------------------------------------------------'
225 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
226 & SQUEEZE_RIGHT , myThid)
227
228 _END_MASTER( myThid )
229
230 RETURN
231 END

  ViewVC Help
Powered by ViewVC 1.1.22