C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_read_pickup.F,v 1.7 2017/07/23 00:24:18 jmc Exp $ C $Name: $ #include "DIAG_OPTIONS.h" C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| CBOP C !ROUTINE: DIAGNOSTICS_READ_PICKUP C !INTERFACE: SUBROUTINE DIAGNOSTICS_READ_PICKUP( I myThid ) C !DESCRIPTION: C Reads previously saved state for 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 myThid :: Number of this instance 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 bi,bj INTEGER prec, sn CHARACTER*(MAX_LEN_FNAM) fn INTEGER ILNBLNK EXTERNAL 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 */ C Add pickup capability IF (diag_pickup_read) THEN #ifdef ALLOW_MNC IF (diag_pickup_read_mnc) THEN DO i = 1,NLEN dn_blnk(i:i) = ' ' ENDDO DO i = 1,MAX_LEN_FNAM diag_mnc_bn(i:i) = ' ' ENDDO WRITE(diag_mnc_bn,'(A)') 'pickup_diagnostics' C Update the record dimension by writing the iteration number CALL MNC_FILE_CLOSE_ALL_MATCHING(diag_mnc_bn, myThid) CALL MNC_CW_SET_UDIM(diag_mnc_bn, 1, myThid) C Read 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) = 'Zd' 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_RL_R('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 Read 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) C- jmc: get warnings when I compile this S/R because something is not right C in the type or one or more arguments. commented out for now c CALL MNC_CW_RL_R('I',diag_mnc_bn,0,0, c & 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 /* ALLOW_MNC */ IF (diag_pickup_read_mdsio) THEN C Read qdiag() prec = precFloat64 WRITE(fn,'(A,I10.10)') 'pickup_qdiag.', nIter0 CALL READ_REC_3D_RL( fn, prec, & numDiags, qdiag, nIter0, myThid ) C Read ndiag() _BARRIER _BEGIN_MASTER(myThid) C-- jmc: should really write 1 file per tile WRITE(fn,'(A,I10.10)') 'pickup_ndiag.', nIter0 CALL MDSFINDUNIT( dUnit, myThid ) OPEN( dUnit, file=fn ) DO n = 1,nlists DO m = 1,nfields(n) ndId = ABS(jdiag(m,n)) READ(dUnit,'(I10)') ndiag(ndId,1,1) ENDDO ENDDO CLOSE( dUnit ) C- Need to fill-in ndiag for other tiles DO bj=1,nSy DO bi=1,nSx DO n=1,ndiagt ndiag(n,bi,bj) = ndiag(n,1,1) ENDDO ENDDO ENDDO _END_MASTER(myThid) _BARRIER ENDIF ENDIF #endif /* DIAGNOSTICS_HAS_PICKUP */ RETURN END