pkg/diagnostics/diagnostics_write_pickup.F

ee2e7fad64 Ed H*0001 #include "DIAG_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP
e129400813 Jean*0005 C     !ROUTINE: DIAGNOSTICS_WRITE_PICKUP
ee2e7fad64 Ed H*0006 C     !INTERFACE:
                0007       SUBROUTINE DIAGNOSTICS_WRITE_PICKUP(
e129400813 Jean*0008      I     isPerm,
                0009      I     suff,
ee2e7fad64 Ed H*0010      I     myTime,
                0011      I     myIter,
                0012      I     myThid )
                0013
                0014 C     !DESCRIPTION:
                0015 C     Writes current state of the diagnostics package.
                0016
                0017 C     !USES:
                0018       IMPLICIT NONE
                0019
                0020 C     == Global variables ===
                0021 #include "SIZE.h"
                0022 #include "EEPARAMS.h"
                0023 #include "PARAMS.h"
                0024 #include "DIAGNOSTICS_SIZE.h"
                0025 #include "DIAGNOSTICS.h"
                0026
                0027 C     !INPUT/OUTPUT PARAMETERS:
c29c5d093c Ed H*0028 C     isPerm  :: permanent checkpoint flag
ee2e7fad64 Ed H*0029 C     suff    :: suffix for pickup file (eg. ckptA or 0000000010)
                0030 C     myTime  :: current time
                0031 C     myIter  :: time-step number
                0032 C     myThid  :: Number of this instance
c29c5d093c Ed H*0033       LOGICAL isPerm
ee2e7fad64 Ed H*0034       CHARACTER*(*) suff
                0035       _RL myTime
                0036       INTEGER myIter
                0037       INTEGER myThid
                0038
e797dd72d4 Ed H*0039 #ifdef DIAGNOSTICS_HAS_PICKUP
ee2e7fad64 Ed H*0040
                0041 C     !LOCAL VARIABLES:
                0042 C     fn      :: character buffer for creating filename
                0043 C     prec    :: precision of pickup files
                0044 c     INTEGER prec, iChar, lChar, k
9f24b0ff20 Jean*0045       INTEGER prec, lChar, sn
ee2e7fad64 Ed H*0046       CHARACTER*(MAX_LEN_FNAM) fn
                0047
                0048       INTEGER  ILNBLNK
                0049       EXTERNAL ILNBLNK
                0050
b38beaf3c1 Jean*0051       INTEGER dUnit, ndId, n, m
3871a20d99 Ed H*0052
9d4572b365 Ed H*0053 #ifdef ALLOW_MNC
9f24b0ff20 Jean*0054       INTEGER i, ii
9d4572b365 Ed H*0055       CHARACTER*(MAX_LEN_FNAM) diag_mnc_bn
                0056       INTEGER CW_DIMS, NLEN
                0057       PARAMETER ( CW_DIMS = 10 )
                0058       PARAMETER ( NLEN    = 80 )
                0059       INTEGER dim(CW_DIMS), ib(CW_DIMS), ie(CW_DIMS)
                0060       CHARACTER*(NLEN) dn(CW_DIMS)
                0061       CHARACTER*(NLEN) d_cw_name
                0062       CHARACTER*(NLEN) dn_blnk
                0063 #endif /*  ALLOW_MNC  */
                0064
ee2e7fad64 Ed H*0065 CEOP
                0066
                0067 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0068
                0069       IF (diag_pickup_write) THEN
                0070
9d4572b365 Ed H*0071 #ifdef ALLOW_MNC
                0072         IF (diag_pickup_write_mnc) THEN
                0073           DO i = 1,NLEN
                0074             dn_blnk(i:i) = ' '
                0075           ENDDO
                0076           DO i = 1,MAX_LEN_FNAM
                0077             diag_mnc_bn(i:i) = ' '
                0078           ENDDO
e129400813 Jean*0079
c29c5d093c Ed H*0080           IF ( isPerm ) THEN
                0081             WRITE(diag_mnc_bn,'(A)') 'pickup_diagnostics'
                0082           ELSE
                0083             ii = ILNBLNK(suff)
                0084             WRITE(diag_mnc_bn,'(A,A)')
                0085      &           'pickup_diagnostics.',suff(1:ii)
                0086           ENDIF
                0087
                0088           CALL MNC_CW_SET_UDIM(fn, 0, myThid)
                0089           IF ( isPerm ) THEN
                0090             CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, 0, myThid)
                0091           ELSE
                0092             CALL MNC_CW_SET_CITER(fn, 2, -1, -1, -1, myThid)
                0093           ENDIF
                0094 C         Then set the actual unlimited dimension
                0095           CALL MNC_CW_SET_UDIM(fn, 1, myThid)
9d4572b365 Ed H*0096
                0097 C         Update the record dimension by writing the iteration number
987ff12cb6 Ed H*0098           CALL MNC_CW_RL_W_S('D',diag_mnc_bn,0,0,'T',myTime,myThid)
                0099           CALL MNC_CW_I_W_S('I',diag_mnc_bn,0,0,'iter',myIter,myThid)
3871a20d99 Ed H*0100
                0101 C         Write the qdiag() array
9d4572b365 Ed H*0102           d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
                0103           DO ii = 1,CW_DIMS
                0104             dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
                0105           ENDDO
                0106           d_cw_name(1:10) = 'diag_state'
                0107           dn(1)(1:3) = 'Xp1'
                0108           dim(1)     = sNx + 2*OLx
                0109           ib(1)      = OLx + 1
                0110           ie(1)      = OLx + sNx + 1
                0111           dn(2)(1:3) = 'Yp1'
                0112           dim(2)     = sNy + 2*OLy
                0113           ib(2)      = OLy + 1
                0114           ie(2)      = OLy + sNy + 1
3871a20d99 Ed H*0115           dn(3)(1:2) = 'Nd'
e129400813 Jean*0116           dim(3)     = numDiags
9d4572b365 Ed H*0117           ib(3)      = 1
e129400813 Jean*0118           ie(3)      = numDiags
9d4572b365 Ed H*0119           dn(4)(1:1) = 'T'
                0120           dim(4)     = -1
                0121           ib(4)      = 1
                0122           ie(4)      = 1
e129400813 Jean*0123
                0124           CALL MNC_CW_ADD_GNAME(d_cw_name, 4,
9d4572b365 Ed H*0125      &         dim, dn, ib, ie, myThid)
e129400813 Jean*0126           CALL MNC_CW_ADD_VNAME(d_cw_name, d_cw_name,
9d4572b365 Ed H*0127      &         4,5, myThid)
                0128           CALL MNC_CW_ADD_VATTR_TEXT(d_cw_name,'description',
                0129      &         'diagnostics state',myThid)
e129400813 Jean*0130
9d4572b365 Ed H*0131           CALL MNC_CW_RL_W('D',diag_mnc_bn,0,0,
                0132      &         d_cw_name, qdiag, myThid)
e129400813 Jean*0133
9d4572b365 Ed H*0134           CALL MNC_CW_DEL_VNAME(d_cw_name, myThid)
                0135           CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
3871a20d99 Ed H*0136
                0137 C         Write the ndiag() array
                0138           d_cw_name(1:NLEN) = dn_blnk(1:NLEN)
                0139           DO ii = 1,CW_DIMS
                0140             dn(ii)(1:NLEN) = dn_blnk(1:NLEN)
                0141           ENDDO
                0142           d_cw_name(1:10) = 'diag_count'
                0143           dn(1)(1:2) = 'Nd'
e129400813 Jean*0144           dim(1)     = numDiags
3871a20d99 Ed H*0145           ib(1)      = 1
e129400813 Jean*0146           ie(1)      = numDiags
3871a20d99 Ed H*0147           dn(2)(1:1) = 'T'
                0148           dim(2)     = -1
                0149           ib(2)      = 1
                0150           ie(2)      = 1
                0151
e129400813 Jean*0152           CALL MNC_CW_ADD_GNAME(d_cw_name, 2,
3871a20d99 Ed H*0153      &         dim, dn, ib, ie, myThid)
e129400813 Jean*0154           CALL MNC_CW_ADD_VNAME(d_cw_name, d_cw_name,
3871a20d99 Ed H*0155      &         4,5, myThid)
                0156           CALL MNC_CW_ADD_VATTR_TEXT(d_cw_name,'description',
                0157      &         'diagnostics state',myThid)
e129400813 Jean*0158
cd2f74c826 Ed H*0159           CALL MNC_CW_I_W('I',diag_mnc_bn,0,0,
3871a20d99 Ed H*0160      &         d_cw_name, ndiag, myThid)
e129400813 Jean*0161
3871a20d99 Ed H*0162           CALL MNC_CW_DEL_VNAME(d_cw_name, myThid)
                0163           CALL MNC_CW_DEL_GNAME(d_cw_name, myThid)
                0164
9d4572b365 Ed H*0165         ENDIF
                0166 #endif
e129400813 Jean*0167
ee2e7fad64 Ed H*0168         IF (diag_pickup_write_mdsio) THEN
3871a20d99 Ed H*0169
                0170           sn = ILNBLNK(suff)
                0171
                0172 C         Write qdiag()
9f24b0ff20 Jean*0173           WRITE(fn,'(a,a)') 'pickup_qdiag.', suff(1:sn)
3871a20d99 Ed H*0174           prec = precFloat64
9f24b0ff20 Jean*0175           CALL WRITE_REC_3D_RL( fn, prec, numDiags, qdiag,
                0176      &                          1, myIter, myThid )
3871a20d99 Ed H*0177
                0178 C         Write ndiag()
9f24b0ff20 Jean*0179           _BARRIER
                0180           _BEGIN_MASTER( myThid )
3871a20d99 Ed H*0181           WRITE(fn,'(a,a)') 'pickup_ndiag.', suff(1:sn)
b38beaf3c1 Jean*0182           CALL MDSFINDUNIT( dUnit, myThid )
3871a20d99 Ed H*0183           OPEN( dUnit, file=fn )
cd2f74c826 Ed H*0184           DO n = 1,nlists
                0185             DO m = 1,nfields(n)
b38beaf3c1 Jean*0186               ndId = ABS(jdiag(m,n))
                0187               WRITE(dUnit,'(I10)') ndiag(ndId,1,1)
cd2f74c826 Ed H*0188             ENDDO
3871a20d99 Ed H*0189           ENDDO
                0190           CLOSE( dUnit )
                0191           _END_MASTER( myThid )
9f24b0ff20 Jean*0192           _BARRIER
ee2e7fad64 Ed H*0193         ENDIF
                0194
                0195       ENDIF
                0196
e797dd72d4 Ed H*0197 #endif /* DIAGNOSTICS_HAS_PICKUP */
ee2e7fad64 Ed H*0198
                0199       RETURN
                0200       END