C $Header: /u/gcmpack/MITgcm/pkg/seaice/seaice_write_pickup.F,v 1.23 2014/05/27 15:24:00 mlosch Exp $ C $Name: $ #include "SEAICE_OPTIONS.h" CBOP C !ROUTINE: SEAICE_WRITE_PICKUP C !INTERFACE: SUBROUTINE SEAICE_WRITE_PICKUP ( permPickup, suff, I myTime, myIter, myThid ) C !DESCRIPTION: \bv C *==========================================================* C | SUBROUTINE SEAICE_WRITE_PICKUP C | o Write sea ice pickup file for restarting. C *==========================================================* C \ev C !USES: IMPLICIT NONE C == Global variables === #include "SIZE.h" #include "EEPARAMS.h" #include "PARAMS.h" #include "SEAICE_SIZE.h" #include "SEAICE_PARAMS.h" #include "SEAICE.h" #include "SEAICE_TRACER.h" C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == C permPickup :: write a permanent pickup C suff :: suffix for pickup file (eg. ckptA or 0000000010) C myTime :: Current time in simulation C myIter :: Current iteration number in simulation C myThid :: My Thread Id number LOGICAL permPickup CHARACTER*(*) suff _RL myTime INTEGER myIter INTEGER myThid C !LOCAL VARIABLES: C == Local variables == C fp :: pickup-file precision ( precFloat64 ) C glf :: local flag for "globalFiles" C fn :: Temp. for building file name. C nWrFlds :: number of fields being written C listDim :: dimension of "wrFldList" local array C wrFldList :: list of written fields C j :: loop index / field number C nj :: record number C msgBuf :: Informational/error message buffer INTEGER fp LOGICAL glf _RL timList(1) CHARACTER*(MAX_LEN_FNAM) fn INTEGER listDim, nWrFlds PARAMETER( listDim = 20 ) CHARACTER*(8) wrFldList(listDim) INTEGER j, nj CHARACTER*(MAX_LEN_MBUF) msgBuf #ifdef ALLOW_SITRACER CHARACTER*(8) fldName INTEGER iTrac #endif CEOP C-- Write model fields WRITE(fn,'(A,A)') 'pickup_seaice.',suff c IF ( seaice_pickup_write_mdsio ) THEN fp = precFloat64 j = 0 nj = 0 C record number < 0 : a hack not to write meta files now: C-- write Sea-Ice Thermodynamics State variables, starting with 3-D fields: IF ( .NOT.useThSIce ) THEN #ifdef SEAICE_ITD j = j + 1 CALL WRITE_REC_3D_RL( fn,fp, nITD, TICES, -j, myIter,myThid ) IF (j.LE.listDim) wrFldList(j) = 'siTICES ' j = j + 1 CALL WRITE_REC_3D_RL( fn,fp, nITD, AREAITD, -j, myIter,myThid ) IF (j.LE.listDim) wrFldList(j) = 'siAREAn ' j = j + 1 CALL WRITE_REC_3D_RL( fn,fp, nITD, HEFFITD, -j, myIter,myThid ) IF (j.LE.listDim) wrFldList(j) = 'siHEFFn ' j = j + 1 CALL WRITE_REC_3D_RL( fn,fp, nITD, HSNOWITD,-j, myIter,myThid ) IF (j.LE.listDim) wrFldList(j) = 'siHSNOWn' C- switch to 2-D fields: nj = -j*nITD #else /* SEAICE_ITD */ j = j + 1 nj = nj-1 IF (SEAICE_multDim.GT.1) THEN CALL WRITE_REC_3D_RL(fn,fp,nITD,TICES, nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siTICES ' C- switch to 2-D fields: c nj = nj*nITD nj = nj-nITD+1 ELSE CALL WRITE_REC_LEV_RL( fn, fp, nITD, 1, 1, TICES, I nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siTICE ' ENDIF C--- continue to write 2-D fields: j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, AREA , nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siAREA ' j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, HEFF , nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siHEFF ' j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, HSNOW , nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siHSNOW ' #endif /* SEAICE_ITD */ #ifdef SEAICE_VARIABLE_SALINITY j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, HSALT , nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siHSALT ' #endif #ifdef ALLOW_SITRACER DO iTrac = 1, SItrNumInUse WRITE(fldName,'(A6,I2.2)') 'siTrac', iTrac j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, & SItracer(1-OLx,1-OLy,1,1,iTrac), & nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = fldName ENDDO #endif ENDIF C-- write Sea-Ice Dynamics variables (all 2-D fields): j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, UICE , nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siUICE ' j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, VICE , nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siVICE ' IF ( SEAICEuseBDF2 ) THEN j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, uIceNm1 , nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siUicNm1' j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, vIceNm1 , nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siVicNm1' ENDIF #if (defined(SEAICE_CGRID) && defined(SEAICE_ALLOW_EVP)) IF ( SEAICEuseEVP ) THEN j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, seaice_sigma1, & nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siSigm1 ' j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, seaice_sigma2, & nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siSigm2 ' j = j + 1 nj = nj-1 CALL WRITE_REC_3D_RL( fn, fp, 1, seaice_sigma12, & nj, myIter, myThid ) IF (j.LE.listDim) wrFldList(j) = 'siSigm12' ENDIF #endif /* SEAICE_ALLOW_EVP */ nWrFlds = j IF ( nWrFlds.GT.listDim ) THEN WRITE(msgBuf,'(2A,I5,A)') 'WRITE_SEAICE_PICKUP: ', & 'trying to write ',nWrFlds,' fields' CALL PRINT_ERROR( msgBuf, myThid ) WRITE(msgBuf,'(2A,I5,A)') 'WRITE_SEAICE_PICKUP: ', & 'field-list dimension (listDim=',listDim,') too small' CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R WRITE_SEAICE_PICKUP (list-size Pb)' ENDIF #ifdef ALLOW_MDSIO C uses this specific S/R to write (with more informations) only meta files nj = ABS(nj) glf = globalFiles timList(1) = myTime CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE., & 0, 0, 1, ' ', & nWrFlds, wrFldList, & 1, timList, oneRL, & nj, myIter, myThid ) C #endif /* ALLOW_MDSIO */ C-------------------------- c ENDIF RETURN END