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

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

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

Revision 1.4 - (hide annotations) (download)
Mon May 16 15:07:45 2005 UTC (19 years ago) by jmc
Branch: MAIN
CVS Tags: checkpoint57i_post, checkpoint57h_done
Changes since 1.3: +8 -2 lines 
move initialization of idiag from _init_early to _set_pointers
1 jmc 1.4 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_set_pointers.F,v 1.3 2004/12/20 01:52:58 jmc Exp $
2 jmc 1.1 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
36     INTEGER m,mm,n
37     INTEGER mate, nActiveMax
38 jmc 1.3 INTEGER l, k, kLev
39 jmc 1.1 LOGICAL found
40     CHARACTER*(MAX_LEN_MBUF) msgBuf
41    
42    
43     _BEGIN_MASTER( myThid)
44    
45 jmc 1.4 C-- Initialize pointer arrays to zero:
46     DO n=1,ndiagMax
47     idiag(n) = 0
48     ENDDO
49    
50     C-- Calculate pointers for diagnostics set to non-zero frequency
51    
52 jmc 1.1 ndiagcount = 0
53     nActiveMax = 0
54     DO n=1,nlists
55     nActive(n) = nfields(n)
56     DO m=1,nfields(n)
57    
58     found = .FALSE.
59     C Search all possible model diagnostics
60     DO mm=1,ndiagt
61     IF ( flds(m,n).EQ.cdiag(mm) ) THEN
62     CALL DIAGNOSTICS_SETDIAG (mate,ndiagcount,mm,myThid)
63     found = .TRUE.
64     jdiag(m,n) = mm
65     ENDIF
66     ENDDO
67     IF ( .NOT.found ) THEN
68     WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
69     & flds(m,n),' is not a Diagnostic'
70     CALL PRINT_ERROR( msgBuf , myThid )
71     STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
72     ENDIF
73     IF ( found .AND. mate.GE.1 ) THEN
74     nActive(n) = nActive(n) + 1
75     IF ( nActive(n).LE.numperlist ) THEN
76     jdiag(nActive(n),n) = mate
77     flds( nActive(n),n) = cdiag(mate)
78     ENDIF
79     ENDIF
80    
81     ENDDO
82     nActiveMax = MAX(nActive(n),nActiveMax)
83     ENDDO
84    
85     IF ( ndiagcount.LE.numdiags .AND.
86     & nActiveMax.LE.numperlist ) THEN
87 jmc 1.2 WRITE(msgBuf,'(A,I6,A)')
88     & ' space allocated for all diagnostics:',
89 jmc 1.1 & ndiagcount, ' levels'
90     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
91 jmc 1.2 & SQUEEZE_RIGHT , myThid)
92 jmc 1.1 ELSE
93     IF ( ndiagcount.GT.numdiags ) THEN
94     WRITE(msgBuf,'(2A)')
95     & 'DIAGNOSTICS_SET_POINTERS: Not enough space',
96     & ' for all active diagnostics (from data.diagnostics)'
97     CALL PRINT_ERROR( msgBuf , myThid )
98     WRITE(msgBuf,'(A,I6,A,I6)')
99     & 'DIAGNOSTICS_SET_POINTERS: numdiags=', numdiags,
100     & ' but needs at least', ndiagcount
101     CALL PRINT_ERROR( msgBuf , myThid )
102     ENDIF
103     IF ( nActiveMax.GT.numperlist ) THEN
104     WRITE(msgBuf,'(2A)')
105     & 'DIAGNOSTICS_SET_POINTERS: Not enough space',
106     & ' for all active diagnostics (from data.diagnostics)'
107     CALL PRINT_ERROR( msgBuf , myThid )
108     WRITE(msgBuf,'(A,I6,A,I6)')
109     & 'DIAGNOSTICS_SET_POINTERS: numperlist=', numperlist,
110     & ' but needs at least', nActiveMax
111     CALL PRINT_ERROR( msgBuf , myThid )
112     ENDIF
113     STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
114     ENDIF
115    
116 jmc 1.3 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
117     C-- Set list of levels to write (if not specified in data.diagnostics)
118    
119     DO n=1,nlists
120     IF ( nlevels(n).EQ.-1 ) THEN
121     C- set Nb of levels to the minimum size of all diag of this list:
122     kLev = numLevels
123     DO m=1,nfields(n)
124     mm = jdiag(m,n)
125     kLev = MIN(kdiag(mm),kLev)
126     ENDDO
127     IF ( kLev.LE.0 ) THEN
128     WRITE(msgBuf,'(2A,I4,2A)')
129     & 'DIAGNOSTICS_SET_POINTERS: kLev < 1 in ',
130     & ' setting levs of list n=',n,', fnames: ', fnames(n)
131     CALL PRINT_ERROR( msgBuf , myThid )
132     STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
133     ENDIF
134     nlevels(n) = kLev
135     DO k=1,kLev
136     levs(k,n) = k
137     ENDDO
138     WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_SET_POINTERS: ',
139     & 'Set levels for Outp.Stream: ',fnames(n)
140     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
141     & SQUEEZE_RIGHT, myThid)
142     DO l=1,nlevels(n),20
143     m = MIN(nlevels(n),l+19)
144     WRITE(msgBuf,'(A,20F5.0)')' Levels: ',(levs(k,n),k=l,m)
145     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
146     & SQUEEZE_RIGHT, myThid)
147     ENDDO
148     ELSE
149     C- Check for levels out of range ( > kdiag)
150     kLev = 0
151     DO k=1,nlevels(n)
152     kLev = MAX(NINT(levs(k,n)),kLev)
153     ENDDO
154     DO m=1,nfields(n)
155     mm = jdiag(m,n)
156     IF ( kLev.GT.kdiag(mm) ) THEN
157     C- Note: diagnostics_out take care (in some way) of this case
158     C so that it does not cause "index out-off bounds" error.
159     C However, the output file looks strange.
160     C- For now, choose to stop, but could change it to just a warning
161     WRITE(msgBuf,'(A,I3,A,I3,2A)')
162     & 'DIAGNOSTICS_SET_POINTERS: Ask for level=',kLev,
163     & ' in list n=', n, ', filename: ', fnames(n)
164     CALL PRINT_ERROR( msgBuf , myThid )
165     WRITE(msgBuf,'(2A,I3,A,I3,2A)')
166     & 'DIAGNOSTICS_SET_POINTERS: ==> exceed Max.Nb of lev.',
167     & '(=',kdiag(mm),') for Diag. #', mm, ' : ',cdiag(mm)
168     CALL PRINT_ERROR( msgBuf , myThid )
169     WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SET_POINTERS: ',
170     & ' parsing code >>',gdiag(mm),'<<'
171     CALL PRINT_ERROR( msgBuf , myThid )
172     STOP 'ABNORMAL END: S/R DIAGNOSTICS_SET_POINTERS'
173     ENDIF
174     ENDDO
175     ENDIF
176     ENDDO
177    
178     WRITE(msgBuf,'(A)') 'DIAGNOSTICS_SET_POINTERS: done'
179     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
180     & SQUEEZE_RIGHT , myThid)
181     WRITE(msgBuf,'(2A)')
182     & '------------------------------------------------------------'
183     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
184     & SQUEEZE_RIGHT , myThid)
185    
186 jmc 1.1 _END_MASTER( myThid )
187    
188     RETURN
189     END
  ViewVC Help
Powered by ViewVC 1.1.22