pkg/diagnostics/diagnostics_write_pickup.F

C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_write_pickup.F,v 1.10 2009/08/27 18:00:01 jmc 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 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, sn
      CHARACTER*(MAX_LEN_FNAM) fn

      INTEGER  ILNBLNK
      EXTERNAL ILNBLNK

      INTEGER dUnit, ndId, n, m

#ifdef ALLOW_MNC
      INTEGER i, 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

        IF (diag_pickup_write_mdsio) THEN

          sn = ILNBLNK(suff)

C         Write qdiag()
          WRITE(fn,'(a,a)') 'pickup_qdiag.', suff(1:sn)
          prec = precFloat64
          CALL WRITE_REC_3D_RL( fn, prec, numDiags, qdiag,
     &                          1, myIter, myThid )

C         Write ndiag()
          _BARRIER
          _BEGIN_MASTER( myThid )
          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)
              ndId = ABS(jdiag(m,n))
              WRITE(dUnit,'(I10)') ndiag(ndId,1,1)
            ENDDO
          ENDDO
          CLOSE( dUnit )
          _END_MASTER( myThid )
          _BARRIER
        ENDIF

      ENDIF

#endif /* DIAGNOSTICS_HAS_PICKUP */

      RETURN
      END
1	jmc	1.11	C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_write_pickup.F,v 1.10 2009/08/27 18:00:01 jmc 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	jmc	1.9	C !ROUTINE: DIAGNOSTICS_WRITE_PICKUP
9	edhill	1.1	C !INTERFACE:
10			SUBROUTINE DIAGNOSTICS_WRITE_PICKUP(
11	jmc	1.9	I isPerm,
12			I suff,
13	edhill	1.1	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	edhill	1.5	#ifdef DIAGNOSTICS_HAS_PICKUP
43	edhill	1.1
44			C !LOCAL VARIABLES:
45			C fn :: character buffer for creating filename
46			C prec :: precision of pickup files
47			c INTEGER prec, iChar, lChar, k
48	jmc	1.10	INTEGER prec, lChar, sn
49	edhill	1.1	CHARACTER*(MAX_LEN_FNAM) fn
50
51			INTEGER ILNBLNK
52			EXTERNAL ILNBLNK
53
54	jmc	1.11	INTEGER dUnit, ndId, n, m
55	edhill	1.4
56	edhill	1.2	#ifdef ALLOW_MNC
57	jmc	1.10	INTEGER i, ii
58	edhill	1.2	CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
59			INTEGER CW_DIMS, NLEN
60			PARAMETER ( CW_DIMS = 10 )
61			PARAMETER ( NLEN = 80 )
62			INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
63			CHARACTER*(NLEN) dn(CW_DIMS)
64			CHARACTER*(NLEN) d_cw_name
65			CHARACTER*(NLEN) dn_blnk
66			#endif /* ALLOW_MNC */
67
68	edhill	1.1	CEOP
69
70			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
71
72			IF (diag_pickup_write) THEN
73
74	edhill	1.2	#ifdef ALLOW_MNC
75			IF (diag_pickup_write_mnc) THEN
76			DO i = 1,NLEN
77			dn_blnk(i:i) = ' '
78			ENDDO
79			DO i = 1,MAX_LEN_FNAM
80			diag_mnc_bn(i:i) = ' '
81			ENDDO
82	jmc	1.9
83	edhill	1.8	IF ( isPerm ) THEN
84			WRITE(diag_mnc_bn,'(A)') 'pickup_diagnostics'
85			ELSE
86			ii = ILNBLNK(suff)
87			WRITE(diag_mnc_bn,'(A,A)')
88			& 'pickup_diagnostics.',suff(1:ii)
89			ENDIF
90
91			CALL MNC_CW_SET_UDIM(fn, 0, myThid)
92			IF ( isPerm ) THEN
93			CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, 0, myThid)
94			ELSE
95			CALL MNC_CW_SET_CITER(fn, 2, -1, -1, -1, myThid)
96			ENDIF
97			C Then set the actual unlimited dimension
98			CALL MNC_CW_SET_UDIM(fn, 1, myThid)
99	edhill	1.2
100			C Update the record dimension by writing the iteration number
101	edhill	1.7	CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)
102			CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)
103	edhill	1.4
104			C Write the qdiag() array
105	edhill	1.2	d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
106			DO ii = 1,CW_DIMS
107			dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
108			ENDDO
109			d_cw_name(1:10) = 'diag_state'
110			dn(1)(1:3) = 'Xp1'
111			dim(1) = sNx + 2*OLx
112			ib(1) = OLx + 1
113			ie(1) = OLx + sNx + 1
114			dn(2)(1:3) = 'Yp1'
115			dim(2) = sNy + 2*OLy
116			ib(2) = OLy + 1
117			ie(2) = OLy + sNy + 1
118	edhill	1.4	dn(3)(1:2) = 'Nd'
119	jmc	1.9	dim(3) = numDiags
120	edhill	1.2	ib(3) = 1
121	jmc	1.9	ie(3) = numDiags
122	edhill	1.2	dn(4)(1:1) = 'T'
123			dim(4) = -1
124			ib(4) = 1
125			ie(4) = 1
126	jmc	1.9
127			CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
128	edhill	1.2	& dim, dn, ib, ie, myThid)
129	jmc	1.9	CALL MNC_CW_ADD_VNAME(d_cw_name, d_cw_name,
130	edhill	1.2	& 4,5, myThid)
131			CALL MNC_CW_ADD_VATTR_TEXT(d_cw_name,'description',
132			& 'diagnostics state',myThid)
133	jmc	1.9
134	edhill	1.2	CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
135			& d_cw_name, qdiag, myThid)
136	jmc	1.9
137	edhill	1.2	CALL MNC_CW_DEL_VNAME(d_cw_name, myThid)
138			CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
139	edhill	1.4
140			C Write the ndiag() array
141			d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
142			DO ii = 1,CW_DIMS
143			dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
144			ENDDO
145			d_cw_name(1:10) = 'diag_count'
146			dn(1)(1:2) = 'Nd'
147	jmc	1.9	dim(1) = numDiags
148	edhill	1.4	ib(1) = 1
149	jmc	1.9	ie(1) = numDiags
150	edhill	1.4	dn(2)(1:1) = 'T'
151			dim(2) = -1
152			ib(2) = 1
153			ie(2) = 1
154
155	jmc	1.9	CALL MNC_CW_ADD_GNAME(d_cw_name, 2,
156	edhill	1.4	& dim, dn, ib, ie, myThid)
157	jmc	1.9	CALL MNC_CW_ADD_VNAME(d_cw_name, d_cw_name,
158	edhill	1.4	& 4,5, myThid)
159			CALL MNC_CW_ADD_VATTR_TEXT(d_cw_name,'description',
160			& 'diagnostics state',myThid)
161	jmc	1.9
162	edhill	1.6	CALL MNC_CW_I_W('I',diag_mnc_bn,0,0,
163	edhill	1.4	& d_cw_name, ndiag, myThid)
164	jmc	1.9
165	edhill	1.4	CALL MNC_CW_DEL_VNAME(d_cw_name, myThid)
166			CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
167
168	edhill	1.2	ENDIF
169			#endif
170	jmc	1.9
171	edhill	1.1	IF (diag_pickup_write_mdsio) THEN
172	edhill	1.4
173			sn = ILNBLNK(suff)
174
175			C Write qdiag()
176	jmc	1.10	WRITE(fn,'(a,a)') 'pickup_qdiag.', suff(1:sn)
177	edhill	1.4	prec = precFloat64
178	jmc	1.10	CALL WRITE_REC_3D_RL( fn, prec, numDiags, qdiag,
179			& 1, myIter, myThid )
180	edhill	1.4
181			C Write ndiag()
182	jmc	1.10	_BARRIER
183			_BEGIN_MASTER( myThid )
184	edhill	1.4	WRITE(fn,'(a,a)') 'pickup_ndiag.', suff(1:sn)
185	jmc	1.11	CALL MDSFINDUNIT( dUnit, myThid )
186	edhill	1.4	OPEN( dUnit, file=fn )
187	edhill	1.6	DO n = 1,nlists
188			DO m = 1,nfields(n)
189	jmc	1.11	ndId = ABS(jdiag(m,n))
190			WRITE(dUnit,'(I10)') ndiag(ndId,1,1)
191	edhill	1.6	ENDDO
192	edhill	1.4	ENDDO
193			CLOSE( dUnit )
194			_END_MASTER( myThid )
195	jmc	1.10	_BARRIER
196	edhill	1.1	ENDIF
197
198			ENDIF
199
200	edhill	1.5	#endif /* DIAGNOSTICS_HAS_PICKUP */
201	edhill	1.1
202			RETURN
203			END