pkg/diagnostics/diagstats_set_pointers.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagstats_set_pointers.F,v 1.5 2006/11/19 21:59:57 jmc Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

CBOP
C     !ROUTINE: DIAGSTATS_SET_POINTERS
C     !INTERFACE:
      SUBROUTINE DIAGSTATS_SET_POINTERS( myThid )

C     !DESCRIPTION: \bv
C     *==================================================================
C     | S/R DIAGSTATS_SET_POINTERS
C     | o set pointers for active statistics diagnostics
C     *==================================================================
C     \ev

C     !USES:
      IMPLICIT NONE

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

C     !INPUT/OUTPUT PARAMETERS:
C     == Routine arguments ==
C     myThid - Thread number for this instance of the routine.
      INTEGER myThid
CEOP

C     !LOCAL VARIABLES:
C     == Local variables ==
      INTEGER ndiagcount, ndCount
      INTEGER md,ld,nd
      INTEGER mm, mate, nActiveMax
      INTEGER j, k, l
      LOGICAL found, addMate2List, inList, regListPb
      CHARACTER*(MAX_LEN_MBUF) msgBuf


      _BEGIN_MASTER( myThid)

C--   Initialize pointer arrays to zero:
      DO ld=1,numlists
       DO md=1,numperlist
        iSdiag(md,ld) = 0
        jSdiag(md,ld) = 0
        mSdiag(md,ld) = 0
       ENDDO
      ENDDO

C--   Calculate pointers for diagnostics set to non-zero frequency

      ndiagcount = 0
      nActiveMax = 0
      DO ld=1,diagSt_nbLists
       diagSt_nbActv(ld) = diagSt_nbFlds(ld)
       DO md=1,diagSt_nbFlds(ld)

         found = .FALSE.
C        Search all possible model diagnostics
         DO nd=1,ndiagt
          IF ( diagSt_Flds(md,ld).EQ.cdiag(nd) ) THEN
            CALL DIAGSTATS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
            found = .TRUE.
            jSdiag(md,ld) = nd
          ENDIF
         ENDDO
         IF ( .NOT.found ) THEN
           CALL DIAGNOSTICS_LIST_CHECK(
     O                      ndCount,
     I                      ld,md,diagSt_nbFlds,diagSt_Flds,myThid)
           IF ( ndCount.EQ.0 ) THEN
             WRITE(msgBuf,'(3A)') 'DIAGSTATS_SET_POINTERS: ',
     &                     diagSt_Flds(md,ld),' is not a Diagnostic'
             CALL PRINT_ERROR( msgBuf , myThid )
           ENDIF
           STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
         ENDIF
         IF ( found .AND. mate.LE.-1 ) THEN
C-       add this fields to the active list in case regions are differents:
           addMate2List = .FALSE.
           DO l=1,ld-1
            inList = .FALSE.
            DO k=1,diagSt_nbActv(l)
              IF ( diagSt_Flds(k,l).EQ.cdiag(-mate) ) inList=.TRUE.
            ENDDO
            IF ( inList ) THEN
             DO j=0,nRegions
              addMate2List = addMate2List
     &                 .OR. (diagSt_region(j,l).LT.diagSt_region(j,ld))
             ENDDO
            ENDIF
           ENDDO
           IF ( .NOT.addMate2List ) mate = 0
         ENDIF
         IF ( found .AND. mate.NE.0 ) THEN
            mm = diagSt_nbActv(ld) + 1
            IF ( mm.LE.numperlist ) THEN
             iSdiag(mm,ld) = SIGN(mSdiag(md,ld),mate)
             mate = ABS(mate)
             jSdiag(mm,ld) = mate
             diagSt_Flds(mm,ld) = cdiag(mate)
            ENDIF
            diagSt_nbActv(ld) = mm
         ENDIF

       ENDDO
       nActiveMax = MAX(diagSt_nbActv(ld),nActiveMax)
      ENDDO

      IF (  ndiagcount.LE.diagSt_size .AND.
     &      nActiveMax.LE.numperlist ) THEN
        WRITE(msgBuf,'(A,I8,A)')
     &    '  space allocated for all stats-diags:',
     &    ndiagcount, ' levels'
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                      SQUEEZE_RIGHT , myThid)
      ELSE
       IF ( ndiagcount.GT.diagSt_size ) THEN
         WRITE(msgBuf,'(2A)')
     &    'DIAGSTATS_SET_POINTERS: Not enough space',
     &    ' for all active stats-diags (from data.diagnostics)'
         CALL PRINT_ERROR( msgBuf , myThid )
         WRITE(msgBuf,'(A,I8,A,I8)')
     &    'DIAGSTATS_SET_POINTERS: diagSt_size=', diagSt_size,
     &    ' but needs at least', ndiagcount
         CALL PRINT_ERROR( msgBuf , myThid )
       ENDIF
       IF ( nActiveMax.GT.numperlist ) THEN
         WRITE(msgBuf,'(2A)')
     &    'DIAGSTATS_SET_POINTERS: Not enough space',
     &    ' for all active stats-diags (from data.diagnostics)'
         CALL PRINT_ERROR( msgBuf , myThid )
         WRITE(msgBuf,'(A,I6,A,I6)')
     &    'DIAGSTATS_SET_POINTERS: numperlist=', numperlist,
     &    ' but needs at least', nActiveMax
         CALL PRINT_ERROR( msgBuf , myThid )
       ENDIF
       STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
      ENDIF

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C--   Set list of regions to write
C-    check that all selected regions are actually defined
      regListPb = .FALSE.
      DO l=1,diagSt_nbLists
       DO j=1,nRegions
        IF ( diagSt_region(j,l).NE.0 ) THEN
          IF ( diagSt_kRegMsk(j).LT.1 .OR.
     &         diagSt_kRegMsk(j).GT.nSetRegMask ) THEN
            WRITE(msgBuf,'(A,3(A,I5))') 'DIAGSTATS_SET_POINTERS:',
     &       ' region', j, ' undefined (k=', diagSt_kRegMsk(j),
     &       ') in list l=', l
            CALL PRINT_ERROR( msgBuf , myThid )
            regListPb = .TRUE.
          ENDIF
        ENDIF
       ENDDO
      ENDDO
      IF ( regListPb ) THEN
        WRITE(msgBuf,'(2A)') 'DIAGSTATS_SET_POINTERS:',
     &                       ' Cannot select undefined regions'
        CALL PRINT_ERROR( msgBuf , myThid )
        STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
      ENDIF

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

        WRITE(msgBuf,'(A)') 'DIAGSTATS_SET_POINTERS: done'
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                      SQUEEZE_RIGHT , myThid)
        WRITE(msgBuf,'(2A)')
     &   '------------------------------------------------------------'
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &                      SQUEEZE_RIGHT , myThid)

      _END_MASTER( myThid )

      RETURN
      END
1	jmc	1.6	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagstats_set_pointers.F,v 1.5 2006/11/19 21:59:57 jmc Exp $
2	jmc	1.1	C $Name: $
3
4			#include "DIAG_OPTIONS.h"
5
6			CBOP
7			C !ROUTINE: DIAGSTATS_SET_POINTERS
8			C !INTERFACE:
9			SUBROUTINE DIAGSTATS_SET_POINTERS( myThid )
10
11			C !DESCRIPTION: \bv
12			C *==================================================================
13			C \| S/R DIAGSTATS_SET_POINTERS
14			C \| o set pointers for active statistics 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	jmc	1.3	#include "DIAGSTATS_REGIONS.h"
27	jmc	1.1
28			C !INPUT/OUTPUT PARAMETERS:
29			C == Routine arguments ==
30			C myThid - Thread number for this instance of the routine.
31			INTEGER myThid
32			CEOP
33
34			C !LOCAL VARIABLES:
35			C == Local variables ==
36	jmc	1.5	INTEGER ndiagcount, ndCount
37	jmc	1.2	INTEGER md,ld,nd
38			INTEGER mm, mate, nActiveMax
39			INTEGER j, k, l
40	jmc	1.3	LOGICAL found, addMate2List, inList, regListPb
41	jmc	1.1	CHARACTER*(MAX_LEN_MBUF) msgBuf
42
43
44			_BEGIN_MASTER( myThid)
45
46			C-- Initialize pointer arrays to zero:
47	jmc	1.2	DO ld=1,numlists
48			DO md=1,numperlist
49			iSdiag(md,ld) = 0
50			jSdiag(md,ld) = 0
51			mSdiag(md,ld) = 0
52			ENDDO
53	jmc	1.1	ENDDO
54
55			C-- Calculate pointers for diagnostics set to non-zero frequency
56
57			ndiagcount = 0
58			nActiveMax = 0
59	jmc	1.2	DO ld=1,diagSt_nbLists
60			diagSt_nbActv(ld) = diagSt_nbFlds(ld)
61			DO md=1,diagSt_nbFlds(ld)
62	jmc	1.1
63			found = .FALSE.
64			C Search all possible model diagnostics
65	jmc	1.2	DO nd=1,ndiagt
66			IF ( diagSt_Flds(md,ld).EQ.cdiag(nd) ) THEN
67			CALL DIAGSTATS_SETDIAG(mate,ndiagcount,md,ld,nd,myThid)
68	jmc	1.1	found = .TRUE.
69	jmc	1.2	jSdiag(md,ld) = nd
70	jmc	1.1	ENDIF
71			ENDDO
72			IF ( .NOT.found ) THEN
73	jmc	1.5	CALL DIAGNOSTICS_LIST_CHECK(
74			O ndCount,
75			I ld,md,diagSt_nbFlds,diagSt_Flds,myThid)
76			IF ( ndCount.EQ.0 ) THEN
77			WRITE(msgBuf,'(3A)') 'DIAGSTATS_SET_POINTERS: ',
78	jmc	1.2	& diagSt_Flds(md,ld),' is not a Diagnostic'
79	jmc	1.5	CALL PRINT_ERROR( msgBuf , myThid )
80			ENDIF
81	jmc	1.1	STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
82			ENDIF
83			IF ( found .AND. mate.LE.-1 ) THEN
84			C- add this fields to the active list in case regions are differents:
85			addMate2List = .FALSE.
86	jmc	1.2	DO l=1,ld-1
87	jmc	1.1	inList = .FALSE.
88	jmc	1.2	DO k=1,diagSt_nbActv(l)
89			IF ( diagSt_Flds(k,l).EQ.cdiag(-mate) ) inList=.TRUE.
90	jmc	1.1	ENDDO
91			IF ( inList ) THEN
92			DO j=0,nRegions
93			addMate2List = addMate2List
94	jmc	1.2	& .OR. (diagSt_region(j,l).LT.diagSt_region(j,ld))
95	jmc	1.1	ENDDO
96			ENDIF
97			ENDDO
98			IF ( .NOT.addMate2List ) mate = 0
99			ENDIF
100	jmc	1.2	IF ( found .AND. mate.NE.0 ) THEN
101			mm = diagSt_nbActv(ld) + 1
102			IF ( mm.LE.numperlist ) THEN
103			iSdiag(mm,ld) = SIGN(mSdiag(md,ld),mate)
104			mate = ABS(mate)
105			jSdiag(mm,ld) = mate
106			diagSt_Flds(mm,ld) = cdiag(mate)
107			ENDIF
108			diagSt_nbActv(ld) = mm
109	jmc	1.1	ENDIF
110
111			ENDDO
112	jmc	1.2	nActiveMax = MAX(diagSt_nbActv(ld),nActiveMax)
113	jmc	1.1	ENDDO
114
115			IF ( ndiagcount.LE.diagSt_size .AND.
116			& nActiveMax.LE.numperlist ) THEN
117	jmc	1.6	WRITE(msgBuf,'(A,I8,A)')
118	jmc	1.2	& ' space allocated for all stats-diags:',
119	jmc	1.1	& ndiagcount, ' levels'
120			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
121			& SQUEEZE_RIGHT , myThid)
122			ELSE
123			IF ( ndiagcount.GT.diagSt_size ) THEN
124			WRITE(msgBuf,'(2A)')
125			& 'DIAGSTATS_SET_POINTERS: Not enough space',
126			& ' for all active stats-diags (from data.diagnostics)'
127			CALL PRINT_ERROR( msgBuf , myThid )
128	jmc	1.6	WRITE(msgBuf,'(A,I8,A,I8)')
129	jmc	1.1	& 'DIAGSTATS_SET_POINTERS: diagSt_size=', diagSt_size,
130			& ' but needs at least', ndiagcount
131			CALL PRINT_ERROR( msgBuf , myThid )
132			ENDIF
133			IF ( nActiveMax.GT.numperlist ) THEN
134			WRITE(msgBuf,'(2A)')
135			& 'DIAGSTATS_SET_POINTERS: Not enough space',
136			& ' for all active stats-diags (from data.diagnostics)'
137			CALL PRINT_ERROR( msgBuf , myThid )
138			WRITE(msgBuf,'(A,I6,A,I6)')
139			& 'DIAGSTATS_SET_POINTERS: numperlist=', numperlist,
140			& ' but needs at least', nActiveMax
141			CALL PRINT_ERROR( msgBuf , myThid )
142			ENDIF
143			STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
144			ENDIF
145
146			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
147			C-- Set list of regions to write
148	jmc	1.3	C- check that all selected regions are actually defined
149			regListPb = .FALSE.
150			DO l=1,diagSt_nbLists
151			DO j=1,nRegions
152			IF ( diagSt_region(j,l).NE.0 ) THEN
153			IF ( diagSt_kRegMsk(j).LT.1 .OR.
154	jmc	1.4	& diagSt_kRegMsk(j).GT.nSetRegMask ) THEN
155	jmc	1.6	WRITE(msgBuf,'(A,3(A,I5))') 'DIAGSTATS_SET_POINTERS:',
156	jmc	1.3	& ' region', j, ' undefined (k=', diagSt_kRegMsk(j),
157			& ') in list l=', l
158			CALL PRINT_ERROR( msgBuf , myThid )
159			regListPb = .TRUE.
160			ENDIF
161			ENDIF
162			ENDDO
163			ENDDO
164			IF ( regListPb ) THEN
165			WRITE(msgBuf,'(2A)') 'DIAGSTATS_SET_POINTERS:',
166			& ' Cannot select undefined regions'
167			CALL PRINT_ERROR( msgBuf , myThid )
168			STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
169			ENDIF
170
171			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
172	jmc	1.1
173			WRITE(msgBuf,'(A)') 'DIAGSTATS_SET_POINTERS: done'
174			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
175			& SQUEEZE_RIGHT , myThid)
176			WRITE(msgBuf,'(2A)')
177			& '------------------------------------------------------------'
178			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
179			& SQUEEZE_RIGHT , myThid)
180
181			_END_MASTER( myThid )
182
183			RETURN
184			END