pkg/diagnostics/diagnostics_write_pickup.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_write_pickup.F,v 1.7 2005/05/25 04:03:09 edhill Exp $
C $Name:  $

#include "DIAG_OPTIONS.h"

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: DIAGNOSTICS_WRITE_PICKUP 
C     !INTERFACE:
      SUBROUTINE DIAGNOSTICS_WRITE_PICKUP(
     I     isPerm, 
     I     suff, 
     I     myTime,
     I     myIter,
     I     myThid )

C     !DESCRIPTION:
C     Writes current state of the diagnostics package.

C     !USES:
      IMPLICIT NONE

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

C     !INPUT/OUTPUT PARAMETERS:
C     isPerm  :: permanent checkpoint flag
C     suff    :: suffix for pickup file (eg. ckptA or 0000000010)
C     myTime  :: current time
C     myIter  :: time-step number
C     myThid  :: Number of this instance
      LOGICAL isPerm
      CHARACTER*(*) suff
      _RL myTime
      INTEGER myIter
      INTEGER myThid

#ifdef ALLOW_DIAGNOSTICS
#ifdef DIAGNOSTICS_HAS_PICKUP

C     !LOCAL VARIABLES:
C     fn      :: character buffer for creating filename
C     prec    :: precision of pickup files
c     INTEGER prec, iChar, lChar, k
      INTEGER prec, lChar, i, sn
      CHARACTER*(MAX_LEN_FNAM) fn

      INTEGER  ILNBLNK
      EXTERNAL ILNBLNK

#ifdef ALLOW_MDSIO
      LOGICAL lgf
      INTEGER dUnit, n, m
#endif /* ALLOW_MDSIO */

#ifdef ALLOW_MNC
      INTEGER ii
      CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
      INTEGER CW_DIMS, NLEN
      PARAMETER ( CW_DIMS = 10 )
      PARAMETER ( NLEN    = 80 )
      INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
      CHARACTER*(NLEN) dn(CW_DIMS)
      CHARACTER*(NLEN) d_cw_name
      CHARACTER*(NLEN) dn_blnk
#endif /*  ALLOW_MNC  */

CEOP

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

      IF (diag_pickup_write) THEN

#ifdef ALLOW_MNC
        IF (diag_pickup_write_mnc) THEN
          DO i = 1,NLEN
            dn_blnk(i:i) = ' '
          ENDDO
          DO i = 1,MAX_LEN_FNAM
            diag_mnc_bn(i:i) = ' '
          ENDDO
          
          IF ( isPerm ) THEN
            WRITE(diag_mnc_bn,'(A)') 'pickup_diagnostics'
          ELSE
            ii = ILNBLNK(suff)
            WRITE(diag_mnc_bn,'(A,A)')
     &           'pickup_diagnostics.',suff(1:ii)
          ENDIF

          CALL MNC_CW_SET_UDIM(fn, 0, myThid)
          IF ( isPerm ) THEN
            CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, 0, myThid)
          ELSE
            CALL MNC_CW_SET_CITER(fn, 2, -1, -1, -1, myThid)
          ENDIF
C         Then set the actual unlimited dimension
          CALL MNC_CW_SET_UDIM(fn, 1, myThid)

C         Update the record dimension by writing the iteration number
          CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)
          CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)

C         Write the qdiag() array
          d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
          DO ii = 1,CW_DIMS
            dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
          ENDDO
          d_cw_name(1:10) = 'diag_state'
          dn(1)(1:3) = 'Xp1'
          dim(1)     = sNx + 2*OLx
          ib(1)      = OLx + 1
          ie(1)      = OLx + sNx + 1
          dn(2)(1:3) = 'Yp1'
          dim(2)     = sNy + 2*OLy
          ib(2)      = OLy + 1
          ie(2)      = OLy + sNy + 1
          dn(3)(1:2) = 'Nd'
          dim(3)     = numdiags
          ib(3)      = 1
          ie(3)      = numdiags
          dn(4)(1:1) = 'T'
          dim(4)     = -1
          ib(4)      = 1
          ie(4)      = 1
          
          CALL MNC_CW_ADD_GNAME(d_cw_name, 4, 
     &         dim, dn, ib, ie, myThid)
          CALL MNC_CW_ADD_VNAME(d_cw_name, d_cw_name, 
     &         4,5, myThid)
          CALL MNC_CW_ADD_VATTR_TEXT(d_cw_name,'description',
     &         'diagnostics state',myThid)
          
          CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
     &         d_cw_name, qdiag, myThid)
          
          CALL MNC_CW_DEL_VNAME(d_cw_name, myThid)
          CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)

C         Write the ndiag() array
          d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
          DO ii = 1,CW_DIMS
            dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
          ENDDO
          d_cw_name(1:10) = 'diag_count'
          dn(1)(1:2) = 'Nd'
          dim(1)     = numdiags
          ib(1)      = 1
          ie(1)      = numdiags
          dn(2)(1:1) = 'T'
          dim(2)     = -1
          ib(2)      = 1
          ie(2)      = 1

          CALL MNC_CW_ADD_GNAME(d_cw_name, 2, 
     &         dim, dn, ib, ie, myThid)
          CALL MNC_CW_ADD_VNAME(d_cw_name, d_cw_name, 
     &         4,5, myThid)
          CALL MNC_CW_ADD_VATTR_TEXT(d_cw_name,'description',
     &         'diagnostics state',myThid)
          
          CALL MNC_CW_I_W('I',diag_mnc_bn,0,0,
     &         d_cw_name, ndiag, myThid)
          
          CALL MNC_CW_DEL_VNAME(d_cw_name, myThid)
          CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)


        ENDIF
#endif
        
#ifdef ALLOW_MDSIO
        IF (diag_pickup_write_mdsio) THEN
          _BEGIN_MASTER( myThid )

          sn = ILNBLNK(suff)

C         Write qdiag()
          DO i = 1,80
            fn(i:i) = ' '
          ENDDO
          write(fn,'(a,a)') 'pickup_qdiag.', suff(1:sn)
          prec = precFloat64
          lgf = globalFiles
          CALL MDSWRITEFIELD(fn,prec,lgf,'RL',numdiags,qdiag,
     &         1,myIter,myThid)

C         Write ndiag()
          DO i = 1,80
            fn(i:i) = ' '
          ENDDO
          WRITE(fn,'(a,a)') 'pickup_ndiag.', suff(1:sn)
          CALL MDSFINDUNIT( dUnit, mythid )
          OPEN( dUnit, file=fn )
          DO n = 1,nlists
            DO m = 1,nfields(n)
              WRITE(dUnit,'(I10)') ndiag(jdiag(m,n))
            ENDDO
          ENDDO
          CLOSE( dUnit )
          _END_MASTER( myThid )
        ENDIF
#endif /* ALLOW_MDSIO */

      ENDIF

#endif /* ALLOW_DIAGNOSTICS */
#endif /* DIAGNOSTICS_HAS_PICKUP */

      RETURN
      END
1	edhill	1.8	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_write_pickup.F,v 1.7 2005/05/25 04:03:09 edhill Exp $
2	edhill	1.1	C $Name: $
3
4			#include "DIAG_OPTIONS.h"
5
6			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
7			CBOP
8			C !ROUTINE: DIAGNOSTICS_WRITE_PICKUP
9			C !INTERFACE:
10			SUBROUTINE DIAGNOSTICS_WRITE_PICKUP(
11	edhill	1.8	I isPerm,
12	edhill	1.1	I suff,
13			I myTime,
14			I myIter,
15			I myThid )
16
17			C !DESCRIPTION:
18			C Writes current state of the diagnostics package.
19
20			C !USES:
21			IMPLICIT NONE
22
23			C == Global variables ===
24			#include "SIZE.h"
25			#include "EEPARAMS.h"
26			#include "PARAMS.h"
27			#include "DIAGNOSTICS_SIZE.h"
28			#include "DIAGNOSTICS.h"
29
30			C !INPUT/OUTPUT PARAMETERS:
31	edhill	1.8	C isPerm :: permanent checkpoint flag
32	edhill	1.1	C suff :: suffix for pickup file (eg. ckptA or 0000000010)
33			C myTime :: current time
34			C myIter :: time-step number
35			C myThid :: Number of this instance
36	edhill	1.8	LOGICAL isPerm
37	edhill	1.1	CHARACTER() suff
38			_RL myTime
39			INTEGER myIter
40			INTEGER myThid
41
42			#ifdef ALLOW_DIAGNOSTICS
43	edhill	1.5	#ifdef DIAGNOSTICS_HAS_PICKUP
44	edhill	1.1
45			C !LOCAL VARIABLES:
46			C fn :: character buffer for creating filename
47			C prec :: precision of pickup files
48			c INTEGER prec, iChar, lChar, k
49	edhill	1.4	INTEGER prec, lChar, i, sn
50	edhill	1.1	CHARACTER*(MAX_LEN_FNAM) fn
51
52			INTEGER ILNBLNK
53			EXTERNAL ILNBLNK
54
55	edhill	1.4	#ifdef ALLOW_MDSIO
56			LOGICAL lgf
57	edhill	1.6	INTEGER dUnit, n, m
58	edhill	1.4	#endif /* ALLOW_MDSIO */
59
60	edhill	1.2	#ifdef ALLOW_MNC
61			INTEGER ii
62			CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
63			INTEGER CW_DIMS, NLEN
64			PARAMETER ( CW_DIMS = 10 )
65			PARAMETER ( NLEN = 80 )
66			INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
67			CHARACTER*(NLEN) dn(CW_DIMS)
68			CHARACTER*(NLEN) d_cw_name
69			CHARACTER*(NLEN) dn_blnk
70			#endif /* ALLOW_MNC */
71
72	edhill	1.1	CEOP
73
74			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
75
76			IF (diag_pickup_write) THEN
77
78	edhill	1.2	#ifdef ALLOW_MNC
79			IF (diag_pickup_write_mnc) THEN
80			DO i = 1,NLEN
81			dn_blnk(i:i) = ' '
82			ENDDO
83			DO i = 1,MAX_LEN_FNAM
84			diag_mnc_bn(i:i) = ' '
85			ENDDO
86	edhill	1.8
87			IF ( isPerm ) THEN
88			WRITE(diag_mnc_bn,'(A)') 'pickup_diagnostics'
89			ELSE
90			ii = ILNBLNK(suff)
91			WRITE(diag_mnc_bn,'(A,A)')
92			& 'pickup_diagnostics.',suff(1:ii)
93			ENDIF
94
95			CALL MNC_CW_SET_UDIM(fn, 0, myThid)
96			IF ( isPerm ) THEN
97			CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, 0, myThid)
98			ELSE
99			CALL MNC_CW_SET_CITER(fn, 2, -1, -1, -1, myThid)
100			ENDIF
101			C Then set the actual unlimited dimension
102			CALL MNC_CW_SET_UDIM(fn, 1, myThid)
103	edhill	1.2
104			C Update the record dimension by writing the iteration number
105	edhill	1.7	CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)
106			CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)
107	edhill	1.4
108			C Write the qdiag() array
109	edhill	1.2	d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
110			DO ii = 1,CW_DIMS
111			dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
112			ENDDO
113			d_cw_name(1:10) = 'diag_state'
114			dn(1)(1:3) = 'Xp1'
115			dim(1) = sNx + 2*OLx
116			ib(1) = OLx + 1
117			ie(1) = OLx + sNx + 1
118			dn(2)(1:3) = 'Yp1'
119			dim(2) = sNy + 2*OLy
120			ib(2) = OLy + 1
121			ie(2) = OLy + sNy + 1
122	edhill	1.4	dn(3)(1:2) = 'Nd'
123	edhill	1.2	dim(3) = numdiags
124			ib(3) = 1
125			ie(3) = numdiags
126			dn(4)(1:1) = 'T'
127			dim(4) = -1
128			ib(4) = 1
129			ie(4) = 1
130
131			CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
132			& dim, dn, ib, ie, myThid)
133			CALL MNC_CW_ADD_VNAME(d_cw_name, d_cw_name,
134			& 4,5, myThid)
135			CALL MNC_CW_ADD_VATTR_TEXT(d_cw_name,'description',
136			& 'diagnostics state',myThid)
137
138			CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
139			& d_cw_name, qdiag, myThid)
140
141			CALL MNC_CW_DEL_VNAME(d_cw_name, myThid)
142			CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
143	edhill	1.4
144			C Write the ndiag() array
145			d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
146			DO ii = 1,CW_DIMS
147			dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
148			ENDDO
149			d_cw_name(1:10) = 'diag_count'
150			dn(1)(1:2) = 'Nd'
151			dim(1) = numdiags
152			ib(1) = 1
153			ie(1) = numdiags
154			dn(2)(1:1) = 'T'
155			dim(2) = -1
156			ib(2) = 1
157			ie(2) = 1
158
159			CALL MNC_CW_ADD_GNAME(d_cw_name, 2,
160			& dim, dn, ib, ie, myThid)
161			CALL MNC_CW_ADD_VNAME(d_cw_name, d_cw_name,
162			& 4,5, myThid)
163			CALL MNC_CW_ADD_VATTR_TEXT(d_cw_name,'description',
164			& 'diagnostics state',myThid)
165	edhill	1.2
166	edhill	1.6	CALL MNC_CW_I_W('I',diag_mnc_bn,0,0,
167	edhill	1.4	& d_cw_name, ndiag, myThid)
168
169			CALL MNC_CW_DEL_VNAME(d_cw_name, myThid)
170			CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
171
172
173	edhill	1.2	ENDIF
174			#endif
175
176	edhill	1.4	#ifdef ALLOW_MDSIO
177	edhill	1.1	IF (diag_pickup_write_mdsio) THEN
178	edhill	1.4	_BEGIN_MASTER( myThid )
179
180			sn = ILNBLNK(suff)
181
182			C Write qdiag()
183			DO i = 1,80
184			fn(i:i) = ' '
185			ENDDO
186			write(fn,'(a,a)') 'pickup_qdiag.', suff(1:sn)
187			prec = precFloat64
188			lgf = globalFiles
189	edhill	1.1	CALL MDSWRITEFIELD(fn,prec,lgf,'RL',numdiags,qdiag,
190			& 1,myIter,myThid)
191	edhill	1.4
192			C Write ndiag()
193			DO i = 1,80
194			fn(i:i) = ' '
195			ENDDO
196			WRITE(fn,'(a,a)') 'pickup_ndiag.', suff(1:sn)
197			CALL MDSFINDUNIT( dUnit, mythid )
198			OPEN( dUnit, file=fn )
199	edhill	1.6	DO n = 1,nlists
200			DO m = 1,nfields(n)
201			WRITE(dUnit,'(I10)') ndiag(jdiag(m,n))
202			ENDDO
203	edhill	1.4	ENDDO
204			CLOSE( dUnit )
205			_END_MASTER( myThid )
206	edhill	1.1	ENDIF
207	edhill	1.4	#endif /* ALLOW_MDSIO */
208	edhill	1.1
209			ENDIF
210
211			#endif /* ALLOW_DIAGNOSTICS */
212	edhill	1.5	#endif /* DIAGNOSTICS_HAS_PICKUP */
213	edhill	1.1
214			RETURN
215			END