pkg/diagnostics/diagstats_set_pointers.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagstats_set_pointers.F,v 1.2 2005/06/26 16:51:49 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
      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
           WRITE(msgBuf,'(3A)') 'DIAGSTATS_SET_POINTERS: ',
     &                     diagSt_Flds(md,ld),' is not a Diagnostic'
           CALL PRINT_ERROR( msgBuf , myThid )
           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,I6,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,I6,A,I6)')
     &    '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.nLevRegMask ) THEN
            WRITE(msgBuf,'(A,3(A,I3))') '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.3	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagstats_set_pointers.F,v 1.2 2005/06/26 16:51:49 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			INTEGER ndiagcount
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.2	WRITE(msgBuf,'(3A)') 'DIAGSTATS_SET_POINTERS: ',
74			& diagSt_Flds(md,ld),' is not a Diagnostic'
75	jmc	1.1	CALL PRINT_ERROR( msgBuf , myThid )
76			STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
77			ENDIF
78			IF ( found .AND. mate.LE.-1 ) THEN
79			C- add this fields to the active list in case regions are differents:
80			addMate2List = .FALSE.
81	jmc	1.2	DO l=1,ld-1
82	jmc	1.1	inList = .FALSE.
83	jmc	1.2	DO k=1,diagSt_nbActv(l)
84			IF ( diagSt_Flds(k,l).EQ.cdiag(-mate) ) inList=.TRUE.
85	jmc	1.1	ENDDO
86			IF ( inList ) THEN
87			DO j=0,nRegions
88			addMate2List = addMate2List
89	jmc	1.2	& .OR. (diagSt_region(j,l).LT.diagSt_region(j,ld))
90	jmc	1.1	ENDDO
91			ENDIF
92			ENDDO
93			IF ( .NOT.addMate2List ) mate = 0
94			ENDIF
95	jmc	1.2	IF ( found .AND. mate.NE.0 ) THEN
96			mm = diagSt_nbActv(ld) + 1
97			IF ( mm.LE.numperlist ) THEN
98			iSdiag(mm,ld) = SIGN(mSdiag(md,ld),mate)
99			mate = ABS(mate)
100			jSdiag(mm,ld) = mate
101			diagSt_Flds(mm,ld) = cdiag(mate)
102			ENDIF
103			diagSt_nbActv(ld) = mm
104	jmc	1.1	ENDIF
105
106			ENDDO
107	jmc	1.2	nActiveMax = MAX(diagSt_nbActv(ld),nActiveMax)
108	jmc	1.1	ENDDO
109
110			IF ( ndiagcount.LE.diagSt_size .AND.
111			& nActiveMax.LE.numperlist ) THEN
112			WRITE(msgBuf,'(A,I6,A)')
113	jmc	1.2	& ' space allocated for all stats-diags:',
114	jmc	1.1	& ndiagcount, ' levels'
115			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
116			& SQUEEZE_RIGHT , myThid)
117			ELSE
118			IF ( ndiagcount.GT.diagSt_size ) THEN
119			WRITE(msgBuf,'(2A)')
120			& 'DIAGSTATS_SET_POINTERS: Not enough space',
121			& ' for all active stats-diags (from data.diagnostics)'
122			CALL PRINT_ERROR( msgBuf , myThid )
123			WRITE(msgBuf,'(A,I6,A,I6)')
124			& 'DIAGSTATS_SET_POINTERS: diagSt_size=', diagSt_size,
125			& ' but needs at least', ndiagcount
126			CALL PRINT_ERROR( msgBuf , myThid )
127			ENDIF
128			IF ( nActiveMax.GT.numperlist ) THEN
129			WRITE(msgBuf,'(2A)')
130			& 'DIAGSTATS_SET_POINTERS: Not enough space',
131			& ' for all active stats-diags (from data.diagnostics)'
132			CALL PRINT_ERROR( msgBuf , myThid )
133			WRITE(msgBuf,'(A,I6,A,I6)')
134			& 'DIAGSTATS_SET_POINTERS: numperlist=', numperlist,
135			& ' but needs at least', nActiveMax
136			CALL PRINT_ERROR( msgBuf , myThid )
137			ENDIF
138			STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
139			ENDIF
140
141			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
142			C-- Set list of regions to write
143	jmc	1.3	C- check that all selected regions are actually defined
144			regListPb = .FALSE.
145			DO l=1,diagSt_nbLists
146			DO j=1,nRegions
147			IF ( diagSt_region(j,l).NE.0 ) THEN
148			IF ( diagSt_kRegMsk(j).LT.1 .OR.
149			& diagSt_kRegMsk(j).GT.nLevRegMask ) THEN
150			WRITE(msgBuf,'(A,3(A,I3))') 'DIAGSTATS_SET_POINTERS:',
151			& ' region', j, ' undefined (k=', diagSt_kRegMsk(j),
152			& ') in list l=', l
153			CALL PRINT_ERROR( msgBuf , myThid )
154			regListPb = .TRUE.
155			ENDIF
156			ENDIF
157			ENDDO
158			ENDDO
159			IF ( regListPb ) THEN
160			WRITE(msgBuf,'(2A)') 'DIAGSTATS_SET_POINTERS:',
161			& ' Cannot select undefined regions'
162			CALL PRINT_ERROR( msgBuf , myThid )
163			STOP 'ABNORMAL END: S/R DIAGSTATS_SET_POINTERS'
164			ENDIF
165
166			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
167	jmc	1.1
168			WRITE(msgBuf,'(A)') 'DIAGSTATS_SET_POINTERS: done'
169			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
170			& SQUEEZE_RIGHT , myThid)
171			WRITE(msgBuf,'(2A)')
172			& '------------------------------------------------------------'
173			CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
174			& SQUEEZE_RIGHT , myThid)
175
176			_END_MASTER( myThid )
177
178			RETURN
179			END