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

Diff of /MITgcm/pkg/diagnostics/diagnostics_utils.F

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

revision 1.22 by molod, Mon Jul 11 16:20:10 2005 UTC revision 1.32 by jmc, Wed Aug 14 00:54:06 2013 UTC
# Line 3  C $Name$ Line 3  C $Name$
3    
4  #include "DIAG_OPTIONS.h"  #include "DIAG_OPTIONS.h"
5    
6    C--   File diagnostics_utils.F: General purpose support routines
7    C--    Contents:
8    C--    o DIAGNOSTICS_COUNT
9    C--    o DIAGNOSTICS_GET_DIAG
10    C--    o DIAGNOSTICS_GET_POINTERS
11    C--    o DIAGNOSTICS_SETKLEV
12    C--    o DIAGS_GET_PARMS_I (Function)
13    C--    o DIAGS_MK_UNITS (Function)
14    C--    o DIAGS_MK_TITLE (Function)
15    
16  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
17    
18  CBOP 0  CBOP 0
19  C     !ROUTINE: GETDIAG  C     !ROUTINE: DIAGNOSTICS_COUNT
20    C     !INTERFACE:
21          SUBROUTINE DIAGNOSTICS_COUNT( diagName,
22         I                              biArg, bjArg, myThid )
23    
24    C     !DESCRIPTION:
25    C***********************************************************************
26    C   routine to increment the diagnostic counter only
27    C***********************************************************************
28    C     !USES:
29          IMPLICIT NONE
30    
31    C     == Global variables ===
32    #include "EEPARAMS.h"
33    #include "SIZE.h"
34    #include "DIAGNOSTICS_SIZE.h"
35    #include "DIAGNOSTICS.h"
36    
37    C     !INPUT PARAMETERS:
38    C***********************************************************************
39    C  Arguments Description
40    C  ----------------------
41    C     diagName :: name of diagnostic to increment the counter
42    C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
43    C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
44    C     myThid   :: my thread Id number
45    C***********************************************************************
46          CHARACTER*8 diagName
47          INTEGER biArg, bjArg
48          INTEGER myThid
49    CEOP
50    
51    C     !LOCAL VARIABLES:
52    C ===============
53          INTEGER m, n
54          INTEGER bi, bj
55          INTEGER ipt, ndId
56    c     CHARACTER*(MAX_LEN_MBUF) msgBuf
57    
58          IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
59            bi = myBxLo(myThid)
60            bj = myByLo(myThid)
61          ELSE
62            bi = MIN(biArg,nSx)
63            bj = MIN(bjArg,nSy)
64          ENDIF
65    
66    C--   Run through list of active diagnostics to find which counter
67    C     to increment (needs to be a valid & active diagnostic-counter)
68          DO n=1,nLists
69           DO m=1,nActive(n)
70            IF ( diagName.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
71             ipt = idiag(m,n)
72             IF (ndiag(ipt,bi,bj).GE.0) THEN
73              ndId = jdiag(m,n)
74              ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId)
75    C-    Increment the counter for the diagnostic
76              IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
77               DO bj=myByLo(myThid), myByHi(myThid)
78                DO bi=myBxLo(myThid), myBxHi(myThid)
79                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
80                ENDDO
81               ENDDO
82              ELSE
83                 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
84              ENDIF
85    C-    Increment is done
86             ENDIF
87            ENDIF
88           ENDDO
89          ENDDO
90    
91          RETURN
92          END
93    
94    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
95    
96    CBOP 0
97    C     !ROUTINE: DIAGNOSTICS_GET_DIAG
98    
99  C     !INTERFACE:  C     !INTERFACE:
100        SUBROUTINE GETDIAG(        SUBROUTINE DIAGNOSTICS_GET_DIAG(
101       I                    levreal, undef,       I                    kl, undefRL,
102       O                    qtmp,       O                    qtmp,
103       I                    ndId, mate, ip, im, bi, bj, myThid )       I                    ndId, mate, ip, im, bi, bj, myThid )
104    
105  C     !DESCRIPTION:  C     !DESCRIPTION:
106  C     Retrieve averaged model diagnostic  C     Retrieve time-averaged (or snap-shot) diagnostic field
107    
108  C     !USES:  C     !USES:
109        IMPLICIT NONE        IMPLICIT NONE
# Line 24  C     !USES: Line 113  C     !USES:
113  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
114    
115  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
116  C     levreal :: Diagnostic LEVEL  C     kl      :: level selection: >0 : single selected lev ; =0 : all kdiag levels
117  C     undef   :: UNDEFINED VALUE  C     undefRL :: undefined "_RL" type value
118  C     ndId    :: DIAGNOSTIC NUMBER FROM MENU  C     ndId    :: diagnostic Id number (in available diagnostics list)
119  C     mate    :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise  C     mate    :: counter diagnostic number if any ; 0 otherwise
120  C     ip      :: pointer to storage array location for diag.  C     ip      :: pointer to storage array location for diag.
121  C     im      :: pointer to storage array location for mate  C     im      :: pointer to storage array location for mate
122  C     bi      :: X-direction tile number  C     bi      :: X-direction tile number
123  C     bj      :: Y-direction tile number  C     bj      :: Y-direction tile number
124  C     myThid  :: my thread Id number  C     myThid  :: my thread Id number
125        _RL levreal        INTEGER kl
126        _RL undef        _RL undefRL
127        INTEGER ndId, mate, ip, im        INTEGER ndId, mate, ip, im
128        INTEGER bi,bj, myThid        INTEGER bi, bj, myThid
129    
130  C     !OUTPUT PARAMETERS:  C     !OUTPUT PARAMETERS:
131  C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY  C     qtmp    :: time-averaged (or snap-shot) diagnostic field
132        _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)        _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,*)
133  CEOP  CEOP
134    
135  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
136        _RL factor        _RL factor
137        INTEGER i, j, ipnt,ipCt        INTEGER i, j, ipnt, ipCt
138        INTEGER lev, levCt, klev        INTEGER k, kd, km, kLev
139    
140        IF (ndId.GE.1) THEN        IF (ndId.GE.1) THEN
141         lev = NINT(levreal)         kLev = kdiag(ndId)
142         klev = kdiag(ndId)         IF ( kl.GE.1 .AND. kl.LE.kLev ) THEN
143         IF (lev.LE.klev) THEN          kLev = 1
144           ELSEIF ( kl.NE.0 ) THEN
145            kLev = 0
146           ENDIF
147    
148           DO k = 1,kLev
149            kd = k
150            IF ( kl.GE.1 ) kd = kl
151    
152          IF ( mate.EQ.0 ) THEN          IF ( mate.EQ.0 ) THEN
153  C-      No counter diagnostics => average = Sum / ndiag :  C-      No counter diagnostics => average = Sum / ndiag :
154    
155            ipnt = ip + lev - 1            ipnt = ip + kd - 1
156            factor = FLOAT(ndiag(ip,bi,bj))            factor = FLOAT(ndiag(ip,bi,bj))
157            IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor            IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
158    
159    #ifdef ALLOW_FIZHI
160            DO j = 1,sNy+1            DO j = 1,sNy+1
161              DO i = 1,sNx+1              DO i = 1,sNx+1
162                IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN                IF ( qdiag(i,j,ipnt,bi,bj) .LE. undefRL ) THEN
163                  qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor                  qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
164                ELSE                ELSE
165                  qtmp(i,j) = undef                  qtmp(i,j,k) = undefRL
166                ENDIF                ENDIF
167              ENDDO              ENDDO
168            ENDDO            ENDDO
169    #else /* ALLOW_FIZHI */
170              DO j = 1,sNy+1
171                DO i = 1,sNx+1
172                  qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
173                ENDDO
174              ENDDO
175    #endif /* ALLOW_FIZHI */
176    
177          ELSE          ELSE
178  C-      With counter diagnostics => average = Sum / counter:  C-      With counter diagnostics => average = Sum / counter:
179    
180            ipnt = ip + lev - 1            ipnt = ip + kd - 1
181            levCt= MIN(lev,kdiag(mate))            km = MIN(kd,kdiag(mate))
182            ipCt = im + levCt - 1            ipCt = im + km - 1
183            DO j = 1,sNy+1            DO j = 1,sNy+1
184              DO i = 1,sNx+1              DO i = 1,sNx+1
185                IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN                IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
186                  qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)                  qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)
187       &                    / qdiag(i,j,ipCt,bi,bj)       &                      / qdiag(i,j,ipCt,bi,bj)
188                ELSE                ELSE
189                  qtmp(i,j) = undef                  qtmp(i,j,k) = undefRL
190                ENDIF                ENDIF
191              ENDDO              ENDDO
192            ENDDO            ENDDO
193    
194          ENDIF          ENDIF
195         ENDIF         ENDDO
196        ENDIF        ENDIF
197    
198        RETURN        RETURN
# Line 97  C-      With counter diagnostics => aver Line 201  C-      With counter diagnostics => aver
201  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
202    
203  CBOP 0  CBOP 0
204  C     !ROUTINE: DIAGNOSTICS_COUNT  C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
205  C     !INTERFACE:  C     !INTERFACE:
206        SUBROUTINE DIAGNOSTICS_COUNT (chardiag,        SUBROUTINE DIAGNOSTICS_GET_POINTERS(
207       I                              biArg, bjArg, myThid)       I                       diagName, listId,
208         O                       ndId, ip,
209         I                       myThid )
210    
211  C     !DESCRIPTION:  C     !DESCRIPTION:
212  C***********************************************************************  C     *================================================================*
213  C   routine to increment the diagnostic counter only  C     | o Returns the diagnostic Id number and diagnostic
214  C***********************************************************************  C     |   pointer to storage array for a specified diagnostic.
215    C     *================================================================*
216    C     | Note: A diagnostics field can be stored multiple times
217    C     |       (for different output frequency,phase, ...).
218    C     | operates in 2 ways:
219    C     | o listId =0 => find 1 diagnostics Id & pointer which name matches.
220    C     | o listId >0 => find the unique diagnostic Id & pointer with
221    C     |      the right name and same output time as "listId" output-list
222    C     | o return ip=0 if did not find the right diagnostic;
223    C     |   (ndId <>0 if diagnostic exist but output time does not match)
224    C     *================================================================*
225    
226  C     !USES:  C     !USES:
227        IMPLICIT NONE        IMPLICIT NONE
   
 C     == Global variables ===  
228  #include "EEPARAMS.h"  #include "EEPARAMS.h"
229  #include "SIZE.h"  #include "SIZE.h"
230  #include "DIAGNOSTICS_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
231  #include "DIAGNOSTICS.h"  #include "DIAGNOSTICS.h"
232    
233  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
234  C***********************************************************************  C     diagName :: diagnostic identificator name (8 characters long)
235  C  Arguments Description  C     listId   :: list number that specify the output frequency
236  C  ----------------------  C     myThid   :: my Thread Id number
237  C     chardiag :: Character expression for diag to increment the counter  C     !OUTPUT PARAMETERS:
238  C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops  C     ndId     :: diagnostics  Id number (in available diagnostics list)
239  C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops  C     ip       :: diagnostics  pointer to storage array
240  C     myThid   :: my thread Id number  
241  C***********************************************************************        CHARACTER*8 diagName
242        CHARACTER*8 chardiag        INTEGER listId
243        INTEGER biArg, bjArg        INTEGER ndId, ip
244        INTEGER myThid        INTEGER myThid
245  CEOP  CEOP
246    
247  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
248  C ===============        INTEGER n,m
       INTEGER m, n  
       INTEGER bi, bj  
       INTEGER ipt  
 c     CHARACTER*(MAX_LEN_MBUF) msgBuf  
249    
250  C--   Run through list of active diagnostics to find which counter        ip   = 0
251  C     to increment (needs to be a valid & active diagnostic-counter)        ndId = 0
252        DO n=1,nlists  
253         DO m=1,nActive(n)        IF ( listId.LE.0 ) THEN
254          IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN  C--   select the 1rst one which name matches:
255           ipt = idiag(m,n)  
256           IF (ndiag(ipt,1,1).GE.0) THEN  C-    search for this diag. in the active 2D/3D diagnostics list
257  C-    Increment the counter for the diagnostic          DO n=1,nLists
258            IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN           DO m=1,nActive(n)
259             DO bj=myByLo(myThid), myByHi(myThid)             IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
260              DO bi=myBxLo(myThid), myBxHi(myThid)       &                  .AND. idiag(m,n).NE.0 ) THEN
261               ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1              ip   = ABS(idiag(m,n))
262              ENDDO              ndId = jdiag(m,n)
263             ENDDO             ENDIF
264            ELSE           ENDDO
265               bi = MIN(biArg,nSx)          ENDDO
266               bj = MIN(bjArg,nSy)  
267               ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1        ELSEIF ( listId.LE.nLists ) THEN
268            ENDIF  C--   select the unique diagnostic with output-time identical to listId
269  C-    Increment is done  
270    C-    search for this diag. in the active 2D/3D diagnostics list
271            DO n=1,nLists
272             IF ( ip.EQ.0
273         &        .AND. freq(n) .EQ. freq(listId)
274         &        .AND. phase(n).EQ.phase(listId)
275         &        .AND. averageFreq(n) .EQ.averageFreq(listId)
276         &        .AND. averagePhase(n).EQ.averagePhase(listId)
277         &        .AND. averageCycle(n).EQ.averageCycle(listId)
278         &      ) THEN
279              DO m=1,nActive(n)
280               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
281         &                  .AND. idiag(m,n).NE.0 ) THEN
282                ip   = ABS(idiag(m,n))
283                ndId = jdiag(m,n)
284               ENDIF
285              ENDDO
286             ELSEIF ( ip.EQ.0 ) THEN
287              DO m=1,nActive(n)
288               IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
289         &                  .AND. idiag(m,n).NE.0 ) THEN
290                ndId = jdiag(m,n)
291               ENDIF
292              ENDDO
293           ENDIF           ENDIF
294            ENDDO
295    
296          ELSE
297            STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
298          ENDIF
299    
300          RETURN
301          END
302    
303    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
304    
305    CBOP 0
306    C     !ROUTINE: DIAGNOSTICS_SETKLEV
307    
308    C     !INTERFACE:
309          SUBROUTINE DIAGNOSTICS_SETKLEV(
310         I                                diagName, nLevDiag, myThid )
311    
312    C     !DESCRIPTION:
313    C     *==========================================================*
314    C     | S/R DIAGNOSTICS_SETKLEV
315    C     | o Define explicitly the number of level (stored in kdiag)
316    C     |   of a diagnostic field. For most diagnostics, the number
317    C     |   of levels is derived (in S/R SET_LEVELS) from gdiag(10)
318    C     |   but occasionally one may want to set it explicitly.
319    C     *==========================================================*
320    
321    C     !USES:
322          IMPLICIT NONE
323    #include "EEPARAMS.h"
324    #include "SIZE.h"
325    #include "DIAGNOSTICS_SIZE.h"
326    #include "DIAGNOSTICS.h"
327    
328    C     !INPUT PARAMETERS:
329    C     diagName  :: diagnostic identificator name (8 characters long)
330    C     nLevDiag  :: number of level to set for this diagnostics field
331    C     myThid    :: my Thread Id number
332          CHARACTER*8  diagName
333          INTEGER nLevDiag
334          INTEGER myThid
335    CEOP
336    
337    C     !LOCAL VARIABLES:
338          CHARACTER*(MAX_LEN_MBUF) msgBuf
339          INTEGER n, ndId
340    
341    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
342    
343          _BEGIN_MASTER( myThid)
344    
345    C--   Check if this S/R is called from the right place ;
346    C     needs to be after DIAGNOSTICS_INIT_EARLY and before DIAGNOSTICS_INIT_FIXED
347          IF ( diag_pkgStatus.NE.ready2setDiags ) THEN
348            CALL DIAGNOSTICS_STATUS_ERROR( 'DIAGNOSTICS_SETKLEV',
349         &                   ' ', diagName, ready2setDiags, myThid )
350          ENDIF
351    
352    C--   Find this diagnostics in the list of available diag.
353          ndId = 0
354          DO n = 1,ndiagt
355            IF ( diagName.EQ.cdiag(n) ) THEN
356              ndId = n
357          ENDIF          ENDIF
        ENDDO  
358        ENDDO        ENDDO
359          IF ( ndId.EQ.0 ) THEN
360            WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SETKLEV: ',
361         &     'diagName="', diagName, '" not known.'
362            CALL PRINT_ERROR( msgBuf, myThid )
363            STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'
364          ENDIF
365    
366    C-    Optional level number diagnostics (X): set number of levels
367          IF ( kdiag(ndId).EQ.0
368         &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
369            kdiag(ndId) = nLevDiag
370          ELSEIF ( kdiag(ndId).EQ.nLevDiag
371         &   .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
372    C-    level number already set to same value: send warning
373            WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
374         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
375            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
376         &                      SQUEEZE_RIGHT , myThid )
377            WRITE(msgBuf,'(2A,I5,A)')'** WARNING ** DIAGNOSTICS_SETKLEV:',
378         &     ' level Nb (=', kdiag(ndId), ') already set.'
379            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
380         &                      SQUEEZE_RIGHT , myThid )
381          ELSEIF ( gdiag(ndId)(10:10).EQ.'X' ) THEN
382    C-    level number already set to a different value: do not reset but stop
383            WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',
384         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
385            CALL PRINT_ERROR( msgBuf, myThid )
386            WRITE(msgBuf,'(2A,I5,3A)') 'DIAGNOSTICS_SETKLEV: ',
387         &     'level Nb already set to', kdiag(ndId), ' => STOP'
388            CALL PRINT_ERROR( msgBuf, myThid )
389          ELSE
390    C-    for now, do nothing but just send a warning
391            WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
392         &     'diagName="', diagName, '" , nLevDiag=', nLevDiag
393            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
394         &                      SQUEEZE_RIGHT , myThid )
395            WRITE(msgBuf,'(2A,I5,3A)') '** WARNING ** will set level Nb',
396         &     ' from diagCode(ndId=', ndId, ')="', gdiag(ndId)(1:10), '"'
397            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
398         &                      SQUEEZE_RIGHT , myThid )
399            WRITE(msgBuf,'(4A)') '** WARNING ** DIAGNOSTICS_SETKLEV',
400         &     '("', diagName, '") <== Ignore this call.'
401            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
402         &                      SQUEEZE_RIGHT , myThid )
403          ENDIF
404    
405          _END_MASTER( myThid)
406    
407          RETURN
408          END
409    
410    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
411    
412    CBOP 0
413    C     !ROUTINE: DIAGS_GET_PARMS_I
414    
415    C     !INTERFACE:
416          INTEGER FUNCTION DIAGS_GET_PARMS_I(
417         I                            parName, myThid )
418    
419    C     !DESCRIPTION:
420    C     *==========================================================*
421    C     | FUNCTION DIAGS_GET_PARMS_I
422    C     | o Return the value of integer parameter
423    C     |   from one of the DIAGNOSTICS.h common blocs
424    C     *==========================================================*
425    
426    C     !USES:
427          IMPLICIT NONE
428    #include "EEPARAMS.h"
429    #include "SIZE.h"
430    #include "DIAGNOSTICS_SIZE.h"
431    #include "DIAGNOSTICS.h"
432    
433    C     !INPUT PARAMETERS:
434    C     parName   :: string used to identify which parameter to get
435    C     myThid    :: my Thread Id number
436          CHARACTER*(*) parName
437          INTEGER myThid
438    CEOP
439    
440    C     !LOCAL VARIABLES:
441          CHARACTER*(MAX_LEN_MBUF) msgBuf
442          INTEGER n
443    
444    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
445    
446          n = LEN(parName)
447    c     write(0,'(3A,I4)')
448    c    &  'DIAGS_GET_PARMS_I: parName="',parName,'" , length=',n
449    
450          IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
451             DIAGS_GET_PARMS_I = ndiagt
452          ELSE
453             WRITE(msgBuf,'(4A)') 'DIAGS_GET_PARMS_I: ',
454         &    ' parName="', parName, '" not known.'
455             CALL PRINT_ERROR( msgBuf, myThid )
456             STOP 'ABNORMAL END: S/R DIAGS_GET_PARMS_I'
457          ENDIF
458    
459        RETURN        RETURN
460        END        END
# Line 196  C     !LOCAL VARIABLES: Line 491  C     !LOCAL VARIABLES:
491        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
492        INTEGER i,j,n        INTEGER i,j,n
493    
494        DIAGS_MK_UNITS = '          '        DIAGS_MK_UNITS = '                '
495        n = LEN(diagUnitsInPieces)        n = LEN(diagUnitsInPieces)
496    
497        j = 0        j = 0
# Line 208  C     !LOCAL VARIABLES: Line 503  C     !LOCAL VARIABLES:
503        ENDDO        ENDDO
504    
505        IF ( j.GT.16 ) THEN        IF ( j.GT.16 ) THEN
506           WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',           WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
507       &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'       &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
508          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
509       &       SQUEEZE_RIGHT , myThid)       &       SQUEEZE_RIGHT , myThid)
510           WRITE(msgBuf,'(3A)') '**WARNING** ',           WRITE(msgBuf,'(3A)') '** WARNING ** ',
511       &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces       &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
512          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
513       &       SQUEEZE_RIGHT , myThid)       &       SQUEEZE_RIGHT , myThid)
# Line 220  C     !LOCAL VARIABLES: Line 515  C     !LOCAL VARIABLES:
515    
516        RETURN        RETURN
517        END        END
518    
519  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
520    
521  CBOP 0  CBOP 0
522  C     !ROUTINE: diagnostics_get_pointers  C     !ROUTINE: DIAGS_MK_TITLE
523    
524  C     !INTERFACE:  C     !INTERFACE:
525        subroutine diagnostics_get_pointers(diagName,ipoint,jpoint,myThid)        CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
526         I                            diagTitleInPieces, myThid )
527    
528  C     !DESCRIPTION:  C     !DESCRIPTION:
529  C     *==========================================================*  C     *==========================================================*
530  C     | subroutine diagnostics_get_pointers  C     | FUNCTION DIAGS_MK_TITLE
531  C     | o Returns the idiag and jdiag pointers for a  C     | o Return the diagnostic title string (80c) removing
532  C     |   specified diagnostic - returns 0 if not active  C     |   consecutive blanks from the input string
533  C     *==========================================================*  C     *==========================================================*
534    
535  C     !USES:  C     !USES:
536        IMPLICIT NONE        IMPLICIT NONE
537  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "SIZE.h"  
 #include "DIAGNOSTICS_SIZE.h"  
 #include "DIAGNOSTICS.h"  
538    
539  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
540  C     diagName   ::  diagnostic identificator name (8 characters long)  C     diagTitleInPieces :: string for diagnostic units: in several
541  C     myThid     ::  my thread Id number  C                          pieces, with blanks in between
542  C     !OUTPUT PARAMETERS:  C     myThid            ::  my Thread Id number
543  C     ipoint     ::  pointer value into qdiag array        CHARACTER*(*) diagTitleInPieces
544  C     jpoint     ::  pointer value into diagnostics list        INTEGER      myThid
   
       CHARACTER*8 diagName  
       INTEGER ipoint, jpoint, myThid  
545  CEOP  CEOP
546    
547  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
548        INTEGER n,m        CHARACTER*(MAX_LEN_MBUF) msgBuf
549          LOGICAL flag
550          INTEGER i,j,n
551    
552        ipoint = 0  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
       jpoint = 0  
553    
554  C-    search for this diag. in the active 2D/3D diagnostics list        DIAGS_MK_TITLE = '                                        '
555        DO n=1,nlists       &               //'                                        '
556         DO m=1,nActive(n)        n = LEN(diagTitleInPieces)
557          IF ( diagName.EQ.flds(m,n) .AND. idiag(m,n).NE.0 ) THEN  
558            ipoint = abs(idiag(m,n))        j = 0
559            jpoint = jdiag(m,n)        flag = .FALSE.
560          ENDIF        DO i=1,n
561         ENDDO         IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
562             IF ( flag ) THEN
563               j = j+1
564               IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
565             ENDIF
566             j = j+1
567             IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
568             flag = .FALSE.
569           ELSE
570             flag = j.GE.1
571           ENDIF
572        ENDDO        ENDDO
573    
574          IF ( j.GT.80 ) THEN
575             WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
576         &   'DIAGS_MK_TITLE: too long (',j,' >80) input string'
577            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
578         &       SQUEEZE_RIGHT , myThid)
579             WRITE(msgBuf,'(3A)') '** WARNING ** ',
580         &   'DIAGS_MK_TITLE: input=', diagTitleInPieces
581            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
582         &       SQUEEZE_RIGHT , myThid)
583          ENDIF
584    
585        RETURN        RETURN
586        END        END
Legend:
Removed from v.1.22  
changed lines
  Added in v.1.32
  ViewVC Help
Powered by ViewVC 1.1.22