C $Header: /u/gcmpack/MITgcm/pkg/gmredi/gmredi_write_pickup.F,v 1.2 2014/03/06 05:00:33 m_bates Exp $ C $Name: $ #include "GMREDI_OPTIONS.h" CBOP C !ROUTINE: GMREDI_WRITE_PICKUP C !INTERFACE: ========================================================== SUBROUTINE GMREDI_WRITE_PICKUP( permPickup, & suff, myTime, myIter, myThid ) C !DESCRIPTION: C Writes current state of passive tracers to a pickup file C !USES: =============================================================== IMPLICIT NONE #include "SIZE.h" #include "EEPARAMS.h" #include "PARAMS.h" #include "GMREDI.h" C !INPUT PARAMETERS: =================================================== C permPickup :: write a permanent pickup C suff :: suffix for pickup file (eg. ckptA or 0000000010) C myTime :: model time C myIter :: time-step number C myThid :: thread number LOGICAL permPickup CHARACTER*(*) suff _RL myTime INTEGER myIter INTEGER myThid C !OUTPUT PARAMETERS: ================================================== C none #ifdef GM_K3D C === Functions ==== INTEGER ILNBLNK EXTERNAL C !LOCAL VARIABLES: ==================================================== C m :: loop index / field number C nm :: record number C fp :: pickup-file precision C glf :: local flag for "globalFiles" C fn :: character buffer for creating filename C nWrFlds :: number of fields being written C listDim :: dimension of "wrFldList" local array C wrFldList :: list of written fields C msgBuf :: Informational/error message buffer INTEGER i,j,k,bi,bj,m,n, nm, fp, lChar LOGICAL glf _RL timList(1) CHARACTER*(MAX_LEN_FNAM) fn INTEGER listDim, nWrFlds PARAMETER( listDim = 2+2*GM_K3D_NModes ) CHARACTER*(8) wrFldList(listDim) CHARACTER*(MAX_LEN_MBUF) msgBuf _RL vec(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy) CHARACTER*(8) fieldname CEOP IF (.NOT. GM_useK3D) RETURN lChar = ILNBLNK(suff) IF ( lChar.EQ.0 ) THEN WRITE(fn,'(2A)') 'pickup_gmredi' ELSE WRITE(fn,'(2A)') 'pickup_gmredi.',suff(1:lChar) ENDIF fp = precFloat64 m = 0 C record number < 0 : a hack not to write meta files now: C Centre mode DO bj=myByLo(myThid),myByHi(myThid) DO bi=myBxLo(myThid),myBxHi(myThid) DO k=1,Nr DO j=1-Oly,sNy+Oly DO i=1-Olx,sNx+Olx vec(i,j,k,bi,bj) = modesC(1,i,j,k,bi,bj) ENDDO ENDDO ENDDO ENDDO ENDDO m = m + 1 CALL WRITE_REC_3D_RL( fn, fp, Nr, & vec, -m, myIter, myThid ) fieldname='mode01C' IF (m.LE.listDim) wrFldList(m) = fieldname C Western Mode DO n=1,GM_K3D_NModes DO bj=myByLo(myThid),myByHi(myThid) DO bi=myBxLo(myThid),myBxHi(myThid) DO k=1,Nr DO j=1-Oly,sNy+Oly DO i=1-Olx,sNx+Olx vec(i,j,k,bi,bj) = modesW(n,i,j,k,bi,bj) ENDDO ENDDO ENDDO ENDDO ENDDO m = m + 1 CALL WRITE_REC_3D_RL( fn, fp, Nr, & vec, -m, myIter, myThid ) WRITE(fieldname, '(A,I2.2,A)') 'mode',n,'W' IF (m.LE.listDim) wrFldList(m) = fieldname ENDDO C Southern Mode DO n=1,GM_K3D_NModes DO bj=myByLo(myThid),myByHi(myThid) DO bi=myBxLo(myThid),myBxHi(myThid) DO k=1,Nr DO j=1-Oly,sNy+Oly DO i=1-Olx,sNx+Olx vec(i,j,k,bi,bj) = modesS(n,i,j,k,bi,bj) ENDDO ENDDO ENDDO ENDDO ENDDO m = m + 1 CALL WRITE_REC_3D_RL( fn, fp, Nr, & vec, -m, myIter, myThid ) WRITE(fieldname, '(A,I2.2,A)') 'mode',n,'S' IF (m.LE.listDim) wrFldList(m) = fieldname ENDDO C-------------------------- C- switch to 2-D fields: nm = -m*Nr C The deformation radius (2D field) m = m + 1 nm = nm-1 CALL WRITE_REC_3D_RL( fn, fp, 1, & Rdef, nm, myIter, myThid ) fieldname = 'Rdef' IF (m.LE.listDim) wrFldList(m) = fieldname nWrFlds = m IF ( nWrFlds.GT.listDim ) THEN WRITE(msgBuf,'(2A,I5,A)') 'GMREDI_WRITE_PICKUP: ', & 'trying to write ',nWrFlds,' fields' CALL PRINT_ERROR( msgBuf, myThid ) WRITE(msgBuf,'(2A,I5,A)') 'GMREDI_WRITE_PICKUP: ', & 'field-list dimension (listDim=',listDim,') too small' CALL PRINT_ERROR( msgBuf, myThid ) CALL ALL_PROC_DIE( myThid ) STOP 'ABNORMAL END: S/R GMREDI_WRITE_PICKUP (list-size Pb)' ENDIF #ifdef ALLOW_MDSIO C uses this specific S/R to write (with more informations) only meta files m = 1 nm = ABS(nm) IF ( nWrFlds*Nr .EQ. nm ) THEN m = Nr nm = nWrFlds ENDIF glf = globalFiles timList(1) = myTime CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE., & 0, 0, m, ' ', & nWrFlds, wrFldList, & 1, timList, oneRL, & nm, myIter, myThid ) #endif /* ALLOW_MDSIO */ C-------------------------- #endif /* GM_K3D */ RETURN END