pkg/diagnostics/diagnostics_utils.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.24 2006/12/24 20:18:05 jmc Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

C--   File diagnostics_utils.F: General purpose support routines
C--    Contents:
C--    o GETDIAG
C--    o DIAGNOSTICS_COUNT
C--    o DIAGS_MK_UNITS (Function)
C--    o DIAGS_MK_TITLE (Function)
C--    o DIAGNOSTICS_GET_POINTERS

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 0
C     !ROUTINE: GETDIAG

C     !INTERFACE:
      SUBROUTINE GETDIAG(
     I                    levreal, undef,
     O                    qtmp,
     I                    ndId, mate, ip, im, bi, bj, myThid )

C     !DESCRIPTION:
C     Retrieve averaged model diagnostic

C     !USES:
      IMPLICIT NONE
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"

C     !INPUT PARAMETERS:
C     levreal :: Diagnostic LEVEL
C     undef   :: UNDEFINED VALUE
C     ndId    :: DIAGNOSTIC NUMBER FROM MENU
C     mate    :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise
C     ip      :: pointer to storage array location for diag.
C     im      :: pointer to storage array location for mate
C     bi      :: X-direction tile number
C     bj      :: Y-direction tile number
C     myThid  :: my thread Id number
      _RL levreal
      _RL undef
      INTEGER ndId, mate, ip, im
      INTEGER bi,bj, myThid

C     !OUTPUT PARAMETERS:
C     qtmp    ..... AVERAGED DIAGNOSTIC QUANTITY
      _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
CEOP

C     !LOCAL VARIABLES:
      _RL factor
      INTEGER i, j, ipnt,ipCt
      INTEGER lev, levCt, klev

      IF (ndId.GE.1) THEN
       lev = NINT(levreal)
       klev = kdiag(ndId)
       IF (lev.LE.klev) THEN

        IF ( mate.EQ.0 ) THEN
C-      No counter diagnostics => average = Sum / ndiag :

          ipnt = ip + lev - 1
          factor = FLOAT(ndiag(ip,bi,bj))
          IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor

          DO j = 1,sNy+1
            DO i = 1,sNx+1
              IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN
                qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor
              ELSE
                qtmp(i,j) = undef
              ENDIF
            ENDDO
          ENDDO

        ELSE
C-      With counter diagnostics => average = Sum / counter:

          ipnt = ip + lev - 1
          levCt= MIN(lev,kdiag(mate))
          ipCt = im + levCt - 1
          DO j = 1,sNy+1
            DO i = 1,sNx+1
              IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
                qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)
     &                    / qdiag(i,j,ipCt,bi,bj)
              ELSE
                qtmp(i,j) = undef
              ENDIF
            ENDDO
          ENDDO

        ENDIF
       ENDIF
      ENDIF

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

CBOP 0
C     !ROUTINE: DIAGNOSTICS_COUNT
C     !INTERFACE:
      SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
     I                              biArg, bjArg, myThid)

C     !DESCRIPTION:
C***********************************************************************
C   routine to increment the diagnostic counter only
C***********************************************************************
C     !USES:
      IMPLICIT NONE

C     == Global variables ===
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"

C     !INPUT PARAMETERS:
C***********************************************************************
C  Arguments Description
C  ----------------------
C     chardiag :: Character expression for diag to increment the counter
C     biArg    :: X-direction tile number, or 0 if called outside bi,bj loops
C     bjArg    :: Y-direction tile number, or 0 if called outside bi,bj loops
C     myThid   :: my thread Id number
C***********************************************************************
      CHARACTER*8 chardiag
      INTEGER biArg, bjArg
      INTEGER myThid
CEOP

C     !LOCAL VARIABLES:
C ===============
      INTEGER m, n
      INTEGER bi, bj
      INTEGER ipt
c     CHARACTER*(MAX_LEN_MBUF) msgBuf

C--   Run through list of active diagnostics to find which counter
C     to increment (needs to be a valid & active diagnostic-counter)
      DO n=1,nlists
       DO m=1,nActive(n)
        IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
         ipt = idiag(m,n)
         IF (ndiag(ipt,1,1).GE.0) THEN
C-    Increment the counter for the diagnostic
          IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
           DO bj=myByLo(myThid), myByHi(myThid)
            DO bi=myBxLo(myThid), myBxHi(myThid)
             ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
            ENDDO
           ENDDO
          ELSE
             bi = MIN(biArg,nSx)
             bj = MIN(bjArg,nSy)
             ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
          ENDIF
C-    Increment is done
         ENDIF
        ENDIF
       ENDDO
      ENDDO

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

CBOP 0
C     !ROUTINE: DIAGS_MK_UNITS

C     !INTERFACE:
      CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
     I                            diagUnitsInPieces, myThid )

C     !DESCRIPTION:
C     *==========================================================*
C     | FUNCTION DIAGS_MK_UNITS
C     | o Return the diagnostic units string (16c) removing
C     |   blanks from the input string
C     *==========================================================*

C     !USES:
      IMPLICIT NONE
#include "EEPARAMS.h"

C     !INPUT PARAMETERS:
C     diagUnitsInPieces :: string for diagnostic units: in several
C                          pieces, with blanks in between
C     myThid            ::  my thread Id number
      CHARACTER*(*) diagUnitsInPieces
      INTEGER      myThid
CEOP

C     !LOCAL VARIABLES:
      CHARACTER*(MAX_LEN_MBUF) msgBuf
      INTEGER i,j,n

      DIAGS_MK_UNITS = '          '
      n = LEN(diagUnitsInPieces)

      j = 0
      DO i=1,n
       IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
         j = j+1
         IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
       ENDIF
      ENDDO

      IF ( j.GT.16 ) THEN
         WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
     &   'DIAGS_MK_UNITS: too long (',j,' >16) input string'
        CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &       SQUEEZE_RIGHT , myThid)
         WRITE(msgBuf,'(3A)') '**WARNING** ',
     &   'DIAGS_MK_UNITS: input=', diagUnitsInPieces
        CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &       SQUEEZE_RIGHT , myThid)
      ENDIF

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

CBOP 0
C     !ROUTINE: DIAGS_MK_TITLE

C     !INTERFACE:
      CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
     I                            diagTitleInPieces, myThid )

C     !DESCRIPTION:
C     *==========================================================*
C     | FUNCTION DIAGS_MK_TITLE
C     | o Return the diagnostic title string (80c) removing
C     |   consecutive blanks from the input string
C     *==========================================================*

C     !USES:
      IMPLICIT NONE
#include "EEPARAMS.h"

C     !INPUT PARAMETERS:
C     diagTitleInPieces :: string for diagnostic units: in several
C                          pieces, with blanks in between
C     myThid            ::  my Thread Id number
      CHARACTER*(*) diagTitleInPieces
      INTEGER      myThid
CEOP

C     !LOCAL VARIABLES:
      CHARACTER*(MAX_LEN_MBUF) msgBuf
      LOGICAL flag
      INTEGER i,j,n

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      DIAGS_MK_TITLE = '                                        '
     &               //'                                        '
      n = LEN(diagTitleInPieces)

      j = 0
      flag = .FALSE.
      DO i=1,n
       IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
         IF ( flag ) THEN
           j = j+1
           IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
         ENDIF
         j = j+1
         IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
         flag = .FALSE.
       ELSE
         flag = j.GE.1
       ENDIF
      ENDDO

      IF ( j.GT.80 ) THEN
         WRITE(msgBuf,'(2A,I4,A)') '**WARNING** ',
     &   'DIAGS_MK_TITLE: too long (',j,' >80) input string'
        CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &       SQUEEZE_RIGHT , myThid)
         WRITE(msgBuf,'(3A)') '**WARNING** ',
     &   'DIAGS_MK_TITLE: input=', diagTitleInPieces
        CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &       SQUEEZE_RIGHT , myThid)
      ENDIF

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

CBOP 0
C     !ROUTINE: DIAGNOSTICS_GET_POINTERS
C     !INTERFACE:
      SUBROUTINE DIAGNOSTICS_GET_POINTERS(
     I                       diagName, listId,
     O                       ndId, ip,
     I                       myThid )

C     !DESCRIPTION:
C     *================================================================*
C     | o Returns the diagnostic Id number and diagnostic
C     |   pointer to storage array for a specified diagnostic.
C     *================================================================*
C     | Note: A diagnostics field can be stored multiple times
C     |       (for different output frequency,phase, ...).
C     | operates in 2 ways:
C     | o listId =0 => find 1 diagnostics Id & pointer which name matches.
C     | o listId >0 => find the unique diagnostic Id & pointer with
C     |      the right name and same output time as "listId" output-list
C     | o return ip=0 if did not find the right diagnostic;
C     |   (ndId <>0 if diagnostic exist but output time does not match)
C     *================================================================*

C     !USES:
      IMPLICIT NONE
#include "EEPARAMS.h"
#include "SIZE.h"
#include "DIAGNOSTICS_SIZE.h"
#include "DIAGNOSTICS.h"

C     !INPUT PARAMETERS:
C     diagName :: diagnostic identificator name (8 characters long)
C     listId   :: list number that specify the output frequency
C     myThid   :: my Thread Id number
C     !OUTPUT PARAMETERS:
C     ndId     :: diagnostics  Id number (in available diagnostics list)
C     ip       :: diagnostics  pointer to storage array


      CHARACTER*8 diagName
      INTEGER listId
      INTEGER ndId, ip
      INTEGER myThid
CEOP

C     !LOCAL VARIABLES:
      INTEGER n,m

      ip   = 0
      ndId = 0

      IF ( listId.LE.0 ) THEN
C--   select the 1rst one which name matches:

C-    search for this diag. in the active 2D/3D diagnostics list
        DO n=1,nlists
         DO m=1,nActive(n)
           IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
     &                  .AND. idiag(m,n).NE.0 ) THEN
            ip   = ABS(idiag(m,n))
            ndId = jdiag(m,n)
           ENDIF
         ENDDO
        ENDDO

      ELSEIF ( listId.LE.nlists ) THEN
C--   select the unique diagnostic with output-time identical to listId

C-    search for this diag. in the active 2D/3D diagnostics list
        DO n=1,nlists
         IF ( ip.EQ.0
     &        .AND. freq(n) .EQ. freq(listId)
     &        .AND. phase(n).EQ.phase(listId)
     &        .AND. averageFreq(n) .EQ.averageFreq(listId)
     &        .AND. averagePhase(n).EQ.averagePhase(listId)
     &        .AND. averageCycle(n).EQ.averageCycle(listId)
     &      ) THEN
          DO m=1,nActive(n)
           IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
     &                  .AND. idiag(m,n).NE.0 ) THEN
            ip   = ABS(idiag(m,n))
            ndId = jdiag(m,n)
           ENDIF
          ENDDO
         ELSEIF ( ip.EQ.0 ) THEN
          DO m=1,nActive(n)
           IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
     &                  .AND. idiag(m,n).NE.0 ) THEN
            ndId = jdiag(m,n)
           ENDIF
          ENDDO
         ENDIF
        ENDDO

      ELSE
        STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
      ENDIF

      RETURN
      END
1	jmc	1.25	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_utils.F,v 1.24 2006/12/24 20:18:05 jmc Exp $
2	edhill	1.8	C $Name: $
3
4	edhill	1.9	#include "DIAG_OPTIONS.h"
5
6	jmc	1.25	C-- File diagnostics_utils.F: General purpose support routines
7			C-- Contents:
8			C-- o GETDIAG
9			C-- o DIAGNOSTICS_COUNT
10			C-- o DIAGS_MK_UNITS (Function)
11			C-- o DIAGS_MK_TITLE (Function)
12			C-- o DIAGNOSTICS_GET_POINTERS
13
14	edhill	1.12	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
15			CBOP 0
16			C !ROUTINE: GETDIAG
17
18			C !INTERFACE:
19	jmc	1.18	SUBROUTINE GETDIAG(
20			I levreal, undef,
21			O qtmp,
22	jmc	1.21	I ndId, mate, ip, im, bi, bj, myThid )
23	edhill	1.12
24			C !DESCRIPTION:
25	edhill	1.13	C Retrieve averaged model diagnostic
26	jmc	1.15
27	edhill	1.12	C !USES:
28	jmc	1.18	IMPLICIT NONE
29	molod	1.3	#include "EEPARAMS.h"
30	molod	1.1	#include "SIZE.h"
31	jmc	1.15	#include "DIAGNOSTICS_SIZE.h"
32			#include "DIAGNOSTICS.h"
33	molod	1.3
34	jmc	1.18	C !INPUT PARAMETERS:
35	jmc	1.21	C levreal :: Diagnostic LEVEL
36			C undef :: UNDEFINED VALUE
37			C ndId :: DIAGNOSTIC NUMBER FROM MENU
38			C mate :: counter DIAGNOSTIC NUMBER if any ; 0 otherwise
39			C ip :: pointer to storage array location for diag.
40			C im :: pointer to storage array location for mate
41			C bi :: X-direction tile number
42			C bj :: Y-direction tile number
43			C myThid :: my thread Id number
44	jmc	1.15	_RL levreal
45	molod	1.3	_RL undef
46	jmc	1.21	INTEGER ndId, mate, ip, im
47	jmc	1.18	INTEGER bi,bj, myThid
48	jmc	1.15
49	jmc	1.18	C !OUTPUT PARAMETERS:
50	edhill	1.12	C qtmp ..... AVERAGED DIAGNOSTIC QUANTITY
51	jmc	1.18	_RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
52			CEOP
53	molod	1.11
54	jmc	1.18	C !LOCAL VARIABLES:
55	molod	1.3	_RL factor
56	jmc	1.18	INTEGER i, j, ipnt,ipCt
57			INTEGER lev, levCt, klev
58	molod	1.11
59	jmc	1.21	IF (ndId.GE.1) THEN
60	jmc	1.15	lev = NINT(levreal)
61	jmc	1.21	klev = kdiag(ndId)
62	jmc	1.18	IF (lev.LE.klev) THEN
63	jmc	1.15
64	jmc	1.18	IF ( mate.EQ.0 ) THEN
65			C- No counter diagnostics => average = Sum / ndiag :
66	jmc	1.15
67	jmc	1.21	ipnt = ip + lev - 1
68			factor = FLOAT(ndiag(ip,bi,bj))
69			IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
70	jmc	1.18
71			DO j = 1,sNy+1
72			DO i = 1,sNx+1
73			IF ( qdiag(i,j,ipnt,bi,bj) .LE. undef ) THEN
74			qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)*factor
75			ELSE
76			qtmp(i,j) = undef
77			ENDIF
78			ENDDO
79			ENDDO
80
81			ELSE
82			C- With counter diagnostics => average = Sum / counter:
83
84	jmc	1.21	ipnt = ip + lev - 1
85	jmc	1.18	levCt= MIN(lev,kdiag(mate))
86	jmc	1.21	ipCt = im + levCt - 1
87	jmc	1.18	DO j = 1,sNy+1
88			DO i = 1,sNx+1
89			IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
90			qtmp(i,j) = qdiag(i,j,ipnt,bi,bj)
91			& / qdiag(i,j,ipCt,bi,bj)
92			ELSE
93			qtmp(i,j) = undef
94			ENDIF
95			ENDDO
96			ENDDO
97	molod	1.1
98	jmc	1.18	ENDIF
99			ENDIF
100			ENDIF
101	molod	1.3
102	jmc	1.15	RETURN
103			END
104	edhill	1.12
105			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
106
107	jmc	1.15	CBOP 0
108	jmc	1.19	C !ROUTINE: DIAGNOSTICS_COUNT
109			C !INTERFACE:
110	jmc	1.21	SUBROUTINE DIAGNOSTICS_COUNT (chardiag,
111			I biArg, bjArg, myThid)
112	jmc	1.19
113			C !DESCRIPTION:
114			C***********************************************************************
115			C routine to increment the diagnostic counter only
116			C***********************************************************************
117			C !USES:
118			IMPLICIT NONE
119
120			C == Global variables ===
121			#include "EEPARAMS.h"
122			#include "SIZE.h"
123			#include "DIAGNOSTICS_SIZE.h"
124			#include "DIAGNOSTICS.h"
125
126			C !INPUT PARAMETERS:
127			C***********************************************************************
128			C Arguments Description
129			C ----------------------
130			C chardiag :: Character expression for diag to increment the counter
131			C biArg :: X-direction tile number, or 0 if called outside bi,bj loops
132			C bjArg :: Y-direction tile number, or 0 if called outside bi,bj loops
133			C myThid :: my thread Id number
134			C***********************************************************************
135			CHARACTER*8 chardiag
136			INTEGER biArg, bjArg
137			INTEGER myThid
138			CEOP
139
140			C !LOCAL VARIABLES:
141			C ===============
142	jmc	1.21	INTEGER m, n
143			INTEGER bi, bj
144			INTEGER ipt
145	jmc	1.19	c CHARACTER*(MAX_LEN_MBUF) msgBuf
146
147	jmc	1.21	C-- Run through list of active diagnostics to find which counter
148			C to increment (needs to be a valid & active diagnostic-counter)
149	jmc	1.19	DO n=1,nlists
150			DO m=1,nActive(n)
151	jmc	1.21	IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
152			ipt = idiag(m,n)
153			IF (ndiag(ipt,1,1).GE.0) THEN
154			C- Increment the counter for the diagnostic
155			IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
156			DO bj=myByLo(myThid), myByHi(myThid)
157			DO bi=myBxLo(myThid), myBxHi(myThid)
158			ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
159			ENDDO
160			ENDDO
161			ELSE
162			bi = MIN(biArg,nSx)
163			bj = MIN(bjArg,nSy)
164			ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
165			ENDIF
166			C- Increment is done
167			ENDIF
168	jmc	1.19	ENDIF
169			ENDDO
170			ENDDO
171
172	jmc	1.21	RETURN
173	jmc	1.19	END
174
175			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
176
177			CBOP 0
178	jmc	1.17	C !ROUTINE: DIAGS_MK_UNITS
179
180			C !INTERFACE:
181	jmc	1.21	CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
182	jmc	1.17	I diagUnitsInPieces, myThid )
183
184			C !DESCRIPTION:
185			C ==========================================================
186			C \| FUNCTION DIAGS_MK_UNITS
187	jmc	1.21	C \| o Return the diagnostic units string (16c) removing
188	jmc	1.17	C \| blanks from the input string
189			C ==========================================================
190
191			C !USES:
192			IMPLICIT NONE
193			#include "EEPARAMS.h"
194
195			C !INPUT PARAMETERS:
196	jmc	1.21	C diagUnitsInPieces :: string for diagnostic units: in several
197	jmc	1.17	C pieces, with blanks in between
198			C myThid :: my thread Id number
199			CHARACTER() diagUnitsInPieces
200			INTEGER myThid
201			CEOP
202
203			C !LOCAL VARIABLES:
204			CHARACTER*(MAX_LEN_MBUF) msgBuf
205			INTEGER i,j,n
206
207	jmc	1.21	DIAGS_MK_UNITS = ' '
208	jmc	1.17	n = LEN(diagUnitsInPieces)
209	jmc	1.21
210	jmc	1.17	j = 0
211			DO i=1,n
212			IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
213			j = j+1
214			IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
215			ENDIF
216			ENDDO
217
218			IF ( j.GT.16 ) THEN
219			WRITE(msgBuf,'(2A,I4,A)') 'WARNING ',
220			& 'DIAGS_MK_UNITS: too long (',j,' >16) input string'
221			CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
222			& SQUEEZE_RIGHT , myThid)
223			WRITE(msgBuf,'(3A)') 'WARNING ',
224			& 'DIAGS_MK_UNITS: input=', diagUnitsInPieces
225			CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
226			& SQUEEZE_RIGHT , myThid)
227			ENDIF
228
229			RETURN
230			END
231	jmc	1.23
232			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
233
234			CBOP 0
235			C !ROUTINE: DIAGS_MK_TITLE
236
237			C !INTERFACE:
238			CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
239			I diagTitleInPieces, myThid )
240
241			C !DESCRIPTION:
242			C ==========================================================
243			C \| FUNCTION DIAGS_MK_TITLE
244			C \| o Return the diagnostic title string (80c) removing
245			C \| consecutive blanks from the input string
246			C ==========================================================
247
248			C !USES:
249			IMPLICIT NONE
250			#include "EEPARAMS.h"
251
252			C !INPUT PARAMETERS:
253			C diagTitleInPieces :: string for diagnostic units: in several
254			C pieces, with blanks in between
255			C myThid :: my Thread Id number
256			CHARACTER() diagTitleInPieces
257			INTEGER myThid
258			CEOP
259
260			C !LOCAL VARIABLES:
261			CHARACTER*(MAX_LEN_MBUF) msgBuf
262			LOGICAL flag
263			INTEGER i,j,n
264
265	molod	1.22	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
266	jmc	1.23
267			DIAGS_MK_TITLE = ' '
268			& //' '
269			n = LEN(diagTitleInPieces)
270
271			j = 0
272			flag = .FALSE.
273			DO i=1,n
274			IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
275			IF ( flag ) THEN
276			j = j+1
277			IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
278			ENDIF
279			j = j+1
280			IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
281			flag = .FALSE.
282			ELSE
283			flag = j.GE.1
284			ENDIF
285			ENDDO
286
287			IF ( j.GT.80 ) THEN
288			WRITE(msgBuf,'(2A,I4,A)') 'WARNING ',
289			& 'DIAGS_MK_TITLE: too long (',j,' >80) input string'
290			CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
291			& SQUEEZE_RIGHT , myThid)
292			WRITE(msgBuf,'(3A)') 'WARNING ',
293			& 'DIAGS_MK_TITLE: input=', diagTitleInPieces
294			CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
295			& SQUEEZE_RIGHT , myThid)
296			ENDIF
297
298			RETURN
299			END
300
301			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
302
303	molod	1.22	CBOP 0
304	jmc	1.24	C !ROUTINE: DIAGNOSTICS_GET_POINTERS
305	molod	1.22	C !INTERFACE:
306	jmc	1.24	SUBROUTINE DIAGNOSTICS_GET_POINTERS(
307			I diagName, listId,
308			O ndId, ip,
309			I myThid )
310	molod	1.22
311			C !DESCRIPTION:
312	jmc	1.24	C ================================================================
313			C \| o Returns the diagnostic Id number and diagnostic
314			C \| pointer to storage array for a specified diagnostic.
315			C ================================================================
316			C \| Note: A diagnostics field can be stored multiple times
317			C \| (for different output frequency,phase, ...).
318			C \| operates in 2 ways:
319			C \| o listId =0 => find 1 diagnostics Id & pointer which name matches.
320			C \| o listId >0 => find the unique diagnostic Id & pointer with
321			C \| the right name and same output time as "listId" output-list
322			C \| o return ip=0 if did not find the right diagnostic;
323			C \| (ndId <>0 if diagnostic exist but output time does not match)
324			C ================================================================
325	molod	1.22
326			C !USES:
327			IMPLICIT NONE
328			#include "EEPARAMS.h"
329			#include "SIZE.h"
330			#include "DIAGNOSTICS_SIZE.h"
331			#include "DIAGNOSTICS.h"
332
333			C !INPUT PARAMETERS:
334	jmc	1.24	C diagName :: diagnostic identificator name (8 characters long)
335			C listId :: list number that specify the output frequency
336			C myThid :: my Thread Id number
337	molod	1.22	C !OUTPUT PARAMETERS:
338	jmc	1.24	C ndId :: diagnostics Id number (in available diagnostics list)
339			C ip :: diagnostics pointer to storage array
340
341	molod	1.22
342			CHARACTER*8 diagName
343	jmc	1.24	INTEGER listId
344			INTEGER ndId, ip
345			INTEGER myThid
346	molod	1.22	CEOP
347
348			C !LOCAL VARIABLES:
349			INTEGER n,m
350
351	jmc	1.24	ip = 0
352			ndId = 0
353
354			IF ( listId.LE.0 ) THEN
355			C-- select the 1rst one which name matches:
356	molod	1.22
357			C- search for this diag. in the active 2D/3D diagnostics list
358	jmc	1.24	DO n=1,nlists
359			DO m=1,nActive(n)
360			IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
361			& .AND. idiag(m,n).NE.0 ) THEN
362			ip = ABS(idiag(m,n))
363			ndId = jdiag(m,n)
364			ENDIF
365			ENDDO
366			ENDDO
367
368			ELSEIF ( listId.LE.nlists ) THEN
369			C-- select the unique diagnostic with output-time identical to listId
370
371			C- search for this diag. in the active 2D/3D diagnostics list
372			DO n=1,nlists
373			IF ( ip.EQ.0
374			& .AND. freq(n) .EQ. freq(listId)
375			& .AND. phase(n).EQ.phase(listId)
376			& .AND. averageFreq(n) .EQ.averageFreq(listId)
377			& .AND. averagePhase(n).EQ.averagePhase(listId)
378			& .AND. averageCycle(n).EQ.averageCycle(listId)
379			& ) THEN
380			DO m=1,nActive(n)
381			IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
382			& .AND. idiag(m,n).NE.0 ) THEN
383			ip = ABS(idiag(m,n))
384			ndId = jdiag(m,n)
385			ENDIF
386			ENDDO
387			ELSEIF ( ip.EQ.0 ) THEN
388			DO m=1,nActive(n)
389			IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
390			& .AND. idiag(m,n).NE.0 ) THEN
391			ndId = jdiag(m,n)
392			ENDIF
393			ENDDO
394			ENDIF
395			ENDDO
396
397			ELSE
398			STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
399			ENDIF
400	molod	1.22
401			RETURN
402			END